moved directory src/HOLCF to src/HOL/HOLCF;
added HOLCF theories to src/HOL/IsaMakefile;

--- /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))"
+  by (induct l) simp_all
+
+end

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/HOLCF/IOA/ABP/Packet.thy	Sat Nov 27 16:08:10 2010 -0800
@@ -0,0 +1,22 @@
+(*  Title:      HOLCF/IOA/ABP/Packet.thy
+    Author:     Olaf Müller
+*)
+
+header {* Packets *}
+
+theory Packet
+imports Main
+begin
+
+types
+  'msg packet = "bool * 'msg"
+
+definition
+  hdr :: "'msg packet => bool" where
+  "hdr = fst"
+
+definition
+  msg :: "'msg packet => 'msg" where
+  "msg = snd"
+
+end

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/HOLCF/IOA/ABP/ROOT.ML	Sat Nov 27 16:08:10 2010 -0800
@@ -0,0 +1,7 @@
+(*  Title:      HOLCF/IOA/ABP/ROOT.ML
+    Author:     Olaf Mueller
+
+This is the ROOT file for the Alternating Bit Protocol performed in
+I/O-Automata.
+*)
+use_thys ["Correctness"];

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/HOLCF/IOA/ABP/Read_me	Sat Nov 27 16:08:10 2010 -0800
@@ -0,0 +1,10 @@
+Isabelle Verification of the Alternating Bit Protocol by 
+combining IOA with Model Checking
+
+-------------------------------------------------------------
+
+Correctness.ML contains the proof of the abstraction from unbounded
+channels to finite ones.
+
+Check.ML contains a simple ModelChecker prototype checking Spec against 
+the finite version of the ABP-protocol.

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/HOLCF/IOA/ABP/Receiver.thy	Sat Nov 27 16:08:10 2010 -0800
@@ -0,0 +1,57 @@
+(*  Title:      HOLCF/IOA/ABP/Receiver.thy
+    Author:     Olaf Müller
+*)
+
+header {* The implementation: receiver *}
+
+theory Receiver
+imports IOA Action Lemmas
+begin
+
+types
+  'm receiver_state = "'m list * bool"  -- {* messages, mode *}
+
+definition
+  rq :: "'m receiver_state => 'm list" where
+  "rq = fst"
+
+definition
+  rbit :: "'m receiver_state => bool" where
+  "rbit = snd"
+
+definition
+  receiver_asig :: "'m action signature" where
+  "receiver_asig =
+    (UN pkt. {R_pkt(pkt)},
+    (UN m. {R_msg(m)}) Un (UN b. {S_ack(b)}),
+    {})"
+
+definition
+  receiver_trans :: "('m action, 'm receiver_state)transition set" where
+  "receiver_trans =
+   {tr. let s = fst(tr);
+            t = snd(snd(tr))
+        in
+        case fst(snd(tr))
+        of
+        Next    =>  False |
+        S_msg(m) => False |
+        R_msg(m) => (rq(s) ~= [])  &
+                     m = hd(rq(s))  &
+                     rq(t) = tl(rq(s))   &
+                    rbit(t)=rbit(s)  |
+        S_pkt(pkt) => False |
+        R_pkt(pkt) => if (hdr(pkt) ~= rbit(s))&rq(s)=[] then
+                           rq(t) = (rq(s)@[msg(pkt)]) &rbit(t) = (~rbit(s)) else
+                           rq(t) =rq(s) & rbit(t)=rbit(s)  |
+        S_ack(b) => b = rbit(s)                        &
+                        rq(t) = rq(s)                    &
+                        rbit(t)=rbit(s) |
+        R_ack(b) => False}"
+
+definition
+  receiver_ioa :: "('m action, 'm receiver_state)ioa" where
+  "receiver_ioa =
+   (receiver_asig, {([],False)}, receiver_trans,{},{})"
+
+end

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/HOLCF/IOA/ABP/Sender.thy	Sat Nov 27 16:08:10 2010 -0800
@@ -0,0 +1,55 @@
+(*  Title:      HOLCF/IOA/ABP/Sender.thy
+    Author:     Olaf Müller
+*)
+
+header {* The implementation: sender *}
+
+theory Sender
+imports IOA Action Lemmas
+begin
+
+types
+  'm sender_state = "'m list  *  bool"  -- {* messages, Alternating Bit *}
+
+definition
+  sq :: "'m sender_state => 'm list" where
+  "sq = fst"
+
+definition
+  sbit :: "'m sender_state => bool" where
+  "sbit = snd"
+
+definition
+  sender_asig :: "'m action signature" where
+  "sender_asig = ((UN m. {S_msg(m)}) Un (UN b. {R_ack(b)}),
+                   UN pkt. {S_pkt(pkt)},
+                   {})"
+
+definition
+  sender_trans :: "('m action, 'm sender_state)transition set" where
+  "sender_trans =
+   {tr. let s = fst(tr);
+            t = snd(snd(tr))
+        in case fst(snd(tr))
+        of
+        Next     => if sq(s)=[] then t=s else False |
+        S_msg(m) => sq(t)=sq(s)@[m]   &
+                    sbit(t)=sbit(s)  |
+        R_msg(m) => False |
+        S_pkt(pkt) => sq(s) ~= []  &
+                       hdr(pkt) = sbit(s)      &
+                      msg(pkt) = hd(sq(s))    &
+                      sq(t) = sq(s)           &
+                      sbit(t) = sbit(s) |
+        R_pkt(pkt) => False |
+        S_ack(b)   => False |
+        R_ack(b)   => if b = sbit(s) then
+                       sq(t)=tl(sq(s)) & sbit(t)=(~sbit(s)) else
+                       sq(t)=sq(s) & sbit(t)=sbit(s)}"
+  
+definition
+  sender_ioa :: "('m action, 'm sender_state)ioa" where
+  "sender_ioa =
+   (sender_asig, {([],True)}, sender_trans,{},{})"
+
+end

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/HOLCF/IOA/ABP/Spec.thy	Sat Nov 27 16:08:10 2010 -0800
@@ -0,0 +1,37 @@
+(*  Title:      HOLCF/IOA/ABP/Spec.thy
+    Author:     Olaf Müller
+*)
+
+header {* The specification of reliable transmission *}
+
+theory Spec
+imports IOA Action
+begin
+
+definition
+  spec_sig :: "'m action signature" where
+  sig_def: "spec_sig = (UN m.{S_msg(m)},
+                       UN m.{R_msg(m)} Un {Next},
+                       {})"
+
+definition
+  spec_trans :: "('m action, 'm list)transition set" where
+  trans_def: "spec_trans =
+   {tr. let s = fst(tr);
+            t = snd(snd(tr))
+        in
+        case fst(snd(tr))
+        of
+        Next =>  t=s |            (* Note that there is condition as in Sender *)
+        S_msg(m) => t = s@[m]  |
+        R_msg(m) => s = (m#t)  |
+        S_pkt(pkt) => False |
+        R_pkt(pkt) => False |
+        S_ack(b) => False |
+        R_ack(b) => False}"
+
+definition
+  spec_ioa :: "('m action, 'm list)ioa" where
+  ioa_def: "spec_ioa = (spec_sig, {[]}, spec_trans)"
+
+end

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/HOLCF/IOA/NTP/Abschannel.thy	Sat Nov 27 16:08:10 2010 -0800
@@ -0,0 +1,141 @@
+(*  Title:      HOL/IOA/NTP/Abschannel.thy
+    Author:     Olaf Müller
+*)
+
+header {* The (faulty) transmission channel (both directions) *}
+
+theory Abschannel
+imports IOA Action
+begin
+
+datatype 'a abs_action = S 'a | R 'a
+
+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 multiset)transition set" where
+  "ch_trans =
+    {tr. let s = fst(tr);
+             t = snd(snd(tr))
+         in
+         case fst(snd(tr))
+           of S(b) => t = addm s b |
+              R(b) => count s b ~= 0 & t = delm s b}"
+
+definition
+  ch_ioa :: "('a abs_action, 'a multiset)ioa" where
+  "ch_ioa = (ch_asig, {{|}}, ch_trans,{},{})"
+
+definition
+  rsch_actions :: "'m action => bool abs_action option" where
+  "rsch_actions (akt) =
+          (case akt of
+           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)) |
+           C_m_s =>  None  |
+           C_m_r =>  None |
+           C_r_s =>  None  |
+           C_r_r(m) => None)"
+
+definition
+  srch_actions :: "'m action =>(bool * 'm) abs_action option" where
+  "srch_actions (akt) =
+          (case akt of
+           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 |
+           C_m_s => None |
+           C_m_r => None |
+           C_r_s => None |
+           C_r_r(m) => None)"
+
+definition
+  srch_ioa :: "('m action, 'm packet multiset)ioa" where
+  "srch_ioa = rename ch_ioa srch_actions"
+
+definition
+  rsch_ioa :: "('m action, bool multiset)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_wfair :: "('m action)set set" where
+  "srch_wfair = wfair_of(srch_ioa)"
+definition
+  srch_sfair :: "('m action)set set" where
+  "srch_sfair = sfair_of(srch_ioa)"
+definition
+  rsch_sfair :: "('m action)set set" where
+  "rsch_sfair = sfair_of(rsch_ioa)"
+definition
+  rsch_wfair :: "('m action)set set" where
+  "rsch_wfair = wfair_of(rsch_ioa)"
+
+definition
+  srch_trans :: "('m action, 'm packet multiset)transition set" where
+  "srch_trans = trans_of(srch_ioa)"
+definition
+  rsch_trans :: "('m action, bool multiset)transition set" where
+  "rsch_trans = trans_of(rsch_ioa)"
+
+
+lemmas unfold_renaming =
+  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 srch_trans_def rsch_trans_def ch_trans_def starts_of_def
+  trans_of_def asig_projections
+
+lemma in_srch_asig: 
+     "S_msg(m) ~: actions(srch_asig)        &     
+       R_msg(m) ~: actions(srch_asig)        &     
+       S_pkt(pkt) : actions(srch_asig)    &     
+       R_pkt(pkt) : actions(srch_asig)    &     
+       S_ack(b) ~: actions(srch_asig)     &     
+       R_ack(b) ~: actions(srch_asig)     &     
+       C_m_s ~: actions(srch_asig)           &     
+       C_m_r ~: actions(srch_asig)           &     
+       C_r_s ~: actions(srch_asig)  & C_r_r(m) ~: actions(srch_asig)"
+  by (simp add: unfold_renaming)
+
+lemma in_rsch_asig: 
+      "S_msg(m) ~: actions(rsch_asig)         &  
+       R_msg(m) ~: actions(rsch_asig)         &  
+       S_pkt(pkt) ~: actions(rsch_asig)    &  
+       R_pkt(pkt) ~: actions(rsch_asig)    &  
+       S_ack(b) : actions(rsch_asig)       &  
+       R_ack(b) : actions(rsch_asig)       &  
+       C_m_s ~: actions(rsch_asig)            &  
+       C_m_r ~: actions(rsch_asig)            &  
+       C_r_s ~: actions(rsch_asig)            &  
+       C_r_r(m) ~: actions(rsch_asig)"
+  by (simp add: unfold_renaming)
+
+lemma srch_ioa_thm: "srch_ioa =  
+    (srch_asig, {{|}}, srch_trans,srch_wfair,srch_sfair)"
+apply (simp (no_asm) add: srch_asig_def srch_trans_def asig_of_def trans_of_def wfair_of_def sfair_of_def srch_wfair_def srch_sfair_def)
+apply (simp (no_asm) add: unfold_renaming)
+done
+
+lemma rsch_ioa_thm: "rsch_ioa =  
+     (rsch_asig, {{|}}, rsch_trans,rsch_wfair,rsch_sfair)"
+apply (simp (no_asm) add: rsch_asig_def rsch_trans_def asig_of_def trans_of_def wfair_of_def sfair_of_def rsch_wfair_def rsch_sfair_def)
+apply (simp (no_asm) add: unfold_renaming)
+done
+
+end

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/HOLCF/IOA/NTP/Action.thy	Sat Nov 27 16:08:10 2010 -0800
@@ -0,0 +1,16 @@
+(*  Title:      HOL/IOA/NTP/Action.thy
+    Author:     Tobias Nipkow & Konrad Slind
+*)
+
+header {* The set of all actions of the system *}
+
+theory Action
+imports Packet
+begin
+
+datatype 'm action = S_msg 'm | R_msg 'm
+                   | S_pkt "'m packet" | R_pkt "'m packet"
+                   | S_ack bool | R_ack bool
+                   | C_m_s | C_m_r | C_r_s | C_r_r 'm
+
+end

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/HOLCF/IOA/NTP/Correctness.thy	Sat Nov 27 16:08:10 2010 -0800
@@ -0,0 +1,105 @@
+(*  Title:      HOL/IOA/NTP/Correctness.thy
+    Author:     Tobias Nipkow & Konrad Slind
+*)
+
+header {* The main correctness proof: Impl implements Spec *}
+
+theory Correctness
+imports Impl Spec
+begin
+
+definition
+  hom :: "'m impl_state => 'm list" where
+  "hom s = rq(rec(s)) @ (if rbit(rec s) = sbit(sen s) then sq(sen s)
+                         else tl(sq(sen s)))"
+
+declaration {* fn _ =>
+  (* repeated from Traces.ML *)
+  Classical.map_cs (fn cs => cs delSWrapper "split_all_tac")
+*}
+
+lemmas hom_ioas = Spec.ioa_def Spec.trans_def sender_trans_def receiver_trans_def impl_ioas
+  and impl_asigs = sender_asig_def receiver_asig_def srch_asig_def rsch_asig_def
+
+declare split_paired_All [simp del]
+
+
+text {*
+  A lemma about restricting the action signature of the implementation
+  to that of the specification.
+*}
+
+lemma externals_lemma: 
+ "a:externals(asig_of(Automata.restrict impl_ioa (externals spec_sig))) =  
+  (case a of                   
+      S_msg(m) => True         
+    | R_msg(m) => True         
+    | S_pkt(pkt) => False   
+    | R_pkt(pkt) => False   
+    | S_ack(b) => False     
+    | R_ack(b) => False     
+    | C_m_s => False           
+    | C_m_r => False           
+    | C_r_s => False           
+    | C_r_r(m) => False)"
+ apply (simp (no_asm) add: externals_def restrict_def restrict_asig_def Spec.sig_def asig_projections)
+
+  apply (induct_tac "a")
+  apply (simp_all (no_asm) add: actions_def asig_projections)
+  txt {* 2 *}
+  apply (simp (no_asm) add: impl_ioas)
+  apply (simp (no_asm) add: impl_asigs)
+  apply (simp (no_asm) add: asig_of_par asig_comp_def asig_projections)
+  apply (simp (no_asm) add: "transitions"(1) unfold_renaming)
+  txt {* 1 *}
+  apply (simp (no_asm) add: impl_ioas)
+  apply (simp (no_asm) add: impl_asigs)
+  apply (simp (no_asm) add: asig_of_par asig_comp_def asig_projections)
+  done
+
+lemmas sels = sbit_def sq_def ssending_def rbit_def rq_def rsending_def
+
+
+text {* Proof of correctness *}
+lemma ntp_correct:
+  "is_weak_ref_map hom (Automata.restrict impl_ioa (externals spec_sig)) spec_ioa"
+apply (unfold Spec.ioa_def is_weak_ref_map_def)
+apply (simp (no_asm) cong del: if_weak_cong split del: split_if add: Correctness.hom_def
+  cancel_restrict externals_lemma)
+apply (rule conjI)
+ apply (simp (no_asm) add: hom_ioas)
+ apply (simp (no_asm_simp) add: sels)
+apply (rule allI)+
+apply (rule imp_conj_lemma)
+
+apply (induct_tac "a")
+apply (simp_all (no_asm_simp) add: hom_ioas)
+apply (frule inv4)
+apply force
+
+apply (frule inv4)
+apply (frule inv2)
+apply (erule disjE)
+apply (simp (no_asm_simp))
+apply force
+
+apply (frule inv2)
+apply (erule disjE)
+
+apply (frule inv3)
+apply (case_tac "sq (sen (s))=[]")
+
+apply (simp add: hom_ioas)
+apply (blast dest!: add_leD1 [THEN leD])
+
+apply (case_tac "m = hd (sq (sen (s)))")
+
+apply force
+
+apply simp
+apply (blast dest!: add_leD1 [THEN leD])
+
+apply simp
+done
+
+end

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/HOLCF/IOA/NTP/Impl.thy	Sat Nov 27 16:08:10 2010 -0800
@@ -0,0 +1,356 @@
+(*  Title:      HOL/IOA/NTP/Impl.thy
+    Author:     Tobias Nipkow & Konrad Slind
+*)
+
+header {* The implementation *}
+
+theory Impl
+imports Sender Receiver Abschannel
+begin
+
+types 'm impl_state
+  = "'m sender_state * 'm receiver_state * 'm packet multiset * bool multiset"
+  (*  sender_state   *  receiver_state   *    srch_state      * rsch_state *)
+
+
+definition
+  impl_ioa :: "('m action, 'm impl_state)ioa" where
+  impl_def: "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 multiset" where "srch = fst o snd o snd"
+definition rsch :: "'m impl_state => bool multiset" where "rsch = snd o snd o snd"
+
+definition
+  hdr_sum :: "'m packet multiset => bool => nat" where
+  "hdr_sum M b == countm M (%pkt. hdr(pkt) = b)"
+
+(* Lemma 5.1 *)
+definition
+  "inv1(s) ==
+     (!b. count (rsent(rec s)) b = count (srcvd(sen s)) b + count (rsch s) b)
+   & (!b. count (ssent(sen s)) b
+          = hdr_sum (rrcvd(rec s)) b + hdr_sum (srch s) b)"
+
+(* Lemma 5.2 *)
+definition
+  "inv2(s) ==
+  (rbit(rec(s)) = sbit(sen(s)) &
+   ssending(sen(s)) &
+   count (rsent(rec s)) (~sbit(sen s)) <= count (ssent(sen s)) (~sbit(sen s)) &
+   count (ssent(sen s)) (~sbit(sen s)) <= count (rsent(rec s)) (sbit(sen s)))
+   |
+  (rbit(rec(s)) = (~sbit(sen(s))) &
+   rsending(rec(s)) &
+   count (ssent(sen s)) (~sbit(sen s)) <= count (rsent(rec s)) (sbit(sen s)) &
+   count (rsent(rec s)) (sbit(sen s)) <= count (ssent(sen s)) (sbit(sen s)))"
+
+(* Lemma 5.3 *)
+definition
+  "inv3(s) ==
+   rbit(rec(s)) = sbit(sen(s))
+   --> (!m. sq(sen(s))=[] | m ~= hd(sq(sen(s)))
+        -->  count (rrcvd(rec s)) (sbit(sen(s)),m)
+             + count (srch s) (sbit(sen(s)),m)
+            <= count (rsent(rec s)) (~sbit(sen s)))"
+
+(* Lemma 5.4 *)
+definition "inv4(s) == rbit(rec(s)) = (~sbit(sen(s))) --> sq(sen(s)) ~= []"
+
+
+subsection {* Invariants *}
+
+declare le_SucI [simp]
+
+lemmas impl_ioas =
+  impl_def sender_ioa_def receiver_ioa_def srch_ioa_thm [THEN eq_reflection]
+  rsch_ioa_thm [THEN eq_reflection]
+
+lemmas "transitions" =
+  sender_trans_def receiver_trans_def srch_trans_def rsch_trans_def
+
+
+lemmas [simp] =
+  ioa_triple_proj starts_of_par trans_of_par4 in_sender_asig
+  in_receiver_asig in_srch_asig in_rsch_asig
+
+declare let_weak_cong [cong]
+
+lemma [simp]:
+  "fst(x) = sen(x)"
+  "fst(snd(x)) = rec(x)"
+  "fst(snd(snd(x))) = srch(x)"
+  "snd(snd(snd(x))) = rsch(x)"
+  by (simp_all add: sen_def rec_def srch_def rsch_def)
+
+lemma [simp]:
+  "a:actions(sender_asig)
+  | a:actions(receiver_asig)
+  | a:actions(srch_asig)
+  | a:actions(rsch_asig)"
+  by (induct a) simp_all
+
+declare split_paired_All [simp del]
+
+
+(* Three Simp_sets in different sizes
+----------------------------------------------
+
+1) simpset() does not unfold the transition relations
+2) ss unfolds transition relations
+3) renname_ss unfolds transitions and the abstract channel *)
+
+ML {*
+val ss = @{simpset} addsimps @{thms "transitions"};
+val rename_ss = ss addsimps @{thms unfold_renaming};
+
+val tac     = asm_simp_tac (ss addcongs [@{thm conj_cong}] addsplits [@{thm split_if}])
+val tac_ren = asm_simp_tac (rename_ss addcongs [@{thm conj_cong}] addsplits [@{thm split_if}])
+*}
+
+
+subsubsection {* Invariant 1 *}
+
+lemma raw_inv1: "invariant impl_ioa inv1"
+
+apply (unfold impl_ioas)
+apply (rule invariantI)
+apply (simp add: inv1_def hdr_sum_def srcvd_def ssent_def rsent_def rrcvd_def)
+
+apply (simp (no_asm) del: trans_of_par4 add: imp_conjR inv1_def)
+
+txt {* Split proof in two *}
+apply (rule conjI)
+
+(* First half *)
+apply (simp add: Impl.inv1_def split del: split_if)
+apply (induct_tac a)
+
+apply (tactic "EVERY1[tac, tac, tac, tac]")
+apply (tactic "tac 1")
+apply (tactic "tac_ren 1")
+
+txt {* 5 + 1 *}
+
+apply (tactic "tac 1")
+apply (tactic "tac_ren 1")
+
+txt {* 4 + 1 *}
+apply (tactic {* EVERY1[tac, tac, tac, tac] *})
+
+
+txt {* Now the other half *}
+apply (simp add: Impl.inv1_def split del: split_if)
+apply (induct_tac a)
+apply (tactic "EVERY1 [tac, tac]")
+
+txt {* detour 1 *}
+apply (tactic "tac 1")
+apply (tactic "tac_ren 1")
+apply (rule impI)
+apply (erule conjE)+
+apply (simp (no_asm_simp) add: hdr_sum_def Multiset.count_def Multiset.countm_nonempty_def
+  split add: split_if)
+txt {* detour 2 *}
+apply (tactic "tac 1")
+apply (tactic "tac_ren 1")
+apply (rule impI)
+apply (erule conjE)+
+apply (simp add: Impl.hdr_sum_def Multiset.count_def Multiset.countm_nonempty_def
+  Multiset.delm_nonempty_def split add: split_if)
+apply (rule allI)
+apply (rule conjI)
+apply (rule impI)
+apply hypsubst
+apply (rule pred_suc [THEN iffD1])
+apply (drule less_le_trans)
+apply (cut_tac eq_packet_imp_eq_hdr [unfolded Packet.hdr_def, THEN countm_props])
+apply assumption
+apply assumption
+
+apply (rule countm_done_delm [THEN mp, symmetric])
+apply (rule refl)
+apply (simp (no_asm_simp) add: Multiset.count_def)
+
+apply (rule impI)
+apply (simp add: neg_flip)
+apply hypsubst
+apply (rule countm_spurious_delm)
+apply (simp (no_asm))
+
+apply (tactic "EVERY1 [tac, tac, tac, tac, tac, tac]")
+
+done
+
+
+
+subsubsection {* INVARIANT 2 *}
+
+lemma raw_inv2: "invariant impl_ioa inv2"
+
+  apply (rule invariantI1)
+  txt {* Base case *}
+  apply (simp add: inv2_def receiver_projections sender_projections impl_ioas)
+
+  apply (simp (no_asm_simp) add: impl_ioas split del: split_if)
+  apply (induct_tac "a")
+
+  txt {* 10 cases. First 4 are simple, since state doesn't change *}
+
+  ML_prf {* val tac2 = asm_full_simp_tac (ss addsimps [@{thm inv2_def}]) *}
+
+  txt {* 10 - 7 *}
+  apply (tactic "EVERY1 [tac2,tac2,tac2,tac2]")
+  txt {* 6 *}
+  apply (tactic {* forward_tac [rewrite_rule [@{thm Impl.inv1_def}]
+                               (@{thm raw_inv1} RS @{thm invariantE}) RS conjunct1] 1 *})
+
+  txt {* 6 - 5 *}
+  apply (tactic "EVERY1 [tac2,tac2]")
+
+  txt {* 4 *}
+  apply (tactic {* forward_tac [rewrite_rule [@{thm Impl.inv1_def}]
+                                (@{thm raw_inv1} RS @{thm invariantE}) RS conjunct1] 1 *})
+  apply (tactic "tac2 1")
+
+  txt {* 3 *}
+  apply (tactic {* forward_tac [rewrite_rule [@{thm Impl.inv1_def}]
+    (@{thm raw_inv1} RS @{thm invariantE})] 1 *})
+
+  apply (tactic "tac2 1")
+  apply (tactic {* fold_goals_tac [rewrite_rule [@{thm Packet.hdr_def}]
+    (@{thm Impl.hdr_sum_def})] *})
+  apply arith
+
+  txt {* 2 *}
+  apply (tactic "tac2 1")
+  apply (tactic {* forward_tac [rewrite_rule [@{thm Impl.inv1_def}]
+                               (@{thm raw_inv1} RS @{thm invariantE}) RS conjunct1] 1 *})
+  apply (intro strip)
+  apply (erule conjE)+
+  apply simp
+
+  txt {* 1 *}
+  apply (tactic "tac2 1")
+  apply (tactic {* forward_tac [rewrite_rule [@{thm Impl.inv1_def}]
+                               (@{thm raw_inv1} RS @{thm invariantE}) RS conjunct2] 1 *})
+  apply (intro strip)
+  apply (erule conjE)+
+  apply (tactic {* fold_goals_tac [rewrite_rule [@{thm Packet.hdr_def}] (@{thm Impl.hdr_sum_def})] *})
+  apply simp
+
+  done
+
+
+subsubsection {* INVARIANT 3 *}
+
+lemma raw_inv3: "invariant impl_ioa inv3"
+
+  apply (rule invariantI)
+  txt {* Base case *}
+  apply (simp add: Impl.inv3_def receiver_projections sender_projections impl_ioas)
+
+  apply (simp (no_asm_simp) add: impl_ioas split del: split_if)
+  apply (induct_tac "a")
+
+  ML_prf {* val tac3 = asm_full_simp_tac (ss addsimps [@{thm inv3_def}]) *}
+
+  txt {* 10 - 8 *}
+
+  apply (tactic "EVERY1[tac3,tac3,tac3]")
+
+  apply (tactic "tac_ren 1")
+  apply (intro strip, (erule conjE)+)
+  apply hypsubst
+  apply (erule exE)
+  apply simp
+
+  txt {* 7 *}
+  apply (tactic "tac3 1")
+  apply (tactic "tac_ren 1")
+  apply force
+
+  txt {* 6 - 3 *}
+
+  apply (tactic "EVERY1[tac3,tac3,tac3,tac3]")
+
+  txt {* 2 *}
+  apply (tactic "asm_full_simp_tac ss 1")
+  apply (simp (no_asm) add: inv3_def)
+  apply (intro strip, (erule conjE)+)
+  apply (rule imp_disjL [THEN iffD1])
+  apply (rule impI)
+  apply (tactic {* forward_tac [rewrite_rule [@{thm Impl.inv2_def}]
+    (@{thm raw_inv2} RS @{thm invariantE})] 1 *})
+  apply simp
+  apply (erule conjE)+
+  apply (rule_tac j = "count (ssent (sen s)) (~sbit (sen s))" and
+    k = "count (rsent (rec s)) (sbit (sen s))" in le_trans)
+  apply (tactic {* forward_tac [rewrite_rule [@{thm inv1_def}]
+                                (@{thm raw_inv1} RS @{thm invariantE}) RS conjunct2] 1 *})
+  apply (simp add: hdr_sum_def Multiset.count_def)
+  apply (rule add_le_mono)
+  apply (rule countm_props)
+  apply (simp (no_asm))
+  apply (rule countm_props)
+  apply (simp (no_asm))
+  apply assumption
+
+  txt {* 1 *}
+  apply (tactic "tac3 1")
+  apply (intro strip, (erule conjE)+)
+  apply (rule imp_disjL [THEN iffD1])
+  apply (rule impI)
+  apply (tactic {* forward_tac [rewrite_rule [@{thm Impl.inv2_def}]
+    (@{thm raw_inv2} RS @{thm invariantE})] 1 *})
+  apply simp
+  done
+
+
+subsubsection {* INVARIANT 4 *}
+
+lemma raw_inv4: "invariant impl_ioa inv4"
+
+  apply (rule invariantI)
+  txt {* Base case *}
+  apply (simp add: Impl.inv4_def receiver_projections sender_projections impl_ioas)
+
+  apply (simp (no_asm_simp) add: impl_ioas split del: split_if)
+  apply (induct_tac "a")
+
+  ML_prf {* val tac4 =  asm_full_simp_tac (ss addsimps [@{thm inv4_def}]) *}
+
+  txt {* 10 - 2 *}
+
+  apply (tactic "EVERY1[tac4,tac4,tac4,tac4,tac4,tac4,tac4,tac4,tac4]")
+
+  txt {* 2 b *}
+
+  apply (intro strip, (erule conjE)+)
+  apply (tactic {* forward_tac [rewrite_rule [@{thm Impl.inv2_def}]
+                               (@{thm raw_inv2} RS @{thm invariantE})] 1 *})
+  apply simp
+
+  txt {* 1 *}
+  apply (tactic "tac4 1")
+  apply (intro strip, (erule conjE)+)
+  apply (rule ccontr)
+  apply (tactic {* forward_tac [rewrite_rule [@{thm Impl.inv2_def}]
+                               (@{thm raw_inv2} RS @{thm invariantE})] 1 *})
+  apply (tactic {* forward_tac [rewrite_rule [@{thm Impl.inv3_def}]
+                               (@{thm raw_inv3} RS @{thm invariantE})] 1 *})
+  apply simp
+  apply (erule_tac x = "m" in allE)
+  apply simp
+  done
+
+
+text {* rebind them *}
+
+lemmas inv1 = raw_inv1 [THEN invariantE, unfolded inv1_def]
+  and inv2 = raw_inv2 [THEN invariantE, unfolded inv2_def]
+  and inv3 = raw_inv3 [THEN invariantE, unfolded inv3_def]
+  and inv4 = raw_inv4 [THEN invariantE, unfolded inv4_def]
+
+end

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/HOLCF/IOA/NTP/Lemmas.thy	Sat Nov 27 16:08:10 2010 -0800
@@ -0,0 +1,32 @@
+(*  Title:      HOL/IOA/NTP/Lemmas.thy
+    Author:     Tobias Nipkow & Konrad Slind
+*)
+
+theory Lemmas
+imports Main
+begin
+
+subsubsection {* Logic *}
+
+lemma neg_flip: "(X = (~ Y)) = ((~X) = Y)"
+  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
+
+
+subsection {* Arithmetic *}
+
+lemma pred_suc: "0<x ==> (x - 1 = y) = (x = Suc(y))"
+  by (simp add: diff_Suc split add: nat.split)
+
+lemmas [simp] = hd_append set_lemmas
+
+end

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/HOLCF/IOA/NTP/Multiset.thy	Sat Nov 27 16:08:10 2010 -0800
@@ -0,0 +1,95 @@
+(*  Title:      HOL/IOA/NTP/Multiset.thy
+    Author:     Tobias Nipkow & Konrad Slind
+*)
+
+header {* Axiomatic multisets *}
+
+theory Multiset
+imports Lemmas
+begin
+
+typedecl
+  'a multiset
+
+consts
+
+  "{|}"  :: "'a multiset"                        ("{|}")
+  addm   :: "['a multiset, 'a] => 'a multiset"
+  delm   :: "['a multiset, 'a] => 'a multiset"
+  countm :: "['a multiset, 'a => bool] => nat"
+  count  :: "['a multiset, 'a] => nat"
+
+axioms
+
+delm_empty_def:
+  "delm {|} x = {|}"
+
+delm_nonempty_def:
+  "delm (addm M x) y == (if x=y then M else addm (delm M y) x)"
+
+countm_empty_def:
+   "countm {|} P == 0"
+
+countm_nonempty_def:
+   "countm (addm M x) P == countm M P + (if P x then Suc 0 else 0)"
+
+count_def:
+   "count M x == countm M (%y. y = x)"
+
+"induction":
+   "[| P({|}); !!M x. P(M) ==> P(addm M x) |] ==> P(M)"
+
+lemma count_empty: 
+   "count {|} x = 0"
+  by (simp add: Multiset.count_def Multiset.countm_empty_def)
+
+lemma count_addm_simp: 
+     "count (addm M x) y = (if y=x then Suc(count M y) else count M y)"
+  by (simp add: Multiset.count_def Multiset.countm_nonempty_def)
+
+lemma count_leq_addm: "count M y <= count (addm M x) y"
+  by (simp add: count_addm_simp)
+
+lemma count_delm_simp: 
+     "count (delm M x) y = (if y=x then count M y - 1 else count M y)"
+apply (unfold Multiset.count_def)
+apply (rule_tac M = "M" in Multiset.induction)
+apply (simp (no_asm_simp) add: Multiset.delm_empty_def Multiset.countm_empty_def)
+apply (simp add: Multiset.delm_nonempty_def Multiset.countm_nonempty_def)
+apply safe
+apply simp
+done
+
+lemma countm_props: "!!M. (!x. P(x) --> Q(x)) ==> (countm M P <= countm M Q)"
+apply (rule_tac M = "M" in Multiset.induction)
+ apply (simp (no_asm) add: Multiset.countm_empty_def)
+apply (simp (no_asm) add: Multiset.countm_nonempty_def)
+apply auto
+done
+
+lemma countm_spurious_delm: "!!P. ~P(obj) ==> countm M P = countm (delm M obj) P"
+  apply (rule_tac M = "M" in Multiset.induction)
+  apply (simp (no_asm) add: Multiset.delm_empty_def Multiset.countm_empty_def)
+  apply (simp (no_asm_simp) add: Multiset.countm_nonempty_def Multiset.delm_nonempty_def)
+  done
+
+
+lemma pos_count_imp_pos_countm [rule_format (no_asm)]: "!!P. P(x) ==> 0<count M x --> countm M P > 0"
+  apply (rule_tac M = "M" in Multiset.induction)
+  apply (simp (no_asm) add: Multiset.delm_empty_def Multiset.count_def Multiset.countm_empty_def)
+  apply (simp add: Multiset.count_def Multiset.delm_nonempty_def Multiset.countm_nonempty_def)
+  done
+
+lemma countm_done_delm: 
+   "!!P. P(x) ==> 0<count M x --> countm (delm M x) P = countm M P - 1"
+  apply (rule_tac M = "M" in Multiset.induction)
+  apply (simp (no_asm) add: Multiset.delm_empty_def Multiset.countm_empty_def)
+  apply (simp (no_asm_simp) add: count_addm_simp Multiset.delm_nonempty_def Multiset.countm_nonempty_def pos_count_imp_pos_countm)
+  apply auto
+  done
+
+
+declare count_addm_simp [simp] count_delm_simp [simp]
+  Multiset.countm_empty_def [simp] Multiset.delm_empty_def [simp] count_empty [simp]
+
+end

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/HOLCF/IOA/NTP/Packet.thy	Sat Nov 27 16:08:10 2010 -0800
@@ -0,0 +1,27 @@
+(*  Title:      HOL/IOA/NTP/Packet.thy
+    Author:     Tobias Nipkow & Konrad Slind
+*)
+
+theory Packet
+imports Multiset
+begin
+
+types
+  'msg packet = "bool * 'msg"
+
+definition
+  hdr :: "'msg packet => bool" where
+  "hdr == fst"
+
+definition
+  msg :: "'msg packet => 'msg" where
+  "msg == snd"
+
+
+text {* Instantiation of a tautology? *}
+lemma eq_packet_imp_eq_hdr: "!x. x = packet --> hdr(x) = hdr(packet)"
+  by simp
+
+declare hdr_def [simp] msg_def [simp]
+
+end

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/HOLCF/IOA/NTP/ROOT.ML	Sat Nov 27 16:08:10 2010 -0800
@@ -0,0 +1,9 @@
+(*  Title:      HOLCF/IOA/NTP/ROOT.ML
+    Author:     Tobias Nipkow & Konrad Slind
+
+This is the ROOT file for a network transmission protocol (NTP
+subdirectory), performed in the I/O automata formalization by Olaf
+Mueller.
+*)
+
+use_thys ["Correctness"];

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/HOLCF/IOA/NTP/Read_me	Sat Nov 27 16:08:10 2010 -0800
@@ -0,0 +1,167 @@
+Isabelle Verification of a protocol using IOA.
+
+------------------------------------------------------------------------------
+
+The System.
+
+The system being proved correct is a parallel composition of 4 processes:
+
+    Sender || Schannel || Receiver || Rchannel
+
+Accordingly, the system state is a 4-tuple:
+
+    (Sender_state, Schannel_state, Receiver_state, Rchannel_state)
+
+------------------------------------------------------------------------------
+Packets.
+
+The objects going over the medium from Sender to Receiver are modelled
+with the type
+
+    'm packet = bool * 'm
+
+This expresses that messages (modelled by polymorphic type "'m") are
+sent with a single header bit. Packet fields are accessed by
+
+    hdr<b,m> = b
+    mesg<b,m> = m
+------------------------------------------------------------------------------
+
+The Sender.
+
+The state of the process "Sender" is a 5-tuple:
+
+     1. messages : 'm list        (* sq *)
+     2. sent     : bool multiset  (* ssent *)
+     3. received : bool multiset  (* srcvd *)
+     4. header   : bool           (* sbit *)
+     5. mode     : bool           (* ssending *)
+
+
+The Receiver.
+
+The state of the process "Receiver" is a 5-tuple:
+
+     1. messages    : 'm list              (* rq *)
+     2. replies     : bool multiset        (* rsent *)
+     3. received    : 'm packet multiset   (* rrcvd *)
+     4. header      : bool                 (* rbit *)
+     5. mode        : bool                 (* rsending *)
+
+
+The Channels.
+
+The Sender and Receiver each have a proprietary channel, named
+"Schannel" and "Rchannel" respectively. The messages sent by the Sender
+and Receiver are never lost, but the channels may mix them
+up. Accordingly, multisets are used in modelling the state of the
+channels. The state of "Schannel" is modelled with the following type:
+
+    'm packet multiset
+
+The state of "Rchannel" is modelled with the following type:
+
+    bool multiset
+
+This expresses that replies from the Receiver are just one bit.
+
+Both Channels are instances of an abstract channel, that is modelled with
+the type 
+  
+    'a multiset.
+
+------------------------------------------------------------------------------
+
+The events.
+
+An `execution' of the system is modelled by a sequence of 
+
+    <system_state, action, system_state>
+
+transitions. The actions, or events, of the system are described by the
+following ML-style datatype declaration:
+
+    'm action = S_msg ('m)           (* Rqt for Sender to send mesg      *)
+              | R_msg ('m)           (* Mesg taken from Receiver's queue *)
+              | S_pkt_sr ('m packet) (* Packet arrives in Schannel       *)
+              | R_pkt_sr ('m packet) (* Packet leaves Schannel           *)
+              | S_pkt_rs (bool)      (* Packet arrives in Rchannel       *)
+              | R_pkt_rs (bool)      (* Packet leaves Rchannel           *)
+              | C_m_s                (* Change mode in Sender            *)
+              | C_m_r                (* Change mode in Receiver          *)
+              | C_r_s                (* Change round in Sender           *)
+              | C_r_r ('m)           (* Change round in Receiver         *)
+
+------------------------------------------------------------------------------
+
+The Specification.
+
+The abstract description of system behaviour is given by defining an
+IO/automaton named "Spec". The state of Spec is a message queue,
+modelled as an "'m list". The only actions performed in the abstract
+system are: "S_msg(m)" (putting message "m" at the end of the queue);
+and "R_msg(m)" (taking message "m" from the head of the queue).
+
+
+------------------------------------------------------------------------------
+
+The Verification.
+
+The verification proceeds by showing that a certain mapping ("hom") from
+the concrete system state to the abstract system state is a `weak
+possibilities map` from "Impl" to "Spec". 
+
+
+    hom : (S_state * Sch_state * R_state * Rch_state) -> queue
+
+The verification depends on several system invariants that relate the
+states of the 4 processes. These invariants must hold in all reachable
+states of the system. These invariants are difficult to make sense of;
+however, we attempt to give loose English paraphrases of them.
+
+Invariant 1.
+
+This expresses that no packets from the Receiver to the Sender are
+dropped by Rchannel. The analogous statement for Schannel is also true.
+
+    !b. R.replies b = S.received b + Rch b 
+    /\
+    !pkt. S.sent(hdr(pkt)) = R.received(hdr(b)) + Sch(pkt)
+
+
+Invariant 2.
+
+This expresses a complicated relationship about how many messages are
+sent and header bits.
+
+    R.header = S.header 
+    /\ S.mode = SENDING
+    /\ R.replies (flip S.header) <= S.sent (flip S.header)
+    /\ S.sent (flip S.header) <= R.replies header
+    OR
+    R.header = flip S.header
+    /\ R.mode = SENDING
+    /\ S.sent (flip S.header) <= R.replies S.header
+    /\ R.replies S.header <= S.sent S.header
+
+
+Invariant 3.
+
+The number of incoming messages in the Receiver plus the number of those
+messages in transit (in Schannel) is not greater than the number of
+replies, provided the message isn't current and the header bits agree.
+
+    let mesg = <S.header, m>
+    in
+    R.header = S.header
+    ==>
+    !m. (S.messages = [] \/ m ~= hd S.messages)
+        ==> R.received mesg + Sch mesg <= R.replies (flip S.header)
+
+
+Invariant 4.
+
+If the headers are opposite, then the Sender queue has a message in it.
+
+    R.header = flip S.header ==> S.messages ~= []
+

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/HOLCF/IOA/NTP/Receiver.thy	Sat Nov 27 16:08:10 2010 -0800
@@ -0,0 +1,96 @@
+(*  Title:      HOL/IOA/NTP/Receiver.thy
+    Author:     Tobias Nipkow & Konrad Slind
+*)
+
+header {* The implementation: receiver *}
+
+theory Receiver
+imports IOA Action
+begin
+
+types
+
+'m receiver_state
+= "'m list * bool multiset * 'm packet multiset * bool * bool"
+(* messages  #replies        #received            header mode *)
+
+definition rq :: "'m receiver_state => 'm list" where "rq == fst"
+definition rsent :: "'m receiver_state => bool multiset" where "rsent == fst o snd"
+definition rrcvd :: "'m receiver_state => 'm packet multiset" where "rrcvd == fst o snd o snd"
+definition rbit :: "'m receiver_state => bool" where "rbit == fst o snd o snd o snd"
+definition rsending :: "'m receiver_state => bool" where "rsending == snd o snd o snd o snd"
+
+definition
+  receiver_asig :: "'m action signature" where
+  "receiver_asig =
+   (UN pkt. {R_pkt(pkt)},
+    (UN m. {R_msg(m)}) Un (UN b. {S_ack(b)}),
+    insert C_m_r (UN m. {C_r_r(m)}))"
+
+definition
+  receiver_trans:: "('m action, 'm receiver_state)transition set" where
+"receiver_trans =
+ {tr. let s = fst(tr);
+          t = snd(snd(tr))
+      in
+      case fst(snd(tr))
+      of
+      S_msg(m) => False |
+      R_msg(m) => rq(s) = (m # rq(t))   &
+                  rsent(t)=rsent(s)     &
+                  rrcvd(t)=rrcvd(s)     &
+                  rbit(t)=rbit(s)       &
+                  rsending(t)=rsending(s) |
+      S_pkt(pkt) => False |
+      R_pkt(pkt) => rq(t) = rq(s)                        &
+                       rsent(t) = rsent(s)                  &
+                       rrcvd(t) = addm (rrcvd s) pkt        &
+                       rbit(t) = rbit(s)                    &
+                       rsending(t) = rsending(s) |
+      S_ack(b) => b = rbit(s)                        &
+                     rq(t) = rq(s)                      &
+                     rsent(t) = addm (rsent s) (rbit s) &
+                     rrcvd(t) = rrcvd(s)                &
+                     rbit(t)=rbit(s)                    &
+                     rsending(s)                        &
+                     rsending(t) |
+      R_ack(b) => False |
+      C_m_s => False |
+ C_m_r => count (rsent s) (~rbit s) < countm (rrcvd s) (%y. hdr(y)=rbit(s)) &
+             rq(t) = rq(s)                        &
+             rsent(t)=rsent(s)                    &
+             rrcvd(t)=rrcvd(s)                    &
+             rbit(t)=rbit(s)                      &
+             rsending(s)                          &
+             ~rsending(t) |
+    C_r_s => False |
+ C_r_r(m) => count (rsent s) (rbit s) <= countm (rrcvd s) (%y. hdr(y)=rbit(s)) &
+             count (rsent s) (~rbit s) < count (rrcvd s) (rbit(s),m) &
+             rq(t) = rq(s)@[m]                         &
+             rsent(t)=rsent(s)                         &
+             rrcvd(t)=rrcvd(s)                         &
+             rbit(t) = (~rbit(s))                      &
+             ~rsending(s)                              &
+             rsending(t)}"
+
+definition
+  receiver_ioa  :: "('m action, 'm receiver_state)ioa" where
+  "receiver_ioa =
+    (receiver_asig, {([],{|},{|},False,False)}, receiver_trans,{},{})"
+
+lemma in_receiver_asig:
+  "S_msg(m) ~: actions(receiver_asig)"
+  "R_msg(m) : actions(receiver_asig)"
+  "S_pkt(pkt) ~: actions(receiver_asig)"
+  "R_pkt(pkt) : actions(receiver_asig)"
+  "S_ack(b) : actions(receiver_asig)"
+  "R_ack(b) ~: actions(receiver_asig)"
+  "C_m_s ~: actions(receiver_asig)"
+  "C_m_r : actions(receiver_asig)"
+  "C_r_s ~: actions(receiver_asig)"
+  "C_r_r(m) : actions(receiver_asig)"
+  by (simp_all add: receiver_asig_def actions_def asig_projections)
+
+lemmas receiver_projections = rq_def rsent_def rrcvd_def rbit_def rsending_def
+
+end

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/HOLCF/IOA/NTP/Sender.thy	Sat Nov 27 16:08:10 2010 -0800
@@ -0,0 +1,92 @@
+(*  Title:      HOL/IOA/NTP/Sender.thy
+    Author:     Tobias Nipkow & Konrad Slind
+*)
+
+header {* The implementation: sender *}
+
+theory Sender
+imports IOA Action
+begin
+
+types
+'m sender_state = "'m list * bool multiset * bool multiset * bool * bool"
+(*                messages   #sent           #received      header  mode *)
+
+definition sq :: "'m sender_state => 'm list" where "sq = fst"
+definition ssent :: "'m sender_state => bool multiset" where "ssent = fst o snd"
+definition srcvd :: "'m sender_state => bool multiset" where "srcvd = fst o snd o snd"
+definition sbit :: "'m sender_state => bool" where "sbit = fst o snd o snd o snd"
+definition ssending :: "'m sender_state => bool" where "ssending = snd o snd o snd o snd"
+
+definition
+  sender_asig :: "'m action signature" where
+  "sender_asig = ((UN m. {S_msg(m)}) Un (UN b. {R_ack(b)}),
+                   UN pkt. {S_pkt(pkt)},
+                   {C_m_s,C_r_s})"
+
+definition
+  sender_trans :: "('m action, 'm sender_state)transition set" where
+  "sender_trans =
+ {tr. let s = fst(tr);
+          t = snd(snd(tr))
+      in case fst(snd(tr))
+      of
+      S_msg(m) => sq(t)=sq(s)@[m]   &
+                  ssent(t)=ssent(s) &
+                  srcvd(t)=srcvd(s) &
+                  sbit(t)=sbit(s)   &
+                  ssending(t)=ssending(s) |
+      R_msg(m) => False |
+      S_pkt(pkt) => hdr(pkt) = sbit(s)      &
+                       (? Q. sq(s) = (msg(pkt)#Q))  &
+                       sq(t) = sq(s)           &
+                       ssent(t) = addm (ssent s) (sbit s) &
+                       srcvd(t) = srcvd(s) &
+                       sbit(t) = sbit(s)   &
+                       ssending(s)         &
+                       ssending(t) |
+    R_pkt(pkt) => False |
+    S_ack(b)   => False |
+      R_ack(b) => sq(t)=sq(s)                  &
+                     ssent(t)=ssent(s)            &
+                     srcvd(t) = addm (srcvd s) b  &
+                     sbit(t)=sbit(s)              &
+                     ssending(t)=ssending(s) |
+      C_m_s => count (ssent s) (~sbit s) < count (srcvd s) (~sbit s) &
+               sq(t)=sq(s)       &
+               ssent(t)=ssent(s) &
+               srcvd(t)=srcvd(s) &
+               sbit(t)=sbit(s)   &
+               ssending(s)       &
+               ~ssending(t) |
+      C_m_r => False |
+      C_r_s => count (ssent s) (sbit s) <= count (srcvd s) (~sbit s) &
+               sq(t)=tl(sq(s))      &
+               ssent(t)=ssent(s)    &
+               srcvd(t)=srcvd(s)    &
+               sbit(t) = (~sbit(s)) &
+               ~ssending(s)         &
+               ssending(t) |
+      C_r_r(m) => False}"
+
+definition
+  sender_ioa :: "('m action, 'm sender_state)ioa" where
+  "sender_ioa =
+   (sender_asig, {([],{|},{|},False,True)}, sender_trans,{},{})"
+
+lemma in_sender_asig: 
+  "S_msg(m) : actions(sender_asig)"
+  "R_msg(m) ~: actions(sender_asig)"
+  "S_pkt(pkt) : actions(sender_asig)"
+  "R_pkt(pkt) ~: actions(sender_asig)"
+  "S_ack(b) ~: actions(sender_asig)"
+  "R_ack(b) : actions(sender_asig)"
+  "C_m_s : actions(sender_asig)"
+  "C_m_r ~: actions(sender_asig)"
+  "C_r_s : actions(sender_asig)"
+  "C_r_r(m) ~: actions(sender_asig)"
+  by (simp_all add: sender_asig_def actions_def asig_projections)
+
+lemmas sender_projections = sq_def ssent_def srcvd_def sbit_def ssending_def
+
+end

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/HOLCF/IOA/NTP/Spec.thy	Sat Nov 27 16:08:10 2010 -0800
@@ -0,0 +1,40 @@
+(*  Title:      HOL/IOA/NTP/Spec.thy
+    Author:     Tobias Nipkow & Konrad Slind
+*)
+
+header {* The specification of reliable transmission *}
+
+theory Spec
+imports IOA Action
+begin
+
+definition
+  spec_sig :: "'m action signature" where
+  sig_def: "spec_sig = (UN m.{S_msg(m)}, 
+                        UN m.{R_msg(m)}, 
+                        {})"
+
+definition
+  spec_trans :: "('m action, 'm list)transition set" where
+  trans_def: "spec_trans =
+   {tr. let s = fst(tr);                            
+            t = snd(snd(tr))                        
+        in                                          
+        case fst(snd(tr))                           
+        of                                          
+        S_msg(m) => t = s@[m]  |                    
+        R_msg(m) => s = (m#t)  |                    
+        S_pkt(pkt) => False |                    
+        R_pkt(pkt) => False |                    
+        S_ack(b) => False |                      
+        R_ack(b) => False |                      
+        C_m_s => False |                            
+        C_m_r => False |                            
+        C_r_s => False |                            
+        C_r_r(m) => False}"
+
+definition
+  spec_ioa :: "('m action, 'm list)ioa" where
+  ioa_def: "spec_ioa = (spec_sig, {[]}, spec_trans,{},{})"
+
+end

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/HOLCF/IOA/README.html	Sat Nov 27 16:08:10 2010 -0800
@@ -0,0 +1,24 @@
+<!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/IOA/README</TITLE>
+</HEAD>
+
+<BODY>
+
+<H3>IOA: A formalization of I/O automata in HOLCF</H3>
+
+Author:     Olaf M&uuml;ller<BR>
+Copyright   1997 Technische Universit&auml;t M&uuml;nchen<P>
+
+The distribution contains simulation relations, temporal logic, and an abstraction theory.
+Everything is based upon a domain-theoretic model of finite and infinite sequences. 
+<p>
+For details see the <A HREF="http://www4.informatik.tu-muenchen.de/~isabelle/IOA/">IOA project</a>.
+
+</BODY></HTML>
+
+

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/HOLCF/IOA/ROOT.ML	Sat Nov 27 16:08:10 2010 -0800
@@ -0,0 +1,8 @@
+(*  Title:      HOLCF/IOA/ROOT.ML
+    Author:     Olaf Mueller
+
+Formalization of a semantic model of I/O-Automata.  See README.html
+for details.
+*)
+
+use_thys ["meta_theory/Abstraction"];

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/HOLCF/IOA/Storage/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 Main
+begin
+
+datatype action = New  | Loc nat | Free nat
+
+lemma [cong]: "!!x. x = y ==> action_case a b c x = action_case a b c y"
+  by simp
+
+end

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/HOLCF/IOA/Storage/Correctness.thy	Sat Nov 27 16:08:10 2010 -0800
@@ -0,0 +1,75 @@
+(*  Title:      HOL/IOA/example/Correctness.thy
+    Author:     Olaf Müller
+*)
+
+header {* Correctness Proof *}
+
+theory Correctness
+imports SimCorrectness Spec Impl
+begin
+
+default_sort type
+
+definition
+  sim_relation :: "((nat * bool) * (nat set * bool)) set" where
+  "sim_relation = {qua. let c = fst qua; a = snd qua ;
+                            k = fst c;   b = snd c;
+                            used = fst a; c = snd a
+                        in
+                        (! l:used. l < k) & b=c}"
+
+declare split_paired_Ex [simp del]
+
+
+(* Idea: instead of impl_con_lemma do not rewrite impl_ioa, but derive
+         simple lemmas asig_of impl_ioa = impl_sig, trans_of impl_ioa = impl_trans
+   Idea: ?ex. move .. should be generally replaced by a step via a subst tac if desired,
+         as this can be done globally *)
+
+lemma issimulation:
+      "is_simulation sim_relation impl_ioa spec_ioa"
+apply (simp (no_asm) add: is_simulation_def)
+apply (rule conjI)
+txt {* start states *}
+apply (auto)[1]
+apply (rule_tac x = " ({},False) " in exI)
+apply (simp add: sim_relation_def starts_of_def spec_ioa_def impl_ioa_def)
+txt {* main-part *}
+apply (rule allI)+
+apply (rule imp_conj_lemma)
+apply (rename_tac k b used c k' b' a)
+apply (induct_tac "a")
+apply (simp_all (no_asm) add: sim_relation_def impl_ioa_def impl_trans_def trans_of_def)
+apply auto
+txt {* NEW *}
+apply (rule_tac x = "(used,True)" in exI)
+apply simp
+apply (rule transition_is_ex)
+apply (simp (no_asm) add: spec_ioa_def spec_trans_def trans_of_def)
+txt {* LOC *}
+apply (rule_tac x = " (used Un {k},False) " in exI)
+apply (simp add: less_SucI)
+apply (rule transition_is_ex)
+apply (simp (no_asm) add: spec_ioa_def spec_trans_def trans_of_def)
+apply fast
+txt {* FREE *}
+apply (rule_tac x = " (used - {nat},c) " in exI)
+apply simp
+apply (rule transition_is_ex)
+apply (simp (no_asm) add: spec_ioa_def spec_trans_def trans_of_def)
+done
+
+
+lemma implementation:
+"impl_ioa =<| spec_ioa"
+apply (unfold ioa_implements_def)
+apply (rule conjI)
+apply (simp (no_asm) add: impl_sig_def spec_sig_def impl_ioa_def spec_ioa_def
+  asig_outputs_def asig_of_def asig_inputs_def)
+apply (rule trace_inclusion_for_simulations)
+apply (simp (no_asm) add: impl_sig_def spec_sig_def impl_ioa_def spec_ioa_def
+  externals_def asig_outputs_def asig_of_def asig_inputs_def)
+apply (rule issimulation)
+done
+
+end

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/HOLCF/IOA/Storage/Impl.thy	Sat Nov 27 16:08:10 2010 -0800
@@ -0,0 +1,39 @@
+(*  Title:      HOL/IOA/example/Spec.thy
+    Author:     Olaf Müller
+*)
+
+header {* The implementation of a memory *}
+
+theory Impl
+imports IOA Action
+begin
+
+definition
+  impl_sig :: "action signature" where
+  "impl_sig = (UN l.{Free l} Un {New},
+               UN l.{Loc l},
+               {})"
+
+definition
+  impl_trans :: "(action, nat  * bool)transition set" where
+  "impl_trans =
+    {tr. let s = fst(tr); k = fst s; b = snd s;
+             t = snd(snd(tr)); k' = fst t; b' = snd t
+         in
+         case fst(snd(tr))
+         of
+         New       => k' = k & b'  |
+         Loc l     => b & l= k & k'= (Suc k) & ~b' |
+         Free l    => k'=k & b'=b}"
+
+definition
+  impl_ioa :: "(action, nat * bool)ioa" where
+  "impl_ioa = (impl_sig, {(0,False)}, impl_trans,{},{})"
+
+lemma in_impl_asig:
+  "New : actions(impl_sig) &
+    Loc l : actions(impl_sig) &
+    Free l : actions(impl_sig) "
+  by (simp add: impl_sig_def actions_def asig_projections)
+
+end

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/HOLCF/IOA/Storage/ROOT.ML	Sat Nov 27 16:08:10 2010 -0800
@@ -0,0 +1,6 @@
+(*  Title:      HOLCF/IOA/Storage/ROOT.ML
+    Author:     Olaf Mueller
+
+Memory storage case study.
+*)
+use_thys ["Correctness"];

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/HOLCF/IOA/Storage/Spec.thy	Sat Nov 27 16:08:10 2010 -0800
@@ -0,0 +1,33 @@
+(*  Title:      HOL/IOA/example/Spec.thy
+    Author:     Olaf Müller
+*)
+
+header {* The specification of a memory *}
+
+theory Spec
+imports IOA Action
+begin
+
+definition
+  spec_sig :: "action signature" where
+  "spec_sig = (UN l.{Free l} Un {New},
+               UN l.{Loc l},
+               {})"
+
+definition
+  spec_trans :: "(action, nat set * bool)transition set" where
+  "spec_trans =
+   {tr. let s = fst(tr); used = fst s; c = snd s;
+            t = snd(snd(tr)); used' = fst t; c' = snd t
+        in
+        case fst(snd(tr))
+        of
+        New       => used' = used & c'  |
+        Loc l     => c & l~:used  & used'= used Un {l} & ~c'   |
+        Free l    => used'=used - {l} & c'=c}"
+
+definition
+  spec_ioa :: "(action, nat set * bool)ioa" where
+  "spec_ioa = (spec_sig, {({},False)}, spec_trans,{},{})"
+
+end

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/HOLCF/IOA/ex/ROOT.ML	Sat Nov 27 16:08:10 2010 -0800
@@ -0,0 +1,5 @@
+(*  Title:      HOLCF/IOA/ex/ROOT.ML
+    Author:     Olaf Mueller
+*)
+
+use_thys ["TrivEx", "TrivEx2"];

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/HOLCF/IOA/ex/TrivEx.thy	Sat Nov 27 16:08:10 2010 -0800
@@ -0,0 +1,72 @@
+(*  Title:      HOLCF/IOA/TrivEx.thy
+    Author:     Olaf Müller
+*)
+
+header {* Trivial Abstraction Example *}
+
+theory TrivEx
+imports Abstraction
+begin
+
+datatype action = INC
+
+definition
+  C_asig :: "action signature" where
+  "C_asig = ({},{INC},{})"
+definition
+  C_trans :: "(action, nat)transition set" where
+  "C_trans =
+   {tr. let s = fst(tr);
+            t = snd(snd(tr))
+        in case fst(snd(tr))
+        of
+        INC       => t = Suc(s)}"
+definition
+  C_ioa :: "(action, nat)ioa" where
+  "C_ioa = (C_asig, {0}, C_trans,{},{})"
+
+definition
+  A_asig :: "action signature" where
+  "A_asig = ({},{INC},{})"
+definition
+  A_trans :: "(action, bool)transition set" where
+  "A_trans =
+   {tr. let s = fst(tr);
+            t = snd(snd(tr))
+        in case fst(snd(tr))
+        of
+        INC       => t = True}"
+definition
+  A_ioa :: "(action, bool)ioa" where
+  "A_ioa = (A_asig, {False}, A_trans,{},{})"
+
+definition
+  h_abs :: "nat => bool" where
+  "h_abs n = (n~=0)"
+
+axiomatization where
+  MC_result: "validIOA A_ioa (<>[] <%(b,a,c). b>)"
+
+lemma h_abs_is_abstraction:
+  "is_abstraction h_abs C_ioa A_ioa"
+apply (unfold is_abstraction_def)
+apply (rule conjI)
+txt {* start states *}
+apply (simp (no_asm) add: h_abs_def starts_of_def C_ioa_def A_ioa_def)
+txt {* step case *}
+apply (rule allI)+
+apply (rule imp_conj_lemma)
+apply (simp (no_asm) add: trans_of_def C_ioa_def A_ioa_def C_trans_def A_trans_def)
+apply (induct_tac "a")
+apply (simp add: h_abs_def)
+done
+
+lemma TrivEx_abstraction: "validIOA C_ioa (<>[] <%(n,a,m). n~=0>)"
+apply (rule AbsRuleT1)
+apply (rule h_abs_is_abstraction)
+apply (rule MC_result)
+apply abstraction
+apply (simp add: h_abs_def)
+done
+
+end

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/HOLCF/IOA/ex/TrivEx2.thy	Sat Nov 27 16:08:10 2010 -0800
@@ -0,0 +1,102 @@
+(*  Title:      HOLCF/IOA/TrivEx.thy
+    Author:     Olaf Müller
+*)
+
+header {* Trivial Abstraction Example with fairness *}
+
+theory TrivEx2
+imports IOA Abstraction
+begin
+
+datatype action = INC
+
+definition
+  C_asig :: "action signature" where
+  "C_asig = ({},{INC},{})"
+definition
+  C_trans :: "(action, nat)transition set" where
+  "C_trans =
+   {tr. let s = fst(tr);
+            t = snd(snd(tr))
+        in case fst(snd(tr))
+        of
+        INC       => t = Suc(s)}"
+definition
+  C_ioa :: "(action, nat)ioa" where
+  "C_ioa = (C_asig, {0}, C_trans,{},{})"
+definition
+  C_live_ioa :: "(action, nat)live_ioa" where
+  "C_live_ioa = (C_ioa, WF C_ioa {INC})"
+
+definition
+  A_asig :: "action signature" where
+  "A_asig = ({},{INC},{})"
+definition
+  A_trans :: "(action, bool)transition set" where
+  "A_trans =
+   {tr. let s = fst(tr);
+            t = snd(snd(tr))
+        in case fst(snd(tr))
+        of
+        INC       => t = True}"
+definition
+  A_ioa :: "(action, bool)ioa" where
+  "A_ioa = (A_asig, {False}, A_trans,{},{})"
+definition
+  A_live_ioa :: "(action, bool)live_ioa" where
+  "A_live_ioa = (A_ioa, WF A_ioa {INC})"
+
+definition
+  h_abs :: "nat => bool" where
+  "h_abs n = (n~=0)"
+
+axiomatization where
+  MC_result: "validLIOA (A_ioa,WF A_ioa {INC}) (<>[] <%(b,a,c). b>)"
+
+
+lemma h_abs_is_abstraction:
+"is_abstraction h_abs C_ioa A_ioa"
+apply (unfold is_abstraction_def)
+apply (rule conjI)
+txt {* start states *}
+apply (simp (no_asm) add: h_abs_def starts_of_def C_ioa_def A_ioa_def)
+txt {* step case *}
+apply (rule allI)+
+apply (rule imp_conj_lemma)
+apply (simp (no_asm) add: trans_of_def C_ioa_def A_ioa_def C_trans_def A_trans_def)
+apply (induct_tac "a")
+apply (simp (no_asm) add: h_abs_def)
+done
+
+
+lemma Enabled_implication:
+    "!!s. Enabled A_ioa {INC} (h_abs s) ==> Enabled C_ioa {INC} s"
+  apply (unfold Enabled_def enabled_def h_abs_def A_ioa_def C_ioa_def A_trans_def
+    C_trans_def trans_of_def)
+  apply auto
+  done
+
+
+lemma h_abs_is_liveabstraction:
+"is_live_abstraction h_abs (C_ioa, WF C_ioa {INC}) (A_ioa, WF A_ioa {INC})"
+apply (unfold is_live_abstraction_def)
+apply auto
+txt {* is_abstraction *}
+apply (rule h_abs_is_abstraction)
+txt {* temp_weakening *}
+apply abstraction
+apply (erule Enabled_implication)
+done
+
+
+lemma TrivEx2_abstraction:
+  "validLIOA C_live_ioa (<>[] <%(n,a,m). n~=0>)"
+apply (unfold C_live_ioa_def)
+apply (rule AbsRuleT2)
+apply (rule h_abs_is_liveabstraction)
+apply (rule MC_result)
+apply abstraction
+apply (simp add: h_abs_def)
+done
+
+end

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/HOLCF/IOA/meta_theory/Abstraction.thy	Sat Nov 27 16:08:10 2010 -0800
@@ -0,0 +1,615 @@
+(*  Title:      HOLCF/IOA/meta_theory/Abstraction.thy
+    Author:     Olaf Müller
+*)
+
+header {* Abstraction Theory -- tailored for I/O automata *}
+
+theory Abstraction
+imports LiveIOA
+begin
+
+default_sort type
+
+definition
+  cex_abs :: "('s1 => 's2) => ('a,'s1)execution => ('a,'s2)execution" where
+  "cex_abs f ex = (f (fst ex), Map (%(a,t). (a,f t))$(snd ex))"
+definition
+  -- {* equals cex_abs on Sequences -- after ex2seq application *}
+  cex_absSeq :: "('s1 => 's2) => ('a option,'s1)transition Seq => ('a option,'s2)transition Seq" where
+  "cex_absSeq f = (%s. Map (%(s,a,t). (f s,a,f t))$s)"
+
+definition
+  is_abstraction ::"[('s1=>'s2),('a,'s1)ioa,('a,'s2)ioa] => bool" where
+  "is_abstraction f C A =
+   ((!s:starts_of(C). f(s):starts_of(A)) &
+   (!s t a. reachable C s & s -a--C-> t
+            --> (f s) -a--A-> (f t)))"
+
+definition
+  weakeningIOA :: "('a,'s2)ioa => ('a,'s1)ioa => ('s1 => 's2) => bool" where
+  "weakeningIOA A C h = (!ex. ex : executions C --> cex_abs h ex : executions A)"
+definition
+  temp_strengthening :: "('a,'s2)ioa_temp => ('a,'s1)ioa_temp => ('s1 => 's2) => bool" where
+  "temp_strengthening Q P h = (!ex. (cex_abs h ex |== Q) --> (ex |== P))"
+definition
+  temp_weakening :: "('a,'s2)ioa_temp => ('a,'s1)ioa_temp => ('s1 => 's2) => bool" where
+  "temp_weakening Q P h = temp_strengthening (.~ Q) (.~ P) h"
+
+definition
+  state_strengthening :: "('a,'s2)step_pred => ('a,'s1)step_pred => ('s1 => 's2) => bool" where
+  "state_strengthening Q P h = (!s t a.  Q (h(s),a,h(t)) --> P (s,a,t))"
+definition
+  state_weakening :: "('a,'s2)step_pred => ('a,'s1)step_pred => ('s1 => 's2) => bool" where
+  "state_weakening Q P h = state_strengthening (.~Q) (.~P) h"
+
+definition
+  is_live_abstraction :: "('s1 => 's2) => ('a,'s1)live_ioa => ('a,'s2)live_ioa => bool" where
+  "is_live_abstraction h CL AM =
+     (is_abstraction h (fst CL) (fst AM) &
+      temp_weakening (snd AM) (snd CL) h)"
+
+
+axiomatization where
+(* thm about ex2seq which is not provable by induction as ex2seq is not continous *)
+ex2seq_abs_cex:
+  "ex2seq (cex_abs h ex) = cex_absSeq h (ex2seq ex)"
+
+axiomatization where
+(* analog to the proved thm strength_Box - proof skipped as trivial *)
+weak_Box:
+"temp_weakening P Q h
+ ==> temp_weakening ([] P) ([] Q) h"
+
+axiomatization where
+(* analog to the proved thm strength_Next - proof skipped as trivial *)
+weak_Next:
+"temp_weakening P Q h
+ ==> temp_weakening (Next P) (Next Q) h"
+
+
+subsection "cex_abs"
+
+lemma cex_abs_UU: "cex_abs f (s,UU) = (f s, UU)"
+  by (simp add: cex_abs_def)
+
+lemma cex_abs_nil: "cex_abs f (s,nil) = (f s, nil)"
+  by (simp add: cex_abs_def)
+
+lemma cex_abs_cons: "cex_abs f (s,(a,t)>>ex) = (f s, (a,f t) >> (snd (cex_abs f (t,ex))))"
+  by (simp add: cex_abs_def)
+
+declare cex_abs_UU [simp] cex_abs_nil [simp] cex_abs_cons [simp]
+
+
+subsection "lemmas"
+
+lemma temp_weakening_def2: "temp_weakening Q P h = (! ex. (ex |== P) --> (cex_abs h ex |== Q))"
+  apply (simp add: temp_weakening_def temp_strengthening_def NOT_def temp_sat_def satisfies_def)
+  apply auto
+  done
+
+lemma state_weakening_def2: "state_weakening Q P h = (! s t a. P (s,a,t) --> Q (h(s),a,h(t)))"
+  apply (simp add: state_weakening_def state_strengthening_def NOT_def)
+  apply auto
+  done
+
+
+subsection "Abstraction Rules for Properties"
+
+lemma exec_frag_abstraction [rule_format]:
+ "[| is_abstraction h C A |] ==>
+  !s. reachable C s & is_exec_frag C (s,xs)
+  --> is_exec_frag A (cex_abs h (s,xs))"
+apply (unfold cex_abs_def)
+apply simp
+apply (tactic {* pair_induct_tac @{context} "xs" [@{thm is_exec_frag_def}] 1 *})
+txt {* main case *}
+apply (auto dest: reachable.reachable_n simp add: is_abstraction_def)
+done
+
+
+lemma abs_is_weakening: "is_abstraction h C A ==> weakeningIOA A C h"
+apply (simp add: weakeningIOA_def)
+apply auto
+apply (simp add: executions_def)
+txt {* start state *}
+apply (rule conjI)
+apply (simp add: is_abstraction_def cex_abs_def)
+txt {* is-execution-fragment *}
+apply (erule exec_frag_abstraction)
+apply (simp add: reachable.reachable_0)
+done
+
+
+lemma AbsRuleT1: "[|is_abstraction h C A; validIOA A Q; temp_strengthening Q P h |]
+          ==> validIOA C P"
+apply (drule abs_is_weakening)
+apply (simp add: weakeningIOA_def validIOA_def temp_strengthening_def)
+apply (auto simp add: split_paired_all)
+done
+
+
+(* FIX: Nach TLS.ML *)
+
+lemma IMPLIES_temp_sat: "(ex |== P .--> Q) = ((ex |== P) --> (ex |== Q))"
+  by (simp add: IMPLIES_def temp_sat_def satisfies_def)
+
+lemma AND_temp_sat: "(ex |== P .& Q) = ((ex |== P) & (ex |== Q))"
+  by (simp add: AND_def temp_sat_def satisfies_def)
+
+lemma OR_temp_sat: "(ex |== P .| Q) = ((ex |== P) | (ex |== Q))"
+  by (simp add: OR_def temp_sat_def satisfies_def)
+
+lemma NOT_temp_sat: "(ex |== .~ P) = (~ (ex |== P))"
+  by (simp add: NOT_def temp_sat_def satisfies_def)
+
+declare IMPLIES_temp_sat [simp] AND_temp_sat [simp] OR_temp_sat [simp] NOT_temp_sat [simp]
+
+
+lemma AbsRuleT2:
+   "[|is_live_abstraction h (C,L) (A,M);
+          validLIOA (A,M) Q;  temp_strengthening Q P h |]
+          ==> validLIOA (C,L) P"
+apply (unfold is_live_abstraction_def)
+apply auto
+apply (drule abs_is_weakening)
+apply (simp add: weakeningIOA_def temp_weakening_def2 validLIOA_def validIOA_def temp_strengthening_def)
+apply (auto simp add: split_paired_all)
+done
+
+
+lemma AbsRuleTImprove:
+   "[|is_live_abstraction h (C,L) (A,M);
+          validLIOA (A,M) (H1 .--> Q);  temp_strengthening Q P h;
+          temp_weakening H1 H2 h; validLIOA (C,L) H2 |]
+          ==> validLIOA (C,L) P"
+apply (unfold is_live_abstraction_def)
+apply auto
+apply (drule abs_is_weakening)
+apply (simp add: weakeningIOA_def temp_weakening_def2 validLIOA_def validIOA_def temp_strengthening_def)
+apply (auto simp add: split_paired_all)
+done
+
+
+subsection "Correctness of safe abstraction"
+
+lemma abstraction_is_ref_map:
+"is_abstraction h C A ==> is_ref_map h C A"
+apply (unfold is_abstraction_def is_ref_map_def)
+apply auto
+apply (rule_tac x = "(a,h t) >>nil" in exI)
+apply (simp add: move_def)
+done
+
+
+lemma abs_safety: "[| inp(C)=inp(A); out(C)=out(A);
+                   is_abstraction h C A |]
+                ==> C =<| A"
+apply (simp add: ioa_implements_def)
+apply (rule trace_inclusion)
+apply (simp (no_asm) add: externals_def)
+apply (auto)[1]
+apply (erule abstraction_is_ref_map)
+done
+
+
+subsection "Correctness of life abstraction"
+
+(* Reduces to Filter (Map fst x) = Filter (Map fst (Map (%(a,t). (a,x)) x),
+   that is to special Map Lemma *)
+lemma traces_coincide_abs:
+  "ext C = ext A
+         ==> mk_trace C$xs = mk_trace A$(snd (cex_abs f (s,xs)))"
+apply (unfold cex_abs_def mk_trace_def filter_act_def)
+apply simp
+apply (tactic {* pair_induct_tac @{context} "xs" [] 1 *})
+done
+
+
+(* Does not work with abstraction_is_ref_map as proof of abs_safety, because
+   is_live_abstraction includes temp_strengthening which is necessarily based
+   on cex_abs and not on corresp_ex. Thus, the proof is redoone in a more specific
+   way for cex_abs *)
+lemma abs_liveness: "[| inp(C)=inp(A); out(C)=out(A);
+                   is_live_abstraction h (C,M) (A,L) |]
+                ==> live_implements (C,M) (A,L)"
+apply (simp add: is_live_abstraction_def live_implements_def livetraces_def liveexecutions_def)
+apply auto
+apply (rule_tac x = "cex_abs h ex" in exI)
+apply auto
+  (* Traces coincide *)
+  apply (tactic {* pair_tac @{context} "ex" 1 *})
+  apply (rule traces_coincide_abs)
+  apply (simp (no_asm) add: externals_def)
+  apply (auto)[1]
+
+  (* cex_abs is execution *)
+  apply (tactic {* pair_tac @{context} "ex" 1 *})
+  apply (simp add: executions_def)
+  (* start state *)
+  apply (rule conjI)
+  apply (simp add: is_abstraction_def cex_abs_def)
+  (* is-execution-fragment *)
+  apply (erule exec_frag_abstraction)
+  apply (simp add: reachable.reachable_0)
+
+ (* Liveness *)
+apply (simp add: temp_weakening_def2)
+ apply (tactic {* pair_tac @{context} "ex" 1 *})
+done
+
+(* FIX: NAch Traces.ML bringen *)
+
+lemma implements_trans:
+"[| A =<| B; B =<| C|] ==> A =<| C"
+by (auto simp add: ioa_implements_def)
+
+
+subsection "Abstraction Rules for Automata"
+
+lemma AbsRuleA1: "[| inp(C)=inp(A); out(C)=out(A);
+                   inp(Q)=inp(P); out(Q)=out(P);
+                   is_abstraction h1 C A;
+                   A =<| Q ;
+                   is_abstraction h2 Q P |]
+                ==> C =<| P"
+apply (drule abs_safety)
+apply assumption+
+apply (drule abs_safety)
+apply assumption+
+apply (erule implements_trans)
+apply (erule implements_trans)
+apply assumption
+done
+
+
+lemma AbsRuleA2: "!!LC. [| inp(C)=inp(A); out(C)=out(A);
+                   inp(Q)=inp(P); out(Q)=out(P);
+                   is_live_abstraction h1 (C,LC) (A,LA);
+                   live_implements (A,LA) (Q,LQ) ;
+                   is_live_abstraction h2 (Q,LQ) (P,LP) |]
+                ==> live_implements (C,LC) (P,LP)"
+apply (drule abs_liveness)
+apply assumption+
+apply (drule abs_liveness)
+apply assumption+
+apply (erule live_implements_trans)
+apply (erule live_implements_trans)
+apply assumption
+done
+
+
+declare split_paired_All [simp del]
+
+
+subsection "Localizing Temporal Strengthenings and Weakenings"
+
+lemma strength_AND:
+"[| temp_strengthening P1 Q1 h;
+          temp_strengthening P2 Q2 h |]
+       ==> temp_strengthening (P1 .& P2) (Q1 .& Q2) h"
+apply (unfold temp_strengthening_def)
+apply auto
+done
+
+lemma strength_OR:
+"[| temp_strengthening P1 Q1 h;
+          temp_strengthening P2 Q2 h |]
+       ==> temp_strengthening (P1 .| P2) (Q1 .| Q2) h"
+apply (unfold temp_strengthening_def)
+apply auto
+done
+
+lemma strength_NOT:
+"[| temp_weakening P Q h |]
+       ==> temp_strengthening (.~ P) (.~ Q) h"
+apply (unfold temp_strengthening_def)
+apply (simp add: temp_weakening_def2)
+apply auto
+done
+
+lemma strength_IMPLIES:
+"[| temp_weakening P1 Q1 h;
+          temp_strengthening P2 Q2 h |]
+       ==> temp_strengthening (P1 .--> P2) (Q1 .--> Q2) h"
+apply (unfold temp_strengthening_def)
+apply (simp add: temp_weakening_def2)
+done
+
+
+lemma weak_AND:
+"[| temp_weakening P1 Q1 h;
+          temp_weakening P2 Q2 h |]
+       ==> temp_weakening (P1 .& P2) (Q1 .& Q2) h"
+apply (simp add: temp_weakening_def2)
+done
+
+lemma weak_OR:
+"[| temp_weakening P1 Q1 h;
+          temp_weakening P2 Q2 h |]
+       ==> temp_weakening (P1 .| P2) (Q1 .| Q2) h"
+apply (simp add: temp_weakening_def2)
+done
+
+lemma weak_NOT:
+"[| temp_strengthening P Q h |]
+       ==> temp_weakening (.~ P) (.~ Q) h"
+apply (unfold temp_strengthening_def)
+apply (simp add: temp_weakening_def2)
+apply auto
+done
+
+lemma weak_IMPLIES:
+"[| temp_strengthening P1 Q1 h;
+          temp_weakening P2 Q2 h |]
+       ==> temp_weakening (P1 .--> P2) (Q1 .--> Q2) h"
+apply (unfold temp_strengthening_def)
+apply (simp add: temp_weakening_def2)
+done
+
+
+subsubsection {* Box *}
+
+(* FIX: should be same as nil_is_Conc2 when all nils are turned to right side !! *)
+lemma UU_is_Conc: "(UU = x @@ y) = (((x::'a Seq)= UU) | (x=nil & y=UU))"
+apply (tactic {* Seq_case_simp_tac @{context} "x" 1 *})
+done
+
+lemma ex2seqConc [rule_format]:
+"Finite s1 -->
+  (! ex. (s~=nil & s~=UU & ex2seq ex = s1 @@ s) --> (? ex'. s = ex2seq ex'))"
+apply (rule impI)
+apply (tactic {* Seq_Finite_induct_tac @{context} 1 *})
+apply blast
+(* main case *)
+apply clarify
+apply (tactic {* pair_tac @{context} "ex" 1 *})
+apply (tactic {* Seq_case_simp_tac @{context} "y" 1 *})
+(* UU case *)
+apply (simp add: nil_is_Conc)
+(* nil case *)
+apply (simp add: nil_is_Conc)
+(* cons case *)
+apply (tactic {* pair_tac @{context} "aa" 1 *})
+apply auto
+done
+
+(* important property of ex2seq: can be shiftet, as defined "pointwise" *)
+
+lemma ex2seq_tsuffix:
+"tsuffix s (ex2seq ex) ==> ? ex'. s = (ex2seq ex')"
+apply (unfold tsuffix_def suffix_def)
+apply auto
+apply (drule ex2seqConc)
+apply auto
+done
+
+
+(* FIX: NAch Sequence.ML bringen *)
+
+lemma Mapnil: "(Map f$s = nil) = (s=nil)"
+apply (tactic {* Seq_case_simp_tac @{context} "s" 1 *})
+done
+
+lemma MapUU: "(Map f$s = UU) = (s=UU)"
+apply (tactic {* Seq_case_simp_tac @{context} "s" 1 *})
+done
+
+
+(* important property of cex_absSeq: As it is a 1to1 correspondence,
+  properties carry over *)
+
+lemma cex_absSeq_tsuffix:
+"tsuffix s t ==> tsuffix (cex_absSeq h s) (cex_absSeq h t)"
+apply (unfold tsuffix_def suffix_def cex_absSeq_def)
+apply auto
+apply (simp add: Mapnil)
+apply (simp add: MapUU)
+apply (rule_tac x = "Map (% (s,a,t) . (h s,a, h t))$s1" in exI)
+apply (simp add: Map2Finite MapConc)
+done
+
+
+lemma strength_Box:
+"[| temp_strengthening P Q h |]
+       ==> temp_strengthening ([] P) ([] Q) h"
+apply (unfold temp_strengthening_def state_strengthening_def temp_sat_def satisfies_def Box_def)
+apply clarify
+apply (frule ex2seq_tsuffix)
+apply clarify
+apply (drule_tac h = "h" in cex_absSeq_tsuffix)
+apply (simp add: ex2seq_abs_cex)
+done
+
+
+subsubsection {* Init *}
+
+lemma strength_Init:
+"[| state_strengthening P Q h |]
+       ==> temp_strengthening (Init P) (Init Q) h"
+apply (unfold temp_strengthening_def state_strengthening_def
+  temp_sat_def satisfies_def Init_def unlift_def)
+apply auto
+apply (tactic {* pair_tac @{context} "ex" 1 *})
+apply (tactic {* Seq_case_simp_tac @{context} "y" 1 *})
+apply (tactic {* pair_tac @{context} "a" 1 *})
+done
+
+
+subsubsection {* Next *}
+
+lemma TL_ex2seq_UU:
+"(TL$(ex2seq (cex_abs h ex))=UU) = (TL$(ex2seq ex)=UU)"
+apply (tactic {* pair_tac @{context} "ex" 1 *})
+apply (tactic {* Seq_case_simp_tac @{context} "y" 1 *})
+apply (tactic {* pair_tac @{context} "a" 1 *})
+apply (tactic {* Seq_case_simp_tac @{context} "s" 1 *})
+apply (tactic {* pair_tac @{context} "a" 1 *})
+done
+
+lemma TL_ex2seq_nil:
+"(TL$(ex2seq (cex_abs h ex))=nil) = (TL$(ex2seq ex)=nil)"
+apply (tactic {* pair_tac @{context} "ex" 1 *})
+apply (tactic {* Seq_case_simp_tac @{context} "y" 1 *})
+apply (tactic {* pair_tac @{context} "a" 1 *})
+apply (tactic {* Seq_case_simp_tac @{context} "s" 1 *})
+apply (tactic {* pair_tac @{context} "a" 1 *})
+done
+
+(* FIX: put to Sequence Lemmas *)
+lemma MapTL: "Map f$(TL$s) = TL$(Map f$s)"
+apply (tactic {* Seq_induct_tac @{context} "s" [] 1 *})
+done
+
+(* important property of cex_absSeq: As it is a 1to1 correspondence,
+  properties carry over *)
+
+lemma cex_absSeq_TL:
+"cex_absSeq h (TL$s) = (TL$(cex_absSeq h s))"
+apply (unfold cex_absSeq_def)
+apply (simp add: MapTL)
+done
+
+(* important property of ex2seq: can be shiftet, as defined "pointwise" *)
+
+lemma TLex2seq: "[| (snd ex)~=UU ; (snd ex)~=nil |] ==> (? ex'. TL$(ex2seq ex) = ex2seq ex')"
+apply (tactic {* pair_tac @{context} "ex" 1 *})
+apply (tactic {* Seq_case_simp_tac @{context} "y" 1 *})
+apply (tactic {* pair_tac @{context} "a" 1 *})
+apply auto
+done
+
+
+lemma ex2seqnilTL: "(TL$(ex2seq ex)~=nil) = ((snd ex)~=nil & (snd ex)~=UU)"
+apply (tactic {* pair_tac @{context} "ex" 1 *})
+apply (tactic {* Seq_case_simp_tac @{context} "y" 1 *})
+apply (tactic {* pair_tac @{context} "a" 1 *})
+apply (tactic {* Seq_case_simp_tac @{context} "s" 1 *})
+apply (tactic {* pair_tac @{context} "a" 1 *})
+done
+
+
+lemma strength_Next:
+"[| temp_strengthening P Q h |]
+       ==> temp_strengthening (Next P) (Next Q) h"
+apply (unfold temp_strengthening_def state_strengthening_def temp_sat_def satisfies_def Next_def)
+apply simp
+apply auto
+apply (simp add: TL_ex2seq_nil TL_ex2seq_UU)
+apply (simp add: TL_ex2seq_nil TL_ex2seq_UU)
+apply (simp add: TL_ex2seq_nil TL_ex2seq_UU)
+apply (simp add: TL_ex2seq_nil TL_ex2seq_UU)
+(* cons case *)
+apply (simp add: TL_ex2seq_nil TL_ex2seq_UU ex2seq_abs_cex cex_absSeq_TL [symmetric] ex2seqnilTL)
+apply (erule conjE)
+apply (drule TLex2seq)
+apply assumption
+apply auto
+done
+
+
+text {* Localizing Temporal Weakenings     - 2 *}
+
+lemma weak_Init:
+"[| state_weakening P Q h |]
+       ==> temp_weakening (Init P) (Init Q) h"
+apply (simp add: temp_weakening_def2 state_weakening_def2
+  temp_sat_def satisfies_def Init_def unlift_def)
+apply auto
+apply (tactic {* pair_tac @{context} "ex" 1 *})
+apply (tactic {* Seq_case_simp_tac @{context} "y" 1 *})
+apply (tactic {* pair_tac @{context} "a" 1 *})
+done
+
+
+text {* Localizing Temproal Strengthenings - 3 *}
+
+lemma strength_Diamond:
+"[| temp_strengthening P Q h |]
+       ==> temp_strengthening (<> P) (<> Q) h"
+apply (unfold Diamond_def)
+apply (rule strength_NOT)
+apply (rule weak_Box)
+apply (erule weak_NOT)
+done
+
+lemma strength_Leadsto:
+"[| temp_weakening P1 P2 h;
+          temp_strengthening Q1 Q2 h |]
+       ==> temp_strengthening (P1 ~> Q1) (P2 ~> Q2) h"
+apply (unfold Leadsto_def)
+apply (rule strength_Box)
+apply (erule strength_IMPLIES)
+apply (erule strength_Diamond)
+done
+
+
+text {* Localizing Temporal Weakenings - 3 *}
+
+lemma weak_Diamond:
+"[| temp_weakening P Q h |]
+       ==> temp_weakening (<> P) (<> Q) h"
+apply (unfold Diamond_def)
+apply (rule weak_NOT)
+apply (rule strength_Box)
+apply (erule strength_NOT)
+done
+
+lemma weak_Leadsto:
+"[| temp_strengthening P1 P2 h;
+          temp_weakening Q1 Q2 h |]
+       ==> temp_weakening (P1 ~> Q1) (P2 ~> Q2) h"
+apply (unfold Leadsto_def)
+apply (rule weak_Box)
+apply (erule weak_IMPLIES)
+apply (erule weak_Diamond)
+done
+
+lemma weak_WF:
+  " !!A. [| !! s. Enabled A acts (h s) ==> Enabled C acts s|]
+    ==> temp_weakening (WF A acts) (WF C acts) h"
+apply (unfold WF_def)
+apply (rule weak_IMPLIES)
+apply (rule strength_Diamond)
+apply (rule strength_Box)
+apply (rule strength_Init)
+apply (rule_tac [2] weak_Box)
+apply (rule_tac [2] weak_Diamond)
+apply (rule_tac [2] weak_Init)
+apply (auto simp add: state_weakening_def state_strengthening_def
+  xt2_def plift_def option_lift_def NOT_def)
+done
+
+lemma weak_SF:
+  " !!A. [| !! s. Enabled A acts (h s) ==> Enabled C acts s|]
+    ==> temp_weakening (SF A acts) (SF C acts) h"
+apply (unfold SF_def)
+apply (rule weak_IMPLIES)
+apply (rule strength_Box)
+apply (rule strength_Diamond)
+apply (rule strength_Init)
+apply (rule_tac [2] weak_Box)
+apply (rule_tac [2] weak_Diamond)
+apply (rule_tac [2] weak_Init)
+apply (auto simp add: state_weakening_def state_strengthening_def
+  xt2_def plift_def option_lift_def NOT_def)
+done
+
+
+lemmas weak_strength_lemmas =
+  weak_OR weak_AND weak_NOT weak_IMPLIES weak_Box weak_Next weak_Init
+  weak_Diamond weak_Leadsto strength_OR strength_AND strength_NOT
+  strength_IMPLIES strength_Box strength_Next strength_Init
+  strength_Diamond strength_Leadsto weak_WF weak_SF
+
+ML {*
+fun abstraction_tac ctxt =
+  let val (cs, ss) = clasimpset_of ctxt in
+    SELECT_GOAL (auto_tac (cs addSIs @{thms weak_strength_lemmas},
+        ss addsimps [@{thm state_strengthening_def}, @{thm state_weakening_def}]))
+  end
+*}
+
+method_setup abstraction = {* Scan.succeed (SIMPLE_METHOD' o abstraction_tac) *} ""
+
+end

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/HOLCF/IOA/meta_theory/Asig.thy	Sat Nov 27 16:08:10 2010 -0800
@@ -0,0 +1,101 @@
+(*  Title:      HOL/IOA/meta_theory/Asig.thy
+    Author:     Olaf Müller, Tobias Nipkow & Konrad Slind
+*)
+
+header {* Action signatures *}
+
+theory Asig
+imports Main
+begin
+
+types
+  'a signature = "('a set * 'a set * 'a set)"
+
+definition
+  inputs :: "'action signature => 'action set" where
+  asig_inputs_def: "inputs = fst"
+
+definition
+  outputs :: "'action signature => 'action set" where
+  asig_outputs_def: "outputs = (fst o snd)"
+
+definition
+  internals :: "'action signature => 'action set" where
+  asig_internals_def: "internals = (snd o snd)"
+
+definition
+  actions :: "'action signature => 'action set" where
+  "actions(asig) = (inputs(asig) Un outputs(asig) Un internals(asig))"
+
+definition
+  externals :: "'action signature => 'action set" where
+  "externals(asig) = (inputs(asig) Un outputs(asig))"
+
+definition
+  locals :: "'action signature => 'action set" where
+  "locals asig = ((internals asig) Un (outputs asig))"
+
+definition
+  is_asig :: "'action signature => bool" where
+  "is_asig(triple) =
+     ((inputs(triple) Int outputs(triple) = {}) &
+      (outputs(triple) Int internals(triple) = {}) &
+      (inputs(triple) Int internals(triple) = {}))"
+
+definition
+  mk_ext_asig :: "'action signature => 'action signature" where
+  "mk_ext_asig(triple) = (inputs(triple), outputs(triple), {})"
+
+
+lemmas asig_projections = asig_inputs_def asig_outputs_def asig_internals_def
+
+lemma asig_triple_proj:
+ "(outputs    (a,b,c) = b)   &
+  (inputs     (a,b,c) = a) &
+  (internals  (a,b,c) = c)"
+  apply (simp add: asig_projections)
+  done
+
+lemma int_and_ext_is_act: "[| a~:internals(S) ;a~:externals(S)|] ==> a~:actions(S)"
+apply (simp add: externals_def actions_def)
+done
+
+lemma ext_is_act: "[|a:externals(S)|] ==> a:actions(S)"
+apply (simp add: externals_def actions_def)
+done
+
+lemma int_is_act: "[|a:internals S|] ==> a:actions S"
+apply (simp add: asig_internals_def actions_def)
+done
+
+lemma inp_is_act: "[|a:inputs S|] ==> a:actions S"
+apply (simp add: asig_inputs_def actions_def)
+done
+
+lemma out_is_act: "[|a:outputs S|] ==> a:actions S"
+apply (simp add: asig_outputs_def actions_def)
+done
+
+lemma ext_and_act: "(x: actions S & x : externals S) = (x: externals S)"
+apply (fast intro!: ext_is_act)
+done
+
+lemma not_ext_is_int: "[|is_asig S;x: actions S|] ==> (x~:externals S) = (x: internals S)"
+apply (simp add: actions_def is_asig_def externals_def)
+apply blast
+done
+
+lemma not_ext_is_int_or_not_act: "is_asig S ==> (x~:externals S) = (x: internals S | x~:actions S)"
+apply (simp add: actions_def is_asig_def externals_def)
+apply blast
+done
+
+lemma int_is_not_ext:
+ "[| is_asig (S); x:internals S |] ==> x~:externals S"
+apply (unfold externals_def actions_def is_asig_def)
+apply simp
+apply blast
+done
+
+
+end

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/HOLCF/IOA/meta_theory/Automata.thy	Sat Nov 27 16:08:10 2010 -0800
@@ -0,0 +1,691 @@
+(*  Title:      HOLCF/IOA/meta_theory/Automata.thy
+    Author:     Olaf Müller, Konrad Slind, Tobias Nipkow
+*)
+
+header {* The I/O automata of Lynch and Tuttle in HOLCF *}
+
+theory Automata
+imports Asig
+begin
+
+default_sort type
+
+types
+  ('a, 's) transition = "'s * 'a * 's"
+  ('a, 's) ioa = "'a signature * 's set * ('a,'s)transition set * ('a set set) * ('a set set)"
+
+consts
+
+  (* IO automata *)
+
+  asig_of        ::"('a,'s)ioa => 'a signature"
+  starts_of      ::"('a,'s)ioa => 's set"
+  trans_of       ::"('a,'s)ioa => ('a,'s)transition set"
+  wfair_of       ::"('a,'s)ioa => ('a set) set"
+  sfair_of       ::"('a,'s)ioa => ('a set) set"
+
+  is_asig_of     ::"('a,'s)ioa => bool"
+  is_starts_of   ::"('a,'s)ioa => bool"
+  is_trans_of    ::"('a,'s)ioa => bool"
+  input_enabled  ::"('a,'s)ioa => bool"
+  IOA            ::"('a,'s)ioa => bool"
+
+  (* constraints for fair IOA *)
+
+  fairIOA        ::"('a,'s)ioa => bool"
+  input_resistant::"('a,'s)ioa => bool"
+
+  (* enabledness of actions and action sets *)
+
+  enabled        ::"('a,'s)ioa => 'a => 's => bool"
+  Enabled    ::"('a,'s)ioa => 'a set => 's => bool"
+
+  (* action set keeps enabled until probably disabled by itself *)
+
+  en_persistent  :: "('a,'s)ioa => 'a set => bool"
+
+ (* post_conditions for actions and action sets *)
+
+  was_enabled        ::"('a,'s)ioa => 'a => 's => bool"
+  set_was_enabled    ::"('a,'s)ioa => 'a set => 's => bool"
+
+  (* invariants *)
+  invariant     :: "[('a,'s)ioa, 's=>bool] => bool"
+
+  (* binary composition of action signatures and automata *)
+  asig_comp    ::"['a signature, 'a signature] => 'a signature"
+  compatible   ::"[('a,'s)ioa, ('a,'t)ioa] => bool"
+  par          ::"[('a,'s)ioa, ('a,'t)ioa] => ('a,'s*'t)ioa"  (infixr "||" 10)
+
+  (* hiding and restricting *)
+  hide_asig     :: "['a signature, 'a set] => 'a signature"
+  hide          :: "[('a,'s)ioa, 'a set] => ('a,'s)ioa"
+  restrict_asig :: "['a signature, 'a set] => 'a signature"
+  restrict      :: "[('a,'s)ioa, 'a set] => ('a,'s)ioa"
+
+  (* renaming *)
+  rename_set    :: "'a set => ('c => 'a option) => 'c set"
+  rename        :: "('a, 'b)ioa => ('c => 'a option) => ('c,'b)ioa"
+
+notation (xsymbols)
+  par  (infixr "\<parallel>" 10)
+
+
+inductive
+  reachable :: "('a, 's) ioa => 's => bool"
+  for C :: "('a, 's) ioa"
+  where
+    reachable_0:  "s : starts_of C ==> reachable C s"
+  | reachable_n:  "[| reachable C s; (s, a, t) : trans_of C |] ==> reachable C t"
+
+abbreviation
+  trans_of_syn  ("_ -_--_-> _" [81,81,81,81] 100) where
+  "s -a--A-> t == (s,a,t):trans_of A"
+
+notation (xsymbols)
+  trans_of_syn  ("_ \<midarrow>_\<midarrow>_\<longrightarrow> _" [81,81,81,81] 100)
+
+abbreviation "act A == actions (asig_of A)"
+abbreviation "ext A == externals (asig_of A)"
+abbreviation int where "int A == internals (asig_of A)"
+abbreviation "inp A == inputs (asig_of A)"
+abbreviation "out A == outputs (asig_of A)"
+abbreviation "local A == locals (asig_of A)"
+
+defs
+
+(* --------------------------------- IOA ---------------------------------*)
+
+asig_of_def:   "asig_of == fst"
+starts_of_def: "starts_of == (fst o snd)"
+trans_of_def:  "trans_of == (fst o snd o snd)"
+wfair_of_def:  "wfair_of == (fst o snd o snd o snd)"
+sfair_of_def:  "sfair_of == (snd o snd o snd o snd)"
+
+is_asig_of_def:
+  "is_asig_of A == is_asig (asig_of A)"
+
+is_starts_of_def:
+  "is_starts_of A ==  (~ starts_of A = {})"
+
+is_trans_of_def:
+  "is_trans_of A ==
+    (!triple. triple:(trans_of A) --> fst(snd(triple)):actions(asig_of A))"
+
+input_enabled_def:
+  "input_enabled A ==
+    (!a. (a:inputs(asig_of A)) --> (!s1. ? s2. (s1,a,s2):(trans_of A)))"
+
+
+ioa_def:
+  "IOA A == (is_asig_of A    &
+             is_starts_of A  &
+             is_trans_of A   &
+             input_enabled A)"
+
+
+invariant_def: "invariant A P == (!s. reachable A s --> P(s))"
+
+
+(* ------------------------- parallel composition --------------------------*)
+
+
+compatible_def:
+  "compatible A B ==
+  (((out A Int out B) = {}) &
+   ((int A Int act B) = {}) &
+   ((int B Int act A) = {}))"
+
+asig_comp_def:
+  "asig_comp a1 a2 ==
+     (((inputs(a1) Un inputs(a2)) - (outputs(a1) Un outputs(a2)),
+       (outputs(a1) Un outputs(a2)),
+       (internals(a1) Un internals(a2))))"
+
+par_def:
+  "(A || B) ==
+      (asig_comp (asig_of A) (asig_of B),
+       {pr. fst(pr):starts_of(A) & snd(pr):starts_of(B)},
+       {tr. let s = fst(tr); a = fst(snd(tr)); t = snd(snd(tr))
+            in (a:act A | a:act B) &
+               (if a:act A then
+                  (fst(s),a,fst(t)):trans_of(A)
+                else fst(t) = fst(s))
+               &
+               (if a:act B then
+                  (snd(s),a,snd(t)):trans_of(B)
+                else snd(t) = snd(s))},
+        wfair_of A Un wfair_of B,
+        sfair_of A Un sfair_of B)"
+
+
+(* ------------------------ hiding -------------------------------------------- *)
+
+restrict_asig_def:
+  "restrict_asig asig actns ==
+    (inputs(asig) Int actns,
+     outputs(asig) Int actns,
+     internals(asig) Un (externals(asig) - actns))"
+
+(* Notice that for wfair_of and sfair_of nothing has to be changed, as
+   changes from the outputs to the internals does not touch the locals as
+   a whole, which is of importance for fairness only *)
+
+restrict_def:
+  "restrict A actns ==
+    (restrict_asig (asig_of A) actns,
+     starts_of A,
+     trans_of A,
+     wfair_of A,
+     sfair_of A)"
+
+hide_asig_def:
+  "hide_asig asig actns ==
+    (inputs(asig) - actns,
+     outputs(asig) - actns,
+     internals(asig) Un actns)"
+
+hide_def:
+  "hide A actns ==
+    (hide_asig (asig_of A) actns,
+     starts_of A,
+     trans_of A,
+     wfair_of A,
+     sfair_of A)"
+
+(* ------------------------- renaming ------------------------------------------- *)
+
+rename_set_def:
+  "rename_set A ren == {b. ? x. Some x = ren b & x : A}"
+
+rename_def:
+"rename ioa ren ==
+  ((rename_set (inp ioa) ren,
+    rename_set (out ioa) ren,
+    rename_set (int ioa) ren),
+   starts_of ioa,
+   {tr. let s = fst(tr); a = fst(snd(tr));  t = snd(snd(tr))
+        in
+        ? x. Some(x) = ren(a) & (s,x,t):trans_of ioa},
+   {rename_set s ren | s. s: wfair_of ioa},
+   {rename_set s ren | s. s: sfair_of ioa})"
+
+(* ------------------------- fairness ----------------------------- *)
+
+fairIOA_def:
+  "fairIOA A == (! S : wfair_of A. S<= local A) &
+                (! S : sfair_of A. S<= local A)"
+
+input_resistant_def:
+  "input_resistant A == ! W : sfair_of A. ! s a t.
+                        reachable A s & reachable A t & a:inp A &
+                        Enabled A W s & s -a--A-> t
+                        --> Enabled A W t"
+
+enabled_def:
+  "enabled A a s == ? t. s-a--A-> t"
+
+Enabled_def:
+  "Enabled A W s == ? w:W. enabled A w s"
+
+en_persistent_def:
+  "en_persistent A W == ! s a t. Enabled A W s &
+                                 a ~:W &
+                                 s -a--A-> t
+                                 --> Enabled A W t"
+was_enabled_def:
+  "was_enabled A a t == ? s. s-a--A-> t"
+
+set_was_enabled_def:
+  "set_was_enabled A W t == ? w:W. was_enabled A w t"
+
+
+declare split_paired_Ex [simp del]
+
+lemmas ioa_projections = asig_of_def starts_of_def trans_of_def wfair_of_def sfair_of_def
+
+
+subsection "asig_of, starts_of, trans_of"
+
+lemma ioa_triple_proj: 
+ "((asig_of (x,y,z,w,s)) = x)   &  
+  ((starts_of (x,y,z,w,s)) = y) &  
+  ((trans_of (x,y,z,w,s)) = z)  &  
+  ((wfair_of (x,y,z,w,s)) = w) &  
+  ((sfair_of (x,y,z,w,s)) = s)"
+  apply (simp add: ioa_projections)
+  done
+
+lemma trans_in_actions: 
+  "[| is_trans_of A; (s1,a,s2):trans_of(A) |] ==> a:act A"
+apply (unfold is_trans_of_def actions_def is_asig_def)
+  apply (erule allE, erule impE, assumption)
+  apply simp
+done
+
+lemma starts_of_par: 
+"starts_of(A || B) = {p. fst(p):starts_of(A) & snd(p):starts_of(B)}"
+  apply (simp add: par_def ioa_projections)
+done
+
+lemma trans_of_par: 
+"trans_of(A || B) = {tr. let s = fst(tr); a = fst(snd(tr)); t = snd(snd(tr))  
+             in (a:act A | a:act B) &  
+                (if a:act A then        
+                   (fst(s),a,fst(t)):trans_of(A)  
+                 else fst(t) = fst(s))             
+                &                                   
+                (if a:act B then                     
+                   (snd(s),a,snd(t)):trans_of(B)      
+                 else snd(t) = snd(s))}"
+
+apply (simp add: par_def ioa_projections)
+done
+
+
+subsection "actions and par"
+
+lemma actions_asig_comp: 
+  "actions(asig_comp a b) = actions(a) Un actions(b)"
+  apply (simp (no_asm) add: actions_def asig_comp_def asig_projections)
+  apply blast
+  done
+
+lemma asig_of_par: "asig_of(A || B) = asig_comp (asig_of A) (asig_of B)"
+  apply (simp add: par_def ioa_projections)
+  done
+
+
+lemma externals_of_par: "ext (A1||A2) =     
+   (ext A1) Un (ext A2)"
+apply (simp add: externals_def asig_of_par asig_comp_def
+  asig_inputs_def asig_outputs_def Un_def set_diff_eq)
+apply blast
+done
+
+lemma actions_of_par: "act (A1||A2) =     
+   (act A1) Un (act A2)"
+apply (simp add: actions_def asig_of_par asig_comp_def
+  asig_inputs_def asig_outputs_def asig_internals_def Un_def set_diff_eq)
+apply blast
+done
+
+lemma inputs_of_par: "inp (A1||A2) = 
+          ((inp A1) Un (inp A2)) - ((out A1) Un (out A2))"
+apply (simp add: actions_def asig_of_par asig_comp_def
+  asig_inputs_def asig_outputs_def Un_def set_diff_eq)
+done
+
+lemma outputs_of_par: "out (A1||A2) = 
+          (out A1) Un (out A2)"
+apply (simp add: actions_def asig_of_par asig_comp_def
+  asig_outputs_def Un_def set_diff_eq)
+done
+
+lemma internals_of_par: "int (A1||A2) = 
+          (int A1) Un (int A2)"
+apply (simp add: actions_def asig_of_par asig_comp_def
+  asig_inputs_def asig_outputs_def asig_internals_def Un_def set_diff_eq)
+done
+
+
+subsection "actions and compatibility"
+
+lemma compat_commute: "compatible A B = compatible B A"
+apply (simp add: compatible_def Int_commute)
+apply auto
+done
+
+lemma ext1_is_not_int2: 
+ "[| compatible A1 A2; a:ext A1|] ==> a~:int A2"
+apply (unfold externals_def actions_def compatible_def)
+apply simp
+apply blast
+done
+
+(* just commuting the previous one: better commute compatible *)
+lemma ext2_is_not_int1: 
+ "[| compatible A2 A1 ; a:ext A1|] ==> a~:int A2"
+apply (unfold externals_def actions_def compatible_def)
+apply simp
+apply blast
+done
+
+lemmas ext1_ext2_is_not_act2 = ext1_is_not_int2 [THEN int_and_ext_is_act, standard]
+lemmas ext1_ext2_is_not_act1 = ext2_is_not_int1 [THEN int_and_ext_is_act, standard]
+
+lemma intA_is_not_extB: 
+ "[| compatible A B; x:int A |] ==> x~:ext B"
+apply (unfold externals_def actions_def compatible_def)
+apply simp
+apply blast
+done
+
+lemma intA_is_not_actB: 
+"[| compatible A B; a:int A |] ==> a ~: act B"
+apply (unfold externals_def actions_def compatible_def is_asig_def asig_of_def)
+apply simp
+apply blast
+done
+
+(* the only one that needs disjointness of outputs and of internals and _all_ acts *)
+lemma outAactB_is_inpB: 
+"[| compatible A B; a:out A ;a:act B|] ==> a : inp B"
+apply (unfold asig_outputs_def asig_internals_def actions_def asig_inputs_def 
+    compatible_def is_asig_def asig_of_def)
+apply simp
+apply blast
+done
+
+(* needed for propagation of input_enabledness from A,B to A||B *)
+lemma inpAAactB_is_inpBoroutB: 
+"[| compatible A B; a:inp A ;a:act B|] ==> a : inp B | a: out B"
+apply (unfold asig_outputs_def asig_internals_def actions_def asig_inputs_def 
+    compatible_def is_asig_def asig_of_def)
+apply simp
+apply blast
+done
+
+
+subsection "input_enabledness and par"
+
+
+(* ugly case distinctions. Heart of proof:
+     1. inpAAactB_is_inpBoroutB ie. internals are really hidden.
+     2. inputs_of_par: outputs are no longer inputs of par. This is important here *)
+lemma input_enabled_par: 
+"[| compatible A B; input_enabled A; input_enabled B|]  
+      ==> input_enabled (A||B)"
+apply (unfold input_enabled_def)
+apply (simp add: Let_def inputs_of_par trans_of_par)
+apply (tactic "safe_tac (global_claset_of @{theory Fun})")
+apply (simp add: inp_is_act)
+prefer 2
+apply (simp add: inp_is_act)
+(* a: inp A *)
+apply (case_tac "a:act B")
+(* a:act B *)
+apply (erule_tac x = "a" in allE)
+apply simp
+apply (drule inpAAactB_is_inpBoroutB)
+apply assumption
+apply assumption
+apply (erule_tac x = "a" in allE)
+apply simp
+apply (erule_tac x = "aa" in allE)
+apply (erule_tac x = "b" in allE)
+apply (erule exE)
+apply (erule exE)
+apply (rule_tac x = " (s2,s2a) " in exI)
+apply (simp add: inp_is_act)
+(* a~: act B*)
+apply (simp add: inp_is_act)
+apply (erule_tac x = "a" in allE)
+apply simp
+apply (erule_tac x = "aa" in allE)
+apply (erule exE)
+apply (rule_tac x = " (s2,b) " in exI)
+apply simp
+
+(* a:inp B *)
+apply (case_tac "a:act A")
+(* a:act A *)
+apply (erule_tac x = "a" in allE)
+apply (erule_tac x = "a" in allE)
+apply (simp add: inp_is_act)
+apply (frule_tac A1 = "A" in compat_commute [THEN iffD1])
+apply (drule inpAAactB_is_inpBoroutB)
+back
+apply assumption
+apply assumption
+apply simp
+apply (erule_tac x = "aa" in allE)
+apply (erule_tac x = "b" in allE)
+apply (erule exE)
+apply (erule exE)
+apply (rule_tac x = " (s2,s2a) " in exI)
+apply (simp add: inp_is_act)
+(* a~: act B*)
+apply (simp add: inp_is_act)
+apply (erule_tac x = "a" in allE)
+apply (erule_tac x = "a" in allE)
+apply simp
+apply (erule_tac x = "b" in allE)
+apply (erule exE)
+apply (rule_tac x = " (aa,s2) " in exI)
+apply simp
+done
+
+
+subsection "invariants"
+
+lemma invariantI:
+  "[| !!s. s:starts_of(A) ==> P(s);      
+      !!s t a. [|reachable A s; P(s)|] ==> (s,a,t): trans_of(A) --> P(t) |]  
+   ==> invariant A P"
+apply (unfold invariant_def)
+apply (rule allI)
+apply (rule impI)
+apply (rule_tac x = "s" in reachable.induct)
+apply assumption
+apply blast
+apply blast
+done
+
+lemma invariantI1:
+ "[| !!s. s : starts_of(A) ==> P(s);  
+     !!s t a. reachable A s ==> P(s) --> (s,a,t):trans_of(A) --> P(t)  
+  |] ==> invariant A P"
+  apply (blast intro: invariantI)
+  done
+
+lemma invariantE: "[| invariant A P; reachable A s |] ==> P(s)"
+  apply (unfold invariant_def)
+  apply blast
+  done
+
+
+subsection "restrict"
+
+
+lemmas reachable_0 = reachable.reachable_0
+  and reachable_n = reachable.reachable_n
+
+lemma cancel_restrict_a: "starts_of(restrict ioa acts) = starts_of(ioa) &      
+          trans_of(restrict ioa acts) = trans_of(ioa)"
+apply (simp add: restrict_def ioa_projections)
+done
+
+lemma cancel_restrict_b: "reachable (restrict ioa acts) s = reachable ioa s"
+apply (rule iffI)
+apply (erule reachable.induct)
+apply (simp add: cancel_restrict_a reachable_0)
+apply (erule reachable_n)
+apply (simp add: cancel_restrict_a)
+(* <--  *)
+apply (erule reachable.induct)
+apply (rule reachable_0)
+apply (simp add: cancel_restrict_a)
+apply (erule reachable_n)
+apply (simp add: cancel_restrict_a)
+done
+
+lemma acts_restrict: "act (restrict A acts) = act A"
+apply (simp (no_asm) add: actions_def asig_internals_def
+  asig_outputs_def asig_inputs_def externals_def asig_of_def restrict_def restrict_asig_def)
+apply auto
+done
+
+lemma cancel_restrict: "starts_of(restrict ioa acts) = starts_of(ioa) &      
+          trans_of(restrict ioa acts) = trans_of(ioa) &  
+          reachable (restrict ioa acts) s = reachable ioa s &  
+          act (restrict A acts) = act A"
+  apply (simp (no_asm) add: cancel_restrict_a cancel_restrict_b acts_restrict)
+  done
+
+
+subsection "rename"
+
+lemma trans_rename: "s -a--(rename C f)-> t ==> (? x. Some(x) = f(a) & s -x--C-> t)"
+apply (simp add: Let_def rename_def trans_of_def)
+done
+
+
+lemma reachable_rename: "[| reachable (rename C g) s |] ==> reachable C s"
+apply (erule reachable.induct)
+apply (rule reachable_0)
+apply (simp add: rename_def ioa_projections)
+apply (drule trans_rename)
+apply (erule exE)
+apply (erule conjE)
+apply (erule reachable_n)
+apply assumption
+done
+
+
+subsection "trans_of(A||B)"
+
+
+lemma trans_A_proj: "[|(s,a,t):trans_of (A||B); a:act A|]  
+              ==> (fst s,a,fst t):trans_of A"
+apply (simp add: Let_def par_def trans_of_def)
+done
+
+lemma trans_B_proj: "[|(s,a,t):trans_of (A||B); a:act B|]  
+              ==> (snd s,a,snd t):trans_of B"
+apply (simp add: Let_def par_def trans_of_def)
+done
+
+lemma trans_A_proj2: "[|(s,a,t):trans_of (A||B); a~:act A|] 
+              ==> fst s = fst t"
+apply (simp add: Let_def par_def trans_of_def)
+done
+
+lemma trans_B_proj2: "[|(s,a,t):trans_of (A||B); a~:act B|] 
+              ==> snd s = snd t"
+apply (simp add: Let_def par_def trans_of_def)
+done
+
+lemma trans_AB_proj: "(s,a,t):trans_of (A||B)  
+               ==> a :act A | a :act B"
+apply (simp add: Let_def par_def trans_of_def)
+done
+
+lemma trans_AB: "[|a:act A;a:act B; 
+       (fst s,a,fst t):trans_of A;(snd s,a,snd t):trans_of B|] 
+   ==> (s,a,t):trans_of (A||B)"
+apply (simp add: Let_def par_def trans_of_def)
+done
+
+lemma trans_A_notB: "[|a:act A;a~:act B; 
+       (fst s,a,fst t):trans_of A;snd s=snd t|] 
+   ==> (s,a,t):trans_of (A||B)"
+apply (simp add: Let_def par_def trans_of_def)
+done
+
+lemma trans_notA_B: "[|a~:act A;a:act B; 
+       (snd s,a,snd t):trans_of B;fst s=fst t|] 
+   ==> (s,a,t):trans_of (A||B)"
+apply (simp add: Let_def par_def trans_of_def)
+done
+
+lemmas trans_of_defs1 = trans_AB trans_A_notB trans_notA_B
+  and trans_of_defs2 = trans_A_proj trans_B_proj trans_A_proj2 trans_B_proj2 trans_AB_proj
+
+
+lemma trans_of_par4: 
+"((s,a,t) : trans_of(A || B || C || D)) =                                     
+  ((a:actions(asig_of(A)) | a:actions(asig_of(B)) | a:actions(asig_of(C)) |   
+    a:actions(asig_of(D))) &                                                  
+   (if a:actions(asig_of(A)) then (fst(s),a,fst(t)):trans_of(A)               
+    else fst t=fst s) &                                                       
+   (if a:actions(asig_of(B)) then (fst(snd(s)),a,fst(snd(t))):trans_of(B)     
+    else fst(snd(t))=fst(snd(s))) &                                           
+   (if a:actions(asig_of(C)) then                                             
+      (fst(snd(snd(s))),a,fst(snd(snd(t)))):trans_of(C)                       
+    else fst(snd(snd(t)))=fst(snd(snd(s)))) &                                 
+   (if a:actions(asig_of(D)) then                                             
+      (snd(snd(snd(s))),a,snd(snd(snd(t)))):trans_of(D)                       
+    else snd(snd(snd(t)))=snd(snd(snd(s)))))"
+  apply (simp (no_asm) add: par_def actions_asig_comp Pair_fst_snd_eq Let_def ioa_projections)
+  done
+
+
+subsection "proof obligation generator for IOA requirements"
+
+(* without assumptions on A and B because is_trans_of is also incorporated in ||def *)
+lemma is_trans_of_par: "is_trans_of (A||B)"
+apply (unfold is_trans_of_def)
+apply (simp add: Let_def actions_of_par trans_of_par)
+done
+
+lemma is_trans_of_restrict: 
+"is_trans_of A ==> is_trans_of (restrict A acts)"
+apply (unfold is_trans_of_def)
+apply (simp add: cancel_restrict acts_restrict)
+done
+
+lemma is_trans_of_rename: 
+"is_trans_of A ==> is_trans_of (rename A f)"
+apply (unfold is_trans_of_def restrict_def restrict_asig_def)
+apply (simp add: Let_def actions_def trans_of_def asig_internals_def
+  asig_outputs_def asig_inputs_def externals_def asig_of_def rename_def rename_set_def)
+apply blast
+done
+
+lemma is_asig_of_par: "[| is_asig_of A; is_asig_of B; compatible A B|]   
+          ==> is_asig_of (A||B)"
+apply (simp add: is_asig_of_def asig_of_par asig_comp_def compatible_def
+  asig_internals_def asig_outputs_def asig_inputs_def actions_def is_asig_def)
+apply (simp add: asig_of_def)
+apply auto
+done
+
+lemma is_asig_of_restrict: 
+"is_asig_of A ==> is_asig_of (restrict A f)"
+apply (unfold is_asig_of_def is_asig_def asig_of_def restrict_def restrict_asig_def 
+           asig_internals_def asig_outputs_def asig_inputs_def externals_def o_def)
+apply simp
+apply auto
+done
+
+lemma is_asig_of_rename: "is_asig_of A ==> is_asig_of (rename A f)"
+apply (simp add: is_asig_of_def rename_def rename_set_def asig_internals_def
+  asig_outputs_def asig_inputs_def actions_def is_asig_def asig_of_def)
+apply auto
+apply (drule_tac [!] s = "Some ?x" in sym)
+apply auto
+done
+
+lemmas [simp] = is_asig_of_par is_asig_of_restrict
+  is_asig_of_rename is_trans_of_par is_trans_of_restrict is_trans_of_rename
+
+
+lemma compatible_par: 
+"[|compatible A B; compatible A C |]==> compatible A (B||C)"
+apply (unfold compatible_def)
+apply (simp add: internals_of_par outputs_of_par actions_of_par)
+apply auto
+done
+
+(*  better derive by previous one and compat_commute *)
+lemma compatible_par2: 
+"[|compatible A C; compatible B C |]==> compatible (A||B) C"
+apply (unfold compatible_def)
+apply (simp add: internals_of_par outputs_of_par actions_of_par)
+apply auto
+done
+
+lemma compatible_restrict: 
+"[| compatible A B; (ext B - S) Int ext A = {}|]  
+      ==> compatible A (restrict B S)"
+apply (unfold compatible_def)
+apply (simp add: ioa_triple_proj asig_triple_proj externals_def
+  restrict_def restrict_asig_def actions_def)
+apply auto
+done
+
+
+declare split_paired_Ex [simp]
+
+end

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/HOLCF/IOA/meta_theory/CompoExecs.thy	Sat Nov 27 16:08:10 2010 -0800
@@ -0,0 +1,303 @@
+(*  Title:      HOLCF/IOA/meta_theory/CompoExecs.thy
+    Author:     Olaf Müller
+*)
+
+header {* Compositionality on Execution level *}
+
+theory CompoExecs
+imports Traces
+begin
+
+definition
+  ProjA2 :: "('a,'s * 't)pairs -> ('a,'s)pairs" where
+  "ProjA2 = Map (%x.(fst x,fst(snd x)))"
+
+definition
+  ProjA :: "('a,'s * 't)execution => ('a,'s)execution" where
+  "ProjA ex = (fst (fst ex), ProjA2$(snd ex))"
+
+definition
+  ProjB2 :: "('a,'s * 't)pairs -> ('a,'t)pairs" where
+  "ProjB2 = Map (%x.(fst x,snd(snd x)))"
+
+definition
+  ProjB :: "('a,'s * 't)execution => ('a,'t)execution" where
+  "ProjB ex = (snd (fst ex), ProjB2$(snd ex))"
+
+definition
+  Filter_ex2 :: "'a signature => ('a,'s)pairs -> ('a,'s)pairs" where
+  "Filter_ex2 sig = Filter (%x. fst x:actions sig)"
+
+definition
+  Filter_ex :: "'a signature => ('a,'s)execution => ('a,'s)execution" where
+  "Filter_ex sig ex = (fst ex,Filter_ex2 sig$(snd ex))"
+
+definition
+  stutter2 :: "'a signature => ('a,'s)pairs -> ('s => tr)" where
+  "stutter2 sig = (fix$(LAM h ex. (%s. case ex of
+      nil => TT
+    | x##xs => (flift1
+            (%p.(If Def ((fst p)~:actions sig)
+                 then Def (s=(snd p))
+                 else TT)
+                andalso (h$xs) (snd p))
+             $x)
+   )))"
+
+definition
+  stutter :: "'a signature => ('a,'s)execution => bool" where
+  "stutter sig ex = ((stutter2 sig$(snd ex)) (fst ex) ~= FF)"
+
+definition
+  par_execs :: "[('a,'s)execution_module,('a,'t)execution_module] => ('a,'s*'t)execution_module" where
+  "par_execs ExecsA ExecsB =
+      (let exA = fst ExecsA; sigA = snd ExecsA;
+           exB = fst ExecsB; sigB = snd ExecsB
+       in
+       (    {ex. Filter_ex sigA (ProjA ex) : exA}
+        Int {ex. Filter_ex sigB (ProjB ex) : exB}
+        Int {ex. stutter sigA (ProjA ex)}
+        Int {ex. stutter sigB (ProjB ex)}
+        Int {ex. Forall (%x. fst x:(actions sigA Un actions sigB)) (snd ex)},
+        asig_comp sigA sigB))"
+
+
+lemmas [simp del] = split_paired_All
+
+
+section "recursive equations of operators"
+
+
+(* ---------------------------------------------------------------- *)
+(*                               ProjA2                             *)
+(* ---------------------------------------------------------------- *)
+
+
+lemma ProjA2_UU: "ProjA2$UU = UU"
+apply (simp add: ProjA2_def)
+done
+
+lemma ProjA2_nil: "ProjA2$nil = nil"
+apply (simp add: ProjA2_def)
+done
+
+lemma ProjA2_cons: "ProjA2$((a,t)>>xs) = (a,fst t) >> ProjA2$xs"
+apply (simp add: ProjA2_def)
+done
+
+
+(* ---------------------------------------------------------------- *)
+(*                               ProjB2                             *)
+(* ---------------------------------------------------------------- *)
+
+
+lemma ProjB2_UU: "ProjB2$UU = UU"
+apply (simp add: ProjB2_def)
+done
+
+lemma ProjB2_nil: "ProjB2$nil = nil"
+apply (simp add: ProjB2_def)
+done
+
+lemma ProjB2_cons: "ProjB2$((a,t)>>xs) = (a,snd t) >> ProjB2$xs"
+apply (simp add: ProjB2_def)
+done
+
+
+
+(* ---------------------------------------------------------------- *)
+(*                             Filter_ex2                           *)
+(* ---------------------------------------------------------------- *)
+
+
+lemma Filter_ex2_UU: "Filter_ex2 sig$UU=UU"
+apply (simp add: Filter_ex2_def)
+done
+
+lemma Filter_ex2_nil: "Filter_ex2 sig$nil=nil"
+apply (simp add: Filter_ex2_def)
+done
+
+lemma Filter_ex2_cons: "Filter_ex2 sig$(at >> xs) =
+             (if (fst at:actions sig)
+                  then at >> (Filter_ex2 sig$xs)
+                  else        Filter_ex2 sig$xs)"
+
+apply (simp add: Filter_ex2_def)
+done
+
+
+(* ---------------------------------------------------------------- *)
+(*                             stutter2                             *)
+(* ---------------------------------------------------------------- *)
+
+
+lemma stutter2_unfold: "stutter2 sig = (LAM ex. (%s. case ex of
+       nil => TT
+     | x##xs => (flift1
+             (%p.(If Def ((fst p)~:actions sig)
+                  then Def (s=(snd p))
+                  else TT)
+                 andalso (stutter2 sig$xs) (snd p))
+              $x)
+            ))"
+apply (rule trans)
+apply (rule fix_eq2)
+apply (simp only: stutter2_def)
+apply (rule beta_cfun)
+apply (simp add: flift1_def)
+done
+
+lemma stutter2_UU: "(stutter2 sig$UU) s=UU"
+apply (subst stutter2_unfold)
+apply simp
+done
+
+lemma stutter2_nil: "(stutter2 sig$nil) s = TT"
+apply (subst stutter2_unfold)
+apply simp
+done
+
+lemma stutter2_cons: "(stutter2 sig$(at>>xs)) s =
+               ((if (fst at)~:actions sig then Def (s=snd at) else TT)
+                 andalso (stutter2 sig$xs) (snd at))"
+apply (rule trans)
+apply (subst stutter2_unfold)
+apply (simp add: Consq_def flift1_def If_and_if)
+apply simp
+done
+
+
+declare stutter2_UU [simp] stutter2_nil [simp] stutter2_cons [simp]
+
+
+(* ---------------------------------------------------------------- *)
+(*                             stutter                              *)
+(* ---------------------------------------------------------------- *)
+
+lemma stutter_UU: "stutter sig (s, UU)"
+apply (simp add: stutter_def)
+done
+
+lemma stutter_nil: "stutter sig (s, nil)"
+apply (simp add: stutter_def)
+done
+
+lemma stutter_cons: "stutter sig (s, (a,t)>>ex) =
+      ((a~:actions sig --> (s=t)) & stutter sig (t,ex))"
+apply (simp add: stutter_def)
+done
+
+(* ----------------------------------------------------------------------------------- *)
+
+declare stutter2_UU [simp del] stutter2_nil [simp del] stutter2_cons [simp del]
+
+lemmas compoex_simps = ProjA2_UU ProjA2_nil ProjA2_cons
+  ProjB2_UU ProjB2_nil ProjB2_cons
+  Filter_ex2_UU Filter_ex2_nil Filter_ex2_cons
+  stutter_UU stutter_nil stutter_cons
+
+declare compoex_simps [simp]
+
+
+
+(* ------------------------------------------------------------------ *)
+(*                      The following lemmata aim for                 *)
+(*             COMPOSITIONALITY   on    EXECUTION     Level           *)
+(* ------------------------------------------------------------------ *)
+
+
+(* --------------------------------------------------------------------- *)
+(*  Lemma_1_1a : is_ex_fr propagates from A||B to Projections A and B    *)
+(* --------------------------------------------------------------------- *)
+
+lemma lemma_1_1a: "!s. is_exec_frag (A||B) (s,xs)
+       -->  is_exec_frag A (fst s, Filter_ex2 (asig_of A)$(ProjA2$xs)) &
+            is_exec_frag B (snd s, Filter_ex2 (asig_of B)$(ProjB2$xs))"
+
+apply (tactic {* pair_induct_tac @{context} "xs" [@{thm is_exec_frag_def}] 1 *})
+(* main case *)
+apply (auto simp add: trans_of_defs2)
+done
+
+
+(* --------------------------------------------------------------------- *)
+(*  Lemma_1_1b : is_ex_fr (A||B) implies stuttering on Projections       *)
+(* --------------------------------------------------------------------- *)
+
+lemma lemma_1_1b: "!s. is_exec_frag (A||B) (s,xs)
+       --> stutter (asig_of A) (fst s,ProjA2$xs)  &
+           stutter (asig_of B) (snd s,ProjB2$xs)"
+
+apply (tactic {* pair_induct_tac @{context} "xs"
+  [@{thm stutter_def}, @{thm is_exec_frag_def}] 1 *})
+(* main case *)
+apply (auto simp add: trans_of_defs2)
+done
+
+
+(* --------------------------------------------------------------------- *)
+(*  Lemma_1_1c : Executions of A||B have only  A- or B-actions           *)
+(* --------------------------------------------------------------------- *)
+
+lemma lemma_1_1c: "!s. (is_exec_frag (A||B) (s,xs)
+   --> Forall (%x. fst x:act (A||B)) xs)"
+
+apply (tactic {* pair_induct_tac @{context} "xs" [@{thm Forall_def}, @{thm sforall_def},
+  @{thm is_exec_frag_def}] 1 *})
+(* main case *)
+apply auto
+apply (simp add: trans_of_defs2 actions_asig_comp asig_of_par)
+done
+
+
+(* ----------------------------------------------------------------------- *)
+(*  Lemma_1_2 : ex A, exB, stuttering and forall a:A|B implies ex (A||B)   *)
+(* ----------------------------------------------------------------------- *)
+
+lemma lemma_1_2:
+"!s. is_exec_frag A (fst s,Filter_ex2 (asig_of A)$(ProjA2$xs)) &
+     is_exec_frag B (snd s,Filter_ex2 (asig_of B)$(ProjB2$xs)) &
+     stutter (asig_of A) (fst s,(ProjA2$xs)) &
+     stutter (asig_of B) (snd s,(ProjB2$xs)) &
+     Forall (%x. fst x:act (A||B)) xs
+     --> is_exec_frag (A||B) (s,xs)"
+
+apply (tactic {* pair_induct_tac @{context} "xs" [@{thm Forall_def}, @{thm sforall_def},
+  @{thm is_exec_frag_def}, @{thm stutter_def}] 1 *})
+apply (auto simp add: trans_of_defs1 actions_asig_comp asig_of_par)
+done
+
+
+subsection {* COMPOSITIONALITY on EXECUTION Level -- Main Theorem *}
+
+lemma compositionality_ex:
+"(ex:executions(A||B)) =
+ (Filter_ex (asig_of A) (ProjA ex) : executions A &
+  Filter_ex (asig_of B) (ProjB ex) : executions B &
+  stutter (asig_of A) (ProjA ex) & stutter (asig_of B) (ProjB ex) &
+  Forall (%x. fst x:act (A||B)) (snd ex))"
+
+apply (simp (no_asm) add: executions_def ProjB_def Filter_ex_def ProjA_def starts_of_par)
+apply (tactic {* pair_tac @{context} "ex" 1 *})
+apply (rule iffI)
+(* ==>  *)
+apply (erule conjE)+
+apply (simp add: lemma_1_1a lemma_1_1b lemma_1_1c)
+(* <==  *)
+apply (erule conjE)+
+apply (simp add: lemma_1_2)
+done
+
+
+subsection {* COMPOSITIONALITY on EXECUTION Level -- for Modules *}
+
+lemma compositionality_ex_modules:
+  "Execs (A||B) = par_execs (Execs A) (Execs B)"
+apply (unfold Execs_def par_execs_def)
+apply (simp add: asig_of_par)
+apply (rule set_eqI)
+apply (simp add: compositionality_ex actions_of_par)
+done
+
+end

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/HOLCF/IOA/meta_theory/CompoScheds.thy	Sat Nov 27 16:08:10 2010 -0800
@@ -0,0 +1,553 @@
+(*  Title:      HOLCF/IOA/meta_theory/CompoScheds.thy
+    Author:     Olaf Müller
+*)
+
+header {* Compositionality on Schedule level *}
+
+theory CompoScheds
+imports CompoExecs
+begin
+
+definition
+  mkex2 :: "('a,'s)ioa => ('a,'t)ioa => 'a Seq ->
+              ('a,'s)pairs -> ('a,'t)pairs ->
+              ('s => 't => ('a,'s*'t)pairs)" where
+  "mkex2 A B = (fix$(LAM h sch exA exB. (%s t. case sch of
+       nil => nil
+    | x##xs =>
+      (case x of
+        UU => UU
+      | Def y =>
+         (if y:act A then
+             (if y:act B then
+                (case HD$exA of
+                   UU => UU
+                 | Def a => (case HD$exB of
+                              UU => UU
+                            | Def b =>
+                   (y,(snd a,snd b))>>
+                     (h$xs$(TL$exA)$(TL$exB)) (snd a) (snd b)))
+              else
+                (case HD$exA of
+                   UU => UU
+                 | Def a =>
+                   (y,(snd a,t))>>(h$xs$(TL$exA)$exB) (snd a) t)
+              )
+          else
+             (if y:act B then
+                (case HD$exB of
+                   UU => UU
+                 | Def b =>
+                   (y,(s,snd b))>>(h$xs$exA$(TL$exB)) s (snd b))
+             else
+               UU
+             )
+         )
+       ))))"
+
+definition
+  mkex :: "('a,'s)ioa => ('a,'t)ioa => 'a Seq =>
+              ('a,'s)execution => ('a,'t)execution =>('a,'s*'t)execution" where
+  "mkex A B sch exA exB =
+       ((fst exA,fst exB),
+        (mkex2 A B$sch$(snd exA)$(snd exB)) (fst exA) (fst exB))"
+
+definition
+  par_scheds ::"['a schedule_module,'a schedule_module] => 'a schedule_module" where
+  "par_scheds SchedsA SchedsB =
+      (let schA = fst SchedsA; sigA = snd SchedsA;
+           schB = fst SchedsB; sigB = snd SchedsB
+       in
+       (    {sch. Filter (%a. a:actions sigA)$sch : schA}
+        Int {sch. Filter (%a. a:actions sigB)$sch : schB}
+        Int {sch. Forall (%x. x:(actions sigA Un actions sigB)) sch},
+        asig_comp sigA sigB))"
+
+
+subsection "mkex rewrite rules"
+
+
+lemma mkex2_unfold:
+"mkex2 A B = (LAM sch exA exB. (%s t. case sch of
+      nil => nil
+   | x##xs =>
+     (case x of
+       UU => UU
+     | Def y =>
+        (if y:act A then
+            (if y:act B then
+               (case HD$exA of
+                  UU => UU
+                | Def a => (case HD$exB of
+                             UU => UU
+                           | Def b =>
+                  (y,(snd a,snd b))>>
+                    (mkex2 A B$xs$(TL$exA)$(TL$exB)) (snd a) (snd b)))
+             else
+               (case HD$exA of
+                  UU => UU
+                | Def a =>
+                  (y,(snd a,t))>>(mkex2 A B$xs$(TL$exA)$exB) (snd a) t)
+             )
+         else
+            (if y:act B then
+               (case HD$exB of
+                  UU => UU
+                | Def b =>
+                  (y,(s,snd b))>>(mkex2 A B$xs$exA$(TL$exB)) s (snd b))
+            else
+              UU
+            )
+        )
+      )))"
+apply (rule trans)
+apply (rule fix_eq2)
+apply (simp only: mkex2_def)
+apply (rule beta_cfun)
+apply simp
+done
+
+lemma mkex2_UU: "(mkex2 A B$UU$exA$exB) s t = UU"
+apply (subst mkex2_unfold)
+apply simp
+done
+
+lemma mkex2_nil: "(mkex2 A B$nil$exA$exB) s t= nil"
+apply (subst mkex2_unfold)
+apply simp
+done
+
+lemma mkex2_cons_1: "[| x:act A; x~:act B; HD$exA=Def a|]
+    ==> (mkex2 A B$(x>>sch)$exA$exB) s t =
+        (x,snd a,t) >> (mkex2 A B$sch$(TL$exA)$exB) (snd a) t"
+apply (rule trans)
+apply (subst mkex2_unfold)
+apply (simp add: Consq_def If_and_if)
+apply (simp add: Consq_def)
+done
+
+lemma mkex2_cons_2: "[| x~:act A; x:act B; HD$exB=Def b|]
+    ==> (mkex2 A B$(x>>sch)$exA$exB) s t =
+        (x,s,snd b) >> (mkex2 A B$sch$exA$(TL$exB)) s (snd b)"
+apply (rule trans)
+apply (subst mkex2_unfold)
+apply (simp add: Consq_def If_and_if)
+apply (simp add: Consq_def)
+done
+
+lemma mkex2_cons_3: "[| x:act A; x:act B; HD$exA=Def a;HD$exB=Def b|]
+    ==> (mkex2 A B$(x>>sch)$exA$exB) s t =
+         (x,snd a,snd b) >>
+            (mkex2 A B$sch$(TL$exA)$(TL$exB)) (snd a) (snd b)"
+apply (rule trans)
+apply (subst mkex2_unfold)
+apply (simp add: Consq_def If_and_if)
+apply (simp add: Consq_def)
+done
+
+declare mkex2_UU [simp] mkex2_nil [simp] mkex2_cons_1 [simp]
+  mkex2_cons_2 [simp] mkex2_cons_3 [simp]
+
+
+subsection {* mkex *}
+
+lemma mkex_UU: "mkex A B UU  (s,exA) (t,exB) = ((s,t),UU)"
+apply (simp add: mkex_def)
+done
+
+lemma mkex_nil: "mkex A B nil (s,exA) (t,exB) = ((s,t),nil)"
+apply (simp add: mkex_def)
+done
+
+lemma mkex_cons_1: "[| x:act A; x~:act B |]
+    ==> mkex A B (x>>sch) (s,a>>exA) (t,exB)  =
+        ((s,t), (x,snd a,t) >> snd (mkex A B sch (snd a,exA) (t,exB)))"
+apply (simp (no_asm) add: mkex_def)
+apply (cut_tac exA = "a>>exA" in mkex2_cons_1)
+apply auto
+done
+
+lemma mkex_cons_2: "[| x~:act A; x:act B |]
+    ==> mkex A B (x>>sch) (s,exA) (t,b>>exB) =
+        ((s,t), (x,s,snd b) >> snd (mkex A B sch (s,exA) (snd b,exB)))"
+apply (simp (no_asm) add: mkex_def)
+apply (cut_tac exB = "b>>exB" in mkex2_cons_2)
+apply auto
+done
+
+lemma mkex_cons_3: "[| x:act A; x:act B |]
+    ==>  mkex A B (x>>sch) (s,a>>exA) (t,b>>exB) =
+         ((s,t), (x,snd a,snd b) >> snd (mkex A B sch (snd a,exA) (snd b,exB)))"
+apply (simp (no_asm) add: mkex_def)
+apply (cut_tac exB = "b>>exB" and exA = "a>>exA" in mkex2_cons_3)
+apply auto
+done
+
+declare mkex2_UU [simp del] mkex2_nil [simp del]
+  mkex2_cons_1 [simp del] mkex2_cons_2 [simp del] mkex2_cons_3 [simp del]
+
+lemmas composch_simps = mkex_UU mkex_nil mkex_cons_1 mkex_cons_2 mkex_cons_3
+
+declare composch_simps [simp]
+
+
+subsection {* COMPOSITIONALITY on SCHEDULE Level *}
+
+subsubsection "Lemmas for ==>"
+
+(* --------------------------------------------------------------------- *)
+(*    Lemma_2_1 :  tfilter(ex) and filter_act are commutative            *)
+(* --------------------------------------------------------------------- *)
+
+lemma lemma_2_1a:
+   "filter_act$(Filter_ex2 (asig_of A)$xs)=
+    Filter (%a. a:act A)$(filter_act$xs)"
+
+apply (unfold filter_act_def Filter_ex2_def)
+apply (simp (no_asm) add: MapFilter o_def)
+done
+
+
+(* --------------------------------------------------------------------- *)
+(*    Lemma_2_2 : State-projections do not affect filter_act             *)
+(* --------------------------------------------------------------------- *)
+
+lemma lemma_2_1b:
+   "filter_act$(ProjA2$xs) =filter_act$xs &
+    filter_act$(ProjB2$xs) =filter_act$xs"
+apply (tactic {* pair_induct_tac @{context} "xs" [] 1 *})
+done
+
+
+(* --------------------------------------------------------------------- *)
+(*             Schedules of A||B have only  A- or B-actions              *)
+(* --------------------------------------------------------------------- *)
+
+(* very similar to lemma_1_1c, but it is not checking if every action element of
+   an ex is in A or B, but after projecting it onto the action schedule. Of course, this
+   is the same proposition, but we cannot change this one, when then rather lemma_1_1c  *)
+
+lemma sch_actions_in_AorB: "!s. is_exec_frag (A||B) (s,xs)
+   --> Forall (%x. x:act (A||B)) (filter_act$xs)"
+
+apply (tactic {* pair_induct_tac @{context} "xs" [@{thm is_exec_frag_def}, @{thm Forall_def},
+  @{thm sforall_def}] 1 *})
+(* main case *)
+apply auto
+apply (simp add: trans_of_defs2 actions_asig_comp asig_of_par)
+done
+
+
+subsubsection "Lemmas for <=="
+
+(*---------------------------------------------------------------------------
+    Filtering actions out of mkex(sch,exA,exB) yields the oracle sch
+                             structural induction
+  --------------------------------------------------------------------------- *)
+
+lemma Mapfst_mkex_is_sch: "! exA exB s t.
+  Forall (%x. x:act (A||B)) sch  &
+  Filter (%a. a:act A)$sch << filter_act$exA &
+  Filter (%a. a:act B)$sch << filter_act$exB
+  --> filter_act$(snd (mkex A B sch (s,exA) (t,exB))) = sch"
+
+apply (tactic {* Seq_induct_tac @{context} "sch" [@{thm Filter_def}, @{thm Forall_def},
+  @{thm sforall_def}, @{thm mkex_def}] 1 *})
+
+(* main case *)
+(* splitting into 4 cases according to a:A, a:B *)
+apply auto
+
+(* Case y:A, y:B *)
+apply (tactic {* Seq_case_simp_tac @{context} "exA" 1 *})
+(* Case exA=UU, Case exA=nil*)
+(* These UU and nil cases are the only places where the assumption filter A sch<<f_act exA
+   is used! --> to generate a contradiction using  ~a>>ss<< UU(nil), using theorems
+   Cons_not_less_UU and Cons_not_less_nil  *)
+apply (tactic {* Seq_case_simp_tac @{context} "exB" 1 *})
+(* Case exA=a>>x, exB=b>>y *)
+(* here it is important that Seq_case_simp_tac uses no !full!_simp_tac for the cons case,
+   as otherwise mkex_cons_3 would  not be rewritten without use of rotate_tac: then tactic
+   would not be generally applicable *)
+apply simp
+
+(* Case y:A, y~:B *)
+apply (tactic {* Seq_case_simp_tac @{context} "exA" 1 *})
+apply simp
+
+(* Case y~:A, y:B *)
+apply (tactic {* Seq_case_simp_tac @{context} "exB" 1 *})
+apply simp
+
+(* Case y~:A, y~:B *)
+apply (simp add: asig_of_par actions_asig_comp)
+done
+
+
+(* generalizing the proof above to a tactic *)
+
+ML {*
+
+local
+  val defs = [@{thm Filter_def}, @{thm Forall_def}, @{thm sforall_def}, @{thm mkex_def},
+    @{thm stutter_def}]
+  val asigs = [@{thm asig_of_par}, @{thm actions_asig_comp}]
+in
+
+fun mkex_induct_tac ctxt sch exA exB =
+  let val ss = simpset_of ctxt in
+    EVERY1[Seq_induct_tac ctxt sch defs,
+           asm_full_simp_tac ss,
+           SELECT_GOAL (safe_tac (global_claset_of @{theory Fun})),
+           Seq_case_simp_tac ctxt exA,
+           Seq_case_simp_tac ctxt exB,
+           asm_full_simp_tac ss,
+           Seq_case_simp_tac ctxt exA,
+           asm_full_simp_tac ss,
+           Seq_case_simp_tac ctxt exB,
+           asm_full_simp_tac ss,
+           asm_full_simp_tac (ss addsimps asigs)
+          ]
+  end
+
+end
+*}
+
+
+(*---------------------------------------------------------------------------
+               Projection of mkex(sch,exA,exB) onto A stutters on A
+                             structural induction
+  --------------------------------------------------------------------------- *)
+
+lemma stutterA_mkex: "! exA exB s t.
+  Forall (%x. x:act (A||B)) sch &
+  Filter (%a. a:act A)$sch << filter_act$exA &
+  Filter (%a. a:act B)$sch << filter_act$exB
+  --> stutter (asig_of A) (s,ProjA2$(snd (mkex A B sch (s,exA) (t,exB))))"
+
+apply (tactic {* mkex_induct_tac @{context} "sch" "exA" "exB" *})
+done
+
+
+lemma stutter_mkex_on_A: "[|
+  Forall (%x. x:act (A||B)) sch ;
+  Filter (%a. a:act A)$sch << filter_act$(snd exA) ;
+  Filter (%a. a:act B)$sch << filter_act$(snd exB) |]
+  ==> stutter (asig_of A) (ProjA (mkex A B sch exA exB))"
+
+apply (cut_tac stutterA_mkex)
+apply (simp add: stutter_def ProjA_def mkex_def)
+apply (erule allE)+
+apply (drule mp)
+prefer 2 apply (assumption)
+apply simp
+done
+
+
+(*---------------------------------------------------------------------------
+               Projection of mkex(sch,exA,exB) onto B stutters on B
+                             structural induction
+  --------------------------------------------------------------------------- *)
+
+lemma stutterB_mkex: "! exA exB s t.
+  Forall (%x. x:act (A||B)) sch &
+  Filter (%a. a:act A)$sch << filter_act$exA &
+  Filter (%a. a:act B)$sch << filter_act$exB
+  --> stutter (asig_of B) (t,ProjB2$(snd (mkex A B sch (s,exA) (t,exB))))"
+apply (tactic {* mkex_induct_tac @{context} "sch" "exA" "exB" *})
+done
+
+
+lemma stutter_mkex_on_B: "[|
+  Forall (%x. x:act (A||B)) sch ;
+  Filter (%a. a:act A)$sch << filter_act$(snd exA) ;
+  Filter (%a. a:act B)$sch << filter_act$(snd exB) |]
+  ==> stutter (asig_of B) (ProjB (mkex A B sch exA exB))"
+apply (cut_tac stutterB_mkex)
+apply (simp add: stutter_def ProjB_def mkex_def)
+apply (erule allE)+
+apply (drule mp)
+prefer 2 apply (assumption)
+apply simp
+done
+
+
+(*---------------------------------------------------------------------------
+     Filter of mkex(sch,exA,exB) to A after projection onto A is exA
+        --  using zip$(proj1$exA)$(proj2$exA) instead of exA    --
+        --           because of admissibility problems          --
+                             structural induction
+  --------------------------------------------------------------------------- *)
+
+lemma filter_mkex_is_exA_tmp: "! exA exB s t.
+  Forall (%x. x:act (A||B)) sch &
+  Filter (%a. a:act A)$sch << filter_act$exA  &
+  Filter (%a. a:act B)$sch << filter_act$exB
+  --> Filter_ex2 (asig_of A)$(ProjA2$(snd (mkex A B sch (s,exA) (t,exB)))) =
+      Zip$(Filter (%a. a:act A)$sch)$(Map snd$exA)"
+apply (tactic {* mkex_induct_tac @{context} "sch" "exB" "exA" *})
+done
+
+(*---------------------------------------------------------------------------
+                      zip$(proj1$y)$(proj2$y) = y   (using the lift operations)
+                    lemma for admissibility problems
+  --------------------------------------------------------------------------- *)
+
+lemma Zip_Map_fst_snd: "Zip$(Map fst$y)$(Map snd$y) = y"
+apply (tactic {* Seq_induct_tac @{context} "y" [] 1 *})
+done
+
+
+(*---------------------------------------------------------------------------
+      filter A$sch = proj1$ex   -->  zip$(filter A$sch)$(proj2$ex) = ex
+         lemma for eliminating non admissible equations in assumptions
+  --------------------------------------------------------------------------- *)
+
+lemma trick_against_eq_in_ass: "!! sch ex.
+  Filter (%a. a:act AB)$sch = filter_act$ex
+  ==> ex = Zip$(Filter (%a. a:act AB)$sch)$(Map snd$ex)"
+apply (simp add: filter_act_def)
+apply (rule Zip_Map_fst_snd [symmetric])
+done
+
+(*---------------------------------------------------------------------------
+     Filter of mkex(sch,exA,exB) to A after projection onto A is exA
+                       using the above trick
+  --------------------------------------------------------------------------- *)
+
+
+lemma filter_mkex_is_exA: "!!sch exA exB.
+  [| Forall (%a. a:act (A||B)) sch ;
+  Filter (%a. a:act A)$sch = filter_act$(snd exA)  ;
+  Filter (%a. a:act B)$sch = filter_act$(snd exB) |]
+  ==> Filter_ex (asig_of A) (ProjA (mkex A B sch exA exB)) = exA"
+apply (simp add: ProjA_def Filter_ex_def)
+apply (tactic {* pair_tac @{context} "exA" 1 *})
+apply (tactic {* pair_tac @{context} "exB" 1 *})
+apply (rule conjI)
+apply (simp (no_asm) add: mkex_def)
+apply (simplesubst trick_against_eq_in_ass)
+back
+apply assumption
+apply (simp add: filter_mkex_is_exA_tmp)
+done
+
+
+(*---------------------------------------------------------------------------
+     Filter of mkex(sch,exA,exB) to B after projection onto B is exB
+        --  using zip$(proj1$exB)$(proj2$exB) instead of exB    --
+        --           because of admissibility problems          --
+                             structural induction
+  --------------------------------------------------------------------------- *)
+
+lemma filter_mkex_is_exB_tmp: "! exA exB s t.
+  Forall (%x. x:act (A||B)) sch &
+  Filter (%a. a:act A)$sch << filter_act$exA  &
+  Filter (%a. a:act B)$sch << filter_act$exB
+  --> Filter_ex2 (asig_of B)$(ProjB2$(snd (mkex A B sch (s,exA) (t,exB)))) =
+      Zip$(Filter (%a. a:act B)$sch)$(Map snd$exB)"
+
+(* notice necessary change of arguments exA and exB *)
+apply (tactic {* mkex_induct_tac @{context} "sch" "exA" "exB" *})
+done
+
+
+(*---------------------------------------------------------------------------
+     Filter of mkex(sch,exA,exB) to A after projection onto B is exB
+                       using the above trick
+  --------------------------------------------------------------------------- *)
+
+
+lemma filter_mkex_is_exB: "!!sch exA exB.
+  [| Forall (%a. a:act (A||B)) sch ;
+  Filter (%a. a:act A)$sch = filter_act$(snd exA)  ;
+  Filter (%a. a:act B)$sch = filter_act$(snd exB) |]
+  ==> Filter_ex (asig_of B) (ProjB (mkex A B sch exA exB)) = exB"
+apply (simp add: ProjB_def Filter_ex_def)
+apply (tactic {* pair_tac @{context} "exA" 1 *})
+apply (tactic {* pair_tac @{context} "exB" 1 *})
+apply (rule conjI)
+apply (simp (no_asm) add: mkex_def)
+apply (simplesubst trick_against_eq_in_ass)
+back
+apply assumption
+apply (simp add: filter_mkex_is_exB_tmp)
+done
+
+(* --------------------------------------------------------------------- *)
+(*                    mkex has only  A- or B-actions                    *)
+(* --------------------------------------------------------------------- *)
+
+
+lemma mkex_actions_in_AorB: "!s t exA exB.
+  Forall (%x. x : act (A || B)) sch &
+  Filter (%a. a:act A)$sch << filter_act$exA  &
+  Filter (%a. a:act B)$sch << filter_act$exB
+   --> Forall (%x. fst x : act (A ||B))
+         (snd (mkex A B sch (s,exA) (t,exB)))"
+apply (tactic {* mkex_induct_tac @{context} "sch" "exA" "exB" *})
+done
+
+
+(* ------------------------------------------------------------------ *)
+(*           COMPOSITIONALITY   on    SCHEDULE      Level             *)
+(*                          Main Theorem                              *)
+(* ------------------------------------------------------------------ *)
+
+lemma compositionality_sch:
+"(sch : schedules (A||B)) =
+  (Filter (%a. a:act A)$sch : schedules A &
+   Filter (%a. a:act B)$sch : schedules B &
+   Forall (%x. x:act (A||B)) sch)"
+apply (simp (no_asm) add: schedules_def has_schedule_def)
+apply auto
+(* ==> *)
+apply (rule_tac x = "Filter_ex (asig_of A) (ProjA ex) " in bexI)
+prefer 2
+apply (simp add: compositionality_ex)
+apply (simp (no_asm) add: Filter_ex_def ProjA_def lemma_2_1a lemma_2_1b)
+apply (rule_tac x = "Filter_ex (asig_of B) (ProjB ex) " in bexI)
+prefer 2
+apply (simp add: compositionality_ex)
+apply (simp (no_asm) add: Filter_ex_def ProjB_def lemma_2_1a lemma_2_1b)
+apply (simp add: executions_def)
+apply (tactic {* pair_tac @{context} "ex" 1 *})
+apply (erule conjE)
+apply (simp add: sch_actions_in_AorB)
+
+(* <== *)
+
+(* mkex is exactly the construction of exA||B out of exA, exB, and the oracle sch,
+   we need here *)
+apply (rename_tac exA exB)
+apply (rule_tac x = "mkex A B sch exA exB" in bexI)
+(* mkex actions are just the oracle *)
+apply (tactic {* pair_tac @{context} "exA" 1 *})
+apply (tactic {* pair_tac @{context} "exB" 1 *})
+apply (simp add: Mapfst_mkex_is_sch)
+
+(* mkex is an execution -- use compositionality on ex-level *)
+apply (simp add: compositionality_ex)
+apply (simp add: stutter_mkex_on_A stutter_mkex_on_B filter_mkex_is_exB filter_mkex_is_exA)
+apply (tactic {* pair_tac @{context} "exA" 1 *})
+apply (tactic {* pair_tac @{context} "exB" 1 *})
+apply (simp add: mkex_actions_in_AorB)
+done
+
+
+subsection {* COMPOSITIONALITY on SCHEDULE Level -- for Modules *}
+
+lemma compositionality_sch_modules:
+  "Scheds (A||B) = par_scheds (Scheds A) (Scheds B)"
+
+apply (unfold Scheds_def par_scheds_def)
+apply (simp add: asig_of_par)
+apply (rule set_eqI)
+apply (simp add: compositionality_sch actions_of_par)
+done
+
+
+declare compoex_simps [simp del]
+declare composch_simps [simp del]
+
+end

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/HOLCF/IOA/meta_theory/CompoTraces.thy	Sat Nov 27 16:08:10 2010 -0800
@@ -0,0 +1,973 @@
+(*  Title:      HOLCF/IOA/meta_theory/CompoTraces.thy
+    Author:     Olaf Müller
+*) 
+
+header {* Compositionality on Trace level *}
+
+theory CompoTraces
+imports CompoScheds ShortExecutions
+begin
+ 
+
+consts  
+
+ mksch      ::"('a,'s)ioa => ('a,'t)ioa => 'a Seq -> 'a Seq -> 'a Seq -> 'a Seq" 
+ par_traces ::"['a trace_module,'a trace_module] => 'a trace_module"
+
+defs
+
+mksch_def:
+  "mksch A B == (fix$(LAM h tr schA schB. case tr of 
+       nil => nil
+    | x##xs => 
+      (case x of 
+        UU => UU
+      | Def y => 
+         (if y:act A then 
+             (if y:act B then 
+                   ((Takewhile (%a. a:int A)$schA)
+                      @@ (Takewhile (%a. a:int B)$schB)
+                           @@ (y>>(h$xs
+                                    $(TL$(Dropwhile (%a. a:int A)$schA))
+                                    $(TL$(Dropwhile (%a. a:int B)$schB))
+                    )))
+              else
+                 ((Takewhile (%a. a:int A)$schA)
+                  @@ (y>>(h$xs
+                           $(TL$(Dropwhile (%a. a:int A)$schA))
+                           $schB)))
+              )
+          else 
+             (if y:act B then 
+                 ((Takewhile (%a. a:int B)$schB)
+                     @@ (y>>(h$xs
+                              $schA
+                              $(TL$(Dropwhile (%a. a:int B)$schB))
+                              )))
+             else
+               UU
+             )
+         )
+       )))"
+
+
+par_traces_def:
+  "par_traces TracesA TracesB == 
+       let trA = fst TracesA; sigA = snd TracesA; 
+           trB = fst TracesB; sigB = snd TracesB       
+       in
+       (    {tr. Filter (%a. a:actions sigA)$tr : trA}
+        Int {tr. Filter (%a. a:actions sigB)$tr : trB}
+        Int {tr. Forall (%x. x:(externals sigA Un externals sigB)) tr},
+        asig_comp sigA sigB)"
+
+axioms
+
+finiteR_mksch:
+  "Finite (mksch A B$tr$x$y) --> Finite tr"
+
+
+declaration {* fn _ => Simplifier.map_ss (fn ss => ss setmksym (K (K NONE))) *}
+
+
+subsection "mksch rewrite rules"
+
+lemma mksch_unfold:
+"mksch A B = (LAM tr schA schB. case tr of 
+       nil => nil
+    | x##xs => 
+      (case x of  
+        UU => UU  
+      | Def y => 
+         (if y:act A then 
+             (if y:act B then 
+                   ((Takewhile (%a. a:int A)$schA) 
+                         @@(Takewhile (%a. a:int B)$schB) 
+                              @@(y>>(mksch A B$xs   
+                                       $(TL$(Dropwhile (%a. a:int A)$schA))  
+                                       $(TL$(Dropwhile (%a. a:int B)$schB))  
+                    )))   
+              else  
+                 ((Takewhile (%a. a:int A)$schA)  
+                      @@ (y>>(mksch A B$xs  
+                              $(TL$(Dropwhile (%a. a:int A)$schA))  
+                              $schB)))  
+              )   
+          else    
+             (if y:act B then  
+                 ((Takewhile (%a. a:int B)$schB)  
+                       @@ (y>>(mksch A B$xs   
+                              $schA   
+                              $(TL$(Dropwhile (%a. a:int B)$schB))  
+                              )))  
+             else  
+               UU  
+             )  
+         )  
+       ))"
+apply (rule trans)
+apply (rule fix_eq2)
+apply (rule mksch_def)
+apply (rule beta_cfun)
+apply simp
+done
+
+lemma mksch_UU: "mksch A B$UU$schA$schB = UU"
+apply (subst mksch_unfold)
+apply simp
+done
+
+lemma mksch_nil: "mksch A B$nil$schA$schB = nil"
+apply (subst mksch_unfold)
+apply simp
+done
+
+lemma mksch_cons1: "[|x:act A;x~:act B|]   
+    ==> mksch A B$(x>>tr)$schA$schB =  
+          (Takewhile (%a. a:int A)$schA)  
+          @@ (x>>(mksch A B$tr$(TL$(Dropwhile (%a. a:int A)$schA))  
+                              $schB))"
+apply (rule trans)
+apply (subst mksch_unfold)
+apply (simp add: Consq_def If_and_if)
+apply (simp add: Consq_def)
+done
+
+lemma mksch_cons2: "[|x~:act A;x:act B|]  
+    ==> mksch A B$(x>>tr)$schA$schB =  
+         (Takewhile (%a. a:int B)$schB)   
+          @@ (x>>(mksch A B$tr$schA$(TL$(Dropwhile (%a. a:int B)$schB))   
+                             ))"
+apply (rule trans)
+apply (subst mksch_unfold)
+apply (simp add: Consq_def If_and_if)
+apply (simp add: Consq_def)
+done
+
+lemma mksch_cons3: "[|x:act A;x:act B|]  
+    ==> mksch A B$(x>>tr)$schA$schB =  
+             (Takewhile (%a. a:int A)$schA)  
+          @@ ((Takewhile (%a. a:int B)$schB)   
+          @@ (x>>(mksch A B$tr$(TL$(Dropwhile (%a. a:int A)$schA))  
+                             $(TL$(Dropwhile (%a. a:int B)$schB))))   
+              )"
+apply (rule trans)
+apply (subst mksch_unfold)
+apply (simp add: Consq_def If_and_if)
+apply (simp add: Consq_def)
+done
+
+lemmas compotr_simps = mksch_UU mksch_nil mksch_cons1 mksch_cons2 mksch_cons3
+
+declare compotr_simps [simp]
+
+
+subsection {* COMPOSITIONALITY on TRACE Level *}
+
+subsubsection "Lemmata for ==>"
+
+(* Consequence out of ext1_ext2_is_not_act1(2), which in turn are consequences out of
+   the compatibility of IOA, in particular out of the condition that internals are
+   really hidden. *)
+
+lemma compatibility_consequence1: "(eB & ~eA --> ~A) -->        
+          (A & (eA | eB)) = (eA & A)"
+apply fast
+done
+
+
+(* very similar to above, only the commutativity of | is used to make a slight change *)
+
+lemma compatibility_consequence2: "(eB & ~eA --> ~A) -->        
+          (A & (eB | eA)) = (eA & A)"
+apply fast
+done
+
+
+subsubsection "Lemmata for <=="
+
+(* Lemma for substitution of looping assumption in another specific assumption *)
+lemma subst_lemma1: "[| f << (g x) ; x=(h x) |] ==> f << g (h x)"
+by (erule subst)
+
+(* Lemma for substitution of looping assumption in another specific assumption *)
+lemma subst_lemma2: "[| (f x) = y >> g; x=(h x) |] ==> (f (h x)) = y >> g"
+by (erule subst)
+
+lemma ForallAorB_mksch [rule_format]:
+  "!!A B. compatible A B ==>  
+    ! schA schB. Forall (%x. x:act (A||B)) tr  
+    --> Forall (%x. x:act (A||B)) (mksch A B$tr$schA$schB)"
+apply (tactic {* Seq_induct_tac @{context} "tr"
+  [@{thm Forall_def}, @{thm sforall_def}, @{thm mksch_def}] 1 *})
+apply auto
+apply (simp add: actions_of_par)
+apply (case_tac "a:act A")
+apply (case_tac "a:act B")
+(* a:A, a:B *)
+apply simp
+apply (rule Forall_Conc_impl [THEN mp])
+apply (simp add: intA_is_not_actB int_is_act)
+apply (rule Forall_Conc_impl [THEN mp])
+apply (simp add: intA_is_not_actB int_is_act)
+(* a:A,a~:B *)
+apply simp
+apply (rule Forall_Conc_impl [THEN mp])
+apply (simp add: intA_is_not_actB int_is_act)
+apply (case_tac "a:act B")
+(* a~:A, a:B *)
+apply simp
+apply (rule Forall_Conc_impl [THEN mp])
+apply (simp add: intA_is_not_actB int_is_act)
+(* a~:A,a~:B *)
+apply auto
+done
+
+lemma ForallBnAmksch [rule_format (no_asm)]: "!!A B. compatible B A  ==>  
+    ! schA schB.  (Forall (%x. x:act B & x~:act A) tr  
+    --> Forall (%x. x:act B & x~:act A) (mksch A B$tr$schA$schB))"
+apply (tactic {* Seq_induct_tac @{context} "tr"
+  [@{thm Forall_def}, @{thm sforall_def}, @{thm mksch_def}] 1 *})
+apply auto
+apply (rule Forall_Conc_impl [THEN mp])
+apply (simp add: intA_is_not_actB int_is_act)
+done
+
+lemma ForallAnBmksch [rule_format (no_asm)]: "!!A B. compatible A B ==>  
+    ! schA schB.  (Forall (%x. x:act A & x~:act B) tr  
+    --> Forall (%x. x:act A & x~:act B) (mksch A B$tr$schA$schB))"
+apply (tactic {* Seq_induct_tac @{context} "tr"
+  [@{thm Forall_def}, @{thm sforall_def}, @{thm mksch_def}] 1 *})
+apply auto
+apply (rule Forall_Conc_impl [THEN mp])
+apply (simp add: intA_is_not_actB int_is_act)
+done
+
+(* safe-tac makes too many case distinctions with this lemma in the next proof *)
+declare FiniteConc [simp del]
+
+lemma FiniteL_mksch [rule_format (no_asm)]: "[| Finite tr; is_asig(asig_of A); is_asig(asig_of B) |] ==>  
+    ! x y. Forall (%x. x:act A) x & Forall (%x. x:act B) y &  
+           Filter (%a. a:ext A)$x = Filter (%a. a:act A)$tr &  
+           Filter (%a. a:ext B)$y = Filter (%a. a:act B)$tr & 
+           Forall (%x. x:ext (A||B)) tr  
+           --> Finite (mksch A B$tr$x$y)"
+
+apply (erule Seq_Finite_ind)
+apply simp
+(* main case *)
+apply simp
+apply auto
+
+(* a: act A; a: act B *)
+apply (frule sym [THEN eq_imp_below, THEN divide_Seq])
+apply (frule sym [THEN eq_imp_below, THEN divide_Seq])
+back
+apply (erule conjE)+
+(* Finite (tw iA x) and Finite (tw iB y) *)
+apply (simp add: not_ext_is_int_or_not_act FiniteConc)
+(* now for conclusion IH applicable, but assumptions have to be transformed *)
+apply (drule_tac x = "x" and g = "Filter (%a. a:act A) $s" in subst_lemma2)
+apply assumption
+apply (drule_tac x = "y" and g = "Filter (%a. a:act B) $s" in subst_lemma2)
+apply assumption
+(* IH *)
+apply (simp add: not_ext_is_int_or_not_act ForallTL ForallDropwhile)
+
+(* a: act B; a~: act A *)
+apply (frule sym [THEN eq_imp_below, THEN divide_Seq])
+
+apply (erule conjE)+
+(* Finite (tw iB y) *)
+apply (simp add: not_ext_is_int_or_not_act FiniteConc)
+(* now for conclusion IH applicable, but assumptions have to be transformed *)
+apply (drule_tac x = "y" and g = "Filter (%a. a:act B) $s" in subst_lemma2)
+apply assumption
+(* IH *)
+apply (simp add: not_ext_is_int_or_not_act ForallTL ForallDropwhile)
+
+(* a~: act B; a: act A *)
+apply (frule sym [THEN eq_imp_below, THEN divide_Seq])
+
+apply (erule conjE)+
+(* Finite (tw iA x) *)
+apply (simp add: not_ext_is_int_or_not_act FiniteConc)
+(* now for conclusion IH applicable, but assumptions have to be transformed *)
+apply (drule_tac x = "x" and g = "Filter (%a. a:act A) $s" in subst_lemma2)
+apply assumption
+(* IH *)
+apply (simp add: not_ext_is_int_or_not_act ForallTL ForallDropwhile)
+
+(* a~: act B; a~: act A *)
+apply (fastsimp intro!: ext_is_act simp: externals_of_par)
+done
+
+declare FiniteConc [simp]
+
+declare FilterConc [simp del]
+
+lemma reduceA_mksch1 [rule_format (no_asm)]: " [| Finite bs; is_asig(asig_of A); is_asig(asig_of B);compatible A B|] ==>   
+ ! y. Forall (%x. x:act B) y & Forall (%x. x:act B & x~:act A) bs & 
+     Filter (%a. a:ext B)$y = Filter (%a. a:act B)$(bs @@ z)  
+     --> (? y1 y2.  (mksch A B$(bs @@ z)$x$y) = (y1 @@ (mksch A B$z$x$y2)) &  
+                    Forall (%x. x:act B & x~:act A) y1 &  
+                    Finite y1 & y = (y1 @@ y2) &  
+                    Filter (%a. a:ext B)$y1 = bs)"
+apply (frule_tac A1 = "A" in compat_commute [THEN iffD1])
+apply (erule Seq_Finite_ind)
+apply (rule allI)+
+apply (rule impI)
+apply (rule_tac x = "nil" in exI)
+apply (rule_tac x = "y" in exI)
+apply simp
+(* main case *)
+apply (rule allI)+
+apply (rule impI)
+apply simp
+apply (erule conjE)+
+apply simp
+(* divide_Seq on s *)
+apply (frule sym [THEN eq_imp_below, THEN divide_Seq])
+apply (erule conjE)+
+(* transform assumption f eB y = f B (s@z) *)
+apply (drule_tac x = "y" and g = "Filter (%a. a:act B) $ (s@@z) " in subst_lemma2)
+apply assumption
+apply (simp add: not_ext_is_int_or_not_act FilterConc)
+(* apply IH *)
+apply (erule_tac x = "TL$ (Dropwhile (%a. a:int B) $y) " in allE)
+apply (simp add: ForallTL ForallDropwhile FilterConc)
+apply (erule exE)+
+apply (erule conjE)+
+apply (simp add: FilterConc)
+(* for replacing IH in conclusion *)
+apply (rotate_tac -2)
+(* instantiate y1a and y2a *)
+apply (rule_tac x = "Takewhile (%a. a:int B) $y @@ a>>y1" in exI)
+apply (rule_tac x = "y2" in exI)
+(* elminate all obligations up to two depending on Conc_assoc *)
+apply (simp add: intA_is_not_actB int_is_act int_is_not_ext FilterConc)
+apply (simp (no_asm) add: Conc_assoc FilterConc)
+done
+
+lemmas reduceA_mksch = conjI [THEN [6] conjI [THEN [5] reduceA_mksch1]]
+
+lemma reduceB_mksch1 [rule_format]:
+" [| Finite a_s; is_asig(asig_of A); is_asig(asig_of B);compatible A B|] ==>   
+ ! x. Forall (%x. x:act A) x & Forall (%x. x:act A & x~:act B) a_s & 
+     Filter (%a. a:ext A)$x = Filter (%a. a:act A)$(a_s @@ z)  
+     --> (? x1 x2.  (mksch A B$(a_s @@ z)$x$y) = (x1 @@ (mksch A B$z$x2$y)) &  
+                    Forall (%x. x:act A & x~:act B) x1 &  
+                    Finite x1 & x = (x1 @@ x2) &  
+                    Filter (%a. a:ext A)$x1 = a_s)"
+apply (frule_tac A1 = "A" in compat_commute [THEN iffD1])
+apply (erule Seq_Finite_ind)
+apply (rule allI)+
+apply (rule impI)
+apply (rule_tac x = "nil" in exI)
+apply (rule_tac x = "x" in exI)
+apply simp
+(* main case *)
+apply (rule allI)+
+apply (rule impI)
+apply simp
+apply (erule conjE)+
+apply simp
+(* divide_Seq on s *)
+apply (frule sym [THEN eq_imp_below, THEN divide_Seq])
+apply (erule conjE)+
+(* transform assumption f eA x = f A (s@z) *)
+apply (drule_tac x = "x" and g = "Filter (%a. a:act A) $ (s@@z) " in subst_lemma2)
+apply assumption
+apply (simp add: not_ext_is_int_or_not_act FilterConc)
+(* apply IH *)
+apply (erule_tac x = "TL$ (Dropwhile (%a. a:int A) $x) " in allE)
+apply (simp add: ForallTL ForallDropwhile FilterConc)
+apply (erule exE)+
+apply (erule conjE)+
+apply (simp add: FilterConc)
+(* for replacing IH in conclusion *)
+apply (rotate_tac -2)
+(* instantiate y1a and y2a *)
+apply (rule_tac x = "Takewhile (%a. a:int A) $x @@ a>>x1" in exI)
+apply (rule_tac x = "x2" in exI)
+(* elminate all obligations up to two depending on Conc_assoc *)
+apply (simp add: intA_is_not_actB int_is_act int_is_not_ext FilterConc)
+apply (simp (no_asm) add: Conc_assoc FilterConc)
+done
+
+lemmas reduceB_mksch = conjI [THEN [6] conjI [THEN [5] reduceB_mksch1]]
+
+declare FilterConc [simp]
+
+
+subsection "Filtering external actions out of mksch(tr,schA,schB) yields the oracle tr"
+
+lemma FilterA_mksch_is_tr: 
+"!! A B. [| compatible A B; compatible B A; 
+            is_asig(asig_of A); is_asig(asig_of B) |] ==>  
+  ! schA schB. Forall (%x. x:act A) schA & Forall (%x. x:act B) schB &  
+  Forall (%x. x:ext (A||B)) tr &  
+  Filter (%a. a:act A)$tr << Filter (%a. a:ext A)$schA & 
+  Filter (%a. a:act B)$tr << Filter (%a. a:ext B)$schB   
+  --> Filter (%a. a:ext (A||B))$(mksch A B$tr$schA$schB) = tr"
+
+apply (tactic {* Seq_induct_tac @{context} "tr"
+  [@{thm Forall_def}, @{thm sforall_def}, @{thm mksch_def}] 1 *})
+(* main case *)
+(* splitting into 4 cases according to a:A, a:B *)
+apply auto
+
+(* Case a:A, a:B *)
+apply (frule divide_Seq)
+apply (frule divide_Seq)
+back
+apply (erule conjE)+
+(* filtering internals of A in schA and of B in schB is nil *)
+apply (simp add: not_ext_is_int_or_not_act externals_of_par intA_is_not_extB int_is_not_ext)
+(* conclusion of IH ok, but assumptions of IH have to be transformed *)
+apply (drule_tac x = "schA" in subst_lemma1)
+apply assumption
+apply (drule_tac x = "schB" in subst_lemma1)
+apply assumption
+(* IH *)
+apply (simp add: not_ext_is_int_or_not_act ForallTL ForallDropwhile)
+
+(* Case a:A, a~:B *)
+apply (frule divide_Seq)
+apply (erule conjE)+
+(* filtering internals of A is nil *)
+apply (simp add: not_ext_is_int_or_not_act externals_of_par intA_is_not_extB int_is_not_ext)
+apply (drule_tac x = "schA" in subst_lemma1)
+apply assumption
+apply (simp add: not_ext_is_int_or_not_act ForallTL ForallDropwhile)
+
+(* Case a:B, a~:A *)
+apply (frule divide_Seq)
+apply (erule conjE)+
+(* filtering internals of A is nil *)
+apply (simp add: not_ext_is_int_or_not_act externals_of_par intA_is_not_extB int_is_not_ext)
+apply (drule_tac x = "schB" in subst_lemma1)
+back
+apply assumption
+apply (simp add: not_ext_is_int_or_not_act ForallTL ForallDropwhile)
+
+(* Case a~:A, a~:B *)
+apply (fastsimp intro!: ext_is_act simp: externals_of_par)
+done
+
+
+subsection" Filter of mksch(tr,schA,schB) to A is schA -- take lemma proof"
+
+lemma FilterAmksch_is_schA: "!! A B. [| compatible A B; compatible B A;  
+  is_asig(asig_of A); is_asig(asig_of B) |] ==>  
+  Forall (%x. x:ext (A||B)) tr &  
+  Forall (%x. x:act A) schA & Forall (%x. x:act B) schB &  
+  Filter (%a. a:ext A)$schA = Filter (%a. a:act A)$tr & 
+  Filter (%a. a:ext B)$schB = Filter (%a. a:act B)$tr & 
+  LastActExtsch A schA & LastActExtsch B schB   
+  --> Filter (%a. a:act A)$(mksch A B$tr$schA$schB) = schA"
+apply (intro strip)
+apply (rule seq.take_lemma)
+apply (rule mp)
+prefer 2 apply assumption
+back back back back
+apply (rule_tac x = "schA" in spec)
+apply (rule_tac x = "schB" in spec)
+apply (rule_tac x = "tr" in spec)
+apply (tactic "thin_tac' 5 1")
+apply (rule nat_less_induct)
+apply (rule allI)+
+apply (rename_tac tr schB schA)
+apply (intro strip)
+apply (erule conjE)+
+
+apply (case_tac "Forall (%x. x:act B & x~:act A) tr")
+
+apply (rule seq_take_lemma [THEN iffD2, THEN spec])
+apply (tactic "thin_tac' 5 1")
+
+
+apply (case_tac "Finite tr")
+
+(* both sides of this equation are nil *)
+apply (subgoal_tac "schA=nil")
+apply (simp (no_asm_simp))
+(* first side: mksch = nil *)
+apply (auto intro!: ForallQFilterPnil ForallBnAmksch FiniteL_mksch)[1]
+(* second side: schA = nil *)
+apply (erule_tac A = "A" in LastActExtimplnil)
+apply (simp (no_asm_simp))
+apply (erule_tac Q = "%x. x:act B & x~:act A" in ForallQFilterPnil)
+apply assumption
+apply fast
+
+(* case ~ Finite s *)
+
+(* both sides of this equation are UU *)
+apply (subgoal_tac "schA=UU")
+apply (simp (no_asm_simp))
+(* first side: mksch = UU *)
+apply (auto intro!: ForallQFilterPUU finiteR_mksch [THEN mp, COMP rev_contrapos] ForallBnAmksch)[1]
+(* schA = UU *)
+apply (erule_tac A = "A" in LastActExtimplUU)
+apply (simp (no_asm_simp))
+apply (erule_tac Q = "%x. x:act B & x~:act A" in ForallQFilterPUU)
+apply assumption
+apply fast
+
+(* case" ~ Forall (%x.x:act B & x~:act A) s" *)
+
+apply (drule divide_Seq3)
+
+apply (erule exE)+
+apply (erule conjE)+
+apply hypsubst
+
+(* bring in lemma reduceA_mksch *)
+apply (frule_tac x = "schA" and y = "schB" and A = "A" and B = "B" in reduceA_mksch)
+apply assumption+
+apply (erule exE)+
+apply (erule conjE)+
+
+(* use reduceA_mksch to rewrite conclusion *)
+apply hypsubst
+apply simp
+
+(* eliminate the B-only prefix *)
+
+apply (subgoal_tac " (Filter (%a. a :act A) $y1) = nil")
+apply (erule_tac [2] ForallQFilterPnil)
+prefer 2 apply assumption
+prefer 2 apply fast
+
+(* Now real recursive step follows (in y) *)
+
+apply simp
+apply (case_tac "x:act A")
+apply (case_tac "x~:act B")
+apply (rotate_tac -2)
+apply simp
+
+apply (subgoal_tac "Filter (%a. a:act A & a:ext B) $y1=nil")
+apply (rotate_tac -1)
+apply simp
+(* eliminate introduced subgoal 2 *)
+apply (erule_tac [2] ForallQFilterPnil)
+prefer 2 apply assumption
+prefer 2 apply fast
+
+(* bring in divide Seq for s *)
+apply (frule sym [THEN eq_imp_below, THEN divide_Seq])
+apply (erule conjE)+
+
+(* subst divide_Seq in conclusion, but only at the righest occurence *)
+apply (rule_tac t = "schA" in ssubst)
+back
+back
+back
+apply assumption
+
+(* reduce trace_takes from n to strictly smaller k *)
+apply (rule take_reduction)
+
+(* f A (tw iA) = tw ~eA *)
+apply (simp add: int_is_act not_ext_is_int_or_not_act)
+apply (rule refl)
+apply (simp add: int_is_act not_ext_is_int_or_not_act)
+apply (rotate_tac -11)
+
+(* now conclusion fulfills induction hypothesis, but assumptions are not ready *)
+
+(* assumption Forall tr *)
+(* assumption schB *)
+apply (simp add: ext_and_act)
+(* assumption schA *)
+apply (drule_tac x = "schA" and g = "Filter (%a. a:act A) $rs" in subst_lemma2)
+apply assumption
+apply (simp add: int_is_not_ext)
+(* assumptions concerning LastActExtsch, cannot be rewritten, as LastActExtsmalli are looping  *)
+apply (drule_tac sch = "schA" and P = "%a. a:int A" in LastActExtsmall1)
+apply (frule_tac ?sch1.0 = "y1" in LastActExtsmall2)
+apply assumption
+
+(* assumption Forall schA *)
+apply (drule_tac s = "schA" and P = "Forall (%x. x:act A) " in subst)
+apply assumption
+apply (simp add: int_is_act)
+
+(* case x:actions(asig_of A) & x: actions(asig_of B) *)
+
+
+apply (rotate_tac -2)
+apply simp
+
+apply (subgoal_tac "Filter (%a. a:act A & a:ext B) $y1=nil")
+apply (rotate_tac -1)
+apply simp
+(* eliminate introduced subgoal 2 *)
+apply (erule_tac [2] ForallQFilterPnil)
+prefer 2 apply (assumption)
+prefer 2 apply (fast)
+
+(* bring in divide Seq for s *)
+apply (frule sym [THEN eq_imp_below, THEN divide_Seq])
+apply (erule conjE)+
+
+(* subst divide_Seq in conclusion, but only at the righest occurence *)
+apply (rule_tac t = "schA" in ssubst)
+back
+back
+back
+apply assumption
+
+(* f A (tw iA) = tw ~eA *)
+apply (simp add: int_is_act not_ext_is_int_or_not_act)
+
+(* rewrite assumption forall and schB *)
+apply (rotate_tac 13)
+apply (simp add: ext_and_act)
+
+(* divide_Seq for schB2 *)
+apply (frule_tac y = "y2" in sym [THEN eq_imp_below, THEN divide_Seq])
+apply (erule conjE)+
+(* assumption schA *)
+apply (drule_tac x = "schA" and g = "Filter (%a. a:act A) $rs" in subst_lemma2)
+apply assumption
+apply (simp add: int_is_not_ext)
+
+(* f A (tw iB schB2) = nil *)
+apply (simp add: int_is_not_ext not_ext_is_int_or_not_act intA_is_not_actB)
+
+
+(* reduce trace_takes from n to strictly smaller k *)
+apply (rule take_reduction)
+apply (rule refl)
+apply (rule refl)
+
+(* now conclusion fulfills induction hypothesis, but assumptions are not all ready *)
+
+(* assumption schB *)
+apply (drule_tac x = "y2" and g = "Filter (%a. a:act B) $rs" in subst_lemma2)
+apply assumption
+apply (simp add: intA_is_not_actB int_is_not_ext)
+
+(* conclusions concerning LastActExtsch, cannot be rewritten, as LastActExtsmalli are looping  *)
+apply (drule_tac sch = "schA" and P = "%a. a:int A" in LastActExtsmall1)
+apply (frule_tac ?sch1.0 = "y1" in LastActExtsmall2)
+apply assumption
+apply (drule_tac sch = "y2" and P = "%a. a:int B" in LastActExtsmall1)
+
+(* assumption Forall schA, and Forall schA are performed by ForallTL,ForallDropwhile *)
+apply (simp add: ForallTL ForallDropwhile)
+
+(* case x~:A & x:B  *)
+(* cannot occur, as just this case has been scheduled out before as the B-only prefix *)
+apply (case_tac "x:act B")
+apply fast
+
+(* case x~:A & x~:B  *)
+(* cannot occur because of assumption: Forall (a:ext A | a:ext B) *)
+apply (rotate_tac -9)
+(* reduce forall assumption from tr to (x>>rs) *)
+apply (simp add: externals_of_par)
+apply (fast intro!: ext_is_act)
+
+done
+
+
+
+subsection" Filter of mksch(tr,schA,schB) to B is schB -- take lemma proof"
+
+lemma FilterBmksch_is_schB: "!! A B. [| compatible A B; compatible B A;  
+  is_asig(asig_of A); is_asig(asig_of B) |] ==>  
+  Forall (%x. x:ext (A||B)) tr &  
+  Forall (%x. x:act A) schA & Forall (%x. x:act B) schB &  
+  Filter (%a. a:ext A)$schA = Filter (%a. a:act A)$tr & 
+  Filter (%a. a:ext B)$schB = Filter (%a. a:act B)$tr & 
+  LastActExtsch A schA & LastActExtsch B schB   
+  --> Filter (%a. a:act B)$(mksch A B$tr$schA$schB) = schB"
+apply (intro strip)
+apply (rule seq.take_lemma)
+apply (rule mp)
+prefer 2 apply assumption
+back back back back
+apply (rule_tac x = "schA" in spec)
+apply (rule_tac x = "schB" in spec)
+apply (rule_tac x = "tr" in spec)
+apply (tactic "thin_tac' 5 1")
+apply (rule nat_less_induct)
+apply (rule allI)+
+apply (rename_tac tr schB schA)
+apply (intro strip)
+apply (erule conjE)+
+
+apply (case_tac "Forall (%x. x:act A & x~:act B) tr")
+
+apply (rule seq_take_lemma [THEN iffD2, THEN spec])
+apply (tactic "thin_tac' 5 1")
+
+apply (case_tac "Finite tr")
+
+(* both sides of this equation are nil *)
+apply (subgoal_tac "schB=nil")
+apply (simp (no_asm_simp))
+(* first side: mksch = nil *)
+apply (auto intro!: ForallQFilterPnil ForallAnBmksch FiniteL_mksch)[1]
+(* second side: schA = nil *)
+apply (erule_tac A = "B" in LastActExtimplnil)
+apply (simp (no_asm_simp))
+apply (erule_tac Q = "%x. x:act A & x~:act B" in ForallQFilterPnil)
+apply assumption
+apply fast
+
+(* case ~ Finite tr *)
+
+(* both sides of this equation are UU *)
+apply (subgoal_tac "schB=UU")
+apply (simp (no_asm_simp))
+(* first side: mksch = UU *)
+apply (force intro!: ForallQFilterPUU finiteR_mksch [THEN mp, COMP rev_contrapos] ForallAnBmksch)
+(* schA = UU *)
+apply (erule_tac A = "B" in LastActExtimplUU)
+apply (simp (no_asm_simp))
+apply (erule_tac Q = "%x. x:act A & x~:act B" in ForallQFilterPUU)
+apply assumption
+apply fast
+
+(* case" ~ Forall (%x.x:act B & x~:act A) s" *)
+
+apply (drule divide_Seq3)
+
+apply (erule exE)+
+apply (erule conjE)+
+apply hypsubst
+
+(* bring in lemma reduceB_mksch *)
+apply (frule_tac y = "schB" and x = "schA" and A = "A" and B = "B" in reduceB_mksch)
+apply assumption+
+apply (erule exE)+
+apply (erule conjE)+
+
+(* use reduceB_mksch to rewrite conclusion *)
+apply hypsubst
+apply simp
+
+(* eliminate the A-only prefix *)
+
+apply (subgoal_tac "(Filter (%a. a :act B) $x1) = nil")
+apply (erule_tac [2] ForallQFilterPnil)
+prefer 2 apply (assumption)
+prefer 2 apply (fast)
+
+(* Now real recursive step follows (in x) *)
+
+apply simp
+apply (case_tac "x:act B")
+apply (case_tac "x~:act A")
+apply (rotate_tac -2)
+apply simp
+
+apply (subgoal_tac "Filter (%a. a:act B & a:ext A) $x1=nil")
+apply (rotate_tac -1)
+apply simp
+(* eliminate introduced subgoal 2 *)
+apply (erule_tac [2] ForallQFilterPnil)
+prefer 2 apply (assumption)
+prefer 2 apply (fast)
+
+(* bring in divide Seq for s *)
+apply (frule sym [THEN eq_imp_below, THEN divide_Seq])
+apply (erule conjE)+
+
+(* subst divide_Seq in conclusion, but only at the righest occurence *)
+apply (rule_tac t = "schB" in ssubst)
+back
+back
+back
+apply assumption
+
+(* reduce trace_takes from n to strictly smaller k *)
+apply (rule take_reduction)
+
+(* f B (tw iB) = tw ~eB *)
+apply (simp add: int_is_act not_ext_is_int_or_not_act)
+apply (rule refl)
+apply (simp add: int_is_act not_ext_is_int_or_not_act)
+apply (rotate_tac -11)
+
+(* now conclusion fulfills induction hypothesis, but assumptions are not ready *)
+
+(* assumption schA *)
+apply (simp add: ext_and_act)
+(* assumption schB *)
+apply (drule_tac x = "schB" and g = "Filter (%a. a:act B) $rs" in subst_lemma2)
+apply assumption
+apply (simp add: int_is_not_ext)
+(* assumptions concerning LastActExtsch, cannot be rewritten, as LastActExtsmalli are looping  *)
+apply (drule_tac sch = "schB" and P = "%a. a:int B" in LastActExtsmall1)
+apply (frule_tac ?sch1.0 = "x1" in LastActExtsmall2)
+apply assumption
+
+(* assumption Forall schB *)
+apply (drule_tac s = "schB" and P = "Forall (%x. x:act B) " in subst)
+apply assumption
+apply (simp add: int_is_act)
+
+(* case x:actions(asig_of A) & x: actions(asig_of B) *)
+
+apply (rotate_tac -2)
+apply simp
+
+apply (subgoal_tac "Filter (%a. a:act B & a:ext A) $x1=nil")
+apply (rotate_tac -1)
+apply simp
+(* eliminate introduced subgoal 2 *)
+apply (erule_tac [2] ForallQFilterPnil)
+prefer 2 apply (assumption)
+prefer 2 apply (fast)
+
+(* bring in divide Seq for s *)
+apply (frule sym [THEN eq_imp_below, THEN divide_Seq])
+apply (erule conjE)+
+
+(* subst divide_Seq in conclusion, but only at the righest occurence *)
+apply (rule_tac t = "schB" in ssubst)
+back
+back
+back
+apply assumption
+
+(* f B (tw iB) = tw ~eB *)
+apply (simp add: int_is_act not_ext_is_int_or_not_act)
+
+(* rewrite assumption forall and schB *)
+apply (rotate_tac 13)
+apply (simp add: ext_and_act)
+
+(* divide_Seq for schB2 *)
+apply (frule_tac y = "x2" in sym [THEN eq_imp_below, THEN divide_Seq])
+apply (erule conjE)+
+(* assumption schA *)
+apply (drule_tac x = "schB" and g = "Filter (%a. a:act B) $rs" in subst_lemma2)
+apply assumption
+apply (simp add: int_is_not_ext)
+
+(* f B (tw iA schA2) = nil *)
+apply (simp add: int_is_not_ext not_ext_is_int_or_not_act intA_is_not_actB)
+
+
+(* reduce trace_takes from n to strictly smaller k *)
+apply (rule take_reduction)
+apply (rule refl)
+apply (rule refl)
+
+(* now conclusion fulfills induction hypothesis, but assumptions are not all ready *)
+
+(* assumption schA *)
+apply (drule_tac x = "x2" and g = "Filter (%a. a:act A) $rs" in subst_lemma2)
+apply assumption
+apply (simp add: intA_is_not_actB int_is_not_ext)
+
+(* conclusions concerning LastActExtsch, cannot be rewritten, as LastActExtsmalli are looping  *)
+apply (drule_tac sch = "schB" and P = "%a. a:int B" in LastActExtsmall1)
+apply (frule_tac ?sch1.0 = "x1" in LastActExtsmall2)
+apply assumption
+apply (drule_tac sch = "x2" and P = "%a. a:int A" in LastActExtsmall1)
+
+(* assumption Forall schA, and Forall schA are performed by ForallTL,ForallDropwhile *)
+apply (simp add: ForallTL ForallDropwhile)
+
+(* case x~:B & x:A  *)
+(* cannot occur, as just this case has been scheduled out before as the B-only prefix *)
+apply (case_tac "x:act A")
+apply fast
+
+(* case x~:B & x~:A  *)
+(* cannot occur because of assumption: Forall (a:ext A | a:ext B) *)
+apply (rotate_tac -9)
+(* reduce forall assumption from tr to (x>>rs) *)
+apply (simp add: externals_of_par)
+apply (fast intro!: ext_is_act)
+
+done
+
+
+subsection "COMPOSITIONALITY on TRACE Level -- Main Theorem"
+
+lemma compositionality_tr: 
+"!! A B. [| is_trans_of A; is_trans_of B; compatible A B; compatible B A;  
+            is_asig(asig_of A); is_asig(asig_of B)|]  
+        ==>  (tr: traces(A||B)) =  
+             (Filter (%a. a:act A)$tr : traces A & 
+              Filter (%a. a:act B)$tr : traces B & 
+              Forall (%x. x:ext(A||B)) tr)"
+
+apply (simp (no_asm) add: traces_def has_trace_def)
+apply auto
+
+(* ==> *)
+(* There is a schedule of A *)
+apply (rule_tac x = "Filter (%a. a:act A) $sch" in bexI)
+prefer 2
+apply (simp add: compositionality_sch)
+apply (simp add: compatibility_consequence1 externals_of_par ext1_ext2_is_not_act1)
+(* There is a schedule of B *)
+apply (rule_tac x = "Filter (%a. a:act B) $sch" in bexI)
+prefer 2
+apply (simp add: compositionality_sch)
+apply (simp add: compatibility_consequence2 externals_of_par ext1_ext2_is_not_act2)
+(* Traces of A||B have only external actions from A or B *)
+apply (rule ForallPFilterP)
+
+(* <== *)
+
+(* replace schA and schB by Cut(schA) and Cut(schB) *)
+apply (drule exists_LastActExtsch)
+apply assumption
+apply (drule exists_LastActExtsch)
+apply assumption
+apply (erule exE)+
+apply (erule conjE)+
+(* Schedules of A(B) have only actions of A(B) *)
+apply (drule scheds_in_sig)
+apply assumption
+apply (drule scheds_in_sig)
+apply assumption
+
+apply (rename_tac h1 h2 schA schB)
+(* mksch is exactly the construction of trA||B out of schA, schB, and the oracle tr,
+   we need here *)
+apply (rule_tac x = "mksch A B$tr$schA$schB" in bexI)
+
+(* External actions of mksch are just the oracle *)
+apply (simp add: FilterA_mksch_is_tr)
+
+(* mksch is a schedule -- use compositionality on sch-level *)
+apply (simp add: compositionality_sch)
+apply (simp add: FilterAmksch_is_schA FilterBmksch_is_schB)
+apply (erule ForallAorB_mksch)
+apply (erule ForallPForallQ)
+apply (erule ext_is_act)
+done
+
+
+
+subsection {* COMPOSITIONALITY on TRACE Level -- for Modules *}
+
+lemma compositionality_tr_modules: 
+
+"!! A B. [| is_trans_of A; is_trans_of B; compatible A B; compatible B A;  
+            is_asig(asig_of A); is_asig(asig_of B)|]  
+ ==> Traces (A||B) = par_traces (Traces A) (Traces B)"
+
+apply (unfold Traces_def par_traces_def)
+apply (simp add: asig_of_par)
+apply (rule set_eqI)
+apply (simp add: compositionality_tr externals_of_par)
+done
+
+
+declaration {* fn _ => Simplifier.map_ss (fn ss => ss setmksym (K (SOME o symmetric_fun))) *}
+
+
+end

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/HOLCF/IOA/meta_theory/Compositionality.thy	Sat Nov 27 16:08:10 2010 -0800
@@ -0,0 +1,75 @@
+(*  Title:      HOLCF/IOA/meta_theory/Compositionality.thy
+    Author:     Olaf Müller
+*)
+
+header {* Compositionality of I/O automata *}
+theory Compositionality
+imports CompoTraces
+begin
+
+lemma compatibility_consequence3: "[|eA --> A ; eB & ~eA --> ~A|] ==> (eA | eB) --> A=eA"
+apply auto
+done
+
+
+lemma Filter_actAisFilter_extA: 
+"!! A B. [| compatible A B; Forall (%a. a: ext A | a: ext B) tr |] ==>  
+            Filter (%a. a: act A)$tr= Filter (%a. a: ext A)$tr"
+apply (rule ForallPFilterQR)
+(* i.e.: [| (! x. P x --> (Q x = R x)) ; Forall P tr |] ==> Filter Q$tr = Filter R$tr *)
+prefer 2 apply (assumption)
+apply (rule compatibility_consequence3)
+apply (simp_all add: ext_is_act ext1_ext2_is_not_act1)
+done
+
+
+(* the next two theorems are only necessary, as there is no theorem ext (A||B) = ext (B||A) *)
+
+lemma compatibility_consequence4: "[|eA --> A ; eB & ~eA --> ~A|] ==> (eB | eA) --> A=eA"
+apply auto
+done
+
+lemma Filter_actAisFilter_extA2: "[| compatible A B; Forall (%a. a: ext B | a: ext A) tr |] ==>  
+            Filter (%a. a: act A)$tr= Filter (%a. a: ext A)$tr"
+apply (rule ForallPFilterQR)
+prefer 2 apply (assumption)
+apply (rule compatibility_consequence4)
+apply (simp_all add: ext_is_act ext1_ext2_is_not_act1)
+done
+
+
+subsection " Main Compositionality Theorem "
+
+lemma compositionality: "[| is_trans_of A1; is_trans_of A2; is_trans_of B1; is_trans_of B2; 
+             is_asig_of A1; is_asig_of A2;  
+             is_asig_of B1; is_asig_of B2;  
+             compatible A1 B1; compatible A2 B2;  
+             A1 =<| A2;  
+             B1 =<| B2 |]  
+         ==> (A1 || B1) =<| (A2 || B2)"
+apply (simp add: is_asig_of_def)
+apply (frule_tac A1 = "A1" in compat_commute [THEN iffD1])
+apply (frule_tac A1 = "A2" in compat_commute [THEN iffD1])
+apply (simp add: ioa_implements_def inputs_of_par outputs_of_par externals_of_par)
+apply auto
+apply (simp add: compositionality_tr)
+apply (subgoal_tac "ext A1 = ext A2 & ext B1 = ext B2")
+prefer 2
+apply (simp add: externals_def)
+apply (erule conjE)+
+(* rewrite with proven subgoal *)
+apply (simp add: externals_of_par)
+apply auto
+
+(* 2 goals, the 3rd has been solved automatically *)
+(* 1: Filter A2 x : traces A2 *)
+apply (drule_tac A = "traces A1" in subsetD)
+apply assumption
+apply (simp add: Filter_actAisFilter_extA)
+(* 2: Filter B2 x : traces B2 *)
+apply (drule_tac A = "traces B1" in subsetD)
+apply assumption
+apply (simp add: Filter_actAisFilter_extA2)
+done
+
+end

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/HOLCF/IOA/meta_theory/Deadlock.thy	Sat Nov 27 16:08:10 2010 -0800
@@ -0,0 +1,92 @@
+(*  Title:      HOLCF/IOA/meta_theory/Deadlock.thy
+    Author:     Olaf Müller
+*)
+
+header {* Deadlock freedom of I/O Automata *}
+
+theory Deadlock
+imports RefCorrectness CompoScheds
+begin
+
+text {* input actions may always be added to a schedule *}
+
+lemma scheds_input_enabled:
+  "[| Filter (%x. x:act A)$sch : schedules A; a:inp A; input_enabled A; Finite sch|]  
+          ==> Filter (%x. x:act A)$sch @@ a>>nil : schedules A"
+apply (simp add: schedules_def has_schedule_def)
+apply auto
+apply (frule inp_is_act)
+apply (simp add: executions_def)
+apply (tactic {* pair_tac @{context} "ex" 1 *})
+apply (rename_tac s ex)
+apply (subgoal_tac "Finite ex")
+prefer 2
+apply (simp add: filter_act_def)
+defer
+apply (rule_tac [2] Map2Finite [THEN iffD1])
+apply (rule_tac [2] t = "Map fst$ex" in subst)
+prefer 2 apply (assumption)
+apply (erule_tac [2] FiniteFilter)
+(* subgoal 1 *)
+apply (frule exists_laststate)
+apply (erule allE)
+apply (erule exE)
+(* using input-enabledness *)
+apply (simp add: input_enabled_def)
+apply (erule conjE)+
+apply (erule_tac x = "a" in allE)
+apply simp
+apply (erule_tac x = "u" in allE)
+apply (erule exE)
+(* instantiate execution *)
+apply (rule_tac x = " (s,ex @@ (a,s2) >>nil) " in exI)
+apply (simp add: filter_act_def MapConc)
+apply (erule_tac t = "u" in lemma_2_1)
+apply simp
+apply (rule sym)
+apply assumption
+done
+
+text {*
+               Deadlock freedom: component B cannot block an out or int action
+                                 of component A in every schedule.
+    Needs compositionality on schedule level, input-enabledness, compatibility
+                    and distributivity of is_exec_frag over @@
+*}
+
+declare split_if [split del]
+lemma IOA_deadlock_free: "[| a : local A; Finite sch; sch : schedules (A||B);  
+             Filter (%x. x:act A)$(sch @@ a>>nil) : schedules A; compatible A B; input_enabled B |]  
+           ==> (sch @@ a>>nil) : schedules (A||B)"
+apply (simp add: compositionality_sch locals_def)
+apply (rule conjI)
+(* a : act (A||B) *)
+prefer 2
+apply (simp add: actions_of_par)
+apply (blast dest: int_is_act out_is_act)
+
+(* Filter B (sch@@[a]) : schedules B *)
+
+apply (case_tac "a:int A")
+apply (drule intA_is_not_actB)
+apply (assumption) (* --> a~:act B *)
+apply simp
+
+(* case a~:int A , i.e. a:out A *)
+apply (case_tac "a~:act B")
+apply simp
+(* case a:act B *)
+apply simp
+apply (subgoal_tac "a:out A")
+prefer 2 apply (blast)
+apply (drule outAactB_is_inpB)
+apply assumption
+apply assumption
+apply (rule scheds_input_enabled)
+apply simp
+apply assumption+
+done
+
+declare split_if [split]
+
+end

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/HOLCF/IOA/meta_theory/IOA.thy	Sat Nov 27 16:08:10 2010 -0800
@@ -0,0 +1,11 @@
+(*  Title:      HOLCF/IOA/meta_theory/IOA.thy
+    Author:     Olaf Müller
+*)
+
+header {* The theory of I/O automata in HOLCF *}
+
+theory IOA
+imports SimCorrectness Compositionality Deadlock
+begin
+
+end

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/HOLCF/IOA/meta_theory/LiveIOA.thy	Sat Nov 27 16:08:10 2010 -0800
@@ -0,0 +1,82 @@
+(*  Title:      HOLCF/IOA/meta_theory/LiveIOA.thy
+    Author:     Olaf Müller
+*)
+
+header {* Live I/O automata -- specified by temproal formulas *}
+
+theory LiveIOA
+imports TLS
+begin
+
+default_sort type
+
+types
+  ('a, 's) live_ioa = "('a,'s)ioa * ('a,'s)ioa_temp"
+
+definition
+  validLIOA :: "('a,'s)live_ioa => ('a,'s)ioa_temp  => bool" where
+  "validLIOA AL P = validIOA (fst AL) ((snd AL) .--> P)"
+
+definition
+  WF :: "('a,'s)ioa => 'a set => ('a,'s)ioa_temp" where
+  "WF A acts = (<> [] <%(s,a,t) . Enabled A acts s> .--> [] <> <xt2 (plift (%a. a : acts))>)"
+definition
+  SF :: "('a,'s)ioa => 'a set => ('a,'s)ioa_temp" where
+  "SF A acts = ([] <> <%(s,a,t) . Enabled A acts s> .--> [] <> <xt2 (plift (%a. a : acts))>)"
+
+definition
+  liveexecutions :: "('a,'s)live_ioa => ('a,'s)execution set" where
+  "liveexecutions AP = {exec. exec : executions (fst AP) & (exec |== (snd AP))}"
+definition
+  livetraces :: "('a,'s)live_ioa => 'a trace set" where
+  "livetraces AP = {mk_trace (fst AP)$(snd ex) | ex. ex:liveexecutions AP}"
+definition
+  live_implements :: "('a,'s1)live_ioa => ('a,'s2)live_ioa => bool" where
+  "live_implements CL AM = ((inp (fst CL) = inp (fst AM)) &
+                            (out (fst CL) = out (fst AM)) &
+                            livetraces CL <= livetraces AM)"
+definition
+  is_live_ref_map :: "('s1 => 's2) => ('a,'s1)live_ioa => ('a,'s2)live_ioa => bool" where
+  "is_live_ref_map f CL AM =
+           (is_ref_map f (fst CL ) (fst AM) &
+            (! exec : executions (fst CL). (exec |== (snd CL)) -->
+                                           ((corresp_ex (fst AM) f exec) |== (snd AM))))"
+
+
+lemma live_implements_trans:
+"!!LC. [| live_implements (A,LA) (B,LB); live_implements (B,LB) (C,LC) |]
+      ==> live_implements (A,LA) (C,LC)"
+apply (unfold live_implements_def)
+apply auto
+done
+
+
+subsection "Correctness of live refmap"
+
+lemma live_implements: "[| inp(C)=inp(A); out(C)=out(A);
+                   is_live_ref_map f (C,M) (A,L) |]
+                ==> live_implements (C,M) (A,L)"
+apply (simp add: is_live_ref_map_def live_implements_def livetraces_def liveexecutions_def)
+apply auto
+apply (rule_tac x = "corresp_ex A f ex" in exI)
+apply auto
+  (* Traces coincide, Lemma 1 *)
+  apply (tactic {* pair_tac @{context} "ex" 1 *})
+  apply (erule lemma_1 [THEN spec, THEN mp])
+  apply (simp (no_asm) add: externals_def)
+  apply (auto)[1]
+  apply (simp add: executions_def reachable.reachable_0)
+
+  (* corresp_ex is execution, Lemma 2 *)
+  apply (tactic {* pair_tac @{context} "ex" 1 *})
+  apply (simp add: executions_def)
+  (* start state *)
+  apply (rule conjI)
+  apply (simp add: is_ref_map_def corresp_ex_def)
+  (* is-execution-fragment *)
+  apply (erule lemma_2 [THEN spec, THEN mp])
+  apply (simp add: reachable.reachable_0)
+
+done
+
+end

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/HOLCF/IOA/meta_theory/Pred.thy	Sat Nov 27 16:08:10 2010 -0800
@@ -0,0 +1,69 @@
+(*  Title:      HOLCF/IOA/meta_theory/Pred.thy
+    Author:     Olaf Müller
+*)
+
+header {* Logical Connectives lifted to predicates *}
+
+theory Pred
+imports Main
+begin
+
+default_sort type
+
+types
+  'a predicate = "'a => bool"
+
+consts
+
+satisfies    ::"'a  => 'a predicate => bool"    ("_ |= _" [100,9] 8)
+valid        ::"'a predicate => bool"           (*  ("|-") *)
+
+NOT          ::"'a predicate => 'a predicate"  (".~ _" [40] 40)
+AND          ::"'a predicate => 'a predicate => 'a predicate"    (infixr ".&" 35)
+OR           ::"'a predicate => 'a predicate => 'a predicate"    (infixr ".|" 30)
+IMPLIES      ::"'a predicate => 'a predicate => 'a predicate"    (infixr ".-->" 25)
+
+
+notation (output)
+  NOT  ("~ _" [40] 40) and
+  AND  (infixr "&" 35) and
+  OR  (infixr "|" 30) and
+  IMPLIES  (infixr "-->" 25)
+
+notation (xsymbols output)
+  NOT  ("\<not> _" [40] 40) and
+  AND  (infixr "\<and>" 35) and
+  OR  (infixr "\<or>" 30) and
+  IMPLIES  (infixr "\<longrightarrow>" 25)
+
+notation (xsymbols)
+  satisfies  ("_ \<Turnstile> _" [100,9] 8)
+
+notation (HTML output)
+  NOT  ("\<not> _" [40] 40) and
+  AND  (infixr "\<and>" 35) and
+  OR  (infixr "\<or>" 30)
+
+
+defs
+
+satisfies_def:
+   "s |= P  == P s"
+
+(* priority einfuegen, da clash mit |=, wenn graphisches Symbol *)
+valid_def:
+   "valid P == (! s. (s |= P))"
+
+NOT_def:
+  "NOT P s ==  ~ (P s)"
+
+AND_def:
+  "(P .& Q) s == (P s) & (Q s)"
+
+OR_def:
+  "(P .| Q) s ==  (P s) | (Q s)"
+
+IMPLIES_def:
+  "(P .--> Q) s == (P s) --> (Q s)"
+
+end

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/HOLCF/IOA/meta_theory/RefCorrectness.thy	Sat Nov 27 16:08:10 2010 -0800
@@ -0,0 +1,371 @@
+(*  Title:      HOLCF/IOA/meta_theory/RefCorrectness.thy
+    Author:     Olaf Müller
+*)
+
+header {* Correctness of Refinement Mappings in HOLCF/IOA *}
+
+theory RefCorrectness
+imports RefMappings
+begin
+
+definition
+  corresp_exC :: "('a,'s2)ioa => ('s1 => 's2) => ('a,'s1)pairs
+                   -> ('s1 => ('a,'s2)pairs)" where
+  "corresp_exC A f = (fix$(LAM h ex. (%s. case ex of
+      nil =>  nil
+    | x##xs => (flift1 (%pr. (@cex. move A cex (f s) (fst pr) (f (snd pr)))
+                              @@ ((h$xs) (snd pr)))
+                        $x) )))"
+definition
+  corresp_ex :: "('a,'s2)ioa => ('s1 => 's2) =>
+                  ('a,'s1)execution => ('a,'s2)execution" where
+  "corresp_ex A f ex = (f (fst ex),(corresp_exC A f$(snd ex)) (fst ex))"
+
+definition
+  is_fair_ref_map :: "('s1 => 's2) => ('a,'s1)ioa => ('a,'s2)ioa => bool" where
+  "is_fair_ref_map f C A =
+      (is_ref_map f C A &
+       (! ex : executions(C). fair_ex C ex --> fair_ex A (corresp_ex A f ex)))"
+
+(* Axioms for fair trace inclusion proof support, not for the correctness proof
+   of refinement mappings!
+   Note: Everything is superseded by LiveIOA.thy! *)
+
+axiomatization where
+corresp_laststate:
+  "Finite ex ==> laststate (corresp_ex A f (s,ex)) = f (laststate (s,ex))"
+
+axiomatization where
+corresp_Finite:
+  "Finite (snd (corresp_ex A f (s,ex))) = Finite ex"
+
+axiomatization where
+FromAtoC:
+  "fin_often (%x. P (snd x)) (snd (corresp_ex A f (s,ex))) ==> fin_often (%y. P (f (snd y))) ex"
+
+axiomatization where
+FromCtoA:
+  "inf_often (%y. P (fst y)) ex ==> inf_often (%x. P (fst x)) (snd (corresp_ex A f (s,ex)))"
+
+
+(* Proof by case on inf W in ex: If so, ok. If not, only fin W in ex, ie there is
+   an index i from which on no W in ex. But W inf enabled, ie at least once after i
+   W is enabled. As W does not occur after i and W is enabling_persistent, W keeps
+   enabled until infinity, ie. indefinitely *)
+axiomatization where
+persistent:
+  "[|inf_often (%x. Enabled A W (snd x)) ex; en_persistent A W|]
+   ==> inf_often (%x. fst x :W) ex | fin_often (%x. ~Enabled A W (snd x)) ex"
+
+axiomatization where
+infpostcond:
+  "[| is_exec_frag A (s,ex); inf_often (%x. fst x:W) ex|]
+    ==> inf_often (% x. set_was_enabled A W (snd x)) ex"
+
+
+subsection "corresp_ex"
+
+lemma corresp_exC_unfold: "corresp_exC A f  = (LAM ex. (%s. case ex of
+       nil =>  nil
+     | x##xs => (flift1 (%pr. (@cex. move A cex (f s) (fst pr) (f (snd pr)))
+                               @@ ((corresp_exC A f $xs) (snd pr)))
+                         $x) ))"
+apply (rule trans)
+apply (rule fix_eq2)
+apply (simp only: corresp_exC_def)
+apply (rule beta_cfun)
+apply (simp add: flift1_def)
+done
+
+lemma corresp_exC_UU: "(corresp_exC A f$UU) s=UU"
+apply (subst corresp_exC_unfold)
+apply simp
+done
+
+lemma corresp_exC_nil: "(corresp_exC A f$nil) s = nil"
+apply (subst corresp_exC_unfold)
+apply simp
+done
+
+lemma corresp_exC_cons: "(corresp_exC A f$(at>>xs)) s =
+           (@cex. move A cex (f s) (fst at) (f (snd at)))
+           @@ ((corresp_exC A f$xs) (snd at))"
+apply (rule trans)
+apply (subst corresp_exC_unfold)
+apply (simp add: Consq_def flift1_def)
+apply simp
+done
+
+
+declare corresp_exC_UU [simp] corresp_exC_nil [simp] corresp_exC_cons [simp]
+
+
+
+subsection "properties of move"
+
+lemma move_is_move:
+   "[|is_ref_map f C A; reachable C s; (s,a,t):trans_of C|] ==>
+      move A (@x. move A x (f s) a (f t)) (f s) a (f t)"
+apply (unfold is_ref_map_def)
+apply (subgoal_tac "? ex. move A ex (f s) a (f t) ")
+prefer 2
+apply simp
+apply (erule exE)
+apply (rule someI)
+apply assumption
+done
+
+lemma move_subprop1:
+   "[|is_ref_map f C A; reachable C s; (s,a,t):trans_of C|] ==>
+     is_exec_frag A (f s,@x. move A x (f s) a (f t))"
+apply (cut_tac move_is_move)
+defer
+apply assumption+
+apply (simp add: move_def)
+done
+
+lemma move_subprop2:
+   "[|is_ref_map f C A; reachable C s; (s,a,t):trans_of C|] ==>
+     Finite ((@x. move A x (f s) a (f t)))"
+apply (cut_tac move_is_move)
+defer
+apply assumption+
+apply (simp add: move_def)
+done
+
+lemma move_subprop3:
+   "[|is_ref_map f C A; reachable C s; (s,a,t):trans_of C|] ==>
+     laststate (f s,@x. move A x (f s) a (f t)) = (f t)"
+apply (cut_tac move_is_move)
+defer
+apply assumption+
+apply (simp add: move_def)
+done
+
+lemma move_subprop4:
+   "[|is_ref_map f C A; reachable C s; (s,a,t):trans_of C|] ==>
+      mk_trace A$((@x. move A x (f s) a (f t))) =
+        (if a:ext A then a>>nil else nil)"
+apply (cut_tac move_is_move)
+defer
+apply assumption+
+apply (simp add: move_def)
+done
+
+
+(* ------------------------------------------------------------------ *)
+(*                   The following lemmata contribute to              *)
+(*                 TRACE INCLUSION Part 1: Traces coincide            *)
+(* ------------------------------------------------------------------ *)
+
+section "Lemmata for <=="
+
+(* --------------------------------------------------- *)
+(*   Lemma 1.1: Distribution of mk_trace and @@        *)
+(* --------------------------------------------------- *)
+
+lemma mk_traceConc: "mk_trace C$(ex1 @@ ex2)= (mk_trace C$ex1) @@ (mk_trace C$ex2)"
+apply (simp add: mk_trace_def filter_act_def MapConc)
+done
+
+
+
+(* ------------------------------------------------------
+                 Lemma 1 :Traces coincide
+   ------------------------------------------------------- *)
+declare split_if [split del]
+
+lemma lemma_1:
+  "[|is_ref_map f C A; ext C = ext A|] ==>
+         !s. reachable C s & is_exec_frag C (s,xs) -->
+             mk_trace C$xs = mk_trace A$(snd (corresp_ex A f (s,xs)))"
+apply (unfold corresp_ex_def)
+apply (tactic {* pair_induct_tac @{context} "xs" [@{thm is_exec_frag_def}] 1 *})
+(* cons case *)
+apply (auto simp add: mk_traceConc)
+apply (frule reachable.reachable_n)
+apply assumption
+apply (erule_tac x = "y" in allE)
+apply (simp add: move_subprop4 split add: split_if)
+done
+
+declare split_if [split]
+
+(* ------------------------------------------------------------------ *)
+(*                   The following lemmata contribute to              *)
+(*              TRACE INCLUSION Part 2: corresp_ex is execution       *)
+(* ------------------------------------------------------------------ *)
+
+section "Lemmata for ==>"
+
+(* -------------------------------------------------- *)
+(*                   Lemma 2.1                        *)
+(* -------------------------------------------------- *)
+
+lemma lemma_2_1 [rule_format (no_asm)]:
+"Finite xs -->
+ (!s .is_exec_frag A (s,xs) & is_exec_frag A (t,ys) &
+      t = laststate (s,xs)
+  --> is_exec_frag A (s,xs @@ ys))"
+
+apply (rule impI)
+apply (tactic {* Seq_Finite_induct_tac @{context} 1 *})
+(* main case *)
+apply (auto simp add: split_paired_all)
+done
+
+
+(* ----------------------------------------------------------- *)
+(*               Lemma 2 : corresp_ex is execution             *)
+(* ----------------------------------------------------------- *)
+
+
+
+lemma lemma_2:
+ "[| is_ref_map f C A |] ==>
+  !s. reachable C s & is_exec_frag C (s,xs)
+  --> is_exec_frag A (corresp_ex A f (s,xs))"
+
+apply (unfold corresp_ex_def)
+
+apply simp
+apply (tactic {* pair_induct_tac @{context} "xs" [@{thm is_exec_frag_def}] 1 *})
+(* main case *)
+apply auto
+apply (rule_tac t = "f y" in lemma_2_1)
+
+(* Finite *)
+apply (erule move_subprop2)
+apply assumption+
+apply (rule conjI)
+
+(* is_exec_frag *)
+apply (erule move_subprop1)
+apply assumption+
+apply (rule conjI)
+
+(* Induction hypothesis  *)
+(* reachable_n looping, therefore apply it manually *)
+apply (erule_tac x = "y" in allE)
+apply simp
+apply (frule reachable.reachable_n)
+apply assumption
+apply simp
+(* laststate *)
+apply (erule move_subprop3 [symmetric])
+apply assumption+
+done
+
+
+subsection "Main Theorem: TRACE - INCLUSION"
+
+lemma trace_inclusion:
+  "[| ext C = ext A; is_ref_map f C A |]
+           ==> traces C <= traces A"
+
+  apply (unfold traces_def)
+
+  apply (simp (no_asm) add: has_trace_def2)
+  apply auto
+
+  (* give execution of abstract automata *)
+  apply (rule_tac x = "corresp_ex A f ex" in bexI)
+
+  (* Traces coincide, Lemma 1 *)
+  apply (tactic {* pair_tac @{context} "ex" 1 *})
+  apply (erule lemma_1 [THEN spec, THEN mp])
+  apply assumption+
+  apply (simp add: executions_def reachable.reachable_0)
+
+  (* corresp_ex is execution, Lemma 2 *)
+  apply (tactic {* pair_tac @{context} "ex" 1 *})
+  apply (simp add: executions_def)
+  (* start state *)
+  apply (rule conjI)
+  apply (simp add: is_ref_map_def corresp_ex_def)
+  (* is-execution-fragment *)
+  apply (erule lemma_2 [THEN spec, THEN mp])
+  apply (simp add: reachable.reachable_0)
+  done
+
+
+subsection "Corollary:  FAIR TRACE - INCLUSION"
+
+lemma fininf: "(~inf_often P s) = fin_often P s"
+apply (unfold fin_often_def)
+apply auto
+done
+
+
+lemma WF_alt: "is_wfair A W (s,ex) =
+  (fin_often (%x. ~Enabled A W (snd x)) ex --> inf_often (%x. fst x :W) ex)"
+apply (simp add: is_wfair_def fin_often_def)
+apply auto
+done
+
+lemma WF_persistent: "[|is_wfair A W (s,ex); inf_often (%x. Enabled A W (snd x)) ex;
+          en_persistent A W|]
+    ==> inf_often (%x. fst x :W) ex"
+apply (drule persistent)
+apply assumption
+apply (simp add: WF_alt)
+apply auto
+done
+
+
+lemma fair_trace_inclusion: "!! C A.
+          [| is_ref_map f C A; ext C = ext A;
+          !! ex. [| ex:executions C; fair_ex C ex|] ==> fair_ex A (corresp_ex A f ex) |]
+          ==> fairtraces C <= fairtraces A"
+apply (simp (no_asm) add: fairtraces_def fairexecutions_def)
+apply auto
+apply (rule_tac x = "corresp_ex A f ex" in exI)
+apply auto
+
+  (* Traces coincide, Lemma 1 *)
+  apply (tactic {* pair_tac @{context} "ex" 1 *})
+  apply (erule lemma_1 [THEN spec, THEN mp])
+  apply assumption+
+  apply (simp add: executions_def reachable.reachable_0)
+
+  (* corresp_ex is execution, Lemma 2 *)
+  apply (tactic {* pair_tac @{context} "ex" 1 *})
+  apply (simp add: executions_def)
+  (* start state *)
+  apply (rule conjI)
+  apply (simp add: is_ref_map_def corresp_ex_def)
+  (* is-execution-fragment *)
+  apply (erule lemma_2 [THEN spec, THEN mp])
+  apply (simp add: reachable.reachable_0)
+
+done
+
+lemma fair_trace_inclusion2: "!! C A.
+          [| inp(C) = inp(A); out(C)=out(A);
+             is_fair_ref_map f C A |]
+          ==> fair_implements C A"
+apply (simp add: is_fair_ref_map_def fair_implements_def fairtraces_def fairexecutions_def)
+apply auto
+apply (rule_tac x = "corresp_ex A f ex" in exI)
+apply auto
+
+  (* Traces coincide, Lemma 1 *)
+  apply (tactic {* pair_tac @{context} "ex" 1 *})
+  apply (erule lemma_1 [THEN spec, THEN mp])
+  apply (simp (no_asm) add: externals_def)
+  apply (auto)[1]
+  apply (simp add: executions_def reachable.reachable_0)
+
+  (* corresp_ex is execution, Lemma 2 *)
+  apply (tactic {* pair_tac @{context} "ex" 1 *})
+  apply (simp add: executions_def)
+  (* start state *)
+  apply (rule conjI)
+  apply (simp add: is_ref_map_def corresp_ex_def)
+  (* is-execution-fragment *)
+  apply (erule lemma_2 [THEN spec, THEN mp])
+  apply (simp add: reachable.reachable_0)
+
+done
+
+end

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/HOLCF/IOA/meta_theory/RefMappings.thy	Sat Nov 27 16:08:10 2010 -0800
@@ -0,0 +1,129 @@
+(*  Title:      HOLCF/IOA/meta_theory/RefMappings.thy
+    Author:     Olaf Müller
+*)
+
+header {* Refinement Mappings in HOLCF/IOA *}
+
+theory RefMappings
+imports Traces
+begin
+
+default_sort type
+
+definition
+  move :: "[('a,'s)ioa,('a,'s)pairs,'s,'a,'s] => bool" where
+  "move ioa ex s a t =
+    (is_exec_frag ioa (s,ex) &  Finite ex &
+     laststate (s,ex)=t  &
+     mk_trace ioa$ex = (if a:ext(ioa) then a>>nil else nil))"
+
+definition
+  is_ref_map :: "[('s1=>'s2),('a,'s1)ioa,('a,'s2)ioa] => bool" where
+  "is_ref_map f C A =
+   ((!s:starts_of(C). f(s):starts_of(A)) &
+   (!s t a. reachable C s &
+            s -a--C-> t
+            --> (? ex. move A ex (f s) a (f t))))"
+
+definition
+  is_weak_ref_map :: "[('s1=>'s2),('a,'s1)ioa,('a,'s2)ioa] => bool" where
+  "is_weak_ref_map f C A =
+   ((!s:starts_of(C). f(s):starts_of(A)) &
+   (!s t a. reachable C s &
+            s -a--C-> t
+            --> (if a:ext(C)
+                 then (f s) -a--A-> (f t)
+                 else (f s)=(f t))))"
+
+
+subsection "transitions and moves"
+
+
+lemma transition_is_ex: "s -a--A-> t ==> ? ex. move A ex s a t"
+apply (rule_tac x = " (a,t) >>nil" in exI)
+apply (simp add: move_def)
+done
+
+
+lemma nothing_is_ex: "(~a:ext A) & s=t ==> ? ex. move A ex s a t"
+apply (rule_tac x = "nil" in exI)
+apply (simp add: move_def)
+done
+
+
+lemma ei_transitions_are_ex: "(s -a--A-> s') & (s' -a'--A-> s'') & (~a':ext A)  
+         ==> ? ex. move A ex s a s''"
+apply (rule_tac x = " (a,s') >> (a',s'') >>nil" in exI)
+apply (simp add: move_def)
+done
+
+
+lemma eii_transitions_are_ex: "(s1 -a1--A-> s2) & (s2 -a2--A-> s3) & (s3 -a3--A-> s4) & 
+      (~a2:ext A) & (~a3:ext A) ==>  
+      ? ex. move A ex s1 a1 s4"
+apply (rule_tac x = " (a1,s2) >> (a2,s3) >> (a3,s4) >>nil" in exI)
+apply (simp add: move_def)
+done
+
+
+subsection "weak_ref_map and ref_map"
+
+lemma weak_ref_map2ref_map:
+  "[| ext C = ext A;  
+     is_weak_ref_map f C A |] ==> is_ref_map f C A"
+apply (unfold is_weak_ref_map_def is_ref_map_def)
+apply auto
+apply (case_tac "a:ext A")
+apply (auto intro: transition_is_ex nothing_is_ex)
+done
+
+
+lemma imp_conj_lemma: "(P ==> Q-->R) ==> P&Q --> R"
+  by blast
+
+declare split_if [split del]
+declare if_weak_cong [cong del]
+
+lemma rename_through_pmap: "[| is_weak_ref_map f C A |]  
+      ==> (is_weak_ref_map f (rename C g) (rename A g))"
+apply (simp add: is_weak_ref_map_def)
+apply (rule conjI)
+(* 1: start states *)
+apply (simp add: rename_def rename_set_def starts_of_def)
+(* 2: reachable transitions *)
+apply (rule allI)+
+apply (rule imp_conj_lemma)
+apply (simp (no_asm) add: rename_def rename_set_def)
+apply (simp add: externals_def asig_inputs_def asig_outputs_def asig_of_def trans_of_def)
+apply safe
+apply (simplesubst split_if)
+ apply (rule conjI)
+ apply (rule impI)
+ apply (erule disjE)
+ apply (erule exE)
+apply (erule conjE)
+(* x is input *)
+ apply (drule sym)
+ apply (drule sym)
+apply simp
+apply hypsubst+
+apply (frule reachable_rename)
+apply simp
+(* x is output *)
+ apply (erule exE)
+apply (erule conjE)
+ apply (drule sym)
+ apply (drule sym)
+apply simp
+apply hypsubst+
+apply (frule reachable_rename)
+apply simp
+(* x is internal *)
+apply (frule reachable_rename)
+apply auto
+done
+
+declare split_if [split]
+declare if_weak_cong [cong]
+
+end

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/HOLCF/IOA/meta_theory/Seq.thy	Sat Nov 27 16:08:10 2010 -0800
@@ -0,0 +1,328 @@
+(*  Title:      HOLCF/IOA/meta_theory/Seq.thy
+    Author:     Olaf Müller
+*)
+
+header {* Partial, Finite and Infinite Sequences (lazy lists), modeled as domain *}
+
+theory Seq
+imports HOLCF
+begin
+
+default_sort pcpo
+
+domain (unsafe) 'a seq = nil  ("nil") | cons (HD :: 'a) (lazy TL :: "'a seq")  (infixr "##" 65)
+
+(*
+   sfilter       :: "('a -> tr) -> 'a seq -> 'a seq"
+   smap          :: "('a -> 'b) -> 'a seq -> 'b seq"
+   sforall       :: "('a -> tr) => 'a seq => bool"
+   sforall2      :: "('a -> tr) -> 'a seq -> tr"
+   slast         :: "'a seq     -> 'a"
+   sconc         :: "'a seq     -> 'a seq -> 'a seq"
+   sdropwhile    :: "('a -> tr)  -> 'a seq -> 'a seq"
+   stakewhile    :: "('a -> tr)  -> 'a seq -> 'a seq"
+   szip          :: "'a seq      -> 'b seq -> ('a*'b) seq"
+   sflat        :: "('a seq) seq  -> 'a seq"
+
+   sfinite       :: "'a seq set"
+   Partial       :: "'a seq => bool"
+   Infinite      :: "'a seq => bool"
+
+   nproj        :: "nat => 'a seq => 'a"
+   sproj        :: "nat => 'a seq => 'a seq"
+*)
+
+inductive
+  Finite :: "'a seq => bool"
+  where
+    sfinite_0:  "Finite nil"
+  | sfinite_n:  "[| Finite tr; a~=UU |] ==> Finite (a##tr)"
+
+declare Finite.intros [simp]
+
+definition
+  Partial :: "'a seq => bool"
+where
+  "Partial x  == (seq_finite x) & ~(Finite x)"
+
+definition
+  Infinite :: "'a seq => bool"
+where
+  "Infinite x == ~(seq_finite x)"
+
+
+subsection {* recursive equations of operators *}
+
+subsubsection {* smap *}
+
+fixrec
+  smap :: "('a -> 'b) -> 'a seq -> 'b seq"
+where
+  smap_nil: "smap$f$nil=nil"
+| smap_cons: "[|x~=UU|] ==> smap$f$(x##xs)= (f$x)##smap$f$xs"
+
+lemma smap_UU [simp]: "smap$f$UU=UU"
+by fixrec_simp
+
+subsubsection {* sfilter *}
+
+fixrec
+   sfilter :: "('a -> tr) -> 'a seq -> 'a seq"
+where
+  sfilter_nil: "sfilter$P$nil=nil"
+| sfilter_cons:
+    "x~=UU ==> sfilter$P$(x##xs)=
+              (If P$x then x##(sfilter$P$xs) else sfilter$P$xs)"
+
+lemma sfilter_UU [simp]: "sfilter$P$UU=UU"
+by fixrec_simp
+
+subsubsection {* sforall2 *}
+
+fixrec
+  sforall2 :: "('a -> tr) -> 'a seq -> tr"
+where
+  sforall2_nil: "sforall2$P$nil=TT"
+| sforall2_cons:
+    "x~=UU ==> sforall2$P$(x##xs)= ((P$x) andalso sforall2$P$xs)"
+
+lemma sforall2_UU [simp]: "sforall2$P$UU=UU"
+by fixrec_simp
+
+definition
+  sforall_def: "sforall P t == (sforall2$P$t ~=FF)"
+
+subsubsection {* stakewhile *}
+
+fixrec
+  stakewhile :: "('a -> tr)  -> 'a seq -> 'a seq"
+where
+  stakewhile_nil: "stakewhile$P$nil=nil"
+| stakewhile_cons:
+    "x~=UU ==> stakewhile$P$(x##xs) =
+              (If P$x then x##(stakewhile$P$xs) else nil)"
+
+lemma stakewhile_UU [simp]: "stakewhile$P$UU=UU"
+by fixrec_simp
+
+subsubsection {* sdropwhile *}
+
+fixrec
+  sdropwhile :: "('a -> tr) -> 'a seq -> 'a seq"
+where
+  sdropwhile_nil: "sdropwhile$P$nil=nil"
+| sdropwhile_cons:
+    "x~=UU ==> sdropwhile$P$(x##xs) =
+              (If P$x then sdropwhile$P$xs else x##xs)"
+
+lemma sdropwhile_UU [simp]: "sdropwhile$P$UU=UU"
+by fixrec_simp
+
+subsubsection {* slast *}
+
+fixrec
+  slast :: "'a seq -> 'a"
+where
+  slast_nil: "slast$nil=UU"
+| slast_cons:
+    "x~=UU ==> slast$(x##xs)= (If is_nil$xs then x else slast$xs)"
+
+lemma slast_UU [simp]: "slast$UU=UU"
+by fixrec_simp
+
+subsubsection {* sconc *}
+
+fixrec
+  sconc :: "'a seq -> 'a seq -> 'a seq"
+where
+  sconc_nil: "sconc$nil$y = y"
+| sconc_cons':
+    "x~=UU ==> sconc$(x##xs)$y = x##(sconc$xs$y)"
+
+abbreviation
+  sconc_syn :: "'a seq => 'a seq => 'a seq"  (infixr "@@" 65) where
+  "xs @@ ys == sconc $ xs $ ys"
+
+lemma sconc_UU [simp]: "UU @@ y=UU"
+by fixrec_simp
+
+lemma sconc_cons [simp]: "(x##xs) @@ y=x##(xs @@ y)"
+apply (cases "x=UU")
+apply simp_all
+done
+
+declare sconc_cons' [simp del]
+
+subsubsection {* sflat *}
+
+fixrec
+  sflat :: "('a seq) seq -> 'a seq"
+where
+  sflat_nil: "sflat$nil=nil"
+| sflat_cons': "x~=UU ==> sflat$(x##xs)= x@@(sflat$xs)"
+
+lemma sflat_UU [simp]: "sflat$UU=UU"
+by fixrec_simp
+
+lemma sflat_cons [simp]: "sflat$(x##xs)= x@@(sflat$xs)"
+by (cases "x=UU", simp_all)
+
+declare sflat_cons' [simp del]
+
+subsubsection {* szip *}
+
+fixrec
+  szip :: "'a seq -> 'b seq -> ('a*'b) seq"
+where
+  szip_nil: "szip$nil$y=nil"
+| szip_cons_nil: "x~=UU ==> szip$(x##xs)$nil=UU"
+| szip_cons:
+    "[| x~=UU; y~=UU|] ==> szip$(x##xs)$(y##ys) = (x,y)##szip$xs$ys"
+
+lemma szip_UU1 [simp]: "szip$UU$y=UU"
+by fixrec_simp
+
+lemma szip_UU2 [simp]: "x~=nil ==> szip$x$UU=UU"
+by (cases x, simp_all, fixrec_simp)
+
+
+subsection "scons, nil"
+
+lemma scons_inject_eq:
+ "[|x~=UU;y~=UU|]==> (x##xs=y##ys) = (x=y & xs=ys)"
+by simp
+
+lemma nil_less_is_nil: "nil<<x ==> nil=x"
+apply (cases x)
+apply simp
+apply simp
+apply simp
+done
+
+subsection "sfilter, sforall, sconc"
+
+lemma if_and_sconc [simp]: "(if b then tr1 else tr2) @@ tr
+        = (if b then tr1 @@ tr else tr2 @@ tr)"
+by simp
+
+
+lemma sfiltersconc: "sfilter$P$(x @@ y) = (sfilter$P$x @@ sfilter$P$y)"
+apply (induct x)
+(* adm *)
+apply simp
+(* base cases *)
+apply simp
+apply simp
+(* main case *)
+apply (rule_tac p="P$a" in trE)
+apply simp
+apply simp
+apply simp
+done
+
+lemma sforallPstakewhileP: "sforall P (stakewhile$P$x)"
+apply (simp add: sforall_def)
+apply (induct x)
+(* adm *)
+apply simp
+(* base cases *)
+apply simp
+apply simp
+(* main case *)
+apply (rule_tac p="P$a" in trE)
+apply simp
+apply simp
+apply simp
+done
+
+lemma forallPsfilterP: "sforall P (sfilter$P$x)"
+apply (simp add: sforall_def)
+apply (induct x)
+(* adm *)
+apply simp
+(* base cases *)
+apply simp
+apply simp
+(* main case *)
+apply (rule_tac p="P$a" in trE)
+apply simp
+apply simp
+apply simp
+done
+
+
+subsection "Finite"
+
+(* ----------------------------------------------------  *)
+(* Proofs of rewrite rules for Finite:                  *)
+(* 1. Finite(nil),   (by definition)                    *)
+(* 2. ~Finite(UU),                                      *)
+(* 3. a~=UU==> Finite(a##x)=Finite(x)                  *)
+(* ----------------------------------------------------  *)
+
+lemma Finite_UU_a: "Finite x --> x~=UU"
+apply (rule impI)
+apply (erule Finite.induct)
+ apply simp
+apply simp
+done
+
+lemma Finite_UU [simp]: "~(Finite UU)"
+apply (cut_tac x="UU" in Finite_UU_a)
+apply fast
+done
+
+lemma Finite_cons_a: "Finite x --> a~=UU --> x=a##xs --> Finite xs"
+apply (intro strip)
+apply (erule Finite.cases)
+apply fastsimp
+apply simp
+done
+
+lemma Finite_cons: "a~=UU ==>(Finite (a##x)) = (Finite x)"
+apply (rule iffI)
+apply (erule (1) Finite_cons_a [rule_format])
+apply fast
+apply simp
+done
+
+lemma Finite_upward: "\<lbrakk>Finite x; x \<sqsubseteq> y\<rbrakk> \<Longrightarrow> Finite y"
+apply (induct arbitrary: y set: Finite)
+apply (case_tac y, simp, simp, simp)
+apply (case_tac y, simp, simp)
+apply simp
+done
+
+lemma adm_Finite [simp]: "adm Finite"
+by (rule adm_upward, rule Finite_upward)
+
+
+subsection "induction"
+
+
+(*--------------------------------   *)
+(* Extensions to Induction Theorems  *)
+(*--------------------------------   *)
+
+
+lemma seq_finite_ind_lemma:
+  assumes "(!!n. P(seq_take n$s))"
+  shows "seq_finite(s) -->P(s)"
+apply (unfold seq.finite_def)
+apply (intro strip)
+apply (erule exE)
+apply (erule subst)
+apply (rule prems)
+done
+
+
+lemma seq_finite_ind: "!!P.[|P(UU);P(nil);
+   !! x s1.[|x~=UU;P(s1)|] ==> P(x##s1)
+   |] ==> seq_finite(s) --> P(s)"
+apply (rule seq_finite_ind_lemma)
+apply (erule seq.finite_induct)
+ apply assumption
+apply simp
+done
+
+end

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/HOLCF/IOA/meta_theory/Sequence.thy	Sat Nov 27 16:08:10 2010 -0800
@@ -0,0 +1,1118 @@
+(*  Title:      HOLCF/IOA/meta_theory/Sequence.thy
+    Author:     Olaf Müller
+
+Sequences over flat domains with lifted elements.
+*)
+
+theory Sequence
+imports Seq
+begin
+
+default_sort type
+
+types 'a Seq = "'a lift seq"
+
+consts
+
+  Consq            ::"'a            => 'a Seq -> 'a Seq"
+  Filter           ::"('a => bool)  => 'a Seq -> 'a Seq"
+  Map              ::"('a => 'b)    => 'a Seq -> 'b Seq"
+  Forall           ::"('a => bool)  => 'a Seq => bool"
+  Last             ::"'a Seq        -> 'a lift"
+  Dropwhile        ::"('a => bool)  => 'a Seq -> 'a Seq"
+  Takewhile        ::"('a => bool)  => 'a Seq -> 'a Seq"
+  Zip              ::"'a Seq        -> 'b Seq -> ('a * 'b) Seq"
+  Flat             ::"('a Seq) seq   -> 'a Seq"
+
+  Filter2          ::"('a => bool)  => 'a Seq -> 'a Seq"
+
+abbreviation
+  Consq_syn  ("(_/>>_)"  [66,65] 65) where
+  "a>>s == Consq a$s"
+
+notation (xsymbols)
+  Consq_syn  ("(_\<leadsto>_)"  [66,65] 65)
+
+
+(* list Enumeration *)
+syntax
+  "_totlist"      :: "args => 'a Seq"              ("[(_)!]")
+  "_partlist"     :: "args => 'a Seq"              ("[(_)?]")
+translations
+  "[x, xs!]"     == "x>>[xs!]"
+  "[x!]"         == "x>>nil"
+  "[x, xs?]"     == "x>>[xs?]"
+  "[x?]"         == "x>>CONST UU"
+
+defs
+
+Consq_def:     "Consq a == LAM s. Def a ## s"
+
+Filter_def:    "Filter P == sfilter$(flift2 P)"
+
+Map_def:       "Map f  == smap$(flift2 f)"
+
+Forall_def:    "Forall P == sforall (flift2 P)"
+
+Last_def:      "Last == slast"
+
+Dropwhile_def: "Dropwhile P == sdropwhile$(flift2 P)"
+
+Takewhile_def: "Takewhile P == stakewhile$(flift2 P)"
+
+Flat_def:      "Flat == sflat"
+
+Zip_def:
+  "Zip == (fix$(LAM h t1 t2. case t1 of
+               nil   => nil
+             | x##xs => (case t2 of
+                          nil => UU
+                        | y##ys => (case x of
+                                      UU  => UU
+                                    | Def a => (case y of
+                                                  UU => UU
+                                                | Def b => Def (a,b)##(h$xs$ys))))))"
+
+Filter2_def:    "Filter2 P == (fix$(LAM h t. case t of
+            nil => nil
+          | x##xs => (case x of UU => UU | Def y => (if P y
+                     then x##(h$xs)
+                     else     h$xs))))"
+
+declare andalso_and [simp]
+declare andalso_or [simp]
+
+subsection "recursive equations of operators"
+
+subsubsection "Map"
+
+lemma Map_UU: "Map f$UU =UU"
+by (simp add: Map_def)
+
+lemma Map_nil: "Map f$nil =nil"
+by (simp add: Map_def)
+
+lemma Map_cons: "Map f$(x>>xs)=(f x) >> Map f$xs"
+by (simp add: Map_def Consq_def flift2_def)
+
+
+subsubsection {* Filter *}
+
+lemma Filter_UU: "Filter P$UU =UU"
+by (simp add: Filter_def)
+
+lemma Filter_nil: "Filter P$nil =nil"
+by (simp add: Filter_def)
+
+lemma Filter_cons:
+  "Filter P$(x>>xs)= (if P x then x>>(Filter P$xs) else Filter P$xs)"
+by (simp add: Filter_def Consq_def flift2_def If_and_if)
+
+
+subsubsection {* Forall *}
+
+lemma Forall_UU: "Forall P UU"
+by (simp add: Forall_def sforall_def)
+
+lemma Forall_nil: "Forall P nil"
+by (simp add: Forall_def sforall_def)
+
+lemma Forall_cons: "Forall P (x>>xs)= (P x & Forall P xs)"
+by (simp add: Forall_def sforall_def Consq_def flift2_def)
+
+
+subsubsection {* Conc *}
+
+lemma Conc_cons: "(x>>xs) @@ y = x>>(xs @@y)"
+by (simp add: Consq_def)
+
+
+subsubsection {* Takewhile *}
+
+lemma Takewhile_UU: "Takewhile P$UU =UU"
+by (simp add: Takewhile_def)
+
+lemma Takewhile_nil: "Takewhile P$nil =nil"
+by (simp add: Takewhile_def)
+
+lemma Takewhile_cons:
+  "Takewhile P$(x>>xs)= (if P x then x>>(Takewhile P$xs) else nil)"
+by (simp add: Takewhile_def Consq_def flift2_def If_and_if)
+
+
+subsubsection {* DropWhile *}
+
+lemma Dropwhile_UU: "Dropwhile P$UU =UU"
+by (simp add: Dropwhile_def)
+
+lemma Dropwhile_nil: "Dropwhile P$nil =nil"
+by (simp add: Dropwhile_def)
+
+lemma Dropwhile_cons:
+  "Dropwhile P$(x>>xs)= (if P x then Dropwhile P$xs else x>>xs)"
+by (simp add: Dropwhile_def Consq_def flift2_def If_and_if)
+
+
+subsubsection {* Last *}
+
+lemma Last_UU: "Last$UU =UU"
+by (simp add: Last_def)
+
+lemma Last_nil: "Last$nil =UU"
+by (simp add: Last_def)
+
+lemma Last_cons: "Last$(x>>xs)= (if xs=nil then Def x else Last$xs)"
+apply (simp add: Last_def Consq_def)
+apply (cases xs)
+apply simp_all
+done
+
+
+subsubsection {* Flat *}
+
+lemma Flat_UU: "Flat$UU =UU"
+by (simp add: Flat_def)
+
+lemma Flat_nil: "Flat$nil =nil"
+by (simp add: Flat_def)
+
+lemma Flat_cons: "Flat$(x##xs)= x @@ (Flat$xs)"
+by (simp add: Flat_def Consq_def)
+
+
+subsubsection {* Zip *}
+
+lemma Zip_unfold:
+"Zip = (LAM t1 t2. case t1 of
+                nil   => nil
+              | x##xs => (case t2 of
+                           nil => UU
+                         | y##ys => (case x of
+                                       UU  => UU
+                                     | Def a => (case y of
+                                                   UU => UU
+                                                 | Def b => Def (a,b)##(Zip$xs$ys)))))"
+apply (rule trans)
+apply (rule fix_eq2)
+apply (rule Zip_def)
+apply (rule beta_cfun)
+apply simp
+done
+
+lemma Zip_UU1: "Zip$UU$y =UU"
+apply (subst Zip_unfold)
+apply simp
+done
+
+lemma Zip_UU2: "x~=nil ==> Zip$x$UU =UU"
+apply (subst Zip_unfold)
+apply simp
+apply (cases x)
+apply simp_all
+done
+
+lemma Zip_nil: "Zip$nil$y =nil"
+apply (subst Zip_unfold)
+apply simp
+done
+
+lemma Zip_cons_nil: "Zip$(x>>xs)$nil= UU"
+apply (subst Zip_unfold)
+apply (simp add: Consq_def)
+done
+
+lemma Zip_cons: "Zip$(x>>xs)$(y>>ys)= (x,y) >> Zip$xs$ys"
+apply (rule trans)
+apply (subst Zip_unfold)
+apply simp
+apply (simp add: Consq_def)
+done
+
+lemmas [simp del] =
+  sfilter_UU sfilter_nil sfilter_cons
+  smap_UU smap_nil smap_cons
+  sforall2_UU sforall2_nil sforall2_cons
+  slast_UU slast_nil slast_cons
+  stakewhile_UU  stakewhile_nil  stakewhile_cons
+  sdropwhile_UU  sdropwhile_nil  sdropwhile_cons
+  sflat_UU sflat_nil sflat_cons
+  szip_UU1 szip_UU2 szip_nil szip_cons_nil szip_cons
+
+lemmas [simp] =
+  Filter_UU Filter_nil Filter_cons
+  Map_UU Map_nil Map_cons
+  Forall_UU Forall_nil Forall_cons
+  Last_UU Last_nil Last_cons
+  Conc_cons
+  Takewhile_UU Takewhile_nil Takewhile_cons
+  Dropwhile_UU Dropwhile_nil Dropwhile_cons
+  Zip_UU1 Zip_UU2 Zip_nil Zip_cons_nil Zip_cons
+
+
+
+section "Cons"
+
+lemma Consq_def2: "a>>s = (Def a)##s"
+apply (simp add: Consq_def)
+done
+
+lemma Seq_exhaust: "x = UU | x = nil | (? a s. x = a >> s)"
+apply (simp add: Consq_def2)
+apply (cut_tac seq.nchotomy)
+apply (fast dest: not_Undef_is_Def [THEN iffD1])
+done
+
+
+lemma Seq_cases:
+"!!P. [| x = UU ==> P; x = nil ==> P; !!a s. x = a >> s  ==> P |] ==> P"
+apply (cut_tac x="x" in Seq_exhaust)
+apply (erule disjE)
+apply simp
+apply (erule disjE)
+apply simp
+apply (erule exE)+
+apply simp
+done
+
+(*
+fun Seq_case_tac s i = rule_tac x",s)] Seq_cases i
+          THEN hyp_subst_tac i THEN hyp_subst_tac (i+1) THEN hyp_subst_tac (i+2);
+*)
+(* on a>>s only simp_tac, as full_simp_tac is uncomplete and often causes errors *)
+(*
+fun Seq_case_simp_tac s i = Seq_case_tac s i THEN Asm_simp_tac (i+2)
+                                             THEN Asm_full_simp_tac (i+1)
+                                             THEN Asm_full_simp_tac i;
+*)
+
+lemma Cons_not_UU: "a>>s ~= UU"
+apply (subst Consq_def2)
+apply simp
+done
+
+
+lemma Cons_not_less_UU: "~(a>>x) << UU"
+apply (rule notI)
+apply (drule below_antisym)
+apply simp
+apply (simp add: Cons_not_UU)
+done
+
+lemma Cons_not_less_nil: "~a>>s << nil"
+apply (simp add: Consq_def2)
+done
+
+lemma Cons_not_nil: "a>>s ~= nil"
+apply (simp add: Consq_def2)
+done
+
+lemma Cons_not_nil2: "nil ~= a>>s"
+apply (simp add: Consq_def2)
+done
+
+lemma Cons_inject_eq: "(a>>s = b>>t) = (a = b & s = t)"
+apply (simp only: Consq_def2)
+apply (simp add: scons_inject_eq)
+done
+
+lemma Cons_inject_less_eq: "(a>>s<<b>>t) = (a = b & s<<t)"
+apply (simp add: Consq_def2)
+done
+
+lemma seq_take_Cons: "seq_take (Suc n)$(a>>x) = a>> (seq_take n$x)"
+apply (simp add: Consq_def)
+done
+
+lemmas [simp] =
+  Cons_not_nil2 Cons_inject_eq Cons_inject_less_eq seq_take_Cons
+  Cons_not_UU Cons_not_less_UU Cons_not_less_nil Cons_not_nil
+
+
+subsection "induction"
+
+lemma Seq_induct:
+"!! P. [| adm P; P UU; P nil; !! a s. P s ==> P (a>>s)|] ==> P x"
+apply (erule (2) seq.induct)
+apply defined
+apply (simp add: Consq_def)
+done
+
+lemma Seq_FinitePartial_ind:
+"!! P.[|P UU;P nil; !! a s. P s ==> P(a>>s) |]
+                ==> seq_finite x --> P x"
+apply (erule (1) seq_finite_ind)
+apply defined
+apply (simp add: Consq_def)
+done
+
+lemma Seq_Finite_ind:
+"!! P.[| Finite x; P nil; !! a s. [| Finite s; P s|] ==> P (a>>s) |] ==> P x"
+apply (erule (1) Finite.induct)
+apply defined
+apply (simp add: Consq_def)
+done
+
+
+(* rws are definitions to be unfolded for admissibility check *)
+(*
+fun Seq_induct_tac s rws i = rule_tac x",s)] Seq_induct i
+                         THEN (REPEAT_DETERM (CHANGED (Asm_simp_tac (i+1))))
+                         THEN simp add: rws) i;
+
+fun Seq_Finite_induct_tac i = erule Seq_Finite_ind i
+                              THEN (REPEAT_DETERM (CHANGED (Asm_simp_tac i)));
+
+fun pair_tac s = rule_tac p",s)] PairE
+                          THEN' hyp_subst_tac THEN' Simp_tac;
+*)
+(* induction on a sequence of pairs with pairsplitting and simplification *)
+(*
+fun pair_induct_tac s rws i =
+           rule_tac x",s)] Seq_induct i
+           THEN pair_tac "a" (i+3)
+           THEN (REPEAT_DETERM (CHANGED (Simp_tac (i+1))))
+           THEN simp add: rws) i;
+*)
+
+
+(* ------------------------------------------------------------------------------------ *)
+
+subsection "HD,TL"
+
+lemma HD_Cons [simp]: "HD$(x>>y) = Def x"
+apply (simp add: Consq_def)
+done
+
+lemma TL_Cons [simp]: "TL$(x>>y) = y"
+apply (simp add: Consq_def)
+done
+
+(* ------------------------------------------------------------------------------------ *)
+
+subsection "Finite, Partial, Infinite"
+
+lemma Finite_Cons [simp]: "Finite (a>>xs) = Finite xs"
+apply (simp add: Consq_def2 Finite_cons)
+done
+
+lemma FiniteConc_1: "Finite (x::'a Seq) ==> Finite y --> Finite (x@@y)"
+apply (erule Seq_Finite_ind, simp_all)
+done
+
+lemma FiniteConc_2:
+"Finite (z::'a Seq) ==> !x y. z= x@@y --> (Finite x & Finite y)"
+apply (erule Seq_Finite_ind)
+(* nil*)
+apply (intro strip)
+apply (rule_tac x="x" in Seq_cases, simp_all)
+(* cons *)
+apply (intro strip)
+apply (rule_tac x="x" in Seq_cases, simp_all)
+apply (rule_tac x="y" in Seq_cases, simp_all)
+done
+
+lemma FiniteConc [simp]: "Finite(x@@y) = (Finite (x::'a Seq) & Finite y)"
+apply (rule iffI)
+apply (erule FiniteConc_2 [rule_format])
+apply (rule refl)
+apply (rule FiniteConc_1 [rule_format])
+apply auto
+done
+
+
+lemma FiniteMap1: "Finite s ==> Finite (Map f$s)"
+apply (erule Seq_Finite_ind, simp_all)
+done
+
+lemma FiniteMap2: "Finite s ==> ! t. (s = Map f$t) --> Finite t"
+apply (erule Seq_Finite_ind)
+apply (intro strip)
+apply (rule_tac x="t" in Seq_cases, simp_all)
+(* main case *)
+apply auto
+apply (rule_tac x="t" in Seq_cases, simp_all)
+done
+
+lemma Map2Finite: "Finite (Map f$s) = Finite s"
+apply auto
+apply (erule FiniteMap2 [rule_format])
+apply (rule refl)
+apply (erule FiniteMap1)
+done
+
+
+lemma FiniteFilter: "Finite s ==> Finite (Filter P$s)"
+apply (erule Seq_Finite_ind, simp_all)
+done
+
+
+(* ----------------------------------------------------------------------------------- *)
+
+subsection "Conc"
+
+lemma Conc_cong: "!! x::'a Seq. Finite x ==> ((x @@ y) = (x @@ z)) = (y = z)"
+apply (erule Seq_Finite_ind, simp_all)
+done
+
+lemma Conc_assoc: "(x @@ y) @@ z = (x::'a Seq) @@ y @@ z"
+apply (rule_tac x="x" in Seq_induct, simp_all)
+done
+
+lemma nilConc [simp]: "s@@ nil = s"
+apply (induct s)
+apply simp
+apply simp
+apply simp
+apply simp
+done
+
+
+(* should be same as nil_is_Conc2 when all nils are turned to right side !! *)
+lemma nil_is_Conc: "(nil = x @@ y) = ((x::'a Seq)= nil & y = nil)"
+apply (rule_tac x="x" in Seq_cases)
+apply auto
+done
+
+lemma nil_is_Conc2: "(x @@ y = nil) = ((x::'a Seq)= nil & y = nil)"
+apply (rule_tac x="x" in Seq_cases)
+apply auto
+done
+
+
+(* ------------------------------------------------------------------------------------ *)
+
+subsection "Last"
+
+lemma Finite_Last1: "Finite s ==> s~=nil --> Last$s~=UU"
+apply (erule Seq_Finite_ind, simp_all)
+done
+
+lemma Finite_Last2: "Finite s ==> Last$s=UU --> s=nil"
+apply (erule Seq_Finite_ind, simp_all)
+apply fast
+done
+
+
+(* ------------------------------------------------------------------------------------ *)
+
+
+subsection "Filter, Conc"
+
+
+lemma FilterPQ: "Filter P$(Filter Q$s) = Filter (%x. P x & Q x)$s"
+apply (rule_tac x="s" in Seq_induct, simp_all)
+done
+
+lemma FilterConc: "Filter P$(x @@ y) = (Filter P$x @@ Filter P$y)"
+apply (simp add: Filter_def sfiltersconc)
+done
+
+(* ------------------------------------------------------------------------------------ *)
+
+subsection "Map"
+
+lemma MapMap: "Map f$(Map g$s) = Map (f o g)$s"
+apply (rule_tac x="s" in Seq_induct, simp_all)
+done
+
+lemma MapConc: "Map f$(x@@y) = (Map f$x) @@ (Map f$y)"
+apply (rule_tac x="x" in Seq_induct, simp_all)
+done
+
+lemma MapFilter: "Filter P$(Map f$x) = Map f$(Filter (P o f)$x)"
+apply (rule_tac x="x" in Seq_induct, simp_all)
+done
+
+lemma nilMap: "nil = (Map f$s) --> s= nil"
+apply (rule_tac x="s" in Seq_cases, simp_all)
+done
+
+
+lemma ForallMap: "Forall P (Map f$s) = Forall (P o f) s"
+apply (rule_tac x="s" in Seq_induct)
+apply (simp add: Forall_def sforall_def)
+apply simp_all
+done
+
+
+
+
+(* ------------------------------------------------------------------------------------ *)
+
+subsection "Forall"
+
+
+lemma ForallPForallQ1: "Forall P ys & (! x. P x --> Q x)
+         --> Forall Q ys"
+apply (rule_tac x="ys" in Seq_induct)
+apply (simp add: Forall_def sforall_def)
+apply simp_all
+done
+
+lemmas ForallPForallQ =
+  ForallPForallQ1 [THEN mp, OF conjI, OF _ allI, OF _ impI]
+
+lemma Forall_Conc_impl: "(Forall P x & Forall P y) --> Forall P (x @@ y)"
+apply (rule_tac x="x" in Seq_induct)
+apply (simp add: Forall_def sforall_def)
+apply simp_all
+done
+
+lemma Forall_Conc [simp]:
+  "Finite x ==> Forall P (x @@ y) = (Forall P x & Forall P y)"
+apply (erule Seq_Finite_ind, simp_all)
+done
+
+lemma ForallTL1: "Forall P s  --> Forall P (TL$s)"
+apply (rule_tac x="s" in Seq_induct)
+apply (simp add: Forall_def sforall_def)
+apply simp_all
+done
+
+lemmas ForallTL = ForallTL1 [THEN mp]
+
+lemma ForallDropwhile1: "Forall P s  --> Forall P (Dropwhile Q$s)"
+apply (rule_tac x="s" in Seq_induct)
+apply (simp add: Forall_def sforall_def)
+apply simp_all
+done
+
+lemmas ForallDropwhile = ForallDropwhile1 [THEN mp]
+
+
+(* only admissible in t, not if done in s *)
+
+lemma Forall_prefix: "! s. Forall P s --> t<<s --> Forall P t"
+apply (rule_tac x="t" in Seq_induct)
+apply (simp add: Forall_def sforall_def)
+apply simp_all
+apply (intro strip)
+apply (rule_tac x="sa" in Seq_cases)
+apply simp
+apply auto
+done
+
+lemmas Forall_prefixclosed = Forall_prefix [rule_format]
+
+lemma Forall_postfixclosed:
+  "[| Finite h; Forall P s; s= h @@ t |] ==> Forall P t"
+apply auto
+done
+
+
+lemma ForallPFilterQR1:
+  "((! x. P x --> (Q x = R x)) & Forall P tr) --> Filter Q$tr = Filter R$tr"
+apply (rule_tac x="tr" in Seq_induct)
+apply (simp add: Forall_def sforall_def)
+apply simp_all
+done
+
+lemmas ForallPFilterQR = ForallPFilterQR1 [THEN mp, OF conjI, OF allI]
+
+
+(* ------------------------------------------------------------------------------------- *)
+
+subsection "Forall, Filter"
+
+
+lemma ForallPFilterP: "Forall P (Filter P$x)"
+apply (simp add: Filter_def Forall_def forallPsfilterP)
+done
+
+(* holds also in other direction, then equal to forallPfilterP *)
+lemma ForallPFilterPid1: "Forall P x --> Filter P$x = x"
+apply (rule_tac x="x" in Seq_induct)
+apply (simp add: Forall_def sforall_def Filter_def)
+apply simp_all
+done
+
+lemmas ForallPFilterPid = ForallPFilterPid1 [THEN mp]
+
+
+(* holds also in other direction *)
+lemma ForallnPFilterPnil1: "!! ys . Finite ys ==>
+   Forall (%x. ~P x) ys --> Filter P$ys = nil "
+apply (erule Seq_Finite_ind, simp_all)
+done
+
+lemmas ForallnPFilterPnil = ForallnPFilterPnil1 [THEN mp]
+
+
+(* holds also in other direction *)
+lemma ForallnPFilterPUU1: "~Finite ys & Forall (%x. ~P x) ys
+                  --> Filter P$ys = UU "
+apply (rule_tac x="ys" in Seq_induct)
+apply (simp add: Forall_def sforall_def)
+apply simp_all
+done
+
+lemmas ForallnPFilterPUU = ForallnPFilterPUU1 [THEN mp, OF conjI]
+
+
+(* inverse of ForallnPFilterPnil *)
+
+lemma FilternPnilForallP1: "!! ys . Filter P$ys = nil -->
+   (Forall (%x. ~P x) ys & Finite ys)"
+apply (rule_tac x="ys" in Seq_induct)
+(* adm *)
+apply (simp add: Forall_def sforall_def)
+(* base cases *)
+apply simp
+apply simp
+(* main case *)
+apply simp
+done
+
+lemmas FilternPnilForallP = FilternPnilForallP1 [THEN mp]
+
+(* inverse of ForallnPFilterPUU. proved apply 2 lemmas because of adm problems *)
+
+lemma FilterUU_nFinite_lemma1: "Finite ys ==> Filter P$ys ~= UU"
+apply (erule Seq_Finite_ind, simp_all)
+done
+
+lemma FilterUU_nFinite_lemma2: "~ Forall (%x. ~P x) ys --> Filter P$ys ~= UU"
+apply (rule_tac x="ys" in Seq_induct)
+apply (simp add: Forall_def sforall_def)
+apply simp_all
+done
+
+lemma FilternPUUForallP:
+  "Filter P$ys = UU ==> (Forall (%x. ~P x) ys  & ~Finite ys)"
+apply (rule conjI)
+apply (cut_tac FilterUU_nFinite_lemma2 [THEN mp, COMP rev_contrapos])
+apply auto
+apply (blast dest!: FilterUU_nFinite_lemma1)
+done
+
+
+lemma ForallQFilterPnil:
+  "!! Q P.[| Forall Q ys; Finite ys; !!x. Q x ==> ~P x|]
+    ==> Filter P$ys = nil"
+apply (erule ForallnPFilterPnil)
+apply (erule ForallPForallQ)
+apply auto
+done
+
+lemma ForallQFilterPUU:
+ "!! Q P. [| ~Finite ys; Forall Q ys;  !!x. Q x ==> ~P x|]
+    ==> Filter P$ys = UU "
+apply (erule ForallnPFilterPUU)
+apply (erule ForallPForallQ)
+apply auto
+done
+
+
+
+(* ------------------------------------------------------------------------------------- *)
+
+subsection "Takewhile, Forall, Filter"
+
+
+lemma ForallPTakewhileP [simp]: "Forall P (Takewhile P$x)"
+apply (simp add: Forall_def Takewhile_def sforallPstakewhileP)
+done
+
+
+lemma ForallPTakewhileQ [simp]:
+"!! P. [| !!x. Q x==> P x |] ==> Forall P (Takewhile Q$x)"
+apply (rule ForallPForallQ)
+apply (rule ForallPTakewhileP)
+apply auto
+done
+
+
+lemma FilterPTakewhileQnil [simp]:
+  "!! Q P.[| Finite (Takewhile Q$ys); !!x. Q x ==> ~P x |]
+   ==> Filter P$(Takewhile Q$ys) = nil"
+apply (erule ForallnPFilterPnil)
+apply (rule ForallPForallQ)
+apply (rule ForallPTakewhileP)
+apply auto
+done
+
+lemma FilterPTakewhileQid [simp]:
+ "!! Q P. [| !!x. Q x ==> P x |] ==>
+            Filter P$(Takewhile Q$ys) = (Takewhile Q$ys)"
+apply (rule ForallPFilterPid)
+apply (rule ForallPForallQ)
+apply (rule ForallPTakewhileP)
+apply auto
+done
+
+
+lemma Takewhile_idempotent: "Takewhile P$(Takewhile P$s) = Takewhile P$s"
+apply (rule_tac x="s" in Seq_induct)
+apply (simp add: Forall_def sforall_def)
+apply simp_all
+done
+
+lemma ForallPTakewhileQnP [simp]:
+ "Forall P s --> Takewhile (%x. Q x | (~P x))$s = Takewhile Q$s"
+apply (rule_tac x="s" in Seq_induct)
+apply (simp add: Forall_def sforall_def)
+apply simp_all
+done
+
+lemma ForallPDropwhileQnP [simp]:
+ "Forall P s --> Dropwhile (%x. Q x | (~P x))$s = Dropwhile Q$s"
+apply (rule_tac x="s" in Seq_induct)
+apply (simp add: Forall_def sforall_def)
+apply simp_all
+done
+
+
+lemma TakewhileConc1:
+ "Forall P s --> Takewhile P$(s @@ t) = s @@ (Takewhile P$t)"
+apply (rule_tac x="s" in Seq_induct)
+apply (simp add: Forall_def sforall_def)
+apply simp_all
+done
+
+lemmas TakewhileConc = TakewhileConc1 [THEN mp]
+
+lemma DropwhileConc1:
+ "Finite s ==> Forall P s --> Dropwhile P$(s @@ t) = Dropwhile P$t"
+apply (erule Seq_Finite_ind, simp_all)
+done
+
+lemmas DropwhileConc = DropwhileConc1 [THEN mp]
+
+
+
+(* ----------------------------------------------------------------------------------- *)
+
+subsection "coinductive characterizations of Filter"
+
+
+lemma divide_Seq_lemma:
+ "HD$(Filter P$y) = Def x
+    --> y = ((Takewhile (%x. ~P x)$y) @@ (x >> TL$(Dropwhile (%a.~P a)$y))) 
+             & Finite (Takewhile (%x. ~ P x)$y)  & P x"
+
+(* FIX: pay attention: is only admissible with chain-finite package to be added to
+        adm test and Finite f x admissibility *)
+apply (rule_tac x="y" in Seq_induct)
+apply (simp add: adm_subst [OF _ adm_Finite])
+apply simp
+apply simp
+apply (case_tac "P a")
+ apply simp
+ apply blast
+(* ~ P a *)
+apply simp
+done
+
+lemma divide_Seq: "(x>>xs) << Filter P$y 
+   ==> y = ((Takewhile (%a. ~ P a)$y) @@ (x >> TL$(Dropwhile (%a.~P a)$y)))
+      & Finite (Takewhile (%a. ~ P a)$y)  & P x"
+apply (rule divide_Seq_lemma [THEN mp])
+apply (drule_tac f="HD" and x="x>>xs" in  monofun_cfun_arg)
+apply simp
+done
+
+
+lemma nForall_HDFilter:
+ "~Forall P y --> (? x. HD$(Filter (%a. ~P a)$y) = Def x)"
+unfolding not_Undef_is_Def [symmetric]
+apply (induct y rule: Seq_induct)
+apply (simp add: Forall_def sforall_def)
+apply simp_all
+done
+
+
+lemma divide_Seq2: "~Forall P y
+  ==> ? x. y= (Takewhile P$y @@ (x >> TL$(Dropwhile P$y))) &
+      Finite (Takewhile P$y) & (~ P x)"
+apply (drule nForall_HDFilter [THEN mp])
+apply safe
+apply (rule_tac x="x" in exI)
+apply (cut_tac P1="%x. ~ P x" in divide_Seq_lemma [THEN mp])
+apply auto
+done
+
+
+lemma divide_Seq3: "~Forall P y
+  ==> ? x bs rs. y= (bs @@ (x>>rs)) & Finite bs & Forall P bs & (~ P x)"
+apply (drule divide_Seq2)
+(*Auto_tac no longer proves it*)
+apply fastsimp
+done
+
+lemmas [simp] = FilterPQ FilterConc Conc_cong
+
+
+(* ------------------------------------------------------------------------------------- *)
+
+
+subsection "take_lemma"
+
+lemma seq_take_lemma: "(!n. seq_take n$x = seq_take n$x') = (x = x')"
+apply (rule iffI)
+apply (rule seq.take_lemma)
+apply auto
+done
+
+lemma take_reduction1:
+"  ! n. ((! k. k < n --> seq_take k$y1 = seq_take k$y2)
+    --> seq_take n$(x @@ (t>>y1)) =  seq_take n$(x @@ (t>>y2)))"
+apply (rule_tac x="x" in Seq_induct)
+apply simp_all
+apply (intro strip)
+apply (case_tac "n")
+apply auto
+apply (case_tac "n")
+apply auto
+done
+
+
+lemma take_reduction:
+ "!! n.[| x=y; s=t; !! k. k<n ==> seq_take k$y1 = seq_take k$y2|]
+  ==> seq_take n$(x @@ (s>>y1)) =  seq_take n$(y @@ (t>>y2))"
+apply (auto intro!: take_reduction1 [rule_format])
+done
+
+(* ------------------------------------------------------------------
+          take-lemma and take_reduction for << instead of =
+   ------------------------------------------------------------------ *)
+
+lemma take_reduction_less1:
+"  ! n. ((! k. k < n --> seq_take k$y1 << seq_take k$y2)
+    --> seq_take n$(x @@ (t>>y1)) <<  seq_take n$(x @@ (t>>y2)))"
+apply (rule_tac x="x" in Seq_induct)
+apply simp_all
+apply (intro strip)
+apply (case_tac "n")
+apply auto
+apply (case_tac "n")
+apply auto
+done
+
+
+lemma take_reduction_less:
+ "!! n.[| x=y; s=t;!! k. k<n ==> seq_take k$y1 << seq_take k$y2|]
+  ==> seq_take n$(x @@ (s>>y1)) <<  seq_take n$(y @@ (t>>y2))"
+apply (auto intro!: take_reduction_less1 [rule_format])
+done
+
+lemma take_lemma_less1:
+  assumes "!! n. seq_take n$s1 << seq_take n$s2"
+  shows "s1<<s2"
+apply (rule_tac t="s1" in seq.reach [THEN subst])
+apply (rule_tac t="s2" in seq.reach [THEN subst])
+apply (rule lub_mono)
+apply (rule seq.chain_take [THEN ch2ch_Rep_cfunL])
+apply (rule seq.chain_take [THEN ch2ch_Rep_cfunL])
+apply (rule assms)
+done
+
+
+lemma take_lemma_less: "(!n. seq_take n$x << seq_take n$x') = (x << x')"
+apply (rule iffI)
+apply (rule take_lemma_less1)
+apply auto
+apply (erule monofun_cfun_arg)
+done
+
+(* ------------------------------------------------------------------
+          take-lemma proof principles
+   ------------------------------------------------------------------ *)
+
+lemma take_lemma_principle1:
+ "!! Q. [|!! s. [| Forall Q s; A s |] ==> (f s) = (g s) ;
+            !! s1 s2 y. [| Forall Q s1; Finite s1; ~ Q y; A (s1 @@ y>>s2)|]
+                          ==> (f (s1 @@ y>>s2)) = (g (s1 @@ y>>s2)) |]
+               ==> A x --> (f x)=(g x)"
+apply (case_tac "Forall Q x")
+apply (auto dest!: divide_Seq3)
+done
+
+lemma take_lemma_principle2:
+  "!! Q. [|!! s. [| Forall Q s; A s |] ==> (f s) = (g s) ;
+           !! s1 s2 y. [| Forall Q s1; Finite s1; ~ Q y; A (s1 @@ y>>s2)|]
+                          ==> ! n. seq_take n$(f (s1 @@ y>>s2))
+                                 = seq_take n$(g (s1 @@ y>>s2)) |]
+               ==> A x --> (f x)=(g x)"
+apply (case_tac "Forall Q x")
+apply (auto dest!: divide_Seq3)
+apply (rule seq.take_lemma)
+apply auto
+done
+
+
+(* Note: in the following proofs the ordering of proof steps is very
+         important, as otherwise either (Forall Q s1) would be in the IH as
+         assumption (then rule useless) or it is not possible to strengthen
+         the IH apply doing a forall closure of the sequence t (then rule also useless).
+         This is also the reason why the induction rule (nat_less_induct or nat_induct) has to
+         to be imbuilt into the rule, as induction has to be done early and the take lemma
+         has to be used in the trivial direction afterwards for the (Forall Q x) case.  *)
+
+lemma take_lemma_induct:
+"!! Q. [|!! s. [| Forall Q s; A s |] ==> (f s) = (g s) ;
+         !! s1 s2 y n. [| ! t. A t --> seq_take n$(f t) = seq_take n$(g t);
+                          Forall Q s1; Finite s1; ~ Q y; A (s1 @@ y>>s2) |]
+                          ==>   seq_take (Suc n)$(f (s1 @@ y>>s2))
+                              = seq_take (Suc n)$(g (s1 @@ y>>s2)) |]
+               ==> A x --> (f x)=(g x)"
+apply (rule impI)
+apply (rule seq.take_lemma)
+apply (rule mp)
+prefer 2 apply assumption
+apply (rule_tac x="x" in spec)
+apply (rule nat.induct)
+apply simp
+apply (rule allI)
+apply (case_tac "Forall Q xa")
+apply (force intro!: seq_take_lemma [THEN iffD2, THEN spec])
+apply (auto dest!: divide_Seq3)
+done
+
+
+lemma take_lemma_less_induct:
+"!! Q. [|!! s. [| Forall Q s; A s |] ==> (f s) = (g s) ;
+        !! s1 s2 y n. [| ! t m. m < n --> A t --> seq_take m$(f t) = seq_take m$(g t);
+                          Forall Q s1; Finite s1; ~ Q y; A (s1 @@ y>>s2) |]
+                          ==>   seq_take n$(f (s1 @@ y>>s2))
+                              = seq_take n$(g (s1 @@ y>>s2)) |]
+               ==> A x --> (f x)=(g x)"
+apply (rule impI)
+apply (rule seq.take_lemma)
+apply (rule mp)
+prefer 2 apply assumption
+apply (rule_tac x="x" in spec)
+apply (rule nat_less_induct)
+apply (rule allI)
+apply (case_tac "Forall Q xa")
+apply (force intro!: seq_take_lemma [THEN iffD2, THEN spec])
+apply (auto dest!: divide_Seq3)
+done
+
+
+
+lemma take_lemma_in_eq_out:
+"!! Q. [| A UU  ==> (f UU) = (g UU) ;
+          A nil ==> (f nil) = (g nil) ;
+          !! s y n. [| ! t. A t --> seq_take n$(f t) = seq_take n$(g t);
+                     A (y>>s) |]
+                     ==>   seq_take (Suc n)$(f (y>>s))
+                         = seq_take (Suc n)$(g (y>>s)) |]
+               ==> A x --> (f x)=(g x)"
+apply (rule impI)
+apply (rule seq.take_lemma)
+apply (rule mp)
+prefer 2 apply assumption
+apply (rule_tac x="x" in spec)
+apply (rule nat.induct)
+apply simp
+apply (rule allI)
+apply (rule_tac x="xa" in Seq_cases)
+apply simp_all
+done
+
+
+(* ------------------------------------------------------------------------------------ *)
+
+subsection "alternative take_lemma proofs"
+
+
+(* --------------------------------------------------------------- *)
+(*              Alternative Proof of FilterPQ                      *)
+(* --------------------------------------------------------------- *)
+
+declare FilterPQ [simp del]
+
+
+(* In general: How to do this case without the same adm problems
+   as for the entire proof ? *)
+lemma Filter_lemma1: "Forall (%x.~(P x & Q x)) s
+          --> Filter P$(Filter Q$s) =
+              Filter (%x. P x & Q x)$s"
+
+apply (rule_tac x="s" in Seq_induct)
+apply (simp add: Forall_def sforall_def)
+apply simp_all
+done
+
+lemma Filter_lemma2: "Finite s ==>
+          (Forall (%x. (~P x) | (~ Q x)) s
+          --> Filter P$(Filter Q$s) = nil)"
+apply (erule Seq_Finite_ind, simp_all)
+done
+
+lemma Filter_lemma3: "Finite s ==>
+          Forall (%x. (~P x) | (~ Q x)) s
+          --> Filter (%x. P x & Q x)$s = nil"
+apply (erule Seq_Finite_ind, simp_all)
+done
+
+
+lemma FilterPQ_takelemma: "Filter P$(Filter Q$s) = Filter (%x. P x & Q x)$s"
+apply (rule_tac A1="%x. True" and
+                 Q1="%x.~(P x & Q x)" and x1="s" in
+                 take_lemma_induct [THEN mp])
+(* better support for A = %x. True *)
+apply (simp add: Filter_lemma1)
+apply (simp add: Filter_lemma2 Filter_lemma3)
+apply simp
+done
+
+declare FilterPQ [simp]
+
+
+(* --------------------------------------------------------------- *)
+(*              Alternative Proof of MapConc                       *)
+(* --------------------------------------------------------------- *)
+
+
+
+lemma MapConc_takelemma: "Map f$(x@@y) = (Map f$x) @@ (Map f$y)"
+apply (rule_tac A1="%x. True" and x1="x" in
+    take_lemma_in_eq_out [THEN mp])
+apply auto
+done
+
+
+ML {*
+
+fun Seq_case_tac ctxt s i =
+  res_inst_tac ctxt [(("x", 0), s)] @{thm Seq_cases} i
+  THEN hyp_subst_tac i THEN hyp_subst_tac (i+1) THEN hyp_subst_tac (i+2);
+
+(* on a>>s only simp_tac, as full_simp_tac is uncomplete and often causes errors *)
+fun Seq_case_simp_tac ctxt s i =
+  let val ss = simpset_of ctxt in
+    Seq_case_tac ctxt s i
+    THEN asm_simp_tac ss (i+2)
+    THEN asm_full_simp_tac ss (i+1)
+    THEN asm_full_simp_tac ss i
+  end;
+
+(* rws are definitions to be unfolded for admissibility check *)
+fun Seq_induct_tac ctxt s rws i =
+  let val ss = simpset_of ctxt in
+    res_inst_tac ctxt [(("x", 0), s)] @{thm Seq_induct} i
+    THEN (REPEAT_DETERM (CHANGED (asm_simp_tac ss (i+1))))
+    THEN simp_tac (ss addsimps rws) i
+  end;
+
+fun Seq_Finite_induct_tac ctxt i =
+  etac @{thm Seq_Finite_ind} i
+  THEN (REPEAT_DETERM (CHANGED (asm_simp_tac (simpset_of ctxt) i)));
+
+fun pair_tac ctxt s =
+  res_inst_tac ctxt [(("p", 0), s)] @{thm PairE}
+  THEN' hyp_subst_tac THEN' asm_full_simp_tac (simpset_of ctxt);
+
+(* induction on a sequence of pairs with pairsplitting and simplification *)
+fun pair_induct_tac ctxt s rws i =
+  let val ss = simpset_of ctxt in
+    res_inst_tac ctxt [(("x", 0), s)] @{thm Seq_induct} i
+    THEN pair_tac ctxt "a" (i+3)
+    THEN (REPEAT_DETERM (CHANGED (simp_tac ss (i+1))))
+    THEN simp_tac (ss addsimps rws) i
+  end;
+
+*}
+
+end

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/HOLCF/IOA/meta_theory/ShortExecutions.thy	Sat Nov 27 16:08:10 2010 -0800
@@ -0,0 +1,278 @@
+(*  Title:      HOLCF/IOA/meta_theory/ShortExecutions.thy
+    Author:     Olaf Müller
+*)
+
+theory ShortExecutions
+imports Traces
+begin
+
+text {*
+  Some properties about @{text "Cut ex"}, defined as follows:
+
+  For every execution ex there is another shorter execution @{text "Cut ex"}
+  that has the same trace as ex, but its schedule ends with an external action.
+*}
+
+definition
+  oraclebuild :: "('a => bool) => 'a Seq -> 'a Seq -> 'a Seq" where
+  "oraclebuild P = (fix$(LAM h s t. case t of
+       nil => nil
+    | x##xs =>
+      (case x of
+        UU => UU
+      | Def y => (Takewhile (%x.~P x)$s)
+                  @@ (y>>(h$(TL$(Dropwhile (%x.~ P x)$s))$xs))
+      )
+    ))"
+
+definition
+  Cut :: "('a => bool) => 'a Seq => 'a Seq" where
+  "Cut P s = oraclebuild P$s$(Filter P$s)"
+
+definition
+  LastActExtsch :: "('a,'s)ioa => 'a Seq => bool" where
+  "LastActExtsch A sch = (Cut (%x. x: ext A) sch = sch)"
+
+(* LastActExtex      ::"('a,'s)ioa => ('a,'s) pairs  => bool"*)
+(* LastActExtex_def:
+  "LastActExtex A ex == LastActExtsch A (filter_act$ex)" *)
+
+axiomatization where
+  Cut_prefixcl_Finite: "Finite s ==> (? y. s = Cut P s @@ y)"
+
+axiomatization where
+  LastActExtsmall1: "LastActExtsch A sch ==> LastActExtsch A (TL$(Dropwhile P$sch))"
+
+axiomatization where
+  LastActExtsmall2: "[| Finite sch1; LastActExtsch A (sch1 @@ sch2) |] ==> LastActExtsch A sch2"
+
+
+ML {*
+fun thin_tac' j =
+  rotate_tac (j - 1) THEN'
+  etac thin_rl THEN'
+  rotate_tac (~ (j - 1))
+*}
+
+
+subsection "oraclebuild rewrite rules"
+
+
+lemma oraclebuild_unfold:
+"oraclebuild P = (LAM s t. case t of
+       nil => nil
+    | x##xs =>
+      (case x of
+        UU => UU
+      | Def y => (Takewhile (%a.~ P a)$s)
+                  @@ (y>>(oraclebuild P$(TL$(Dropwhile (%a.~ P a)$s))$xs))
+      )
+    )"
+apply (rule trans)
+apply (rule fix_eq2)
+apply (simp only: oraclebuild_def)
+apply (rule beta_cfun)
+apply simp
+done
+
+lemma oraclebuild_UU: "oraclebuild P$sch$UU = UU"
+apply (subst oraclebuild_unfold)
+apply simp
+done
+
+lemma oraclebuild_nil: "oraclebuild P$sch$nil = nil"
+apply (subst oraclebuild_unfold)
+apply simp
+done
+
+lemma oraclebuild_cons: "oraclebuild P$s$(x>>t) =
+          (Takewhile (%a.~ P a)$s)
+           @@ (x>>(oraclebuild P$(TL$(Dropwhile (%a.~ P a)$s))$t))"
+apply (rule trans)
+apply (subst oraclebuild_unfold)
+apply (simp add: Consq_def)
+apply (simp add: Consq_def)
+done
+
+
+subsection "Cut rewrite rules"
+
+lemma Cut_nil:
+"[| Forall (%a.~ P a) s; Finite s|]
+            ==> Cut P s =nil"
+apply (unfold Cut_def)
+apply (subgoal_tac "Filter P$s = nil")
+apply (simp (no_asm_simp) add: oraclebuild_nil)
+apply (rule ForallQFilterPnil)
+apply assumption+
+done
+
+lemma Cut_UU:
+"[| Forall (%a.~ P a) s; ~Finite s|]
+            ==> Cut P s =UU"
+apply (unfold Cut_def)
+apply (subgoal_tac "Filter P$s= UU")
+apply (simp (no_asm_simp) add: oraclebuild_UU)
+apply (rule ForallQFilterPUU)
+apply assumption+
+done
+
+lemma Cut_Cons:
+"[| P t;  Forall (%x.~ P x) ss; Finite ss|]
+            ==> Cut P (ss @@ (t>> rs))
+                 = ss @@ (t >> Cut P rs)"
+apply (unfold Cut_def)
+apply (simp add: ForallQFilterPnil oraclebuild_cons TakewhileConc DropwhileConc)
+done
+
+
+subsection "Cut lemmas for main theorem"
+
+lemma FilterCut: "Filter P$s = Filter P$(Cut P s)"
+apply (rule_tac A1 = "%x. True" and Q1 = "%x.~ P x" and x1 = "s" in take_lemma_induct [THEN mp])
+prefer 3 apply (fast)
+apply (case_tac "Finite s")
+apply (simp add: Cut_nil ForallQFilterPnil)
+apply (simp add: Cut_UU ForallQFilterPUU)
+(* main case *)
+apply (simp add: Cut_Cons ForallQFilterPnil)
+done
+
+
+lemma Cut_idemp: "Cut P (Cut P s) = (Cut P s)"
+apply (rule_tac A1 = "%x. True" and Q1 = "%x.~ P x" and x1 = "s" in
+  take_lemma_less_induct [THEN mp])
+prefer 3 apply (fast)
+apply (case_tac "Finite s")
+apply (simp add: Cut_nil ForallQFilterPnil)
+apply (simp add: Cut_UU ForallQFilterPUU)
+(* main case *)
+apply (simp add: Cut_Cons ForallQFilterPnil)
+apply (rule take_reduction)
+apply auto
+done
+
+
+lemma MapCut: "Map f$(Cut (P o f) s) = Cut P (Map f$s)"
+apply (rule_tac A1 = "%x. True" and Q1 = "%x.~ P (f x) " and x1 = "s" in
+  take_lemma_less_induct [THEN mp])
+prefer 3 apply (fast)
+apply (case_tac "Finite s")
+apply (simp add: Cut_nil)
+apply (rule Cut_nil [symmetric])
+apply (simp add: ForallMap o_def)
+apply (simp add: Map2Finite)
+(* csae ~ Finite s *)
+apply (simp add: Cut_UU)
+apply (rule Cut_UU)
+apply (simp add: ForallMap o_def)
+apply (simp add: Map2Finite)
+(* main case *)
+apply (simp add: Cut_Cons MapConc ForallMap FiniteMap1 o_def)
+apply (rule take_reduction)
+apply auto
+done
+
+
+lemma Cut_prefixcl_nFinite [rule_format (no_asm)]: "~Finite s --> Cut P s << s"
+apply (intro strip)
+apply (rule take_lemma_less [THEN iffD1])
+apply (intro strip)
+apply (rule mp)
+prefer 2 apply (assumption)
+apply (tactic "thin_tac' 1 1")
+apply (rule_tac x = "s" in spec)
+apply (rule nat_less_induct)
+apply (intro strip)
+apply (rename_tac na n s)
+apply (case_tac "Forall (%x. ~ P x) s")
+apply (rule take_lemma_less [THEN iffD2, THEN spec])
+apply (simp add: Cut_UU)
+(* main case *)
+apply (drule divide_Seq3)
+apply (erule exE)+
+apply (erule conjE)+
+apply hypsubst
+apply (simp add: Cut_Cons)
+apply (rule take_reduction_less)
+(* auto makes also reasoning about Finiteness of parts of s ! *)
+apply auto
+done
+
+
+lemma execThruCut: "!!ex .is_exec_frag A (s,ex) ==> is_exec_frag A (s,Cut P ex)"
+apply (case_tac "Finite ex")
+apply (cut_tac s = "ex" and P = "P" in Cut_prefixcl_Finite)
+apply assumption
+apply (erule exE)
+apply (rule exec_prefix2closed)
+apply (erule_tac s = "ex" and t = "Cut P ex @@ y" in subst)
+apply assumption
+apply (erule exec_prefixclosed)
+apply (erule Cut_prefixcl_nFinite)
+done
+
+
+subsection "Main Cut Theorem"
+
+lemma exists_LastActExtsch:
+ "[|sch : schedules A ; tr = Filter (%a. a:ext A)$sch|]
+    ==> ? sch. sch : schedules A &
+               tr = Filter (%a. a:ext A)$sch &
+               LastActExtsch A sch"
+
+apply (unfold schedules_def has_schedule_def)
+apply auto
+apply (rule_tac x = "filter_act$ (Cut (%a. fst a:ext A) (snd ex))" in exI)
+apply (simp add: executions_def)
+apply (tactic {* pair_tac @{context} "ex" 1 *})
+apply auto
+apply (rule_tac x = " (x,Cut (%a. fst a:ext A) y) " in exI)
+apply (simp (no_asm_simp))
+
+(* Subgoal 1: Lemma:  propagation of execution through Cut *)
+
+apply (simp add: execThruCut)
+
+(* Subgoal 2:  Lemma:  Filter P s = Filter P (Cut P s) *)
+
+apply (simp (no_asm) add: filter_act_def)
+apply (subgoal_tac "Map fst$ (Cut (%a. fst a: ext A) y) = Cut (%a. a:ext A) (Map fst$y) ")
+
+apply (rule_tac [2] MapCut [unfolded o_def])
+apply (simp add: FilterCut [symmetric])
+
+(* Subgoal 3: Lemma: Cut idempotent  *)
+
+apply (simp (no_asm) add: LastActExtsch_def filter_act_def)
+apply (subgoal_tac "Map fst$ (Cut (%a. fst a: ext A) y) = Cut (%a. a:ext A) (Map fst$y) ")
+apply (rule_tac [2] MapCut [unfolded o_def])
+apply (simp add: Cut_idemp)
+done
+
+
+subsection "Further Cut lemmas"
+
+lemma LastActExtimplnil:
+  "[| LastActExtsch A sch; Filter (%x. x:ext A)$sch = nil |]
+    ==> sch=nil"
+apply (unfold LastActExtsch_def)
+apply (drule FilternPnilForallP)
+apply (erule conjE)
+apply (drule Cut_nil)
+apply assumption
+apply simp
+done
+
+lemma LastActExtimplUU:
+  "[| LastActExtsch A sch; Filter (%x. x:ext A)$sch = UU |]
+    ==> sch=UU"
+apply (unfold LastActExtsch_def)
+apply (drule FilternPUUForallP)
+apply (erule conjE)
+apply (drule Cut_UU)
+apply assumption
+apply simp
+done
+
+end

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/HOLCF/IOA/meta_theory/SimCorrectness.thy	Sat Nov 27 16:08:10 2010 -0800
@@ -0,0 +1,292 @@
+(*  Title:      HOLCF/IOA/meta_theory/SimCorrectness.thy
+    Author:     Olaf Müller
+*)
+
+header {* Correctness of Simulations in HOLCF/IOA *}
+
+theory SimCorrectness
+imports Simulations
+begin
+
+definition
+  (* Note: s2 instead of s1 in last argument type !! *)
+  corresp_ex_simC :: "('a,'s2)ioa => (('s1 * 's2)set) => ('a,'s1)pairs
+                   -> ('s2 => ('a,'s2)pairs)" where
+  "corresp_ex_simC A R = (fix$(LAM h ex. (%s. case ex of
+      nil =>  nil
+    | x##xs => (flift1 (%pr. let a = (fst pr); t = (snd pr);
+                                 T' = @t'. ? ex1. (t,t'):R & move A ex1 s a t'
+                             in
+                                (@cex. move A cex s a T')
+                                 @@ ((h$xs) T'))
+                        $x) )))"
+
+definition
+  corresp_ex_sim :: "('a,'s2)ioa => (('s1 *'s2)set) =>
+                      ('a,'s1)execution => ('a,'s2)execution" where
+  "corresp_ex_sim A R ex == let S'= (@s'.(fst ex,s'):R & s': starts_of A)
+                            in
+                               (S',(corresp_ex_simC A R$(snd ex)) S')"
+
+
+subsection "corresp_ex_sim"
+
+lemma corresp_ex_simC_unfold: "corresp_ex_simC A R  = (LAM ex. (%s. case ex of
+       nil =>  nil
+     | x##xs => (flift1 (%pr. let a = (fst pr); t = (snd pr);
+                                  T' = @t'. ? ex1. (t,t'):R & move A ex1 s a t'
+                              in
+                                 (@cex. move A cex s a T')
+                               @@ ((corresp_ex_simC A R $xs) T'))
+                         $x) ))"
+apply (rule trans)
+apply (rule fix_eq2)
+apply (simp only: corresp_ex_simC_def)
+apply (rule beta_cfun)
+apply (simp add: flift1_def)
+done
+
+lemma corresp_ex_simC_UU: "(corresp_ex_simC A R$UU) s=UU"
+apply (subst corresp_ex_simC_unfold)
+apply simp
+done
+
+lemma corresp_ex_simC_nil: "(corresp_ex_simC A R$nil) s = nil"
+apply (subst corresp_ex_simC_unfold)
+apply simp
+done
+
+lemma corresp_ex_simC_cons: "(corresp_ex_simC A R$((a,t)>>xs)) s =
+           (let T' = @t'. ? ex1. (t,t'):R & move A ex1 s a t'
+            in
+             (@cex. move A cex s a T')
+              @@ ((corresp_ex_simC A R$xs) T'))"
+apply (rule trans)
+apply (subst corresp_ex_simC_unfold)
+apply (simp add: Consq_def flift1_def)
+apply simp
+done
+
+
+declare corresp_ex_simC_UU [simp] corresp_ex_simC_nil [simp] corresp_ex_simC_cons [simp]
+
+
+subsection "properties of move"
+
+declare Let_def [simp del]
+
+lemma move_is_move_sim:
+   "[|is_simulation R C A; reachable C s; s -a--C-> t; (s,s'):R|] ==>
+      let T' = @t'. ? ex1. (t,t'):R & move A ex1 s' a t' in
+      (t,T'): R & move A (@ex2. move A ex2 s' a T') s' a T'"
+apply (unfold is_simulation_def)
+
+(* Does not perform conditional rewriting on assumptions automatically as
+   usual. Instantiate all variables per hand. Ask Tobias?? *)
+apply (subgoal_tac "? t' ex. (t,t') :R & move A ex s' a t'")
+prefer 2
+apply simp
+apply (erule conjE)
+apply (erule_tac x = "s" in allE)
+apply (erule_tac x = "s'" in allE)
+apply (erule_tac x = "t" in allE)
+apply (erule_tac x = "a" in allE)
+apply simp
+(* Go on as usual *)
+apply (erule exE)
+apply (drule_tac x = "t'" and P = "%t'. ? ex. (t,t') :R & move A ex s' a t'" in someI)
+apply (erule exE)
+apply (erule conjE)
+apply (simp add: Let_def)
+apply (rule_tac x = "ex" in someI)
+apply (erule conjE)
+apply assumption
+done
+
+declare Let_def [simp]
+
+lemma move_subprop1_sim:
+   "[|is_simulation R C A; reachable C s; s-a--C-> t; (s,s'):R|] ==>
+    let T' = @t'. ? ex1. (t,t'):R & move A ex1 s' a t' in
+     is_exec_frag A (s',@x. move A x s' a T')"
+apply (cut_tac move_is_move_sim)
+defer
+apply assumption+
+apply (simp add: move_def)
+done
+
+lemma move_subprop2_sim:
+   "[|is_simulation R C A; reachable C s; s-a--C-> t; (s,s'):R|] ==>
+    let T' = @t'. ? ex1. (t,t'):R & move A ex1 s' a t' in
+    Finite (@x. move A x s' a T')"
+apply (cut_tac move_is_move_sim)
+defer
+apply assumption+
+apply (simp add: move_def)
+done
+
+lemma move_subprop3_sim:
+   "[|is_simulation R C A; reachable C s; s-a--C-> t; (s,s'):R|] ==>
+    let T' = @t'. ? ex1. (t,t'):R & move A ex1 s' a t' in
+     laststate (s',@x. move A x s' a T') = T'"
+apply (cut_tac move_is_move_sim)
+defer
+apply assumption+
+apply (simp add: move_def)
+done
+
+lemma move_subprop4_sim:
+   "[|is_simulation R C A; reachable C s; s-a--C-> t; (s,s'):R|] ==>
+    let T' = @t'. ? ex1. (t,t'):R & move A ex1 s' a t' in
+      mk_trace A$((@x. move A x s' a T')) =
+        (if a:ext A then a>>nil else nil)"
+apply (cut_tac move_is_move_sim)
+defer
+apply assumption+
+apply (simp add: move_def)
+done
+
+lemma move_subprop5_sim:
+   "[|is_simulation R C A; reachable C s; s-a--C-> t; (s,s'):R|] ==>
+    let T' = @t'. ? ex1. (t,t'):R & move A ex1 s' a t' in
+      (t,T'):R"
+apply (cut_tac move_is_move_sim)
+defer
+apply assumption+
+apply (simp add: move_def)
+done
+
+
+subsection {* TRACE INCLUSION Part 1: Traces coincide *}
+
+subsubsection "Lemmata for <=="
+
+(* ------------------------------------------------------
+                 Lemma 1 :Traces coincide
+   ------------------------------------------------------- *)
+
+declare split_if [split del]
+lemma traces_coincide_sim [rule_format (no_asm)]:
+  "[|is_simulation R C A; ext C = ext A|] ==>
+         !s s'. reachable C s & is_exec_frag C (s,ex) & (s,s'): R -->
+             mk_trace C$ex = mk_trace A$((corresp_ex_simC A R$ex) s')"
+
+apply (tactic {* pair_induct_tac @{context} "ex" [@{thm is_exec_frag_def}] 1 *})
+(* cons case *)
+apply auto
+apply (rename_tac ex a t s s')
+apply (simp add: mk_traceConc)
+apply (frule reachable.reachable_n)
+apply assumption
+apply (erule_tac x = "t" in allE)
+apply (erule_tac x = "@t'. ? ex1. (t,t') :R & move A ex1 s' a t'" in allE)
+apply (simp add: move_subprop5_sim [unfolded Let_def]
+  move_subprop4_sim [unfolded Let_def] split add: split_if)
+done
+declare split_if [split]
+
+
+(* ----------------------------------------------------------- *)
+(*               Lemma 2 : corresp_ex_sim is execution         *)
+(* ----------------------------------------------------------- *)
+
+
+lemma correspsim_is_execution [rule_format (no_asm)]:
+ "[| is_simulation R C A |] ==>
+  !s s'. reachable C s & is_exec_frag C (s,ex) & (s,s'):R
+  --> is_exec_frag A (s',(corresp_ex_simC A R$ex) s')"
+
+apply (tactic {* pair_induct_tac @{context} "ex" [@{thm is_exec_frag_def}] 1 *})
+(* main case *)
+apply auto
+apply (rename_tac ex a t s s')
+apply (rule_tac t = "@t'. ? ex1. (t,t') :R & move A ex1 s' a t'" in lemma_2_1)
+
+(* Finite *)
+apply (erule move_subprop2_sim [unfolded Let_def])
+apply assumption+
+apply (rule conjI)
+
+(* is_exec_frag *)
+apply (erule move_subprop1_sim [unfolded Let_def])
+apply assumption+
+apply (rule conjI)
+
+(* Induction hypothesis  *)
+(* reachable_n looping, therefore apply it manually *)
+apply (erule_tac x = "t" in allE)
+apply (erule_tac x = "@t'. ? ex1. (t,t') :R & move A ex1 s' a t'" in allE)
+apply simp
+apply (frule reachable.reachable_n)
+apply assumption
+apply (simp add: move_subprop5_sim [unfolded Let_def])
+(* laststate *)
+apply (erule move_subprop3_sim [unfolded Let_def, symmetric])
+apply assumption+
+done
+
+
+subsection "Main Theorem: TRACE - INCLUSION"
+
+(* -------------------------------------------------------------------------------- *)
+
+  (* generate condition (s,S'):R & S':starts_of A, the first being intereting
+     for the induction cases concerning the two lemmas correpsim_is_execution and
+     traces_coincide_sim, the second for the start state case.
+     S':= @s'. (s,s'):R & s':starts_of A, where s:starts_of C  *)
+
+lemma simulation_starts:
+"[| is_simulation R C A; s:starts_of C |]
+  ==> let S' = @s'. (s,s'):R & s':starts_of A in
+      (s,S'):R & S':starts_of A"
+  apply (simp add: is_simulation_def corresp_ex_sim_def Int_non_empty Image_def)
+  apply (erule conjE)+
+  apply (erule ballE)
+  prefer 2 apply (blast)
+  apply (erule exE)
+  apply (rule someI2)
+  apply assumption
+  apply blast
+  done
+
+lemmas sim_starts1 = simulation_starts [unfolded Let_def, THEN conjunct1, standard]
+lemmas sim_starts2 = simulation_starts [unfolded Let_def, THEN conjunct2, standard]
+
+
+lemma trace_inclusion_for_simulations:
+  "[| ext C = ext A; is_simulation R C A |]
+           ==> traces C <= traces A"
+
+  apply (unfold traces_def)
+
+  apply (simp (no_asm) add: has_trace_def2)
+  apply auto
+
+  (* give execution of abstract automata *)
+  apply (rule_tac x = "corresp_ex_sim A R ex" in bexI)
+
+  (* Traces coincide, Lemma 1 *)
+  apply (tactic {* pair_tac @{context} "ex" 1 *})
+  apply (rename_tac s ex)
+  apply (simp (no_asm) add: corresp_ex_sim_def)
+  apply (rule_tac s = "s" in traces_coincide_sim)
+  apply assumption+
+  apply (simp add: executions_def reachable.reachable_0 sim_starts1)
+
+  (* corresp_ex_sim is execution, Lemma 2 *)
+  apply (tactic {* pair_tac @{context} "ex" 1 *})
+  apply (simp add: executions_def)
+  apply (rename_tac s ex)
+
+  (* start state *)
+  apply (rule conjI)
+  apply (simp add: sim_starts2 corresp_ex_sim_def)
+
+  (* is-execution-fragment *)
+  apply (simp add: corresp_ex_sim_def)
+  apply (rule_tac s = s in correspsim_is_execution)
+  apply assumption
+  apply (simp add: reachable.reachable_0 sim_starts1)
+  done
+
+end

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/HOLCF/IOA/meta_theory/Simulations.thy	Sat Nov 27 16:08:10 2010 -0800
@@ -0,0 +1,85 @@
+(*  Title:      HOLCF/IOA/meta_theory/Simulations.thy
+    Author:     Olaf Müller
+*)
+
+header {* Simulations in HOLCF/IOA *}
+
+theory Simulations
+imports RefCorrectness
+begin
+
+default_sort type
+
+definition
+  is_simulation :: "[('s1 * 's2)set,('a,'s1)ioa,('a,'s2)ioa] => bool" where
+  "is_simulation R C A =
+   ((!s:starts_of C. R``{s} Int starts_of A ~= {}) &
+   (!s s' t a. reachable C s &
+               s -a--C-> t   &
+               (s,s') : R
+               --> (? t' ex. (t,t'):R & move A ex s' a t')))"
+
+definition
+  is_backward_simulation :: "[('s1 * 's2)set,('a,'s1)ioa,('a,'s2)ioa] => bool" where
+  "is_backward_simulation R C A =
+   ((!s:starts_of C. R``{s} <= starts_of A) &
+   (!s t t' a. reachable C s &
+               s -a--C-> t   &
+               (t,t') : R
+               --> (? ex s'. (s,s'):R & move A ex s' a t')))"
+
+definition
+  is_forw_back_simulation :: "[('s1 * 's2 set)set,('a,'s1)ioa,('a,'s2)ioa] => bool" where
+  "is_forw_back_simulation R C A =
+   ((!s:starts_of C. ? S'. (s,S'):R & S'<= starts_of A) &
+   (!s S' t a. reachable C s &
+               s -a--C-> t   &
+               (s,S') : R
+               --> (? T'. (t,T'):R & (! t':T'. ? s':S'. ? ex. move A ex s' a t'))))"
+
+definition
+  is_back_forw_simulation :: "[('s1 * 's2 set)set,('a,'s1)ioa,('a,'s2)ioa] => bool" where
+  "is_back_forw_simulation R C A =
+   ((!s:starts_of C. ! S'. (s,S'):R --> S' Int starts_of A ~={}) &
+   (!s t T' a. reachable C s &
+               s -a--C-> t   &
+               (t,T') : R
+               --> (? S'. (s,S'):R & (! s':S'. ? t':T'. ? ex. move A ex s' a t'))))"
+
+definition
+  is_history_relation :: "[('s1 * 's2)set,('a,'s1)ioa,('a,'s2)ioa] => bool" where
+  "is_history_relation R C A = (is_simulation R C A &
+                                is_ref_map (%x.(@y. (x,y):(R^-1))) A C)"
+
+definition
+  is_prophecy_relation :: "[('s1 * 's2)set,('a,'s1)ioa,('a,'s2)ioa] => bool" where
+  "is_prophecy_relation R C A = (is_backward_simulation R C A &
+                                 is_ref_map (%x.(@y. (x,y):(R^-1))) A C)"
+
+
+lemma set_non_empty: "(A~={}) = (? x. x:A)"
+apply auto
+done
+
+lemma Int_non_empty: "(A Int B ~= {}) = (? x. x: A & x:B)"
+apply (simp add: set_non_empty)
+done
+
+
+lemma Sim_start_convert:
+"(R``{x} Int S ~= {}) = (? y. (x,y):R & y:S)"
+apply (unfold Image_def)
+apply (simp add: Int_non_empty)
+done
+
+declare Sim_start_convert [simp]
+
+
+lemma ref_map_is_simulation:
+"!! f. is_ref_map f C A ==> is_simulation {p. (snd p) = f (fst p)} C A"
+
+apply (unfold is_ref_map_def is_simulation_def)
+apply simp
+done
+
+end

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/HOLCF/IOA/meta_theory/TL.thy	Sat Nov 27 16:08:10 2010 -0800
@@ -0,0 +1,203 @@
+(*  Title:      HOLCF/IOA/meta_theory/TLS.thy
+    Author:     Olaf Müller
+*)
+
+header {* A General Temporal Logic *}
+
+theory TL
+imports Pred Sequence
+begin
+
+default_sort type
+
+types
+  'a temporal = "'a Seq predicate"
+
+
+consts
+suffix     :: "'a Seq => 'a Seq => bool"
+tsuffix    :: "'a Seq => 'a Seq => bool"
+
+validT     :: "'a Seq predicate => bool"
+
+unlift     ::  "'a lift => 'a"
+
+Init         ::"'a predicate => 'a temporal"          ("<_>" [0] 1000)
+
+Box          ::"'a temporal => 'a temporal"   ("[] (_)" [80] 80)
+Diamond      ::"'a temporal => 'a temporal"   ("<> (_)" [80] 80)
+Next         ::"'a temporal => 'a temporal"
+Leadsto      ::"'a temporal => 'a temporal => 'a temporal"  (infixr "~>" 22)
+
+notation (xsymbols)
+  Box  ("\<box> (_)" [80] 80) and
+  Diamond  ("\<diamond> (_)" [80] 80) and
+  Leadsto  (infixr "\<leadsto>" 22)
+
+defs
+
+unlift_def:
+  "unlift x == (case x of Def y   => y)"
+
+(* this means that for nil and UU the effect is unpredictable *)
+Init_def:
+  "Init P s ==  (P (unlift (HD$s)))"
+
+suffix_def:
+  "suffix s2 s == ? s1. (Finite s1  & s = s1 @@ s2)"
+
+tsuffix_def:
+  "tsuffix s2 s == s2 ~= nil & s2 ~= UU & suffix s2 s"
+
+Box_def:
+  "([] P) s == ! s2. tsuffix s2 s --> P s2"
+
+Next_def:
+  "(Next P) s == if (TL$s=UU | TL$s=nil) then (P s) else P (TL$s)"
+
+Diamond_def:
+  "<> P == .~ ([] (.~ P))"
+
+Leadsto_def:
+   "P ~> Q == ([] (P .--> (<> Q)))"
+
+validT_def:
+  "validT P == ! s. s~=UU & s~=nil --> (s |= P)"
+
+
+lemma simple: "[] <> (.~ P) = (.~ <> [] P)"
+apply (rule ext)
+apply (simp add: Diamond_def NOT_def Box_def)
+done
+
+lemma Boxnil: "nil |= [] P"
+apply (simp add: satisfies_def Box_def tsuffix_def suffix_def nil_is_Conc)
+done
+
+lemma Diamondnil: "~(nil |= <> P)"
+apply (simp add: Diamond_def satisfies_def NOT_def)
+apply (cut_tac Boxnil)
+apply (simp add: satisfies_def)
+done
+
+lemma Diamond_def2: "(<> F) s = (? s2. tsuffix s2 s & F s2)"
+apply (simp add: Diamond_def NOT_def Box_def)
+done
+
+
+
+subsection "TLA Axiomatization by Merz"
+
+lemma suffix_refl: "suffix s s"
+apply (simp add: suffix_def)
+apply (rule_tac x = "nil" in exI)
+apply auto
+done
+
+lemma reflT: "s~=UU & s~=nil --> (s |= [] F .--> F)"
+apply (simp add: satisfies_def IMPLIES_def Box_def)
+apply (rule impI)+
+apply (erule_tac x = "s" in allE)
+apply (simp add: tsuffix_def suffix_refl)
+done
+
+
+lemma suffix_trans: "[| suffix y x ; suffix z y |]  ==> suffix z x"
+apply (simp add: suffix_def)
+apply auto
+apply (rule_tac x = "s1 @@ s1a" in exI)
+apply auto
+apply (simp (no_asm) add: Conc_assoc)
+done
+
+lemma transT: "s |= [] F .--> [] [] F"
+apply (simp (no_asm) add: satisfies_def IMPLIES_def Box_def tsuffix_def)
+apply auto
+apply (drule suffix_trans)
+apply assumption
+apply (erule_tac x = "s2a" in allE)
+apply auto
+done
+
+
+lemma normalT: "s |= [] (F .--> G) .--> [] F .--> [] G"
+apply (simp (no_asm) add: satisfies_def IMPLIES_def Box_def)
+done
+
+
+subsection "TLA Rules by Lamport"
+
+lemma STL1a: "validT P ==> validT ([] P)"
+apply (simp add: validT_def satisfies_def Box_def tsuffix_def)
+done
+
+lemma STL1b: "valid P ==> validT (Init P)"
+apply (simp add: valid_def validT_def satisfies_def Init_def)
+done
+
+lemma STL1: "valid P ==> validT ([] (Init P))"
+apply (rule STL1a)
+apply (erule STL1b)
+done
+
+(* Note that unlift and HD is not at all used !!! *)
+lemma STL4: "valid (P .--> Q)  ==> validT ([] (Init P) .--> [] (Init Q))"
+apply (simp add: valid_def validT_def satisfies_def IMPLIES_def Box_def Init_def)
+done
+
+
+subsection "LTL Axioms by Manna/Pnueli"
+
+lemma tsuffix_TL [rule_format (no_asm)]: 
+"s~=UU & s~=nil --> tsuffix s2 (TL$s) --> tsuffix s2 s"
+apply (unfold tsuffix_def suffix_def)
+apply auto
+apply (tactic {* Seq_case_simp_tac @{context} "s" 1 *})
+apply (rule_tac x = "a>>s1" in exI)
+apply auto
+done
+
+lemmas tsuffix_TL2 = conjI [THEN tsuffix_TL]
+
+declare split_if [split del]
+lemma LTL1: 
+   "s~=UU & s~=nil --> (s |= [] F .--> (F .& (Next ([] F))))"
+apply (unfold Next_def satisfies_def NOT_def IMPLIES_def AND_def Box_def)
+apply auto
+(* []F .--> F *)
+apply (erule_tac x = "s" in allE)
+apply (simp add: tsuffix_def suffix_refl)
+(* []F .--> Next [] F *)
+apply (simp split add: split_if)
+apply auto
+apply (drule tsuffix_TL2)
+apply assumption+
+apply auto
+done
+declare split_if [split]
+
+
+lemma LTL2a: 
+    "s |= .~ (Next F) .--> (Next (.~ F))"
+apply (unfold Next_def satisfies_def NOT_def IMPLIES_def)
+apply simp
+done
+
+lemma LTL2b: 
+    "s |= (Next (.~ F)) .--> (.~ (Next F))"
+apply (unfold Next_def satisfies_def NOT_def IMPLIES_def)
+apply simp
+done
+
+lemma LTL3: 
+"ex |= (Next (F .--> G)) .--> (Next F) .--> (Next G)"
+apply (unfold Next_def satisfies_def NOT_def IMPLIES_def)
+apply simp
+done
+
+
+lemma ModusPonens: "[| validT (P .--> Q); validT P |] ==> validT Q"
+apply (simp add: validT_def satisfies_def IMPLIES_def)
+done
+
+end

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/HOLCF/IOA/meta_theory/TLS.thy	Sat Nov 27 16:08:10 2010 -0800
@@ -0,0 +1,201 @@
+(*  Title:      HOLCF/IOA/meta_theory/TLS.thy
+    Author:     Olaf Müller
+*)
+
+header {* Temporal Logic of Steps -- tailored for I/O automata *}
+
+theory TLS
+imports IOA TL
+begin
+
+default_sort type
+
+types
+  ('a, 's) ioa_temp  = "('a option,'s)transition temporal"
+  ('a, 's) step_pred = "('a option,'s)transition predicate"
+  's state_pred      = "'s predicate"
+
+consts
+
+option_lift :: "('a => 'b) => 'b => ('a option => 'b)"
+plift       :: "('a => bool) => ('a option => bool)"
+
+temp_sat   :: "('a,'s)execution => ('a,'s)ioa_temp => bool"    (infixr "|==" 22)
+xt1        :: "'s predicate => ('a,'s)step_pred"
+xt2        :: "'a option predicate => ('a,'s)step_pred"
+
+validTE    :: "('a,'s)ioa_temp => bool"
+validIOA   :: "('a,'s)ioa => ('a,'s)ioa_temp => bool"
+
+mkfin      :: "'a Seq => 'a Seq"
+
+ex2seq     :: "('a,'s)execution => ('a option,'s)transition Seq"
+ex2seqC    :: "('a,'s)pairs -> ('s => ('a option,'s)transition Seq)"
+
+
+defs
+
+mkfin_def:
+  "mkfin s == if Partial s then @t. Finite t & s = t @@ UU
+                           else s"
+
+option_lift_def:
+  "option_lift f s y == case y of None => s | Some x => (f x)"
+
+(* plift is used to determine that None action is always false in
+   transition predicates *)
+plift_def:
+  "plift P == option_lift P False"
+
+temp_sat_def:
+  "ex |== P == ((ex2seq ex) |= P)"
+
+xt1_def:
+  "xt1 P tr == P (fst tr)"
+
+xt2_def:
+  "xt2 P tr == P (fst (snd tr))"
+
+ex2seq_def:
+  "ex2seq ex == ((ex2seqC $(mkfin (snd ex))) (fst ex))"
+
+ex2seqC_def:
+  "ex2seqC == (fix$(LAM h ex. (%s. case ex of
+      nil =>  (s,None,s)>>nil
+    | x##xs => (flift1 (%pr.
+                (s,Some (fst pr), snd pr)>> (h$xs) (snd pr))
+                $x)
+      )))"
+
+validTE_def:
+  "validTE P == ! ex. (ex |== P)"
+
+validIOA_def:
+  "validIOA A P == ! ex : executions A . (ex |== P)"
+
+
+axioms
+
+mkfin_UU:
+  "mkfin UU = nil"
+
+mkfin_nil:
+  "mkfin nil =nil"
+
+mkfin_cons:
+  "(mkfin (a>>s)) = (a>>(mkfin s))"
+
+
+lemmas [simp del] = HOL.ex_simps HOL.all_simps split_paired_Ex
+
+declaration {* fn _ => Classical.map_cs (fn cs => cs delSWrapper "split_all_tac") *}
+
+
+subsection {* ex2seqC *}
+
+lemma ex2seqC_unfold: "ex2seqC  = (LAM ex. (%s. case ex of  
+       nil =>  (s,None,s)>>nil    
+     | x##xs => (flift1 (%pr.  
+                 (s,Some (fst pr), snd pr)>> (ex2seqC$xs) (snd pr))   
+                 $x)   
+       ))"
+apply (rule trans)
+apply (rule fix_eq2)
+apply (rule ex2seqC_def)
+apply (rule beta_cfun)
+apply (simp add: flift1_def)
+done
+
+lemma ex2seqC_UU: "(ex2seqC $UU) s=UU"
+apply (subst ex2seqC_unfold)
+apply simp
+done
+
+lemma ex2seqC_nil: "(ex2seqC $nil) s = (s,None,s)>>nil"
+apply (subst ex2seqC_unfold)
+apply simp
+done
+
+lemma ex2seqC_cons: "(ex2seqC $((a,t)>>xs)) s =  
+           (s,Some a,t)>> ((ex2seqC$xs) t)"
+apply (rule trans)
+apply (subst ex2seqC_unfold)
+apply (simp add: Consq_def flift1_def)
+apply (simp add: Consq_def flift1_def)
+done
+
+declare ex2seqC_UU [simp] ex2seqC_nil [simp] ex2seqC_cons [simp]
+
+
+
+declare mkfin_UU [simp] mkfin_nil [simp] mkfin_cons [simp]
+
+lemma ex2seq_UU: "ex2seq (s, UU) = (s,None,s)>>nil"
+apply (simp add: ex2seq_def)
+done
+
+lemma ex2seq_nil: "ex2seq (s, nil) = (s,None,s)>>nil"
+apply (simp add: ex2seq_def)
+done
+
+lemma ex2seq_cons: "ex2seq (s, (a,t)>>ex) = (s,Some a,t) >> ex2seq (t, ex)"
+apply (simp add: ex2seq_def)
+done
+
+declare ex2seqC_UU [simp del] ex2seqC_nil [simp del] ex2seqC_cons [simp del]
+declare ex2seq_UU [simp] ex2seq_nil [simp] ex2seq_cons [simp]
+
+
+lemma ex2seq_nUUnnil: "ex2seq exec ~= UU & ex2seq exec ~= nil"
+apply (tactic {* pair_tac @{context} "exec" 1 *})
+apply (tactic {* Seq_case_simp_tac @{context} "y" 1 *})
+apply (tactic {* pair_tac @{context} "a" 1 *})
+done
+
+
+subsection {* Interface TL -- TLS *}
+
+(* uses the fact that in executions states overlap, which is lost in 
+   after the translation via ex2seq !! *)
+
+lemma TL_TLS: 
+ "[| ! s a t. (P s) & s-a--A-> t --> (Q t) |] 
+   ==> ex |== (Init (%(s,a,t). P s) .& Init (%(s,a,t). s -a--A-> t)  
+              .--> (Next (Init (%(s,a,t).Q s))))"
+apply (unfold Init_def Next_def temp_sat_def satisfies_def IMPLIES_def AND_def)
+
+apply clarify
+apply (simp split add: split_if)
+(* TL = UU *)
+apply (rule conjI)
+apply (tactic {* pair_tac @{context} "ex" 1 *})
+apply (tactic {* Seq_case_simp_tac @{context} "y" 1 *})
+apply (tactic {* pair_tac @{context} "a" 1 *})
+apply (tactic {* Seq_case_simp_tac @{context} "s" 1 *})
+apply (tactic {* pair_tac @{context} "a" 1 *})
+(* TL = nil *)
+apply (rule conjI)
+apply (tactic {* pair_tac @{context} "ex" 1 *})
+apply (tactic {* Seq_case_tac @{context} "y" 1 *})
+apply (simp add: unlift_def)
+apply fast
+apply (simp add: unlift_def)
+apply fast
+apply (simp add: unlift_def)
+apply (tactic {* pair_tac @{context} "a" 1 *})
+apply (tactic {* Seq_case_simp_tac @{context} "s" 1 *})
+apply (tactic {* pair_tac @{context} "a" 1 *})
+(* TL =cons *)
+apply (simp add: unlift_def)
+
+apply (tactic {* pair_tac @{context} "ex" 1 *})
+apply (tactic {* Seq_case_simp_tac @{context} "y" 1 *})
+apply (tactic {* pair_tac @{context} "a" 1 *})
+apply (tactic {* Seq_case_simp_tac @{context} "s" 1 *})
+apply blast
+apply fastsimp
+apply (tactic {* pair_tac @{context} "a" 1 *})
+ apply fastsimp
+done
+
+end

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/HOLCF/IOA/meta_theory/Traces.thy	Sat Nov 27 16:08:10 2010 -0800
@@ -0,0 +1,410 @@
+(*  Title:      HOLCF/IOA/meta_theory/Traces.thy
+    Author:     Olaf Müller
+*)
+
+header {* Executions and Traces of I/O automata in HOLCF *}
+
+theory Traces
+imports Sequence Automata
+begin
+
+default_sort type
+
+types
+   ('a,'s)pairs            =    "('a * 's) Seq"
+   ('a,'s)execution        =    "'s * ('a,'s)pairs"
+   'a trace                =    "'a Seq"
+
+   ('a,'s)execution_module = "('a,'s)execution set * 'a signature"
+   'a schedule_module      = "'a trace set * 'a signature"
+   'a trace_module         = "'a trace set * 'a signature"
+
+consts
+
+   (* Executions *)
+
+  is_exec_fragC ::"('a,'s)ioa => ('a,'s)pairs -> 's => tr"
+  is_exec_frag  ::"[('a,'s)ioa, ('a,'s)execution] => bool"
+  has_execution ::"[('a,'s)ioa, ('a,'s)execution] => bool"
+  executions    :: "('a,'s)ioa => ('a,'s)execution set"
+
+  (* Schedules and traces *)
+  filter_act    ::"('a,'s)pairs -> 'a trace"
+  has_schedule  :: "[('a,'s)ioa, 'a trace] => bool"
+  has_trace     :: "[('a,'s)ioa, 'a trace] => bool"
+  schedules     :: "('a,'s)ioa => 'a trace set"
+  traces        :: "('a,'s)ioa => 'a trace set"
+  mk_trace      :: "('a,'s)ioa => ('a,'s)pairs -> 'a trace"
+
+  laststate    ::"('a,'s)execution => 's"
+
+  (* A predicate holds infinitely (finitely) often in a sequence *)
+
+  inf_often      ::"('a => bool) => 'a Seq => bool"
+  fin_often      ::"('a => bool) => 'a Seq => bool"
+
+  (* fairness of executions *)
+
+  wfair_ex       ::"('a,'s)ioa => ('a,'s)execution => bool"
+  sfair_ex       ::"('a,'s)ioa => ('a,'s)execution => bool"
+  is_wfair       ::"('a,'s)ioa => 'a set => ('a,'s)execution => bool"
+  is_sfair       ::"('a,'s)ioa => 'a set => ('a,'s)execution => bool"
+  fair_ex        ::"('a,'s)ioa => ('a,'s)execution => bool"
+
+  (* fair behavior sets *)
+
+  fairexecutions ::"('a,'s)ioa => ('a,'s)execution set"
+  fairtraces     ::"('a,'s)ioa => 'a trace set"
+
+  (* Notions of implementation *)
+  ioa_implements :: "[('a,'s1)ioa, ('a,'s2)ioa] => bool"   (infixr "=<|" 12)
+  fair_implements  :: "('a,'s1)ioa => ('a,'s2)ioa => bool"
+
+  (* Execution, schedule and trace modules *)
+  Execs         ::  "('a,'s)ioa => ('a,'s)execution_module"
+  Scheds        ::  "('a,'s)ioa => 'a schedule_module"
+  Traces        ::  "('a,'s)ioa => 'a trace_module"
+
+
+defs
+
+
+(*  ------------------- Executions ------------------------------ *)
+
+
+is_exec_frag_def:
+  "is_exec_frag A ex ==  ((is_exec_fragC A$(snd ex)) (fst ex) ~= FF)"
+
+
+is_exec_fragC_def:
+  "is_exec_fragC A ==(fix$(LAM h ex. (%s. case ex of
+      nil => TT
+    | x##xs => (flift1
+            (%p. Def ((s,p):trans_of A) andalso (h$xs) (snd p))
+             $x)
+   )))"
+
+
+
+executions_def:
+  "executions ioa == {e. ((fst e) : starts_of(ioa)) &
+                         is_exec_frag ioa e}"
+
+
+(*  ------------------- Schedules ------------------------------ *)
+
+
+filter_act_def:
+  "filter_act == Map fst"
+
+has_schedule_def:
+  "has_schedule ioa sch ==
+     (? ex:executions ioa. sch = filter_act$(snd ex))"
+
+schedules_def:
+  "schedules ioa == {sch. has_schedule ioa sch}"
+
+
+(*  ------------------- Traces ------------------------------ *)
+
+has_trace_def:
+  "has_trace ioa tr ==
+     (? sch:schedules ioa. tr = Filter (%a. a:ext(ioa))$sch)"
+
+traces_def:
+  "traces ioa == {tr. has_trace ioa tr}"
+
+
+mk_trace_def:
+  "mk_trace ioa == LAM tr.
+     Filter (%a. a:ext(ioa))$(filter_act$tr)"
+
+
+(*  ------------------- Fair Traces ------------------------------ *)
+
+laststate_def:
+  "laststate ex == case Last$(snd ex) of
+                      UU  => fst ex
+                    | Def at => snd at"
+
+inf_often_def:
+  "inf_often P s == Infinite (Filter P$s)"
+
+(*  filtering P yields a finite or partial sequence *)
+fin_often_def:
+  "fin_often P s == ~inf_often P s"
+
+(* Note that partial execs cannot be wfair as the inf_often predicate in the
+   else branch prohibits it. However they can be sfair in the case when all W
+   are only finitely often enabled: Is this the right model?
+   See LiveIOA for solution conforming with the literature and superseding this one *)
+wfair_ex_def:
+  "wfair_ex A ex == ! W : wfair_of A.
+                      if   Finite (snd ex)
+                      then ~Enabled A W (laststate ex)
+                      else is_wfair A W ex"
+
+is_wfair_def:
+  "is_wfair A W ex == (inf_often (%x. fst x:W) (snd ex)
+                     | inf_often (%x.~Enabled A W (snd x)) (snd ex))"
+
+sfair_ex_def:
+  "sfair_ex A ex == ! W : sfair_of A.
+                      if   Finite (snd ex)
+                      then ~Enabled A W (laststate ex)
+                      else is_sfair A W ex"
+
+is_sfair_def:
+  "is_sfair A W ex ==  (inf_often (%x. fst x:W) (snd ex)
+                      | fin_often (%x. Enabled A W (snd x)) (snd ex))"
+
+fair_ex_def:
+  "fair_ex A ex == wfair_ex A ex & sfair_ex A ex"
+
+fairexecutions_def:
+  "fairexecutions A == {ex. ex:executions A & fair_ex A ex}"
+
+fairtraces_def:
+  "fairtraces A == {mk_trace A$(snd ex) | ex. ex:fairexecutions A}"
+
+
+(*  ------------------- Implementation ------------------------------ *)
+
+ioa_implements_def:
+  "ioa1 =<| ioa2 ==
+    (((inputs(asig_of(ioa1)) = inputs(asig_of(ioa2))) &
+     (outputs(asig_of(ioa1)) = outputs(asig_of(ioa2)))) &
+      traces(ioa1) <= traces(ioa2))"
+
+fair_implements_def:
+  "fair_implements C A == inp(C) = inp(A) &  out(C)=out(A) &
+                          fairtraces(C) <= fairtraces(A)"
+
+(*  ------------------- Modules ------------------------------ *)
+
+Execs_def:
+  "Execs A  == (executions A, asig_of A)"
+
+Scheds_def:
+  "Scheds A == (schedules A, asig_of A)"
+
+Traces_def:
+  "Traces A == (traces A,asig_of A)"
+
+
+lemmas [simp del] = HOL.ex_simps HOL.all_simps split_paired_Ex
+declare Let_def [simp]
+declaration {* fn _ => Classical.map_cs (fn cs => cs delSWrapper "split_all_tac") *}
+
+lemmas exec_rws = executions_def is_exec_frag_def
+
+
+
+subsection "recursive equations of operators"
+
+(* ---------------------------------------------------------------- *)
+(*                               filter_act                         *)
+(* ---------------------------------------------------------------- *)
+
+
+lemma filter_act_UU: "filter_act$UU = UU"
+apply (simp add: filter_act_def)
+done
+
+lemma filter_act_nil: "filter_act$nil = nil"
+apply (simp add: filter_act_def)
+done
+
+lemma filter_act_cons: "filter_act$(x>>xs) = (fst x) >> filter_act$xs"
+apply (simp add: filter_act_def)
+done
+
+declare filter_act_UU [simp] filter_act_nil [simp] filter_act_cons [simp]
+
+
+(* ---------------------------------------------------------------- *)
+(*                             mk_trace                             *)
+(* ---------------------------------------------------------------- *)
+
+lemma mk_trace_UU: "mk_trace A$UU=UU"
+apply (simp add: mk_trace_def)
+done
+
+lemma mk_trace_nil: "mk_trace A$nil=nil"
+apply (simp add: mk_trace_def)
+done
+
+lemma mk_trace_cons: "mk_trace A$(at >> xs) =     
+             (if ((fst at):ext A)            
+                  then (fst at) >> (mk_trace A$xs)     
+                  else mk_trace A$xs)"
+
+apply (simp add: mk_trace_def)
+done
+
+declare mk_trace_UU [simp] mk_trace_nil [simp] mk_trace_cons [simp]
+
+(* ---------------------------------------------------------------- *)
+(*                             is_exec_fragC                             *)
+(* ---------------------------------------------------------------- *)
+
+
+lemma is_exec_fragC_unfold: "is_exec_fragC A = (LAM ex. (%s. case ex of  
+       nil => TT  
+     | x##xs => (flift1   
+             (%p. Def ((s,p):trans_of A) andalso (is_exec_fragC A$xs) (snd p))  
+              $x)  
+    ))"
+apply (rule trans)
+apply (rule fix_eq2)
+apply (rule is_exec_fragC_def)
+apply (rule beta_cfun)
+apply (simp add: flift1_def)
+done
+
+lemma is_exec_fragC_UU: "(is_exec_fragC A$UU) s=UU"
+apply (subst is_exec_fragC_unfold)
+apply simp
+done
+
+lemma is_exec_fragC_nil: "(is_exec_fragC A$nil) s = TT"
+apply (subst is_exec_fragC_unfold)
+apply simp
+done
+
+lemma is_exec_fragC_cons: "(is_exec_fragC A$(pr>>xs)) s =  
+                         (Def ((s,pr):trans_of A)  
+                 andalso (is_exec_fragC A$xs)(snd pr))"
+apply (rule trans)
+apply (subst is_exec_fragC_unfold)
+apply (simp add: Consq_def flift1_def)
+apply simp
+done
+
+
+declare is_exec_fragC_UU [simp] is_exec_fragC_nil [simp] is_exec_fragC_cons [simp]
+
+
+(* ---------------------------------------------------------------- *)
+(*                        is_exec_frag                              *)
+(* ---------------------------------------------------------------- *)
+
+lemma is_exec_frag_UU: "is_exec_frag A (s, UU)"
+apply (simp add: is_exec_frag_def)
+done
+
+lemma is_exec_frag_nil: "is_exec_frag A (s, nil)"
+apply (simp add: is_exec_frag_def)
+done
+
+lemma is_exec_frag_cons: "is_exec_frag A (s, (a,t)>>ex) =  
+                                (((s,a,t):trans_of A) &  
+                                is_exec_frag A (t, ex))"
+apply (simp add: is_exec_frag_def)
+done
+
+
+(* Delsimps [is_exec_fragC_UU,is_exec_fragC_nil,is_exec_fragC_cons]; *)
+declare is_exec_frag_UU [simp] is_exec_frag_nil [simp] is_exec_frag_cons [simp]
+
+(* ---------------------------------------------------------------------------- *)
+                           section "laststate"
+(* ---------------------------------------------------------------------------- *)
+
+lemma laststate_UU: "laststate (s,UU) = s"
+apply (simp add: laststate_def)
+done
+
+lemma laststate_nil: "laststate (s,nil) = s"
+apply (simp add: laststate_def)
+done
+
+lemma laststate_cons: "!! ex. Finite ex ==> laststate (s,at>>ex) = laststate (snd at,ex)"
+apply (simp (no_asm) add: laststate_def)
+apply (case_tac "ex=nil")
+apply (simp (no_asm_simp))
+apply (simp (no_asm_simp))
+apply (drule Finite_Last1 [THEN mp])
+apply assumption
+apply defined
+done
+
+declare laststate_UU [simp] laststate_nil [simp] laststate_cons [simp]
+
+lemma exists_laststate: "!!ex. Finite ex ==> (! s. ? u. laststate (s,ex)=u)"
+apply (tactic "Seq_Finite_induct_tac @{context} 1")
+done
+
+
+subsection "has_trace, mk_trace"
+
+(* alternative definition of has_trace tailored for the refinement proof, as it does not 
+   take the detour of schedules *)
+
+lemma has_trace_def2: 
+"has_trace A b = (? ex:executions A. b = mk_trace A$(snd ex))"
+apply (unfold executions_def mk_trace_def has_trace_def schedules_def has_schedule_def)
+apply auto
+done
+
+
+subsection "signatures and executions, schedules"
+
+(* All executions of A have only actions of A. This is only true because of the 
+   predicate state_trans (part of the predicate IOA): We have no dependent types.
+   For executions of parallel automata this assumption is not needed, as in par_def
+   this condition is included once more. (see Lemmas 1.1.1c in CompoExecs for example) *)
+
+lemma execfrag_in_sig: 
+  "!! A. is_trans_of A ==>  
+  ! s. is_exec_frag A (s,xs) --> Forall (%a. a:act A) (filter_act$xs)"
+apply (tactic {* pair_induct_tac @{context} "xs" [@{thm is_exec_frag_def},
+  @{thm Forall_def}, @{thm sforall_def}] 1 *})
+(* main case *)
+apply (auto simp add: is_trans_of_def)
+done
+
+lemma exec_in_sig: 
+  "!! A.[|  is_trans_of A; x:executions A |] ==>  
+  Forall (%a. a:act A) (filter_act$(snd x))"
+apply (simp add: executions_def)
+apply (tactic {* pair_tac @{context} "x" 1 *})
+apply (rule execfrag_in_sig [THEN spec, THEN mp])
+apply auto
+done
+
+lemma scheds_in_sig: 
+  "!! A.[|  is_trans_of A; x:schedules A |] ==>  
+    Forall (%a. a:act A) x"
+apply (unfold schedules_def has_schedule_def)
+apply (fast intro!: exec_in_sig)
+done
+
+
+subsection "executions are prefix closed"
+
+(* only admissible in y, not if done in x !! *)
+lemma execfrag_prefixclosed: "!x s. is_exec_frag A (s,x) & y<<x  --> is_exec_frag A (s,y)"
+apply (tactic {* pair_induct_tac @{context} "y" [@{thm is_exec_frag_def}] 1 *})
+apply (intro strip)
+apply (tactic {* Seq_case_simp_tac @{context} "xa" 1 *})
+apply (tactic {* pair_tac @{context} "a" 1 *})
+apply auto
+done
+
+lemmas exec_prefixclosed =
+  conjI [THEN execfrag_prefixclosed [THEN spec, THEN spec, THEN mp], standard]
+
+
+(* second prefix notion for Finite x *)
+
+lemma exec_prefix2closed [rule_format]:
+  "! y s. is_exec_frag A (s,x@@y) --> is_exec_frag A (s,x)"
+apply (tactic {* pair_induct_tac @{context} "x" [@{thm is_exec_frag_def}] 1 *})
+apply (intro strip)
+apply (tactic {* Seq_case_simp_tac @{context} "s" 1 *})
+apply (tactic {* pair_tac @{context} "a" 1 *})
+apply auto
+done
+
+end

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/HOLCF/IsaMakefile	Sat Nov 27 16:08:10 2010 -0800
@@ -0,0 +1,224 @@
+#
+# IsaMakefile for HOLCF
+#
+
+## targets
+
+default: HOLCF
+images: HOLCF IOA
+test: \
+  HOLCF-FOCUS \
+  HOLCF-IMP \
+  HOLCF-Library \
+  HOLCF-Tutorial \
+  HOLCF-ex \
+  IOA-ABP \
+  IOA-NTP \
+  IOA-Storage \
+  IOA-ex
+all: images test
+
+
+## global settings
+
+SRC = $(ISABELLE_HOME)/src
+OUT = $(ISABELLE_OUTPUT)
+LOG = $(OUT)/log
+
+
+## HOLCF
+
+HOLCF: HOL $(OUT)/HOLCF
+
+HOL:
+	@cd $(SRC)/HOL; $(ISABELLE_TOOL) make HOL
+
+$(OUT)/HOLCF: $(OUT)/HOL \
+  ROOT.ML \
+  Adm.thy \
+  Algebraic.thy \
+  Bifinite.thy \
+  Cfun.thy \
+  CompactBasis.thy \
+  Completion.thy \
+  Cont.thy \
+  ConvexPD.thy \
+  Cpodef.thy \
+  Cprod.thy \
+  Discrete.thy \
+  Deflation.thy \
+  Domain.thy \
+  Domain_Aux.thy \
+  Fixrec.thy \
+  Fix.thy \
+  Fun_Cpo.thy \
+  HOLCF.thy \
+  Lift.thy \
+  LowerPD.thy \
+  Map_Functions.thy \
+  One.thy \
+  Pcpo.thy \
+  Plain_HOLCF.thy \
+  Porder.thy \
+  Powerdomains.thy \
+  Product_Cpo.thy \
+  Sfun.thy \
+  Sprod.thy \
+  Ssum.thy \
+  Tr.thy \
+  Universal.thy \
+  UpperPD.thy \
+  Up.thy \
+  Tools/cont_consts.ML \
+  Tools/cont_proc.ML \
+  Tools/holcf_library.ML \
+  Tools/Domain/domain.ML \
+  Tools/Domain/domain_axioms.ML \
+  Tools/Domain/domain_constructors.ML \
+  Tools/Domain/domain_induction.ML \
+  Tools/Domain/domain_isomorphism.ML \
+  Tools/Domain/domain_take_proofs.ML \
+  Tools/cpodef.ML \
+  Tools/domaindef.ML \
+  Tools/fixrec.ML \
+  document/root.tex
+	@$(ISABELLE_TOOL) usedir -b -g true $(OUT)/HOL HOLCF
+
+
+## HOLCF-Tutorial
+
+HOLCF-Tutorial: HOLCF $(LOG)/HOLCF-Tutorial.gz
+
+$(LOG)/HOLCF-Tutorial.gz: $(OUT)/HOLCF \
+  Tutorial/Domain_ex.thy \
+  Tutorial/Fixrec_ex.thy \
+  Tutorial/New_Domain.thy \
+  Tutorial/document/root.tex \
+  Tutorial/ROOT.ML
+	@$(ISABELLE_TOOL) usedir $(OUT)/HOLCF Tutorial
+
+
+## HOLCF-Library
+
+HOLCF-Library: HOLCF $(LOG)/HOLCF-Library.gz
+
+$(LOG)/HOLCF-Library.gz: $(OUT)/HOLCF \
+  Library/Defl_Bifinite.thy \
+  Library/List_Cpo.thy \
+  Library/Stream.thy \
+  Library/Sum_Cpo.thy \
+  Library/HOLCF_Library.thy \
+  Library/ROOT.ML
+	@$(ISABELLE_TOOL) usedir $(OUT)/HOLCF Library
+
+
+## HOLCF-IMP
+
+HOLCF-IMP: HOLCF $(LOG)/HOLCF-IMP.gz
+
+$(LOG)/HOLCF-IMP.gz: $(OUT)/HOLCF IMP/HoareEx.thy \
+  IMP/Denotational.thy IMP/ROOT.ML IMP/document/root.tex
+	@$(ISABELLE_TOOL) usedir $(OUT)/HOLCF IMP
+
+
+## HOLCF-ex
+
+HOLCF-ex: HOLCF $(LOG)/HOLCF-ex.gz
+
+$(LOG)/HOLCF-ex.gz: $(OUT)/HOLCF \
+  ../Library/Nat_Infinity.thy \
+  ex/Dagstuhl.thy \
+  ex/Dnat.thy \
+  ex/Domain_Proofs.thy \
+  ex/Fix2.thy \
+  ex/Focus_ex.thy \
+  ex/Hoare.thy \
+  ex/Letrec.thy \
+  ex/Loop.thy \
+  ex/Pattern_Match.thy \
+  ex/Powerdomain_ex.thy \
+  ex/ROOT.ML
+	@$(ISABELLE_TOOL) usedir $(OUT)/HOLCF ex
+
+
+## HOLCF-FOCUS
+
+HOLCF-FOCUS: HOLCF $(LOG)/HOLCF-FOCUS.gz
+
+$(LOG)/HOLCF-FOCUS.gz: $(OUT)/HOLCF \
+  Library/Stream.thy \
+  FOCUS/Fstreams.thy \
+  FOCUS/Fstream.thy FOCUS/FOCUS.thy \
+  FOCUS/Stream_adm.thy ../Library/Continuity.thy \
+  FOCUS/Buffer.thy FOCUS/Buffer_adm.thy
+	@$(ISABELLE_TOOL) usedir $(OUT)/HOLCF FOCUS
+
+## IOA
+
+IOA: HOLCF $(OUT)/IOA
+
+$(OUT)/IOA: $(OUT)/HOLCF IOA/ROOT.ML IOA/meta_theory/Traces.thy        \
+  IOA/meta_theory/Asig.thy IOA/meta_theory/CompoScheds.thy	       \
+  IOA/meta_theory/CompoTraces.thy IOA/meta_theory/Seq.thy	       \
+  IOA/meta_theory/RefCorrectness.thy IOA/meta_theory/Automata.thy      \
+  IOA/meta_theory/ShortExecutions.thy IOA/meta_theory/IOA.thy	       \
+  IOA/meta_theory/Sequence.thy IOA/meta_theory/CompoExecs.thy	       \
+  IOA/meta_theory/RefMappings.thy IOA/meta_theory/Compositionality.thy \
+  IOA/meta_theory/TL.thy IOA/meta_theory/TLS.thy		       \
+  IOA/meta_theory/LiveIOA.thy IOA/meta_theory/Pred.thy		       \
+  IOA/meta_theory/Abstraction.thy IOA/meta_theory/Simulations.thy      \
+  IOA/meta_theory/SimCorrectness.thy
+	@cd IOA; $(ISABELLE_TOOL) usedir -b $(OUT)/HOLCF IOA
+
+
+## IOA-ABP
+
+IOA-ABP: IOA $(LOG)/IOA-ABP.gz
+
+$(LOG)/IOA-ABP.gz: $(OUT)/IOA IOA/ABP/Abschannel.thy \
+  IOA/ABP/Abschannel_finite.thy IOA/ABP/Action.thy \
+  IOA/ABP/Check.ML IOA/ABP/Correctness.thy \
+  IOA/ABP/Env.thy IOA/ABP/Impl.thy IOA/ABP/Impl_finite.thy \
+  IOA/ABP/Lemmas.thy IOA/ABP/Packet.thy \
+  IOA/ABP/ROOT.ML IOA/ABP/Receiver.thy IOA/ABP/Sender.thy \
+  IOA/ABP/Spec.thy
+	@cd IOA; $(ISABELLE_TOOL) usedir $(OUT)/IOA ABP
+
+## IOA-NTP
+
+IOA-NTP: IOA $(LOG)/IOA-NTP.gz
+
+$(LOG)/IOA-NTP.gz: $(OUT)/IOA \
+  IOA/NTP/Abschannel.thy IOA/NTP/Action.thy IOA/NTP/Correctness.thy \
+  IOA/NTP/Impl.thy IOA/NTP/Lemmas.thy IOA/NTP/Multiset.thy \
+  IOA/NTP/Packet.thy IOA/NTP/ROOT.ML IOA/NTP/Receiver.thy IOA/NTP/Sender.thy \
+  IOA/NTP/Spec.thy
+	@cd IOA; $(ISABELLE_TOOL) usedir $(OUT)/IOA NTP
+
+
+## IOA-Storage
+
+IOA-Storage: IOA $(LOG)/IOA-Storage.gz
+
+$(LOG)/IOA-Storage.gz: $(OUT)/IOA IOA/Storage/Action.thy \
+  IOA/Storage/Correctness.thy IOA/Storage/Impl.thy \
+  IOA/Storage/ROOT.ML IOA/Storage/Spec.thy
+	@cd IOA; $(ISABELLE_TOOL) usedir $(OUT)/IOA Storage
+
+
+## IOA-ex
+
+IOA-ex: IOA $(LOG)/IOA-ex.gz
+
+$(LOG)/IOA-ex.gz: $(OUT)/IOA IOA/ex/ROOT.ML IOA/ex/TrivEx.thy IOA/ex/TrivEx2.thy
+	@cd IOA; $(ISABELLE_TOOL) usedir $(OUT)/IOA ex
+
+
+## clean
+
+clean:
+	@rm -f $(OUT)/HOLCF $(LOG)/HOLCF.gz $(LOG)/HOLCF-IMP.gz	\
+	  $(LOG)/HOLCF-ex.gz $(LOG)/HOLCF-FOCUS.gz $(OUT)/IOA	\
+	  $(LOG)/IOA.gz $(LOG)/IOA-ABP.gz $(LOG)/IOA-NTP.gz	\
+	  $(LOG)/IOA-Storage.gz $(LOG)/HOLCF-Library.gz		\
+	  $(LOG)/IOA-ex.gz $(LOG)/HOLCF-Tutorial.gz

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/HOLCF/Library/Defl_Bifinite.thy	Sat Nov 27 16:08:10 2010 -0800
@@ -0,0 +1,661 @@
+(*  Title:      HOLCF/Library/Defl_Bifinite.thy
+    Author:     Brian Huffman
+*)
+
+header {* Algebraic deflations are a bifinite domain *}
+
+theory Defl_Bifinite
+imports HOLCF Infinite_Set
+begin
+
+subsection {* Lemmas about MOST *}
+
+default_sort type
+
+lemma MOST_INFM:
+  assumes inf: "infinite (UNIV::'a set)"
+  shows "MOST x::'a. P x \<Longrightarrow> INFM x::'a. P x"
+  unfolding Alm_all_def Inf_many_def
+  apply (auto simp add: Collect_neg_eq)
+  apply (drule (1) finite_UnI)
+  apply (simp add: Compl_partition2 inf)
+  done
+
+lemma MOST_SucI: "MOST n. P n \<Longrightarrow> MOST n. P (Suc n)"
+by (rule MOST_inj [OF _ inj_Suc])
+
+lemma MOST_SucD: "MOST n. P (Suc n) \<Longrightarrow> MOST n. P n"
+unfolding MOST_nat
+apply (clarify, rule_tac x="Suc m" in exI, clarify)
+apply (erule Suc_lessE, simp)
+done
+
+lemma MOST_Suc_iff: "(MOST n. P (Suc n)) \<longleftrightarrow> (MOST n. P n)"
+by (rule iffI [OF MOST_SucD MOST_SucI])
+
+lemma INFM_finite_Bex_distrib:
+  "finite A \<Longrightarrow> (INFM y. \<exists>x\<in>A. P x y) \<longleftrightarrow> (\<exists>x\<in>A. INFM y. P x y)"
+by (induct set: finite, simp, simp add: INFM_disj_distrib)
+
+lemma MOST_finite_Ball_distrib:
+  "finite A \<Longrightarrow> (MOST y. \<forall>x\<in>A. P x y) \<longleftrightarrow> (\<forall>x\<in>A. MOST y. P x y)"
+by (induct set: finite, simp, simp add: MOST_conj_distrib)
+
+lemma MOST_ge_nat: "MOST n::nat. m \<le> n"
+unfolding MOST_nat_le by fast
+
+subsection {* Eventually constant sequences *}
+
+definition
+  eventually_constant :: "(nat \<Rightarrow> 'a) \<Rightarrow> bool"
+where
+  "eventually_constant S = (\<exists>x. MOST i. S i = x)"
+
+lemma eventually_constant_MOST_MOST:
+  "eventually_constant S \<longleftrightarrow> (MOST m. MOST n. S n = S m)"
+unfolding eventually_constant_def MOST_nat
+apply safe
+apply (rule_tac x=m in exI, clarify)
+apply (rule_tac x=m in exI, clarify)
+apply simp
+apply fast
+done
+
+lemma eventually_constantI: "MOST i. S i = x \<Longrightarrow> eventually_constant S"
+unfolding eventually_constant_def by fast
+
+lemma eventually_constant_comp:
+  "eventually_constant (\<lambda>i. S i) \<Longrightarrow> eventually_constant (\<lambda>i. f (S i))"
+unfolding eventually_constant_def
+apply (erule exE, rule_tac x="f x" in exI)
+apply (erule MOST_mono, simp)
+done
+
+lemma eventually_constant_Suc_iff:
+  "eventually_constant (\<lambda>i. S (Suc i)) \<longleftrightarrow> eventually_constant (\<lambda>i. S i)"
+unfolding eventually_constant_def
+by (subst MOST_Suc_iff, rule refl)
+
+lemma eventually_constant_SucD:
+  "eventually_constant (\<lambda>i. S (Suc i)) \<Longrightarrow> eventually_constant (\<lambda>i. S i)"
+by (rule eventually_constant_Suc_iff [THEN iffD1])
+
+subsection {* Limits of eventually constant sequences *}
+
+definition
+  eventual :: "(nat \<Rightarrow> 'a) \<Rightarrow> 'a" where
+  "eventual S = (THE x. MOST i. S i = x)"
+
+lemma eventual_eqI: "MOST i. S i = x \<Longrightarrow> eventual S = x"
+unfolding eventual_def
+apply (rule the_equality, assumption)
+apply (rename_tac y)
+apply (subgoal_tac "MOST i::nat. y = x", simp)
+apply (erule MOST_rev_mp)
+apply (erule MOST_rev_mp)
+apply simp
+done
+
+lemma MOST_eq_eventual:
+  "eventually_constant S \<Longrightarrow> MOST i. S i = eventual S"
+unfolding eventually_constant_def
+by (erule exE, simp add: eventual_eqI)
+
+lemma eventual_mem_range:
+  "eventually_constant S \<Longrightarrow> eventual S \<in> range S"
+apply (drule MOST_eq_eventual)
+apply (simp only: MOST_nat_le, clarify)
+apply (drule spec, drule mp, rule order_refl)
+apply (erule range_eqI [OF sym])
+done
+
+lemma eventually_constant_MOST_iff:
+  assumes S: "eventually_constant S"
+  shows "(MOST n. P (S n)) \<longleftrightarrow> P (eventual S)"
+apply (subgoal_tac "(MOST n. P (S n)) \<longleftrightarrow> (MOST n::nat. P (eventual S))")
+apply simp
+apply (rule iffI)
+apply (rule MOST_rev_mp [OF MOST_eq_eventual [OF S]])
+apply (erule MOST_mono, force)
+apply (rule MOST_rev_mp [OF MOST_eq_eventual [OF S]])
+apply (erule MOST_mono, simp)
+done
+
+lemma MOST_eventual:
+  "\<lbrakk>eventually_constant S; MOST n. P (S n)\<rbrakk> \<Longrightarrow> P (eventual S)"
+proof -
+  assume "eventually_constant S"
+  hence "MOST n. S n = eventual S"
+    by (rule MOST_eq_eventual)
+  moreover assume "MOST n. P (S n)"
+  ultimately have "MOST n. S n = eventual S \<and> P (S n)"
+    by (rule MOST_conj_distrib [THEN iffD2, OF conjI])
+  hence "MOST n::nat. P (eventual S)"
+    by (rule MOST_mono) auto
+  thus ?thesis by simp
+qed
+
+lemma eventually_constant_MOST_Suc_eq:
+  "eventually_constant S \<Longrightarrow> MOST n. S (Suc n) = S n"
+apply (drule MOST_eq_eventual)
+apply (frule MOST_Suc_iff [THEN iffD2])
+apply (erule MOST_rev_mp)
+apply (erule MOST_rev_mp)
+apply simp
+done
+
+lemma eventual_comp:
+  "eventually_constant S \<Longrightarrow> eventual (\<lambda>i. f (S i)) = f (eventual (\<lambda>i. S i))"
+apply (rule eventual_eqI)
+apply (rule MOST_mono)
+apply (erule MOST_eq_eventual)
+apply simp
+done
+
+subsection {* Constructing finite deflations by iteration *}
+
+default_sort cpo
+
+lemma le_Suc_induct:
+  assumes le: "i \<le> j"
+  assumes step: "\<And>i. P i (Suc i)"
+  assumes refl: "\<And>i. P i i"
+  assumes trans: "\<And>i j k. \<lbrakk>P i j; P j k\<rbrakk> \<Longrightarrow> P i k"
+  shows "P i j"
+proof (cases "i = j")
+  assume "i = j"
+  thus "P i j" by (simp add: refl)
+next
+  assume "i \<noteq> j"
+  with le have "i < j" by simp
+  thus "P i j" using step trans by (rule less_Suc_induct)
+qed
+
+definition
+  eventual_iterate :: "('a \<rightarrow> 'a::cpo) \<Rightarrow> ('a \<rightarrow> 'a)"
+where
+  "eventual_iterate f = eventual (\<lambda>n. iterate n\<cdot>f)"
+
+text {* A pre-deflation is like a deflation, but not idempotent. *}
+
+locale pre_deflation =
+  fixes f :: "'a \<rightarrow> 'a::cpo"
+  assumes below: "\<And>x. f\<cdot>x \<sqsubseteq> x"
+  assumes finite_range: "finite (range (\<lambda>x. f\<cdot>x))"
+begin
+
+lemma iterate_below: "iterate i\<cdot>f\<cdot>x \<sqsubseteq> x"
+by (induct i, simp_all add: below_trans [OF below])
+
+lemma iterate_fixed: "f\<cdot>x = x \<Longrightarrow> iterate i\<cdot>f\<cdot>x = x"
+by (induct i, simp_all)
+
+lemma antichain_iterate_app: "i \<le> j \<Longrightarrow> iterate j\<cdot>f\<cdot>x \<sqsubseteq> iterate i\<cdot>f\<cdot>x"
+apply (erule le_Suc_induct)
+apply (simp add: below)
+apply (rule below_refl)
+apply (erule (1) below_trans)
+done
+
+lemma finite_range_iterate_app: "finite (range (\<lambda>i. iterate i\<cdot>f\<cdot>x))"
+proof (rule finite_subset)
+  show "range (\<lambda>i. iterate i\<cdot>f\<cdot>x) \<subseteq> insert x (range (\<lambda>x. f\<cdot>x))"
+    by (clarify, case_tac i, simp_all)
+  show "finite (insert x (range (\<lambda>x. f\<cdot>x)))"
+    by (simp add: finite_range)
+qed
+
+lemma eventually_constant_iterate_app:
+  "eventually_constant (\<lambda>i. iterate i\<cdot>f\<cdot>x)"
+unfolding eventually_constant_def MOST_nat_le
+proof -
+  let ?Y = "\<lambda>i. iterate i\<cdot>f\<cdot>x"
+  have "\<exists>j. \<forall>k. ?Y j \<sqsubseteq> ?Y k"
+    apply (rule finite_range_has_max)
+    apply (erule antichain_iterate_app)
+    apply (rule finite_range_iterate_app)
+    done
+  then obtain j where j: "\<And>k. ?Y j \<sqsubseteq> ?Y k" by fast
+  show "\<exists>z m. \<forall>n\<ge>m. ?Y n = z"
+  proof (intro exI allI impI)
+    fix k
+    assume "j \<le> k"
+    hence "?Y k \<sqsubseteq> ?Y j" by (rule antichain_iterate_app)
+    also have "?Y j \<sqsubseteq> ?Y k" by (rule j)
+    finally show "?Y k = ?Y j" .
+  qed
+qed
+
+lemma eventually_constant_iterate:
+  "eventually_constant (\<lambda>n. iterate n\<cdot>f)"
+proof -
+  have "\<forall>y\<in>range (\<lambda>x. f\<cdot>x). eventually_constant (\<lambda>i. iterate i\<cdot>f\<cdot>y)"
+    by (simp add: eventually_constant_iterate_app)
+  hence "\<forall>y\<in>range (\<lambda>x. f\<cdot>x). MOST i. MOST j. iterate j\<cdot>f\<cdot>y = iterate i\<cdot>f\<cdot>y"
+    unfolding eventually_constant_MOST_MOST .
+  hence "MOST i. MOST j. \<forall>y\<in>range (\<lambda>x. f\<cdot>x). iterate j\<cdot>f\<cdot>y = iterate i\<cdot>f\<cdot>y"
+    by (simp only: MOST_finite_Ball_distrib [OF finite_range])
+  hence "MOST i. MOST j. \<forall>x. iterate j\<cdot>f\<cdot>(f\<cdot>x) = iterate i\<cdot>f\<cdot>(f\<cdot>x)"
+    by simp
+  hence "MOST i. MOST j. \<forall>x. iterate (Suc j)\<cdot>f\<cdot>x = iterate (Suc i)\<cdot>f\<cdot>x"
+    by (simp only: iterate_Suc2)
+  hence "MOST i. MOST j. iterate (Suc j)\<cdot>f = iterate (Suc i)\<cdot>f"
+    by (simp only: cfun_eq_iff)
+  hence "eventually_constant (\<lambda>i. iterate (Suc i)\<cdot>f)"
+    unfolding eventually_constant_MOST_MOST .
+  thus "eventually_constant (\<lambda>i. iterate i\<cdot>f)"
+    by (rule eventually_constant_SucD)
+qed
+
+abbreviation
+  d :: "'a \<rightarrow> 'a"
+where
+  "d \<equiv> eventual_iterate f"
+
+lemma MOST_d: "MOST n. P (iterate n\<cdot>f) \<Longrightarrow> P d"
+unfolding eventual_iterate_def
+using eventually_constant_iterate by (rule MOST_eventual)
+
+lemma f_d: "f\<cdot>(d\<cdot>x) = d\<cdot>x"
+apply (rule MOST_d)
+apply (subst iterate_Suc [symmetric])
+apply (rule eventually_constant_MOST_Suc_eq)
+apply (rule eventually_constant_iterate_app)
+done
+
+lemma d_fixed_iff: "d\<cdot>x = x \<longleftrightarrow> f\<cdot>x = x"
+proof
+  assume "d\<cdot>x = x"
+  with f_d [where x=x]
+  show "f\<cdot>x = x" by simp
+next
+  assume f: "f\<cdot>x = x"
+  have "\<forall>n. iterate n\<cdot>f\<cdot>x = x"
+    by (rule allI, rule nat.induct, simp, simp add: f)
+  hence "MOST n. iterate n\<cdot>f\<cdot>x = x"
+    by (rule ALL_MOST)
+  thus "d\<cdot>x = x"
+    by (rule MOST_d)
+qed
+
+lemma finite_deflation_d: "finite_deflation d"
+proof
+  fix x :: 'a
+  have "d \<in> range (\<lambda>n. iterate n\<cdot>f)"
+    unfolding eventual_iterate_def
+    using eventually_constant_iterate
+    by (rule eventual_mem_range)
+  then obtain n where n: "d = iterate n\<cdot>f" ..
+  have "iterate n\<cdot>f\<cdot>(d\<cdot>x) = d\<cdot>x"
+    using f_d by (rule iterate_fixed)
+  thus "d\<cdot>(d\<cdot>x) = d\<cdot>x"
+    by (simp add: n)
+next
+  fix x :: 'a
+  show "d\<cdot>x \<sqsubseteq> x"
+    by (rule MOST_d, simp add: iterate_below)
+next
+  from finite_range
+  have "finite {x. f\<cdot>x = x}"
+    by (rule finite_range_imp_finite_fixes)
+  thus "finite {x. d\<cdot>x = x}"
+    by (simp add: d_fixed_iff)
+qed
+
+lemma deflation_d: "deflation d"
+using finite_deflation_d
+by (rule finite_deflation_imp_deflation)
+
+end
+
+lemma finite_deflation_eventual_iterate:
+  "pre_deflation d \<Longrightarrow> finite_deflation (eventual_iterate d)"
+by (rule pre_deflation.finite_deflation_d)
+
+lemma pre_deflation_oo:
+  assumes "finite_deflation d"
+  assumes f: "\<And>x. f\<cdot>x \<sqsubseteq> x"
+  shows "pre_deflation (d oo f)"
+proof
+  interpret d: finite_deflation d by fact
+  fix x
+  show "\<And>x. (d oo f)\<cdot>x \<sqsubseteq> x"
+    by (simp, rule below_trans [OF d.below f])
+  show "finite (range (\<lambda>x. (d oo f)\<cdot>x))"
+    by (rule finite_subset [OF _ d.finite_range], auto)
+qed
+
+lemma eventual_iterate_oo_fixed_iff:
+  assumes "finite_deflation d"
+  assumes f: "\<And>x. f\<cdot>x \<sqsubseteq> x"
+  shows "eventual_iterate (d oo f)\<cdot>x = x \<longleftrightarrow> d\<cdot>x = x \<and> f\<cdot>x = x"
+proof -
+  interpret d: finite_deflation d by fact
+  let ?e = "d oo f"
+  interpret e: pre_deflation "d oo f"
+    using `finite_deflation d` f
+    by (rule pre_deflation_oo)
+  let ?g = "eventual (\<lambda>n. iterate n\<cdot>?e)"
+  show ?thesis
+    apply (subst e.d_fixed_iff)
+    apply simp
+    apply safe
+    apply (erule subst)
+    apply (rule d.idem)
+    apply (rule below_antisym)
+    apply (rule f)
+    apply (erule subst, rule d.below)
+    apply simp
+    done
+qed
+
+lemma eventual_mono:
+  assumes A: "eventually_constant A"
+  assumes B: "eventually_constant B"
+  assumes below: "\<And>n. A n \<sqsubseteq> B n"
+  shows "eventual A \<sqsubseteq> eventual B"
+proof -
+  from A have "MOST n. A n = eventual A"
+    by (rule MOST_eq_eventual)
+  then have "MOST n. eventual A \<sqsubseteq> B n"
+    by (rule MOST_mono) (erule subst, rule below)
+  with B show "eventual A \<sqsubseteq> eventual B"
+    by (rule MOST_eventual)
+qed
+
+lemma eventual_iterate_mono:
+  assumes f: "pre_deflation f" and g: "pre_deflation g" and "f \<sqsubseteq> g"
+  shows "eventual_iterate f \<sqsubseteq> eventual_iterate g"
+unfolding eventual_iterate_def
+apply (rule eventual_mono)
+apply (rule pre_deflation.eventually_constant_iterate [OF f])
+apply (rule pre_deflation.eventually_constant_iterate [OF g])
+apply (rule monofun_cfun_arg [OF `f \<sqsubseteq> g`])
+done
+
+lemma cont2cont_eventual_iterate_oo:
+  assumes d: "finite_deflation d"
+  assumes cont: "cont f" and below: "\<And>x y. f x\<cdot>y \<sqsubseteq> y"
+  shows "cont (\<lambda>x. eventual_iterate (d oo f x))"
+    (is "cont ?e")
+proof (rule contI2)
+  show "monofun ?e"
+    apply (rule monofunI)
+    apply (rule eventual_iterate_mono)
+    apply (rule pre_deflation_oo [OF d below])
+    apply (rule pre_deflation_oo [OF d below])
+    apply (rule monofun_cfun_arg)
+    apply (erule cont2monofunE [OF cont])
+    done
+next
+  fix Y :: "nat \<Rightarrow> 'b"
+  assume Y: "chain Y"
+  with cont have fY: "chain (\<lambda>i. f (Y i))"
+    by (rule ch2ch_cont)
+  assume eY: "chain (\<lambda>i. ?e (Y i))"
+  have lub_below: "\<And>x. f (\<Squnion>i. Y i)\<cdot>x \<sqsubseteq> x"
+    by (rule admD [OF _ Y], simp add: cont, rule below)
+  have "deflation (?e (\<Squnion>i. Y i))"
+    apply (rule pre_deflation.deflation_d)
+    apply (rule pre_deflation_oo [OF d lub_below])
+    done
+  then show "?e (\<Squnion>i. Y i) \<sqsubseteq> (\<Squnion>i. ?e (Y i))"
+  proof (rule deflation.belowI)
+    fix x :: 'a
+    assume "?e (\<Squnion>i. Y i)\<cdot>x = x"
+    hence "d\<cdot>x = x" and "f (\<Squnion>i. Y i)\<cdot>x = x"
+      by (simp_all add: eventual_iterate_oo_fixed_iff [OF d lub_below])
+    hence "(\<Squnion>i. f (Y i)\<cdot>x) = x"
+      apply (simp only: cont2contlubE [OF cont Y])
+      apply (simp only: contlub_cfun_fun [OF fY])
+      done
+    have "compact (d\<cdot>x)"
+      using d by (rule finite_deflation.compact)
+    then have "compact x"
+      using `d\<cdot>x = x` by simp
+    then have "compact (\<Squnion>i. f (Y i)\<cdot>x)"
+      using `(\<Squnion>i. f (Y i)\<cdot>x) = x` by simp
+    then have "\<exists>n. max_in_chain n (\<lambda>i. f (Y i)\<cdot>x)"
+      by - (rule compact_imp_max_in_chain, simp add: fY, assumption)
+    then obtain n where n: "max_in_chain n (\<lambda>i. f (Y i)\<cdot>x)" ..
+    then have "f (Y n)\<cdot>x = x"
+      using `(\<Squnion>i. f (Y i)\<cdot>x) = x` fY by (simp add: maxinch_is_thelub)
+    with `d\<cdot>x = x` have "?e (Y n)\<cdot>x = x"
+      by (simp add: eventual_iterate_oo_fixed_iff [OF d below])
+    moreover have "?e (Y n)\<cdot>x \<sqsubseteq> (\<Squnion>i. ?e (Y i)\<cdot>x)"
+      by (rule is_ub_thelub, simp add: eY)
+    ultimately have "x \<sqsubseteq> (\<Squnion>i. ?e (Y i))\<cdot>x"
+      by (simp add: contlub_cfun_fun eY)
+    also have "(\<Squnion>i. ?e (Y i))\<cdot>x \<sqsubseteq> x"
+      apply (rule deflation.below)
+      apply (rule admD [OF adm_deflation eY])
+      apply (rule pre_deflation.deflation_d)
+      apply (rule pre_deflation_oo [OF d below])
+      done
+    finally show "(\<Squnion>i. ?e (Y i))\<cdot>x = x" ..
+  qed
+qed
+
+subsection {* Take function for finite deflations *}
+
+definition
+  defl_take :: "nat \<Rightarrow> (udom \<rightarrow> udom) \<Rightarrow> (udom \<rightarrow> udom)"
+where
+  "defl_take i d = eventual_iterate (udom_approx i oo d)"
+
+lemma finite_deflation_defl_take:
+  "deflation d \<Longrightarrow> finite_deflation (defl_take i d)"
+unfolding defl_take_def
+apply (rule pre_deflation.finite_deflation_d)
+apply (rule pre_deflation_oo)
+apply (rule finite_deflation_udom_approx)
+apply (erule deflation.below)
+done
+
+lemma deflation_defl_take:
+  "deflation d \<Longrightarrow> deflation (defl_take i d)"
+apply (rule finite_deflation_imp_deflation)
+apply (erule finite_deflation_defl_take)
+done
+
+lemma defl_take_fixed_iff:
+  "deflation d \<Longrightarrow> defl_take i d\<cdot>x = x \<longleftrightarrow> udom_approx i\<cdot>x = x \<and> d\<cdot>x = x"
+unfolding defl_take_def
+apply (rule eventual_iterate_oo_fixed_iff)
+apply (rule finite_deflation_udom_approx)
+apply (erule deflation.below)
+done
+
+lemma defl_take_below:
+  "\<lbrakk>a \<sqsubseteq> b; deflation a; deflation b\<rbrakk> \<Longrightarrow> defl_take i a \<sqsubseteq> defl_take i b"
+apply (rule deflation.belowI)
+apply (erule deflation_defl_take)
+apply (simp add: defl_take_fixed_iff)
+apply (erule (1) deflation.belowD)
+apply (erule conjunct2)
+done
+
+lemma cont2cont_defl_take:
+  assumes cont: "cont f" and below: "\<And>x y. f x\<cdot>y \<sqsubseteq> y"
+  shows "cont (\<lambda>x. defl_take i (f x))"
+unfolding defl_take_def
+using finite_deflation_udom_approx assms
+by (rule cont2cont_eventual_iterate_oo)
+
+definition
+  fd_take :: "nat \<Rightarrow> fin_defl \<Rightarrow> fin_defl"
+where
+  "fd_take i d = Abs_fin_defl (defl_take i (Rep_fin_defl d))"
+
+lemma Rep_fin_defl_fd_take:
+  "Rep_fin_defl (fd_take i d) = defl_take i (Rep_fin_defl d)"
+unfolding fd_take_def
+apply (rule Abs_fin_defl_inverse [unfolded mem_Collect_eq])
+apply (rule finite_deflation_defl_take)
+apply (rule deflation_Rep_fin_defl)
+done
+
+lemma fd_take_fixed_iff:
+  "Rep_fin_defl (fd_take i d)\<cdot>x = x \<longleftrightarrow>
+    udom_approx i\<cdot>x = x \<and> Rep_fin_defl d\<cdot>x = x"
+unfolding Rep_fin_defl_fd_take
+apply (rule defl_take_fixed_iff)
+apply (rule deflation_Rep_fin_defl)
+done
+
+lemma fd_take_below: "fd_take n d \<sqsubseteq> d"
+apply (rule fin_defl_belowI)
+apply (simp add: fd_take_fixed_iff)
+done
+
+lemma fd_take_idem: "fd_take n (fd_take n d) = fd_take n d"
+apply (rule fin_defl_eqI)
+apply (simp add: fd_take_fixed_iff)
+done
+
+lemma fd_take_mono: "a \<sqsubseteq> b \<Longrightarrow> fd_take n a \<sqsubseteq> fd_take n b"
+apply (rule fin_defl_belowI)
+apply (simp add: fd_take_fixed_iff)
+apply (simp add: fin_defl_belowD)
+done
+
+lemma approx_fixed_le_lemma: "\<lbrakk>i \<le> j; udom_approx i\<cdot>x = x\<rbrakk> \<Longrightarrow> udom_approx j\<cdot>x = x"
+apply (rule deflation.belowD)
+apply (rule finite_deflation_imp_deflation)
+apply (rule finite_deflation_udom_approx)
+apply (erule chain_mono [OF chain_udom_approx])
+apply assumption
+done
+
+lemma fd_take_chain: "m \<le> n \<Longrightarrow> fd_take m a \<sqsubseteq> fd_take n a"
+apply (rule fin_defl_belowI)
+apply (simp add: fd_take_fixed_iff)
+apply (simp add: approx_fixed_le_lemma)
+done
+
+lemma finite_range_fd_take: "finite (range (fd_take n))"
+apply (rule finite_imageD [where f="\<lambda>a. {x. Rep_fin_defl a\<cdot>x = x}"])
+apply (rule finite_subset [where B="Pow {x. udom_approx n\<cdot>x = x}"])
+apply (clarify, simp add: fd_take_fixed_iff)
+apply (simp add: finite_deflation.finite_fixes [OF finite_deflation_udom_approx])
+apply (rule inj_onI, clarify)
+apply (simp add: set_eq_iff fin_defl_eqI)
+done
+
+lemma fd_take_covers: "\<exists>n. fd_take n a = a"
+apply (rule_tac x=
+  "Max ((\<lambda>x. LEAST n. udom_approx n\<cdot>x = x) ` {x. Rep_fin_defl a\<cdot>x = x})" in exI)
+apply (rule below_antisym)
+apply (rule fd_take_below)
+apply (rule fin_defl_belowI)
+apply (simp add: fd_take_fixed_iff)
+apply (rule approx_fixed_le_lemma)
+apply (rule Max_ge)
+apply (rule finite_imageI)
+apply (rule Rep_fin_defl.finite_fixes)
+apply (rule imageI)
+apply (erule CollectI)
+apply (rule LeastI_ex)
+apply (rule approx_chain.compact_eq_approx [OF udom_approx])
+apply (erule subst)
+apply (rule Rep_fin_defl.compact)
+done
+
+subsection {* Chain of approx functions on algebraic deflations *}
+
+definition
+  defl_approx :: "nat \<Rightarrow> defl \<rightarrow> defl"
+where
+  "defl_approx = (\<lambda>i. defl.basis_fun (\<lambda>d. defl_principal (fd_take i d)))"
+
+lemma defl_approx_principal:
+  "defl_approx i\<cdot>(defl_principal d) = defl_principal (fd_take i d)"
+unfolding defl_approx_def
+by (simp add: defl.basis_fun_principal fd_take_mono)
+
+lemma defl_approx: "approx_chain defl_approx"
+proof
+  show chain: "chain defl_approx"
+    unfolding defl_approx_def
+    by (simp add: chainI defl.basis_fun_mono fd_take_mono fd_take_chain)
+  show idem: "\<And>i x. defl_approx i\<cdot>(defl_approx i\<cdot>x) = defl_approx i\<cdot>x"
+    apply (induct_tac x rule: defl.principal_induct, simp)
+    apply (simp add: defl_approx_principal fd_take_idem)
+    done
+  show below: "\<And>i x. defl_approx i\<cdot>x \<sqsubseteq> x"
+    apply (induct_tac x rule: defl.principal_induct, simp)
+    apply (simp add: defl_approx_principal fd_take_below)
+    done
+  show lub: "(\<Squnion>i. defl_approx i) = ID"
+    apply (rule cfun_eqI, rule below_antisym)
+    apply (simp add: contlub_cfun_fun chain lub_below_iff chain below)
+    apply (induct_tac x rule: defl.principal_induct, simp)
+    apply (simp add: contlub_cfun_fun chain)
+    apply (simp add: compact_below_lub_iff defl.compact_principal chain)
+    apply (simp add: defl_approx_principal)
+    apply (subgoal_tac "\<exists>i. fd_take i a = a", metis below_refl)
+    apply (rule fd_take_covers)
+    done
+  show "\<And>i. finite {x. defl_approx i\<cdot>x = x}"
+    apply (rule finite_range_imp_finite_fixes)
+    apply (rule_tac B="defl_principal ` range (fd_take i)" in rev_finite_subset)
+    apply (simp add: finite_range_fd_take)
+    apply (clarsimp, rename_tac x)
+    apply (induct_tac x rule: defl.principal_induct)
+    apply (simp add: adm_mem_finite finite_range_fd_take)
+    apply (simp add: defl_approx_principal)
+    done
+qed
+
+subsection {* Algebraic deflations are a bifinite domain *}
+
+instantiation defl :: liftdomain
+begin
+
+definition
+  "emb = udom_emb defl_approx"
+
+definition
+  "prj = udom_prj defl_approx"
+
+definition
+  "defl (t::defl itself) =
+    (\<Squnion>i. defl_principal (Abs_fin_defl (emb oo defl_approx i oo prj)))"
+
+definition
+  "(liftemb :: defl u \<rightarrow> udom) = udom_emb u_approx oo u_map\<cdot>emb"
+
+definition
+  "(liftprj :: udom \<rightarrow> defl u) = u_map\<cdot>prj oo udom_prj u_approx"
+
+definition
+  "liftdefl (t::defl itself) = u_defl\<cdot>DEFL(defl)"
+
+instance
+using liftemb_defl_def liftprj_defl_def liftdefl_defl_def
+proof (rule liftdomain_class_intro)
+  show ep: "ep_pair emb (prj :: udom \<rightarrow> defl)"
+    unfolding emb_defl_def prj_defl_def
+    by (rule ep_pair_udom [OF defl_approx])
+  show "cast\<cdot>DEFL(defl) = emb oo (prj :: udom \<rightarrow> defl)"
+    unfolding defl_defl_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 approx_chain.finite_deflation_approx [OF defl_approx]
+                     ep_pair.finite_deflation_e_d_p [OF ep])
+    apply (intro monofun_cfun below_refl)
+    apply (rule chainE)
+    apply (rule approx_chain.chain_approx [OF defl_approx])
+    apply (subst cast_defl_principal)
+    apply (simp add: Abs_fin_defl_inverse approx_chain.finite_deflation_approx [OF defl_approx]
+                     ep_pair.finite_deflation_e_d_p [OF ep])
+    apply (simp add: lub_distribs approx_chain.chain_approx [OF defl_approx]
+                     approx_chain.lub_approx [OF defl_approx])
+    done
+qed
+
+end
+
+end

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/HOLCF/Library/HOLCF_Library.thy	Sat Nov 27 16:08:10 2010 -0800
@@ -0,0 +1,9 @@
+theory HOLCF_Library
+imports
+  Defl_Bifinite
+  List_Cpo
+  Stream
+  Sum_Cpo
+begin
+
+end

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/HOLCF/Library/List_Cpo.thy	Sat Nov 27 16:08:10 2010 -0800
@@ -0,0 +1,268 @@
+(*  Title:      HOLCF/Library/List_Cpo.thy
+    Author:     Brian Huffman
+*)
+
+header {* Lists as a complete partial order *}
+
+theory List_Cpo
+imports HOLCF
+begin
+
+subsection {* Lists are a partial order *}
+
+instantiation list :: (po) po
+begin
+
+definition
+  "xs \<sqsubseteq> ys \<longleftrightarrow> list_all2 (op \<sqsubseteq>) xs ys"
+
+instance proof
+  fix xs :: "'a list"
+  from below_refl show "xs \<sqsubseteq> xs"
+    unfolding below_list_def
+    by (rule list_all2_refl)
+next
+  fix xs ys zs :: "'a list"
+  assume "xs \<sqsubseteq> ys" and "ys \<sqsubseteq> zs"
+  with below_trans show "xs \<sqsubseteq> zs"
+    unfolding below_list_def
+    by (rule list_all2_trans)
+next
+  fix xs ys zs :: "'a list"
+  assume "xs \<sqsubseteq> ys" and "ys \<sqsubseteq> xs"
+  with below_antisym show "xs = ys"
+    unfolding below_list_def
+    by (rule list_all2_antisym)
+qed
+
+end
+
+lemma below_list_simps [simp]:
+  "[] \<sqsubseteq> []"
+  "x # xs \<sqsubseteq> y # ys \<longleftrightarrow> x \<sqsubseteq> y \<and> xs \<sqsubseteq> ys"
+  "\<not> [] \<sqsubseteq> y # ys"
+  "\<not> x # xs \<sqsubseteq> []"
+by (simp_all add: below_list_def)
+
+lemma Nil_below_iff [simp]: "[] \<sqsubseteq> xs \<longleftrightarrow> xs = []"
+by (cases xs, simp_all)
+
+lemma below_Nil_iff [simp]: "xs \<sqsubseteq> [] \<longleftrightarrow> xs = []"
+by (cases xs, simp_all)
+
+lemma list_below_induct [consumes 1, case_names Nil Cons]:
+  assumes "xs \<sqsubseteq> ys"
+  assumes 1: "P [] []"
+  assumes 2: "\<And>x y xs ys. \<lbrakk>x \<sqsubseteq> y; xs \<sqsubseteq> ys; P xs ys\<rbrakk> \<Longrightarrow> P (x # xs) (y # ys)"
+  shows "P xs ys"
+using `xs \<sqsubseteq> ys`
+proof (induct xs arbitrary: ys)
+  case Nil thus ?case by (simp add: 1)
+next
+  case (Cons x xs) thus ?case by (cases ys, simp_all add: 2)
+qed
+
+lemma list_below_cases:
+  assumes "xs \<sqsubseteq> ys"
+  obtains "xs = []" and "ys = []" |
+    x y xs' ys' where "xs = x # xs'" and "ys = y # ys'"
+using assms by (cases xs, simp, cases ys, auto)
+
+text "Thanks to Joachim Breitner"
+
+lemma list_Cons_below:
+  assumes "a # as \<sqsubseteq> xs"
+  obtains b and bs where "a \<sqsubseteq> b" and "as \<sqsubseteq> bs" and "xs = b # bs"
+  using assms by (cases xs, auto)
+
+lemma list_below_Cons:
+  assumes "xs \<sqsubseteq> b # bs"
+  obtains a and as where "a \<sqsubseteq> b" and "as \<sqsubseteq> bs" and "xs = a # as"
+  using assms by (cases xs, auto)
+
+lemma hd_mono: "xs \<sqsubseteq> ys \<Longrightarrow> hd xs \<sqsubseteq> hd ys"
+by (cases xs, simp, cases ys, simp, simp)
+
+lemma tl_mono: "xs \<sqsubseteq> ys \<Longrightarrow> tl xs \<sqsubseteq> tl ys"
+by (cases xs, simp, cases ys, simp, simp)
+
+lemma ch2ch_hd [simp]: "chain (\<lambda>i. S i) \<Longrightarrow> chain (\<lambda>i. hd (S i))"
+by (rule chainI, rule hd_mono, erule chainE)
+
+lemma ch2ch_tl [simp]: "chain (\<lambda>i. S i) \<Longrightarrow> chain (\<lambda>i. tl (S i))"
+by (rule chainI, rule tl_mono, erule chainE)
+
+lemma below_same_length: "xs \<sqsubseteq> ys \<Longrightarrow> length xs = length ys"
+unfolding below_list_def by (rule list_all2_lengthD)
+
+lemma list_chain_induct [consumes 1, case_names Nil Cons]:
+  assumes "chain S"
+  assumes 1: "P (\<lambda>i. [])"
+  assumes 2: "\<And>A B. chain A \<Longrightarrow> chain B \<Longrightarrow> P B \<Longrightarrow> P (\<lambda>i. A i # B i)"
+  shows "P S"
+using `chain S`
+proof (induct "S 0" arbitrary: S)
+  case Nil
+  have "\<forall>i. S 0 \<sqsubseteq> S i" by (simp add: chain_mono [OF `chain S`])
+  with Nil have "\<forall>i. S i = []" by simp
+  thus ?case by (simp add: 1)
+next
+  case (Cons x xs)
+  have "\<forall>i. S 0 \<sqsubseteq> S i" by (simp add: chain_mono [OF `chain S`])
+  hence *: "\<forall>i. S i \<noteq> []" by (rule all_forward, insert Cons) auto
+  have "chain (\<lambda>i. hd (S i))" and "chain (\<lambda>i. tl (S i))"
+    using `chain S` by simp_all
+  moreover have "P (\<lambda>i. tl (S i))"
+    using `chain S` and `x # xs = S 0` [symmetric]
+    by (simp add: Cons(1))
+  ultimately have "P (\<lambda>i. hd (S i) # tl (S i))"
+    by (rule 2)
+  thus "P S" by (simp add: *)
+qed
+
+lemma list_chain_cases:
+  assumes S: "chain S"
+  obtains "S = (\<lambda>i. [])" |
+    A B where "chain A" and "chain B" and "S = (\<lambda>i. A i # B i)"
+using S by (induct rule: list_chain_induct) simp_all
+
+subsection {* Lists are a complete partial order *}
+
+lemma is_lub_Cons:
+  assumes A: "range A <<| x"
+  assumes B: "range B <<| xs"
+  shows "range (\<lambda>i. A i # B i) <<| x # xs"
+using assms
+unfolding is_lub_def is_ub_def
+by (clarsimp, case_tac u, simp_all)
+
+instance list :: (cpo) cpo
+proof
+  fix S :: "nat \<Rightarrow> 'a list"
+  assume "chain S" thus "\<exists>x. range S <<| x"
+  proof (induct rule: list_chain_induct)
+    case Nil thus ?case by (auto intro: is_lub_const)
+  next
+    case (Cons A B) thus ?case by (auto intro: is_lub_Cons cpo_lubI)
+  qed
+qed
+
+subsection {* Continuity of list operations *}
+
+lemma cont2cont_Cons [simp, cont2cont]:
+  assumes f: "cont (\<lambda>x. f x)"
+  assumes g: "cont (\<lambda>x. g x)"
+  shows "cont (\<lambda>x. f x # g x)"
+apply (rule contI)
+apply (rule is_lub_Cons)
+apply (erule contE [OF f])
+apply (erule contE [OF g])
+done
+
+lemma lub_Cons:
+  fixes A :: "nat \<Rightarrow> 'a::cpo"
+  assumes A: "chain A" and B: "chain B"
+  shows "(\<Squnion>i. A i # B i) = (\<Squnion>i. A i) # (\<Squnion>i. B i)"
+by (intro lub_eqI is_lub_Cons cpo_lubI A B)
+
+lemma cont2cont_list_case:
+  assumes f: "cont (\<lambda>x. f x)"
+  assumes g: "cont (\<lambda>x. g x)"
+  assumes h1: "\<And>y ys. cont (\<lambda>x. h x y ys)"
+  assumes h2: "\<And>x ys. cont (\<lambda>y. h x y ys)"
+  assumes h3: "\<And>x y. cont (\<lambda>ys. h x y ys)"
+  shows "cont (\<lambda>x. case f x of [] \<Rightarrow> g x | y # ys \<Rightarrow> h x y ys)"
+apply (rule cont_apply [OF f])
+apply (rule contI)
+apply (erule list_chain_cases)
+apply (simp add: is_lub_const)
+apply (simp add: lub_Cons)
+apply (simp add: cont2contlubE [OF h2])
+apply (simp add: cont2contlubE [OF h3])
+apply (simp add: diag_lub ch2ch_cont [OF h2] ch2ch_cont [OF h3])
+apply (rule cpo_lubI, rule chainI, rule below_trans)
+apply (erule cont2monofunE [OF h2 chainE])
+apply (erule cont2monofunE [OF h3 chainE])
+apply (case_tac y, simp_all add: g h1)
+done
+
+lemma cont2cont_list_case' [simp, cont2cont]:
+  assumes f: "cont (\<lambda>x. f x)"
+  assumes g: "cont (\<lambda>x. g x)"
+  assumes h: "cont (\<lambda>p. h (fst p) (fst (snd p)) (snd (snd p)))"
+  shows "cont (\<lambda>x. case f x of [] \<Rightarrow> g x | y # ys \<Rightarrow> h x y ys)"
+using assms by (simp add: cont2cont_list_case prod_cont_iff)
+
+text {* The simple version (due to Joachim Breitner) is needed if the
+  element type of the list is not a cpo. *}
+
+lemma cont2cont_list_case_simple [simp, cont2cont]:
+  assumes "cont (\<lambda>x. f1 x)"
+  assumes "\<And>y ys. cont (\<lambda>x. f2 x y ys)"
+  shows "cont (\<lambda>x. case l of [] \<Rightarrow> f1 x | y # ys \<Rightarrow> f2 x y ys)"
+using assms by (cases l) auto
+
+text {* Lemma for proving continuity of recursive list functions: *}
+
+lemma list_contI:
+  fixes f :: "'a::cpo list \<Rightarrow> 'b::cpo"
+  assumes f: "\<And>x xs. f (x # xs) = g x xs (f xs)"
+  assumes g1: "\<And>xs y. cont (\<lambda>x. g x xs y)"
+  assumes g2: "\<And>x y. cont (\<lambda>xs. g x xs y)"
+  assumes g3: "\<And>x xs. cont (\<lambda>y. g x xs y)"
+  shows "cont f"
+proof (rule contI2)
+  obtain h where h: "\<And>x xs y. g x xs y = h\<cdot>x\<cdot>xs\<cdot>y"
+  proof
+    fix x xs y show "g x xs y = (\<Lambda> x xs y. g x xs y)\<cdot>x\<cdot>xs\<cdot>y"
+    by (simp add: cont2cont_LAM g1 g2 g3)
+  qed
+  show mono: "monofun f"
+    apply (rule monofunI)
+    apply (erule list_below_induct)
+    apply simp
+    apply (simp add: f h monofun_cfun)
+    done
+  fix Y :: "nat \<Rightarrow> 'a list"
+  assume "chain Y" thus "f (\<Squnion>i. Y i) \<sqsubseteq> (\<Squnion>i. f (Y i))"
+    apply (induct rule: list_chain_induct)
+    apply simp
+    apply (simp add: lub_Cons f h)
+    apply (simp add: contlub_cfun [symmetric] ch2ch_monofun [OF mono])
+    apply (simp add: monofun_cfun)
+    done
+qed
+
+text {* There are probably lots of other list operations that also
+deserve to have continuity lemmas.  I'll add more as they are
+needed. *}
+
+subsection {* Using lists with fixrec *}
+
+definition
+  match_Nil :: "'a::cpo list \<rightarrow> 'b match \<rightarrow> 'b match"
+where
+  "match_Nil = (\<Lambda> xs k. case xs of [] \<Rightarrow> k | y # ys \<Rightarrow> Fixrec.fail)"
+
+definition
+  match_Cons :: "'a::cpo list \<rightarrow> ('a \<rightarrow> 'a list \<rightarrow> 'b match) \<rightarrow> 'b match"
+where
+  "match_Cons = (\<Lambda> xs k. case xs of [] \<Rightarrow> Fixrec.fail | y # ys \<Rightarrow> k\<cdot>y\<cdot>ys)"
+
+lemma match_Nil_simps [simp]:
+  "match_Nil\<cdot>[]\<cdot>k = k"
+  "match_Nil\<cdot>(x # xs)\<cdot>k = Fixrec.fail"
+unfolding match_Nil_def by simp_all
+
+lemma match_Cons_simps [simp]:
+  "match_Cons\<cdot>[]\<cdot>k = Fixrec.fail"
+  "match_Cons\<cdot>(x # xs)\<cdot>k = k\<cdot>x\<cdot>xs"
+unfolding match_Cons_def by simp_all
+
+setup {*
+  Fixrec.add_matchers
+    [ (@{const_name Nil}, @{const_name match_Nil}),
+      (@{const_name Cons}, @{const_name match_Cons}) ]
+*}
+
+end

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/HOLCF/Library/ROOT.ML	Sat Nov 27 16:08:10 2010 -0800
@@ -0,0 +1,1 @@
+use_thys ["HOLCF_Library"];

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/HOLCF/Library/Stream.thy	Sat Nov 27 16:08:10 2010 -0800
@@ -0,0 +1,967 @@
+(*  Title:      HOLCF/ex/Stream.thy
+    Author:     Franz Regensburger, David von Oheimb, Borislav Gajanovic
+*)
+
+header {* General Stream domain *}
+
+theory Stream
+imports HOLCF Nat_Infinity
+begin
+
+default_sort pcpo
+
+domain (unsafe) 'a stream = scons (ft::'a) (lazy rt::"'a stream") (infixr "&&" 65)
+
+definition
+  smap :: "('a \<rightarrow> 'b) \<rightarrow> 'a stream \<rightarrow> 'b stream" where
+  "smap = fix\<cdot>(\<Lambda> h f s. case s of x && xs \<Rightarrow> f\<cdot>x && h\<cdot>f\<cdot>xs)"
+
+definition
+  sfilter :: "('a \<rightarrow> tr) \<rightarrow> 'a stream \<rightarrow> 'a stream" where
+  "sfilter = fix\<cdot>(\<Lambda> h p s. case s of x && xs \<Rightarrow>
+                                     If p\<cdot>x then x && h\<cdot>p\<cdot>xs else h\<cdot>p\<cdot>xs)"
+
+definition
+  slen :: "'a stream \<Rightarrow> inat"  ("#_" [1000] 1000) where
+  "#s = (if stream_finite s then Fin (LEAST n. stream_take n\<cdot>s = s) else \<infinity>)"
+
+
+(* concatenation *)
+
+definition
+  i_rt :: "nat => 'a stream => 'a stream" where (* chops the first i elements *)
+  "i_rt = (%i s. iterate i$rt$s)"
+
+definition
+  i_th :: "nat => 'a stream => 'a" where (* the i-th element *)
+  "i_th = (%i s. ft$(i_rt i s))"
+
+definition
+  sconc :: "'a stream => 'a stream => 'a stream"  (infixr "ooo" 65) where
+  "s1 ooo s2 = (case #s1 of
+                  Fin n \<Rightarrow> (SOME s. (stream_take n$s=s1) & (i_rt n s = s2))
+               | \<infinity>     \<Rightarrow> s1)"
+
+primrec constr_sconc' :: "nat => 'a stream => 'a stream => 'a stream"
+where
+  constr_sconc'_0:   "constr_sconc' 0 s1 s2 = s2"
+| constr_sconc'_Suc: "constr_sconc' (Suc n) s1 s2 = ft$s1 &&
+                                                    constr_sconc' n (rt$s1) s2"
+
+definition
+  constr_sconc  :: "'a stream => 'a stream => 'a stream" where (* constructive *)
+  "constr_sconc s1 s2 = (case #s1 of
+                          Fin n \<Rightarrow> constr_sconc' n s1 s2
+                        | \<infinity>    \<Rightarrow> s1)"
+
+
+(* ----------------------------------------------------------------------- *)
+(* theorems about scons                                                    *)
+(* ----------------------------------------------------------------------- *)
+
+
+section "scons"
+
+lemma scons_eq_UU: "(a && s = UU) = (a = UU)"
+by simp
+
+lemma scons_not_empty: "[| a && x = UU; a ~= UU |] ==> R"
+by simp
+
+lemma stream_exhaust_eq: "(x ~= UU) = (EX a y. a ~= UU &  x = a && y)"
+by (cases x, auto)
+
+lemma stream_neq_UU: "x~=UU ==> EX a a_s. x=a&&a_s & a~=UU"
+by (simp add: stream_exhaust_eq,auto)
+
+lemma stream_prefix:
+  "[| a && s << t; a ~= UU  |] ==> EX b tt. t = b && tt &  b ~= UU &  s << tt"
+by (cases t, auto)
+
+lemma stream_prefix':
+  "b ~= UU ==> x << b && z =
+   (x = UU |  (EX a y. x = a && y &  a ~= UU &  a << b &  y << z))"
+by (cases x, auto)
+
+
+(*
+lemma stream_prefix1: "[| x<<y; xs<<ys |] ==> x&&xs << y&&ys"
+by (insert stream_prefix' [of y "x&&xs" ys],force)
+*)
+
+lemma stream_flat_prefix:
+  "[| x && xs << y && ys; (x::'a::flat) ~= UU|] ==> x = y & xs << ys"
+apply (case_tac "y=UU",auto)
+by (drule ax_flat,simp)
+
+
+
+
+(* ----------------------------------------------------------------------- *)
+(* theorems about stream_case                                              *)
+(* ----------------------------------------------------------------------- *)
+
+section "stream_case"
+
+
+lemma stream_case_strictf: "stream_case$UU$s=UU"
+by (cases s, auto)
+
+
+
+(* ----------------------------------------------------------------------- *)
+(* theorems about ft and rt                                                *)
+(* ----------------------------------------------------------------------- *)
+
+
+section "ft & rt"
+
+
+lemma ft_defin: "s~=UU ==> ft$s~=UU"
+by simp
+
+lemma rt_strict_rev: "rt$s~=UU ==> s~=UU"
+by auto
+
+lemma surjectiv_scons: "(ft$s)&&(rt$s)=s"
+by (cases s, auto)
+
+lemma monofun_rt_mult: "x << s ==> iterate i$rt$x << iterate i$rt$s"
+by (rule monofun_cfun_arg)
+
+
+
+(* ----------------------------------------------------------------------- *)
+(* theorems about stream_take                                              *)
+(* ----------------------------------------------------------------------- *)
+
+
+section "stream_take"
+
+
+lemma stream_reach2: "(LUB i. stream_take i$s) = s"
+by (rule stream.reach)
+
+lemma chain_stream_take: "chain (%i. stream_take i$s)"
+by simp
+
+lemma stream_take_prefix [simp]: "stream_take n$s << s"
+apply (insert stream_reach2 [of s])
+apply (erule subst) back
+apply (rule is_ub_thelub)
+by (simp only: chain_stream_take)
+
+lemma stream_take_more [rule_format]:
+  "ALL x. stream_take n$x = x --> stream_take (Suc n)$x = x"
+apply (induct_tac n,auto)
+apply (case_tac "x=UU",auto)
+by (drule stream_exhaust_eq [THEN iffD1],auto)
+
+lemma stream_take_lemma3 [rule_format]:
+  "ALL x xs. x~=UU --> stream_take n$(x && xs) = x && xs --> stream_take n$xs=xs"
+apply (induct_tac n,clarsimp)
+(*apply (drule sym, erule scons_not_empty, simp)*)
+apply (clarify, rule stream_take_more)
+apply (erule_tac x="x" in allE)
+by (erule_tac x="xs" in allE,simp)
+
+lemma stream_take_lemma4:
+  "ALL x xs. stream_take n$xs=xs --> stream_take (Suc n)$(x && xs) = x && xs"
+by auto
+
+lemma stream_take_idempotent [rule_format, simp]:
+ "ALL s. stream_take n$(stream_take n$s) = stream_take n$s"
+apply (induct_tac n, auto)
+apply (case_tac "s=UU", auto)
+by (drule stream_exhaust_eq [THEN iffD1], auto)
+
+lemma stream_take_take_Suc [rule_format, simp]:
+  "ALL s. stream_take n$(stream_take (Suc n)$s) =
+                                    stream_take n$s"
+apply (induct_tac n, auto)
+apply (case_tac "s=UU", auto)
+by (drule stream_exhaust_eq [THEN iffD1], auto)
+
+lemma mono_stream_take_pred:
+  "stream_take (Suc n)$s1 << stream_take (Suc n)$s2 ==>
+                       stream_take n$s1 << stream_take n$s2"
+by (insert monofun_cfun_arg [of "stream_take (Suc n)$s1"
+  "stream_take (Suc n)$s2" "stream_take n"], auto)
+(*
+lemma mono_stream_take_pred:
+  "stream_take (Suc n)$s1 << stream_take (Suc n)$s2 ==>
+                       stream_take n$s1 << stream_take n$s2"
+by (drule mono_stream_take [of _ _ n],simp)
+*)
+
+lemma stream_take_lemma10 [rule_format]:
+  "ALL k<=n. stream_take n$s1 << stream_take n$s2
+                             --> stream_take k$s1 << stream_take k$s2"
+apply (induct_tac n,simp,clarsimp)
+apply (case_tac "k=Suc n",blast)
+apply (erule_tac x="k" in allE)
+by (drule mono_stream_take_pred,simp)
+
+lemma stream_take_le_mono : "k<=n ==> stream_take k$s1 << stream_take n$s1"
+apply (insert chain_stream_take [of s1])
+by (drule chain_mono,auto)
+
+lemma mono_stream_take: "s1 << s2 ==> stream_take n$s1 << stream_take n$s2"
+by (simp add: monofun_cfun_arg)
+
+(*
+lemma stream_take_prefix [simp]: "stream_take n$s << s"
+apply (subgoal_tac "s=(LUB n. stream_take n$s)")
+ apply (erule ssubst, rule is_ub_thelub)
+ apply (simp only: chain_stream_take)
+by (simp only: stream_reach2)
+*)
+
+lemma stream_take_take_less:"stream_take k$(stream_take n$s) << stream_take k$s"
+by (rule monofun_cfun_arg,auto)
+
+
+(* ------------------------------------------------------------------------- *)
+(* special induction rules                                                   *)
+(* ------------------------------------------------------------------------- *)
+
+
+section "induction"
+
+lemma stream_finite_ind:
+ "[| stream_finite x; P UU; !!a s. [| a ~= UU; P s |] ==> P (a && s) |] ==> P x"
+apply (simp add: stream.finite_def,auto)
+apply (erule subst)
+by (drule stream.finite_induct [of P _ x], auto)
+
+lemma stream_finite_ind2:
+"[| P UU; !! x. x ~= UU ==> P (x && UU); !! y z s. [| y ~= UU; z ~= UU; P s |] ==> P (y && z && s )|] ==>
+                                 !s. P (stream_take n$s)"
+apply (rule nat_less_induct [of _ n],auto)
+apply (case_tac n, auto) 
+apply (case_tac nat, auto) 
+apply (case_tac "s=UU",clarsimp)
+apply (drule stream_exhaust_eq [THEN iffD1],clarsimp)
+apply (case_tac "s=UU",clarsimp)
+apply (drule stream_exhaust_eq [THEN iffD1],clarsimp)
+apply (case_tac "y=UU",clarsimp)
+by (drule stream_exhaust_eq [THEN iffD1],clarsimp)
+
+lemma stream_ind2:
+"[| adm P; P UU; !!a. a ~= UU ==> P (a && UU); !!a b s. [| a ~= UU; b ~= UU; P s |] ==> P (a && b && s) |] ==> P x"
+apply (insert stream.reach [of x],erule subst)
+apply (erule admD, rule chain_stream_take)
+apply (insert stream_finite_ind2 [of P])
+by simp
+
+
+
+(* ----------------------------------------------------------------------- *)
+(* simplify use of coinduction                                             *)
+(* ----------------------------------------------------------------------- *)
+
+
+section "coinduction"
+
+lemma stream_coind_lemma2: "!s1 s2. R s1 s2 --> ft$s1 = ft$s2 &  R (rt$s1) (rt$s2) ==> stream_bisim R"
+ apply (simp add: stream.bisim_def,clarsimp)
+ apply (drule spec, drule spec, drule (1) mp)
+ apply (case_tac "x", simp)
+ apply (case_tac "y", simp)
+by auto
+
+
+
+(* ----------------------------------------------------------------------- *)
+(* theorems about stream_finite                                            *)
+(* ----------------------------------------------------------------------- *)
+
+
+section "stream_finite"
+
+lemma stream_finite_UU [simp]: "stream_finite UU"
+by (simp add: stream.finite_def)
+
+lemma stream_finite_UU_rev: "~  stream_finite s ==> s ~= UU"
+by (auto simp add: stream.finite_def)
+
+lemma stream_finite_lemma1: "stream_finite xs ==> stream_finite (x && xs)"
+apply (simp add: stream.finite_def,auto)
+apply (rule_tac x="Suc n" in exI)
+by (simp add: stream_take_lemma4)
+
+lemma stream_finite_lemma2: "[| x ~= UU; stream_finite (x && xs) |] ==> stream_finite xs"
+apply (simp add: stream.finite_def, auto)
+apply (rule_tac x="n" in exI)
+by (erule stream_take_lemma3,simp)
+
+lemma stream_finite_rt_eq: "stream_finite (rt$s) = stream_finite s"
+apply (cases s, auto)
+apply (rule stream_finite_lemma1, simp)
+by (rule stream_finite_lemma2,simp)
+
+lemma stream_finite_less: "stream_finite s ==> !t. t<<s --> stream_finite t"
+apply (erule stream_finite_ind [of s], auto)
+apply (case_tac "t=UU", auto)
+apply (drule stream_exhaust_eq [THEN iffD1],auto)
+apply (erule_tac x="y" in allE, simp)
+by (rule stream_finite_lemma1, simp)
+
+lemma stream_take_finite [simp]: "stream_finite (stream_take n$s)"
+apply (simp add: stream.finite_def)
+by (rule_tac x="n" in exI,simp)
+
+lemma adm_not_stream_finite: "adm (%x. ~ stream_finite x)"
+apply (rule adm_upward)
+apply (erule contrapos_nn)
+apply (erule (1) stream_finite_less [rule_format])
+done
+
+
+
+(* ----------------------------------------------------------------------- *)
+(* theorems about stream length                                            *)
+(* ----------------------------------------------------------------------- *)
+
+
+section "slen"
+
+lemma slen_empty [simp]: "#\<bottom> = 0"
+by (simp add: slen_def stream.finite_def zero_inat_def Least_equality)
+
+lemma slen_scons [simp]: "x ~= \<bottom> ==> #(x&&xs) = iSuc (#xs)"
+apply (case_tac "stream_finite (x && xs)")
+apply (simp add: slen_def, auto)
+apply (simp add: stream.finite_def, auto simp add: iSuc_Fin)
+apply (rule Least_Suc2, auto)
+(*apply (drule sym)*)
+(*apply (drule sym scons_eq_UU [THEN iffD1],simp)*)
+apply (erule stream_finite_lemma2, simp)
+apply (simp add: slen_def, auto)
+by (drule stream_finite_lemma1,auto)
+
+lemma slen_less_1_eq: "(#x < Fin (Suc 0)) = (x = \<bottom>)"
+by (cases x, auto simp add: Fin_0 iSuc_Fin[THEN sym])
+
+lemma slen_empty_eq: "(#x = 0) = (x = \<bottom>)"
+by (cases x, auto)
+
+lemma slen_scons_eq: "(Fin (Suc n) < #x) = (? a y. x = a && y &  a ~= \<bottom> &  Fin n < #y)"
+apply (auto, case_tac "x=UU",auto)
+apply (drule stream_exhaust_eq [THEN iffD1], auto)
+apply (case_tac "#y") apply simp_all
+apply (case_tac "#y") apply simp_all
+done
+
+lemma slen_iSuc: "#x = iSuc n --> (? a y. x = a&&y &  a ~= \<bottom> &  #y = n)"
+by (cases x, auto)
+
+lemma slen_stream_take_finite [simp]: "#(stream_take n$s) ~= \<infinity>"
+by (simp add: slen_def)
+
+lemma slen_scons_eq_rev: "(#x < Fin (Suc (Suc n))) = (!a y. x ~= a && y |  a = \<bottom> |  #y < Fin (Suc n))"
+ apply (cases x, auto)
+   apply (simp add: zero_inat_def)
+  apply (case_tac "#stream") apply (simp_all add: iSuc_Fin)
+ apply (case_tac "#stream") apply (simp_all add: iSuc_Fin)
+done
+
+lemma slen_take_lemma4 [rule_format]:
+  "!s. stream_take n$s ~= s --> #(stream_take n$s) = Fin n"
+apply (induct n, auto simp add: Fin_0)
+apply (case_tac "s=UU", simp)
+by (drule stream_exhaust_eq [THEN iffD1], auto simp add: iSuc_Fin)
+
+(*
+lemma stream_take_idempotent [simp]:
+ "stream_take n$(stream_take n$s) = stream_take n$s"
+apply (case_tac "stream_take n$s = s")
+apply (auto,insert slen_take_lemma4 [of n s]);
+by (auto,insert slen_take_lemma1 [of "stream_take n$s" n],simp)
+
+lemma stream_take_take_Suc [simp]: "stream_take n$(stream_take (Suc n)$s) =
+                                    stream_take n$s"
+apply (simp add: po_eq_conv,auto)
+ apply (simp add: stream_take_take_less)
+apply (subgoal_tac "stream_take n$s = stream_take n$(stream_take n$s)")
+ apply (erule ssubst)
+ apply (rule_tac monofun_cfun_arg)
+ apply (insert chain_stream_take [of s])
+by (simp add: chain_def,simp)
+*)
+
+lemma slen_take_eq: "ALL x. (Fin n < #x) = (stream_take n\<cdot>x ~= x)"
+apply (induct_tac n, auto)
+apply (simp add: Fin_0, clarsimp)
+apply (drule not_sym)
+apply (drule slen_empty_eq [THEN iffD1], simp)
+apply (case_tac "x=UU", simp)
+apply (drule stream_exhaust_eq [THEN iffD1], clarsimp)
+apply (erule_tac x="y" in allE, auto)
+apply (simp_all add: not_less iSuc_Fin)
+apply (case_tac "#y") apply simp_all
+apply (case_tac "x=UU", simp)
+apply (drule stream_exhaust_eq [THEN iffD1], clarsimp)
+apply (erule_tac x="y" in allE, simp)
+apply (case_tac "#y") by simp_all
+
+lemma slen_take_eq_rev: "(#x <= Fin n) = (stream_take n\<cdot>x = x)"
+by (simp add: linorder_not_less [symmetric] slen_take_eq)
+
+lemma slen_take_lemma1: "#x = Fin n ==> stream_take n\<cdot>x = x"
+by (rule slen_take_eq_rev [THEN iffD1], auto)
+
+lemma slen_rt_mono: "#s2 <= #s1 ==> #(rt$s2) <= #(rt$s1)"
+apply (cases s1)
+ by (cases s2, simp+)+
+
+lemma slen_take_lemma5: "#(stream_take n$s) <= Fin n"
+apply (case_tac "stream_take n$s = s")
+ apply (simp add: slen_take_eq_rev)
+by (simp add: slen_take_lemma4)
+
+lemma slen_take_lemma2: "!x. ~stream_finite x --> #(stream_take i\<cdot>x) = Fin i"
+apply (simp add: stream.finite_def, auto)
+by (simp add: slen_take_lemma4)
+
+lemma slen_infinite: "stream_finite x = (#x ~= Infty)"
+by (simp add: slen_def)
+
+lemma slen_mono_lemma: "stream_finite s ==> ALL t. s << t --> #s <= #t"
+apply (erule stream_finite_ind [of s], auto)
+apply (case_tac "t=UU", auto)
+apply (drule stream_exhaust_eq [THEN iffD1], auto)
+done
+
+lemma slen_mono: "s << t ==> #s <= #t"
+apply (case_tac "stream_finite t")
+apply (frule stream_finite_less)
+apply (erule_tac x="s" in allE, simp)
+apply (drule slen_mono_lemma, auto)
+by (simp add: slen_def)
+
+lemma iterate_lemma: "F$(iterate n$F$x) = iterate n$F$(F$x)"
+by (insert iterate_Suc2 [of n F x], auto)
+
+lemma slen_rt_mult [rule_format]: "!x. Fin (i + j) <= #x --> Fin j <= #(iterate i$rt$x)"
+apply (induct i, auto)
+apply (case_tac "x=UU", auto simp add: zero_inat_def)
+apply (drule stream_exhaust_eq [THEN iffD1], auto)
+apply (erule_tac x="y" in allE, auto)
+apply (simp add: not_le) apply (case_tac "#y") apply (simp_all add: iSuc_Fin)
+by (simp add: iterate_lemma)
+
+lemma slen_take_lemma3 [rule_format]:
+  "!(x::'a::flat stream) y. Fin n <= #x --> x << y --> stream_take n\<cdot>x = stream_take n\<cdot>y"
+apply (induct_tac n, auto)
+apply (case_tac "x=UU", auto)
+apply (simp add: zero_inat_def)
+apply (simp add: Suc_ile_eq)
+apply (case_tac "y=UU", clarsimp)
+apply (drule stream_exhaust_eq [THEN iffD1], clarsimp)+
+apply (erule_tac x="ya" in allE, simp)
+by (drule ax_flat, simp)
+
+lemma slen_strict_mono_lemma:
+  "stream_finite t ==> !s. #(s::'a::flat stream) = #t &  s << t --> s = t"
+apply (erule stream_finite_ind, auto)
+apply (case_tac "sa=UU", auto)
+apply (drule stream_exhaust_eq [THEN iffD1], clarsimp)
+by (drule ax_flat, simp)
+
+lemma slen_strict_mono: "[|stream_finite t; s ~= t; s << (t::'a::flat stream) |] ==> #s < #t"
+by (auto simp add: slen_mono less_le dest: slen_strict_mono_lemma)
+
+lemma stream_take_Suc_neq: "stream_take (Suc n)$s ~=s ==>
+                     stream_take n$s ~= stream_take (Suc n)$s"
+apply auto
+apply (subgoal_tac "stream_take n$s ~=s")
+ apply (insert slen_take_lemma4 [of n s],auto)
+apply (cases s, simp)
+by (simp add: slen_take_lemma4 iSuc_Fin)
+
+(* ----------------------------------------------------------------------- *)
+(* theorems about smap                                                     *)
+(* ----------------------------------------------------------------------- *)
+
+
+section "smap"
+
+lemma smap_unfold: "smap = (\<Lambda> f t. case t of x&&xs \<Rightarrow> f$x && smap$f$xs)"
+by (insert smap_def [where 'a='a and 'b='b, THEN eq_reflection, THEN fix_eq2], auto)
+
+lemma smap_empty [simp]: "smap\<cdot>f\<cdot>\<bottom> = \<bottom>"
+by (subst smap_unfold, simp)
+
+lemma smap_scons [simp]: "x~=\<bottom> ==> smap\<cdot>f\<cdot>(x&&xs) = (f\<cdot>x)&&(smap\<cdot>f\<cdot>xs)"
+by (subst smap_unfold, force)
+
+
+
+(* ----------------------------------------------------------------------- *)
+(* theorems about sfilter                                                  *)
+(* ----------------------------------------------------------------------- *)
+
+section "sfilter"
+
+lemma sfilter_unfold:
+ "sfilter = (\<Lambda> p s. case s of x && xs \<Rightarrow>
+  If p\<cdot>x then x && sfilter\<cdot>p\<cdot>xs else sfilter\<cdot>p\<cdot>xs)"
+by (insert sfilter_def [where 'a='a, THEN eq_reflection, THEN fix_eq2], auto)
+
+lemma strict_sfilter: "sfilter\<cdot>\<bottom> = \<bottom>"
+apply (rule cfun_eqI)
+apply (subst sfilter_unfold, auto)
+apply (case_tac "x=UU", auto)
+by (drule stream_exhaust_eq [THEN iffD1], auto)
+
+lemma sfilter_empty [simp]: "sfilter\<cdot>f\<cdot>\<bottom> = \<bottom>"
+by (subst sfilter_unfold, force)
+
+lemma sfilter_scons [simp]:
+  "x ~= \<bottom> ==> sfilter\<cdot>f\<cdot>(x && xs) =
+                           If f\<cdot>x then x && sfilter\<cdot>f\<cdot>xs else sfilter\<cdot>f\<cdot>xs"
+by (subst sfilter_unfold, force)
+
+
+(* ----------------------------------------------------------------------- *)
+   section "i_rt"
+(* ----------------------------------------------------------------------- *)
+
+lemma i_rt_UU [simp]: "i_rt n UU = UU"
+  by (induct n) (simp_all add: i_rt_def)
+
+lemma i_rt_0 [simp]: "i_rt 0 s = s"
+by (simp add: i_rt_def)
+
+lemma i_rt_Suc [simp]: "a ~= UU ==> i_rt (Suc n) (a&&s) = i_rt n s"
+by (simp add: i_rt_def iterate_Suc2 del: iterate_Suc)
+
+lemma i_rt_Suc_forw: "i_rt (Suc n) s = i_rt n (rt$s)"
+by (simp only: i_rt_def iterate_Suc2)
+
+lemma i_rt_Suc_back:"i_rt (Suc n) s = rt$(i_rt n s)"
+by (simp only: i_rt_def,auto)
+
+lemma i_rt_mono: "x << s ==> i_rt n x  << i_rt n s"
+by (simp add: i_rt_def monofun_rt_mult)
+
+lemma i_rt_ij_lemma: "Fin (i + j) <= #x ==> Fin j <= #(i_rt i x)"
+by (simp add: i_rt_def slen_rt_mult)
+
+lemma slen_i_rt_mono: "#s2 <= #s1 ==> #(i_rt n s2) <= #(i_rt n s1)"
+apply (induct_tac n,auto)
+apply (simp add: i_rt_Suc_back)
+by (drule slen_rt_mono,simp)
+
+lemma i_rt_take_lemma1 [rule_format]: "ALL s. i_rt n (stream_take n$s) = UU"
+apply (induct_tac n)
+ apply (simp add: i_rt_Suc_back,auto)
+apply (case_tac "s=UU",auto)
+by (drule stream_exhaust_eq [THEN iffD1],auto)
+
+lemma i_rt_slen: "(i_rt n s = UU) = (stream_take n$s = s)"
+apply auto
+ apply (insert i_rt_ij_lemma [of n "Suc 0" s])
+ apply (subgoal_tac "#(i_rt n s)=0")
+  apply (case_tac "stream_take n$s = s",simp+)
+  apply (insert slen_take_eq [rule_format,of n s],simp)
+  apply (cases "#s") apply (simp_all add: zero_inat_def)
+  apply (simp add: slen_take_eq)
+  apply (cases "#s")
+  using i_rt_take_lemma1 [of n s]
+  apply (simp_all add: zero_inat_def)
+  done
+
+lemma i_rt_lemma_slen: "#s=Fin n ==> i_rt n s = UU"
+by (simp add: i_rt_slen slen_take_lemma1)
+
+lemma stream_finite_i_rt [simp]: "stream_finite (i_rt n s) = stream_finite s"
+apply (induct_tac n, auto)
+ apply (cases s, auto simp del: i_rt_Suc)
+by (simp add: i_rt_Suc_back stream_finite_rt_eq)+
+
+lemma take_i_rt_len_lemma: "ALL sl x j t. Fin sl = #x & n <= sl &
+                            #(stream_take n$x) = Fin t & #(i_rt n x)= Fin j
+                                              --> Fin (j + t) = #x"
+apply (induct n, auto)
+ apply (simp add: zero_inat_def)
+apply (case_tac "x=UU",auto)
+ apply (simp add: zero_inat_def)
+apply (drule stream_exhaust_eq [THEN iffD1],clarsimp)
+apply (subgoal_tac "EX k. Fin k = #y",clarify)
+ apply (erule_tac x="k" in allE)
+ apply (erule_tac x="y" in allE,auto)
+ apply (erule_tac x="THE p. Suc p = t" in allE,auto)
+   apply (simp add: iSuc_def split: inat.splits)
+  apply (simp add: iSuc_def split: inat.splits)
+  apply (simp only: the_equality)
+ apply (simp add: iSuc_def split: inat.splits)
+ apply force
+apply (simp add: iSuc_def split: inat.splits)
+done
+
+lemma take_i_rt_len:
+"[| Fin sl = #x; n <= sl; #(stream_take n$x) = Fin t; #(i_rt n x) = Fin j |] ==>
+    Fin (j + t) = #x"
+by (blast intro: take_i_rt_len_lemma [rule_format])
+
+
+(* ----------------------------------------------------------------------- *)
+   section "i_th"
+(* ----------------------------------------------------------------------- *)
+
+lemma i_th_i_rt_step:
+"[| i_th n s1 << i_th n s2; i_rt (Suc n) s1 << i_rt (Suc n) s2 |] ==>
+   i_rt n s1 << i_rt n s2"
+apply (simp add: i_th_def i_rt_Suc_back)
+apply (cases "i_rt n s1", simp)
+apply (cases "i_rt n s2", auto)
+done
+
+lemma i_th_stream_take_Suc [rule_format]:
+ "ALL s. i_th n (stream_take (Suc n)$s) = i_th n s"
+apply (induct_tac n,auto)
+ apply (simp add: i_th_def)
+ apply (case_tac "s=UU",auto)
+ apply (drule stream_exhaust_eq [THEN iffD1],auto)
+apply (case_tac "s=UU",simp add: i_th_def)
+apply (drule stream_exhaust_eq [THEN iffD1],auto)
+by (simp add: i_th_def i_rt_Suc_forw)
+
+lemma i_th_last: "i_th n s && UU = i_rt n (stream_take (Suc n)$s)"
+apply (insert surjectiv_scons [of "i_rt n (stream_take (Suc n)$s)"])
+apply (rule i_th_stream_take_Suc [THEN subst])
+apply (simp add: i_th_def  i_rt_Suc_back [symmetric])
+by (simp add: i_rt_take_lemma1)
+
+lemma i_th_last_eq:
+"i_th n s1 = i_th n s2 ==> i_rt n (stream_take (Suc n)$s1) = i_rt n (stream_take (Suc n)$s2)"
+apply (insert i_th_last [of n s1])
+apply (insert i_th_last [of n s2])
+by auto
+
+lemma i_th_prefix_lemma:
+"[| k <= n; stream_take (Suc n)$s1 << stream_take (Suc n)$s2 |] ==>
+    i_th k s1 << i_th k s2"
+apply (insert i_th_stream_take_Suc [of k s1, THEN sym])
+apply (insert i_th_stream_take_Suc [of k s2, THEN sym],auto)
+apply (simp add: i_th_def)
+apply (rule monofun_cfun, auto)
+apply (rule i_rt_mono)
+by (blast intro: stream_take_lemma10)
+
+lemma take_i_rt_prefix_lemma1:
+  "stream_take (Suc n)$s1 << stream_take (Suc n)$s2 ==>
+   i_rt (Suc n) s1 << i_rt (Suc n) s2 ==>
+   i_rt n s1 << i_rt n s2 & stream_take n$s1 << stream_take n$s2"
+apply auto
+ apply (insert i_th_prefix_lemma [of n n s1 s2])
+ apply (rule i_th_i_rt_step,auto)
+by (drule mono_stream_take_pred,simp)
+
+lemma take_i_rt_prefix_lemma:
+"[| stream_take n$s1 << stream_take n$s2; i_rt n s1 << i_rt n s2 |] ==> s1 << s2"
+apply (case_tac "n=0",simp)
+apply (auto)
+apply (subgoal_tac "stream_take 0$s1 << stream_take 0$s2 &
+                    i_rt 0 s1 << i_rt 0 s2")
+ defer 1
+ apply (rule zero_induct,blast)
+ apply (blast dest: take_i_rt_prefix_lemma1)
+by simp
+
+lemma streams_prefix_lemma: "(s1 << s2) =
+  (stream_take n$s1 << stream_take n$s2 & i_rt n s1 << i_rt n s2)"
+apply auto
+  apply (simp add: monofun_cfun_arg)
+ apply (simp add: i_rt_mono)
+by (erule take_i_rt_prefix_lemma,simp)
+
+lemma streams_prefix_lemma1:
+ "[| stream_take n$s1 = stream_take n$s2; i_rt n s1 = i_rt n s2 |] ==> s1 = s2"
+apply (simp add: po_eq_conv,auto)
+ apply (insert streams_prefix_lemma)
+ by blast+
+
+
+(* ----------------------------------------------------------------------- *)
+   section "sconc"
+(* ----------------------------------------------------------------------- *)
+
+lemma UU_sconc [simp]: " UU ooo s = s "
+by (simp add: sconc_def zero_inat_def)
+
+lemma scons_neq_UU: "a~=UU ==> a && s ~=UU"
+by auto
+
+lemma singleton_sconc [rule_format, simp]: "x~=UU --> (x && UU) ooo y = x && y"
+apply (simp add: sconc_def zero_inat_def iSuc_def split: inat.splits, auto)
+apply (rule someI2_ex,auto)
+ apply (rule_tac x="x && y" in exI,auto)
+apply (simp add: i_rt_Suc_forw)
+apply (case_tac "xa=UU",simp)
+by (drule stream_exhaust_eq [THEN iffD1],auto)
+
+lemma ex_sconc [rule_format]:
+  "ALL k y. #x = Fin k --> (EX w. stream_take k$w = x & i_rt k w = y)"
+apply (case_tac "#x")
+ apply (rule stream_finite_ind [of x],auto)
+  apply (simp add: stream.finite_def)
+  apply (drule slen_take_lemma1,blast)
+ apply (simp_all add: zero_inat_def iSuc_def split: inat.splits)
+apply (erule_tac x="y" in allE,auto)
+by (rule_tac x="a && w" in exI,auto)
+
+lemma rt_sconc1: "Fin n = #x ==> i_rt n (x ooo y) = y"
+apply (simp add: sconc_def split: inat.splits, arith?,auto)
+apply (rule someI2_ex,auto)
+by (drule ex_sconc,simp)
+
+lemma sconc_inj2: "\<lbrakk>Fin n = #x; x ooo y = x ooo z\<rbrakk> \<Longrightarrow> y = z"
+apply (frule_tac y=y in rt_sconc1)
+by (auto elim: rt_sconc1)
+
+lemma sconc_UU [simp]:"s ooo UU = s"
+apply (case_tac "#s")
+ apply (simp add: sconc_def)
+ apply (rule someI2_ex)
+  apply (rule_tac x="s" in exI)
+  apply auto
+   apply (drule slen_take_lemma1,auto)
+  apply (simp add: i_rt_lemma_slen)
+ apply (drule slen_take_lemma1,auto)
+ apply (simp add: i_rt_slen)
+by (simp add: sconc_def)
+
+lemma stream_take_sconc [simp]: "Fin n = #x ==> stream_take n$(x ooo y) = x"
+apply (simp add: sconc_def)
+apply (cases "#x")
+apply auto
+apply (rule someI2_ex, auto)
+by (drule ex_sconc,simp)
+
+lemma scons_sconc [rule_format,simp]: "a~=UU --> (a && x) ooo y = a && x ooo y"
+apply (cases "#x",auto)
+ apply (simp add: sconc_def iSuc_Fin)
+ apply (rule someI2_ex)
+  apply (drule ex_sconc, simp)
+ apply (rule someI2_ex, auto)
+  apply (simp add: i_rt_Suc_forw)
+  apply (rule_tac x="a && x" in exI, auto)
+ apply (case_tac "xa=UU",auto)
+ apply (drule stream_exhaust_eq [THEN iffD1],auto)
+ apply (drule streams_prefix_lemma1,simp+)
+by (simp add: sconc_def)
+
+lemma ft_sconc: "x ~= UU ==> ft$(x ooo y) = ft$x"
+by (cases x, auto)
+
+lemma sconc_assoc: "(x ooo y) ooo z = x ooo y ooo z"
+apply (case_tac "#x")
+ apply (rule stream_finite_ind [of x],auto simp del: scons_sconc)
+  apply (simp add: stream.finite_def del: scons_sconc)
+  apply (drule slen_take_lemma1,auto simp del: scons_sconc)
+ apply (case_tac "a = UU", auto)
+by (simp add: sconc_def)
+
+
+(* ----------------------------------------------------------------------- *)
+
+lemma cont_sconc_lemma1: "stream_finite x \<Longrightarrow> cont (\<lambda>y. x ooo y)"
+by (erule stream_finite_ind, simp_all)
+
+lemma cont_sconc_lemma2: "\<not> stream_finite x \<Longrightarrow> cont (\<lambda>y. x ooo y)"
+by (simp add: sconc_def slen_def)
+
+lemma cont_sconc: "cont (\<lambda>y. x ooo y)"
+apply (cases "stream_finite x")
+apply (erule cont_sconc_lemma1)
+apply (erule cont_sconc_lemma2)
+done
+
+lemma sconc_mono: "y << y' ==> x ooo y << x ooo y'"
+by (rule cont_sconc [THEN cont2mono, THEN monofunE])
+
+lemma sconc_mono1 [simp]: "x << x ooo y"
+by (rule sconc_mono [of UU, simplified])
+
+(* ----------------------------------------------------------------------- *)
+
+lemma empty_sconc [simp]: "(x ooo y = UU) = (x = UU & y = UU)"
+apply (case_tac "#x",auto)
+   apply (insert sconc_mono1 [of x y])
+   by auto
+
+(* ----------------------------------------------------------------------- *)
+
+lemma rt_sconc [rule_format, simp]: "s~=UU --> rt$(s ooo x) = rt$s ooo x"
+by (cases s, auto)
+
+lemma i_th_sconc_lemma [rule_format]:
+  "ALL x y. Fin n < #x --> i_th n (x ooo y) = i_th n x"
+apply (induct_tac n, auto)
+apply (simp add: Fin_0 i_th_def)
+apply (simp add: slen_empty_eq ft_sconc)
+apply (simp add: i_th_def)
+apply (case_tac "x=UU",auto)
+apply (drule stream_exhaust_eq [THEN iffD1], auto)
+apply (erule_tac x="ya" in allE)
+apply (case_tac "#ya") by simp_all
+
+
+
+(* ----------------------------------------------------------------------- *)
+
+lemma sconc_lemma [rule_format, simp]: "ALL s. stream_take n$s ooo i_rt n s = s"
+apply (induct_tac n,auto)
+apply (case_tac "s=UU",auto)
+by (drule stream_exhaust_eq [THEN iffD1],auto)
+
+(* ----------------------------------------------------------------------- *)
+   subsection "pointwise equality"
+(* ----------------------------------------------------------------------- *)
+
+lemma ex_last_stream_take_scons: "stream_take (Suc n)$s =
+                     stream_take n$s ooo i_rt n (stream_take (Suc n)$s)"
+by (insert sconc_lemma [of n "stream_take (Suc n)$s"],simp)
+
+lemma i_th_stream_take_eq:
+"!!n. ALL n. i_th n s1 = i_th n s2 ==> stream_take n$s1 = stream_take n$s2"
+apply (induct_tac n,auto)
+apply (subgoal_tac "stream_take (Suc na)$s1 =
+                    stream_take na$s1 ooo i_rt na (stream_take (Suc na)$s1)")
+ apply (subgoal_tac "i_rt na (stream_take (Suc na)$s1) =
+                    i_rt na (stream_take (Suc na)$s2)")
+  apply (subgoal_tac "stream_take (Suc na)$s2 =
+                    stream_take na$s2 ooo i_rt na (stream_take (Suc na)$s2)")
+   apply (insert ex_last_stream_take_scons,simp)
+  apply blast
+ apply (erule_tac x="na" in allE)
+ apply (insert i_th_last_eq [of _ s1 s2])
+by blast+
+
+lemma pointwise_eq_lemma[rule_format]: "ALL n. i_th n s1 = i_th n s2 ==> s1 = s2"
+by (insert i_th_stream_take_eq [THEN stream.take_lemma],blast)
+
+(* ----------------------------------------------------------------------- *)
+   subsection "finiteness"
+(* ----------------------------------------------------------------------- *)
+
+lemma slen_sconc_finite1:
+  "[| #(x ooo y) = Infty; Fin n = #x |] ==> #y = Infty"
+apply (case_tac "#y ~= Infty",auto)
+apply (drule_tac y=y in rt_sconc1)
+apply (insert stream_finite_i_rt [of n "x ooo y"])
+by (simp add: slen_infinite)
+
+lemma slen_sconc_infinite1: "#x=Infty ==> #(x ooo y) = Infty"
+by (simp add: sconc_def)
+
+lemma slen_sconc_infinite2: "#y=Infty ==> #(x ooo y) = Infty"
+apply (case_tac "#x")
+ apply (simp add: sconc_def)
+ apply (rule someI2_ex)
+  apply (drule ex_sconc,auto)
+ apply (erule contrapos_pp)
+ apply (insert stream_finite_i_rt)
+ apply (fastsimp simp add: slen_infinite,auto)
+by (simp add: sconc_def)
+
+lemma sconc_finite: "(#x~=Infty & #y~=Infty) = (#(x ooo y)~=Infty)"
+apply auto
+  apply (metis not_Infty_eq slen_sconc_finite1)
+ apply (metis not_Infty_eq slen_sconc_infinite1)
+apply (metis not_Infty_eq slen_sconc_infinite2)
+done
+
+(* ----------------------------------------------------------------------- *)
+
+lemma slen_sconc_mono3: "[| Fin n = #x; Fin k = #(x ooo y) |] ==> n <= k"
+apply (insert slen_mono [of "x" "x ooo y"])
+apply (cases "#x") apply simp_all
+apply (cases "#(x ooo y)") apply simp_all
+done
+
+(* ----------------------------------------------------------------------- *)
+   subsection "finite slen"
+(* ----------------------------------------------------------------------- *)
+
+lemma slen_sconc: "[| Fin n = #x; Fin m = #y |] ==> #(x ooo y) = Fin (n + m)"
+apply (case_tac "#(x ooo y)")
+ apply (frule_tac y=y in rt_sconc1)
+ apply (insert take_i_rt_len [of "THE j. Fin j = #(x ooo y)" "x ooo y" n n m],simp)
+ apply (insert slen_sconc_mono3 [of n x _ y],simp)
+by (insert sconc_finite [of x y],auto)
+
+(* ----------------------------------------------------------------------- *)
+   subsection "flat prefix"
+(* ----------------------------------------------------------------------- *)
+
+lemma sconc_prefix: "(s1::'a::flat stream) << s2 ==> EX t. s1 ooo t = s2"
+apply (case_tac "#s1")
+ apply (subgoal_tac "stream_take nat$s1 = stream_take nat$s2")
+  apply (rule_tac x="i_rt nat s2" in exI)
+  apply (simp add: sconc_def)
+  apply (rule someI2_ex)
+   apply (drule ex_sconc)
+   apply (simp,clarsimp,drule streams_prefix_lemma1)
+   apply (simp+,rule slen_take_lemma3 [of _ s1 s2])
+  apply (simp+,rule_tac x="UU" in exI)
+apply (insert slen_take_lemma3 [of _ s1 s2])
+by (rule stream.take_lemma,simp)
+
+(* ----------------------------------------------------------------------- *)
+   subsection "continuity"
+(* ----------------------------------------------------------------------- *)
+
+lemma chain_sconc: "chain S ==> chain (%i. (x ooo S i))"
+by (simp add: chain_def,auto simp add: sconc_mono)
+
+lemma chain_scons: "chain S ==> chain (%i. a && S i)"
+apply (simp add: chain_def,auto)
+by (rule monofun_cfun_arg,simp)
+
+lemma contlub_scons_lemma: "chain S ==> (LUB i. a && S i) = a && (LUB i. S i)"
+by (rule cont2contlubE [OF cont_Rep_cfun2, symmetric])
+
+lemma finite_lub_sconc: "chain Y ==> (stream_finite x) ==>
+                        (LUB i. x ooo Y i) = (x ooo (LUB i. Y i))"
+apply (rule stream_finite_ind [of x])
+ apply (auto)
+apply (subgoal_tac "(LUB i. a && (s ooo Y i)) = a && (LUB i. s ooo Y i)")
+ by (force,blast dest: contlub_scons_lemma chain_sconc)
+
+lemma contlub_sconc_lemma:
+  "chain Y ==> (LUB i. x ooo Y i) = (x ooo (LUB i. Y i))"
+apply (case_tac "#x=Infty")
+ apply (simp add: sconc_def)
+apply (drule finite_lub_sconc,auto simp add: slen_infinite)
+done
+
+lemma monofun_sconc: "monofun (%y. x ooo y)"
+by (simp add: monofun_def sconc_mono)
+
+
+(* ----------------------------------------------------------------------- *)
+   section "constr_sconc"
+(* ----------------------------------------------------------------------- *)
+
+lemma constr_sconc_UUs [simp]: "constr_sconc UU s = s"
+by (simp add: constr_sconc_def zero_inat_def)
+
+lemma "x ooo y = constr_sconc x y"
+apply (case_tac "#x")
+ apply (rule stream_finite_ind [of x],auto simp del: scons_sconc)
+  defer 1
+  apply (simp add: constr_sconc_def del: scons_sconc)
+  apply (case_tac "#s")
+   apply (simp add: iSuc_Fin)
+   apply (case_tac "a=UU",auto simp del: scons_sconc)
+   apply (simp)
+  apply (simp add: sconc_def)
+ apply (simp add: constr_sconc_def)
+apply (simp add: stream.finite_def)
+by (drule slen_take_lemma1,auto)
+
+end

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/HOLCF/Library/Sum_Cpo.thy	Sat Nov 27 16:08:10 2010 -0800
@@ -0,0 +1,292 @@
+(*  Title:      HOLCF/Sum_Cpo.thy
+    Author:     Brian Huffman
+*)
+
+header {* The cpo of disjoint sums *}
+
+theory Sum_Cpo
+imports HOLCF
+begin
+
+subsection {* Ordering on sum type *}
+
+instantiation sum :: (below, below) below
+begin
+
+definition below_sum_def:
+  "x \<sqsubseteq> y \<equiv> case x of
+         Inl a \<Rightarrow> (case y of Inl b \<Rightarrow> a \<sqsubseteq> b | Inr b \<Rightarrow> False) |
+         Inr a \<Rightarrow> (case y of Inl b \<Rightarrow> False | Inr b \<Rightarrow> a \<sqsubseteq> b)"
+
+instance ..
+end
+
+lemma Inl_below_Inl [simp]: "Inl x \<sqsubseteq> Inl y \<longleftrightarrow> x \<sqsubseteq> y"
+unfolding below_sum_def by simp
+
+lemma Inr_below_Inr [simp]: "Inr x \<sqsubseteq> Inr y \<longleftrightarrow> x \<sqsubseteq> y"
+unfolding below_sum_def by simp
+
+lemma Inl_below_Inr [simp]: "\<not> Inl x \<sqsubseteq> Inr y"
+unfolding below_sum_def by simp
+
+lemma Inr_below_Inl [simp]: "\<not> Inr x \<sqsubseteq> Inl y"
+unfolding below_sum_def by simp
+
+lemma Inl_mono: "x \<sqsubseteq> y \<Longrightarrow> Inl x \<sqsubseteq> Inl y"
+by simp
+
+lemma Inr_mono: "x \<sqsubseteq> y \<Longrightarrow> Inr x \<sqsubseteq> Inr y"
+by simp
+
+lemma Inl_belowE: "\<lbrakk>Inl a \<sqsubseteq> x; \<And>b. \<lbrakk>x = Inl b; a \<sqsubseteq> b\<rbrakk> \<Longrightarrow> R\<rbrakk> \<Longrightarrow> R"
+by (cases x, simp_all)
+
+lemma Inr_belowE: "\<lbrakk>Inr a \<sqsubseteq> x; \<And>b. \<lbrakk>x = Inr b; a \<sqsubseteq> b\<rbrakk> \<Longrightarrow> R\<rbrakk> \<Longrightarrow> R"
+by (cases x, simp_all)
+
+lemmas sum_below_elims = Inl_belowE Inr_belowE
+
+lemma sum_below_cases:
+  "\<lbrakk>x \<sqsubseteq> y;
+    \<And>a b. \<lbrakk>x = Inl a; y = Inl b; a \<sqsubseteq> b\<rbrakk> \<Longrightarrow> R;
+    \<And>a b. \<lbrakk>x = Inr a; y = Inr b; a \<sqsubseteq> b\<rbrakk> \<Longrightarrow> R\<rbrakk>
+      \<Longrightarrow> R"
+by (cases x, safe elim!: sum_below_elims, auto)
+
+subsection {* Sum type is a complete partial order *}
+
+instance sum :: (po, po) po
+proof
+  fix x :: "'a + 'b"
+  show "x \<sqsubseteq> x"
+    by (induct x, simp_all)
+next
+  fix x y :: "'a + 'b"
+  assume "x \<sqsubseteq> y" and "y \<sqsubseteq> x" thus "x = y"
+    by (induct x, auto elim!: sum_below_elims intro: below_antisym)
+next
+  fix x y z :: "'a + 'b"
+  assume "x \<sqsubseteq> y" and "y \<sqsubseteq> z" thus "x \<sqsubseteq> z"
+    by (induct x, auto elim!: sum_below_elims intro: below_trans)
+qed
+
+lemma monofun_inv_Inl: "monofun (\<lambda>p. THE a. p = Inl a)"
+by (rule monofunI, erule sum_below_cases, simp_all)
+
+lemma monofun_inv_Inr: "monofun (\<lambda>p. THE b. p = Inr b)"
+by (rule monofunI, erule sum_below_cases, simp_all)
+
+lemma sum_chain_cases:
+  assumes Y: "chain Y"
+  assumes A: "\<And>A. \<lbrakk>chain A; Y = (\<lambda>i. Inl (A i))\<rbrakk> \<Longrightarrow> R"
+  assumes B: "\<And>B. \<lbrakk>chain B; Y = (\<lambda>i. Inr (B i))\<rbrakk> \<Longrightarrow> R"
+  shows "R"
+ apply (cases "Y 0")
+  apply (rule A)
+   apply (rule ch2ch_monofun [OF monofun_inv_Inl Y])
+  apply (rule ext)
+  apply (cut_tac j=i in chain_mono [OF Y le0], simp)
+  apply (erule Inl_belowE, simp)
+ apply (rule B)
+  apply (rule ch2ch_monofun [OF monofun_inv_Inr Y])
+ apply (rule ext)
+ apply (cut_tac j=i in chain_mono [OF Y le0], simp)
+ apply (erule Inr_belowE, simp)
+done
+
+lemma is_lub_Inl: "range S <<| x \<Longrightarrow> range (\<lambda>i. Inl (S i)) <<| Inl x"
+ apply (rule is_lubI)
+  apply (rule ub_rangeI)
+  apply (simp add: is_lub_rangeD1)
+ apply (frule ub_rangeD [where i=arbitrary])
+ apply (erule Inl_belowE, simp)
+ apply (erule is_lubD2)
+ apply (rule ub_rangeI)
+ apply (drule ub_rangeD, simp)
+done
+
+lemma is_lub_Inr: "range S <<| x \<Longrightarrow> range (\<lambda>i. Inr (S i)) <<| Inr x"
+ apply (rule is_lubI)
+  apply (rule ub_rangeI)
+  apply (simp add: is_lub_rangeD1)
+ apply (frule ub_rangeD [where i=arbitrary])
+ apply (erule Inr_belowE, simp)
+ apply (erule is_lubD2)
+ apply (rule ub_rangeI)
+ apply (drule ub_rangeD, simp)
+done
+
+instance sum :: (cpo, cpo) cpo
+ apply intro_classes
+ apply (erule sum_chain_cases, safe)
+  apply (rule exI)
+  apply (rule is_lub_Inl)
+  apply (erule cpo_lubI)
+ apply (rule exI)
+ apply (rule is_lub_Inr)
+ apply (erule cpo_lubI)
+done
+
+subsection {* Continuity of \emph{Inl}, \emph{Inr}, and case function *}
+
+lemma cont_Inl: "cont Inl"
+by (intro contI is_lub_Inl cpo_lubI)
+
+lemma cont_Inr: "cont Inr"
+by (intro contI is_lub_Inr cpo_lubI)
+
+lemmas cont2cont_Inl [simp, cont2cont] = cont_compose [OF cont_Inl]
+lemmas cont2cont_Inr [simp, cont2cont] = cont_compose [OF cont_Inr]
+
+lemmas ch2ch_Inl [simp] = ch2ch_cont [OF cont_Inl]
+lemmas ch2ch_Inr [simp] = ch2ch_cont [OF cont_Inr]
+
+lemmas lub_Inl = cont2contlubE [OF cont_Inl, symmetric]
+lemmas lub_Inr = cont2contlubE [OF cont_Inr, symmetric]
+
+lemma cont_sum_case1:
+  assumes f: "\<And>a. cont (\<lambda>x. f x a)"
+  assumes g: "\<And>b. cont (\<lambda>x. g x b)"
+  shows "cont (\<lambda>x. case y of Inl a \<Rightarrow> f x a | Inr b \<Rightarrow> g x b)"
+by (induct y, simp add: f, simp add: g)
+
+lemma cont_sum_case2: "\<lbrakk>cont f; cont g\<rbrakk> \<Longrightarrow> cont (sum_case f g)"
+apply (rule contI)
+apply (erule sum_chain_cases)
+apply (simp add: cont2contlubE [OF cont_Inl, symmetric] contE)
+apply (simp add: cont2contlubE [OF cont_Inr, symmetric] contE)
+done
+
+lemma cont2cont_sum_case:
+  assumes f1: "\<And>a. cont (\<lambda>x. f x a)" and f2: "\<And>x. cont (\<lambda>a. f x a)"
+  assumes g1: "\<And>b. cont (\<lambda>x. g x b)" and g2: "\<And>x. cont (\<lambda>b. g x b)"
+  assumes h: "cont (\<lambda>x. h x)"
+  shows "cont (\<lambda>x. case h x of Inl a \<Rightarrow> f x a | Inr b \<Rightarrow> g x b)"
+apply (rule cont_apply [OF h])
+apply (rule cont_sum_case2 [OF f2 g2])
+apply (rule cont_sum_case1 [OF f1 g1])
+done
+
+lemma cont2cont_sum_case' [simp, cont2cont]:
+  assumes f: "cont (\<lambda>p. f (fst p) (snd p))"
+  assumes g: "cont (\<lambda>p. g (fst p) (snd p))"
+  assumes h: "cont (\<lambda>x. h x)"
+  shows "cont (\<lambda>x. case h x of Inl a \<Rightarrow> f x a | Inr b \<Rightarrow> g x b)"
+using assms by (simp add: cont2cont_sum_case prod_cont_iff)
+
+subsection {* Compactness and chain-finiteness *}
+
+lemma compact_Inl: "compact a \<Longrightarrow> compact (Inl a)"
+apply (rule compactI2)
+apply (erule sum_chain_cases, safe)
+apply (simp add: lub_Inl)
+apply (erule (2) compactD2)
+apply (simp add: lub_Inr)
+done
+
+lemma compact_Inr: "compact a \<Longrightarrow> compact (Inr a)"
+apply (rule compactI2)
+apply (erule sum_chain_cases, safe)
+apply (simp add: lub_Inl)
+apply (simp add: lub_Inr)
+apply (erule (2) compactD2)
+done
+
+lemma compact_Inl_rev: "compact (Inl a) \<Longrightarrow> compact a"
+unfolding compact_def
+by (drule adm_subst [OF cont_Inl], simp)
+
+lemma compact_Inr_rev: "compact (Inr a) \<Longrightarrow> compact a"
+unfolding compact_def
+by (drule adm_subst [OF cont_Inr], simp)
+
+lemma compact_Inl_iff [simp]: "compact (Inl a) = compact a"
+by (safe elim!: compact_Inl compact_Inl_rev)
+
+lemma compact_Inr_iff [simp]: "compact (Inr a) = compact a"
+by (safe elim!: compact_Inr compact_Inr_rev)
+
+instance sum :: (chfin, chfin) chfin
+apply intro_classes
+apply (erule compact_imp_max_in_chain)
+apply (case_tac "\<Squnion>i. Y i", simp_all)
+done
+
+instance sum :: (discrete_cpo, discrete_cpo) discrete_cpo
+by intro_classes (simp add: below_sum_def split: sum.split)
+
+subsection {* Using sum types with fixrec *}
+
+definition
+  "match_Inl = (\<Lambda> x k. case x of Inl a \<Rightarrow> k\<cdot>a | Inr b \<Rightarrow> Fixrec.fail)"
+
+definition
+  "match_Inr = (\<Lambda> x k. case x of Inl a \<Rightarrow> Fixrec.fail | Inr b \<Rightarrow> k\<cdot>b)"
+
+lemma match_Inl_simps [simp]:
+  "match_Inl\<cdot>(Inl a)\<cdot>k = k\<cdot>a"
+  "match_Inl\<cdot>(Inr b)\<cdot>k = Fixrec.fail"
+unfolding match_Inl_def by simp_all
+
+lemma match_Inr_simps [simp]:
+  "match_Inr\<cdot>(Inl a)\<cdot>k = Fixrec.fail"
+  "match_Inr\<cdot>(Inr b)\<cdot>k = k\<cdot>b"
+unfolding match_Inr_def by simp_all
+
+setup {*
+  Fixrec.add_matchers
+    [ (@{const_name Inl}, @{const_name match_Inl}),
+      (@{const_name Inr}, @{const_name match_Inr}) ]
+*}
+
+subsection {* Disjoint sum is a predomain *}
+
+definition
+  "encode_sum_u =
+    (\<Lambda>(up\<cdot>x). case x of Inl a \<Rightarrow> sinl\<cdot>(up\<cdot>a) | Inr b \<Rightarrow> sinr\<cdot>(up\<cdot>b))"
+
+definition
+  "decode_sum_u = sscase\<cdot>(\<Lambda>(up\<cdot>a). up\<cdot>(Inl a))\<cdot>(\<Lambda>(up\<cdot>b). up\<cdot>(Inr b))"
+
+lemma decode_encode_sum_u [simp]: "decode_sum_u\<cdot>(encode_sum_u\<cdot>x) = x"
+unfolding decode_sum_u_def encode_sum_u_def
+by (case_tac x, simp, rename_tac y, case_tac y, simp_all)
+
+lemma encode_decode_sum_u [simp]: "encode_sum_u\<cdot>(decode_sum_u\<cdot>x) = x"
+unfolding decode_sum_u_def encode_sum_u_def
+apply (case_tac x, simp)
+apply (rename_tac a, case_tac a, simp, simp)
+apply (rename_tac b, case_tac b, simp, simp)
+done
+
+instantiation sum :: (predomain, predomain) predomain
+begin
+
+definition
+  "liftemb = (udom_emb ssum_approx oo ssum_map\<cdot>emb\<cdot>emb) oo encode_sum_u"
+
+definition
+  "liftprj =
+    decode_sum_u oo (ssum_map\<cdot>prj\<cdot>prj oo udom_prj ssum_approx)"
+
+definition
+  "liftdefl (t::('a + 'b) itself) = ssum_defl\<cdot>DEFL('a u)\<cdot>DEFL('b u)"
+
+instance proof
+  show "ep_pair liftemb (liftprj :: udom \<rightarrow> ('a + 'b) u)"
+    unfolding liftemb_sum_def liftprj_sum_def
+    apply (rule ep_pair_comp)
+    apply (rule ep_pair.intro, simp, simp)
+    apply (rule ep_pair_comp)
+    apply (intro ep_pair_ssum_map ep_pair_emb_prj)
+    apply (rule ep_pair_udom [OF ssum_approx])
+    done
+  show "cast\<cdot>LIFTDEFL('a + 'b) = liftemb oo (liftprj :: udom \<rightarrow> ('a + 'b) u)"
+    unfolding liftemb_sum_def liftprj_sum_def liftdefl_sum_def
+    by (simp add: cast_ssum_defl cast_DEFL cfcomp1 ssum_map_map)
+qed
+
+end
+
+end

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/HOLCF/Lift.thy	Sat Nov 27 16:08:10 2010 -0800
@@ -0,0 +1,133 @@
+(*  Title:      HOLCF/Lift.thy
+    Author:     Olaf Mueller
+*)
+
+header {* Lifting types of class type to flat pcpo's *}
+
+theory Lift
+imports Discrete Up
+begin
+
+default_sort type
+
+pcpodef (open) 'a lift = "UNIV :: 'a discr u set"
+by simp_all
+
+lemmas inst_lift_pcpo = Abs_lift_strict [symmetric]
+
+definition
+  Def :: "'a \<Rightarrow> 'a lift" where
+  "Def x = Abs_lift (up\<cdot>(Discr x))"
+
+subsection {* Lift as a datatype *}
+
+lemma lift_induct: "\<lbrakk>P \<bottom>; \<And>x. P (Def x)\<rbrakk> \<Longrightarrow> P y"
+apply (induct y)
+apply (rule_tac p=y in upE)
+apply (simp add: Abs_lift_strict)
+apply (case_tac x)
+apply (simp add: Def_def)
+done
+
+rep_datatype "\<bottom>\<Colon>'a lift" Def
+  by (erule lift_induct) (simp_all add: Def_def Abs_lift_inject inst_lift_pcpo)
+
+lemmas lift_distinct1 = lift.distinct(1)
+lemmas lift_distinct2 = lift.distinct(2)
+lemmas Def_not_UU = lift.distinct(2)
+lemmas Def_inject = lift.inject
+
+
+text {* @{term UU} and @{term Def} *}
+
+lemma not_Undef_is_Def: "(x \<noteq> \<bottom>) = (\<exists>y. x = Def y)"
+  by (cases x) simp_all
+
+lemma lift_definedE: "\<lbrakk>x \<noteq> \<bottom>; \<And>a. x = Def a \<Longrightarrow> R\<rbrakk> \<Longrightarrow> R"
+  by (cases x) simp_all
+
+text {*
+  For @{term "x ~= UU"} in assumptions @{text defined} replaces @{text
+  x} by @{text "Def a"} in conclusion. *}
+
+method_setup defined = {*
+  Scan.succeed (fn ctxt => SIMPLE_METHOD'
+    (etac @{thm lift_definedE} THEN' asm_simp_tac (simpset_of ctxt)))
+*} ""
+
+lemma DefE: "Def x = \<bottom> \<Longrightarrow> R"
+  by simp
+
+lemma DefE2: "\<lbrakk>x = Def s; x = \<bottom>\<rbrakk> \<Longrightarrow> R"
+  by simp
+
+lemma Def_below_Def: "Def x \<sqsubseteq> Def y \<longleftrightarrow> x = y"
+by (simp add: below_lift_def Def_def Abs_lift_inverse)
+
+lemma Def_below_iff [simp]: "Def x \<sqsubseteq> y \<longleftrightarrow> Def x = y"
+by (induct y, simp, simp add: Def_below_Def)
+
+
+subsection {* Lift is flat *}
+
+instance lift :: (type) flat
+proof
+  fix x y :: "'a lift"
+  assume "x \<sqsubseteq> y" thus "x = \<bottom> \<or> x = y"
+    by (induct x) auto
+qed
+
+subsection {* Continuity of @{const lift_case} *}
+
+lemma lift_case_eq: "lift_case \<bottom> f x = fup\<cdot>(\<Lambda> y. f (undiscr y))\<cdot>(Rep_lift x)"
+apply (induct x, unfold lift.cases)
+apply (simp add: Rep_lift_strict)
+apply (simp add: Def_def Abs_lift_inverse)
+done
+
+lemma cont2cont_lift_case [simp]:
+  "\<lbrakk>\<And>y. cont (\<lambda>x. f x y); cont g\<rbrakk> \<Longrightarrow> cont (\<lambda>x. lift_case \<bottom> (f x) (g x))"
+unfolding lift_case_eq by (simp add: cont_Rep_lift [THEN cont_compose])
+
+subsection {* Further operations *}
+
+definition
+  flift1 :: "('a \<Rightarrow> 'b::pcpo) \<Rightarrow> ('a lift \<rightarrow> 'b)"  (binder "FLIFT " 10)  where
+  "flift1 = (\<lambda>f. (\<Lambda> x. lift_case \<bottom> f x))"
+
+translations
+  "\<Lambda>(XCONST Def x). t" => "CONST flift1 (\<lambda>x. t)"
+  "\<Lambda>(CONST Def x). FLIFT y. t" <= "FLIFT x y. t"
+  "\<Lambda>(CONST Def x). t" <= "FLIFT x. t"
+
+definition
+  flift2 :: "('a \<Rightarrow> 'b) \<Rightarrow> ('a lift \<rightarrow> 'b lift)" where
+  "flift2 f = (FLIFT x. Def (f x))"
+
+lemma flift1_Def [simp]: "flift1 f\<cdot>(Def x) = (f x)"
+by (simp add: flift1_def)
+
+lemma flift2_Def [simp]: "flift2 f\<cdot>(Def x) = Def (f x)"
+by (simp add: flift2_def)
+
+lemma flift1_strict [simp]: "flift1 f\<cdot>\<bottom> = \<bottom>"
+by (simp add: flift1_def)
+
+lemma flift2_strict [simp]: "flift2 f\<cdot>\<bottom> = \<bottom>"
+by (simp add: flift2_def)
+
+lemma flift2_defined [simp]: "x \<noteq> \<bottom> \<Longrightarrow> (flift2 f)\<cdot>x \<noteq> \<bottom>"
+by (erule lift_definedE, simp)
+
+lemma flift2_bottom_iff [simp]: "(flift2 f\<cdot>x = \<bottom>) = (x = \<bottom>)"
+by (cases x, simp_all)
+
+lemma FLIFT_mono:
+  "(\<And>x. f x \<sqsubseteq> g x) \<Longrightarrow> (FLIFT x. f x) \<sqsubseteq> (FLIFT x. g x)"
+by (rule cfun_belowI, case_tac x, simp_all)
+
+lemma cont2cont_flift1 [simp, cont2cont]:
+  "\<lbrakk>\<And>y. cont (\<lambda>x. f x y)\<rbrakk> \<Longrightarrow> cont (\<lambda>x. FLIFT y. f x y)"
+by (simp add: flift1_def cont2cont_LAM)
+
+end

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/HOLCF/LowerPD.thy	Sat Nov 27 16:08:10 2010 -0800
@@ -0,0 +1,534 @@
+(*  Title:      HOLCF/LowerPD.thy
+    Author:     Brian Huffman
+*)
+
+header {* Lower powerdomain *}
+
+theory LowerPD
+imports CompactBasis
+begin
+
+subsection {* Basis preorder *}
+
+definition
+  lower_le :: "'a pd_basis \<Rightarrow> 'a pd_basis \<Rightarrow> bool" (infix "\<le>\<flat>" 50) where
+  "lower_le = (\<lambda>u v. \<forall>x\<in>Rep_pd_basis u. \<exists>y\<in>Rep_pd_basis v. x \<sqsubseteq> y)"
+
+lemma lower_le_refl [simp]: "t \<le>\<flat> t"
+unfolding lower_le_def by fast
+
+lemma lower_le_trans: "\<lbrakk>t \<le>\<flat> u; u \<le>\<flat> v\<rbrakk> \<Longrightarrow> t \<le>\<flat> v"
+unfolding lower_le_def
+apply (rule ballI)
+apply (drule (1) bspec, erule bexE)
+apply (drule (1) bspec, erule bexE)
+apply (erule rev_bexI)
+apply (erule (1) below_trans)
+done
+
+interpretation lower_le: preorder lower_le
+by (rule preorder.intro, rule lower_le_refl, rule lower_le_trans)
+
+lemma lower_le_minimal [simp]: "PDUnit compact_bot \<le>\<flat> t"
+unfolding lower_le_def Rep_PDUnit
+by (simp, rule Rep_pd_basis_nonempty [folded ex_in_conv])
+
+lemma PDUnit_lower_mono: "x \<sqsubseteq> y \<Longrightarrow> PDUnit x \<le>\<flat> PDUnit y"
+unfolding lower_le_def Rep_PDUnit by fast
+
+lemma PDPlus_lower_mono: "\<lbrakk>s \<le>\<flat> t; u \<le>\<flat> v\<rbrakk> \<Longrightarrow> PDPlus s u \<le>\<flat> PDPlus t v"
+unfolding lower_le_def Rep_PDPlus by fast
+
+lemma PDPlus_lower_le: "t \<le>\<flat> PDPlus t u"
+unfolding lower_le_def Rep_PDPlus by fast
+
+lemma lower_le_PDUnit_PDUnit_iff [simp]:
+  "(PDUnit a \<le>\<flat> PDUnit b) = (a \<sqsubseteq> b)"
+unfolding lower_le_def Rep_PDUnit by fast
+
+lemma lower_le_PDUnit_PDPlus_iff:
+  "(PDUnit a \<le>\<flat> PDPlus t u) = (PDUnit a \<le>\<flat> t \<or> PDUnit a \<le>\<flat> u)"
+unfolding lower_le_def Rep_PDPlus Rep_PDUnit by fast
+
+lemma lower_le_PDPlus_iff: "(PDPlus t u \<le>\<flat> v) = (t \<le>\<flat> v \<and> u \<le>\<flat> v)"
+unfolding lower_le_def Rep_PDPlus by fast
+
+lemma lower_le_induct [induct set: lower_le]:
+  assumes le: "t \<le>\<flat> u"
+  assumes 1: "\<And>a b. a \<sqsubseteq> b \<Longrightarrow> P (PDUnit a) (PDUnit b)"
+  assumes 2: "\<And>t u a. P (PDUnit a) t \<Longrightarrow> P (PDUnit a) (PDPlus t u)"
+  assumes 3: "\<And>t u v. \<lbrakk>P t v; P u v\<rbrakk> \<Longrightarrow> P (PDPlus t u) v"
+  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_induct)
+apply (simp add: 1)
+apply (simp add: lower_le_PDUnit_PDPlus_iff)
+apply (simp add: 2)
+apply (subst PDPlus_commute)
+apply (simp add: 2)
+apply (simp add: lower_le_PDPlus_iff 3)
+done
+
+
+subsection {* Type definition *}
+
+typedef (open) 'a lower_pd =
+  "{S::'a pd_basis set. lower_le.ideal S}"
+by (fast intro: lower_le.ideal_principal)
+
+instantiation lower_pd :: ("domain") below
+begin
+
+definition
+  "x \<sqsubseteq> y \<longleftrightarrow> Rep_lower_pd x \<subseteq> Rep_lower_pd y"
+
+instance ..
+end
+
+instance lower_pd :: ("domain") po
+using type_definition_lower_pd below_lower_pd_def
+by (rule lower_le.typedef_ideal_po)
+
+instance lower_pd :: ("domain") cpo
+using type_definition_lower_pd below_lower_pd_def
+by (rule lower_le.typedef_ideal_cpo)
+
+definition
+  lower_principal :: "'a pd_basis \<Rightarrow> 'a lower_pd" where
+  "lower_principal t = Abs_lower_pd {u. u \<le>\<flat> t}"
+
+interpretation lower_pd:
+  ideal_completion lower_le lower_principal Rep_lower_pd
+using type_definition_lower_pd below_lower_pd_def
+using lower_principal_def pd_basis_countable
+by (rule lower_le.typedef_ideal_completion)
+
+text {* Lower powerdomain is pointed *}
+
+lemma lower_pd_minimal: "lower_principal (PDUnit compact_bot) \<sqsubseteq> ys"
+by (induct ys rule: lower_pd.principal_induct, simp, simp)
+
+instance lower_pd :: ("domain") pcpo
+by intro_classes (fast intro: lower_pd_minimal)
+
+lemma inst_lower_pd_pcpo: "\<bottom> = lower_principal (PDUnit compact_bot)"
+by (rule lower_pd_minimal [THEN UU_I, symmetric])
+
+
+subsection {* Monadic unit and plus *}
+
+definition
+  lower_unit :: "'a \<rightarrow> 'a lower_pd" where
+  "lower_unit = compact_basis.basis_fun (\<lambda>a. lower_principal (PDUnit a))"
+
+definition
+  lower_plus :: "'a lower_pd \<rightarrow> 'a lower_pd \<rightarrow> 'a lower_pd" where
+  "lower_plus = lower_pd.basis_fun (\<lambda>t. lower_pd.basis_fun (\<lambda>u.
+      lower_principal (PDPlus t u)))"
+
+abbreviation
+  lower_add :: "'a lower_pd \<Rightarrow> 'a lower_pd \<Rightarrow> 'a lower_pd"
+    (infixl "+\<flat>" 65) where
+  "xs +\<flat> ys == lower_plus\<cdot>xs\<cdot>ys"
+
+syntax
+  "_lower_pd" :: "args \<Rightarrow> 'a lower_pd" ("{_}\<flat>")
+
+translations
+  "{x,xs}\<flat>" == "{x}\<flat> +\<flat> {xs}\<flat>"
+  "{x}\<flat>" == "CONST lower_unit\<cdot>x"
+
+lemma lower_unit_Rep_compact_basis [simp]:
+  "{Rep_compact_basis a}\<flat> = lower_principal (PDUnit a)"
+unfolding lower_unit_def
+by (simp add: compact_basis.basis_fun_principal PDUnit_lower_mono)
+
+lemma lower_plus_principal [simp]:
+  "lower_principal t +\<flat> lower_principal u = lower_principal (PDPlus t u)"
+unfolding lower_plus_def
+by (simp add: lower_pd.basis_fun_principal
+    lower_pd.basis_fun_mono PDPlus_lower_mono)
+
+interpretation lower_add: semilattice lower_add proof
+  fix xs ys zs :: "'a lower_pd"
+  show "(xs +\<flat> ys) +\<flat> zs = xs +\<flat> (ys +\<flat> zs)"
+    apply (induct xs ys arbitrary: zs rule: lower_pd.principal_induct2, simp, simp)
+    apply (rule_tac x=zs in lower_pd.principal_induct, simp)
+    apply (simp add: PDPlus_assoc)
+    done
+  show "xs +\<flat> ys = ys +\<flat> xs"
+    apply (induct xs ys rule: lower_pd.principal_induct2, simp, simp)
+    apply (simp add: PDPlus_commute)
+    done
+  show "xs +\<flat> xs = xs"
+    apply (induct xs rule: lower_pd.principal_induct, simp)
+    apply (simp add: PDPlus_absorb)
+    done
+qed
+
+lemmas lower_plus_assoc = lower_add.assoc
+lemmas lower_plus_commute = lower_add.commute
+lemmas lower_plus_absorb = lower_add.idem
+lemmas lower_plus_left_commute = lower_add.left_commute
+lemmas lower_plus_left_absorb = lower_add.left_idem
+
+text {* Useful for @{text "simp add: lower_plus_ac"} *}
+lemmas lower_plus_ac =
+  lower_plus_assoc lower_plus_commute lower_plus_left_commute
+
+text {* Useful for @{text "simp only: lower_plus_aci"} *}
+lemmas lower_plus_aci =
+  lower_plus_ac lower_plus_absorb lower_plus_left_absorb
+
+lemma lower_plus_below1: "xs \<sqsubseteq> xs +\<flat> ys"
+apply (induct xs ys rule: lower_pd.principal_induct2, simp, simp)
+apply (simp add: PDPlus_lower_le)
+done
+
+lemma lower_plus_below2: "ys \<sqsubseteq> xs +\<flat> ys"
+by (subst lower_plus_commute, rule lower_plus_below1)
+
+lemma lower_plus_least: "\<lbrakk>xs \<sqsubseteq> zs; ys \<sqsubseteq> zs\<rbrakk> \<Longrightarrow> xs +\<flat> ys \<sqsubseteq> zs"
+apply (subst lower_plus_absorb [of zs, symmetric])
+apply (erule (1) monofun_cfun [OF monofun_cfun_arg])
+done
+
+lemma lower_plus_below_iff [simp]:
+  "xs +\<flat> ys \<sqsubseteq> zs \<longleftrightarrow> xs \<sqsubseteq> zs \<and> ys \<sqsubseteq> zs"
+apply safe
+apply (erule below_trans [OF lower_plus_below1])
+apply (erule below_trans [OF lower_plus_below2])
+apply (erule (1) lower_plus_least)
+done
+
+lemma lower_unit_below_plus_iff [simp]:
+  "{x}\<flat> \<sqsubseteq> ys +\<flat> zs \<longleftrightarrow> {x}\<flat> \<sqsubseteq> ys \<or> {x}\<flat> \<sqsubseteq> zs"
+apply (induct x rule: compact_basis.principal_induct, simp)
+apply (induct ys rule: lower_pd.principal_induct, simp)
+apply (induct zs rule: lower_pd.principal_induct, simp)
+apply (simp add: lower_le_PDUnit_PDPlus_iff)
+done
+
+lemma lower_unit_below_iff [simp]: "{x}\<flat> \<sqsubseteq> {y}\<flat> \<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
+
+lemmas lower_pd_below_simps =
+  lower_unit_below_iff
+  lower_plus_below_iff
+  lower_unit_below_plus_iff
+
+lemma lower_unit_eq_iff [simp]: "{x}\<flat> = {y}\<flat> \<longleftrightarrow> x = y"
+by (simp add: po_eq_conv)
+
+lemma lower_unit_strict [simp]: "{\<bottom>}\<flat> = \<bottom>"
+using lower_unit_Rep_compact_basis [of compact_bot]
+by (simp add: inst_lower_pd_pcpo)
+
+lemma lower_unit_bottom_iff [simp]: "{x}\<flat> = \<bottom> \<longleftrightarrow> x = \<bottom>"
+unfolding lower_unit_strict [symmetric] by (rule lower_unit_eq_iff)
+
+lemma lower_plus_bottom_iff [simp]:
+  "xs +\<flat> ys = \<bottom> \<longleftrightarrow> xs = \<bottom> \<and> ys = \<bottom>"
+apply safe
+apply (rule UU_I, erule subst, rule lower_plus_below1)
+apply (rule UU_I, erule subst, rule lower_plus_below2)
+apply (rule lower_plus_absorb)
+done
+
+lemma lower_plus_strict1 [simp]: "\<bottom> +\<flat> ys = ys"
+apply (rule below_antisym [OF _ lower_plus_below2])
+apply (simp add: lower_plus_least)
+done
+
+lemma lower_plus_strict2 [simp]: "xs +\<flat> \<bottom> = xs"
+apply (rule below_antisym [OF _ lower_plus_below1])
+apply (simp add: lower_plus_least)
+done
+
+lemma compact_lower_unit: "compact x \<Longrightarrow> compact {x}\<flat>"
+by (auto dest!: compact_basis.compact_imp_principal)
+
+lemma compact_lower_unit_iff [simp]: "compact {x}\<flat> \<longleftrightarrow> compact x"
+apply (safe elim!: compact_lower_unit)
+apply (simp only: compact_def lower_unit_below_iff [symmetric])
+apply (erule adm_subst [OF cont_Rep_cfun2])
+done
+
+lemma compact_lower_plus [simp]:
+  "\<lbrakk>compact xs; compact ys\<rbrakk> \<Longrightarrow> compact (xs +\<flat> ys)"
+by (auto dest!: lower_pd.compact_imp_principal)
+
+
+subsection {* Induction rules *}
+
+lemma lower_pd_induct1:
+  assumes P: "adm P"
+  assumes unit: "\<And>x. P {x}\<flat>"
+  assumes insert:
+    "\<And>x ys. \<lbrakk>P {x}\<flat>; P ys\<rbrakk> \<Longrightarrow> P ({x}\<flat> +\<flat> ys)"
+  shows "P (xs::'a lower_pd)"
+apply (induct xs rule: lower_pd.principal_induct, rule P)
+apply (induct_tac a rule: pd_basis_induct1)
+apply (simp only: lower_unit_Rep_compact_basis [symmetric])
+apply (rule unit)
+apply (simp only: lower_unit_Rep_compact_basis [symmetric]
+                  lower_plus_principal [symmetric])
+apply (erule insert [OF unit])
+done
+
+lemma lower_pd_induct
+  [case_names adm lower_unit lower_plus, induct type: lower_pd]:
+  assumes P: "adm P"
+  assumes unit: "\<And>x. P {x}\<flat>"
+  assumes plus: "\<And>xs ys. \<lbrakk>P xs; P ys\<rbrakk> \<Longrightarrow> P (xs +\<flat> ys)"
+  shows "P (xs::'a lower_pd)"
+apply (induct xs rule: lower_pd.principal_induct, rule P)
+apply (induct_tac a rule: pd_basis_induct)
+apply (simp only: lower_unit_Rep_compact_basis [symmetric] unit)
+apply (simp only: lower_plus_principal [symmetric] plus)
+done
+
+
+subsection {* Monadic bind *}
+
+definition
+  lower_bind_basis ::
+  "'a pd_basis \<Rightarrow> ('a \<rightarrow> 'b lower_pd) \<rightarrow> 'b lower_pd" where
+  "lower_bind_basis = fold_pd
+    (\<lambda>a. \<Lambda> f. f\<cdot>(Rep_compact_basis a))
+    (\<lambda>x y. \<Lambda> f. x\<cdot>f +\<flat> y\<cdot>f)"
+
+lemma ACI_lower_bind:
+  "class.ab_semigroup_idem_mult (\<lambda>x y. \<Lambda> f. x\<cdot>f +\<flat> y\<cdot>f)"
+apply unfold_locales
+apply (simp add: lower_plus_assoc)
+apply (simp add: lower_plus_commute)
+apply (simp add: eta_cfun)
+done
+
+lemma lower_bind_basis_simps [simp]:
+  "lower_bind_basis (PDUnit a) =
+    (\<Lambda> f. f\<cdot>(Rep_compact_basis a))"
+  "lower_bind_basis (PDPlus t u) =
+    (\<Lambda> f. lower_bind_basis t\<cdot>f +\<flat> lower_bind_basis u\<cdot>f)"
+unfolding lower_bind_basis_def
+apply -
+apply (rule fold_pd_PDUnit [OF ACI_lower_bind])
+apply (rule fold_pd_PDPlus [OF ACI_lower_bind])
+done
+
+lemma lower_bind_basis_mono:
+  "t \<le>\<flat> u \<Longrightarrow> lower_bind_basis t \<sqsubseteq> lower_bind_basis u"
+unfolding cfun_below_iff
+apply (erule lower_le_induct, safe)
+apply (simp add: monofun_cfun)
+apply (simp add: rev_below_trans [OF lower_plus_below1])
+apply simp
+done
+
+definition
+  lower_bind :: "'a lower_pd \<rightarrow> ('a \<rightarrow> 'b lower_pd) \<rightarrow> 'b lower_pd" where
+  "lower_bind = lower_pd.basis_fun lower_bind_basis"
+
+lemma lower_bind_principal [simp]:
+  "lower_bind\<cdot>(lower_principal t) = lower_bind_basis t"
+unfolding lower_bind_def
+apply (rule lower_pd.basis_fun_principal)
+apply (erule lower_bind_basis_mono)
+done
+
+lemma lower_bind_unit [simp]:
+  "lower_bind\<cdot>{x}\<flat>\<cdot>f = f\<cdot>x"
+by (induct x rule: compact_basis.principal_induct, simp, simp)
+
+lemma lower_bind_plus [simp]:
+  "lower_bind\<cdot>(xs +\<flat> ys)\<cdot>f = lower_bind\<cdot>xs\<cdot>f +\<flat> lower_bind\<cdot>ys\<cdot>f"
+by (induct xs ys rule: lower_pd.principal_induct2, simp, simp, simp)
+
+lemma lower_bind_strict [simp]: "lower_bind\<cdot>\<bottom>\<cdot>f = f\<cdot>\<bottom>"
+unfolding lower_unit_strict [symmetric] by (rule lower_bind_unit)
+
+lemma lower_bind_bind:
+  "lower_bind\<cdot>(lower_bind\<cdot>xs\<cdot>f)\<cdot>g = lower_bind\<cdot>xs\<cdot>(\<Lambda> x. lower_bind\<cdot>(f\<cdot>x)\<cdot>g)"
+by (induct xs, simp_all)
+
+
+subsection {* Map *}
+
+definition
+  lower_map :: "('a \<rightarrow> 'b) \<rightarrow> 'a lower_pd \<rightarrow> 'b lower_pd" where
+  "lower_map = (\<Lambda> f xs. lower_bind\<cdot>xs\<cdot>(\<Lambda> x. {f\<cdot>x}\<flat>))"
+
+lemma lower_map_unit [simp]:
+  "lower_map\<cdot>f\<cdot>{x}\<flat> = {f\<cdot>x}\<flat>"
+unfolding lower_map_def by simp
+
+lemma lower_map_plus [simp]:
+  "lower_map\<cdot>f\<cdot>(xs +\<flat> ys) = lower_map\<cdot>f\<cdot>xs +\<flat> lower_map\<cdot>f\<cdot>ys"
+unfolding lower_map_def by simp
+
+lemma lower_map_bottom [simp]: "lower_map\<cdot>f\<cdot>\<bottom> = {f\<cdot>\<bottom>}\<flat>"
+unfolding lower_map_def by simp
+
+lemma lower_map_ident: "lower_map\<cdot>(\<Lambda> x. x)\<cdot>xs = xs"
+by (induct xs rule: lower_pd_induct, simp_all)
+
+lemma lower_map_ID: "lower_map\<cdot>ID = ID"
+by (simp add: cfun_eq_iff ID_def lower_map_ident)
+
+lemma lower_map_map:
+  "lower_map\<cdot>f\<cdot>(lower_map\<cdot>g\<cdot>xs) = lower_map\<cdot>(\<Lambda> x. f\<cdot>(g\<cdot>x))\<cdot>xs"
+by (induct xs rule: lower_pd_induct, simp_all)
+
+lemma ep_pair_lower_map: "ep_pair e p \<Longrightarrow> ep_pair (lower_map\<cdot>e) (lower_map\<cdot>p)"
+apply default
+apply (induct_tac x rule: lower_pd_induct, simp_all add: ep_pair.e_inverse)
+apply (induct_tac y rule: lower_pd_induct)
+apply (simp_all add: ep_pair.e_p_below monofun_cfun del: lower_plus_below_iff)
+done
+
+lemma deflation_lower_map: "deflation d \<Longrightarrow> deflation (lower_map\<cdot>d)"
+apply default
+apply (induct_tac x rule: lower_pd_induct, simp_all add: deflation.idem)
+apply (induct_tac x rule: lower_pd_induct)
+apply (simp_all add: deflation.below monofun_cfun del: lower_plus_below_iff)
+done
+
+(* FIXME: long proof! *)
+lemma finite_deflation_lower_map:
+  assumes "finite_deflation d" shows "finite_deflation (lower_map\<cdot>d)"
+proof (rule finite_deflation_intro)
+  interpret d: finite_deflation d by fact
+  have "deflation d" by fact
+  thus "deflation (lower_map\<cdot>d)" by (rule deflation_lower_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 (lower_principal ` Rep_pd_basis -` (Pow (Rep_compact_basis -` range (\<lambda>x. d\<cdot>x))))" by simp
+  hence "finite (range (\<lambda>xs. lower_map\<cdot>d\<cdot>xs))"
+    apply (rule rev_finite_subset)
+    apply clarsimp
+    apply (induct_tac xs rule: lower_pd.principal_induct)
+    apply (simp add: adm_mem_finite *)
+    apply (rename_tac t, induct_tac t rule: pd_basis_induct)
+    apply (simp only: lower_unit_Rep_compact_basis [symmetric] lower_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: lower_plus_principal [symmetric] lower_map_plus)
+    apply clarsimp
+    apply (rule imageI)
+    apply (rule vimageI2)
+    apply (simp add: Rep_PDPlus)
+    done
+  thus "finite {xs. lower_map\<cdot>d\<cdot>xs = xs}"
+    by (rule finite_range_imp_finite_fixes)
+qed
+
+subsection {* Lower powerdomain is a domain *}
+
+definition
+  lower_approx :: "nat \<Rightarrow> udom lower_pd \<rightarrow> udom lower_pd"
+where
+  "lower_approx = (\<lambda>i. lower_map\<cdot>(udom_approx i))"
+
+lemma lower_approx: "approx_chain lower_approx"
+using lower_map_ID finite_deflation_lower_map
+unfolding lower_approx_def by (rule approx_chain_lemma1)
+
+definition lower_defl :: "defl \<rightarrow> defl"
+where "lower_defl = defl_fun1 lower_approx lower_map"
+
+lemma cast_lower_defl:
+  "cast\<cdot>(lower_defl\<cdot>A) =
+    udom_emb lower_approx oo lower_map\<cdot>(cast\<cdot>A) oo udom_prj lower_approx"
+using lower_approx finite_deflation_lower_map
+unfolding lower_defl_def by (rule cast_defl_fun1)
+
+instantiation lower_pd :: ("domain") liftdomain
+begin
+
+definition
+  "emb = udom_emb lower_approx oo lower_map\<cdot>emb"
+
+definition
+  "prj = lower_map\<cdot>prj oo udom_prj lower_approx"
+
+definition
+  "defl (t::'a lower_pd itself) = lower_defl\<cdot>DEFL('a)"
+
+definition
+  "(liftemb :: 'a lower_pd u \<rightarrow> udom) = udom_emb u_approx oo u_map\<cdot>emb"
+
+definition
+  "(liftprj :: udom \<rightarrow> 'a lower_pd u) = u_map\<cdot>prj oo udom_prj u_approx"
+
+definition
+  "liftdefl (t::'a lower_pd itself) = u_defl\<cdot>DEFL('a lower_pd)"
+
+instance
+using liftemb_lower_pd_def liftprj_lower_pd_def liftdefl_lower_pd_def
+proof (rule liftdomain_class_intro)
+  show "ep_pair emb (prj :: udom \<rightarrow> 'a lower_pd)"
+    unfolding emb_lower_pd_def prj_lower_pd_def
+    using ep_pair_udom [OF lower_approx]
+    by (intro ep_pair_comp ep_pair_lower_map ep_pair_emb_prj)
+next
+  show "cast\<cdot>DEFL('a lower_pd) = emb oo (prj :: udom \<rightarrow> 'a lower_pd)"
+    unfolding emb_lower_pd_def prj_lower_pd_def defl_lower_pd_def cast_lower_defl
+    by (simp add: cast_DEFL oo_def cfun_eq_iff lower_map_map)
+qed
+
+end
+
+lemma DEFL_lower: "DEFL('a lower_pd) = lower_defl\<cdot>DEFL('a)"
+by (rule defl_lower_pd_def)
+
+
+subsection {* Join *}
+
+definition
+  lower_join :: "'a lower_pd lower_pd \<rightarrow> 'a lower_pd" where
+  "lower_join = (\<Lambda> xss. lower_bind\<cdot>xss\<cdot>(\<Lambda> xs. xs))"
+
+lemma lower_join_unit [simp]:
+  "lower_join\<cdot>{xs}\<flat> = xs"
+unfolding lower_join_def by simp
+
+lemma lower_join_plus [simp]:
+  "lower_join\<cdot>(xss +\<flat> yss) = lower_join\<cdot>xss +\<flat> lower_join\<cdot>yss"
+unfolding lower_join_def by simp
+
+lemma lower_join_bottom [simp]: "lower_join\<cdot>\<bottom> = \<bottom>"
+unfolding lower_join_def by simp
+
+lemma lower_join_map_unit:
+  "lower_join\<cdot>(lower_map\<cdot>lower_unit\<cdot>xs) = xs"
+by (induct xs rule: lower_pd_induct, simp_all)
+
+lemma lower_join_map_join:
+  "lower_join\<cdot>(lower_map\<cdot>lower_join\<cdot>xsss) = lower_join\<cdot>(lower_join\<cdot>xsss)"
+by (induct xsss rule: lower_pd_induct, simp_all)
+
+lemma lower_join_map_map:
+  "lower_join\<cdot>(lower_map\<cdot>(lower_map\<cdot>f)\<cdot>xss) =
+   lower_map\<cdot>f\<cdot>(lower_join\<cdot>xss)"
+by (induct xss rule: lower_pd_induct, simp_all)
+
+end

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/HOLCF/Map_Functions.thy	Sat Nov 27 16:08:10 2010 -0800
@@ -0,0 +1,464 @@
+(*  Title:      HOLCF/Map_Functions.thy
+    Author:     Brian Huffman
+*)
+
+header {* Map functions for various types *}
+
+theory Map_Functions
+imports Deflation
+begin
+
+subsection {* Map operator for continuous function space *}
+
+default_sort cpo
+
+definition
+  cfun_map :: "('b \<rightarrow> 'a) \<rightarrow> ('c \<rightarrow> 'd) \<rightarrow> ('a \<rightarrow> 'c) \<rightarrow> ('b \<rightarrow> 'd)"
+where
+  "cfun_map = (\<Lambda> a b f x. b\<cdot>(f\<cdot>(a\<cdot>x)))"
+
+lemma cfun_map_beta [simp]: "cfun_map\<cdot>a\<cdot>b\<cdot>f\<cdot>x = b\<cdot>(f\<cdot>(a\<cdot>x))"
+unfolding cfun_map_def by simp
+
+lemma cfun_map_ID: "cfun_map\<cdot>ID\<cdot>ID = ID"
+unfolding cfun_eq_iff by simp
+
+lemma cfun_map_map:
+  "cfun_map\<cdot>f1\<cdot>g1\<cdot>(cfun_map\<cdot>f2\<cdot>g2\<cdot>p) =
+    cfun_map\<cdot>(\<Lambda> x. f2\<cdot>(f1\<cdot>x))\<cdot>(\<Lambda> x. g1\<cdot>(g2\<cdot>x))\<cdot>p"
+by (rule cfun_eqI) simp
+
+lemma ep_pair_cfun_map:
+  assumes "ep_pair e1 p1" and "ep_pair e2 p2"
+  shows "ep_pair (cfun_map\<cdot>p1\<cdot>e2) (cfun_map\<cdot>e1\<cdot>p2)"
+proof
+  interpret e1p1: ep_pair e1 p1 by fact
+  interpret e2p2: ep_pair e2 p2 by fact
+  fix f show "cfun_map\<cdot>e1\<cdot>p2\<cdot>(cfun_map\<cdot>p1\<cdot>e2\<cdot>f) = f"
+    by (simp add: cfun_eq_iff)
+  fix g show "cfun_map\<cdot>p1\<cdot>e2\<cdot>(cfun_map\<cdot>e1\<cdot>p2\<cdot>g) \<sqsubseteq> g"
+    apply (rule cfun_belowI, simp)
+    apply (rule below_trans [OF e2p2.e_p_below])
+    apply (rule monofun_cfun_arg)
+    apply (rule e1p1.e_p_below)
+    done
+qed
+
+lemma deflation_cfun_map:
+  assumes "deflation d1" and "deflation d2"
+  shows "deflation (cfun_map\<cdot>d1\<cdot>d2)"
+proof
+  interpret d1: deflation d1 by fact
+  interpret d2: deflation d2 by fact
+  fix f
+  show "cfun_map\<cdot>d1\<cdot>d2\<cdot>(cfun_map\<cdot>d1\<cdot>d2\<cdot>f) = cfun_map\<cdot>d1\<cdot>d2\<cdot>f"
+    by (simp add: cfun_eq_iff d1.idem d2.idem)
+  show "cfun_map\<cdot>d1\<cdot>d2\<cdot>f \<sqsubseteq> f"
+    apply (rule cfun_belowI, simp)
+    apply (rule below_trans [OF d2.below])
+    apply (rule monofun_cfun_arg)
+    apply (rule d1.below)
+    done
+qed
+
+lemma finite_range_cfun_map:
+  assumes a: "finite (range (\<lambda>x. a\<cdot>x))"
+  assumes b: "finite (range (\<lambda>y. b\<cdot>y))"
+  shows "finite (range (\<lambda>f. cfun_map\<cdot>a\<cdot>b\<cdot>f))"  (is "finite (range ?h)")
+proof (rule finite_imageD)
+  let ?f = "\<lambda>g. range (\<lambda>x. (a\<cdot>x, g\<cdot>x))"
+  show "finite (?f ` range ?h)"
+  proof (rule finite_subset)
+    let ?B = "Pow (range (\<lambda>x. a\<cdot>x) \<times> range (\<lambda>y. b\<cdot>y))"
+    show "?f ` range ?h \<subseteq> ?B"
+      by clarsimp
+    show "finite ?B"
+      by (simp add: a b)
+  qed
+  show "inj_on ?f (range ?h)"
+  proof (rule inj_onI, rule cfun_eqI, clarsimp)
+    fix x f g
+    assume "range (\<lambda>x. (a\<cdot>x, b\<cdot>(f\<cdot>(a\<cdot>x)))) = range (\<lambda>x. (a\<cdot>x, b\<cdot>(g\<cdot>(a\<cdot>x))))"
+    hence "range (\<lambda>x. (a\<cdot>x, b\<cdot>(f\<cdot>(a\<cdot>x)))) \<subseteq> range (\<lambda>x. (a\<cdot>x, b\<cdot>(g\<cdot>(a\<cdot>x))))"
+      by (rule equalityD1)
+    hence "(a\<cdot>x, b\<cdot>(f\<cdot>(a\<cdot>x))) \<in> range (\<lambda>x. (a\<cdot>x, b\<cdot>(g\<cdot>(a\<cdot>x))))"
+      by (simp add: subset_eq)
+    then obtain y where "(a\<cdot>x, b\<cdot>(f\<cdot>(a\<cdot>x))) = (a\<cdot>y, b\<cdot>(g\<cdot>(a\<cdot>y)))"
+      by (rule rangeE)
+    thus "b\<cdot>(f\<cdot>(a\<cdot>x)) = b\<cdot>(g\<cdot>(a\<cdot>x))"
+      by clarsimp
+  qed
+qed
+
+lemma finite_deflation_cfun_map:
+  assumes "finite_deflation d1" and "finite_deflation d2"
+  shows "finite_deflation (cfun_map\<cdot>d1\<cdot>d2)"
+proof (rule finite_deflation_intro)
+  interpret d1: finite_deflation d1 by fact
+  interpret d2: finite_deflation d2 by fact
+  have "deflation d1" and "deflation d2" by fact+
+  thus "deflation (cfun_map\<cdot>d1\<cdot>d2)" by (rule deflation_cfun_map)
+  have "finite (range (\<lambda>f. cfun_map\<cdot>d1\<cdot>d2\<cdot>f))"
+    using d1.finite_range d2.finite_range
+    by (rule finite_range_cfun_map)
+  thus "finite {f. cfun_map\<cdot>d1\<cdot>d2\<cdot>f = f}"
+    by (rule finite_range_imp_finite_fixes)
+qed
+
+text {* Finite deflations are compact elements of the function space *}
+
+lemma finite_deflation_imp_compact: "finite_deflation d \<Longrightarrow> compact d"
+apply (frule finite_deflation_imp_deflation)
+apply (subgoal_tac "compact (cfun_map\<cdot>d\<cdot>d\<cdot>d)")
+apply (simp add: cfun_map_def deflation.idem eta_cfun)
+apply (rule finite_deflation.compact)
+apply (simp only: finite_deflation_cfun_map)
+done
+
+subsection {* Map operator for product type *}
+
+definition
+  cprod_map :: "('a \<rightarrow> 'b) \<rightarrow> ('c \<rightarrow> 'd) \<rightarrow> 'a \<times> 'c \<rightarrow> 'b \<times> 'd"
+where
+  "cprod_map = (\<Lambda> f g p. (f\<cdot>(fst p), g\<cdot>(snd p)))"
+
+lemma cprod_map_Pair [simp]: "cprod_map\<cdot>f\<cdot>g\<cdot>(x, y) = (f\<cdot>x, g\<cdot>y)"
+unfolding cprod_map_def by simp
+
+lemma cprod_map_ID: "cprod_map\<cdot>ID\<cdot>ID = ID"
+unfolding cfun_eq_iff by auto
+
+lemma cprod_map_map:
+  "cprod_map\<cdot>f1\<cdot>g1\<cdot>(cprod_map\<cdot>f2\<cdot>g2\<cdot>p) =
+    cprod_map\<cdot>(\<Lambda> x. f1\<cdot>(f2\<cdot>x))\<cdot>(\<Lambda> x. g1\<cdot>(g2\<cdot>x))\<cdot>p"
+by (induct p) simp
+
+lemma ep_pair_cprod_map:
+  assumes "ep_pair e1 p1" and "ep_pair e2 p2"
+  shows "ep_pair (cprod_map\<cdot>e1\<cdot>e2) (cprod_map\<cdot>p1\<cdot>p2)"
+proof
+  interpret e1p1: ep_pair e1 p1 by fact
+  interpret e2p2: ep_pair e2 p2 by fact
+  fix x show "cprod_map\<cdot>p1\<cdot>p2\<cdot>(cprod_map\<cdot>e1\<cdot>e2\<cdot>x) = x"
+    by (induct x) simp
+  fix y show "cprod_map\<cdot>e1\<cdot>e2\<cdot>(cprod_map\<cdot>p1\<cdot>p2\<cdot>y) \<sqsubseteq> y"
+    by (induct y) (simp add: e1p1.e_p_below e2p2.e_p_below)
+qed
+
+lemma deflation_cprod_map:
+  assumes "deflation d1" and "deflation d2"
+  shows "deflation (cprod_map\<cdot>d1\<cdot>d2)"
+proof
+  interpret d1: deflation d1 by fact
+  interpret d2: deflation d2 by fact
+  fix x
+  show "cprod_map\<cdot>d1\<cdot>d2\<cdot>(cprod_map\<cdot>d1\<cdot>d2\<cdot>x) = cprod_map\<cdot>d1\<cdot>d2\<cdot>x"
+    by (induct x) (simp add: d1.idem d2.idem)
+  show "cprod_map\<cdot>d1\<cdot>d2\<cdot>x \<sqsubseteq> x"
+    by (induct x) (simp add: d1.below d2.below)
+qed
+
+lemma finite_deflation_cprod_map:
+  assumes "finite_deflation d1" and "finite_deflation d2"
+  shows "finite_deflation (cprod_map\<cdot>d1\<cdot>d2)"
+proof (rule finite_deflation_intro)
+  interpret d1: finite_deflation d1 by fact
+  interpret d2: finite_deflation d2 by fact
+  have "deflation d1" and "deflation d2" by fact+
+  thus "deflation (cprod_map\<cdot>d1\<cdot>d2)" by (rule deflation_cprod_map)
+  have "{p. cprod_map\<cdot>d1\<cdot>d2\<cdot>p = p} \<subseteq> {x. d1\<cdot>x = x} \<times> {y. d2\<cdot>y = y}"
+    by clarsimp
+  thus "finite {p. cprod_map\<cdot>d1\<cdot>d2\<cdot>p = p}"
+    by (rule finite_subset, simp add: d1.finite_fixes d2.finite_fixes)
+qed
+
+subsection {* Map function for lifted cpo *}
+
+definition
+  u_map :: "('a \<rightarrow> 'b) \<rightarrow> 'a u \<rightarrow> 'b u"
+where
+  "u_map = (\<Lambda> f. fup\<cdot>(up oo f))"
+
+lemma u_map_strict [simp]: "u_map\<cdot>f\<cdot>\<bottom> = \<bottom>"
+unfolding u_map_def by simp
+
+lemma u_map_up [simp]: "u_map\<cdot>f\<cdot>(up\<cdot>x) = up\<cdot>(f\<cdot>x)"
+unfolding u_map_def by simp
+
+lemma u_map_ID: "u_map\<cdot>ID = ID"
+unfolding u_map_def by (simp add: cfun_eq_iff eta_cfun)
+
+lemma u_map_map: "u_map\<cdot>f\<cdot>(u_map\<cdot>g\<cdot>p) = u_map\<cdot>(\<Lambda> x. f\<cdot>(g\<cdot>x))\<cdot>p"
+by (induct p) simp_all
+
+lemma ep_pair_u_map: "ep_pair e p \<Longrightarrow> ep_pair (u_map\<cdot>e) (u_map\<cdot>p)"
+apply default
+apply (case_tac x, simp, simp add: ep_pair.e_inverse)
+apply (case_tac y, simp, simp add: ep_pair.e_p_below)
+done
+
+lemma deflation_u_map: "deflation d \<Longrightarrow> deflation (u_map\<cdot>d)"
+apply default
+apply (case_tac x, simp, simp add: deflation.idem)
+apply (case_tac x, simp, simp add: deflation.below)
+done
+
+lemma finite_deflation_u_map:
+  assumes "finite_deflation d" shows "finite_deflation (u_map\<cdot>d)"
+proof (rule finite_deflation_intro)
+  interpret d: finite_deflation d by fact
+  have "deflation d" by fact
+  thus "deflation (u_map\<cdot>d)" by (rule deflation_u_map)
+  have "{x. u_map\<cdot>d\<cdot>x = x} \<subseteq> insert \<bottom> ((\<lambda>x. up\<cdot>x) ` {x. d\<cdot>x = x})"
+    by (rule subsetI, case_tac x, simp_all)
+  thus "finite {x. u_map\<cdot>d\<cdot>x = x}"
+    by (rule finite_subset, simp add: d.finite_fixes)
+qed
+
+subsection {* Map function for strict products *}
+
+default_sort pcpo
+
+definition
+  sprod_map :: "('a \<rightarrow> 'b) \<rightarrow> ('c \<rightarrow> 'd) \<rightarrow> 'a \<otimes> 'c \<rightarrow> 'b \<otimes> 'd"
+where
+  "sprod_map = (\<Lambda> f g. ssplit\<cdot>(\<Lambda> x y. (:f\<cdot>x, g\<cdot>y:)))"
+
+lemma sprod_map_strict [simp]: "sprod_map\<cdot>a\<cdot>b\<cdot>\<bottom> = \<bottom>"
+unfolding sprod_map_def by simp
+
+lemma sprod_map_spair [simp]:
+  "x \<noteq> \<bottom> \<Longrightarrow> y \<noteq> \<bottom> \<Longrightarrow> sprod_map\<cdot>f\<cdot>g\<cdot>(:x, y:) = (:f\<cdot>x, g\<cdot>y:)"
+by (simp add: sprod_map_def)
+
+lemma sprod_map_spair':
+  "f\<cdot>\<bottom> = \<bottom> \<Longrightarrow> g\<cdot>\<bottom> = \<bottom> \<Longrightarrow> sprod_map\<cdot>f\<cdot>g\<cdot>(:x, y:) = (:f\<cdot>x, g\<cdot>y:)"
+by (cases "x = \<bottom> \<or> y = \<bottom>") auto
+
+lemma sprod_map_ID: "sprod_map\<cdot>ID\<cdot>ID = ID"
+unfolding sprod_map_def by (simp add: cfun_eq_iff eta_cfun)
+
+lemma sprod_map_map:
+  "\<lbrakk>f1\<cdot>\<bottom> = \<bottom>; g1\<cdot>\<bottom> = \<bottom>\<rbrakk> \<Longrightarrow>
+    sprod_map\<cdot>f1\<cdot>g1\<cdot>(sprod_map\<cdot>f2\<cdot>g2\<cdot>p) =
+     sprod_map\<cdot>(\<Lambda> x. f1\<cdot>(f2\<cdot>x))\<cdot>(\<Lambda> x. g1\<cdot>(g2\<cdot>x))\<cdot>p"
+apply (induct p, simp)
+apply (case_tac "f2\<cdot>x = \<bottom>", simp)
+apply (case_tac "g2\<cdot>y = \<bottom>", simp)
+apply simp
+done
+
+lemma ep_pair_sprod_map:
+  assumes "ep_pair e1 p1" and "ep_pair e2 p2"
+  shows "ep_pair (sprod_map\<cdot>e1\<cdot>e2) (sprod_map\<cdot>p1\<cdot>p2)"
+proof
+  interpret e1p1: pcpo_ep_pair e1 p1 unfolding pcpo_ep_pair_def by fact
+  interpret e2p2: pcpo_ep_pair e2 p2 unfolding pcpo_ep_pair_def by fact
+  fix x show "sprod_map\<cdot>p1\<cdot>p2\<cdot>(sprod_map\<cdot>e1\<cdot>e2\<cdot>x) = x"
+    by (induct x) simp_all
+  fix y show "sprod_map\<cdot>e1\<cdot>e2\<cdot>(sprod_map\<cdot>p1\<cdot>p2\<cdot>y) \<sqsubseteq> y"
+    apply (induct y, simp)
+    apply (case_tac "p1\<cdot>x = \<bottom>", simp, case_tac "p2\<cdot>y = \<bottom>", simp)
+    apply (simp add: monofun_cfun e1p1.e_p_below e2p2.e_p_below)
+    done
+qed
+
+lemma deflation_sprod_map:
+  assumes "deflation d1" and "deflation d2"
+  shows "deflation (sprod_map\<cdot>d1\<cdot>d2)"
+proof
+  interpret d1: deflation d1 by fact
+  interpret d2: deflation d2 by fact
+  fix x
+  show "sprod_map\<cdot>d1\<cdot>d2\<cdot>(sprod_map\<cdot>d1\<cdot>d2\<cdot>x) = sprod_map\<cdot>d1\<cdot>d2\<cdot>x"
+    apply (induct x, simp)
+    apply (case_tac "d1\<cdot>x = \<bottom>", simp, case_tac "d2\<cdot>y = \<bottom>", simp)
+    apply (simp add: d1.idem d2.idem)
+    done
+  show "sprod_map\<cdot>d1\<cdot>d2\<cdot>x \<sqsubseteq> x"
+    apply (induct x, simp)
+    apply (simp add: monofun_cfun d1.below d2.below)
+    done
+qed
+
+lemma finite_deflation_sprod_map:
+  assumes "finite_deflation d1" and "finite_deflation d2"
+  shows "finite_deflation (sprod_map\<cdot>d1\<cdot>d2)"
+proof (rule finite_deflation_intro)
+  interpret d1: finite_deflation d1 by fact
+  interpret d2: finite_deflation d2 by fact
+  have "deflation d1" and "deflation d2" by fact+
+  thus "deflation (sprod_map\<cdot>d1\<cdot>d2)" by (rule deflation_sprod_map)
+  have "{x. sprod_map\<cdot>d1\<cdot>d2\<cdot>x = x} \<subseteq> insert \<bottom>
+        ((\<lambda>(x, y). (:x, y:)) ` ({x. d1\<cdot>x = x} \<times> {y. d2\<cdot>y = y}))"
+    by (rule subsetI, case_tac x, auto simp add: spair_eq_iff)
+  thus "finite {x. sprod_map\<cdot>d1\<cdot>d2\<cdot>x = x}"
+    by (rule finite_subset, simp add: d1.finite_fixes d2.finite_fixes)
+qed
+
+subsection {* Map function for strict sums *}
+
+definition
+  ssum_map :: "('a \<rightarrow> 'b) \<rightarrow> ('c \<rightarrow> 'd) \<rightarrow> 'a \<oplus> 'c \<rightarrow> 'b \<oplus> 'd"
+where
+  "ssum_map = (\<Lambda> f g. sscase\<cdot>(sinl oo f)\<cdot>(sinr oo g))"
+
+lemma ssum_map_strict [simp]: "ssum_map\<cdot>f\<cdot>g\<cdot>\<bottom> = \<bottom>"
+unfolding ssum_map_def by simp
+
+lemma ssum_map_sinl [simp]: "x \<noteq> \<bottom> \<Longrightarrow> ssum_map\<cdot>f\<cdot>g\<cdot>(sinl\<cdot>x) = sinl\<cdot>(f\<cdot>x)"
+unfolding ssum_map_def by simp
+
+lemma ssum_map_sinr [simp]: "x \<noteq> \<bottom> \<Longrightarrow> ssum_map\<cdot>f\<cdot>g\<cdot>(sinr\<cdot>x) = sinr\<cdot>(g\<cdot>x)"
+unfolding ssum_map_def by simp
+
+lemma ssum_map_sinl': "f\<cdot>\<bottom> = \<bottom> \<Longrightarrow> ssum_map\<cdot>f\<cdot>g\<cdot>(sinl\<cdot>x) = sinl\<cdot>(f\<cdot>x)"
+by (cases "x = \<bottom>") simp_all
+
+lemma ssum_map_sinr': "g\<cdot>\<bottom> = \<bottom> \<Longrightarrow> ssum_map\<cdot>f\<cdot>g\<cdot>(sinr\<cdot>x) = sinr\<cdot>(g\<cdot>x)"
+by (cases "x = \<bottom>") simp_all
+
+lemma ssum_map_ID: "ssum_map\<cdot>ID\<cdot>ID = ID"
+unfolding ssum_map_def by (simp add: cfun_eq_iff eta_cfun)
+
+lemma ssum_map_map:
+  "\<lbrakk>f1\<cdot>\<bottom> = \<bottom>; g1\<cdot>\<bottom> = \<bottom>\<rbrakk> \<Longrightarrow>
+    ssum_map\<cdot>f1\<cdot>g1\<cdot>(ssum_map\<cdot>f2\<cdot>g2\<cdot>p) =
+     ssum_map\<cdot>(\<Lambda> x. f1\<cdot>(f2\<cdot>x))\<cdot>(\<Lambda> x. g1\<cdot>(g2\<cdot>x))\<cdot>p"
+apply (induct p, simp)
+apply (case_tac "f2\<cdot>x = \<bottom>", simp, simp)
+apply (case_tac "g2\<cdot>y = \<bottom>", simp, simp)
+done
+
+lemma ep_pair_ssum_map:
+  assumes "ep_pair e1 p1" and "ep_pair e2 p2"
+  shows "ep_pair (ssum_map\<cdot>e1\<cdot>e2) (ssum_map\<cdot>p1\<cdot>p2)"
+proof
+  interpret e1p1: pcpo_ep_pair e1 p1 unfolding pcpo_ep_pair_def by fact
+  interpret e2p2: pcpo_ep_pair e2 p2 unfolding pcpo_ep_pair_def by fact
+  fix x show "ssum_map\<cdot>p1\<cdot>p2\<cdot>(ssum_map\<cdot>e1\<cdot>e2\<cdot>x) = x"
+    by (induct x) simp_all
+  fix y show "ssum_map\<cdot>e1\<cdot>e2\<cdot>(ssum_map\<cdot>p1\<cdot>p2\<cdot>y) \<sqsubseteq> y"
+    apply (induct y, simp)
+    apply (case_tac "p1\<cdot>x = \<bottom>", simp, simp add: e1p1.e_p_below)
+    apply (case_tac "p2\<cdot>y = \<bottom>", simp, simp add: e2p2.e_p_below)
+    done
+qed
+
+lemma deflation_ssum_map:
+  assumes "deflation d1" and "deflation d2"
+  shows "deflation (ssum_map\<cdot>d1\<cdot>d2)"
+proof
+  interpret d1: deflation d1 by fact
+  interpret d2: deflation d2 by fact
+  fix x
+  show "ssum_map\<cdot>d1\<cdot>d2\<cdot>(ssum_map\<cdot>d1\<cdot>d2\<cdot>x) = ssum_map\<cdot>d1\<cdot>d2\<cdot>x"
+    apply (induct x, simp)
+    apply (case_tac "d1\<cdot>x = \<bottom>", simp, simp add: d1.idem)
+    apply (case_tac "d2\<cdot>y = \<bottom>", simp, simp add: d2.idem)
+    done
+  show "ssum_map\<cdot>d1\<cdot>d2\<cdot>x \<sqsubseteq> x"
+    apply (induct x, simp)
+    apply (case_tac "d1\<cdot>x = \<bottom>", simp, simp add: d1.below)
+    apply (case_tac "d2\<cdot>y = \<bottom>", simp, simp add: d2.below)
+    done
+qed
+
+lemma finite_deflation_ssum_map:
+  assumes "finite_deflation d1" and "finite_deflation d2"
+  shows "finite_deflation (ssum_map\<cdot>d1\<cdot>d2)"
+proof (rule finite_deflation_intro)
+  interpret d1: finite_deflation d1 by fact
+  interpret d2: finite_deflation d2 by fact
+  have "deflation d1" and "deflation d2" by fact+
+  thus "deflation (ssum_map\<cdot>d1\<cdot>d2)" by (rule deflation_ssum_map)
+  have "{x. ssum_map\<cdot>d1\<cdot>d2\<cdot>x = x} \<subseteq>
+        (\<lambda>x. sinl\<cdot>x) ` {x. d1\<cdot>x = x} \<union>
+        (\<lambda>x. sinr\<cdot>x) ` {x. d2\<cdot>x = x} \<union> {\<bottom>}"
+    by (rule subsetI, case_tac x, simp_all)
+  thus "finite {x. ssum_map\<cdot>d1\<cdot>d2\<cdot>x = x}"
+    by (rule finite_subset, simp add: d1.finite_fixes d2.finite_fixes)
+qed
+
+subsection {* Map operator for strict function space *}
+
+definition
+  sfun_map :: "('b \<rightarrow> 'a) \<rightarrow> ('c \<rightarrow> 'd) \<rightarrow> ('a \<rightarrow>! 'c) \<rightarrow> ('b \<rightarrow>! 'd)"
+where
+  "sfun_map = (\<Lambda> a b. sfun_abs oo cfun_map\<cdot>a\<cdot>b oo sfun_rep)"
+
+lemma sfun_map_ID: "sfun_map\<cdot>ID\<cdot>ID = ID"
+  unfolding sfun_map_def
+  by (simp add: cfun_map_ID cfun_eq_iff)
+
+lemma sfun_map_map:
+  assumes "f2\<cdot>\<bottom> = \<bottom>" and "g2\<cdot>\<bottom> = \<bottom>" shows
+  "sfun_map\<cdot>f1\<cdot>g1\<cdot>(sfun_map\<cdot>f2\<cdot>g2\<cdot>p) =
+    sfun_map\<cdot>(\<Lambda> x. f2\<cdot>(f1\<cdot>x))\<cdot>(\<Lambda> x. g1\<cdot>(g2\<cdot>x))\<cdot>p"
+unfolding sfun_map_def
+by (simp add: cfun_eq_iff strictify_cancel assms cfun_map_map)
+
+lemma ep_pair_sfun_map:
+  assumes 1: "ep_pair e1 p1"
+  assumes 2: "ep_pair e2 p2"
+  shows "ep_pair (sfun_map\<cdot>p1\<cdot>e2) (sfun_map\<cdot>e1\<cdot>p2)"
+proof
+  interpret e1p1: pcpo_ep_pair e1 p1
+    unfolding pcpo_ep_pair_def by fact
+  interpret e2p2: pcpo_ep_pair e2 p2
+    unfolding pcpo_ep_pair_def by fact
+  fix f show "sfun_map\<cdot>e1\<cdot>p2\<cdot>(sfun_map\<cdot>p1\<cdot>e2\<cdot>f) = f"
+    unfolding sfun_map_def
+    apply (simp add: sfun_eq_iff strictify_cancel)
+    apply (rule ep_pair.e_inverse)
+    apply (rule ep_pair_cfun_map [OF 1 2])
+    done
+  fix g show "sfun_map\<cdot>p1\<cdot>e2\<cdot>(sfun_map\<cdot>e1\<cdot>p2\<cdot>g) \<sqsubseteq> g"
+    unfolding sfun_map_def
+    apply (simp add: sfun_below_iff strictify_cancel)
+    apply (rule ep_pair.e_p_below)
+    apply (rule ep_pair_cfun_map [OF 1 2])
+    done
+qed
+
+lemma deflation_sfun_map:
+  assumes 1: "deflation d1"
+  assumes 2: "deflation d2"
+  shows "deflation (sfun_map\<cdot>d1\<cdot>d2)"
+apply (simp add: sfun_map_def)
+apply (rule deflation.intro)
+apply simp
+apply (subst strictify_cancel)
+apply (simp add: cfun_map_def deflation_strict 1 2)
+apply (simp add: cfun_map_def deflation.idem 1 2)
+apply (simp add: sfun_below_iff)
+apply (subst strictify_cancel)
+apply (simp add: cfun_map_def deflation_strict 1 2)
+apply (rule deflation.below)
+apply (rule deflation_cfun_map [OF 1 2])
+done
+
+lemma finite_deflation_sfun_map:
+  assumes 1: "finite_deflation d1"
+  assumes 2: "finite_deflation d2"
+  shows "finite_deflation (sfun_map\<cdot>d1\<cdot>d2)"
+proof (intro finite_deflation_intro)
+  interpret d1: finite_deflation d1 by fact
+  interpret d2: finite_deflation d2 by fact
+  have "deflation d1" and "deflation d2" by fact+
+  thus "deflation (sfun_map\<cdot>d1\<cdot>d2)" by (rule deflation_sfun_map)
+  from 1 2 have "finite_deflation (cfun_map\<cdot>d1\<cdot>d2)"
+    by (rule finite_deflation_cfun_map)
+  then have "finite {f. cfun_map\<cdot>d1\<cdot>d2\<cdot>f = f}"
+    by (rule finite_deflation.finite_fixes)
+  moreover have "inj (\<lambda>f. sfun_rep\<cdot>f)"
+    by (rule inj_onI, simp add: sfun_eq_iff)
+  ultimately have "finite ((\<lambda>f. sfun_rep\<cdot>f) -` {f. cfun_map\<cdot>d1\<cdot>d2\<cdot>f = f})"
+    by (rule finite_vimageI)
+  then show "finite {f. sfun_map\<cdot>d1\<cdot>d2\<cdot>f = f}"
+    unfolding sfun_map_def sfun_eq_iff
+    by (simp add: strictify_cancel
+         deflation_strict `deflation d1` `deflation d2`)
+qed
+
+end

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/HOLCF/One.thy	Sat Nov 27 16:08:10 2010 -0800
@@ -0,0 +1,72 @@
+(*  Title:      HOLCF/One.thy
+    Author:     Oscar Slotosch
+*)
+
+header {* The unit domain *}
+
+theory One
+imports Lift
+begin
+
+types one = "unit lift"
+translations
+  (type) "one" <= (type) "unit lift" 
+
+definition
+  ONE :: "one"
+where
+  "ONE == Def ()"
+
+text {* Exhaustion and Elimination for type @{typ one} *}
+
+lemma Exh_one: "t = \<bottom> \<or> t = ONE"
+unfolding ONE_def by (induct t) simp_all
+
+lemma oneE [case_names bottom ONE]: "\<lbrakk>p = \<bottom> \<Longrightarrow> Q; p = ONE \<Longrightarrow> Q\<rbrakk> \<Longrightarrow> Q"
+unfolding ONE_def by (induct p) simp_all
+
+lemma one_induct [case_names bottom ONE]: "\<lbrakk>P \<bottom>; P ONE\<rbrakk> \<Longrightarrow> P x"
+by (cases x rule: oneE) simp_all
+
+lemma dist_below_one [simp]: "\<not> ONE \<sqsubseteq> \<bottom>"
+unfolding ONE_def by simp
+
+lemma below_ONE [simp]: "x \<sqsubseteq> ONE"
+by (induct x rule: one_induct) simp_all
+
+lemma ONE_below_iff [simp]: "ONE \<sqsubseteq> x \<longleftrightarrow> x = ONE"
+by (induct x rule: one_induct) simp_all
+
+lemma ONE_defined [simp]: "ONE \<noteq> \<bottom>"
+unfolding ONE_def by simp
+
+lemma one_neq_iffs [simp]:
+  "x \<noteq> ONE \<longleftrightarrow> x = \<bottom>"
+  "ONE \<noteq> x \<longleftrightarrow> x = \<bottom>"
+  "x \<noteq> \<bottom> \<longleftrightarrow> x = ONE"
+  "\<bottom> \<noteq> x \<longleftrightarrow> x = ONE"
+by (induct x rule: one_induct) simp_all
+
+lemma compact_ONE: "compact ONE"
+by (rule compact_chfin)
+
+text {* Case analysis function for type @{typ one} *}
+
+definition
+  one_case :: "'a::pcpo \<rightarrow> one \<rightarrow> 'a" where
+  "one_case = (\<Lambda> a x. seq\<cdot>x\<cdot>a)"
+
+translations
+  "case x of XCONST ONE \<Rightarrow> t" == "CONST one_case\<cdot>t\<cdot>x"
+  "\<Lambda> (XCONST ONE). t" == "CONST one_case\<cdot>t"
+
+lemma one_case1 [simp]: "(case \<bottom> of ONE \<Rightarrow> t) = \<bottom>"
+by (simp add: one_case_def)
+
+lemma one_case2 [simp]: "(case ONE of ONE \<Rightarrow> t) = t"
+by (simp add: one_case_def)
+
+lemma one_case3 [simp]: "(case x of ONE \<Rightarrow> ONE) = x"
+by (induct x rule: one_induct) simp_all
+
+end

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/HOLCF/Pcpo.thy	Sat Nov 27 16:08:10 2010 -0800
@@ -0,0 +1,284 @@
+(*  Title:      HOLCF/Pcpo.thy
+    Author:     Franz Regensburger
+*)
+
+header {* Classes cpo and pcpo *}
+
+theory Pcpo
+imports Porder
+begin
+
+subsection {* Complete partial orders *}
+
+text {* The class cpo of chain complete partial orders *}
+
+class cpo = po +
+  assumes cpo: "chain S \<Longrightarrow> \<exists>x. range S <<| x"
+begin
+
+text {* in cpo's everthing equal to THE lub has lub properties for every chain *}
+
+lemma cpo_lubI: "chain S \<Longrightarrow> range S <<| (\<Squnion>i. S i)"
+  by (fast dest: cpo elim: is_lub_lub)
+
+lemma thelubE: "\<lbrakk>chain S; (\<Squnion>i. S i) = l\<rbrakk> \<Longrightarrow> range S <<| l"
+  by (blast dest: cpo intro: is_lub_lub)
+
+text {* Properties of the lub *}
+
+lemma is_ub_thelub: "chain S \<Longrightarrow> S x \<sqsubseteq> (\<Squnion>i. S i)"
+  by (blast dest: cpo intro: is_lub_lub [THEN is_lub_rangeD1])
+
+lemma is_lub_thelub:
+  "\<lbrakk>chain S; range S <| x\<rbrakk> \<Longrightarrow> (\<Squnion>i. S i) \<sqsubseteq> x"
+  by (blast dest: cpo intro: is_lub_lub [THEN is_lubD2])
+
+lemma lub_below_iff: "chain S \<Longrightarrow> (\<Squnion>i. S i) \<sqsubseteq> x \<longleftrightarrow> (\<forall>i. S i \<sqsubseteq> x)"
+  by (simp add: is_lub_below_iff [OF cpo_lubI] is_ub_def)
+
+lemma lub_below: "\<lbrakk>chain S; \<And>i. S i \<sqsubseteq> x\<rbrakk> \<Longrightarrow> (\<Squnion>i. S i) \<sqsubseteq> x"
+  by (simp add: lub_below_iff)
+
+lemma below_lub: "\<lbrakk>chain S; x \<sqsubseteq> S i\<rbrakk> \<Longrightarrow> x \<sqsubseteq> (\<Squnion>i. S i)"
+  by (erule below_trans, erule is_ub_thelub)
+
+lemma lub_range_mono:
+  "\<lbrakk>range X \<subseteq> range Y; chain Y; chain X\<rbrakk>
+    \<Longrightarrow> (\<Squnion>i. X i) \<sqsubseteq> (\<Squnion>i. Y i)"
+apply (erule lub_below)
+apply (subgoal_tac "\<exists>j. X i = Y j")
+apply  clarsimp
+apply  (erule is_ub_thelub)
+apply auto
+done
+
+lemma lub_range_shift:
+  "chain Y \<Longrightarrow> (\<Squnion>i. Y (i + j)) = (\<Squnion>i. Y i)"
+apply (rule below_antisym)
+apply (rule lub_range_mono)
+apply    fast
+apply   assumption
+apply (erule chain_shift)
+apply (rule lub_below)
+apply assumption
+apply (rule_tac i="i" in below_lub)
+apply (erule chain_shift)
+apply (erule chain_mono)
+apply (rule le_add1)
+done
+
+lemma maxinch_is_thelub:
+  "chain Y \<Longrightarrow> max_in_chain i Y = ((\<Squnion>i. Y i) = Y i)"
+apply (rule iffI)
+apply (fast intro!: lub_eqI lub_finch1)
+apply (unfold max_in_chain_def)
+apply (safe intro!: below_antisym)
+apply (fast elim!: chain_mono)
+apply (drule sym)
+apply (force elim!: is_ub_thelub)
+done
+
+text {* the @{text "\<sqsubseteq>"} relation between two chains is preserved by their lubs *}
+
+lemma lub_mono:
+  "\<lbrakk>chain X; chain Y; \<And>i. X i \<sqsubseteq> Y i\<rbrakk> 
+    \<Longrightarrow> (\<Squnion>i. X i) \<sqsubseteq> (\<Squnion>i. Y i)"
+by (fast elim: lub_below below_lub)
+
+text {* the = relation between two chains is preserved by their lubs *}
+
+lemma lub_eq:
+  "(\<And>i. X i = Y i) \<Longrightarrow> (\<Squnion>i. X i) = (\<Squnion>i. Y i)"
+  by simp
+
+lemma ch2ch_lub:
+  assumes 1: "\<And>j. chain (\<lambda>i. Y i j)"
+  assumes 2: "\<And>i. chain (\<lambda>j. Y i j)"
+  shows "chain (\<lambda>i. \<Squnion>j. Y i j)"
+apply (rule chainI)
+apply (rule lub_mono [OF 2 2])
+apply (rule chainE [OF 1])
+done
+
+lemma diag_lub:
+  assumes 1: "\<And>j. chain (\<lambda>i. Y i j)"
+  assumes 2: "\<And>i. chain (\<lambda>j. Y i j)"
+  shows "(\<Squnion>i. \<Squnion>j. Y i j) = (\<Squnion>i. Y i i)"
+proof (rule below_antisym)
+  have 3: "chain (\<lambda>i. Y i i)"
+    apply (rule chainI)
+    apply (rule below_trans)
+    apply (rule chainE [OF 1])
+    apply (rule chainE [OF 2])
+    done
+  have 4: "chain (\<lambda>i. \<Squnion>j. Y i j)"
+    by (rule ch2ch_lub [OF 1 2])
+  show "(\<Squnion>i. \<Squnion>j. Y i j) \<sqsubseteq> (\<Squnion>i. Y i i)"
+    apply (rule lub_below [OF 4])
+    apply (rule lub_below [OF 2])
+    apply (rule below_lub [OF 3])
+    apply (rule below_trans)
+    apply (rule chain_mono [OF 1 le_maxI1])
+    apply (rule chain_mono [OF 2 le_maxI2])
+    done
+  show "(\<Squnion>i. Y i i) \<sqsubseteq> (\<Squnion>i. \<Squnion>j. Y i j)"
+    apply (rule lub_mono [OF 3 4])
+    apply (rule is_ub_thelub [OF 2])
+    done
+qed
+
+lemma ex_lub:
+  assumes 1: "\<And>j. chain (\<lambda>i. Y i j)"
+  assumes 2: "\<And>i. chain (\<lambda>j. Y i j)"
+  shows "(\<Squnion>i. \<Squnion>j. Y i j) = (\<Squnion>j. \<Squnion>i. Y i j)"
+  by (simp add: diag_lub 1 2)
+
+end
+
+subsection {* Pointed cpos *}
+
+text {* The class pcpo of pointed cpos *}
+
+class pcpo = cpo +
+  assumes least: "\<exists>x. \<forall>y. x \<sqsubseteq> y"
+begin
+
+definition UU :: 'a where
+  "UU = (THE x. \<forall>y. x \<sqsubseteq> y)"
+
+notation (xsymbols)
+  UU  ("\<bottom>")
+
+text {* derive the old rule minimal *}
+ 
+lemma UU_least: "\<forall>z. \<bottom> \<sqsubseteq> z"
+apply (unfold UU_def)
+apply (rule theI')
+apply (rule ex_ex1I)
+apply (rule least)
+apply (blast intro: below_antisym)
+done
+
+lemma minimal [iff]: "\<bottom> \<sqsubseteq> x"
+by (rule UU_least [THEN spec])
+
+end
+
+text {* Simproc to rewrite @{term "\<bottom> = x"} to @{term "x = \<bottom>"}. *}
+
+setup {*
+  Reorient_Proc.add
+    (fn Const(@{const_name UU}, _) => true | _ => false)
+*}
+
+simproc_setup reorient_bottom ("\<bottom> = x") = Reorient_Proc.proc
+
+context pcpo
+begin
+
+text {* useful lemmas about @{term \<bottom>} *}
+
+lemma below_UU_iff [simp]: "(x \<sqsubseteq> \<bottom>) = (x = \<bottom>)"
+by (simp add: po_eq_conv)
+
+lemma eq_UU_iff: "(x = \<bottom>) = (x \<sqsubseteq> \<bottom>)"
+by simp
+
+lemma UU_I: "x \<sqsubseteq> \<bottom> \<Longrightarrow> x = \<bottom>"
+by (subst eq_UU_iff)
+
+lemma lub_eq_bottom_iff: "chain Y \<Longrightarrow> (\<Squnion>i. Y i) = \<bottom> \<longleftrightarrow> (\<forall>i. Y i = \<bottom>)"
+by (simp only: eq_UU_iff lub_below_iff)
+
+lemma chain_UU_I: "\<lbrakk>chain Y; (\<Squnion>i. Y i) = \<bottom>\<rbrakk> \<Longrightarrow> \<forall>i. Y i = \<bottom>"
+by (simp add: lub_eq_bottom_iff)
+
+lemma chain_UU_I_inverse: "\<forall>i::nat. Y i = \<bottom> \<Longrightarrow> (\<Squnion>i. Y i) = \<bottom>"
+by simp
+
+lemma chain_UU_I_inverse2: "(\<Squnion>i. Y i) \<noteq> \<bottom> \<Longrightarrow> \<exists>i::nat. Y i \<noteq> \<bottom>"
+  by (blast intro: chain_UU_I_inverse)
+
+lemma notUU_I: "\<lbrakk>x \<sqsubseteq> y; x \<noteq> \<bottom>\<rbrakk> \<Longrightarrow> y \<noteq> \<bottom>"
+  by (blast intro: UU_I)
+
+end
+
+subsection {* Chain-finite and flat cpos *}
+
+text {* further useful classes for HOLCF domains *}
+
+class chfin = po +
+  assumes chfin: "chain Y \<Longrightarrow> \<exists>n. max_in_chain n Y"
+begin
+
+subclass cpo
+apply default
+apply (frule chfin)
+apply (blast intro: lub_finch1)
+done
+
+lemma chfin2finch: "chain Y \<Longrightarrow> finite_chain Y"
+  by (simp add: chfin finite_chain_def)
+
+end
+
+class flat = pcpo +
+  assumes ax_flat: "x \<sqsubseteq> y \<Longrightarrow> x = \<bottom> \<or> x = y"
+begin
+
+subclass chfin
+apply default
+apply (unfold max_in_chain_def)
+apply (case_tac "\<forall>i. Y i = \<bottom>")
+apply simp
+apply simp
+apply (erule exE)
+apply (rule_tac x="i" in exI)
+apply clarify
+apply (blast dest: chain_mono ax_flat)
+done
+
+lemma flat_below_iff:
+  shows "(x \<sqsubseteq> y) = (x = \<bottom> \<or> x = y)"
+  by (safe dest!: ax_flat)
+
+lemma flat_eq: "a \<noteq> \<bottom> \<Longrightarrow> a \<sqsubseteq> b = (a = b)"
+  by (safe dest!: ax_flat)
+
+end
+
+subsection {* Discrete cpos *}
+
+class discrete_cpo = below +
+  assumes discrete_cpo [simp]: "x \<sqsubseteq> y \<longleftrightarrow> x = y"
+begin
+
+subclass po
+proof qed simp_all
+
+text {* In a discrete cpo, every chain is constant *}
+
+lemma discrete_chain_const:
+  assumes S: "chain S"
+  shows "\<exists>x. S = (\<lambda>i. x)"
+proof (intro exI ext)
+  fix i :: nat
+  have "S 0 \<sqsubseteq> S i" using S le0 by (rule chain_mono)
+  hence "S 0 = S i" by simp
+  thus "S i = S 0" by (rule sym)
+qed
+
+subclass chfin
+proof
+  fix S :: "nat \<Rightarrow> 'a"
+  assume S: "chain S"
+  hence "\<exists>x. S = (\<lambda>i. x)" by (rule discrete_chain_const)
+  hence "max_in_chain 0 S"
+    unfolding max_in_chain_def by auto
+  thus "\<exists>i. max_in_chain i S" ..
+qed
+
+end
+
+end

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/HOLCF/Plain_HOLCF.thy	Sat Nov 27 16:08:10 2010 -0800
@@ -0,0 +1,15 @@
+(*  Title:      HOLCF/Plain_HOLCF.thy
+    Author:     Brian Huffman
+*)
+
+header {* Plain HOLCF *}
+
+theory Plain_HOLCF
+imports Cfun Sfun Cprod Sprod Ssum Up Discrete Lift One Tr Fix
+begin
+
+text {*
+  Basic HOLCF concepts and types; does not include definition packages.
+*}
+
+end

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/HOLCF/Porder.thy	Sat Nov 27 16:08:10 2010 -0800
@@ -0,0 +1,336 @@
+(*  Title:      HOLCF/Porder.thy
+    Author:     Franz Regensburger and Brian Huffman
+*)
+
+header {* Partial orders *}
+
+theory Porder
+imports Main
+begin
+
+subsection {* Type class for partial orders *}
+
+class below =
+  fixes below :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
+begin
+
+notation
+  below (infix "<<" 50)
+
+notation (xsymbols)
+  below (infix "\<sqsubseteq>" 50)
+
+lemma below_eq_trans: "\<lbrakk>a \<sqsubseteq> b; b = c\<rbrakk> \<Longrightarrow> a \<sqsubseteq> c"
+  by (rule subst)
+
+lemma eq_below_trans: "\<lbrakk>a = b; b \<sqsubseteq> c\<rbrakk> \<Longrightarrow> a \<sqsubseteq> c"
+  by (rule ssubst)
+
+end
+
+class po = below +
+  assumes below_refl [iff]: "x \<sqsubseteq> x"
+  assumes below_trans: "x \<sqsubseteq> y \<Longrightarrow> y \<sqsubseteq> z \<Longrightarrow> x \<sqsubseteq> z"
+  assumes below_antisym: "x \<sqsubseteq> y \<Longrightarrow> y \<sqsubseteq> x \<Longrightarrow> x = y"
+begin
+
+lemma eq_imp_below: "x = y \<Longrightarrow> x \<sqsubseteq> y"
+  by simp
+
+lemma box_below: "a \<sqsubseteq> b \<Longrightarrow> c \<sqsubseteq> a \<Longrightarrow> b \<sqsubseteq> d \<Longrightarrow> c \<sqsubseteq> d"
+  by (rule below_trans [OF below_trans])
+
+lemma po_eq_conv: "x = y \<longleftrightarrow> x \<sqsubseteq> y \<and> y \<sqsubseteq> x"
+  by (fast intro!: below_antisym)
+
+lemma rev_below_trans: "y \<sqsubseteq> z \<Longrightarrow> x \<sqsubseteq> y \<Longrightarrow> x \<sqsubseteq> z"
+  by (rule below_trans)
+
+lemma not_below2not_eq: "\<not> x \<sqsubseteq> y \<Longrightarrow> x \<noteq> y"
+  by auto
+
+end
+
+lemmas HOLCF_trans_rules [trans] =
+  below_trans
+  below_antisym
+  below_eq_trans
+  eq_below_trans
+
+context po
+begin
+
+subsection {* Upper bounds *}
+
+definition is_ub :: "'a set \<Rightarrow> 'a \<Rightarrow> bool" (infix "<|" 55) where
+  "S <| x \<longleftrightarrow> (\<forall>y\<in>S. y \<sqsubseteq> x)"
+
+lemma is_ubI: "(\<And>x. x \<in> S \<Longrightarrow> x \<sqsubseteq> u) \<Longrightarrow> S <| u"
+  by (simp add: is_ub_def)
+
+lemma is_ubD: "\<lbrakk>S <| u; x \<in> S\<rbrakk> \<Longrightarrow> x \<sqsubseteq> u"
+  by (simp add: is_ub_def)
+
+lemma ub_imageI: "(\<And>x. x \<in> S \<Longrightarrow> f x \<sqsubseteq> u) \<Longrightarrow> (\<lambda>x. f x) ` S <| u"
+  unfolding is_ub_def by fast
+
+lemma ub_imageD: "\<lbrakk>f ` S <| u; x \<in> S\<rbrakk> \<Longrightarrow> f x \<sqsubseteq> u"
+  unfolding is_ub_def by fast
+
+lemma ub_rangeI: "(\<And>i. S i \<sqsubseteq> x) \<Longrightarrow> range S <| x"
+  unfolding is_ub_def by fast
+
+lemma ub_rangeD: "range S <| x \<Longrightarrow> S i \<sqsubseteq> x"
+  unfolding is_ub_def by fast
+
+lemma is_ub_empty [simp]: "{} <| u"
+  unfolding is_ub_def by fast
+
+lemma is_ub_insert [simp]: "(insert x A) <| y = (x \<sqsubseteq> y \<and> A <| y)"
+  unfolding is_ub_def by fast
+
+lemma is_ub_upward: "\<lbrakk>S <| x; x \<sqsubseteq> y\<rbrakk> \<Longrightarrow> S <| y"
+  unfolding is_ub_def by (fast intro: below_trans)
+
+subsection {* Least upper bounds *}
+
+definition is_lub :: "'a set \<Rightarrow> 'a \<Rightarrow> bool" (infix "<<|" 55) where
+  "S <<| x \<longleftrightarrow> S <| x \<and> (\<forall>u. S <| u \<longrightarrow> x \<sqsubseteq> u)"
+
+definition lub :: "'a set \<Rightarrow> 'a" where
+  "lub S = (THE x. S <<| x)"
+
+end
+
+syntax
+  "_BLub" :: "[pttrn, 'a set, 'b] \<Rightarrow> 'b" ("(3LUB _:_./ _)" [0,0, 10] 10)
+
+syntax (xsymbols)
+  "_BLub" :: "[pttrn, 'a set, 'b] \<Rightarrow> 'b" ("(3\<Squnion>_\<in>_./ _)" [0,0, 10] 10)
+
+translations
+  "LUB x:A. t" == "CONST lub ((%x. t) ` A)"
+
+context po
+begin
+
+abbreviation
+  Lub  (binder "LUB " 10) where
+  "LUB n. t n == lub (range t)"
+
+notation (xsymbols)
+  Lub  (binder "\<Squnion> " 10)
+
+text {* access to some definition as inference rule *}
+
+lemma is_lubD1: "S <<| x \<Longrightarrow> S <| x"
+  unfolding is_lub_def by fast
+
+lemma is_lubD2: "\<lbrakk>S <<| x; S <| u\<rbrakk> \<Longrightarrow> x \<sqsubseteq> u"
+  unfolding is_lub_def by fast
+
+lemma is_lubI: "\<lbrakk>S <| x; \<And>u. S <| u \<Longrightarrow> x \<sqsubseteq> u\<rbrakk> \<Longrightarrow> S <<| x"
+  unfolding is_lub_def by fast
+
+lemma is_lub_below_iff: "S <<| x \<Longrightarrow> x \<sqsubseteq> u \<longleftrightarrow> S <| u"
+  unfolding is_lub_def is_ub_def by (metis below_trans)
+
+text {* lubs are unique *}
+
+lemma is_lub_unique: "\<lbrakk>S <<| x; S <<| y\<rbrakk> \<Longrightarrow> x = y"
+  unfolding is_lub_def is_ub_def by (blast intro: below_antisym)
+
+text {* technical lemmas about @{term lub} and @{term is_lub} *}
+
+lemma is_lub_lub: "M <<| x \<Longrightarrow> M <<| lub M"
+  unfolding lub_def by (rule theI [OF _ is_lub_unique])
+
+lemma lub_eqI: "M <<| l \<Longrightarrow> lub M = l"
+  by (rule is_lub_unique [OF is_lub_lub])
+
+lemma is_lub_singleton: "{x} <<| x"
+  by (simp add: is_lub_def)
+
+lemma lub_singleton [simp]: "lub {x} = x"
+  by (rule is_lub_singleton [THEN lub_eqI])
+
+lemma is_lub_bin: "x \<sqsubseteq> y \<Longrightarrow> {x, y} <<| y"
+  by (simp add: is_lub_def)
+
+lemma lub_bin: "x \<sqsubseteq> y \<Longrightarrow> lub {x, y} = y"
+  by (rule is_lub_bin [THEN lub_eqI])
+
+lemma is_lub_maximal: "\<lbrakk>S <| x; x \<in> S\<rbrakk> \<Longrightarrow> S <<| x"
+  by (erule is_lubI, erule (1) is_ubD)
+
+lemma lub_maximal: "\<lbrakk>S <| x; x \<in> S\<rbrakk> \<Longrightarrow> lub S = x"
+  by (rule is_lub_maximal [THEN lub_eqI])
+
+subsection {* Countable chains *}
+
+definition chain :: "(nat \<Rightarrow> 'a) \<Rightarrow> bool" where
+  -- {* Here we use countable chains and I prefer to code them as functions! *}
+  "chain Y = (\<forall>i. Y i \<sqsubseteq> Y (Suc i))"
+
+lemma chainI: "(\<And>i. Y i \<sqsubseteq> Y (Suc i)) \<Longrightarrow> chain Y"
+  unfolding chain_def by fast
+
+lemma chainE: "chain Y \<Longrightarrow> Y i \<sqsubseteq> Y (Suc i)"
+  unfolding chain_def by fast
+
+text {* chains are monotone functions *}
+
+lemma chain_mono_less: "\<lbrakk>chain Y; i < j\<rbrakk> \<Longrightarrow> Y i \<sqsubseteq> Y j"
+  by (erule less_Suc_induct, erule chainE, erule below_trans)
+
+lemma chain_mono: "\<lbrakk>chain Y; i \<le> j\<rbrakk> \<Longrightarrow> Y i \<sqsubseteq> Y j"
+  by (cases "i = j", simp, simp add: chain_mono_less)
+
+lemma chain_shift: "chain Y \<Longrightarrow> chain (\<lambda>i. Y (i + j))"
+  by (rule chainI, simp, erule chainE)
+
+text {* technical lemmas about (least) upper bounds of chains *}
+
+lemma is_lub_rangeD1: "range S <<| x \<Longrightarrow> S i \<sqsubseteq> x"
+  by (rule is_lubD1 [THEN ub_rangeD])
+
+lemma is_ub_range_shift:
+  "chain S \<Longrightarrow> range (\<lambda>i. S (i + j)) <| x = range S <| x"
+apply (rule iffI)
+apply (rule ub_rangeI)
+apply (rule_tac y="S (i + j)" in below_trans)
+apply (erule chain_mono)
+apply (rule le_add1)
+apply (erule ub_rangeD)
+apply (rule ub_rangeI)
+apply (erule ub_rangeD)
+done
+
+lemma is_lub_range_shift:
+  "chain S \<Longrightarrow> range (\<lambda>i. S (i + j)) <<| x = range S <<| x"
+  by (simp add: is_lub_def is_ub_range_shift)
+
+text {* the lub of a constant chain is the constant *}
+
+lemma chain_const [simp]: "chain (\<lambda>i. c)"
+  by (simp add: chainI)
+
+lemma is_lub_const: "range (\<lambda>x. c) <<| c"
+by (blast dest: ub_rangeD intro: is_lubI ub_rangeI)
+
+lemma lub_const [simp]: "(\<Squnion>i. c) = c"
+  by (rule is_lub_const [THEN lub_eqI])
+
+subsection {* Finite chains *}
+
+definition max_in_chain :: "nat \<Rightarrow> (nat \<Rightarrow> 'a) \<Rightarrow> bool" where
+  -- {* finite chains, needed for monotony of continuous functions *}
+  "max_in_chain i C \<longleftrightarrow> (\<forall>j. i \<le> j \<longrightarrow> C i = C j)"
+
+definition finite_chain :: "(nat \<Rightarrow> 'a) \<Rightarrow> bool" where
+  "finite_chain C = (chain C \<and> (\<exists>i. max_in_chain i C))"
+
+text {* results about finite chains *}
+
+lemma max_in_chainI: "(\<And>j. i \<le> j \<Longrightarrow> Y i = Y j) \<Longrightarrow> max_in_chain i Y"
+  unfolding max_in_chain_def by fast
+
+lemma max_in_chainD: "\<lbrakk>max_in_chain i Y; i \<le> j\<rbrakk> \<Longrightarrow> Y i = Y j"
+  unfolding max_in_chain_def by fast
+
+lemma finite_chainI:
+  "\<lbrakk>chain C; max_in_chain i C\<rbrakk> \<Longrightarrow> finite_chain C"
+  unfolding finite_chain_def by fast
+
+lemma finite_chainE:
+  "\<lbrakk>finite_chain C; \<And>i. \<lbrakk>chain C; max_in_chain i C\<rbrakk> \<Longrightarrow> R\<rbrakk> \<Longrightarrow> R"
+  unfolding finite_chain_def by fast
+
+lemma lub_finch1: "\<lbrakk>chain C; max_in_chain i C\<rbrakk> \<Longrightarrow> range C <<| C i"
+apply (rule is_lubI)
+apply (rule ub_rangeI, rename_tac j)
+apply (rule_tac x=i and y=j in linorder_le_cases)
+apply (drule (1) max_in_chainD, simp)
+apply (erule (1) chain_mono)
+apply (erule ub_rangeD)
+done
+
+lemma lub_finch2:
+  "finite_chain C \<Longrightarrow> range C <<| C (LEAST i. max_in_chain i C)"
+apply (erule finite_chainE)
+apply (erule LeastI2 [where Q="\<lambda>i. range C <<| C i"])
+apply (erule (1) lub_finch1)
+done
+
+lemma finch_imp_finite_range: "finite_chain Y \<Longrightarrow> finite (range Y)"
+ apply (erule finite_chainE)
+ apply (rule_tac B="Y ` {..i}" in finite_subset)
+  apply (rule subsetI)
+  apply (erule rangeE, rename_tac j)
+  apply (rule_tac x=i and y=j in linorder_le_cases)
+   apply (subgoal_tac "Y j = Y i", simp)
+   apply (simp add: max_in_chain_def)
+  apply simp
+ apply simp
+done
+
+lemma finite_range_has_max:
+  fixes f :: "nat \<Rightarrow> 'a" and r :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
+  assumes mono: "\<And>i j. i \<le> j \<Longrightarrow> r (f i) (f j)"
+  assumes finite_range: "finite (range f)"
+  shows "\<exists>k. \<forall>i. r (f i) (f k)"
+proof (intro exI allI)
+  fix i :: nat
+  let ?j = "LEAST k. f k = f i"
+  let ?k = "Max ((\<lambda>x. LEAST k. f k = x) ` range f)"
+  have "?j \<le> ?k"
+  proof (rule Max_ge)
+    show "finite ((\<lambda>x. LEAST k. f k = x) ` range f)"
+      using finite_range by (rule finite_imageI)
+    show "?j \<in> (\<lambda>x. LEAST k. f k = x) ` range f"
+      by (intro imageI rangeI)
+  qed
+  hence "r (f ?j) (f ?k)"
+    by (rule mono)
+  also have "f ?j = f i"
+    by (rule LeastI, rule refl)
+  finally show "r (f i) (f ?k)" .
+qed
+
+lemma finite_range_imp_finch:
+  "\<lbrakk>chain Y; finite (range Y)\<rbrakk> \<Longrightarrow> finite_chain Y"
+ apply (subgoal_tac "\<exists>k. \<forall>i. Y i \<sqsubseteq> Y k")
+  apply (erule exE)
+  apply (rule finite_chainI, assumption)
+  apply (rule max_in_chainI)
+  apply (rule below_antisym)
+   apply (erule (1) chain_mono)
+  apply (erule spec)
+ apply (rule finite_range_has_max)
+  apply (erule (1) chain_mono)
+ apply assumption
+done
+
+lemma bin_chain: "x \<sqsubseteq> y \<Longrightarrow> chain (\<lambda>i. if i=0 then x else y)"
+  by (rule chainI, simp)
+
+lemma bin_chainmax:
+  "x \<sqsubseteq> y \<Longrightarrow> max_in_chain (Suc 0) (\<lambda>i. if i=0 then x else y)"
+  unfolding max_in_chain_def by simp
+
+lemma is_lub_bin_chain:
+  "x \<sqsubseteq> y \<Longrightarrow> range (\<lambda>i::nat. if i=0 then x else y) <<| y"
+apply (frule bin_chain)
+apply (drule bin_chainmax)
+apply (drule (1) lub_finch1)
+apply simp
+done
+
+text {* the maximal element in a chain is its lub *}
+
+lemma lub_chain_maxelem: "\<lbrakk>Y i = c; \<forall>i. Y i \<sqsubseteq> c\<rbrakk> \<Longrightarrow> lub (range Y) = c"
+  by (blast dest: ub_rangeD intro: lub_eqI is_lubI ub_rangeI)
+
+end
+
+end

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/HOLCF/Powerdomains.thy	Sat Nov 27 16:08:10 2010 -0800
@@ -0,0 +1,51 @@
+(*  Title:      HOLCF/Powerdomains.thy
+    Author:     Brian Huffman
+*)
+
+header {* Powerdomains *}
+
+theory Powerdomains
+imports ConvexPD Domain
+begin
+
+lemma isodefl_upper:
+  "isodefl d t \<Longrightarrow> isodefl (upper_map\<cdot>d) (upper_defl\<cdot>t)"
+apply (rule isodeflI)
+apply (simp add: cast_upper_defl cast_isodefl)
+apply (simp add: emb_upper_pd_def prj_upper_pd_def)
+apply (simp add: upper_map_map)
+done
+
+lemma isodefl_lower:
+  "isodefl d t \<Longrightarrow> isodefl (lower_map\<cdot>d) (lower_defl\<cdot>t)"
+apply (rule isodeflI)
+apply (simp add: cast_lower_defl cast_isodefl)
+apply (simp add: emb_lower_pd_def prj_lower_pd_def)
+apply (simp add: lower_map_map)
+done
+
+lemma isodefl_convex:
+  "isodefl d t \<Longrightarrow> isodefl (convex_map\<cdot>d) (convex_defl\<cdot>t)"
+apply (rule isodeflI)
+apply (simp add: cast_convex_defl cast_isodefl)
+apply (simp add: emb_convex_pd_def prj_convex_pd_def)
+apply (simp add: convex_map_map)
+done
+
+subsection {* Domain package setup for powerdomains *}
+
+lemmas [domain_defl_simps] = DEFL_upper DEFL_lower DEFL_convex
+lemmas [domain_map_ID] = upper_map_ID lower_map_ID convex_map_ID
+lemmas [domain_isodefl] = isodefl_upper isodefl_lower isodefl_convex
+
+lemmas [domain_deflation] =
+  deflation_upper_map deflation_lower_map deflation_convex_map
+
+setup {*
+  fold Domain_Take_Proofs.add_rec_type
+    [(@{type_name "upper_pd"}, [true]),
+     (@{type_name "lower_pd"}, [true]),
+     (@{type_name "convex_pd"}, [true])]
+*}
+
+end

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/HOLCF/Product_Cpo.thy	Sat Nov 27 16:08:10 2010 -0800
@@ -0,0 +1,299 @@
+(*  Title:      HOLCF/Product_Cpo.thy
+    Author:     Franz Regensburger
+*)
+
+header {* The cpo of cartesian products *}
+
+theory Product_Cpo
+imports Adm
+begin
+
+default_sort cpo
+
+subsection {* Unit type is a pcpo *}
+
+instantiation unit :: discrete_cpo
+begin
+
+definition
+  below_unit_def [simp]: "x \<sqsubseteq> (y::unit) \<longleftrightarrow> True"
+
+instance proof
+qed simp
+
+end
+
+instance unit :: pcpo
+by intro_classes simp
+
+
+subsection {* Product type is a partial order *}
+
+instantiation prod :: (below, below) below
+begin
+
+definition
+  below_prod_def: "(op \<sqsubseteq>) \<equiv> \<lambda>p1 p2. (fst p1 \<sqsubseteq> fst p2 \<and> snd p1 \<sqsubseteq> snd p2)"
+
+instance ..
+end
+
+instance prod :: (po, po) po
+proof
+  fix x :: "'a \<times> 'b"
+  show "x \<sqsubseteq> x"
+    unfolding below_prod_def by simp
+next
+  fix x y :: "'a \<times> 'b"
+  assume "x \<sqsubseteq> y" "y \<sqsubseteq> x" thus "x = y"
+    unfolding below_prod_def Pair_fst_snd_eq
+    by (fast intro: below_antisym)
+next
+  fix x y z :: "'a \<times> 'b"
+  assume "x \<sqsubseteq> y" "y \<sqsubseteq> z" thus "x \<sqsubseteq> z"
+    unfolding below_prod_def
+    by (fast intro: below_trans)
+qed
+
+subsection {* Monotonicity of \emph{Pair}, \emph{fst}, \emph{snd} *}
+
+lemma prod_belowI: "\<lbrakk>fst p \<sqsubseteq> fst q; snd p \<sqsubseteq> snd q\<rbrakk> \<Longrightarrow> p \<sqsubseteq> q"
+unfolding below_prod_def by simp
+
+lemma Pair_below_iff [simp]: "(a, b) \<sqsubseteq> (c, d) \<longleftrightarrow> a \<sqsubseteq> c \<and> b \<sqsubseteq> d"
+unfolding below_prod_def by simp
+
+text {* Pair @{text "(_,_)"}  is monotone in both arguments *}
+
+lemma monofun_pair1: "monofun (\<lambda>x. (x, y))"
+by (simp add: monofun_def)
+
+lemma monofun_pair2: "monofun (\<lambda>y. (x, y))"
+by (simp add: monofun_def)
+
+lemma monofun_pair:
+  "\<lbrakk>x1 \<sqsubseteq> x2; y1 \<sqsubseteq> y2\<rbrakk> \<Longrightarrow> (x1, y1) \<sqsubseteq> (x2, y2)"
+by simp
+
+lemma ch2ch_Pair [simp]:
+  "chain X \<Longrightarrow> chain Y \<Longrightarrow> chain (\<lambda>i. (X i, Y i))"
+by (rule chainI, simp add: chainE)
+
+text {* @{term fst} and @{term snd} are monotone *}
+
+lemma fst_monofun: "x \<sqsubseteq> y \<Longrightarrow> fst x \<sqsubseteq> fst y"
+unfolding below_prod_def by simp
+
+lemma snd_monofun: "x \<sqsubseteq> y \<Longrightarrow> snd x \<sqsubseteq> snd y"
+unfolding below_prod_def by simp
+
+lemma monofun_fst: "monofun fst"
+by (simp add: monofun_def below_prod_def)
+
+lemma monofun_snd: "monofun snd"
+by (simp add: monofun_def below_prod_def)
+
+lemmas ch2ch_fst [simp] = ch2ch_monofun [OF monofun_fst]
+
+lemmas ch2ch_snd [simp] = ch2ch_monofun [OF monofun_snd]
+
+lemma prod_chain_cases:
+  assumes "chain Y"
+  obtains A B
+  where "chain A" and "chain B" and "Y = (\<lambda>i. (A i, B i))"
+proof
+  from `chain Y` show "chain (\<lambda>i. fst (Y i))" by (rule ch2ch_fst)
+  from `chain Y` show "chain (\<lambda>i. snd (Y i))" by (rule ch2ch_snd)
+  show "Y = (\<lambda>i. (fst (Y i), snd (Y i)))" by simp
+qed
+
+subsection {* Product type is a cpo *}
+
+lemma is_lub_Pair:
+  "\<lbrakk>range A <<| x; range B <<| y\<rbrakk> \<Longrightarrow> range (\<lambda>i. (A i, B i)) <<| (x, y)"
+unfolding is_lub_def is_ub_def ball_simps below_prod_def by simp
+
+lemma lub_Pair:
+  "\<lbrakk>chain (A::nat \<Rightarrow> 'a::cpo); chain (B::nat \<Rightarrow> 'b::cpo)\<rbrakk>
+    \<Longrightarrow> (\<Squnion>i. (A i, B i)) = (\<Squnion>i. A i, \<Squnion>i. B i)"
+by (fast intro: lub_eqI is_lub_Pair elim: thelubE)
+
+lemma is_lub_prod:
+  fixes S :: "nat \<Rightarrow> ('a::cpo \<times> 'b::cpo)"
+  assumes S: "chain S"
+  shows "range S <<| (\<Squnion>i. fst (S i), \<Squnion>i. snd (S i))"
+using S by (auto elim: prod_chain_cases simp add: is_lub_Pair cpo_lubI)
+
+lemma lub_prod:
+  "chain (S::nat \<Rightarrow> 'a::cpo \<times> 'b::cpo)
+    \<Longrightarrow> (\<Squnion>i. S i) = (\<Squnion>i. fst (S i), \<Squnion>i. snd (S i))"
+by (rule is_lub_prod [THEN lub_eqI])
+
+instance prod :: (cpo, cpo) cpo
+proof
+  fix S :: "nat \<Rightarrow> ('a \<times> 'b)"
+  assume "chain S"
+  hence "range S <<| (\<Squnion>i. fst (S i), \<Squnion>i. snd (S i))"
+    by (rule is_lub_prod)
+  thus "\<exists>x. range S <<| x" ..
+qed
+
+instance prod :: (discrete_cpo, discrete_cpo) discrete_cpo
+proof
+  fix x y :: "'a \<times> 'b"
+  show "x \<sqsubseteq> y \<longleftrightarrow> x = y"
+    unfolding below_prod_def Pair_fst_snd_eq
+    by simp
+qed
+
+subsection {* Product type is pointed *}
+
+lemma minimal_prod: "(\<bottom>, \<bottom>) \<sqsubseteq> p"
+by (simp add: below_prod_def)
+
+instance prod :: (pcpo, pcpo) pcpo
+by intro_classes (fast intro: minimal_prod)
+
+lemma inst_prod_pcpo: "\<bottom> = (\<bottom>, \<bottom>)"
+by (rule minimal_prod [THEN UU_I, symmetric])
+
+lemma Pair_bottom_iff [simp]: "(x, y) = \<bottom> \<longleftrightarrow> x = \<bottom> \<and> y = \<bottom>"
+unfolding inst_prod_pcpo by simp
+
+lemma fst_strict [simp]: "fst \<bottom> = \<bottom>"
+unfolding inst_prod_pcpo by (rule fst_conv)
+
+lemma snd_strict [simp]: "snd \<bottom> = \<bottom>"
+unfolding inst_prod_pcpo by (rule snd_conv)
+
+lemma Pair_strict [simp]: "(\<bottom>, \<bottom>) = \<bottom>"
+by simp
+
+lemma split_strict [simp]: "split f \<bottom> = f \<bottom> \<bottom>"
+unfolding split_def by simp
+
+subsection {* Continuity of \emph{Pair}, \emph{fst}, \emph{snd} *}
+
+lemma cont_pair1: "cont (\<lambda>x. (x, y))"
+apply (rule contI)
+apply (rule is_lub_Pair)
+apply (erule cpo_lubI)
+apply (rule is_lub_const)
+done
+
+lemma cont_pair2: "cont (\<lambda>y. (x, y))"
+apply (rule contI)
+apply (rule is_lub_Pair)
+apply (rule is_lub_const)
+apply (erule cpo_lubI)
+done
+
+lemma cont_fst: "cont fst"
+apply (rule contI)
+apply (simp add: lub_prod)
+apply (erule cpo_lubI [OF ch2ch_fst])
+done
+
+lemma cont_snd: "cont snd"
+apply (rule contI)
+apply (simp add: lub_prod)
+apply (erule cpo_lubI [OF ch2ch_snd])
+done
+
+lemma cont2cont_Pair [simp, cont2cont]:
+  assumes f: "cont (\<lambda>x. f x)"
+  assumes g: "cont (\<lambda>x. g x)"
+  shows "cont (\<lambda>x. (f x, g x))"
+apply (rule cont_apply [OF f cont_pair1])
+apply (rule cont_apply [OF g cont_pair2])
+apply (rule cont_const)
+done
+
+lemmas cont2cont_fst [simp, cont2cont] = cont_compose [OF cont_fst]
+
+lemmas cont2cont_snd [simp, cont2cont] = cont_compose [OF cont_snd]
+
+lemma cont2cont_prod_case:
+  assumes f1: "\<And>a b. cont (\<lambda>x. f x a b)"
+  assumes f2: "\<And>x b. cont (\<lambda>a. f x a b)"
+  assumes f3: "\<And>x a. cont (\<lambda>b. f x a b)"
+  assumes g: "cont (\<lambda>x. g x)"
+  shows "cont (\<lambda>x. case g x of (a, b) \<Rightarrow> f x a b)"
+unfolding split_def
+apply (rule cont_apply [OF g])
+apply (rule cont_apply [OF cont_fst f2])
+apply (rule cont_apply [OF cont_snd f3])
+apply (rule cont_const)
+apply (rule f1)
+done
+
+lemma prod_contI:
+  assumes f1: "\<And>y. cont (\<lambda>x. f (x, y))"
+  assumes f2: "\<And>x. cont (\<lambda>y. f (x, y))"
+  shows "cont f"
+proof -
+  have "cont (\<lambda>(x, y). f (x, y))"
+    by (intro cont2cont_prod_case f1 f2 cont2cont)
+  thus "cont f"
+    by (simp only: split_eta)
+qed
+
+lemma prod_cont_iff:
+  "cont f \<longleftrightarrow> (\<forall>y. cont (\<lambda>x. f (x, y))) \<and> (\<forall>x. cont (\<lambda>y. f (x, y)))"
+apply safe
+apply (erule cont_compose [OF _ cont_pair1])
+apply (erule cont_compose [OF _ cont_pair2])
+apply (simp only: prod_contI)
+done
+
+lemma cont2cont_prod_case' [simp, cont2cont]:
+  assumes f: "cont (\<lambda>p. f (fst p) (fst (snd p)) (snd (snd p)))"
+  assumes g: "cont (\<lambda>x. g x)"
+  shows "cont (\<lambda>x. prod_case (f x) (g x))"
+using assms by (simp add: cont2cont_prod_case prod_cont_iff)
+
+text {* The simple version (due to Joachim Breitner) is needed if
+  either element type of the pair is not a cpo. *}
+
+lemma cont2cont_split_simple [simp, cont2cont]:
+ assumes "\<And>a b. cont (\<lambda>x. f x a b)"
+ shows "cont (\<lambda>x. case p of (a, b) \<Rightarrow> f x a b)"
+using assms by (cases p) auto
+
+text {* Admissibility of predicates on product types. *}
+
+lemma adm_prod_case [simp]:
+  assumes "adm (\<lambda>x. P x (fst (f x)) (snd (f x)))"
+  shows "adm (\<lambda>x. case f x of (a, b) \<Rightarrow> P x a b)"
+unfolding prod_case_beta using assms .
+
+subsection {* Compactness and chain-finiteness *}
+
+lemma fst_below_iff: "fst (x::'a \<times> 'b) \<sqsubseteq> y \<longleftrightarrow> x \<sqsubseteq> (y, snd x)"
+unfolding below_prod_def by simp
+
+lemma snd_below_iff: "snd (x::'a \<times> 'b) \<sqsubseteq> y \<longleftrightarrow> x \<sqsubseteq> (fst x, y)"
+unfolding below_prod_def by simp
+
+lemma compact_fst: "compact x \<Longrightarrow> compact (fst x)"
+by (rule compactI, simp add: fst_below_iff)
+
+lemma compact_snd: "compact x \<Longrightarrow> compact (snd x)"
+by (rule compactI, simp add: snd_below_iff)
+
+lemma compact_Pair: "\<lbrakk>compact x; compact y\<rbrakk> \<Longrightarrow> compact (x, y)"
+by (rule compactI, simp add: below_prod_def)
+
+lemma compact_Pair_iff [simp]: "compact (x, y) \<longleftrightarrow> compact x \<and> compact y"
+apply (safe intro!: compact_Pair)
+apply (drule compact_fst, simp)
+apply (drule compact_snd, simp)
+done
+
+instance prod :: (chfin, chfin) chfin
+apply intro_classes
+apply (erule compact_imp_max_in_chain)
+apply (case_tac "\<Squnion>i. Y i", simp)
+done
+
+end

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/HOLCF/README.html	Sat Nov 27 16:08:10 2010 -0800
@@ -0,0 +1,45 @@
+<!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>HOLCF: A higher-order version of LCF based on Isabelle/HOL</h3>
+
+HOLCF is the definitional extension of Church's Higher-Order Logic with
+Scott's Logic for Computable Functions that has been implemented in the
+theorem prover Isabelle.  This results in a flexible setup for reasoning
+about functional programs. HOLCF supports standard domain theory (in particular
+fixpoint reasoning and recursive domain equations) but also coinductive
+arguments about lazy datatypes.
+
+<p>
+
+The most recent description of HOLCF is found here:
+
+<ul>
+  <li><a href="/~nipkow/pubs/jfp99.html">HOLCF = HOL+LCF</a>
+</ul>
+
+A detailed description (in German) of the entire development can be found in:
+
+<ul>
+  <li><a href="http://www4.informatik.tu-muenchen.de/publ/papers/Diss_Regensbu.pdf">HOLCF: eine konservative Erweiterung von HOL um LCF</a>, <br>
+      Franz Regensburger.<br>
+      Dissertation Technische Universit&auml;t M&uuml;nchen.<br>
+      Year: 1994.
+</ul>
+
+A short survey is available in:
+<ul>
+  <li><a href="http://www4.informatik.tu-muenchen.de/publ/papers/Regensburger_HOLT1995.pdf">HOLCF: Higher Order Logic of Computable Functions</a><br>
+</ul>
+
+</body>
+
+</html>

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/HOLCF/ROOT.ML	Sat Nov 27 16:08:10 2010 -0800
@@ -0,0 +1,9 @@
+(*  Title:      HOLCF/ROOT.ML
+    Author:     Franz Regensburger
+
+HOLCF -- a semantic extension of HOL by the LCF logic.
+*)
+
+no_document use_thys ["Nat_Bijection", "Countable"];
+
+use_thys ["Plain_HOLCF", "Fixrec", "HOLCF"];

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/HOLCF/Sfun.thy	Sat Nov 27 16:08:10 2010 -0800
@@ -0,0 +1,62 @@
+(*  Title:      HOLCF/Sfun.thy
+    Author:     Brian Huffman
+*)
+
+header {* The Strict Function Type *}
+
+theory Sfun
+imports Cfun
+begin
+
+pcpodef (open) ('a, 'b) sfun (infixr "->!" 0)
+  = "{f :: 'a \<rightarrow> 'b. f\<cdot>\<bottom> = \<bottom>}"
+by simp_all
+
+type_notation (xsymbols)
+  sfun  (infixr "\<rightarrow>!" 0)
+
+text {* TODO: Define nice syntax for abstraction, application. *}
+
+definition
+  sfun_abs :: "('a \<rightarrow> 'b) \<rightarrow> ('a \<rightarrow>! 'b)"
+where
+  "sfun_abs = (\<Lambda> f. Abs_sfun (strictify\<cdot>f))"
+
+definition
+  sfun_rep :: "('a \<rightarrow>! 'b) \<rightarrow> 'a \<rightarrow> 'b"
+where
+  "sfun_rep = (\<Lambda> f. Rep_sfun f)"
+
+lemma sfun_rep_beta: "sfun_rep\<cdot>f = Rep_sfun f"
+  unfolding sfun_rep_def by (simp add: cont_Rep_sfun)
+
+lemma sfun_rep_strict1 [simp]: "sfun_rep\<cdot>\<bottom> = \<bottom>"
+  unfolding sfun_rep_beta by (rule Rep_sfun_strict)
+
+lemma sfun_rep_strict2 [simp]: "sfun_rep\<cdot>f\<cdot>\<bottom> = \<bottom>"
+  unfolding sfun_rep_beta by (rule Rep_sfun [simplified])
+
+lemma strictify_cancel: "f\<cdot>\<bottom> = \<bottom> \<Longrightarrow> strictify\<cdot>f = f"
+  by (simp add: cfun_eq_iff strictify_conv_if)
+
+lemma sfun_abs_sfun_rep [simp]: "sfun_abs\<cdot>(sfun_rep\<cdot>f) = f"
+  unfolding sfun_abs_def sfun_rep_def
+  apply (simp add: cont_Abs_sfun cont_Rep_sfun)
+  apply (simp add: Rep_sfun_inject [symmetric] Abs_sfun_inverse)
+  apply (simp add: cfun_eq_iff strictify_conv_if)
+  apply (simp add: Rep_sfun [simplified])
+  done
+
+lemma sfun_rep_sfun_abs [simp]: "sfun_rep\<cdot>(sfun_abs\<cdot>f) = strictify\<cdot>f"
+  unfolding sfun_abs_def sfun_rep_def
+  apply (simp add: cont_Abs_sfun cont_Rep_sfun)
+  apply (simp add: Abs_sfun_inverse)
+  done
+
+lemma sfun_eq_iff: "f = g \<longleftrightarrow> sfun_rep\<cdot>f = sfun_rep\<cdot>g"
+by (simp add: sfun_rep_def cont_Rep_sfun Rep_sfun_inject)
+
+lemma sfun_below_iff: "f \<sqsubseteq> g \<longleftrightarrow> sfun_rep\<cdot>f \<sqsubseteq> sfun_rep\<cdot>g"
+by (simp add: sfun_rep_def cont_Rep_sfun below_sfun_def)
+
+end

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/HOLCF/Sprod.thy	Sat Nov 27 16:08:10 2010 -0800
@@ -0,0 +1,214 @@
+(*  Title:      HOLCF/Sprod.thy
+    Author:     Franz Regensburger
+    Author:     Brian Huffman
+*)
+
+header {* The type of strict products *}
+
+theory Sprod
+imports Cfun
+begin
+
+default_sort pcpo
+
+subsection {* Definition of strict product type *}
+
+pcpodef ('a, 'b) sprod (infixr "**" 20) =
+        "{p::'a \<times> 'b. p = \<bottom> \<or> (fst p \<noteq> \<bottom> \<and> snd p \<noteq> \<bottom>)}"
+by simp_all
+
+instance sprod :: ("{chfin,pcpo}", "{chfin,pcpo}") chfin
+by (rule typedef_chfin [OF type_definition_sprod below_sprod_def])
+
+type_notation (xsymbols)
+  sprod  ("(_ \<otimes>/ _)" [21,20] 20)
+type_notation (HTML output)
+  sprod  ("(_ \<otimes>/ _)" [21,20] 20)
+
+subsection {* Definitions of constants *}
+
+definition
+  sfst :: "('a ** 'b) \<rightarrow> 'a" where
+  "sfst = (\<Lambda> p. fst (Rep_sprod p))"
+
+definition
+  ssnd :: "('a ** 'b) \<rightarrow> 'b" where
+  "ssnd = (\<Lambda> p. snd (Rep_sprod p))"
+
+definition
+  spair :: "'a \<rightarrow> 'b \<rightarrow> ('a ** 'b)" where
+  "spair = (\<Lambda> a b. Abs_sprod (seq\<cdot>b\<cdot>a, seq\<cdot>a\<cdot>b))"
+
+definition
+  ssplit :: "('a \<rightarrow> 'b \<rightarrow> 'c) \<rightarrow> ('a ** 'b) \<rightarrow> 'c" where
+  "ssplit = (\<Lambda> f p. seq\<cdot>p\<cdot>(f\<cdot>(sfst\<cdot>p)\<cdot>(ssnd\<cdot>p)))"
+
+syntax
+  "_stuple" :: "['a, args] => 'a ** 'b"  ("(1'(:_,/ _:'))")
+translations
+  "(:x, y, z:)" == "(:x, (:y, z:):)"
+  "(:x, y:)"    == "CONST spair\<cdot>x\<cdot>y"
+
+translations
+  "\<Lambda>(CONST spair\<cdot>x\<cdot>y). t" == "CONST ssplit\<cdot>(\<Lambda> x y. t)"
+
+subsection {* Case analysis *}
+
+lemma spair_sprod: "(seq\<cdot>b\<cdot>a, seq\<cdot>a\<cdot>b) \<in> sprod"
+by (simp add: sprod_def seq_conv_if)
+
+lemma Rep_sprod_spair: "Rep_sprod (:a, b:) = (seq\<cdot>b\<cdot>a, seq\<cdot>a\<cdot>b)"
+by (simp add: spair_def cont_Abs_sprod Abs_sprod_inverse spair_sprod)
+
+lemmas Rep_sprod_simps =
+  Rep_sprod_inject [symmetric] below_sprod_def
+  Pair_fst_snd_eq below_prod_def
+  Rep_sprod_strict Rep_sprod_spair
+
+lemma sprodE [case_names bottom spair, cases type: sprod]:
+  obtains "p = \<bottom>" | x y where "p = (:x, y:)" and "x \<noteq> \<bottom>" and "y \<noteq> \<bottom>"
+using Rep_sprod [of p] by (auto simp add: sprod_def Rep_sprod_simps)
+
+lemma sprod_induct [case_names bottom spair, induct type: sprod]:
+  "\<lbrakk>P \<bottom>; \<And>x y. \<lbrakk>x \<noteq> \<bottom>; y \<noteq> \<bottom>\<rbrakk> \<Longrightarrow> P (:x, y:)\<rbrakk> \<Longrightarrow> P x"
+by (cases x, simp_all)
+
+subsection {* Properties of \emph{spair} *}
+
+lemma spair_strict1 [simp]: "(:\<bottom>, y:) = \<bottom>"
+by (simp add: Rep_sprod_simps)
+
+lemma spair_strict2 [simp]: "(:x, \<bottom>:) = \<bottom>"
+by (simp add: Rep_sprod_simps)
+
+lemma spair_bottom_iff [simp]: "((:x, y:) = \<bottom>) = (x = \<bottom> \<or> y = \<bottom>)"
+by (simp add: Rep_sprod_simps seq_conv_if)
+
+lemma spair_below_iff:
+  "((:a, b:) \<sqsubseteq> (:c, d:)) = (a = \<bottom> \<or> b = \<bottom> \<or> (a \<sqsubseteq> c \<and> b \<sqsubseteq> d))"
+by (simp add: Rep_sprod_simps seq_conv_if)
+
+lemma spair_eq_iff:
+  "((:a, b:) = (:c, d:)) =
+    (a = c \<and> b = d \<or> (a = \<bottom> \<or> b = \<bottom>) \<and> (c = \<bottom> \<or> d = \<bottom>))"
+by (simp add: Rep_sprod_simps seq_conv_if)
+
+lemma spair_strict: "x = \<bottom> \<or> y = \<bottom> \<Longrightarrow> (:x, y:) = \<bottom>"
+by simp
+
+lemma spair_strict_rev: "(:x, y:) \<noteq> \<bottom> \<Longrightarrow> x \<noteq> \<bottom> \<and> y \<noteq> \<bottom>"
+by simp
+
+lemma spair_defined: "\<lbrakk>x \<noteq> \<bottom>; y \<noteq> \<bottom>\<rbrakk> \<Longrightarrow> (:x, y:) \<noteq> \<bottom>"
+by simp
+
+lemma spair_defined_rev: "(:x, y:) = \<bottom> \<Longrightarrow> x = \<bottom> \<or> y = \<bottom>"
+by simp
+
+lemma spair_below:
+  "\<lbrakk>x \<noteq> \<bottom>; y \<noteq> \<bottom>\<rbrakk> \<Longrightarrow> (:x, y:) \<sqsubseteq> (:a, b:) = (x \<sqsubseteq> a \<and> y \<sqsubseteq> b)"
+by (simp add: spair_below_iff)
+
+lemma spair_eq:
+  "\<lbrakk>x \<noteq> \<bottom>; y \<noteq> \<bottom>\<rbrakk> \<Longrightarrow> ((:x, y:) = (:a, b:)) = (x = a \<and> y = b)"
+by (simp add: spair_eq_iff)
+
+lemma spair_inject:
+  "\<lbrakk>x \<noteq> \<bottom>; y \<noteq> \<bottom>; (:x, y:) = (:a, b:)\<rbrakk> \<Longrightarrow> x = a \<and> y = b"
+by (rule spair_eq [THEN iffD1])
+
+lemma inst_sprod_pcpo2: "UU = (:UU,UU:)"
+by simp
+
+lemma sprodE2: "(\<And>x y. p = (:x, y:) \<Longrightarrow> Q) \<Longrightarrow> Q"
+by (cases p, simp only: inst_sprod_pcpo2, simp)
+
+subsection {* Properties of \emph{sfst} and \emph{ssnd} *}
+
+lemma sfst_strict [simp]: "sfst\<cdot>\<bottom> = \<bottom>"
+by (simp add: sfst_def cont_Rep_sprod Rep_sprod_strict)
+
+lemma ssnd_strict [simp]: "ssnd\<cdot>\<bottom> = \<bottom>"
+by (simp add: ssnd_def cont_Rep_sprod Rep_sprod_strict)
+
+lemma sfst_spair [simp]: "y \<noteq> \<bottom> \<Longrightarrow> sfst\<cdot>(:x, y:) = x"
+by (simp add: sfst_def cont_Rep_sprod Rep_sprod_spair)
+
+lemma ssnd_spair [simp]: "x \<noteq> \<bottom> \<Longrightarrow> ssnd\<cdot>(:x, y:) = y"
+by (simp add: ssnd_def cont_Rep_sprod Rep_sprod_spair)
+
+lemma sfst_bottom_iff [simp]: "(sfst\<cdot>p = \<bottom>) = (p = \<bottom>)"
+by (cases p, simp_all)
+
+lemma ssnd_bottom_iff [simp]: "(ssnd\<cdot>p = \<bottom>) = (p = \<bottom>)"
+by (cases p, simp_all)
+
+lemma sfst_defined: "p \<noteq> \<bottom> \<Longrightarrow> sfst\<cdot>p \<noteq> \<bottom>"
+by simp
+
+lemma ssnd_defined: "p \<noteq> \<bottom> \<Longrightarrow> ssnd\<cdot>p \<noteq> \<bottom>"
+by simp
+
+lemma spair_sfst_ssnd: "(:sfst\<cdot>p, ssnd\<cdot>p:) = p"
+by (cases p, simp_all)
+
+lemma below_sprod: "(x \<sqsubseteq> y) = (sfst\<cdot>x \<sqsubseteq> sfst\<cdot>y \<and> ssnd\<cdot>x \<sqsubseteq> ssnd\<cdot>y)"
+by (simp add: Rep_sprod_simps sfst_def ssnd_def cont_Rep_sprod)
+
+lemma eq_sprod: "(x = y) = (sfst\<cdot>x = sfst\<cdot>y \<and> ssnd\<cdot>x = ssnd\<cdot>y)"
+by (auto simp add: po_eq_conv below_sprod)
+
+lemma sfst_below_iff: "sfst\<cdot>x \<sqsubseteq> y \<longleftrightarrow> x \<sqsubseteq> (:y, ssnd\<cdot>x:)"
+apply (cases "x = \<bottom>", simp, cases "y = \<bottom>", simp)
+apply (simp add: below_sprod)
+done
+
+lemma ssnd_below_iff: "ssnd\<cdot>x \<sqsubseteq> y \<longleftrightarrow> x \<sqsubseteq> (:sfst\<cdot>x, y:)"
+apply (cases "x = \<bottom>", simp, cases "y = \<bottom>", simp)
+apply (simp add: below_sprod)
+done
+
+subsection {* Compactness *}
+
+lemma compact_sfst: "compact x \<Longrightarrow> compact (sfst\<cdot>x)"
+by (rule compactI, simp add: sfst_below_iff)
+
+lemma compact_ssnd: "compact x \<Longrightarrow> compact (ssnd\<cdot>x)"
+by (rule compactI, simp add: ssnd_below_iff)
+
+lemma compact_spair: "\<lbrakk>compact x; compact y\<rbrakk> \<Longrightarrow> compact (:x, y:)"
+by (rule compact_sprod, simp add: Rep_sprod_spair seq_conv_if)
+
+lemma compact_spair_iff:
+  "compact (:x, y:) = (x = \<bottom> \<or> y = \<bottom> \<or> (compact x \<and> compact y))"
+apply (safe elim!: compact_spair)
+apply (drule compact_sfst, simp)
+apply (drule compact_ssnd, simp)
+apply simp
+apply simp
+done
+
+subsection {* Properties of \emph{ssplit} *}
+
+lemma ssplit1 [simp]: "ssplit\<cdot>f\<cdot>\<bottom> = \<bottom>"
+by (simp add: ssplit_def)
+
+lemma ssplit2 [simp]: "\<lbrakk>x \<noteq> \<bottom>; y \<noteq> \<bottom>\<rbrakk> \<Longrightarrow> ssplit\<cdot>f\<cdot>(:x, y:) = f\<cdot>x\<cdot>y"
+by (simp add: ssplit_def)
+
+lemma ssplit3 [simp]: "ssplit\<cdot>spair\<cdot>z = z"
+by (cases z, simp_all)
+
+subsection {* Strict product preserves flatness *}
+
+instance sprod :: (flat, flat) flat
+proof
+  fix x y :: "'a \<otimes> 'b"
+  assume "x \<sqsubseteq> y" thus "x = \<bottom> \<or> x = y"
+    apply (induct x, simp)
+    apply (induct y, simp)
+    apply (simp add: spair_below_iff flat_below_iff)
+    done
+qed
+
+end

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/HOLCF/Ssum.thy	Sat Nov 27 16:08:10 2010 -0800
@@ -0,0 +1,198 @@
+(*  Title:      HOLCF/Ssum.thy
+    Author:     Franz Regensburger
+    Author:     Brian Huffman
+*)
+
+header {* The type of strict sums *}
+
+theory Ssum
+imports Tr
+begin
+
+default_sort pcpo
+
+subsection {* Definition of strict sum type *}
+
+pcpodef ('a, 'b) ssum (infixr "++" 10) = 
+  "{p :: tr \<times> ('a \<times> 'b). p = \<bottom> \<or>
+    (fst p = TT \<and> fst (snd p) \<noteq> \<bottom> \<and> snd (snd p) = \<bottom>) \<or>
+    (fst p = FF \<and> fst (snd p) = \<bottom> \<and> snd (snd p) \<noteq> \<bottom>) }"
+by simp_all
+
+instance ssum :: ("{chfin,pcpo}", "{chfin,pcpo}") chfin
+by (rule typedef_chfin [OF type_definition_ssum below_ssum_def])
+
+type_notation (xsymbols)
+  ssum  ("(_ \<oplus>/ _)" [21, 20] 20)
+type_notation (HTML output)
+  ssum  ("(_ \<oplus>/ _)" [21, 20] 20)
+
+
+subsection {* Definitions of constructors *}
+
+definition
+  sinl :: "'a \<rightarrow> ('a ++ 'b)" where
+  "sinl = (\<Lambda> a. Abs_ssum (seq\<cdot>a\<cdot>TT, a, \<bottom>))"
+
+definition
+  sinr :: "'b \<rightarrow> ('a ++ 'b)" where
+  "sinr = (\<Lambda> b. Abs_ssum (seq\<cdot>b\<cdot>FF, \<bottom>, b))"
+
+lemma sinl_ssum: "(seq\<cdot>a\<cdot>TT, a, \<bottom>) \<in> ssum"
+by (simp add: ssum_def seq_conv_if)
+
+lemma sinr_ssum: "(seq\<cdot>b\<cdot>FF, \<bottom>, b) \<in> ssum"
+by (simp add: ssum_def seq_conv_if)
+
+lemma Rep_ssum_sinl: "Rep_ssum (sinl\<cdot>a) = (seq\<cdot>a\<cdot>TT, a, \<bottom>)"
+by (simp add: sinl_def cont_Abs_ssum Abs_ssum_inverse sinl_ssum)
+
+lemma Rep_ssum_sinr: "Rep_ssum (sinr\<cdot>b) = (seq\<cdot>b\<cdot>FF, \<bottom>, b)"
+by (simp add: sinr_def cont_Abs_ssum Abs_ssum_inverse sinr_ssum)
+
+lemmas Rep_ssum_simps =
+  Rep_ssum_inject [symmetric] below_ssum_def
+  Pair_fst_snd_eq below_prod_def
+  Rep_ssum_strict Rep_ssum_sinl Rep_ssum_sinr
+
+subsection {* Properties of \emph{sinl} and \emph{sinr} *}
+
+text {* Ordering *}
+
+lemma sinl_below [simp]: "(sinl\<cdot>x \<sqsubseteq> sinl\<cdot>y) = (x \<sqsubseteq> y)"
+by (simp add: Rep_ssum_simps seq_conv_if)
+
+lemma sinr_below [simp]: "(sinr\<cdot>x \<sqsubseteq> sinr\<cdot>y) = (x \<sqsubseteq> y)"
+by (simp add: Rep_ssum_simps seq_conv_if)
+
+lemma sinl_below_sinr [simp]: "(sinl\<cdot>x \<sqsubseteq> sinr\<cdot>y) = (x = \<bottom>)"
+by (simp add: Rep_ssum_simps seq_conv_if)
+
+lemma sinr_below_sinl [simp]: "(sinr\<cdot>x \<sqsubseteq> sinl\<cdot>y) = (x = \<bottom>)"
+by (simp add: Rep_ssum_simps seq_conv_if)
+
+text {* Equality *}
+
+lemma sinl_eq [simp]: "(sinl\<cdot>x = sinl\<cdot>y) = (x = y)"
+by (simp add: po_eq_conv)
+
+lemma sinr_eq [simp]: "(sinr\<cdot>x = sinr\<cdot>y) = (x = y)"
+by (simp add: po_eq_conv)
+
+lemma sinl_eq_sinr [simp]: "(sinl\<cdot>x = sinr\<cdot>y) = (x = \<bottom> \<and> y = \<bottom>)"
+by (subst po_eq_conv, simp)
+
+lemma sinr_eq_sinl [simp]: "(sinr\<cdot>x = sinl\<cdot>y) = (x = \<bottom> \<and> y = \<bottom>)"
+by (subst po_eq_conv, simp)
+
+lemma sinl_inject: "sinl\<cdot>x = sinl\<cdot>y \<Longrightarrow> x = y"
+by (rule sinl_eq [THEN iffD1])
+
+lemma sinr_inject: "sinr\<cdot>x = sinr\<cdot>y \<Longrightarrow> x = y"
+by (rule sinr_eq [THEN iffD1])
+
+text {* Strictness *}
+
+lemma sinl_strict [simp]: "sinl\<cdot>\<bottom> = \<bottom>"
+by (simp add: Rep_ssum_simps)
+
+lemma sinr_strict [simp]: "sinr\<cdot>\<bottom> = \<bottom>"
+by (simp add: Rep_ssum_simps)
+
+lemma sinl_bottom_iff [simp]: "(sinl\<cdot>x = \<bottom>) = (x = \<bottom>)"
+using sinl_eq [of "x" "\<bottom>"] by simp
+
+lemma sinr_bottom_iff [simp]: "(sinr\<cdot>x = \<bottom>) = (x = \<bottom>)"
+using sinr_eq [of "x" "\<bottom>"] by simp
+
+lemma sinl_defined: "x \<noteq> \<bottom> \<Longrightarrow> sinl\<cdot>x \<noteq> \<bottom>"
+by simp
+
+lemma sinr_defined: "x \<noteq> \<bottom> \<Longrightarrow> sinr\<cdot>x \<noteq> \<bottom>"
+by simp
+
+text {* Compactness *}
+
+lemma compact_sinl: "compact x \<Longrightarrow> compact (sinl\<cdot>x)"
+by (rule compact_ssum, simp add: Rep_ssum_sinl)
+
+lemma compact_sinr: "compact x \<Longrightarrow> compact (sinr\<cdot>x)"
+by (rule compact_ssum, simp add: Rep_ssum_sinr)
+
+lemma compact_sinlD: "compact (sinl\<cdot>x) \<Longrightarrow> compact x"
+unfolding compact_def
+by (drule adm_subst [OF cont_Rep_cfun2 [where f=sinl]], simp)
+
+lemma compact_sinrD: "compact (sinr\<cdot>x) \<Longrightarrow> compact x"
+unfolding compact_def
+by (drule adm_subst [OF cont_Rep_cfun2 [where f=sinr]], simp)
+
+lemma compact_sinl_iff [simp]: "compact (sinl\<cdot>x) = compact x"
+by (safe elim!: compact_sinl compact_sinlD)
+
+lemma compact_sinr_iff [simp]: "compact (sinr\<cdot>x) = compact x"
+by (safe elim!: compact_sinr compact_sinrD)
+
+subsection {* Case analysis *}
+
+lemma ssumE [case_names bottom sinl sinr, cases type: ssum]:
+  obtains "p = \<bottom>"
+  | x where "p = sinl\<cdot>x" and "x \<noteq> \<bottom>"
+  | y where "p = sinr\<cdot>y" and "y \<noteq> \<bottom>"
+using Rep_ssum [of p] by (auto simp add: ssum_def Rep_ssum_simps)
+
+lemma ssum_induct [case_names bottom sinl sinr, induct type: ssum]:
+  "\<lbrakk>P \<bottom>;
+   \<And>x. x \<noteq> \<bottom> \<Longrightarrow> P (sinl\<cdot>x);
+   \<And>y. y \<noteq> \<bottom> \<Longrightarrow> P (sinr\<cdot>y)\<rbrakk> \<Longrightarrow> P x"
+by (cases x, simp_all)
+
+lemma ssumE2 [case_names sinl sinr]:
+  "\<lbrakk>\<And>x. p = sinl\<cdot>x \<Longrightarrow> Q; \<And>y. p = sinr\<cdot>y \<Longrightarrow> Q\<rbrakk> \<Longrightarrow> Q"
+by (cases p, simp only: sinl_strict [symmetric], simp, simp)
+
+lemma below_sinlD: "p \<sqsubseteq> sinl\<cdot>x \<Longrightarrow> \<exists>y. p = sinl\<cdot>y \<and> y \<sqsubseteq> x"
+by (cases p, rule_tac x="\<bottom>" in exI, simp_all)
+
+lemma below_sinrD: "p \<sqsubseteq> sinr\<cdot>x \<Longrightarrow> \<exists>y. p = sinr\<cdot>y \<and> y \<sqsubseteq> x"
+by (cases p, rule_tac x="\<bottom>" in exI, simp_all)
+
+subsection {* Case analysis combinator *}
+
+definition
+  sscase :: "('a \<rightarrow> 'c) \<rightarrow> ('b \<rightarrow> 'c) \<rightarrow> ('a ++ 'b) \<rightarrow> 'c" where
+  "sscase = (\<Lambda> f g s. (\<lambda>(t, x, y). If t then f\<cdot>x else g\<cdot>y) (Rep_ssum s))"
+
+translations
+  "case s of XCONST sinl\<cdot>x \<Rightarrow> t1 | XCONST sinr\<cdot>y \<Rightarrow> t2" == "CONST sscase\<cdot>(\<Lambda> x. t1)\<cdot>(\<Lambda> y. t2)\<cdot>s"
+
+translations
+  "\<Lambda>(XCONST sinl\<cdot>x). t" == "CONST sscase\<cdot>(\<Lambda> x. t)\<cdot>\<bottom>"
+  "\<Lambda>(XCONST sinr\<cdot>y). t" == "CONST sscase\<cdot>\<bottom>\<cdot>(\<Lambda> y. t)"
+
+lemma beta_sscase:
+  "sscase\<cdot>f\<cdot>g\<cdot>s = (\<lambda>(t, x, y). If t then f\<cdot>x else g\<cdot>y) (Rep_ssum s)"
+unfolding sscase_def by (simp add: cont_Rep_ssum [THEN cont_compose])
+
+lemma sscase1 [simp]: "sscase\<cdot>f\<cdot>g\<cdot>\<bottom> = \<bottom>"
+unfolding beta_sscase by (simp add: Rep_ssum_strict)
+
+lemma sscase2 [simp]: "x \<noteq> \<bottom> \<Longrightarrow> sscase\<cdot>f\<cdot>g\<cdot>(sinl\<cdot>x) = f\<cdot>x"
+unfolding beta_sscase by (simp add: Rep_ssum_sinl)
+
+lemma sscase3 [simp]: "y \<noteq> \<bottom> \<Longrightarrow> sscase\<cdot>f\<cdot>g\<cdot>(sinr\<cdot>y) = g\<cdot>y"
+unfolding beta_sscase by (simp add: Rep_ssum_sinr)
+
+lemma sscase4 [simp]: "sscase\<cdot>sinl\<cdot>sinr\<cdot>z = z"
+by (cases z, simp_all)
+
+subsection {* Strict sum preserves flatness *}
+
+instance ssum :: (flat, flat) flat
+apply (intro_classes, clarify)
+apply (case_tac x, simp)
+apply (case_tac y, simp_all add: flat_below_iff)
+apply (case_tac y, simp_all add: flat_below_iff)
+done
+
+end

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/HOLCF/Tools/Domain/domain.ML	Sat Nov 27 16:08:10 2010 -0800
@@ -0,0 +1,266 @@
+(*  Title:      HOLCF/Tools/Domain/domain.ML
+    Author:     David von Oheimb
+    Author:     Brian Huffman
+
+Theory extender for domain command, including theory syntax.
+*)
+
+signature DOMAIN =
+sig
+  val add_domain_cmd:
+      ((string * string option) list * binding * mixfix *
+       (binding * (bool * binding option * string) list * mixfix) list) list
+      -> theory -> theory
+
+  val add_domain:
+      ((string * sort) list * binding * mixfix *
+       (binding * (bool * binding option * typ) list * mixfix) list) list
+      -> theory -> theory
+
+  val add_new_domain_cmd:
+      ((string * string option) list * binding * mixfix *
+       (binding * (bool * binding option * string) list * mixfix) list) list
+      -> theory -> theory
+
+  val add_new_domain:
+      ((string * sort) list * binding * mixfix *
+       (binding * (bool * binding option * typ) list * mixfix) list) list
+      -> theory -> theory
+end;
+
+structure Domain :> DOMAIN =
+struct
+
+open HOLCF_Library;
+
+fun first  (x,_,_) = x;
+fun second (_,x,_) = x;
+fun third  (_,_,x) = x;
+
+(* ----- calls for building new thy and thms -------------------------------- *)
+
+type info =
+     Domain_Take_Proofs.iso_info list * Domain_Take_Proofs.take_induct_info;
+
+fun add_arity ((b, sorts, mx), sort) thy : theory =
+  thy
+  |> Sign.add_types [(b, length sorts, mx)]
+  |> AxClass.axiomatize_arity (Sign.full_name thy b, sorts, sort);
+
+fun gen_add_domain
+    (prep_sort : theory -> 'a -> sort)
+    (prep_typ : theory -> (string * sort) list -> 'b -> typ)
+    (add_isos : (binding * mixfix * (typ * typ)) list -> theory -> info * theory)
+    (arg_sort : bool -> sort)
+    (raw_specs : ((string * 'a) list * binding * mixfix *
+               (binding * (bool * binding option * 'b) list * mixfix) list) list)
+    (thy : theory) =
+  let
+    val dtnvs : (binding * typ list * mixfix) list =
+      let
+        fun prep_tvar (a, s) = TFree (a, prep_sort thy s);
+      in
+        map (fn (vs, dbind, mx, _) =>
+                (dbind, map prep_tvar vs, mx)) raw_specs
+      end;
+
+    fun thy_arity (dbind, tvars, mx) =
+      ((dbind, map (snd o dest_TFree) tvars, mx), arg_sort false);
+
+    (* this theory is used just for parsing and error checking *)
+    val tmp_thy = thy
+      |> Theory.copy
+      |> fold (add_arity o thy_arity) dtnvs;
+
+    val dbinds : binding list =
+        map (fn (_,dbind,_,_) => dbind) raw_specs;
+    val raw_rhss :
+        (binding * (bool * binding option * 'b) list * mixfix) list list =
+        map (fn (_,_,_,cons) => cons) raw_specs;
+    val dtnvs' : (string * typ list) list =
+        map (fn (dbind, vs, mx) => (Sign.full_name thy dbind, vs)) dtnvs;
+
+    val all_cons = map (Binding.name_of o first) (flat raw_rhss);
+    val test_dupl_cons =
+      case duplicates (op =) all_cons of 
+        [] => false | dups => error ("Duplicate constructors: " 
+                                      ^ commas_quote dups);
+    val all_sels =
+      (map Binding.name_of o map_filter second o maps second) (flat raw_rhss);
+    val test_dupl_sels =
+      case duplicates (op =) all_sels of
+        [] => false | dups => error("Duplicate selectors: "^commas_quote dups);
+
+    fun test_dupl_tvars s =
+      case duplicates (op =) (map(fst o dest_TFree)s) of
+        [] => false | dups => error("Duplicate type arguments: " 
+                                    ^commas_quote dups);
+    val test_dupl_tvars' = exists test_dupl_tvars (map snd dtnvs');
+
+    val sorts : (string * sort) list =
+      let val all_sorts = map (map dest_TFree o snd) dtnvs';
+      in
+        case distinct (eq_set (op =)) all_sorts of
+          [sorts] => sorts
+        | _ => error "Mutually recursive domains must have same type parameters"
+      end;
+
+    (* a lazy argument may have an unpointed type *)
+    (* unless the argument has a selector function *)
+    fun check_pcpo (lazy, sel, T) =
+      let val sort = arg_sort (lazy andalso is_none sel) in
+        if Sign.of_sort tmp_thy (T, sort) then ()
+        else error ("Constructor argument type is not of sort " ^
+                    Syntax.string_of_sort_global tmp_thy sort ^ ": " ^
+                    Syntax.string_of_typ_global tmp_thy T)
+      end;
+
+    (* test for free type variables, illegal sort constraints on rhs,
+       non-pcpo-types and invalid use of recursive type;
+       replace sorts in type variables on rhs *)
+    val rec_tab = Domain_Take_Proofs.get_rec_tab thy;
+    fun check_rec rec_ok (T as TFree (v,_))  =
+        if AList.defined (op =) sorts v then T
+        else error ("Free type variable " ^ quote v ^ " on rhs.")
+      | check_rec rec_ok (T as Type (s, Ts)) =
+        (case AList.lookup (op =) dtnvs' s of
+          NONE =>
+            let val rec_ok' = rec_ok andalso Symtab.defined rec_tab s;
+            in Type (s, map (check_rec rec_ok') Ts) end
+        | SOME typevars =>
+          if typevars <> Ts
+          then error ("Recursion of type " ^ 
+                      quote (Syntax.string_of_typ_global tmp_thy T) ^ 
+                      " with different arguments")
+          else if rec_ok then T
+          else error ("Illegal indirect recursion of type " ^ 
+                      quote (Syntax.string_of_typ_global tmp_thy T)))
+      | check_rec rec_ok (TVar _) = error "extender:check_rec";
+
+    fun prep_arg (lazy, sel, raw_T) =
+      let
+        val T = prep_typ tmp_thy sorts raw_T;
+        val _ = check_rec true T;
+        val _ = check_pcpo (lazy, sel, T);
+      in (lazy, sel, T) end;
+    fun prep_con (b, args, mx) = (b, map prep_arg args, mx);
+    fun prep_rhs cons = map prep_con cons;
+    val rhss : (binding * (bool * binding option * typ) list * mixfix) list list =
+        map prep_rhs raw_rhss;
+
+    fun mk_arg_typ (lazy, dest_opt, T) = if lazy then mk_upT T else T;
+    fun mk_con_typ (bind, args, mx) =
+        if null args then oneT else foldr1 mk_sprodT (map mk_arg_typ args);
+    fun mk_rhs_typ cons = foldr1 mk_ssumT (map mk_con_typ cons);
+
+    val absTs : typ list = map Type dtnvs';
+    val repTs : typ list = map mk_rhs_typ rhss;
+
+    val iso_spec : (binding * mixfix * (typ * typ)) list =
+        map (fn ((dbind, _, mx), eq) => (dbind, mx, eq))
+          (dtnvs ~~ (absTs ~~ repTs));
+
+    val ((iso_infos, take_info), thy) = add_isos iso_spec thy;
+
+    val (constr_infos, thy) =
+        thy
+          |> fold_map (fn ((dbind, cons), info) =>
+                Domain_Constructors.add_domain_constructors dbind cons info)
+             (dbinds ~~ rhss ~~ iso_infos);
+
+    val (take_rews, thy) =
+        Domain_Induction.comp_theorems
+          dbinds take_info constr_infos thy;
+  in
+    thy
+  end;
+
+fun define_isos (spec : (binding * mixfix * (typ * typ)) list) =
+  let
+    fun prep (dbind, mx, (lhsT, rhsT)) =
+      let val (dname, vs) = dest_Type lhsT;
+      in (map (fst o dest_TFree) vs, dbind, mx, rhsT, NONE) end;
+  in
+    Domain_Isomorphism.domain_isomorphism (map prep spec)
+  end;
+
+fun pcpo_arg lazy = if lazy then @{sort cpo} else @{sort pcpo};
+fun rep_arg lazy = if lazy then @{sort predomain} else @{sort "domain"};
+
+fun read_sort thy (SOME s) = Syntax.read_sort_global thy s
+  | read_sort thy NONE = Sign.defaultS thy;
+
+(* Adapted from src/HOL/Tools/Datatype/datatype_data.ML *)
+fun read_typ thy sorts str =
+  let
+    val ctxt = ProofContext.init_global thy
+      |> fold (Variable.declare_typ o TFree) sorts;
+  in Syntax.read_typ ctxt str end;
+
+fun cert_typ sign sorts raw_T =
+  let
+    val T = Type.no_tvars (Sign.certify_typ sign raw_T)
+      handle TYPE (msg, _, _) => error msg;
+    val sorts' = Term.add_tfreesT T sorts;
+    val _ =
+      case duplicates (op =) (map fst sorts') of
+        [] => ()
+      | dups => error ("Inconsistent sort constraints for " ^ commas dups)
+  in T end;
+
+val add_domain =
+    gen_add_domain (K I) cert_typ Domain_Axioms.add_axioms pcpo_arg;
+
+val add_new_domain =
+    gen_add_domain (K I) cert_typ define_isos rep_arg;
+
+val add_domain_cmd =
+    gen_add_domain read_sort read_typ Domain_Axioms.add_axioms pcpo_arg;
+
+val add_new_domain_cmd =
+    gen_add_domain read_sort read_typ define_isos rep_arg;
+
+
+(** outer syntax **)
+
+val _ = Keyword.keyword "lazy";
+val _ = Keyword.keyword "unsafe";
+
+val dest_decl : (bool * binding option * string) parser =
+  Parse.$$$ "(" |-- Scan.optional (Parse.$$$ "lazy" >> K true) false --
+    (Parse.binding >> SOME) -- (Parse.$$$ "::" |-- Parse.typ)  --| Parse.$$$ ")" >> Parse.triple1
+    || Parse.$$$ "(" |-- Parse.$$$ "lazy" |-- Parse.typ --| Parse.$$$ ")"
+    >> (fn t => (true,NONE,t))
+    || Parse.typ >> (fn t => (false,NONE,t));
+
+val cons_decl =
+  Parse.binding -- Scan.repeat dest_decl -- Parse.opt_mixfix;
+
+val domain_decl =
+  (Parse.type_args_constrained -- Parse.binding -- Parse.opt_mixfix) --
+    (Parse.$$$ "=" |-- Parse.enum1 "|" cons_decl);
+
+val domains_decl =
+  Scan.optional (Parse.$$$ "(" |-- (Parse.$$$ "unsafe" >> K true) --| Parse.$$$ ")") false --
+    Parse.and_list1 domain_decl;
+
+fun mk_domain
+    (unsafe : bool,
+     doms : ((((string * string option) list * binding) * mixfix) *
+             ((binding * (bool * binding option * string) list) * mixfix) list) list ) =
+  let
+    val specs : ((string * string option) list * binding * mixfix *
+                 (binding * (bool * binding option * string) list * mixfix) list) list =
+        map (fn (((vs, t), mx), cons) =>
+                (vs, t, mx, map (fn ((c, ds), mx) => (c, ds, mx)) cons)) doms;
+  in
+    if unsafe
+    then add_domain_cmd specs
+    else add_new_domain_cmd specs
+  end;
+
+val _ =
+  Outer_Syntax.command "domain" "define recursive domains (HOLCF)"
+    Keyword.thy_decl (domains_decl >> (Toplevel.theory o mk_domain));
+
+end;

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/HOLCF/Tools/Domain/domain_axioms.ML	Sat Nov 27 16:08:10 2010 -0800
@@ -0,0 +1,138 @@
+(*  Title:      HOLCF/Tools/Domain/domain_axioms.ML
+    Author:     David von Oheimb
+    Author:     Brian Huffman
+
+Syntax generator for domain command.
+*)
+
+signature DOMAIN_AXIOMS =
+sig
+  val axiomatize_isomorphism :
+      binding * (typ * typ) ->
+      theory -> Domain_Take_Proofs.iso_info * theory
+
+  val axiomatize_lub_take :
+      binding * term -> theory -> thm * theory
+
+  val add_axioms :
+      (binding * mixfix * (typ * typ)) list -> theory ->
+      (Domain_Take_Proofs.iso_info list
+       * Domain_Take_Proofs.take_induct_info) * theory
+end;
+
+
+structure Domain_Axioms : DOMAIN_AXIOMS =
+struct
+
+open HOLCF_Library;
+
+infixr 6 ->>;
+infix -->>;
+infix 9 `;
+
+fun axiomatize_isomorphism
+    (dbind : binding, (lhsT, rhsT))
+    (thy : theory)
+    : Domain_Take_Proofs.iso_info * theory =
+  let
+    val abs_bind = Binding.suffix_name "_abs" dbind;
+    val rep_bind = Binding.suffix_name "_rep" dbind;
+
+    val (abs_const, thy) =
+        Sign.declare_const ((abs_bind, rhsT ->> lhsT), NoSyn) thy;
+    val (rep_const, thy) =
+        Sign.declare_const ((rep_bind, lhsT ->> rhsT), NoSyn) thy;
+
+    val x = Free ("x", lhsT);
+    val y = Free ("y", rhsT);
+
+    val abs_iso_eqn =
+        Logic.all y (mk_trp (mk_eq (rep_const ` (abs_const ` y), y)));
+    val rep_iso_eqn =
+        Logic.all x (mk_trp (mk_eq (abs_const ` (rep_const ` x), x)));
+
+    val abs_iso_bind = Binding.qualified true "abs_iso" dbind;
+    val rep_iso_bind = Binding.qualified true "rep_iso" dbind;
+
+    val (abs_iso_thm, thy) = Specification.axiom ((abs_iso_bind, []), abs_iso_eqn) thy;
+    val (rep_iso_thm, thy) = Specification.axiom ((rep_iso_bind, []), rep_iso_eqn) thy;
+
+    val result =
+        {
+          absT = lhsT,
+          repT = rhsT,
+          abs_const = abs_const,
+          rep_const = rep_const,
+          abs_inverse = Drule.export_without_context abs_iso_thm,
+          rep_inverse = Drule.export_without_context rep_iso_thm
+        };
+  in
+    (result, thy)
+  end;
+
+fun axiomatize_lub_take
+    (dbind : binding, take_const : term)
+    (thy : theory)
+    : thm * theory =
+  let
+    val i = Free ("i", natT);
+    val T = (fst o dest_cfunT o range_type o fastype_of) take_const;
+
+    val lub_take_eqn =
+        mk_trp (mk_eq (mk_lub (lambda i (take_const $ i)), mk_ID T));
+
+    val lub_take_bind = Binding.qualified true "lub_take" dbind;
+
+    val (lub_take_thm, thy) = Specification.axiom ((lub_take_bind, []), lub_take_eqn) thy;
+  in
+    (lub_take_thm, thy)
+  end;
+
+fun add_axioms
+    (dom_eqns : (binding * mixfix * (typ * typ)) list)
+    (thy : theory) =
+  let
+
+    val dbinds = map #1 dom_eqns;
+
+    (* declare new types *)
+    fun thy_type (dbind, mx, (lhsT, _)) =
+        (dbind, (length o snd o dest_Type) lhsT, mx);
+    val thy = Sign.add_types (map thy_type dom_eqns) thy;
+
+    (* axiomatize type constructor arities *)
+    fun thy_arity (_, _, (lhsT, _)) =
+        let val (dname, tvars) = dest_Type lhsT;
+        in (dname, map (snd o dest_TFree) tvars, @{sort pcpo}) end;
+    val thy = fold (AxClass.axiomatize_arity o thy_arity) dom_eqns thy;
+
+    (* declare and axiomatize abs/rep *)
+    val (iso_infos, thy) =
+        fold_map axiomatize_isomorphism
+          (map (fn (dbind, _, eqn) => (dbind, eqn)) dom_eqns) thy;
+
+    (* define take functions *)
+    val (take_info, thy) =
+        Domain_Take_Proofs.define_take_functions
+          (dbinds ~~ iso_infos) thy;
+
+    (* declare lub_take axioms *)
+    val (lub_take_thms, thy) =
+        fold_map axiomatize_lub_take
+          (dbinds ~~ #take_consts take_info) thy;
+
+    (* prove additional take theorems *)
+    val (take_info2, thy) =
+        Domain_Take_Proofs.add_lub_take_theorems
+          (dbinds ~~ iso_infos) take_info lub_take_thms thy;
+
+    (* define map functions *)
+    val (map_info, thy) =
+        Domain_Isomorphism.define_map_functions
+          (dbinds ~~ iso_infos) thy;
+
+  in
+    ((iso_infos, take_info2), thy)
+  end;
+
+end; (* struct *)

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/HOLCF/Tools/Domain/domain_constructors.ML	Sat Nov 27 16:08:10 2010 -0800
@@ -0,0 +1,975 @@
+(*  Title:      HOLCF/Tools/Domain/domain_constructors.ML
+    Author:     Brian Huffman
+
+Defines constructor functions for a given domain isomorphism
+and proves related theorems.
+*)
+
+signature DOMAIN_CONSTRUCTORS =
+sig
+  type constr_info =
+    {
+      iso_info : Domain_Take_Proofs.iso_info,
+      con_specs : (term * (bool * typ) list) list,
+      con_betas : thm list,
+      nchotomy : thm,
+      exhaust : thm,
+      compacts : thm list,
+      con_rews : thm list,
+      inverts : thm list,
+      injects : thm list,
+      dist_les : thm list,
+      dist_eqs : thm list,
+      cases : thm list,
+      sel_rews : thm list,
+      dis_rews : thm list,
+      match_rews : thm list
+    }
+  val add_domain_constructors :
+      binding
+      -> (binding * (bool * binding option * typ) list * mixfix) list
+      -> Domain_Take_Proofs.iso_info
+      -> theory
+      -> constr_info * theory;
+end;
+
+
+structure Domain_Constructors :> DOMAIN_CONSTRUCTORS =
+struct
+
+open HOLCF_Library;
+
+infixr 6 ->>;
+infix -->>;
+infix 9 `;
+
+type constr_info =
+  {
+    iso_info : Domain_Take_Proofs.iso_info,
+    con_specs : (term * (bool * typ) list) list,
+    con_betas : thm list,
+    nchotomy : thm,
+    exhaust : thm,
+    compacts : thm list,
+    con_rews : thm list,
+    inverts : thm list,
+    injects : thm list,
+    dist_les : thm list,
+    dist_eqs : thm list,
+    cases : thm list,
+    sel_rews : thm list,
+    dis_rews : thm list,
+    match_rews : thm list
+  }
+
+(************************** miscellaneous functions ***************************)
+
+val simple_ss = HOL_basic_ss addsimps simp_thms;
+
+val beta_rules =
+  @{thms beta_cfun cont_id cont_const cont2cont_APP cont2cont_LAM'} @
+  @{thms cont2cont_fst cont2cont_snd cont2cont_Pair};
+
+val beta_ss = HOL_basic_ss addsimps (simp_thms @ beta_rules);
+
+fun define_consts
+    (specs : (binding * term * mixfix) list)
+    (thy : theory)
+    : (term list * thm list) * theory =
+  let
+    fun mk_decl (b, t, mx) = (b, fastype_of t, mx);
+    val decls = map mk_decl specs;
+    val thy = Cont_Consts.add_consts decls thy;
+    fun mk_const (b, T, mx) = Const (Sign.full_name thy b, T);
+    val consts = map mk_const decls;
+    fun mk_def c (b, t, mx) =
+      (Binding.suffix_name "_def" b, Logic.mk_equals (c, t));
+    val defs = map2 mk_def consts specs;
+    val (def_thms, thy) =
+      Global_Theory.add_defs false (map Thm.no_attributes defs) thy;
+  in
+    ((consts, def_thms), thy)
+  end;
+
+fun prove
+    (thy : theory)
+    (defs : thm list)
+    (goal : term)
+    (tacs : {prems: thm list, context: Proof.context} -> tactic list)
+    : thm =
+  let
+    fun tac {prems, context} =
+      rewrite_goals_tac defs THEN
+      EVERY (tacs {prems = map (rewrite_rule defs) prems, context = context})
+  in
+    Goal.prove_global thy [] [] goal tac
+  end;
+
+fun get_vars_avoiding
+    (taken : string list)
+    (args : (bool * typ) list)
+    : (term list * term list) =
+  let
+    val Ts = map snd args;
+    val ns = Name.variant_list taken (Datatype_Prop.make_tnames Ts);
+    val vs = map Free (ns ~~ Ts);
+    val nonlazy = map snd (filter_out (fst o fst) (args ~~ vs));
+  in
+    (vs, nonlazy)
+  end;
+
+fun get_vars args = get_vars_avoiding [] args;
+
+(************** generating beta reduction rules from definitions **************)
+
+local
+  fun arglist (Const _ $ Abs (s, T, t)) =
+      let
+        val arg = Free (s, T);
+        val (args, body) = arglist (subst_bound (arg, t));
+      in (arg :: args, body) end
+    | arglist t = ([], t);
+in
+  fun beta_of_def thy def_thm =
+      let
+        val (con, lam) = Logic.dest_equals (concl_of def_thm);
+        val (args, rhs) = arglist lam;
+        val lhs = list_ccomb (con, args);
+        val goal = mk_equals (lhs, rhs);
+        val cs = ContProc.cont_thms lam;
+        val betas = map (fn c => mk_meta_eq (c RS @{thm beta_cfun})) cs;
+      in
+        prove thy (def_thm::betas) goal (K [rtac reflexive_thm 1])
+      end;
+end;
+
+(******************************************************************************)
+(************* definitions and theorems for constructor functions *************)
+(******************************************************************************)
+
+fun add_constructors
+    (spec : (binding * (bool * typ) list * mixfix) list)
+    (abs_const : term)
+    (iso_locale : thm)
+    (thy : theory)
+    =
+  let
+
+    (* get theorems about rep and abs *)
+    val abs_strict = iso_locale RS @{thm iso.abs_strict};
+
+    (* get types of type isomorphism *)
+    val (rhsT, lhsT) = dest_cfunT (fastype_of abs_const);
+
+    fun vars_of args =
+      let
+        val Ts = map snd args;
+        val ns = Datatype_Prop.make_tnames Ts;
+      in
+        map Free (ns ~~ Ts)
+      end;
+
+    (* define constructor functions *)
+    val ((con_consts, con_defs), thy) =
+      let
+        fun one_arg (lazy, T) var = if lazy then mk_up var else var;
+        fun one_con (_,args,_) = mk_stuple (map2 one_arg args (vars_of args));
+        fun mk_abs t = abs_const ` t;
+        val rhss = map mk_abs (mk_sinjects (map one_con spec));
+        fun mk_def (bind, args, mx) rhs =
+          (bind, big_lambdas (vars_of args) rhs, mx);
+      in
+        define_consts (map2 mk_def spec rhss) thy
+      end;
+
+    (* prove beta reduction rules for constructors *)
+    val con_betas = map (beta_of_def thy) con_defs;
+
+    (* replace bindings with terms in constructor spec *)
+    val spec' : (term * (bool * typ) list) list =
+      let fun one_con con (b, args, mx) = (con, args);
+      in map2 one_con con_consts spec end;
+
+    (* prove exhaustiveness of constructors *)
+    local
+      fun arg2typ n (true,  T) = (n+1, mk_upT (TVar (("'a", n), @{sort cpo})))
+        | arg2typ n (false, T) = (n+1, TVar (("'a", n), @{sort pcpo}));
+      fun args2typ n [] = (n, oneT)
+        | args2typ n [arg] = arg2typ n arg
+        | args2typ n (arg::args) =
+          let
+            val (n1, t1) = arg2typ n arg;
+            val (n2, t2) = args2typ n1 args
+          in (n2, mk_sprodT (t1, t2)) end;
+      fun cons2typ n [] = (n, oneT)
+        | cons2typ n [con] = args2typ n (snd con)
+        | cons2typ n (con::cons) =
+          let
+            val (n1, t1) = args2typ n (snd con);
+            val (n2, t2) = cons2typ n1 cons
+          in (n2, mk_ssumT (t1, t2)) end;
+      val ct = ctyp_of thy (snd (cons2typ 1 spec'));
+      val thm1 = instantiate' [SOME ct] [] @{thm exh_start};
+      val thm2 = rewrite_rule (map mk_meta_eq @{thms ex_bottom_iffs}) thm1;
+      val thm3 = rewrite_rule [mk_meta_eq @{thm conj_assoc}] thm2;
+
+      val y = Free ("y", lhsT);
+      fun one_con (con, args) =
+        let
+          val (vs, nonlazy) = get_vars_avoiding ["y"] args;
+          val eqn = mk_eq (y, list_ccomb (con, vs));
+          val conj = foldr1 mk_conj (eqn :: map mk_defined nonlazy);
+        in Library.foldr mk_ex (vs, conj) end;
+      val goal = mk_trp (foldr1 mk_disj (mk_undef y :: map one_con spec'));
+      (* first rules replace "y = UU \/ P" with "rep$y = UU \/ P" *)
+      val tacs = [
+          rtac (iso_locale RS @{thm iso.casedist_rule}) 1,
+          rewrite_goals_tac [mk_meta_eq (iso_locale RS @{thm iso.iso_swap})],
+          rtac thm3 1];
+    in
+      val nchotomy = prove thy con_betas goal (K tacs);
+      val exhaust =
+          (nchotomy RS @{thm exh_casedist0})
+          |> rewrite_rule @{thms exh_casedists}
+          |> Drule.zero_var_indexes;
+    end;
+
+    (* prove compactness rules for constructors *)
+    val compacts =
+      let
+        val rules = @{thms compact_sinl compact_sinr compact_spair
+                           compact_up compact_ONE};
+        val tacs =
+          [rtac (iso_locale RS @{thm iso.compact_abs}) 1,
+           REPEAT (resolve_tac rules 1 ORELSE atac 1)];
+        fun con_compact (con, args) =
+          let
+            val vs = vars_of args;
+            val con_app = list_ccomb (con, vs);
+            val concl = mk_trp (mk_compact con_app);
+            val assms = map (mk_trp o mk_compact) vs;
+            val goal = Logic.list_implies (assms, concl);
+          in
+            prove thy con_betas goal (K tacs)
+          end;
+      in
+        map con_compact spec'
+      end;
+
+    (* prove strictness rules for constructors *)
+    local
+      fun con_strict (con, args) = 
+        let
+          val rules = abs_strict :: @{thms con_strict_rules};
+          val (vs, nonlazy) = get_vars args;
+          fun one_strict v' =
+            let
+              val UU = mk_bottom (fastype_of v');
+              val vs' = map (fn v => if v = v' then UU else v) vs;
+              val goal = mk_trp (mk_undef (list_ccomb (con, vs')));
+              val tacs = [simp_tac (HOL_basic_ss addsimps rules) 1];
+            in prove thy con_betas goal (K tacs) end;
+        in map one_strict nonlazy end;
+
+      fun con_defin (con, args) =
+        let
+          fun iff_disj (t, []) = HOLogic.mk_not t
+            | iff_disj (t, ts) = mk_eq (t, foldr1 HOLogic.mk_disj ts);
+          val (vs, nonlazy) = get_vars args;
+          val lhs = mk_undef (list_ccomb (con, vs));
+          val rhss = map mk_undef nonlazy;
+          val goal = mk_trp (iff_disj (lhs, rhss));
+          val rule1 = iso_locale RS @{thm iso.abs_bottom_iff};
+          val rules = rule1 :: @{thms con_bottom_iff_rules};
+          val tacs = [simp_tac (HOL_ss addsimps rules) 1];
+        in prove thy con_betas goal (K tacs) end;
+    in
+      val con_stricts = maps con_strict spec';
+      val con_defins = map con_defin spec';
+      val con_rews = con_stricts @ con_defins;
+    end;
+
+    (* prove injectiveness of constructors *)
+    local
+      fun pgterm rel (con, args) =
+        let
+          fun prime (Free (n, T)) = Free (n^"'", T)
+            | prime t             = t;
+          val (xs, nonlazy) = get_vars args;
+          val ys = map prime xs;
+          val lhs = rel (list_ccomb (con, xs), list_ccomb (con, ys));
+          val rhs = foldr1 mk_conj (ListPair.map rel (xs, ys));
+          val concl = mk_trp (mk_eq (lhs, rhs));
+          val zs = case args of [_] => [] | _ => nonlazy;
+          val assms = map (mk_trp o mk_defined) zs;
+          val goal = Logic.list_implies (assms, concl);
+        in prove thy con_betas goal end;
+      val cons' = filter (fn (_, args) => not (null args)) spec';
+    in
+      val inverts =
+        let
+          val abs_below = iso_locale RS @{thm iso.abs_below};
+          val rules1 = abs_below :: @{thms sinl_below sinr_below spair_below up_below};
+          val rules2 = @{thms up_defined spair_defined ONE_defined}
+          val rules = rules1 @ rules2;
+          val tacs = [asm_simp_tac (simple_ss addsimps rules) 1];
+        in map (fn c => pgterm mk_below c (K tacs)) cons' end;
+      val injects =
+        let
+          val abs_eq = iso_locale RS @{thm iso.abs_eq};
+          val rules1 = abs_eq :: @{thms sinl_eq sinr_eq spair_eq up_eq};
+          val rules2 = @{thms up_defined spair_defined ONE_defined}
+          val rules = rules1 @ rules2;
+          val tacs = [asm_simp_tac (simple_ss addsimps rules) 1];
+        in map (fn c => pgterm mk_eq c (K tacs)) cons' end;
+    end;
+
+    (* prove distinctness of constructors *)
+    local
+      fun map_dist (f : 'a -> 'a -> 'b) (xs : 'a list) : 'b list =
+        flat (map_index (fn (i, x) => map (f x) (nth_drop i xs)) xs);
+      fun prime (Free (n, T)) = Free (n^"'", T)
+        | prime t             = t;
+      fun iff_disj (t, []) = mk_not t
+        | iff_disj (t, ts) = mk_eq (t, foldr1 mk_disj ts);
+      fun iff_disj2 (t, [], us) = mk_not t
+        | iff_disj2 (t, ts, []) = mk_not t
+        | iff_disj2 (t, ts, us) =
+          mk_eq (t, mk_conj (foldr1 mk_disj ts, foldr1 mk_disj us));
+      fun dist_le (con1, args1) (con2, args2) =
+        let
+          val (vs1, zs1) = get_vars args1;
+          val (vs2, zs2) = get_vars args2 |> pairself (map prime);
+          val lhs = mk_below (list_ccomb (con1, vs1), list_ccomb (con2, vs2));
+          val rhss = map mk_undef zs1;
+          val goal = mk_trp (iff_disj (lhs, rhss));
+          val rule1 = iso_locale RS @{thm iso.abs_below};
+          val rules = rule1 :: @{thms con_below_iff_rules};
+          val tacs = [simp_tac (HOL_ss addsimps rules) 1];
+        in prove thy con_betas goal (K tacs) end;
+      fun dist_eq (con1, args1) (con2, args2) =
+        let
+          val (vs1, zs1) = get_vars args1;
+          val (vs2, zs2) = get_vars args2 |> pairself (map prime);
+          val lhs = mk_eq (list_ccomb (con1, vs1), list_ccomb (con2, vs2));
+          val rhss1 = map mk_undef zs1;
+          val rhss2 = map mk_undef zs2;
+          val goal = mk_trp (iff_disj2 (lhs, rhss1, rhss2));
+          val rule1 = iso_locale RS @{thm iso.abs_eq};
+          val rules = rule1 :: @{thms con_eq_iff_rules};
+          val tacs = [simp_tac (HOL_ss addsimps rules) 1];
+        in prove thy con_betas goal (K tacs) end;
+    in
+      val dist_les = map_dist dist_le spec';
+      val dist_eqs = map_dist dist_eq spec';
+    end;
+
+    val result =
+      {
+        con_consts = con_consts,
+        con_betas = con_betas,
+        nchotomy = nchotomy,
+        exhaust = exhaust,
+        compacts = compacts,
+        con_rews = con_rews,
+        inverts = inverts,
+        injects = injects,
+        dist_les = dist_les,
+        dist_eqs = dist_eqs
+      };
+  in
+    (result, thy)
+  end;
+
+(******************************************************************************)
+(**************** definition and theorems for case combinator *****************)
+(******************************************************************************)
+
+fun add_case_combinator
+    (spec : (term * (bool * typ) list) list)
+    (lhsT : typ)
+    (dbind : binding)
+    (con_betas : thm list)
+    (exhaust : thm)
+    (iso_locale : thm)
+    (rep_const : term)
+    (thy : theory)
+    : ((typ -> term) * thm list) * theory =
+  let
+
+    (* prove rep/abs rules *)
+    val rep_strict = iso_locale RS @{thm iso.rep_strict};
+    val abs_inverse = iso_locale RS @{thm iso.abs_iso};
+
+    (* calculate function arguments of case combinator *)
+    val tns = map fst (Term.add_tfreesT lhsT []);
+    val resultT = TFree (Name.variant tns "'t", @{sort pcpo});
+    fun fTs T = map (fn (_, args) => map snd args -->> T) spec;
+    val fns = Datatype_Prop.indexify_names (map (K "f") spec);
+    val fs = map Free (fns ~~ fTs resultT);
+    fun caseT T = fTs T -->> (lhsT ->> T);
+
+    (* definition of case combinator *)
+    local
+      val case_bind = Binding.suffix_name "_case" dbind;
+      fun lambda_arg (lazy, v) t =
+          (if lazy then mk_fup else I) (big_lambda v t);
+      fun lambda_args []      t = mk_one_case t
+        | lambda_args (x::[]) t = lambda_arg x t
+        | lambda_args (x::xs) t = mk_ssplit (lambda_arg x (lambda_args xs t));
+      fun one_con f (_, args) =
+        let
+          val Ts = map snd args;
+          val ns = Name.variant_list fns (Datatype_Prop.make_tnames Ts);
+          val vs = map Free (ns ~~ Ts);
+        in
+          lambda_args (map fst args ~~ vs) (list_ccomb (f, vs))
+        end;
+      fun mk_sscases [t] = mk_strictify t
+        | mk_sscases ts = foldr1 mk_sscase ts;
+      val body = mk_sscases (map2 one_con fs spec);
+      val rhs = big_lambdas fs (mk_cfcomp (body, rep_const));
+      val ((case_consts, case_defs), thy) =
+          define_consts [(case_bind, rhs, NoSyn)] thy;
+      val case_name = Sign.full_name thy case_bind;
+    in
+      val case_def = hd case_defs;
+      fun case_const T = Const (case_name, caseT T);
+      val case_app = list_ccomb (case_const resultT, fs);
+      val thy = thy;
+    end;
+
+    (* define syntax for case combinator *)
+    (* TODO: re-implement case syntax using a parse translation *)
+    local
+      open Syntax
+      fun syntax c = Syntax.mark_const (fst (dest_Const c));
+      fun xconst c = Long_Name.base_name (fst (dest_Const c));
+      fun c_ast authentic con =
+          Constant (if authentic then syntax con else xconst con);
+      fun showint n = string_of_int (n+1);
+      fun expvar n = Variable ("e" ^ showint n);
+      fun argvar n (m, _) = Variable ("a" ^ showint n ^ "_" ^ showint m);
+      fun argvars n args = map_index (argvar n) args;
+      fun app s (l, r) = mk_appl (Constant s) [l, r];
+      val cabs = app "_cabs";
+      val capp = app @{const_syntax Rep_cfun};
+      val capps = Library.foldl capp
+      fun con1 authentic n (con,args) =
+          Library.foldl capp (c_ast authentic con, argvars n args);
+      fun case1 authentic (n, c) =
+          app "_case1" (con1 authentic n c, expvar n);
+      fun arg1 (n, (con,args)) = List.foldr cabs (expvar n) (argvars n args);
+      fun when1 n (m, c) =
+          if n = m then arg1 (n, c) else (Constant @{const_syntax UU});
+      val case_constant = Constant (syntax (case_const dummyT));
+      fun case_trans authentic =
+          ParsePrintRule
+            (app "_case_syntax"
+              (Variable "x",
+               foldr1 (app "_case2") (map_index (case1 authentic) spec)),
+             capp (capps (case_constant, map_index arg1 spec), Variable "x"));
+      fun one_abscon_trans authentic (n, c) =
+          ParsePrintRule
+            (cabs (con1 authentic n c, expvar n),
+             capps (case_constant, map_index (when1 n) spec));
+      fun abscon_trans authentic =
+          map_index (one_abscon_trans authentic) spec;
+      val trans_rules : ast Syntax.trrule list =
+          case_trans false :: case_trans true ::
+          abscon_trans false @ abscon_trans true;
+    in
+      val thy = Sign.add_trrules_i trans_rules thy;
+    end;
+
+    (* prove beta reduction rule for case combinator *)
+    val case_beta = beta_of_def thy case_def;
+
+    (* prove strictness of case combinator *)
+    val case_strict =
+      let
+        val defs = case_beta :: map mk_meta_eq [rep_strict, @{thm cfcomp2}];
+        val goal = mk_trp (mk_strict case_app);
+        val rules = @{thms sscase1 ssplit1 strictify1 one_case1};
+        val tacs = [resolve_tac rules 1];
+      in prove thy defs goal (K tacs) end;
+        
+    (* prove rewrites for case combinator *)
+    local
+      fun one_case (con, args) f =
+        let
+          val (vs, nonlazy) = get_vars args;
+          val assms = map (mk_trp o mk_defined) nonlazy;
+          val lhs = case_app ` list_ccomb (con, vs);
+          val rhs = list_ccomb (f, vs);
+          val concl = mk_trp (mk_eq (lhs, rhs));
+          val goal = Logic.list_implies (assms, concl);
+          val defs = case_beta :: con_betas;
+          val rules1 = @{thms strictify2 sscase2 sscase3 ssplit2 fup2 ID1};
+          val rules2 = @{thms con_bottom_iff_rules};
+          val rules3 = @{thms cfcomp2 one_case2};
+          val rules = abs_inverse :: rules1 @ rules2 @ rules3;
+          val tacs = [asm_simp_tac (beta_ss addsimps rules) 1];
+        in prove thy defs goal (K tacs) end;
+    in
+      val case_apps = map2 one_case spec fs;
+    end
+
+  in
+    ((case_const, case_strict :: case_apps), thy)
+  end
+
+(******************************************************************************)
+(************** definitions and theorems for selector functions ***************)
+(******************************************************************************)
+
+fun add_selectors
+    (spec : (term * (bool * binding option * typ) list) list)
+    (rep_const : term)
+    (abs_inv : thm)
+    (rep_strict : thm)
+    (rep_bottom_iff : thm)
+    (con_betas : thm list)
+    (thy : theory)
+    : thm list * theory =
+  let
+
+    (* define selector functions *)
+    val ((sel_consts, sel_defs), thy) =
+      let
+        fun rangeT s = snd (dest_cfunT (fastype_of s));
+        fun mk_outl s = mk_cfcomp (from_sinl (dest_ssumT (rangeT s)), s);
+        fun mk_outr s = mk_cfcomp (from_sinr (dest_ssumT (rangeT s)), s);
+        fun mk_sfst s = mk_cfcomp (sfst_const (dest_sprodT (rangeT s)), s);
+        fun mk_ssnd s = mk_cfcomp (ssnd_const (dest_sprodT (rangeT s)), s);
+        fun mk_down s = mk_cfcomp (from_up (dest_upT (rangeT s)), s);
+
+        fun sels_of_arg s (lazy, NONE,   T) = []
+          | sels_of_arg s (lazy, SOME b, T) =
+            [(b, if lazy then mk_down s else s, NoSyn)];
+        fun sels_of_args s [] = []
+          | sels_of_args s (v :: []) = sels_of_arg s v
+          | sels_of_args s (v :: vs) =
+            sels_of_arg (mk_sfst s) v @ sels_of_args (mk_ssnd s) vs;
+        fun sels_of_cons s [] = []
+          | sels_of_cons s ((con, args) :: []) = sels_of_args s args
+          | sels_of_cons s ((con, args) :: cs) =
+            sels_of_args (mk_outl s) args @ sels_of_cons (mk_outr s) cs;
+        val sel_eqns : (binding * term * mixfix) list =
+            sels_of_cons rep_const spec;
+      in
+        define_consts sel_eqns thy
+      end
+
+    (* replace bindings with terms in constructor spec *)
+    val spec2 : (term * (bool * term option * typ) list) list =
+      let
+        fun prep_arg (lazy, NONE, T) sels = ((lazy, NONE, T), sels)
+          | prep_arg (lazy, SOME _, T) sels =
+            ((lazy, SOME (hd sels), T), tl sels);
+        fun prep_con (con, args) sels =
+            apfst (pair con) (fold_map prep_arg args sels);
+      in
+        fst (fold_map prep_con spec sel_consts)
+      end;
+
+    (* prove selector strictness rules *)
+    val sel_stricts : thm list =
+      let
+        val rules = rep_strict :: @{thms sel_strict_rules};
+        val tacs = [simp_tac (HOL_basic_ss addsimps rules) 1];
+        fun sel_strict sel =
+          let
+            val goal = mk_trp (mk_strict sel);
+          in
+            prove thy sel_defs goal (K tacs)
+          end
+      in
+        map sel_strict sel_consts
+      end
+
+    (* prove selector application rules *)
+    val sel_apps : thm list =
+      let
+        val defs = con_betas @ sel_defs;
+        val rules = abs_inv :: @{thms sel_app_rules};
+        val tacs = [asm_simp_tac (simple_ss addsimps rules) 1];
+        fun sel_apps_of (i, (con, args: (bool * term option * typ) list)) =
+          let
+            val Ts : typ list = map #3 args;
+            val ns : string list = Datatype_Prop.make_tnames Ts;
+            val vs : term list = map Free (ns ~~ Ts);
+            val con_app : term = list_ccomb (con, vs);
+            val vs' : (bool * term) list = map #1 args ~~ vs;
+            fun one_same (n, sel, T) =
+              let
+                val xs = map snd (filter_out fst (nth_drop n vs'));
+                val assms = map (mk_trp o mk_defined) xs;
+                val concl = mk_trp (mk_eq (sel ` con_app, nth vs n));
+                val goal = Logic.list_implies (assms, concl);
+              in
+                prove thy defs goal (K tacs)
+              end;
+            fun one_diff (n, sel, T) =
+              let
+                val goal = mk_trp (mk_eq (sel ` con_app, mk_bottom T));
+              in
+                prove thy defs goal (K tacs)
+              end;
+            fun one_con (j, (_, args')) : thm list =
+              let
+                fun prep (i, (lazy, NONE, T)) = NONE
+                  | prep (i, (lazy, SOME sel, T)) = SOME (i, sel, T);
+                val sels : (int * term * typ) list =
+                  map_filter prep (map_index I args');
+              in
+                if i = j
+                then map one_same sels
+                else map one_diff sels
+              end
+          in
+            flat (map_index one_con spec2)
+          end
+      in
+        flat (map_index sel_apps_of spec2)
+      end
+
+  (* prove selector definedness rules *)
+    val sel_defins : thm list =
+      let
+        val rules = rep_bottom_iff :: @{thms sel_bottom_iff_rules};
+        val tacs = [simp_tac (HOL_basic_ss addsimps rules) 1];
+        fun sel_defin sel =
+          let
+            val (T, U) = dest_cfunT (fastype_of sel);
+            val x = Free ("x", T);
+            val lhs = mk_eq (sel ` x, mk_bottom U);
+            val rhs = mk_eq (x, mk_bottom T);
+            val goal = mk_trp (mk_eq (lhs, rhs));
+          in
+            prove thy sel_defs goal (K tacs)
+          end
+        fun one_arg (false, SOME sel, T) = SOME (sel_defin sel)
+          | one_arg _                    = NONE;
+      in
+        case spec2 of
+          [(con, args)] => map_filter one_arg args
+        | _             => []
+      end;
+
+  in
+    (sel_stricts @ sel_defins @ sel_apps, thy)
+  end
+
+(******************************************************************************)
+(************ definitions and theorems for discriminator functions ************)
+(******************************************************************************)
+
+fun add_discriminators
+    (bindings : binding list)
+    (spec : (term * (bool * typ) list) list)
+    (lhsT : typ)
+    (exhaust : thm)
+    (case_const : typ -> term)
+    (case_rews : thm list)
+    (thy : theory) =
+  let
+
+    fun vars_of args =
+      let
+        val Ts = map snd args;
+        val ns = Datatype_Prop.make_tnames Ts;
+      in
+        map Free (ns ~~ Ts)
+      end;
+
+    (* define discriminator functions *)
+    local
+      fun dis_fun i (j, (con, args)) =
+        let
+          val (vs, nonlazy) = get_vars args;
+          val tr = if i = j then @{term TT} else @{term FF};
+        in
+          big_lambdas vs tr
+        end;
+      fun dis_eqn (i, bind) : binding * term * mixfix =
+        let
+          val dis_bind = Binding.prefix_name "is_" bind;
+          val rhs = list_ccomb (case_const trT, map_index (dis_fun i) spec);
+        in
+          (dis_bind, rhs, NoSyn)
+        end;
+    in
+      val ((dis_consts, dis_defs), thy) =
+          define_consts (map_index dis_eqn bindings) thy
+    end;
+
+    (* prove discriminator strictness rules *)
+    local
+      fun dis_strict dis =
+        let val goal = mk_trp (mk_strict dis);
+        in prove thy dis_defs goal (K [rtac (hd case_rews) 1]) end;
+    in
+      val dis_stricts = map dis_strict dis_consts;
+    end;
+
+    (* prove discriminator/constructor rules *)
+    local
+      fun dis_app (i, dis) (j, (con, args)) =
+        let
+          val (vs, nonlazy) = get_vars args;
+          val lhs = dis ` list_ccomb (con, vs);
+          val rhs = if i = j then @{term TT} else @{term FF};
+          val assms = map (mk_trp o mk_defined) nonlazy;
+          val concl = mk_trp (mk_eq (lhs, rhs));
+          val goal = Logic.list_implies (assms, concl);
+          val tacs = [asm_simp_tac (beta_ss addsimps case_rews) 1];
+        in prove thy dis_defs goal (K tacs) end;
+      fun one_dis (i, dis) =
+          map_index (dis_app (i, dis)) spec;
+    in
+      val dis_apps = flat (map_index one_dis dis_consts);
+    end;
+
+    (* prove discriminator definedness rules *)
+    local
+      fun dis_defin dis =
+        let
+          val x = Free ("x", lhsT);
+          val simps = dis_apps @ @{thms dist_eq_tr};
+          val tacs =
+            [rtac @{thm iffI} 1,
+             asm_simp_tac (HOL_basic_ss addsimps dis_stricts) 2,
+             rtac exhaust 1, atac 1,
+             DETERM_UNTIL_SOLVED (CHANGED
+               (asm_full_simp_tac (simple_ss addsimps simps) 1))];
+          val goal = mk_trp (mk_eq (mk_undef (dis ` x), mk_undef x));
+        in prove thy [] goal (K tacs) end;
+    in
+      val dis_defins = map dis_defin dis_consts;
+    end;
+
+  in
+    (dis_stricts @ dis_defins @ dis_apps, thy)
+  end;
+
+(******************************************************************************)
+(*************** definitions and theorems for match combinators ***************)
+(******************************************************************************)
+
+fun add_match_combinators
+    (bindings : binding list)
+    (spec : (term * (bool * typ) list) list)
+    (lhsT : typ)
+    (exhaust : thm)
+    (case_const : typ -> term)
+    (case_rews : thm list)
+    (thy : theory) =
+  let
+
+    (* get a fresh type variable for the result type *)
+    val resultT : typ =
+      let
+        val ts : string list = map fst (Term.add_tfreesT lhsT []);
+        val t : string = Name.variant ts "'t";
+      in TFree (t, @{sort pcpo}) end;
+
+    (* define match combinators *)
+    local
+      val x = Free ("x", lhsT);
+      fun k args = Free ("k", map snd args -->> mk_matchT resultT);
+      val fail = mk_fail resultT;
+      fun mat_fun i (j, (con, args)) =
+        let
+          val (vs, nonlazy) = get_vars_avoiding ["x","k"] args;
+        in
+          if i = j then k args else big_lambdas vs fail
+        end;
+      fun mat_eqn (i, (bind, (con, args))) : binding * term * mixfix =
+        let
+          val mat_bind = Binding.prefix_name "match_" bind;
+          val funs = map_index (mat_fun i) spec
+          val body = list_ccomb (case_const (mk_matchT resultT), funs);
+          val rhs = big_lambda x (big_lambda (k args) (body ` x));
+        in
+          (mat_bind, rhs, NoSyn)
+        end;
+    in
+      val ((match_consts, match_defs), thy) =
+          define_consts (map_index mat_eqn (bindings ~~ spec)) thy
+    end;
+
+    (* register match combinators with fixrec package *)
+    local
+      val con_names = map (fst o dest_Const o fst) spec;
+      val mat_names = map (fst o dest_Const) match_consts;
+    in
+      val thy = Fixrec.add_matchers (con_names ~~ mat_names) thy;
+    end;
+
+    (* prove strictness of match combinators *)
+    local
+      fun match_strict mat =
+        let
+          val (T, (U, V)) = apsnd dest_cfunT (dest_cfunT (fastype_of mat));
+          val k = Free ("k", U);
+          val goal = mk_trp (mk_eq (mat ` mk_bottom T ` k, mk_bottom V));
+          val tacs = [asm_simp_tac (beta_ss addsimps case_rews) 1];
+        in prove thy match_defs goal (K tacs) end;
+    in
+      val match_stricts = map match_strict match_consts;
+    end;
+
+    (* prove match/constructor rules *)
+    local
+      val fail = mk_fail resultT;
+      fun match_app (i, mat) (j, (con, args)) =
+        let
+          val (vs, nonlazy) = get_vars_avoiding ["k"] args;
+          val (_, (kT, _)) = apsnd dest_cfunT (dest_cfunT (fastype_of mat));
+          val k = Free ("k", kT);
+          val lhs = mat ` list_ccomb (con, vs) ` k;
+          val rhs = if i = j then list_ccomb (k, vs) else fail;
+          val assms = map (mk_trp o mk_defined) nonlazy;
+          val concl = mk_trp (mk_eq (lhs, rhs));
+          val goal = Logic.list_implies (assms, concl);
+          val tacs = [asm_simp_tac (beta_ss addsimps case_rews) 1];
+        in prove thy match_defs goal (K tacs) end;
+      fun one_match (i, mat) =
+          map_index (match_app (i, mat)) spec;
+    in
+      val match_apps = flat (map_index one_match match_consts);
+    end;
+
+  in
+    (match_stricts @ match_apps, thy)
+  end;
+
+(******************************************************************************)
+(******************************* main function ********************************)
+(******************************************************************************)
+
+fun add_domain_constructors
+    (dbind : binding)
+    (spec : (binding * (bool * binding option * typ) list * mixfix) list)
+    (iso_info : Domain_Take_Proofs.iso_info)
+    (thy : theory) =
+  let
+    val dname = Binding.name_of dbind;
+    val _ = writeln ("Proving isomorphism properties of domain "^dname^" ...");
+
+    val bindings = map #1 spec;
+
+    (* retrieve facts about rep/abs *)
+    val lhsT = #absT iso_info;
+    val {rep_const, abs_const, ...} = iso_info;
+    val abs_iso_thm = #abs_inverse iso_info;
+    val rep_iso_thm = #rep_inverse iso_info;
+    val iso_locale = @{thm iso.intro} OF [abs_iso_thm, rep_iso_thm];
+    val rep_strict = iso_locale RS @{thm iso.rep_strict};
+    val abs_strict = iso_locale RS @{thm iso.abs_strict};
+    val rep_bottom_iff = iso_locale RS @{thm iso.rep_bottom_iff};
+    val abs_bottom_iff = iso_locale RS @{thm iso.abs_bottom_iff};
+    val iso_rews = [abs_iso_thm, rep_iso_thm, abs_strict, rep_strict];
+
+    (* qualify constants and theorems with domain name *)
+    val thy = Sign.add_path dname thy;
+
+    (* define constructor functions *)
+    val (con_result, thy) =
+      let
+        fun prep_arg (lazy, sel, T) = (lazy, T);
+        fun prep_con (b, args, mx) = (b, map prep_arg args, mx);
+        val con_spec = map prep_con spec;
+      in
+        add_constructors con_spec abs_const iso_locale thy
+      end;
+    val {con_consts, con_betas, nchotomy, exhaust, compacts, con_rews,
+          inverts, injects, dist_les, dist_eqs} = con_result;
+
+    (* prepare constructor spec *)
+    val con_specs : (term * (bool * typ) list) list =
+      let
+        fun prep_arg (lazy, sel, T) = (lazy, T);
+        fun prep_con c (b, args, mx) = (c, map prep_arg args);
+      in
+        map2 prep_con con_consts spec
+      end;
+
+    (* define case combinator *)
+    val ((case_const : typ -> term, cases : thm list), thy) =
+        add_case_combinator con_specs lhsT dbind
+          con_betas exhaust iso_locale rep_const thy
+
+    (* define and prove theorems for selector functions *)
+    val (sel_thms : thm list, thy : theory) =
+      let
+        val sel_spec : (term * (bool * binding option * typ) list) list =
+          map2 (fn con => fn (b, args, mx) => (con, args)) con_consts spec;
+      in
+        add_selectors sel_spec rep_const
+          abs_iso_thm rep_strict rep_bottom_iff con_betas thy
+      end;
+
+    (* define and prove theorems for discriminator functions *)
+    val (dis_thms : thm list, thy : theory) =
+        add_discriminators bindings con_specs lhsT
+          exhaust case_const cases thy;
+
+    (* define and prove theorems for match combinators *)
+    val (match_thms : thm list, thy : theory) =
+        add_match_combinators bindings con_specs lhsT
+          exhaust case_const cases thy;
+
+    (* restore original signature path *)
+    val thy = Sign.parent_path thy;
+
+    (* bind theorem names in global theory *)
+    val (_, thy) =
+      let
+        fun qualified name = Binding.qualified true name dbind;
+        val names = "bottom" :: map (fn (b,_,_) => Binding.name_of b) spec;
+        val dname = fst (dest_Type lhsT);
+        val simp = Simplifier.simp_add;
+        val case_names = Rule_Cases.case_names names;
+        val cases_type = Induct.cases_type dname;
+      in
+        Global_Theory.add_thmss [
+          ((qualified "iso_rews"  , iso_rews    ), [simp]),
+          ((qualified "nchotomy"  , [nchotomy]  ), []),
+          ((qualified "exhaust"   , [exhaust]   ), [case_names, cases_type]),
+          ((qualified "case_rews" , cases       ), [simp]),
+          ((qualified "compacts"  , compacts    ), [simp]),
+          ((qualified "con_rews"  , con_rews    ), [simp]),
+          ((qualified "sel_rews"  , sel_thms    ), [simp]),
+          ((qualified "dis_rews"  , dis_thms    ), [simp]),
+          ((qualified "dist_les"  , dist_les    ), [simp]),
+          ((qualified "dist_eqs"  , dist_eqs    ), [simp]),
+          ((qualified "inverts"   , inverts     ), [simp]),
+          ((qualified "injects"   , injects     ), [simp]),
+          ((qualified "match_rews", match_thms  ), [simp])] thy
+      end;
+
+    val result =
+      {
+        iso_info = iso_info,
+        con_specs = con_specs,
+        con_betas = con_betas,
+        nchotomy = nchotomy,
+        exhaust = exhaust,
+        compacts = compacts,
+        con_rews = con_rews,
+        inverts = inverts,
+        injects = injects,
+        dist_les = dist_les,
+        dist_eqs = dist_eqs,
+        cases = cases,
+        sel_rews = sel_thms,
+        dis_rews = dis_thms,
+        match_rews = match_thms
+      };
+  in
+    (result, thy)
+  end;
+
+end;

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/HOLCF/Tools/Domain/domain_induction.ML	Sat Nov 27 16:08:10 2010 -0800
@@ -0,0 +1,439 @@
+(*  Title:      HOLCF/Tools/Domain/domain_induction.ML
+    Author:     David von Oheimb
+    Author:     Brian Huffman
+
+Proofs of high-level (co)induction rules for domain command.
+*)
+
+signature DOMAIN_INDUCTION =
+sig
+  val comp_theorems :
+      binding list ->
+      Domain_Take_Proofs.take_induct_info ->
+      Domain_Constructors.constr_info list ->
+      theory -> thm list * theory
+
+  val quiet_mode: bool Unsynchronized.ref;
+  val trace_domain: bool Unsynchronized.ref;
+end;
+
+structure Domain_Induction :> DOMAIN_INDUCTION =
+struct
+
+val quiet_mode = Unsynchronized.ref false;
+val trace_domain = Unsynchronized.ref false;
+
+fun message s = if !quiet_mode then () else writeln s;
+fun trace s = if !trace_domain then tracing s else ();
+
+open HOLCF_Library;
+
+(******************************************************************************)
+(***************************** proofs about take ******************************)
+(******************************************************************************)
+
+fun take_theorems
+    (dbinds : binding list)
+    (take_info : Domain_Take_Proofs.take_induct_info)
+    (constr_infos : Domain_Constructors.constr_info list)
+    (thy : theory) : thm list list * theory =
+let
+  val {take_consts, take_Suc_thms, deflation_take_thms, ...} = take_info;
+  val deflation_thms = Domain_Take_Proofs.get_deflation_thms thy;
+
+  val n = Free ("n", @{typ nat});
+  val n' = @{const Suc} $ n;
+
+  local
+    val newTs = map (#absT o #iso_info) constr_infos;
+    val subs = newTs ~~ map (fn t => t $ n) take_consts;
+    fun is_ID (Const (c, _)) = (c = @{const_name ID})
+      | is_ID _              = false;
+  in
+    fun map_of_arg thy v T =
+      let val m = Domain_Take_Proofs.map_of_typ thy subs T;
+      in if is_ID m then v else mk_capply (m, v) end;
+  end
+
+  fun prove_take_apps
+      ((dbind, take_const), constr_info) thy =
+    let
+      val {iso_info, con_specs, con_betas, ...} = constr_info;
+      val {abs_inverse, ...} = iso_info;
+      fun prove_take_app (con_const, args) =
+        let
+          val Ts = map snd args;
+          val ns = Name.variant_list ["n"] (Datatype_Prop.make_tnames Ts);
+          val vs = map Free (ns ~~ Ts);
+          val lhs = mk_capply (take_const $ n', list_ccomb (con_const, vs));
+          val rhs = list_ccomb (con_const, map2 (map_of_arg thy) vs Ts);
+          val goal = mk_trp (mk_eq (lhs, rhs));
+          val rules =
+              [abs_inverse] @ con_betas @ @{thms take_con_rules}
+              @ take_Suc_thms @ deflation_thms @ deflation_take_thms;
+          val tac = simp_tac (HOL_basic_ss addsimps rules) 1;
+        in
+          Goal.prove_global thy [] [] goal (K tac)
+        end;
+      val take_apps = map prove_take_app con_specs;
+    in
+      yield_singleton Global_Theory.add_thmss
+        ((Binding.qualified true "take_rews" dbind, take_apps),
+        [Simplifier.simp_add]) thy
+    end;
+in
+  fold_map prove_take_apps
+    (dbinds ~~ take_consts ~~ constr_infos) thy
+end;
+
+(******************************************************************************)
+(****************************** induction rules *******************************)
+(******************************************************************************)
+
+val case_UU_allI =
+    @{lemma "(!!x. x ~= UU ==> P x) ==> P UU ==> ALL x. P x" by metis};
+
+fun prove_induction
+    (comp_dbind : binding)
+    (constr_infos : Domain_Constructors.constr_info list)
+    (take_info : Domain_Take_Proofs.take_induct_info)
+    (take_rews : thm list)
+    (thy : theory) =
+let
+  val comp_dname = Binding.name_of comp_dbind;
+
+  val iso_infos = map #iso_info constr_infos;
+  val exhausts = map #exhaust constr_infos;
+  val con_rews = maps #con_rews constr_infos;
+  val {take_consts, take_induct_thms, ...} = take_info;
+
+  val newTs = map #absT iso_infos;
+  val P_names = Datatype_Prop.indexify_names (map (K "P") newTs);
+  val x_names = Datatype_Prop.indexify_names (map (K "x") newTs);
+  val P_types = map (fn T => T --> HOLogic.boolT) newTs;
+  val Ps = map Free (P_names ~~ P_types);
+  val xs = map Free (x_names ~~ newTs);
+  val n = Free ("n", HOLogic.natT);
+
+  fun con_assm defined p (con, args) =
+    let
+      val Ts = map snd args;
+      val ns = Name.variant_list P_names (Datatype_Prop.make_tnames Ts);
+      val vs = map Free (ns ~~ Ts);
+      val nonlazy = map snd (filter_out (fst o fst) (args ~~ vs));
+      fun ind_hyp (v, T) t =
+          case AList.lookup (op =) (newTs ~~ Ps) T of NONE => t
+          | SOME p' => Logic.mk_implies (mk_trp (p' $ v), t);
+      val t1 = mk_trp (p $ list_ccomb (con, vs));
+      val t2 = fold_rev ind_hyp (vs ~~ Ts) t1;
+      val t3 = Logic.list_implies (map (mk_trp o mk_defined) nonlazy, t2);
+    in fold_rev Logic.all vs (if defined then t3 else t2) end;
+  fun eq_assms ((p, T), cons) =
+      mk_trp (p $ HOLCF_Library.mk_bottom T) :: map (con_assm true p) cons;
+  val assms = maps eq_assms (Ps ~~ newTs ~~ map #con_specs constr_infos);
+
+  val take_ss = HOL_ss addsimps (@{thm Rep_cfun_strict1} :: take_rews);
+  fun quant_tac ctxt i = EVERY
+    (map (fn name => res_inst_tac ctxt [(("x", 0), name)] spec i) x_names);
+
+  (* FIXME: move this message to domain_take_proofs.ML *)
+  val is_finite = #is_finite take_info;
+  val _ = if is_finite
+          then message ("Proving finiteness rule for domain "^comp_dname^" ...")
+          else ();
+
+  val _ = trace " Proving finite_ind...";
+  val finite_ind =
+    let
+      val concls =
+          map (fn ((P, t), x) => P $ mk_capply (t $ n, x))
+              (Ps ~~ take_consts ~~ xs);
+      val goal = mk_trp (foldr1 mk_conj concls);
+
+      fun tacf {prems, context} =
+        let
+          (* Prove stronger prems, without definedness side conditions *)
+          fun con_thm p (con, args) =
+            let
+              val subgoal = con_assm false p (con, args);
+              val rules = prems @ con_rews @ simp_thms;
+              val simplify = asm_simp_tac (HOL_basic_ss addsimps rules);
+              fun arg_tac (lazy, _) =
+                  rtac (if lazy then allI else case_UU_allI) 1;
+              val tacs =
+                  rewrite_goals_tac @{thms atomize_all atomize_imp} ::
+                  map arg_tac args @
+                  [REPEAT (rtac impI 1), ALLGOALS simplify];
+            in
+              Goal.prove context [] [] subgoal (K (EVERY tacs))
+            end;
+          fun eq_thms (p, cons) = map (con_thm p) cons;
+          val conss = map #con_specs constr_infos;
+          val prems' = maps eq_thms (Ps ~~ conss);
+
+          val tacs1 = [
+            quant_tac context 1,
+            simp_tac HOL_ss 1,
+            InductTacs.induct_tac context [[SOME "n"]] 1,
+            simp_tac (take_ss addsimps prems) 1,
+            TRY (safe_tac HOL_cs)];
+          fun con_tac _ = 
+            asm_simp_tac take_ss 1 THEN
+            (resolve_tac prems' THEN_ALL_NEW etac spec) 1;
+          fun cases_tacs (cons, exhaust) =
+            res_inst_tac context [(("y", 0), "x")] exhaust 1 ::
+            asm_simp_tac (take_ss addsimps prems) 1 ::
+            map con_tac cons;
+          val tacs = tacs1 @ maps cases_tacs (conss ~~ exhausts)
+        in
+          EVERY (map DETERM tacs)
+        end;
+    in Goal.prove_global thy [] assms goal tacf end;
+
+  val _ = trace " Proving ind...";
+  val ind =
+    let
+      val concls = map (op $) (Ps ~~ xs);
+      val goal = mk_trp (foldr1 mk_conj concls);
+      val adms = if is_finite then [] else map (mk_trp o mk_adm) Ps;
+      fun tacf {prems, context} =
+        let
+          fun finite_tac (take_induct, fin_ind) =
+              rtac take_induct 1 THEN
+              (if is_finite then all_tac else resolve_tac prems 1) THEN
+              (rtac fin_ind THEN_ALL_NEW solve_tac prems) 1;
+          val fin_inds = Project_Rule.projections context finite_ind;
+        in
+          TRY (safe_tac HOL_cs) THEN
+          EVERY (map finite_tac (take_induct_thms ~~ fin_inds))
+        end;
+    in Goal.prove_global thy [] (adms @ assms) goal tacf end
+
+  (* case names for induction rules *)
+  val dnames = map (fst o dest_Type) newTs;
+  val case_ns =
+    let
+      val adms =
+          if is_finite then [] else
+          if length dnames = 1 then ["adm"] else
+          map (fn s => "adm_" ^ Long_Name.base_name s) dnames;
+      val bottoms =
+          if length dnames = 1 then ["bottom"] else
+          map (fn s => "bottom_" ^ Long_Name.base_name s) dnames;
+      fun one_eq bot constr_info =
+        let fun name_of (c, args) = Long_Name.base_name (fst (dest_Const c));
+        in bot :: map name_of (#con_specs constr_info) end;
+    in adms @ flat (map2 one_eq bottoms constr_infos) end;
+
+  val inducts = Project_Rule.projections (ProofContext.init_global thy) ind;
+  fun ind_rule (dname, rule) =
+      ((Binding.empty, rule),
+       [Rule_Cases.case_names case_ns, Induct.induct_type dname]);
+
+in
+  thy
+  |> snd o Global_Theory.add_thms [
+     ((Binding.qualified true "finite_induct" comp_dbind, finite_ind), []),
+     ((Binding.qualified true "induct"        comp_dbind, ind       ), [])]
+  |> (snd o Global_Theory.add_thms (map ind_rule (dnames ~~ inducts)))
+end; (* prove_induction *)
+
+(******************************************************************************)
+(************************ bisimulation and coinduction ************************)
+(******************************************************************************)
+
+fun prove_coinduction
+    (comp_dbind : binding, dbinds : binding list)
+    (constr_infos : Domain_Constructors.constr_info list)
+    (take_info : Domain_Take_Proofs.take_induct_info)
+    (take_rews : thm list list)
+    (thy : theory) : theory =
+let
+  val iso_infos = map #iso_info constr_infos;
+  val newTs = map #absT iso_infos;
+
+  val {take_consts, take_0_thms, take_lemma_thms, ...} = take_info;
+
+  val R_names = Datatype_Prop.indexify_names (map (K "R") newTs);
+  val R_types = map (fn T => T --> T --> boolT) newTs;
+  val Rs = map Free (R_names ~~ R_types);
+  val n = Free ("n", natT);
+  val reserved = "x" :: "y" :: R_names;
+
+  (* declare bisimulation predicate *)
+  val bisim_bind = Binding.suffix_name "_bisim" comp_dbind;
+  val bisim_type = R_types ---> boolT;
+  val (bisim_const, thy) =
+      Sign.declare_const ((bisim_bind, bisim_type), NoSyn) thy;
+
+  (* define bisimulation predicate *)
+  local
+    fun one_con T (con, args) =
+      let
+        val Ts = map snd args;
+        val ns1 = Name.variant_list reserved (Datatype_Prop.make_tnames Ts);
+        val ns2 = map (fn n => n^"'") ns1;
+        val vs1 = map Free (ns1 ~~ Ts);
+        val vs2 = map Free (ns2 ~~ Ts);
+        val eq1 = mk_eq (Free ("x", T), list_ccomb (con, vs1));
+        val eq2 = mk_eq (Free ("y", T), list_ccomb (con, vs2));
+        fun rel ((v1, v2), T) =
+            case AList.lookup (op =) (newTs ~~ Rs) T of
+              NONE => mk_eq (v1, v2) | SOME r => r $ v1 $ v2;
+        val eqs = foldr1 mk_conj (map rel (vs1 ~~ vs2 ~~ Ts) @ [eq1, eq2]);
+      in
+        Library.foldr mk_ex (vs1 @ vs2, eqs)
+      end;
+    fun one_eq ((T, R), cons) =
+      let
+        val x = Free ("x", T);
+        val y = Free ("y", T);
+        val disj1 = mk_conj (mk_eq (x, mk_bottom T), mk_eq (y, mk_bottom T));
+        val disjs = disj1 :: map (one_con T) cons;
+      in
+        mk_all (x, mk_all (y, mk_imp (R $ x $ y, foldr1 mk_disj disjs)))
+      end;
+    val conjs = map one_eq (newTs ~~ Rs ~~ map #con_specs constr_infos);
+    val bisim_rhs = lambdas Rs (Library.foldr1 mk_conj conjs);
+    val bisim_eqn = Logic.mk_equals (bisim_const, bisim_rhs);
+  in
+    val (bisim_def_thm, thy) = thy |>
+        yield_singleton (Global_Theory.add_defs false)
+         ((Binding.qualified true "bisim_def" comp_dbind, bisim_eqn), []);
+  end (* local *)
+
+  (* prove coinduction lemma *)
+  val coind_lemma =
+    let
+      val assm = mk_trp (list_comb (bisim_const, Rs));
+      fun one ((T, R), take_const) =
+        let
+          val x = Free ("x", T);
+          val y = Free ("y", T);
+          val lhs = mk_capply (take_const $ n, x);
+          val rhs = mk_capply (take_const $ n, y);
+        in
+          mk_all (x, mk_all (y, mk_imp (R $ x $ y, mk_eq (lhs, rhs))))
+        end;
+      val goal =
+          mk_trp (foldr1 mk_conj (map one (newTs ~~ Rs ~~ take_consts)));
+      val rules = @{thm Rep_cfun_strict1} :: take_0_thms;
+      fun tacf {prems, context} =
+        let
+          val prem' = rewrite_rule [bisim_def_thm] (hd prems);
+          val prems' = Project_Rule.projections context prem';
+          val dests = map (fn th => th RS spec RS spec RS mp) prems';
+          fun one_tac (dest, rews) =
+              dtac dest 1 THEN safe_tac HOL_cs THEN
+              ALLGOALS (asm_simp_tac (HOL_basic_ss addsimps rews));
+        in
+          rtac @{thm nat.induct} 1 THEN
+          simp_tac (HOL_ss addsimps rules) 1 THEN
+          safe_tac HOL_cs THEN
+          EVERY (map one_tac (dests ~~ take_rews))
+        end
+    in
+      Goal.prove_global thy [] [assm] goal tacf
+    end;
+
+  (* prove individual coinduction rules *)
+  fun prove_coind ((T, R), take_lemma) =
+    let
+      val x = Free ("x", T);
+      val y = Free ("y", T);
+      val assm1 = mk_trp (list_comb (bisim_const, Rs));
+      val assm2 = mk_trp (R $ x $ y);
+      val goal = mk_trp (mk_eq (x, y));
+      fun tacf {prems, context} =
+        let
+          val rule = hd prems RS coind_lemma;
+        in
+          rtac take_lemma 1 THEN
+          asm_simp_tac (HOL_basic_ss addsimps (rule :: prems)) 1
+        end;
+    in
+      Goal.prove_global thy [] [assm1, assm2] goal tacf
+    end;
+  val coinds = map prove_coind (newTs ~~ Rs ~~ take_lemma_thms);
+  val coind_binds = map (Binding.qualified true "coinduct") dbinds;
+
+in
+  thy |> snd o Global_Theory.add_thms
+    (map Thm.no_attributes (coind_binds ~~ coinds))
+end; (* let *)
+
+(******************************************************************************)
+(******************************* main function ********************************)
+(******************************************************************************)
+
+fun comp_theorems
+    (dbinds : binding list)
+    (take_info : Domain_Take_Proofs.take_induct_info)
+    (constr_infos : Domain_Constructors.constr_info list)
+    (thy : theory) =
+let
+
+val comp_dname = space_implode "_" (map Binding.name_of dbinds);
+val comp_dbind = Binding.name comp_dname;
+
+(* Test for emptiness *)
+(* FIXME: reimplement emptiness test
+local
+  open Domain_Library;
+  val dnames = map (fst o fst) eqs;
+  val conss = map snd eqs;
+  fun rec_to ns lazy_rec (n,cons) = forall (exists (fn arg => 
+        is_rec arg andalso not (member (op =) ns (rec_of arg)) andalso
+        ((rec_of arg =  n andalso not (lazy_rec orelse is_lazy arg)) orelse 
+          rec_of arg <> n andalso rec_to (rec_of arg::ns) 
+            (lazy_rec orelse is_lazy arg) (n, (List.nth(conss,rec_of arg))))
+        ) o snd) cons;
+  fun warn (n,cons) =
+    if rec_to [] false (n,cons)
+    then (warning ("domain "^List.nth(dnames,n)^" is empty!"); true)
+    else false;
+in
+  val n__eqs = mapn (fn n => fn (_,cons) => (n,cons)) 0 eqs;
+  val is_emptys = map warn n__eqs;
+end;
+*)
+
+(* Test for indirect recursion *)
+local
+  val newTs = map (#absT o #iso_info) constr_infos;
+  fun indirect_typ (Type (_, Ts)) =
+      exists (fn T => member (op =) newTs T orelse indirect_typ T) Ts
+    | indirect_typ _ = false;
+  fun indirect_arg (_, T) = indirect_typ T;
+  fun indirect_con (_, args) = exists indirect_arg args;
+  fun indirect_eq cons = exists indirect_con cons;
+in
+  val is_indirect = exists indirect_eq (map #con_specs constr_infos);
+  val _ =
+      if is_indirect
+      then message "Indirect recursion detected, skipping proofs of (co)induction rules"
+      else message ("Proving induction properties of domain "^comp_dname^" ...");
+end;
+
+(* theorems about take *)
+
+val (take_rewss, thy) =
+    take_theorems dbinds take_info constr_infos thy;
+
+val {take_lemma_thms, take_0_thms, take_strict_thms, ...} = take_info;
+
+val take_rews = take_0_thms @ take_strict_thms @ flat take_rewss;
+
+(* prove induction rules, unless definition is indirect recursive *)
+val thy =
+    if is_indirect then thy else
+    prove_induction comp_dbind constr_infos take_info take_rews thy;
+
+val thy =
+    if is_indirect then thy else
+    prove_coinduction (comp_dbind, dbinds) constr_infos take_info take_rewss thy;
+
+in
+  (take_rews, thy)
+end; (* let *)
+end; (* struct *)

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/HOLCF/Tools/Domain/domain_isomorphism.ML	Sat Nov 27 16:08:10 2010 -0800
@@ -0,0 +1,787 @@
+(*  Title:      HOLCF/Tools/Domain/domain_isomorphism.ML
+    Author:     Brian Huffman
+
+Defines new types satisfying the given domain equations.
+*)
+
+signature DOMAIN_ISOMORPHISM =
+sig
+  val domain_isomorphism :
+      (string list * binding * mixfix * typ
+       * (binding * binding) option) list ->
+      theory ->
+      (Domain_Take_Proofs.iso_info list
+       * Domain_Take_Proofs.take_induct_info) * theory
+
+  val define_map_functions :
+      (binding * Domain_Take_Proofs.iso_info) list ->
+      theory ->
+      {
+        map_consts : term list,
+        map_apply_thms : thm list,
+        map_unfold_thms : thm list,
+        deflation_map_thms : thm list
+      }
+      * theory
+
+  val domain_isomorphism_cmd :
+    (string list * binding * mixfix * string * (binding * binding) option) list
+      -> theory -> theory
+
+  val setup : theory -> theory
+end;
+
+structure Domain_Isomorphism : DOMAIN_ISOMORPHISM =
+struct
+
+val beta_rules =
+  @{thms beta_cfun cont_id cont_const cont2cont_APP cont2cont_LAM'} @
+  @{thms cont2cont_fst cont2cont_snd cont2cont_Pair cont2cont_prod_case'};
+
+val beta_ss = HOL_basic_ss addsimps (simp_thms @ beta_rules);
+
+val beta_tac = simp_tac beta_ss;
+
+fun is_cpo thy T = Sign.of_sort thy (T, @{sort cpo});
+
+(******************************************************************************)
+(******************************** theory data *********************************)
+(******************************************************************************)
+
+structure RepData = Named_Thms
+(
+  val name = "domain_defl_simps"
+  val description = "theorems like DEFL('a t) = t_defl$DEFL('a)"
+)
+
+structure IsodeflData = Named_Thms
+(
+  val name = "domain_isodefl"
+  val description = "theorems like isodefl d t ==> isodefl (foo_map$d) (foo_defl$t)"
+);
+
+val setup = RepData.setup #> IsodeflData.setup
+
+
+(******************************************************************************)
+(************************** building types and terms **************************)
+(******************************************************************************)
+
+open HOLCF_Library;
+
+infixr 6 ->>;
+infixr -->>;
+
+val udomT = @{typ udom};
+val deflT = @{typ "defl"};
+
+fun mk_DEFL T =
+  Const (@{const_name defl}, Term.itselfT T --> deflT) $ Logic.mk_type T;
+
+fun dest_DEFL (Const (@{const_name defl}, _) $ t) = Logic.dest_type t
+  | dest_DEFL t = raise TERM ("dest_DEFL", [t]);
+
+fun mk_LIFTDEFL T =
+  Const (@{const_name liftdefl}, Term.itselfT T --> deflT) $ Logic.mk_type T;
+
+fun dest_LIFTDEFL (Const (@{const_name liftdefl}, _) $ t) = Logic.dest_type t
+  | dest_LIFTDEFL t = raise TERM ("dest_LIFTDEFL", [t]);
+
+fun mk_u_defl t = mk_capply (@{const "u_defl"}, t);
+
+fun mk_u_map t =
+  let
+    val (T, U) = dest_cfunT (fastype_of t);
+    val u_map_type = (T ->> U) ->> (mk_upT T ->> mk_upT U);
+    val u_map_const = Const (@{const_name u_map}, u_map_type);
+  in
+    mk_capply (u_map_const, t)
+  end;
+
+fun emb_const T = Const (@{const_name emb}, T ->> udomT);
+fun prj_const T = Const (@{const_name prj}, udomT ->> T);
+fun coerce_const (T, U) = mk_cfcomp (prj_const U, emb_const T);
+
+fun isodefl_const T =
+  Const (@{const_name isodefl}, (T ->> T) --> deflT --> HOLogic.boolT);
+
+fun mk_deflation t =
+  Const (@{const_name deflation}, Term.fastype_of t --> boolT) $ t;
+
+(* splits a cterm into the right and lefthand sides of equality *)
+fun dest_eqs t = HOLogic.dest_eq (HOLogic.dest_Trueprop t);
+
+fun mk_eqs (t, u) = HOLogic.mk_Trueprop (HOLogic.mk_eq (t, u));
+
+(******************************************************************************)
+(****************************** isomorphism info ******************************)
+(******************************************************************************)
+
+fun deflation_abs_rep (info : Domain_Take_Proofs.iso_info) : thm =
+  let
+    val abs_iso = #abs_inverse info;
+    val rep_iso = #rep_inverse info;
+    val thm = @{thm deflation_abs_rep} OF [abs_iso, rep_iso];
+  in
+    Drule.zero_var_indexes thm
+  end
+
+(******************************************************************************)
+(*************** fixed-point definitions and unfolding theorems ***************)
+(******************************************************************************)
+
+fun mk_projs []      t = []
+  | mk_projs (x::[]) t = [(x, t)]
+  | mk_projs (x::xs) t = (x, mk_fst t) :: mk_projs xs (mk_snd t);
+
+fun add_fixdefs
+    (spec : (binding * term) list)
+    (thy : theory) : (thm list * thm list) * theory =
+  let
+    val binds = map fst spec;
+    val (lhss, rhss) = ListPair.unzip (map (dest_eqs o snd) spec);
+    val functional = lambda_tuple lhss (mk_tuple rhss);
+    val fixpoint = mk_fix (mk_cabs functional);
+
+    (* project components of fixpoint *)
+    val projs = mk_projs lhss fixpoint;
+
+    (* convert parameters to lambda abstractions *)
+    fun mk_eqn (lhs, rhs) =
+        case lhs of
+          Const (@{const_name Rep_cfun}, _) $ f $ (x as Free _) =>
+            mk_eqn (f, big_lambda x rhs)
+        | f $ Const (@{const_name TYPE}, T) =>
+            mk_eqn (f, Abs ("t", T, rhs))
+        | Const _ => Logic.mk_equals (lhs, rhs)
+        | _ => raise TERM ("lhs not of correct form", [lhs, rhs]);
+    val eqns = map mk_eqn projs;
+
+    (* register constant definitions *)
+    val (fixdef_thms, thy) =
+      (Global_Theory.add_defs false o map Thm.no_attributes)
+        (map (Binding.suffix_name "_def") binds ~~ eqns) thy;
+
+    (* prove applied version of definitions *)
+    fun prove_proj (lhs, rhs) =
+      let
+        val tac = rewrite_goals_tac fixdef_thms THEN beta_tac 1;
+        val goal = Logic.mk_equals (lhs, rhs);
+      in Goal.prove_global thy [] [] goal (K tac) end;
+    val proj_thms = map prove_proj projs;
+
+    (* mk_tuple lhss == fixpoint *)
+    fun pair_equalI (thm1, thm2) = @{thm Pair_equalI} OF [thm1, thm2];
+    val tuple_fixdef_thm = foldr1 pair_equalI proj_thms;
+
+    val cont_thm =
+      Goal.prove_global thy [] [] (mk_trp (mk_cont functional))
+        (K (beta_tac 1));
+    val tuple_unfold_thm =
+      (@{thm def_cont_fix_eq} OF [tuple_fixdef_thm, cont_thm])
+      |> Local_Defs.unfold (ProofContext.init_global thy) @{thms split_conv};
+
+    fun mk_unfold_thms [] thm = []
+      | mk_unfold_thms (n::[]) thm = [(n, thm)]
+      | mk_unfold_thms (n::ns) thm = let
+          val thmL = thm RS @{thm Pair_eqD1};
+          val thmR = thm RS @{thm Pair_eqD2};
+        in (n, thmL) :: mk_unfold_thms ns thmR end;
+    val unfold_binds = map (Binding.suffix_name "_unfold") binds;
+
+    (* register unfold theorems *)
+    val (unfold_thms, thy) =
+      (Global_Theory.add_thms o map (Thm.no_attributes o apsnd Drule.zero_var_indexes))
+        (mk_unfold_thms unfold_binds tuple_unfold_thm) thy;
+  in
+    ((proj_thms, unfold_thms), thy)
+  end;
+
+
+(******************************************************************************)
+(****************** deflation combinators and map functions *******************)
+(******************************************************************************)
+
+fun defl_of_typ
+    (thy : theory)
+    (tab1 : (typ * term) list)
+    (tab2 : (typ * term) list)
+    (T : typ) : term =
+  let
+    val defl_simps = RepData.get (ProofContext.init_global thy);
+    val rules = map (Thm.concl_of #> HOLogic.dest_Trueprop #> HOLogic.dest_eq) defl_simps;
+    val rules' = map (apfst mk_DEFL) tab1 @ map (apfst mk_LIFTDEFL) tab2;
+    fun proc1 t =
+      (case dest_DEFL t of
+        TFree (a, _) => SOME (Free ("d" ^ Library.unprefix "'" a, deflT))
+      | _ => NONE) handle TERM _ => NONE;
+    fun proc2 t =
+      (case dest_LIFTDEFL t of
+        TFree (a, _) => SOME (Free ("p" ^ Library.unprefix "'" a, deflT))
+      | _ => NONE) handle TERM _ => NONE;
+  in
+    Pattern.rewrite_term thy (rules @ rules') [proc1, proc2] (mk_DEFL T)
+  end;
+
+(******************************************************************************)
+(********************* declaring definitions and theorems *********************)
+(******************************************************************************)
+
+fun define_const
+    (bind : binding, rhs : term)
+    (thy : theory)
+    : (term * thm) * theory =
+  let
+    val typ = Term.fastype_of rhs;
+    val (const, thy) = Sign.declare_const ((bind, typ), NoSyn) thy;
+    val eqn = Logic.mk_equals (const, rhs);
+    val def = Thm.no_attributes (Binding.suffix_name "_def" bind, eqn);
+    val (def_thm, thy) = yield_singleton (Global_Theory.add_defs false) def thy;
+  in
+    ((const, def_thm), thy)
+  end;
+
+fun add_qualified_thm name (dbind, thm) =
+    yield_singleton Global_Theory.add_thms
+      ((Binding.qualified true name dbind, thm), []);
+
+(******************************************************************************)
+(*************************** defining map functions ***************************)
+(******************************************************************************)
+
+fun define_map_functions
+    (spec : (binding * Domain_Take_Proofs.iso_info) list)
+    (thy : theory) =
+  let
+
+    (* retrieve components of spec *)
+    val dbinds = map fst spec;
+    val iso_infos = map snd spec;
+    val dom_eqns = map (fn x => (#absT x, #repT x)) iso_infos;
+    val rep_abs_consts = map (fn x => (#rep_const x, #abs_const x)) iso_infos;
+
+    fun mapT (T as Type (_, Ts)) =
+        (map (fn T => T ->> T) (filter (is_cpo thy) Ts)) -->> (T ->> T)
+      | mapT T = T ->> T;
+
+    (* declare map functions *)
+    fun declare_map_const (tbind, (lhsT, rhsT)) thy =
+      let
+        val map_type = mapT lhsT;
+        val map_bind = Binding.suffix_name "_map" tbind;
+      in
+        Sign.declare_const ((map_bind, map_type), NoSyn) thy
+      end;
+    val (map_consts, thy) = thy |>
+      fold_map declare_map_const (dbinds ~~ dom_eqns);
+
+    (* defining equations for map functions *)
+    local
+      fun unprime a = Library.unprefix "'" a;
+      fun mapvar T = Free (unprime (fst (dest_TFree T)), T ->> T);
+      fun map_lhs (map_const, lhsT) =
+          (lhsT, list_ccomb (map_const, map mapvar (filter (is_cpo thy) (snd (dest_Type lhsT)))));
+      val tab1 = map map_lhs (map_consts ~~ map fst dom_eqns);
+      val Ts = (snd o dest_Type o fst o hd) dom_eqns;
+      val tab = (Ts ~~ map mapvar Ts) @ tab1;
+      fun mk_map_spec (((rep_const, abs_const), map_const), (lhsT, rhsT)) =
+        let
+          val lhs = Domain_Take_Proofs.map_of_typ thy tab lhsT;
+          val body = Domain_Take_Proofs.map_of_typ thy tab rhsT;
+          val rhs = mk_cfcomp (abs_const, mk_cfcomp (body, rep_const));
+        in mk_eqs (lhs, rhs) end;
+    in
+      val map_specs =
+          map mk_map_spec (rep_abs_consts ~~ map_consts ~~ dom_eqns);
+    end;
+
+    (* register recursive definition of map functions *)
+    val map_binds = map (Binding.suffix_name "_map") dbinds;
+    val ((map_apply_thms, map_unfold_thms), thy) =
+      add_fixdefs (map_binds ~~ map_specs) thy;
+
+    (* prove deflation theorems for map functions *)
+    val deflation_abs_rep_thms = map deflation_abs_rep iso_infos;
+    val deflation_map_thm =
+      let
+        fun unprime a = Library.unprefix "'" a;
+        fun mk_f T = Free (unprime (fst (dest_TFree T)), T ->> T);
+        fun mk_assm T = mk_trp (mk_deflation (mk_f T));
+        fun mk_goal (map_const, (lhsT, rhsT)) =
+          let
+            val (_, Ts) = dest_Type lhsT;
+            val map_term = list_ccomb (map_const, map mk_f (filter (is_cpo thy) Ts));
+          in mk_deflation map_term end;
+        val assms = (map mk_assm o filter (is_cpo thy) o snd o dest_Type o fst o hd) dom_eqns;
+        val goals = map mk_goal (map_consts ~~ dom_eqns);
+        val goal = mk_trp (foldr1 HOLogic.mk_conj goals);
+        val start_thms =
+          @{thm split_def} :: map_apply_thms;
+        val adm_rules =
+          @{thms adm_conj adm_subst [OF _ adm_deflation]
+                 cont2cont_fst cont2cont_snd cont_id};
+        val bottom_rules =
+          @{thms fst_strict snd_strict deflation_UU simp_thms};
+        val deflation_rules =
+          @{thms conjI deflation_ID}
+          @ deflation_abs_rep_thms
+          @ Domain_Take_Proofs.get_deflation_thms thy;
+      in
+        Goal.prove_global thy [] assms goal (fn {prems, ...} =>
+         EVERY
+          [simp_tac (HOL_basic_ss addsimps start_thms) 1,
+           rtac @{thm fix_ind} 1,
+           REPEAT (resolve_tac adm_rules 1),
+           simp_tac (HOL_basic_ss addsimps bottom_rules) 1,
+           simp_tac beta_ss 1,
+           simp_tac (HOL_basic_ss addsimps @{thms fst_conv snd_conv}) 1,
+           REPEAT (etac @{thm conjE} 1),
+           REPEAT (resolve_tac (deflation_rules @ prems) 1 ORELSE atac 1)])
+      end;
+    fun conjuncts [] thm = []
+      | conjuncts (n::[]) thm = [(n, thm)]
+      | conjuncts (n::ns) thm = let
+          val thmL = thm RS @{thm conjunct1};
+          val thmR = thm RS @{thm conjunct2};
+        in (n, thmL):: conjuncts ns thmR end;
+    val deflation_map_binds = dbinds |>
+        map (Binding.prefix_name "deflation_" o Binding.suffix_name "_map");
+    val (deflation_map_thms, thy) = thy |>
+      (Global_Theory.add_thms o map (Thm.no_attributes o apsnd Drule.zero_var_indexes))
+        (conjuncts deflation_map_binds deflation_map_thm);
+
+    (* register indirect recursion in theory data *)
+    local
+      fun register_map (dname, args) =
+        Domain_Take_Proofs.add_rec_type (dname, args);
+      val dnames = map (fst o dest_Type o fst) dom_eqns;
+      val map_names = map (fst o dest_Const) map_consts;
+      fun args (T, _) = case T of Type (_, Ts) => map (is_cpo thy) Ts | _ => [];
+      val argss = map args dom_eqns;
+    in
+      val thy =
+          fold register_map (dnames ~~ argss) thy;
+    end;
+
+    (* register deflation theorems *)
+    val thy = fold Domain_Take_Proofs.add_deflation_thm deflation_map_thms thy;
+
+    val result =
+      {
+        map_consts = map_consts,
+        map_apply_thms = map_apply_thms,
+        map_unfold_thms = map_unfold_thms,
+        deflation_map_thms = deflation_map_thms
+      }
+  in
+    (result, thy)
+  end;
+
+(******************************************************************************)
+(******************************* main function ********************************)
+(******************************************************************************)
+
+fun read_typ thy str sorts =
+  let
+    val ctxt = ProofContext.init_global thy
+      |> fold (Variable.declare_typ o TFree) sorts;
+    val T = Syntax.read_typ ctxt str;
+  in (T, Term.add_tfreesT T sorts) end;
+
+fun cert_typ sign raw_T sorts =
+  let
+    val T = Type.no_tvars (Sign.certify_typ sign raw_T)
+      handle TYPE (msg, _, _) => error msg;
+    val sorts' = Term.add_tfreesT T sorts;
+    val _ =
+      case duplicates (op =) (map fst sorts') of
+        [] => ()
+      | dups => error ("Inconsistent sort constraints for " ^ commas dups)
+  in (T, sorts') end;
+
+fun gen_domain_isomorphism
+    (prep_typ: theory -> 'a -> (string * sort) list -> typ * (string * sort) list)
+    (doms_raw: (string list * binding * mixfix * 'a * (binding * binding) option) list)
+    (thy: theory)
+    : (Domain_Take_Proofs.iso_info list
+       * Domain_Take_Proofs.take_induct_info) * theory =
+  let
+    val _ = Theory.requires thy "Domain" "domain isomorphisms";
+
+    (* this theory is used just for parsing *)
+    val tmp_thy = thy |>
+      Theory.copy |>
+      Sign.add_types (map (fn (tvs, tbind, mx, _, morphs) =>
+        (tbind, length tvs, mx)) doms_raw);
+
+    fun prep_dom thy (vs, t, mx, typ_raw, morphs) sorts =
+      let val (typ, sorts') = prep_typ thy typ_raw sorts
+      in ((vs, t, mx, typ, morphs), sorts') end;
+
+    val (doms : (string list * binding * mixfix * typ * (binding * binding) option) list,
+         sorts : (string * sort) list) =
+      fold_map (prep_dom tmp_thy) doms_raw [];
+
+    (* lookup function for sorts of type variables *)
+    fun the_sort v = the (AList.lookup (op =) sorts v);
+
+    (* declare arities in temporary theory *)
+    val tmp_thy =
+      let
+        fun arity (vs, tbind, mx, _, _) =
+          (Sign.full_name thy tbind, map the_sort vs, @{sort "domain"});
+      in
+        fold AxClass.axiomatize_arity (map arity doms) tmp_thy
+      end;
+
+    (* check bifiniteness of right-hand sides *)
+    fun check_rhs (vs, tbind, mx, rhs, morphs) =
+      if Sign.of_sort tmp_thy (rhs, @{sort "domain"}) then ()
+      else error ("Type not of sort domain: " ^
+        quote (Syntax.string_of_typ_global tmp_thy rhs));
+    val _ = map check_rhs doms;
+
+    (* domain equations *)
+    fun mk_dom_eqn (vs, tbind, mx, rhs, morphs) =
+      let fun arg v = TFree (v, the_sort v);
+      in (Type (Sign.full_name tmp_thy tbind, map arg vs), rhs) end;
+    val dom_eqns = map mk_dom_eqn doms;
+
+    (* check for valid type parameters *)
+    val (tyvars, _, _, _, _) = hd doms;
+    val new_doms = map (fn (tvs, tname, mx, _, _) =>
+      let val full_tname = Sign.full_name tmp_thy tname
+      in
+        (case duplicates (op =) tvs of
+          [] =>
+            if eq_set (op =) (tyvars, tvs) then (full_tname, tvs)
+            else error ("Mutually recursive domains must have same type parameters")
+        | dups => error ("Duplicate parameter(s) for domain " ^ quote (Binding.str_of tname) ^
+            " : " ^ commas dups))
+      end) doms;
+    val dbinds = map (fn (_, dbind, _, _, _) => dbind) doms;
+    val morphs = map (fn (_, _, _, _, morphs) => morphs) doms;
+
+    (* determine deflation combinator arguments *)
+    val lhsTs : typ list = map fst dom_eqns;
+    val defl_rec = Free ("t", mk_tupleT (map (K deflT) lhsTs));
+    val defl_recs = mk_projs lhsTs defl_rec;
+    val defl_recs' = map (apsnd mk_u_defl) defl_recs;
+    fun defl_body (_, _, _, rhsT, _) =
+      defl_of_typ tmp_thy defl_recs defl_recs' rhsT;
+    val functional = Term.lambda defl_rec (mk_tuple (map defl_body doms));
+
+    val tfrees = map fst (Term.add_tfrees functional []);
+    val frees = map fst (Term.add_frees functional []);
+    fun get_defl_flags (vs, _, _, _, _) =
+      let
+        fun argT v = TFree (v, the_sort v);
+        fun mk_d v = "d" ^ Library.unprefix "'" v;
+        fun mk_p v = "p" ^ Library.unprefix "'" v;
+        val args = maps (fn v => [(mk_d v, mk_DEFL (argT v)), (mk_p v, mk_LIFTDEFL (argT v))]) vs;
+        val typeTs = map argT (filter (member (op =) tfrees) vs);
+        val defl_args = map snd (filter (member (op =) frees o fst) args);
+      in
+        (typeTs, defl_args)
+      end;
+    val defl_flagss = map get_defl_flags doms;
+
+    (* declare deflation combinator constants *)
+    fun declare_defl_const ((typeTs, defl_args), (_, tbind, _, _, _)) thy =
+      let
+        val defl_bind = Binding.suffix_name "_defl" tbind;
+        val defl_type =
+          map Term.itselfT typeTs ---> map (K deflT) defl_args -->> deflT;
+      in
+        Sign.declare_const ((defl_bind, defl_type), NoSyn) thy
+      end;
+    val (defl_consts, thy) =
+      fold_map declare_defl_const (defl_flagss ~~ doms) thy;
+
+    (* defining equations for type combinators *)
+    fun mk_defl_term (defl_const, (typeTs, defl_args)) =
+      let
+        val type_args = map Logic.mk_type typeTs;
+      in
+        list_ccomb (list_comb (defl_const, type_args), defl_args)
+      end;
+    val defl_terms = map mk_defl_term (defl_consts ~~ defl_flagss);
+    val defl_tab = map fst dom_eqns ~~ defl_terms;
+    val defl_tab' = map fst dom_eqns ~~ map mk_u_defl defl_terms;
+    fun mk_defl_spec (lhsT, rhsT) =
+      mk_eqs (defl_of_typ tmp_thy defl_tab defl_tab' lhsT,
+              defl_of_typ tmp_thy defl_tab defl_tab' rhsT);
+    val defl_specs = map mk_defl_spec dom_eqns;
+
+    (* register recursive definition of deflation combinators *)
+    val defl_binds = map (Binding.suffix_name "_defl") dbinds;
+    val ((defl_apply_thms, defl_unfold_thms), thy) =
+      add_fixdefs (defl_binds ~~ defl_specs) thy;
+
+    (* define types using deflation combinators *)
+    fun make_repdef ((vs, tbind, mx, _, _), defl) thy =
+      let
+        val spec = (tbind, map (rpair dummyS) vs, mx);
+        val ((_, _, _, {DEFL, liftemb_def, liftprj_def, ...}), thy) =
+          Domaindef.add_domaindef false NONE spec defl NONE thy;
+        (* declare domain_defl_simps rules *)
+        val thy = Context.theory_map (RepData.add_thm DEFL) thy;
+      in
+        (DEFL, thy)
+      end;
+    val (DEFL_thms, thy) = fold_map make_repdef (doms ~~ defl_terms) thy;
+
+    (* prove DEFL equations *)
+    fun mk_DEFL_eq_thm (lhsT, rhsT) =
+      let
+        val goal = mk_eqs (mk_DEFL lhsT, mk_DEFL rhsT);
+        val DEFL_simps = RepData.get (ProofContext.init_global thy);
+        val tac =
+          rewrite_goals_tac (map mk_meta_eq DEFL_simps)
+          THEN TRY (resolve_tac defl_unfold_thms 1);
+      in
+        Goal.prove_global thy [] [] goal (K tac)
+      end;
+    val DEFL_eq_thms = map mk_DEFL_eq_thm dom_eqns;
+
+    (* register DEFL equations *)
+    val DEFL_eq_binds = map (Binding.prefix_name "DEFL_eq_") dbinds;
+    val (_, thy) = thy |>
+      (Global_Theory.add_thms o map Thm.no_attributes)
+        (DEFL_eq_binds ~~ DEFL_eq_thms);
+
+    (* define rep/abs functions *)
+    fun mk_rep_abs ((tbind, morphs), (lhsT, rhsT)) thy =
+      let
+        val rep_bind = Binding.suffix_name "_rep" tbind;
+        val abs_bind = Binding.suffix_name "_abs" tbind;
+        val ((rep_const, rep_def), thy) =
+            define_const (rep_bind, coerce_const (lhsT, rhsT)) thy;
+        val ((abs_const, abs_def), thy) =
+            define_const (abs_bind, coerce_const (rhsT, lhsT)) thy;
+      in
+        (((rep_const, abs_const), (rep_def, abs_def)), thy)
+      end;
+    val ((rep_abs_consts, rep_abs_defs), thy) = thy
+      |> fold_map mk_rep_abs (dbinds ~~ morphs ~~ dom_eqns)
+      |>> ListPair.unzip;
+
+    (* prove isomorphism and isodefl rules *)
+    fun mk_iso_thms ((tbind, DEFL_eq), (rep_def, abs_def)) thy =
+      let
+        fun make thm =
+            Drule.zero_var_indexes (thm OF [DEFL_eq, abs_def, rep_def]);
+        val rep_iso_thm = make @{thm domain_rep_iso};
+        val abs_iso_thm = make @{thm domain_abs_iso};
+        val isodefl_thm = make @{thm isodefl_abs_rep};
+        val thy = thy
+          |> snd o add_qualified_thm "rep_iso" (tbind, rep_iso_thm)
+          |> snd o add_qualified_thm "abs_iso" (tbind, abs_iso_thm)
+          |> snd o add_qualified_thm "isodefl_abs_rep" (tbind, isodefl_thm);
+      in
+        (((rep_iso_thm, abs_iso_thm), isodefl_thm), thy)
+      end;
+    val ((iso_thms, isodefl_abs_rep_thms), thy) =
+      thy
+      |> fold_map mk_iso_thms (dbinds ~~ DEFL_eq_thms ~~ rep_abs_defs)
+      |>> ListPair.unzip;
+
+    (* collect info about rep/abs *)
+    val iso_infos : Domain_Take_Proofs.iso_info list =
+      let
+        fun mk_info (((lhsT, rhsT), (repC, absC)), (rep_iso, abs_iso)) =
+          {
+            repT = rhsT,
+            absT = lhsT,
+            rep_const = repC,
+            abs_const = absC,
+            rep_inverse = rep_iso,
+            abs_inverse = abs_iso
+          };
+      in
+        map mk_info (dom_eqns ~~ rep_abs_consts ~~ iso_thms)
+      end
+
+    (* definitions and proofs related to map functions *)
+    val (map_info, thy) =
+        define_map_functions (dbinds ~~ iso_infos) thy;
+    val { map_consts, map_apply_thms, map_unfold_thms,
+          deflation_map_thms } = map_info;
+
+    (* prove isodefl rules for map functions *)
+    val isodefl_thm =
+      let
+        fun unprime a = Library.unprefix "'" a;
+        fun mk_d T = Free ("d" ^ unprime (fst (dest_TFree T)), deflT);
+        fun mk_p T = Free ("p" ^ unprime (fst (dest_TFree T)), deflT);
+        fun mk_f T = Free ("f" ^ unprime (fst (dest_TFree T)), T ->> T);
+        fun mk_assm t =
+          case try dest_LIFTDEFL t of
+            SOME T => mk_trp (isodefl_const (mk_upT T) $ mk_u_map (mk_f T) $ mk_p T)
+          | NONE =>
+            let val T = dest_DEFL t
+            in mk_trp (isodefl_const T $ mk_f T $ mk_d T) end;
+        fun mk_goal (map_const, (T, rhsT)) =
+          let
+            val (_, Ts) = dest_Type T;
+            val map_term = list_ccomb (map_const, map mk_f (filter (is_cpo thy) Ts));
+            val defl_term = defl_of_typ thy (Ts ~~ map mk_d Ts) (Ts ~~ map mk_p Ts) T;
+          in isodefl_const T $ map_term $ defl_term end;
+        val assms = (map mk_assm o snd o hd) defl_flagss;
+        val goals = map mk_goal (map_consts ~~ dom_eqns);
+        val goal = mk_trp (foldr1 HOLogic.mk_conj goals);
+        val start_thms =
+          @{thm split_def} :: defl_apply_thms @ map_apply_thms;
+        val adm_rules =
+          @{thms adm_conj adm_isodefl cont2cont_fst cont2cont_snd cont_id};
+        val bottom_rules =
+          @{thms fst_strict snd_strict isodefl_bottom simp_thms};
+        val map_ID_thms = Domain_Take_Proofs.get_map_ID_thms thy;
+        val map_ID_simps = map (fn th => th RS sym) map_ID_thms;
+        val isodefl_rules =
+          @{thms conjI isodefl_ID_DEFL isodefl_LIFTDEFL}
+          @ isodefl_abs_rep_thms
+          @ IsodeflData.get (ProofContext.init_global thy);
+      in
+        Goal.prove_global thy [] assms goal (fn {prems, ...} =>
+         EVERY
+          [simp_tac (HOL_basic_ss addsimps start_thms) 1,
+           (* FIXME: how reliable is unification here? *)
+           (* Maybe I should instantiate the rule. *)
+           rtac @{thm parallel_fix_ind} 1,
+           REPEAT (resolve_tac adm_rules 1),
+           simp_tac (HOL_basic_ss addsimps bottom_rules) 1,
+           simp_tac beta_ss 1,
+           simp_tac (HOL_basic_ss addsimps @{thms fst_conv snd_conv}) 1,
+           simp_tac (HOL_basic_ss addsimps map_ID_simps) 1,
+           REPEAT (etac @{thm conjE} 1),
+           REPEAT (resolve_tac (isodefl_rules @ prems) 1 ORELSE atac 1)])
+      end;
+    val isodefl_binds = map (Binding.prefix_name "isodefl_") dbinds;
+    fun conjuncts [] thm = []
+      | conjuncts (n::[]) thm = [(n, thm)]
+      | conjuncts (n::ns) thm = let
+          val thmL = thm RS @{thm conjunct1};
+          val thmR = thm RS @{thm conjunct2};
+        in (n, thmL):: conjuncts ns thmR end;
+    val (isodefl_thms, thy) = thy |>
+      (Global_Theory.add_thms o map (Thm.no_attributes o apsnd Drule.zero_var_indexes))
+        (conjuncts isodefl_binds isodefl_thm);
+    val thy = fold (Context.theory_map o IsodeflData.add_thm) isodefl_thms thy;
+
+    (* prove map_ID theorems *)
+    fun prove_map_ID_thm
+        (((map_const, (lhsT, _)), DEFL_thm), isodefl_thm) =
+      let
+        val Ts = snd (dest_Type lhsT);
+        fun is_cpo T = Sign.of_sort thy (T, @{sort cpo});
+        val lhs = list_ccomb (map_const, map mk_ID (filter is_cpo Ts));
+        val goal = mk_eqs (lhs, mk_ID lhsT);
+        val tac = EVERY
+          [rtac @{thm isodefl_DEFL_imp_ID} 1,
+           stac DEFL_thm 1,
+           rtac isodefl_thm 1,
+           REPEAT (resolve_tac @{thms isodefl_ID_DEFL isodefl_LIFTDEFL} 1)];
+      in
+        Goal.prove_global thy [] [] goal (K tac)
+      end;
+    val map_ID_binds = map (Binding.suffix_name "_map_ID") dbinds;
+    val map_ID_thms =
+      map prove_map_ID_thm
+        (map_consts ~~ dom_eqns ~~ DEFL_thms ~~ isodefl_thms);
+    val (_, thy) = thy |>
+      (Global_Theory.add_thms o map (rpair [Domain_Take_Proofs.map_ID_add]))
+        (map_ID_binds ~~ map_ID_thms);
+
+    (* definitions and proofs related to take functions *)
+    val (take_info, thy) =
+        Domain_Take_Proofs.define_take_functions
+          (dbinds ~~ iso_infos) thy;
+    val { take_consts, chain_take_thms, take_0_thms, take_Suc_thms, ...} =
+        take_info;
+
+    (* least-upper-bound lemma for take functions *)
+    val lub_take_lemma =
+      let
+        val lhs = mk_tuple (map mk_lub take_consts);
+        fun is_cpo T = Sign.of_sort thy (T, @{sort cpo});
+        fun mk_map_ID (map_const, (lhsT, rhsT)) =
+          list_ccomb (map_const, map mk_ID (filter is_cpo (snd (dest_Type lhsT))));
+        val rhs = mk_tuple (map mk_map_ID (map_consts ~~ dom_eqns));
+        val goal = mk_trp (mk_eq (lhs, rhs));
+        val map_ID_thms = Domain_Take_Proofs.get_map_ID_thms thy;
+        val start_rules =
+            @{thms lub_Pair [symmetric] ch2ch_Pair} @ chain_take_thms
+            @ @{thms pair_collapse split_def}
+            @ map_apply_thms @ map_ID_thms;
+        val rules0 =
+            @{thms iterate_0 Pair_strict} @ take_0_thms;
+        val rules1 =
+            @{thms iterate_Suc Pair_fst_snd_eq fst_conv snd_conv}
+            @ take_Suc_thms;
+        val tac =
+            EVERY
+            [simp_tac (HOL_basic_ss addsimps start_rules) 1,
+             simp_tac (HOL_basic_ss addsimps @{thms fix_def2}) 1,
+             rtac @{thm lub_eq} 1,
+             rtac @{thm nat.induct} 1,
+             simp_tac (HOL_basic_ss addsimps rules0) 1,
+             asm_full_simp_tac (beta_ss addsimps rules1) 1];
+      in
+        Goal.prove_global thy [] [] goal (K tac)
+      end;
+
+    (* prove lub of take equals ID *)
+    fun prove_lub_take (((dbind, take_const), map_ID_thm), (lhsT, rhsT)) thy =
+      let
+        val n = Free ("n", natT);
+        val goal = mk_eqs (mk_lub (lambda n (take_const $ n)), mk_ID lhsT);
+        val tac =
+            EVERY
+            [rtac @{thm trans} 1, rtac map_ID_thm 2,
+             cut_facts_tac [lub_take_lemma] 1,
+             REPEAT (etac @{thm Pair_inject} 1), atac 1];
+        val lub_take_thm = Goal.prove_global thy [] [] goal (K tac);
+      in
+        add_qualified_thm "lub_take" (dbind, lub_take_thm) thy
+      end;
+    val (lub_take_thms, thy) =
+        fold_map prove_lub_take
+          (dbinds ~~ take_consts ~~ map_ID_thms ~~ dom_eqns) thy;
+
+    (* prove additional take theorems *)
+    val (take_info2, thy) =
+        Domain_Take_Proofs.add_lub_take_theorems
+          (dbinds ~~ iso_infos) take_info lub_take_thms thy;
+  in
+    ((iso_infos, take_info2), thy)
+  end;
+
+val domain_isomorphism = gen_domain_isomorphism cert_typ;
+val domain_isomorphism_cmd = snd oo gen_domain_isomorphism read_typ;
+
+(******************************************************************************)
+(******************************** outer syntax ********************************)
+(******************************************************************************)
+
+local
+
+val parse_domain_iso :
+    (string list * binding * mixfix * string * (binding * binding) option)
+      parser =
+  (Parse.type_args -- Parse.binding -- Parse.opt_mixfix -- (Parse.$$$ "=" |-- Parse.typ) --
+    Scan.option (Parse.$$$ "morphisms" |-- Parse.!!! (Parse.binding -- Parse.binding)))
+    >> (fn ((((vs, t), mx), rhs), morphs) => (vs, t, mx, rhs, morphs));
+
+val parse_domain_isos = Parse.and_list1 parse_domain_iso;
+
+in
+
+val _ =
+  Outer_Syntax.command "domain_isomorphism" "define domain isomorphisms (HOLCF)"
+    Keyword.thy_decl
+    (parse_domain_isos >> (Toplevel.theory o domain_isomorphism_cmd));
+
+end;
+
+end;

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/HOLCF/Tools/Domain/domain_take_proofs.ML	Sat Nov 27 16:08:10 2010 -0800
@@ -0,0 +1,609 @@
+(*  Title:      HOLCF/Tools/Domain/domain_take_proofs.ML
+    Author:     Brian Huffman
+
+Defines take functions for the given domain equation
+and proves related theorems.
+*)
+
+signature DOMAIN_TAKE_PROOFS =
+sig
+  type iso_info =
+    {
+      absT : typ,
+      repT : typ,
+      abs_const : term,
+      rep_const : term,
+      abs_inverse : thm,
+      rep_inverse : thm
+    }
+  type take_info =
+    {
+      take_consts : term list,
+      take_defs : thm list,
+      chain_take_thms : thm list,
+      take_0_thms : thm list,
+      take_Suc_thms : thm list,
+      deflation_take_thms : thm list,
+      take_strict_thms : thm list,
+      finite_consts : term list,
+      finite_defs : thm list
+    }
+  type take_induct_info =
+    {
+      take_consts         : term list,
+      take_defs           : thm list,
+      chain_take_thms     : thm list,
+      take_0_thms         : thm list,
+      take_Suc_thms       : thm list,
+      deflation_take_thms : thm list,
+      take_strict_thms    : thm list,
+      finite_consts       : term list,
+      finite_defs         : thm list,
+      lub_take_thms       : thm list,
+      reach_thms          : thm list,
+      take_lemma_thms     : thm list,
+      is_finite           : bool,
+      take_induct_thms    : thm list
+    }
+  val define_take_functions :
+    (binding * iso_info) list -> theory -> take_info * theory
+
+  val add_lub_take_theorems :
+    (binding * iso_info) list -> take_info -> thm list ->
+    theory -> take_induct_info * theory
+
+  val map_of_typ :
+    theory -> (typ * term) list -> typ -> term
+
+  val add_rec_type : (string * bool list) -> theory -> theory
+  val get_rec_tab : theory -> (bool list) Symtab.table
+  val add_deflation_thm : thm -> theory -> theory
+  val get_deflation_thms : theory -> thm list
+  val map_ID_add : attribute
+  val get_map_ID_thms : theory -> thm list
+  val setup : theory -> theory
+end;
+
+structure Domain_Take_Proofs : DOMAIN_TAKE_PROOFS =
+struct
+
+type iso_info =
+  {
+    absT : typ,
+    repT : typ,
+    abs_const : term,
+    rep_const : term,
+    abs_inverse : thm,
+    rep_inverse : thm
+  };
+
+type take_info =
+  { take_consts : term list,
+    take_defs : thm list,
+    chain_take_thms : thm list,
+    take_0_thms : thm list,
+    take_Suc_thms : thm list,
+    deflation_take_thms : thm list,
+    take_strict_thms : thm list,
+    finite_consts : term list,
+    finite_defs : thm list
+  };
+
+type take_induct_info =
+  {
+    take_consts         : term list,
+    take_defs           : thm list,
+    chain_take_thms     : thm list,
+    take_0_thms         : thm list,
+    take_Suc_thms       : thm list,
+    deflation_take_thms : thm list,
+    take_strict_thms    : thm list,
+    finite_consts       : term list,
+    finite_defs         : thm list,
+    lub_take_thms       : thm list,
+    reach_thms          : thm list,
+    take_lemma_thms     : thm list,
+    is_finite           : bool,
+    take_induct_thms    : thm list
+  };
+
+val beta_rules =
+  @{thms beta_cfun cont_id cont_const cont2cont_APP cont2cont_LAM'} @
+  @{thms cont2cont_fst cont2cont_snd cont2cont_Pair};
+
+val beta_ss = HOL_basic_ss addsimps (simp_thms @ beta_rules);
+
+val beta_tac = simp_tac beta_ss;
+
+(******************************************************************************)
+(******************************** theory data *********************************)
+(******************************************************************************)
+
+structure Rec_Data = Theory_Data
+(
+  (* list indicates which type arguments allow indirect recursion *)
+  type T = (bool list) Symtab.table;
+  val empty = Symtab.empty;
+  val extend = I;
+  fun merge data = Symtab.merge (K true) data;
+);
+
+structure DeflMapData = Named_Thms
+(
+  val name = "domain_deflation"
+  val description = "theorems like deflation a ==> deflation (foo_map$a)"
+);
+
+structure Map_Id_Data = Named_Thms
+(
+  val name = "domain_map_ID"
+  val description = "theorems like foo_map$ID = ID"
+);
+
+fun add_rec_type (tname, bs) =
+    Rec_Data.map (Symtab.insert (K true) (tname, bs));
+
+fun add_deflation_thm thm =
+    Context.theory_map (DeflMapData.add_thm thm);
+
+val get_rec_tab = Rec_Data.get;
+fun get_deflation_thms thy = DeflMapData.get (ProofContext.init_global thy);
+
+val map_ID_add = Map_Id_Data.add;
+val get_map_ID_thms = Map_Id_Data.get o ProofContext.init_global;
+
+val setup = DeflMapData.setup #> Map_Id_Data.setup;
+
+(******************************************************************************)
+(************************** building types and terms **************************)
+(******************************************************************************)
+
+open HOLCF_Library;
+
+infixr 6 ->>;
+infix -->>;
+infix 9 `;
+
+fun mapT (T as Type (_, Ts)) =
+    (map (fn T => T ->> T) Ts) -->> (T ->> T)
+  | mapT T = T ->> T;
+
+fun mk_deflation t =
+  Const (@{const_name deflation}, Term.fastype_of t --> boolT) $ t;
+
+fun mk_eqs (t, u) = HOLogic.mk_Trueprop (HOLogic.mk_eq (t, u));
+
+(******************************************************************************)
+(****************************** isomorphism info ******************************)
+(******************************************************************************)
+
+fun deflation_abs_rep (info : iso_info) : thm =
+  let
+    val abs_iso = #abs_inverse info;
+    val rep_iso = #rep_inverse info;
+    val thm = @{thm deflation_abs_rep} OF [abs_iso, rep_iso];
+  in
+    Drule.zero_var_indexes thm
+  end
+
+(******************************************************************************)
+(********************* building map functions over types **********************)
+(******************************************************************************)
+
+fun map_of_typ (thy : theory) (sub : (typ * term) list) (T : typ) : term =
+  let
+    val thms = get_map_ID_thms thy;
+    val rules = map (Thm.concl_of #> HOLogic.dest_Trueprop #> HOLogic.dest_eq) thms;
+    val rules' = map (apfst mk_ID) sub @ map swap rules;
+  in
+    mk_ID T
+    |> Pattern.rewrite_term thy rules' []
+    |> Pattern.rewrite_term thy rules []
+  end;
+
+(******************************************************************************)
+(********************* declaring definitions and theorems *********************)
+(******************************************************************************)
+
+fun add_qualified_def name (dbind, eqn) =
+    yield_singleton (Global_Theory.add_defs false)
+     ((Binding.qualified true name dbind, eqn), []);
+
+fun add_qualified_thm name (dbind, thm) =
+    yield_singleton Global_Theory.add_thms
+      ((Binding.qualified true name dbind, thm), []);
+
+fun add_qualified_simp_thm name (dbind, thm) =
+    yield_singleton Global_Theory.add_thms
+      ((Binding.qualified true name dbind, thm), [Simplifier.simp_add]);
+
+(******************************************************************************)
+(************************** defining take functions ***************************)
+(******************************************************************************)
+
+fun define_take_functions
+    (spec : (binding * iso_info) list)
+    (thy : theory) =
+  let
+
+    (* retrieve components of spec *)
+    val dbinds = map fst spec;
+    val iso_infos = map snd spec;
+    val dom_eqns = map (fn x => (#absT x, #repT x)) iso_infos;
+    val rep_abs_consts = map (fn x => (#rep_const x, #abs_const x)) iso_infos;
+
+    fun mk_projs []      t = []
+      | mk_projs (x::[]) t = [(x, t)]
+      | mk_projs (x::xs) t = (x, mk_fst t) :: mk_projs xs (mk_snd t);
+
+    fun mk_cfcomp2 ((rep_const, abs_const), f) =
+        mk_cfcomp (abs_const, mk_cfcomp (f, rep_const));
+
+    (* define take functional *)
+    val newTs : typ list = map fst dom_eqns;
+    val copy_arg_type = mk_tupleT (map (fn T => T ->> T) newTs);
+    val copy_arg = Free ("f", copy_arg_type);
+    val copy_args = map snd (mk_projs dbinds copy_arg);
+    fun one_copy_rhs (rep_abs, (lhsT, rhsT)) =
+      let
+        val body = map_of_typ thy (newTs ~~ copy_args) rhsT;
+      in
+        mk_cfcomp2 (rep_abs, body)
+      end;
+    val take_functional =
+        big_lambda copy_arg
+          (mk_tuple (map one_copy_rhs (rep_abs_consts ~~ dom_eqns)));
+    val take_rhss =
+      let
+        val n = Free ("n", HOLogic.natT);
+        val rhs = mk_iterate (n, take_functional);
+      in
+        map (lambda n o snd) (mk_projs dbinds rhs)
+      end;
+
+    (* define take constants *)
+    fun define_take_const ((dbind, take_rhs), (lhsT, rhsT)) thy =
+      let
+        val take_type = HOLogic.natT --> lhsT ->> lhsT;
+        val take_bind = Binding.suffix_name "_take" dbind;
+        val (take_const, thy) =
+          Sign.declare_const ((take_bind, take_type), NoSyn) thy;
+        val take_eqn = Logic.mk_equals (take_const, take_rhs);
+        val (take_def_thm, thy) =
+            add_qualified_def "take_def" (dbind, take_eqn) thy;
+      in ((take_const, take_def_thm), thy) end;
+    val ((take_consts, take_defs), thy) = thy
+      |> fold_map define_take_const (dbinds ~~ take_rhss ~~ dom_eqns)
+      |>> ListPair.unzip;
+
+    (* prove chain_take lemmas *)
+    fun prove_chain_take (take_const, dbind) thy =
+      let
+        val goal = mk_trp (mk_chain take_const);
+        val rules = take_defs @ @{thms chain_iterate ch2ch_fst ch2ch_snd};
+        val tac = simp_tac (HOL_basic_ss addsimps rules) 1;
+        val thm = Goal.prove_global thy [] [] goal (K tac);
+      in
+        add_qualified_simp_thm "chain_take" (dbind, thm) thy
+      end;
+    val (chain_take_thms, thy) =
+      fold_map prove_chain_take (take_consts ~~ dbinds) thy;
+
+    (* prove take_0 lemmas *)
+    fun prove_take_0 ((take_const, dbind), (lhsT, rhsT)) thy =
+      let
+        val lhs = take_const $ @{term "0::nat"};
+        val goal = mk_eqs (lhs, mk_bottom (lhsT ->> lhsT));
+        val rules = take_defs @ @{thms iterate_0 fst_strict snd_strict};
+        val tac = simp_tac (HOL_basic_ss addsimps rules) 1;
+        val take_0_thm = Goal.prove_global thy [] [] goal (K tac);
+      in
+        add_qualified_simp_thm "take_0" (dbind, take_0_thm) thy
+      end;
+    val (take_0_thms, thy) =
+      fold_map prove_take_0 (take_consts ~~ dbinds ~~ dom_eqns) thy;
+
+    (* prove take_Suc lemmas *)
+    val n = Free ("n", natT);
+    val take_is = map (fn t => t $ n) take_consts;
+    fun prove_take_Suc
+          (((take_const, rep_abs), dbind), (lhsT, rhsT)) thy =
+      let
+        val lhs = take_const $ (@{term Suc} $ n);
+        val body = map_of_typ thy (newTs ~~ take_is) rhsT;
+        val rhs = mk_cfcomp2 (rep_abs, body);
+        val goal = mk_eqs (lhs, rhs);
+        val simps = @{thms iterate_Suc fst_conv snd_conv}
+        val rules = take_defs @ simps;
+        val tac = simp_tac (beta_ss addsimps rules) 1;
+        val take_Suc_thm = Goal.prove_global thy [] [] goal (K tac);
+      in
+        add_qualified_thm "take_Suc" (dbind, take_Suc_thm) thy
+      end;
+    val (take_Suc_thms, thy) =
+      fold_map prove_take_Suc
+        (take_consts ~~ rep_abs_consts ~~ dbinds ~~ dom_eqns) thy;
+
+    (* prove deflation theorems for take functions *)
+    val deflation_abs_rep_thms = map deflation_abs_rep iso_infos;
+    val deflation_take_thm =
+      let
+        val n = Free ("n", natT);
+        fun mk_goal take_const = mk_deflation (take_const $ n);
+        val goal = mk_trp (foldr1 mk_conj (map mk_goal take_consts));
+        val adm_rules =
+          @{thms adm_conj adm_subst [OF _ adm_deflation]
+                 cont2cont_fst cont2cont_snd cont_id};
+        val bottom_rules =
+          take_0_thms @ @{thms deflation_UU simp_thms};
+        val deflation_rules =
+          @{thms conjI deflation_ID}
+          @ deflation_abs_rep_thms
+          @ get_deflation_thms thy;
+      in
+        Goal.prove_global thy [] [] goal (fn _ =>
+         EVERY
+          [rtac @{thm nat.induct} 1,
+           simp_tac (HOL_basic_ss addsimps bottom_rules) 1,
+           asm_simp_tac (HOL_basic_ss addsimps take_Suc_thms) 1,
+           REPEAT (etac @{thm conjE} 1
+                   ORELSE resolve_tac deflation_rules 1
+                   ORELSE atac 1)])
+      end;
+    fun conjuncts [] thm = []
+      | conjuncts (n::[]) thm = [(n, thm)]
+      | conjuncts (n::ns) thm = let
+          val thmL = thm RS @{thm conjunct1};
+          val thmR = thm RS @{thm conjunct2};
+        in (n, thmL):: conjuncts ns thmR end;
+    val (deflation_take_thms, thy) =
+      fold_map (add_qualified_thm "deflation_take")
+        (map (apsnd Drule.zero_var_indexes)
+          (conjuncts dbinds deflation_take_thm)) thy;
+
+    (* prove strictness of take functions *)
+    fun prove_take_strict (deflation_take, dbind) thy =
+      let
+        val take_strict_thm =
+            Drule.zero_var_indexes
+              (@{thm deflation_strict} OF [deflation_take]);
+      in
+        add_qualified_simp_thm "take_strict" (dbind, take_strict_thm) thy
+      end;
+    val (take_strict_thms, thy) =
+      fold_map prove_take_strict
+        (deflation_take_thms ~~ dbinds) thy;
+
+    (* prove take/take rules *)
+    fun prove_take_take ((chain_take, deflation_take), dbind) thy =
+      let
+        val take_take_thm =
+            Drule.zero_var_indexes
+              (@{thm deflation_chain_min} OF [chain_take, deflation_take]);
+      in
+        add_qualified_thm "take_take" (dbind, take_take_thm) thy
+      end;
+    val (take_take_thms, thy) =
+      fold_map prove_take_take
+        (chain_take_thms ~~ deflation_take_thms ~~ dbinds) thy;
+
+    (* prove take_below rules *)
+    fun prove_take_below (deflation_take, dbind) thy =
+      let
+        val take_below_thm =
+            Drule.zero_var_indexes
+              (@{thm deflation.below} OF [deflation_take]);
+      in
+        add_qualified_thm "take_below" (dbind, take_below_thm) thy
+      end;
+    val (take_below_thms, thy) =
+      fold_map prove_take_below
+        (deflation_take_thms ~~ dbinds) thy;
+
+    (* define finiteness predicates *)
+    fun define_finite_const ((dbind, take_const), (lhsT, rhsT)) thy =
+      let
+        val finite_type = lhsT --> boolT;
+        val finite_bind = Binding.suffix_name "_finite" dbind;
+        val (finite_const, thy) =
+          Sign.declare_const ((finite_bind, finite_type), NoSyn) thy;
+        val x = Free ("x", lhsT);
+        val n = Free ("n", natT);
+        val finite_rhs =
+          lambda x (HOLogic.exists_const natT $
+            (lambda n (mk_eq (mk_capply (take_const $ n, x), x))));
+        val finite_eqn = Logic.mk_equals (finite_const, finite_rhs);
+        val (finite_def_thm, thy) =
+            add_qualified_def "finite_def" (dbind, finite_eqn) thy;
+      in ((finite_const, finite_def_thm), thy) end;
+    val ((finite_consts, finite_defs), thy) = thy
+      |> fold_map define_finite_const (dbinds ~~ take_consts ~~ dom_eqns)
+      |>> ListPair.unzip;
+
+    val result =
+      {
+        take_consts = take_consts,
+        take_defs = take_defs,
+        chain_take_thms = chain_take_thms,
+        take_0_thms = take_0_thms,
+        take_Suc_thms = take_Suc_thms,
+        deflation_take_thms = deflation_take_thms,
+        take_strict_thms = take_strict_thms,
+        finite_consts = finite_consts,
+        finite_defs = finite_defs
+      };
+
+  in
+    (result, thy)
+  end;
+
+fun prove_finite_take_induct
+    (spec : (binding * iso_info) list)
+    (take_info : take_info)
+    (lub_take_thms : thm list)
+    (thy : theory) =
+  let
+    val dbinds = map fst spec;
+    val iso_infos = map snd spec;
+    val absTs = map #absT iso_infos;
+    val {take_consts, ...} = take_info;
+    val {chain_take_thms, take_0_thms, take_Suc_thms, ...} = take_info;
+    val {finite_consts, finite_defs, ...} = take_info;
+
+    val decisive_lemma =
+      let
+        fun iso_locale (info : iso_info) =
+            @{thm iso.intro} OF [#abs_inverse info, #rep_inverse info];
+        val iso_locale_thms = map iso_locale iso_infos;
+        val decisive_abs_rep_thms =
+            map (fn x => @{thm decisive_abs_rep} OF [x]) iso_locale_thms;
+        val n = Free ("n", @{typ nat});
+        fun mk_decisive t =
+            Const (@{const_name decisive}, fastype_of t --> boolT) $ t;
+        fun f take_const = mk_decisive (take_const $ n);
+        val goal = mk_trp (foldr1 mk_conj (map f take_consts));
+        val rules0 = @{thm decisive_bottom} :: take_0_thms;
+        val rules1 =
+            take_Suc_thms @ decisive_abs_rep_thms
+            @ @{thms decisive_ID decisive_ssum_map decisive_sprod_map};
+        val tac = EVERY [
+            rtac @{thm nat.induct} 1,
+            simp_tac (HOL_ss addsimps rules0) 1,
+            asm_simp_tac (HOL_ss addsimps rules1) 1];
+      in Goal.prove_global thy [] [] goal (K tac) end;
+    fun conjuncts 1 thm = [thm]
+      | conjuncts n thm = let
+          val thmL = thm RS @{thm conjunct1};
+          val thmR = thm RS @{thm conjunct2};
+        in thmL :: conjuncts (n-1) thmR end;
+    val decisive_thms = conjuncts (length spec) decisive_lemma;
+
+    fun prove_finite_thm (absT, finite_const) =
+      let
+        val goal = mk_trp (finite_const $ Free ("x", absT));
+        val tac =
+            EVERY [
+            rewrite_goals_tac finite_defs,
+            rtac @{thm lub_ID_finite} 1,
+            resolve_tac chain_take_thms 1,
+            resolve_tac lub_take_thms 1,
+            resolve_tac decisive_thms 1];
+      in
+        Goal.prove_global thy [] [] goal (K tac)
+      end;
+    val finite_thms =
+        map prove_finite_thm (absTs ~~ finite_consts);
+
+    fun prove_take_induct ((ch_take, lub_take), decisive) =
+        Drule.export_without_context
+          (@{thm lub_ID_finite_take_induct} OF [ch_take, lub_take, decisive]);
+    val take_induct_thms =
+        map prove_take_induct
+          (chain_take_thms ~~ lub_take_thms ~~ decisive_thms);
+
+    val thy = thy
+        |> fold (snd oo add_qualified_thm "finite")
+            (dbinds ~~ finite_thms)
+        |> fold (snd oo add_qualified_thm "take_induct")
+            (dbinds ~~ take_induct_thms);
+  in
+    ((finite_thms, take_induct_thms), thy)
+  end;
+
+fun add_lub_take_theorems
+    (spec : (binding * iso_info) list)
+    (take_info : take_info)
+    (lub_take_thms : thm list)
+    (thy : theory) =
+  let
+
+    (* retrieve components of spec *)
+    val dbinds = map fst spec;
+    val iso_infos = map snd spec;
+    val absTs = map #absT iso_infos;
+    val repTs = map #repT iso_infos;
+    val {take_consts, take_0_thms, take_Suc_thms, ...} = take_info;
+    val {chain_take_thms, deflation_take_thms, ...} = take_info;
+
+    (* prove take lemmas *)
+    fun prove_take_lemma ((chain_take, lub_take), dbind) thy =
+      let
+        val take_lemma =
+            Drule.export_without_context
+              (@{thm lub_ID_take_lemma} OF [chain_take, lub_take]);
+      in
+        add_qualified_thm "take_lemma" (dbind, take_lemma) thy
+      end;
+    val (take_lemma_thms, thy) =
+      fold_map prove_take_lemma
+        (chain_take_thms ~~ lub_take_thms ~~ dbinds) thy;
+
+    (* prove reach lemmas *)
+    fun prove_reach_lemma ((chain_take, lub_take), dbind) thy =
+      let
+        val thm =
+            Drule.zero_var_indexes
+              (@{thm lub_ID_reach} OF [chain_take, lub_take]);
+      in
+        add_qualified_thm "reach" (dbind, thm) thy
+      end;
+    val (reach_thms, thy) =
+      fold_map prove_reach_lemma
+        (chain_take_thms ~~ lub_take_thms ~~ dbinds) thy;
+
+    (* test for finiteness of domain definitions *)
+    local
+      val types = [@{type_name ssum}, @{type_name sprod}];
+      fun finite d T = if member (op =) absTs T then d else finite' d T
+      and finite' d (Type (c, Ts)) =
+          let val d' = d andalso member (op =) types c;
+          in forall (finite d') Ts end
+        | finite' d _ = true;
+    in
+      val is_finite = forall (finite true) repTs;
+    end;
+
+    val ((finite_thms, take_induct_thms), thy) =
+      if is_finite
+      then
+        let
+          val ((finites, take_inducts), thy) =
+              prove_finite_take_induct spec take_info lub_take_thms thy;
+        in
+          ((SOME finites, take_inducts), thy)
+        end
+      else
+        let
+          fun prove_take_induct (chain_take, lub_take) =
+              Drule.zero_var_indexes
+                (@{thm lub_ID_take_induct} OF [chain_take, lub_take]);
+          val take_inducts =
+              map prove_take_induct (chain_take_thms ~~ lub_take_thms);
+          val thy = fold (snd oo add_qualified_thm "take_induct")
+                         (dbinds ~~ take_inducts) thy;
+        in
+          ((NONE, take_inducts), thy)
+        end;
+
+    val result =
+      {
+        take_consts         = #take_consts take_info,
+        take_defs           = #take_defs take_info,
+        chain_take_thms     = #chain_take_thms take_info,
+        take_0_thms         = #take_0_thms take_info,
+        take_Suc_thms       = #take_Suc_thms take_info,
+        deflation_take_thms = #deflation_take_thms take_info,
+        take_strict_thms    = #take_strict_thms take_info,
+        finite_consts       = #finite_consts take_info,
+        finite_defs         = #finite_defs take_info,
+        lub_take_thms       = lub_take_thms,
+        reach_thms          = reach_thms,
+        take_lemma_thms     = take_lemma_thms,
+        is_finite           = is_finite,
+        take_induct_thms    = take_induct_thms
+      };
+  in
+    (result, thy)
+  end;
+
+end;

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/HOLCF/Tools/cont_consts.ML	Sat Nov 27 16:08:10 2010 -0800
@@ -0,0 +1,93 @@
+(*  Title:      HOLCF/Tools/cont_consts.ML
+    Author:     Tobias Mayr, David von Oheimb, and Markus Wenzel
+
+HOLCF version of consts: handle continuous function types in mixfix
+syntax.
+*)
+
+signature CONT_CONSTS =
+sig
+  val add_consts: (binding * typ * mixfix) list -> theory -> theory
+  val add_consts_cmd: (binding * string * mixfix) list -> theory -> theory
+end;
+
+structure Cont_Consts: CONT_CONSTS =
+struct
+
+
+(* misc utils *)
+
+fun change_arrow 0 T = T
+  | change_arrow n (Type (_, [S, T])) = Type ("fun", [S, change_arrow (n - 1) T])
+  | change_arrow _ T = raise TYPE ("cont_consts: change_arrow", [T], []);
+
+fun trans_rules name2 name1 n mx =
+  let
+    val vnames = Name.invents Name.context "a" n;
+    val extra_parse_rule = Syntax.ParseRule (Constant name2, Constant name1);
+  in
+    [Syntax.ParsePrintRule
+      (Syntax.mk_appl (Constant name2) (map Variable vnames),
+        fold (fn a => fn t => Syntax.mk_appl (Constant @{const_syntax Rep_cfun}) [t, Variable a])
+          vnames (Constant name1))] @
+    (case mx of
+      Infix _ => [extra_parse_rule]
+    | Infixl _ => [extra_parse_rule]
+    | Infixr _ => [extra_parse_rule]
+    | _ => [])
+  end;
+
+
+(* transforming infix/mixfix declarations of constants with type ...->...
+   a declaration of such a constant is transformed to a normal declaration with
+   an internal name, the same type, and nofix. Additionally, a purely syntactic
+   declaration with the original name, type ...=>..., and the original mixfix
+   is generated and connected to the other declaration via some translation.
+*)
+fun transform thy (c, T, mx) =
+  let
+    fun syntax b = Syntax.mark_const (Sign.full_bname thy b);
+    val c1 = Binding.name_of c;
+    val c2 = c1 ^ "_cont_syntax";
+    val n = Syntax.mixfix_args mx;
+  in
+    ((c, T, NoSyn),
+      (Binding.name c2, change_arrow n T, mx),
+      trans_rules (syntax c2) (syntax c1) n mx)
+  end;
+
+fun cfun_arity (Type (n, [_, T])) = if n = @{type_name cfun} then 1 + cfun_arity T else 0
+  | cfun_arity _ = 0;
+
+fun is_contconst (_, _, NoSyn) = false
+  | is_contconst (_, _, Binder _) = false    (* FIXME ? *)
+  | is_contconst (c, T, mx) =
+      let
+        val n = Syntax.mixfix_args mx handle ERROR msg =>
+          cat_error msg ("in mixfix annotation for " ^ quote (Binding.str_of c));
+      in cfun_arity T >= n end;
+
+
+(* add_consts *)
+
+local
+
+fun gen_add_consts prep_typ raw_decls thy =
+  let
+    val decls = map (fn (c, T, mx) => (c, prep_typ thy T, mx)) raw_decls;
+    val (contconst_decls, normal_decls) = List.partition is_contconst decls;
+    val transformed_decls = map (transform thy) contconst_decls;
+  in
+    thy
+    |> Sign.add_consts_i (normal_decls @ map #1 transformed_decls @ map #2 transformed_decls)
+    |> Sign.add_trrules_i (maps #3 transformed_decls)
+  end;
+
+in
+
+val add_consts = gen_add_consts Sign.certify_typ;
+val add_consts_cmd = gen_add_consts Syntax.read_typ_global;
+
+end;
+
+end;

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/HOLCF/Tools/cont_proc.ML	Sat Nov 27 16:08:10 2010 -0800
@@ -0,0 +1,136 @@
+(*  Title:      HOLCF/Tools/cont_proc.ML
+    Author:     Brian Huffman
+*)
+
+signature CONT_PROC =
+sig
+  val is_lcf_term: term -> bool
+  val cont_thms: term -> thm list
+  val all_cont_thms: term -> thm list
+  val cont_tac: int -> tactic
+  val cont_proc: theory -> simproc
+  val setup: theory -> theory
+end;
+
+structure ContProc :> CONT_PROC =
+struct
+
+(** theory context references **)
+
+val cont_K = @{thm cont_const};
+val cont_I = @{thm cont_id};
+val cont_A = @{thm cont2cont_APP};
+val cont_L = @{thm cont2cont_LAM};
+val cont_R = @{thm cont_Rep_cfun2};
+
+(* checks whether a term contains no dangling bound variables *)
+fun is_closed_term t = not (Term.loose_bvar (t, 0));
+
+(* checks whether a term is written entirely in the LCF sublanguage *)
+fun is_lcf_term (Const (@{const_name Rep_cfun}, _) $ t $ u) =
+      is_lcf_term t andalso is_lcf_term u
+  | is_lcf_term (Const (@{const_name Abs_cfun}, _) $ Abs (_, _, t)) =
+      is_lcf_term t
+  | is_lcf_term (Const (@{const_name Abs_cfun}, _) $ t) =
+      is_lcf_term (Term.incr_boundvars 1 t $ Bound 0)
+  | is_lcf_term (Bound _) = true
+  | is_lcf_term t = is_closed_term t;
+
+(*
+  efficiently generates a cont thm for every LAM abstraction in a term,
+  using forward proof and reusing common subgoals
+*)
+local
+  fun var 0 = [SOME cont_I]
+    | var n = NONE :: var (n-1);
+
+  fun k NONE     = cont_K
+    | k (SOME x) = x;
+
+  fun ap NONE NONE = NONE
+    | ap x    y    = SOME (k y RS (k x RS cont_A));
+
+  fun zip []      []      = []
+    | zip []      (y::ys) = (ap NONE y   ) :: zip [] ys
+    | zip (x::xs) []      = (ap x    NONE) :: zip xs []
+    | zip (x::xs) (y::ys) = (ap x    y   ) :: zip xs ys
+
+  fun lam [] = ([], cont_K)
+    | lam (x::ys) =
+    let
+      (* should use "close_derivation" for thms that are used multiple times *)
+      (* it seems to allow for sharing in explicit proof objects *)
+      val x' = Thm.close_derivation (k x);
+      val Lx = x' RS cont_L;
+    in (map (fn y => SOME (k y RS Lx)) ys, x') end;
+
+  (* first list: cont thm for each dangling bound variable *)
+  (* second list: cont thm for each LAM in t *)
+  (* if b = false, only return cont thm for outermost LAMs *)
+  fun cont_thms1 b (Const (@{const_name Rep_cfun}, _) $ f $ t) =
+    let
+      val (cs1,ls1) = cont_thms1 b f;
+      val (cs2,ls2) = cont_thms1 b t;
+    in (zip cs1 cs2, if b then ls1 @ ls2 else []) end
+    | cont_thms1 b (Const (@{const_name Abs_cfun}, _) $ Abs (_, _, t)) =
+    let
+      val (cs, ls) = cont_thms1 b t;
+      val (cs', l) = lam cs;
+    in (cs', l::ls) end
+    | cont_thms1 b (Const (@{const_name Abs_cfun}, _) $ t) =
+    let
+      val t' = Term.incr_boundvars 1 t $ Bound 0;
+      val (cs, ls) = cont_thms1 b t';
+      val (cs', l) = lam cs;
+    in (cs', l::ls) end
+    | cont_thms1 _ (Bound n) = (var n, [])
+    | cont_thms1 _ _ = ([], []);
+in
+  (* precondition: is_lcf_term t = true *)
+  fun cont_thms t = snd (cont_thms1 false t);
+  fun all_cont_thms t = snd (cont_thms1 true t);
+end;
+
+(*
+  Given the term "cont f", the procedure tries to construct the
+  theorem "cont f == True". If this theorem cannot be completely
+  solved by the introduction rules, then the procedure returns a
+  conditional rewrite rule with the unsolved subgoals as premises.
+*)
+
+val cont_tac =
+  let
+    val rules = [cont_K, cont_I, cont_R, cont_A, cont_L];
+  
+    fun new_cont_tac f' i =
+      case all_cont_thms f' of
+        [] => no_tac
+      | (c::cs) => rtac c i;
+
+    fun cont_tac_of_term (Const (@{const_name cont}, _) $ f) =
+      let
+        val f' = Const (@{const_name Abs_cfun}, dummyT) $ f;
+      in
+        if is_lcf_term f'
+        then new_cont_tac f'
+        else REPEAT_ALL_NEW (resolve_tac rules)
+      end
+      | cont_tac_of_term _ = K no_tac;
+  in
+    SUBGOAL (fn (t, i) =>
+      cont_tac_of_term (HOLogic.dest_Trueprop t) i)
+  end;
+
+local
+  fun solve_cont thy _ t =
+    let
+      val tr = instantiate' [] [SOME (cterm_of thy t)] Eq_TrueI;
+    in Option.map fst (Seq.pull (cont_tac 1 tr)) end
+in
+  fun cont_proc thy =
+    Simplifier.simproc_global thy "cont_proc" ["cont f"] solve_cont;
+end;
+
+fun setup thy = Simplifier.map_simpset (fn ss => ss addsimprocs [cont_proc thy]) thy;
+
+end;

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/HOLCF/Tools/cpodef.ML	Sat Nov 27 16:08:10 2010 -0800
@@ -0,0 +1,383 @@
+(*  Title:      HOLCF/Tools/cpodef.ML
+    Author:     Brian Huffman
+
+Primitive domain definitions for HOLCF, similar to Gordon/HOL-style
+typedef (see also ~~/src/HOL/Tools/typedef.ML).
+*)
+
+signature CPODEF =
+sig
+  type cpo_info =
+    { below_def: thm, adm: thm, cont_Rep: thm, cont_Abs: thm,
+      is_lub: thm, lub: thm, compact: thm }
+  type pcpo_info =
+    { Rep_strict: thm, Abs_strict: thm, Rep_bottom_iff: thm, Abs_bottom_iff: thm,
+      Rep_defined: thm, Abs_defined: thm }
+
+  val add_podef: bool -> binding option -> binding * (string * sort) list * mixfix ->
+    term -> (binding * binding) option -> tactic -> theory ->
+    (Typedef.info * thm) * theory
+  val add_cpodef: bool -> binding option -> binding * (string * sort) list * mixfix ->
+    term -> (binding * binding) option -> tactic * tactic -> theory ->
+    (Typedef.info * cpo_info) * theory
+  val add_pcpodef: bool -> binding option -> binding * (string * sort) list * mixfix ->
+    term -> (binding * binding) option -> tactic * tactic -> theory ->
+    (Typedef.info * cpo_info * pcpo_info) * theory
+
+  val cpodef_proof: (bool * binding)
+    * (binding * (string * sort) list * mixfix) * term
+    * (binding * binding) option -> theory -> Proof.state
+  val cpodef_proof_cmd: (bool * binding)
+    * (binding * (string * string option) list * mixfix) * string
+    * (binding * binding) option -> theory -> Proof.state
+  val pcpodef_proof: (bool * binding)
+    * (binding * (string * sort) list * mixfix) * term
+    * (binding * binding) option -> theory -> Proof.state
+  val pcpodef_proof_cmd: (bool * binding)
+    * (binding * (string * string option) list * mixfix) * string
+    * (binding * binding) option -> theory -> Proof.state
+end;
+
+structure Cpodef :> CPODEF =
+struct
+
+(** type definitions **)
+
+type cpo_info =
+  { below_def: thm, adm: thm, cont_Rep: thm, cont_Abs: thm,
+    is_lub: thm, lub: thm, compact: thm }
+
+type pcpo_info =
+  { Rep_strict: thm, Abs_strict: thm, Rep_bottom_iff: thm, Abs_bottom_iff: thm,
+    Rep_defined: thm, Abs_defined: thm }
+
+(* building terms *)
+
+fun adm_const T = Const (@{const_name adm}, (T --> HOLogic.boolT) --> HOLogic.boolT);
+fun mk_adm (x, T, P) = adm_const T $ absfree (x, T, P);
+
+fun below_const T = Const (@{const_name below}, T --> T --> HOLogic.boolT);
+
+(* manipulating theorems *)
+
+fun fold_adm_mem thm NONE = thm
+  | fold_adm_mem thm (SOME set_def) =
+    let val rule = @{lemma "A == B ==> adm (%x. x : B) ==> adm (%x. x : A)" by simp}
+    in rule OF [set_def, thm] end;
+
+fun fold_UU_mem thm NONE = thm
+  | fold_UU_mem thm (SOME set_def) =
+    let val rule = @{lemma "A == B ==> UU : B ==> UU : A" by simp}
+    in rule OF [set_def, thm] end;
+
+(* proving class instances *)
+
+fun prove_cpo
+      (name: binding)
+      (newT: typ)
+      (Rep_name: binding, Abs_name: binding)
+      (type_definition: thm)  (* type_definition Rep Abs A *)
+      (set_def: thm option)   (* A == set *)
+      (below_def: thm)        (* op << == %x y. Rep x << Rep y *)
+      (admissible: thm)       (* adm (%x. x : set) *)
+      (thy: theory)
+    =
+  let
+    val admissible' = fold_adm_mem admissible set_def;
+    val cpo_thms = map (Thm.transfer thy) [type_definition, below_def, admissible'];
+    val (full_tname, Ts) = dest_Type newT;
+    val lhs_sorts = map (snd o dest_TFree) Ts;
+    val tac = Tactic.rtac (@{thm typedef_cpo} OF cpo_thms) 1;
+    val thy = AxClass.prove_arity (full_tname, lhs_sorts, @{sort cpo}) tac thy;
+    (* transfer thms so that they will know about the new cpo instance *)
+    val cpo_thms' = map (Thm.transfer thy) cpo_thms;
+    fun make thm = Drule.zero_var_indexes (thm OF cpo_thms');
+    val cont_Rep = make @{thm typedef_cont_Rep};
+    val cont_Abs = make @{thm typedef_cont_Abs};
+    val is_lub = make @{thm typedef_is_lub};
+    val lub = make @{thm typedef_lub};
+    val compact = make @{thm typedef_compact};
+    val (_, thy) =
+      thy
+      |> Sign.add_path (Binding.name_of name)
+      |> Global_Theory.add_thms
+        ([((Binding.prefix_name "adm_"      name, admissible'), []),
+          ((Binding.prefix_name "cont_" Rep_name, cont_Rep   ), []),
+          ((Binding.prefix_name "cont_" Abs_name, cont_Abs   ), []),
+          ((Binding.prefix_name "is_lub_"   name, is_lub     ), []),
+          ((Binding.prefix_name "lub_"      name, lub        ), []),
+          ((Binding.prefix_name "compact_"  name, compact    ), [])])
+      ||> Sign.parent_path;
+    val cpo_info : cpo_info =
+      { below_def = below_def, adm = admissible', cont_Rep = cont_Rep,
+        cont_Abs = cont_Abs, is_lub = is_lub, lub = lub, compact = compact };
+  in
+    (cpo_info, thy)
+  end;
+
+fun prove_pcpo
+      (name: binding)
+      (newT: typ)
+      (Rep_name: binding, Abs_name: binding)
+      (type_definition: thm)  (* type_definition Rep Abs A *)
+      (set_def: thm option)   (* A == set *)
+      (below_def: thm)        (* op << == %x y. Rep x << Rep y *)
+      (UU_mem: thm)           (* UU : set *)
+      (thy: theory)
+    =
+  let
+    val UU_mem' = fold_UU_mem UU_mem set_def;
+    val pcpo_thms = map (Thm.transfer thy) [type_definition, below_def, UU_mem'];
+    val (full_tname, Ts) = dest_Type newT;
+    val lhs_sorts = map (snd o dest_TFree) Ts;
+    val tac = Tactic.rtac (@{thm typedef_pcpo} OF pcpo_thms) 1;
+    val thy = AxClass.prove_arity (full_tname, lhs_sorts, @{sort pcpo}) tac thy;
+    val pcpo_thms' = map (Thm.transfer thy) pcpo_thms;
+    fun make thm = Drule.zero_var_indexes (thm OF pcpo_thms');
+    val Rep_strict = make @{thm typedef_Rep_strict};
+    val Abs_strict = make @{thm typedef_Abs_strict};
+    val Rep_bottom_iff = make @{thm typedef_Rep_bottom_iff};
+    val Abs_bottom_iff = make @{thm typedef_Abs_bottom_iff};
+    val Rep_defined = make @{thm typedef_Rep_defined};
+    val Abs_defined = make @{thm typedef_Abs_defined};
+    val (_, thy) =
+      thy
+      |> Sign.add_path (Binding.name_of name)
+      |> Global_Theory.add_thms
+        ([((Binding.suffix_name "_strict"     Rep_name, Rep_strict), []),
+          ((Binding.suffix_name "_strict"     Abs_name, Abs_strict), []),
+          ((Binding.suffix_name "_bottom_iff" Rep_name, Rep_bottom_iff), []),
+          ((Binding.suffix_name "_bottom_iff" Abs_name, Abs_bottom_iff), []),
+          ((Binding.suffix_name "_defined"    Rep_name, Rep_defined), []),
+          ((Binding.suffix_name "_defined"    Abs_name, Abs_defined), [])])
+      ||> Sign.parent_path;
+    val pcpo_info =
+      { Rep_strict = Rep_strict, Abs_strict = Abs_strict,
+        Rep_bottom_iff = Rep_bottom_iff, Abs_bottom_iff = Abs_bottom_iff,
+        Rep_defined = Rep_defined, Abs_defined = Abs_defined };
+  in
+    (pcpo_info, thy)
+  end;
+
+(* prepare_cpodef *)
+
+fun declare_type_name a =
+  Variable.declare_constraints (Logic.mk_type (TFree (a, dummyS)));
+
+fun prepare prep_term name (tname, raw_args, mx) raw_set opt_morphs thy =
+  let
+    val _ = Theory.requires thy "Cpodef" "cpodefs";
+
+    (*rhs*)
+    val tmp_ctxt =
+      ProofContext.init_global thy
+      |> fold (Variable.declare_typ o TFree) raw_args;
+    val set = prep_term tmp_ctxt raw_set;
+    val tmp_ctxt' = tmp_ctxt |> Variable.declare_term set;
+
+    val setT = Term.fastype_of set;
+    val oldT = HOLogic.dest_setT setT handle TYPE _ =>
+      error ("Not a set type: " ^ quote (Syntax.string_of_typ tmp_ctxt setT));
+
+    (*lhs*)
+    val lhs_tfrees = map (ProofContext.check_tfree tmp_ctxt') raw_args;
+    val full_tname = Sign.full_name thy tname;
+    val newT = Type (full_tname, map TFree lhs_tfrees);
+
+    val morphs = opt_morphs
+      |> the_default (Binding.prefix_name "Rep_" name, Binding.prefix_name "Abs_" name);
+  in
+    (newT, oldT, set, morphs)
+  end
+
+fun add_podef def opt_name typ set opt_morphs tac thy =
+  let
+    val name = the_default (#1 typ) opt_name;
+    val ((full_tname, info as ({Rep_name, ...}, {type_definition, set_def, ...})), thy2) = thy
+      |> Typedef.add_typedef_global def opt_name typ set opt_morphs tac;
+    val oldT = #rep_type (#1 info);
+    val newT = #abs_type (#1 info);
+    val lhs_tfrees = map dest_TFree (snd (dest_Type newT));
+
+    val RepC = Const (Rep_name, newT --> oldT);
+    val below_eqn = Logic.mk_equals (below_const newT,
+      Abs ("x", newT, Abs ("y", newT, below_const oldT $ (RepC $ Bound 1) $ (RepC $ Bound 0))));
+    val lthy3 = thy2
+      |> Class.instantiation ([full_tname], lhs_tfrees, @{sort po});
+    val ((_, (_, below_ldef)), lthy4) = lthy3
+      |> Specification.definition (NONE,
+          ((Binding.prefix_name "below_" (Binding.suffix_name "_def" name), []), below_eqn));
+    val ctxt_thy = ProofContext.init_global (ProofContext.theory_of lthy4);
+    val below_def = singleton (ProofContext.export lthy4 ctxt_thy) below_ldef;
+    val thy5 = lthy4
+      |> Class.prove_instantiation_instance
+          (K (Tactic.rtac (@{thm typedef_po} OF [type_definition, below_def]) 1))
+      |> Local_Theory.exit_global;
+  in ((info, below_def), thy5) end;
+
+fun prepare_cpodef
+      (prep_term: Proof.context -> 'a -> term)
+      (def: bool)
+      (name: binding)
+      (typ: binding * (string * sort) list * mixfix)
+      (raw_set: 'a)
+      (opt_morphs: (binding * binding) option)
+      (thy: theory)
+    : term * term * (thm -> thm -> theory -> (Typedef.info * cpo_info) * theory) =
+  let
+    val (newT, oldT, set, morphs as (Rep_name, Abs_name)) =
+      prepare prep_term name typ raw_set opt_morphs thy;
+
+    val goal_nonempty =
+      HOLogic.mk_Trueprop (HOLogic.mk_exists ("x", oldT, HOLogic.mk_mem (Free ("x", oldT), set)));
+    val goal_admissible =
+      HOLogic.mk_Trueprop (mk_adm ("x", oldT, HOLogic.mk_mem (Free ("x", oldT), set)));
+
+    fun cpodef_result nonempty admissible thy =
+      let
+        val ((info as (_, {type_definition, set_def, ...}), below_def), thy2) = thy
+          |> add_podef def (SOME name) typ set opt_morphs (Tactic.rtac nonempty 1);
+        val (cpo_info, thy3) = thy2
+          |> prove_cpo name newT morphs type_definition set_def below_def admissible;
+      in
+        ((info, cpo_info), thy3)
+      end;
+  in
+    (goal_nonempty, goal_admissible, cpodef_result)
+  end
+  handle ERROR msg =>
+    cat_error msg ("The error(s) above occurred in cpodef " ^ quote (Binding.str_of name));
+
+fun prepare_pcpodef
+      (prep_term: Proof.context -> 'a -> term)
+      (def: bool)
+      (name: binding)
+      (typ: binding * (string * sort) list * mixfix)
+      (raw_set: 'a)
+      (opt_morphs: (binding * binding) option)
+      (thy: theory)
+    : term * term * (thm -> thm -> theory -> (Typedef.info * cpo_info * pcpo_info) * theory) =
+  let
+    val (newT, oldT, set, morphs as (Rep_name, Abs_name)) =
+      prepare prep_term name typ raw_set opt_morphs thy;
+
+    val goal_UU_mem =
+      HOLogic.mk_Trueprop (HOLogic.mk_mem (Const (@{const_name UU}, oldT), set));
+
+    val goal_admissible =
+      HOLogic.mk_Trueprop (mk_adm ("x", oldT, HOLogic.mk_mem (Free ("x", oldT), set)));
+
+    fun pcpodef_result UU_mem admissible thy =
+      let
+        val tac = Tactic.rtac exI 1 THEN Tactic.rtac UU_mem 1;
+        val ((info as (_, {type_definition, set_def, ...}), below_def), thy2) = thy
+          |> add_podef def (SOME name) typ set opt_morphs tac;
+        val (cpo_info, thy3) = thy2
+          |> prove_cpo name newT morphs type_definition set_def below_def admissible;
+        val (pcpo_info, thy4) = thy3
+          |> prove_pcpo name newT morphs type_definition set_def below_def UU_mem;
+      in
+        ((info, cpo_info, pcpo_info), thy4)
+      end;
+  in
+    (goal_UU_mem, goal_admissible, pcpodef_result)
+  end
+  handle ERROR msg =>
+    cat_error msg ("The error(s) above occurred in pcpodef " ^ quote (Binding.str_of name));
+
+
+(* tactic interface *)
+
+fun add_cpodef def opt_name typ set opt_morphs (tac1, tac2) thy =
+  let
+    val name = the_default (#1 typ) opt_name;
+    val (goal1, goal2, cpodef_result) =
+      prepare_cpodef Syntax.check_term def name typ set opt_morphs thy;
+    val thm1 = Goal.prove_global thy [] [] goal1 (K tac1)
+      handle ERROR msg => cat_error msg
+        ("Failed to prove non-emptiness of " ^ quote (Syntax.string_of_term_global thy set));
+    val thm2 = Goal.prove_global thy [] [] goal2 (K tac2)
+      handle ERROR msg => cat_error msg
+        ("Failed to prove admissibility of " ^ quote (Syntax.string_of_term_global thy set));
+  in cpodef_result thm1 thm2 thy end;
+
+fun add_pcpodef def opt_name typ set opt_morphs (tac1, tac2) thy =
+  let
+    val name = the_default (#1 typ) opt_name;
+    val (goal1, goal2, pcpodef_result) =
+      prepare_pcpodef Syntax.check_term def name typ set opt_morphs thy;
+    val thm1 = Goal.prove_global thy [] [] goal1 (K tac1)
+      handle ERROR msg => cat_error msg
+        ("Failed to prove non-emptiness of " ^ quote (Syntax.string_of_term_global thy set));
+    val thm2 = Goal.prove_global thy [] [] goal2 (K tac2)
+      handle ERROR msg => cat_error msg
+        ("Failed to prove admissibility of " ^ quote (Syntax.string_of_term_global thy set));
+  in pcpodef_result thm1 thm2 thy end;
+
+
+(* proof interface *)
+
+local
+
+fun gen_cpodef_proof prep_term prep_constraint
+    ((def, name), (b, raw_args, mx), set, opt_morphs) thy =
+  let
+    val ctxt = ProofContext.init_global thy;
+    val args = map (apsnd (prep_constraint ctxt)) raw_args;
+    val (goal1, goal2, make_result) =
+      prepare_cpodef prep_term def name (b, args, mx) set opt_morphs thy;
+    fun after_qed [[th1, th2]] = ProofContext.background_theory (snd o make_result th1 th2)
+      | after_qed _ = raise Fail "cpodef_proof";
+  in Proof.theorem NONE after_qed [[(goal1, []), (goal2, [])]] ctxt end;
+
+fun gen_pcpodef_proof prep_term prep_constraint
+    ((def, name), (b, raw_args, mx), set, opt_morphs) thy =
+  let
+    val ctxt = ProofContext.init_global thy;
+    val args = map (apsnd (prep_constraint ctxt)) raw_args;
+    val (goal1, goal2, make_result) =
+      prepare_pcpodef prep_term def name (b, args, mx) set opt_morphs thy;
+    fun after_qed [[th1, th2]] = ProofContext.background_theory (snd o make_result th1 th2)
+      | after_qed _ = raise Fail "pcpodef_proof";
+  in Proof.theorem NONE after_qed [[(goal1, []), (goal2, [])]] ctxt end;
+
+in
+
+fun cpodef_proof x = gen_cpodef_proof Syntax.check_term (K I) x;
+fun cpodef_proof_cmd x = gen_cpodef_proof Syntax.read_term Typedecl.read_constraint x;
+
+fun pcpodef_proof x = gen_pcpodef_proof Syntax.check_term (K I) x;
+fun pcpodef_proof_cmd x = gen_pcpodef_proof Syntax.read_term Typedecl.read_constraint x;
+
+end;
+
+
+
+(** outer syntax **)
+
+val typedef_proof_decl =
+  Scan.optional (Parse.$$$ "(" |--
+      ((Parse.$$$ "open" >> K false) -- Scan.option Parse.binding ||
+        Parse.binding >> (fn s => (true, SOME s)))
+        --| Parse.$$$ ")") (true, NONE) --
+    (Parse.type_args_constrained -- Parse.binding) -- Parse.opt_mixfix --
+    (Parse.$$$ "=" |-- Parse.term) --
+    Scan.option (Parse.$$$ "morphisms" |-- Parse.!!! (Parse.binding -- Parse.binding));
+
+fun mk_pcpodef_proof pcpo ((((((def, opt_name), (args, t)), mx), A), morphs)) =
+  (if pcpo then pcpodef_proof_cmd else cpodef_proof_cmd)
+    ((def, the_default t opt_name), (t, args, mx), A, morphs);
+
+val _ =
+  Outer_Syntax.command "pcpodef" "HOLCF type definition (requires admissibility proof)"
+  Keyword.thy_goal
+    (typedef_proof_decl >>
+      (Toplevel.print oo (Toplevel.theory_to_proof o mk_pcpodef_proof true)));
+
+val _ =
+  Outer_Syntax.command "cpodef" "HOLCF type definition (requires admissibility proof)"
+  Keyword.thy_goal
+    (typedef_proof_decl >>
+      (Toplevel.print oo (Toplevel.theory_to_proof o mk_pcpodef_proof false)));
+
+end;

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/HOLCF/Tools/domaindef.ML	Sat Nov 27 16:08:10 2010 -0800
@@ -0,0 +1,236 @@
+(*  Title:      HOLCF/Tools/repdef.ML
+    Author:     Brian Huffman
+
+Defining representable domains using algebraic deflations.
+*)
+
+signature DOMAINDEF =
+sig
+  type rep_info =
+    {
+      emb_def : thm,
+      prj_def : thm,
+      defl_def : thm,
+      liftemb_def : thm,
+      liftprj_def : thm,
+      liftdefl_def : thm,
+      DEFL : thm
+    }
+
+  val add_domaindef: bool -> binding option -> binding * (string * sort) list * mixfix ->
+    term -> (binding * binding) option -> theory ->
+    (Typedef.info * Cpodef.cpo_info * Cpodef.pcpo_info * rep_info) * theory
+
+  val domaindef_cmd: (bool * binding) * (binding * (string * string option) list * mixfix) * string
+    * (binding * binding) option -> theory -> theory
+end;
+
+structure Domaindef :> DOMAINDEF =
+struct
+
+open HOLCF_Library;
+
+infixr 6 ->>;
+infix -->>;
+
+(** type definitions **)
+
+type rep_info =
+  {
+    emb_def : thm,
+    prj_def : thm,
+    defl_def : thm,
+    liftemb_def : thm,
+    liftprj_def : thm,
+    liftdefl_def : thm,
+    DEFL : thm
+  };
+
+(* building types and terms *)
+
+val udomT = @{typ udom};
+val deflT = @{typ defl};
+fun emb_const T = Const (@{const_name emb}, T ->> udomT);
+fun prj_const T = Const (@{const_name prj}, udomT ->> T);
+fun defl_const T = Const (@{const_name defl}, Term.itselfT T --> deflT);
+fun liftemb_const T = Const (@{const_name liftemb}, mk_upT T ->> udomT);
+fun liftprj_const T = Const (@{const_name liftprj}, udomT ->> mk_upT T);
+fun liftdefl_const T = Const (@{const_name liftdefl}, Term.itselfT T --> deflT);
+
+fun mk_u_map t =
+  let
+    val (T, U) = dest_cfunT (fastype_of t);
+    val u_map_type = (T ->> U) ->> (mk_upT T ->> mk_upT U);
+    val u_map_const = Const (@{const_name u_map}, u_map_type);
+  in
+    mk_capply (u_map_const, t)
+  end;
+
+fun mk_cast (t, x) =
+  capply_const (udomT, udomT)
+  $ (capply_const (deflT, udomT ->> udomT) $ @{const cast} $ t)
+  $ x;
+
+(* manipulating theorems *)
+
+(* proving class instances *)
+
+fun declare_type_name a =
+  Variable.declare_constraints (Logic.mk_type (TFree (a, dummyS)));
+
+fun gen_add_domaindef
+      (prep_term: Proof.context -> 'a -> term)
+      (def: bool)
+      (name: binding)
+      (typ as (tname, raw_args, mx) : binding * (string * sort) list * mixfix)
+      (raw_defl: 'a)
+      (opt_morphs: (binding * binding) option)
+      (thy: theory)
+    : (Typedef.info * Cpodef.cpo_info * Cpodef.pcpo_info * rep_info) * theory =
+  let
+    val _ = Theory.requires thy "Domain" "domaindefs";
+
+    (*rhs*)
+    val tmp_ctxt =
+      ProofContext.init_global thy
+      |> fold (Variable.declare_typ o TFree) raw_args;
+    val defl = prep_term tmp_ctxt raw_defl;
+    val tmp_ctxt = tmp_ctxt |> Variable.declare_constraints defl;
+
+    val deflT = Term.fastype_of defl;
+    val _ = if deflT = @{typ "defl"} then ()
+            else error ("Not type defl: " ^ quote (Syntax.string_of_typ tmp_ctxt deflT));
+
+    (*lhs*)
+    val lhs_tfrees = map (ProofContext.check_tfree tmp_ctxt) raw_args;
+    val lhs_sorts = map snd lhs_tfrees;
+    val full_tname = Sign.full_name thy tname;
+    val newT = Type (full_tname, map TFree lhs_tfrees);
+
+    (*morphisms*)
+    val morphs = opt_morphs
+      |> the_default (Binding.prefix_name "Rep_" name, Binding.prefix_name "Abs_" name);
+
+    (*set*)
+    val set = @{const defl_set} $ defl;
+
+    (*pcpodef*)
+    val tac1 = rtac @{thm defl_set_bottom} 1;
+    val tac2 = rtac @{thm adm_defl_set} 1;
+    val ((info, cpo_info, pcpo_info), thy) = thy
+      |> Cpodef.add_pcpodef def (SOME name) typ set (SOME morphs) (tac1, tac2);
+
+    (*definitions*)
+    val Rep_const = Const (#Rep_name (#1 info), newT --> udomT);
+    val Abs_const = Const (#Abs_name (#1 info), udomT --> newT);
+    val emb_eqn = Logic.mk_equals (emb_const newT, cabs_const (newT, udomT) $ Rep_const);
+    val prj_eqn = Logic.mk_equals (prj_const newT, cabs_const (udomT, newT) $
+      Abs ("x", udomT, Abs_const $ mk_cast (defl, Bound 0)));
+    val defl_eqn = Logic.mk_equals (defl_const newT,
+      Abs ("x", Term.itselfT newT, defl));
+    val liftemb_eqn =
+      Logic.mk_equals (liftemb_const newT,
+      mk_cfcomp (@{term "udom_emb u_approx"}, mk_u_map (emb_const newT)));
+    val liftprj_eqn =
+      Logic.mk_equals (liftprj_const newT,
+      mk_cfcomp (mk_u_map (prj_const newT), @{term "udom_prj u_approx"}));
+    val liftdefl_eqn =
+      Logic.mk_equals (liftdefl_const newT,
+        Abs ("t", Term.itselfT newT,
+          mk_capply (@{const u_defl}, defl_const newT $ Logic.mk_type newT)));
+
+    val name_def = Binding.suffix_name "_def" name;
+    val emb_bind = (Binding.prefix_name "emb_" name_def, []);
+    val prj_bind = (Binding.prefix_name "prj_" name_def, []);
+    val defl_bind = (Binding.prefix_name "defl_" name_def, []);
+    val liftemb_bind = (Binding.prefix_name "liftemb_" name_def, []);
+    val liftprj_bind = (Binding.prefix_name "liftprj_" name_def, []);
+    val liftdefl_bind = (Binding.prefix_name "liftdefl_" name_def, []);
+
+    (*instantiate class rep*)
+    val lthy = thy
+      |> Class.instantiation ([full_tname], lhs_tfrees, @{sort liftdomain});
+    val ((_, (_, emb_ldef)), lthy) =
+        Specification.definition (NONE, (emb_bind, emb_eqn)) lthy;
+    val ((_, (_, prj_ldef)), lthy) =
+        Specification.definition (NONE, (prj_bind, prj_eqn)) lthy;
+    val ((_, (_, defl_ldef)), lthy) =
+        Specification.definition (NONE, (defl_bind, defl_eqn)) lthy;
+    val ((_, (_, liftemb_ldef)), lthy) =
+        Specification.definition (NONE, (liftemb_bind, liftemb_eqn)) lthy;
+    val ((_, (_, liftprj_ldef)), lthy) =
+        Specification.definition (NONE, (liftprj_bind, liftprj_eqn)) lthy;
+    val ((_, (_, liftdefl_ldef)), lthy) =
+        Specification.definition (NONE, (liftdefl_bind, liftdefl_eqn)) lthy;
+    val ctxt_thy = ProofContext.init_global (ProofContext.theory_of lthy);
+    val emb_def = singleton (ProofContext.export lthy ctxt_thy) emb_ldef;
+    val prj_def = singleton (ProofContext.export lthy ctxt_thy) prj_ldef;
+    val defl_def = singleton (ProofContext.export lthy ctxt_thy) defl_ldef;
+    val liftemb_def = singleton (ProofContext.export lthy ctxt_thy) liftemb_ldef;
+    val liftprj_def = singleton (ProofContext.export lthy ctxt_thy) liftprj_ldef;
+    val liftdefl_def = singleton (ProofContext.export lthy ctxt_thy) liftdefl_ldef;
+    val type_definition_thm =
+      MetaSimplifier.rewrite_rule
+        (the_list (#set_def (#2 info)))
+        (#type_definition (#2 info));
+    val typedef_thms =
+      [type_definition_thm, #below_def cpo_info, emb_def, prj_def, defl_def,
+      liftemb_def, liftprj_def, liftdefl_def];
+    val thy = lthy
+      |> Class.prove_instantiation_instance
+          (K (Tactic.rtac (@{thm typedef_liftdomain_class} OF typedef_thms) 1))
+      |> Local_Theory.exit_global;
+
+    (*other theorems*)
+    val defl_thm' = Thm.transfer thy defl_def;
+    val (DEFL_thm, thy) = thy
+      |> Sign.add_path (Binding.name_of name)
+      |> Global_Theory.add_thm
+         ((Binding.prefix_name "DEFL_" name,
+          Drule.zero_var_indexes (@{thm typedef_DEFL} OF [defl_thm'])), [])
+      ||> Sign.restore_naming thy;
+
+    val rep_info =
+      { emb_def = emb_def, prj_def = prj_def, defl_def = defl_def,
+        liftemb_def = liftemb_def, liftprj_def = liftprj_def,
+        liftdefl_def = liftdefl_def, DEFL = DEFL_thm };
+  in
+    ((info, cpo_info, pcpo_info, rep_info), thy)
+  end
+  handle ERROR msg =>
+    cat_error msg ("The error(s) above occurred in domaindef " ^ quote (Binding.str_of name));
+
+fun add_domaindef def opt_name typ defl opt_morphs thy =
+  let
+    val name = the_default (#1 typ) opt_name;
+  in
+    gen_add_domaindef Syntax.check_term def name typ defl opt_morphs thy
+  end;
+
+fun domaindef_cmd ((def, name), (b, raw_args, mx), A, morphs) thy =
+  let
+    val ctxt = ProofContext.init_global thy;
+    val args = map (apsnd (Typedecl.read_constraint ctxt)) raw_args;
+  in snd (gen_add_domaindef Syntax.read_term def name (b, args, mx) A morphs thy) end;
+
+
+(** outer syntax **)
+
+val domaindef_decl =
+  Scan.optional (Parse.$$$ "(" |--
+      ((Parse.$$$ "open" >> K false) -- Scan.option Parse.binding ||
+        Parse.binding >> (fn s => (true, SOME s)))
+        --| Parse.$$$ ")") (true, NONE) --
+    (Parse.type_args_constrained -- Parse.binding) --
+    Parse.opt_mixfix -- (Parse.$$$ "=" |-- Parse.term) --
+    Scan.option (Parse.$$$ "morphisms" |-- Parse.!!! (Parse.binding -- Parse.binding));
+
+fun mk_domaindef ((((((def, opt_name), (args, t)), mx), A), morphs)) =
+  domaindef_cmd ((def, the_default t opt_name), (t, args, mx), A, morphs);
+
+val _ =
+  Outer_Syntax.command "domaindef" "HOLCF definition of domains from deflations" Keyword.thy_decl
+    (domaindef_decl >>
+      (Toplevel.print oo (Toplevel.theory o mk_domaindef)));
+
+end;

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/HOLCF/Tools/fixrec.ML	Sat Nov 27 16:08:10 2010 -0800
@@ -0,0 +1,417 @@
+(*  Title:      HOLCF/Tools/fixrec.ML
+    Author:     Amber Telfer and Brian Huffman
+
+Recursive function definition package for HOLCF.
+*)
+
+signature FIXREC =
+sig
+  val add_fixrec: (binding * typ option * mixfix) list
+    -> (bool * (Attrib.binding * term)) list -> local_theory -> local_theory
+  val add_fixrec_cmd: (binding * string option * mixfix) list
+    -> (bool * (Attrib.binding * string)) list -> local_theory -> local_theory
+  val add_matchers: (string * string) list -> theory -> theory
+  val fixrec_simp_tac: Proof.context -> int -> tactic
+  val setup: theory -> theory
+end;
+
+structure Fixrec :> FIXREC =
+struct
+
+open HOLCF_Library;
+
+infixr 6 ->>;
+infix -->>;
+infix 9 `;
+
+val def_cont_fix_eq = @{thm def_cont_fix_eq};
+val def_cont_fix_ind = @{thm def_cont_fix_ind};
+
+fun fixrec_err s = error ("fixrec definition error:\n" ^ s);
+fun fixrec_eq_err thy s eq =
+  fixrec_err (s ^ "\nin\n" ^ quote (Syntax.string_of_term_global thy eq));
+
+(*************************************************************************)
+(***************************** building types ****************************)
+(*************************************************************************)
+
+local
+
+fun binder_cfun (Type(@{type_name cfun},[T, U])) = T :: binder_cfun U
+  | binder_cfun (Type(@{type_name "fun"},[T, U])) = T :: binder_cfun U
+  | binder_cfun _   =  [];
+
+fun body_cfun (Type(@{type_name cfun},[T, U])) = body_cfun U
+  | body_cfun (Type(@{type_name "fun"},[T, U])) = body_cfun U
+  | body_cfun T   =  T;
+
+fun strip_cfun T : typ list * typ =
+  (binder_cfun T, body_cfun T);
+
+in
+
+fun matcherT (T, U) =
+  body_cfun T ->> (binder_cfun T -->> U) ->> U;
+
+end
+
+(*************************************************************************)
+(***************************** building terms ****************************)
+(*************************************************************************)
+
+val mk_trp = HOLogic.mk_Trueprop;
+
+(* splits a cterm into the right and lefthand sides of equality *)
+fun dest_eqs t = HOLogic.dest_eq (HOLogic.dest_Trueprop t);
+
+(* similar to Thm.head_of, but for continuous application *)
+fun chead_of (Const(@{const_name Rep_cfun},_)$f$t) = chead_of f
+  | chead_of u = u;
+
+infix 0 ==;  val (op ==) = Logic.mk_equals;
+infix 1 ===; val (op ===) = HOLogic.mk_eq;
+
+fun mk_mplus (t, u) =
+  let val mT = Term.fastype_of t
+  in Const(@{const_name Fixrec.mplus}, mT ->> mT ->> mT) ` t ` u end;
+
+fun mk_run t =
+  let
+    val mT = Term.fastype_of t
+    val T = dest_matchT mT
+    val run = Const(@{const_name Fixrec.run}, mT ->> T)
+  in
+    case t of
+      Const(@{const_name Rep_cfun}, _) $
+        Const(@{const_name Fixrec.succeed}, _) $ u => u
+    | _ => run ` t
+  end;
+
+
+(*************************************************************************)
+(************* fixed-point definitions and unfolding theorems ************)
+(*************************************************************************)
+
+structure FixrecUnfoldData = Generic_Data
+(
+  type T = thm Symtab.table;
+  val empty = Symtab.empty;
+  val extend = I;
+  fun merge data : T = Symtab.merge (K true) data;
+);
+
+local
+
+fun name_of (Const (n, T)) = n
+  | name_of (Free (n, T)) = n
+  | name_of t = raise TERM ("Fixrec.add_unfold: lhs not a constant", [t]);
+
+val lhs_name =
+  name_of o head_of o fst o HOLogic.dest_eq o HOLogic.dest_Trueprop o prop_of;
+
+in
+
+val add_unfold : attribute =
+  Thm.declaration_attribute
+    (fn th => FixrecUnfoldData.map (Symtab.insert (K true) (lhs_name th, th)));
+
+end
+
+fun add_fixdefs
+  (fixes : ((binding * typ) * mixfix) list)
+  (spec : (Attrib.binding * term) list)
+  (lthy : local_theory) =
+  let
+    val thy = ProofContext.theory_of lthy;
+    val names = map (Binding.name_of o fst o fst) fixes;
+    val all_names = space_implode "_" names;
+    val (lhss, rhss) = ListPair.unzip (map (dest_eqs o snd) spec);
+    val functional = lambda_tuple lhss (mk_tuple rhss);
+    val fixpoint = mk_fix (mk_cabs functional);
+
+    val cont_thm =
+      let
+        val prop = mk_trp (mk_cont functional);
+        fun err _ = error (
+          "Continuity proof failed; please check that cont2cont rules\n" ^
+          "or simp rules are configured for all non-HOLCF constants.\n" ^
+          "The error occurred for the goal statement:\n" ^
+          Syntax.string_of_term lthy prop);
+        val rules = Cont2ContData.get lthy;
+        val fast_tac = SOLVED' (REPEAT_ALL_NEW (match_tac rules));
+        val slow_tac = SOLVED' (simp_tac (simpset_of lthy));
+        val tac = fast_tac 1 ORELSE slow_tac 1 ORELSE err;
+      in
+        Goal.prove lthy [] [] prop (K tac)
+      end;
+
+    fun one_def (l as Free(n,_)) r =
+          let val b = Long_Name.base_name n
+          in ((Binding.name (b^"_def"), []), r) end
+      | one_def _ _ = fixrec_err "fixdefs: lhs not of correct form";
+    fun defs [] _ = []
+      | defs (l::[]) r = [one_def l r]
+      | defs (l::ls) r = one_def l (mk_fst r) :: defs ls (mk_snd r);
+    val fixdefs = defs lhss fixpoint;
+    val (fixdef_thms : (term * (string * thm)) list, lthy) = lthy
+      |> fold_map Local_Theory.define (map (apfst fst) fixes ~~ fixdefs);
+    fun pair_equalI (thm1, thm2) = @{thm Pair_equalI} OF [thm1, thm2];
+    val tuple_fixdef_thm = foldr1 pair_equalI (map (snd o snd) fixdef_thms);
+    val P = Var (("P", 0), map Term.fastype_of lhss ---> HOLogic.boolT);
+    val predicate = lambda_tuple lhss (list_comb (P, lhss));
+    val tuple_induct_thm = (def_cont_fix_ind OF [tuple_fixdef_thm, cont_thm])
+      |> Drule.instantiate' [] [SOME (Thm.cterm_of thy predicate)]
+      |> Local_Defs.unfold lthy @{thms split_paired_all split_conv split_strict};
+    val tuple_unfold_thm = (def_cont_fix_eq OF [tuple_fixdef_thm, cont_thm])
+      |> Local_Defs.unfold lthy @{thms split_conv};
+    fun unfolds [] thm = []
+      | unfolds (n::[]) thm = [(n, thm)]
+      | unfolds (n::ns) thm = let
+          val thmL = thm RS @{thm Pair_eqD1};
+          val thmR = thm RS @{thm Pair_eqD2};
+        in (n, thmL) :: unfolds ns thmR end;
+    val unfold_thms = unfolds names tuple_unfold_thm;
+    val induct_note : Attrib.binding * Thm.thm list =
+      let
+        val thm_name = Binding.qualify true all_names (Binding.name "induct");
+      in
+        ((thm_name, []), [tuple_induct_thm])
+      end;
+    fun unfold_note (name, thm) : Attrib.binding * Thm.thm list =
+      let
+        val thm_name = Binding.qualify true name (Binding.name "unfold");
+        val src = Attrib.internal (K add_unfold);
+      in
+        ((thm_name, [src]), [thm])
+      end;
+    val (thmss, lthy) = lthy
+      |> fold_map Local_Theory.note (induct_note :: map unfold_note unfold_thms);
+  in
+    (lthy, names, fixdef_thms, map snd unfold_thms)
+  end;
+
+(*************************************************************************)
+(*********** monadic notation and pattern matching compilation ***********)
+(*************************************************************************)
+
+structure FixrecMatchData = Theory_Data
+(
+  type T = string Symtab.table;
+  val empty = Symtab.empty;
+  val extend = I;
+  fun merge data = Symtab.merge (K true) data;
+);
+
+(* associate match functions with pattern constants *)
+fun add_matchers ms = FixrecMatchData.map (fold Symtab.update ms);
+
+fun taken_names (t : term) : bstring list =
+  let
+    fun taken (Const(a,_), bs) = insert (op =) (Long_Name.base_name a) bs
+      | taken (Free(a,_) , bs) = insert (op =) a bs
+      | taken (f $ u     , bs) = taken (f, taken (u, bs))
+      | taken (Abs(a,_,t), bs) = taken (t, insert (op =) a bs)
+      | taken (_         , bs) = bs;
+  in
+    taken (t, [])
+  end;
+
+(* builds a monadic term for matching a pattern *)
+(* returns (rhs, free variable, used varnames) *)
+fun compile_pat match_name pat rhs taken =
+  let
+    fun comp_pat p rhs taken =
+      if is_Free p then (rhs, p, taken)
+      else comp_con (fastype_of p) p rhs [] taken
+    (* compiles a monadic term for a constructor pattern *)
+    and comp_con T p rhs vs taken =
+      case p of
+        Const(@{const_name Rep_cfun},_) $ f $ x =>
+          let val (rhs', v, taken') = comp_pat x rhs taken
+          in comp_con T f rhs' (v::vs) taken' end
+      | f $ x =>
+          let val (rhs', v, taken') = comp_pat x rhs taken
+          in comp_con T f rhs' (v::vs) taken' end
+      | Const (c, cT) =>
+          let
+            val n = Name.variant taken "v"
+            val v = Free(n, T)
+            val m = Const(match_name c, matcherT (cT, fastype_of rhs))
+            val k = big_lambdas vs rhs
+          in
+            (m`v`k, v, n::taken)
+          end
+      | _ => raise TERM ("fixrec: invalid pattern ", [p])
+  in
+    comp_pat pat rhs taken
+  end;
+
+(* builds a monadic term for matching a function definition pattern *)
+(* returns (constant, (vars, matcher)) *)
+fun compile_lhs match_name pat rhs vs taken =
+  case pat of
+    Const(@{const_name Rep_cfun}, _) $ f $ x =>
+      let val (rhs', v, taken') = compile_pat match_name x rhs taken;
+      in compile_lhs match_name f rhs' (v::vs) taken' end
+  | Free(_,_) => (pat, (vs, rhs))
+  | Const(_,_) => (pat, (vs, rhs))
+  | _ => fixrec_err ("invalid function pattern: "
+                    ^ ML_Syntax.print_term pat);
+
+fun strip_alls t =
+  if Logic.is_all t then strip_alls (snd (Logic.dest_all t)) else t;
+
+fun compile_eq match_name eq =
+  let
+    val (lhs,rhs) = dest_eqs (Logic.strip_imp_concl (strip_alls eq));
+  in
+    compile_lhs match_name lhs (mk_succeed rhs) [] (taken_names eq)
+  end;
+
+(* this is the pattern-matching compiler function *)
+fun compile_eqs match_name eqs =
+  let
+    val (consts, matchers) =
+      ListPair.unzip (map (compile_eq match_name) eqs);
+    val const =
+        case distinct (op =) consts of
+          [n] => n
+        | _ => fixrec_err "all equations in block must define the same function";
+    val vars =
+        case distinct (op = o pairself length) (map fst matchers) of
+          [vars] => vars
+        | _ => fixrec_err "all equations in block must have the same arity";
+    (* rename so all matchers use same free variables *)
+    fun rename (vs, t) = Term.subst_free (filter_out (op =) (vs ~~ vars)) t;
+    val rhs = big_lambdas vars (mk_run (foldr1 mk_mplus (map rename matchers)));
+  in
+    mk_trp (const === rhs)
+  end;
+
+(*************************************************************************)
+(********************** Proving associated theorems **********************)
+(*************************************************************************)
+
+fun eta_tac i = CONVERSION Thm.eta_conversion i;
+
+fun fixrec_simp_tac ctxt =
+  let
+    val tab = FixrecUnfoldData.get (Context.Proof ctxt);
+    val ss = Simplifier.simpset_of ctxt;
+    fun concl t =
+      if Logic.is_all t then concl (snd (Logic.dest_all t))
+      else HOLogic.dest_Trueprop (Logic.strip_imp_concl t);
+    fun tac (t, i) =
+      let
+        val (c, T) =
+            (dest_Const o head_of o chead_of o fst o HOLogic.dest_eq o concl) t;
+        val unfold_thm = the (Symtab.lookup tab c);
+        val rule = unfold_thm RS @{thm ssubst_lhs};
+      in
+        CHANGED (rtac rule i THEN eta_tac i THEN asm_simp_tac ss i)
+      end
+  in
+    SUBGOAL (fn ti => the_default no_tac (try tac ti))
+  end;
+
+(* proves a block of pattern matching equations as theorems, using unfold *)
+fun make_simps ctxt (unfold_thm, eqns : (Attrib.binding * term) list) =
+  let
+    val ss = Simplifier.simpset_of ctxt;
+    val rule = unfold_thm RS @{thm ssubst_lhs};
+    val tac = rtac rule 1 THEN eta_tac 1 THEN asm_simp_tac ss 1;
+    fun prove_term t = Goal.prove ctxt [] [] t (K tac);
+    fun prove_eqn (bind, eqn_t) = (bind, prove_term eqn_t);
+  in
+    map prove_eqn eqns
+  end;
+
+(*************************************************************************)
+(************************* Main fixrec function **************************)
+(*************************************************************************)
+
+local
+(* code adapted from HOL/Tools/primrec.ML *)
+
+fun gen_fixrec
+  prep_spec
+  (raw_fixes : (binding * 'a option * mixfix) list)
+  (raw_spec' : (bool * (Attrib.binding * 'b)) list)
+  (lthy : local_theory) =
+  let
+    val (skips, raw_spec) = ListPair.unzip raw_spec';
+    val (fixes : ((binding * typ) * mixfix) list,
+         spec : (Attrib.binding * term) list) =
+          fst (prep_spec raw_fixes raw_spec lthy);
+    val chead_of_spec =
+      chead_of o fst o dest_eqs o Logic.strip_imp_concl o strip_alls o snd;
+    fun name_of (Free (n, _)) = n
+      | name_of t = fixrec_err ("unknown term");
+    val all_names = map (name_of o chead_of_spec) spec;
+    val names = distinct (op =) all_names;
+    fun block_of_name n =
+      map_filter
+        (fn (m,eq) => if m = n then SOME eq else NONE)
+        (all_names ~~ (spec ~~ skips));
+    val blocks = map block_of_name names;
+
+    val matcher_tab = FixrecMatchData.get (ProofContext.theory_of lthy);
+    fun match_name c =
+      case Symtab.lookup matcher_tab c of SOME m => m
+        | NONE => fixrec_err ("unknown pattern constructor: " ^ c);
+
+    val matches = map (compile_eqs match_name) (map (map (snd o fst)) blocks);
+    val spec' = map (pair Attrib.empty_binding) matches;
+    val (lthy, cnames, fixdef_thms, unfold_thms) =
+      add_fixdefs fixes spec' lthy;
+
+    val blocks' = map (map fst o filter_out snd) blocks;
+    val simps : (Attrib.binding * thm) list list =
+      map (make_simps lthy) (unfold_thms ~~ blocks');
+    fun mk_bind n : Attrib.binding =
+     (Binding.qualify true n (Binding.name "simps"),
+       [Attrib.internal (K Simplifier.simp_add)]);
+    val simps1 : (Attrib.binding * thm list) list =
+      map (fn (n,xs) => (mk_bind n, map snd xs)) (names ~~ simps);
+    val simps2 : (Attrib.binding * thm list) list =
+      map (apsnd (fn thm => [thm])) (flat simps);
+    val (_, lthy) = lthy
+      |> fold_map Local_Theory.note (simps1 @ simps2);
+  in
+    lthy
+  end;
+
+in
+
+val add_fixrec = gen_fixrec Specification.check_spec;
+val add_fixrec_cmd = gen_fixrec Specification.read_spec;
+
+end; (* local *)
+
+
+(*************************************************************************)
+(******************************** Parsers ********************************)
+(*************************************************************************)
+
+val opt_thm_name' : (bool * Attrib.binding) parser =
+  Parse.$$$ "(" -- Parse.$$$ "unchecked" -- Parse.$$$ ")" >> K (true, Attrib.empty_binding)
+    || Parse_Spec.opt_thm_name ":" >> pair false;
+
+val spec' : (bool * (Attrib.binding * string)) parser =
+  opt_thm_name' -- Parse.prop >> (fn ((a, b), c) => (a, (b, c)));
+
+val alt_specs' : (bool * (Attrib.binding * string)) list parser =
+  let val unexpected = Scan.ahead (Parse.name || Parse.$$$ "[" || Parse.$$$ "(");
+  in Parse.enum1 "|" (spec' --| Scan.option (unexpected -- Parse.!!! (Parse.$$$ "|"))) end;
+
+val _ =
+  Outer_Syntax.local_theory "fixrec" "define recursive functions (HOLCF)" Keyword.thy_decl
+    (Parse.fixes -- (Parse.where_ |-- Parse.!!! alt_specs')
+      >> (fn (fixes, specs) => add_fixrec_cmd fixes specs));
+
+val setup =
+  Method.setup @{binding fixrec_simp}
+    (Scan.succeed (SIMPLE_METHOD' o fixrec_simp_tac))
+    "pattern prover for fixrec constants";
+
+end;

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/HOLCF/Tools/holcf_library.ML	Sat Nov 27 16:08:10 2010 -0800
@@ -0,0 +1,289 @@
+(*  Title:      HOLCF/Tools/holcf_library.ML
+    Author:     Brian Huffman
+
+Functions for constructing HOLCF types and terms.
+*)
+
+structure HOLCF_Library =
+struct
+
+infixr 6 ->>;
+infixr -->>;
+infix 9 `;
+
+(*** Operations from Isabelle/HOL ***)
+
+val boolT = HOLogic.boolT;
+val natT = HOLogic.natT;
+
+val mk_equals = Logic.mk_equals;
+val mk_eq = HOLogic.mk_eq;
+val mk_trp = HOLogic.mk_Trueprop;
+val mk_fst = HOLogic.mk_fst;
+val mk_snd = HOLogic.mk_snd;
+val mk_not = HOLogic.mk_not;
+val mk_conj = HOLogic.mk_conj;
+val mk_disj = HOLogic.mk_disj;
+val mk_imp = HOLogic.mk_imp;
+
+fun mk_ex (x, t) = HOLogic.exists_const (fastype_of x) $ Term.lambda x t;
+fun mk_all (x, t) = HOLogic.all_const (fastype_of x) $ Term.lambda x t;
+
+
+(*** Basic HOLCF concepts ***)
+
+fun mk_bottom T = Const (@{const_name UU}, T);
+
+fun below_const T = Const (@{const_name below}, [T, T] ---> boolT);
+fun mk_below (t, u) = below_const (fastype_of t) $ t $ u;
+
+fun mk_undef t = mk_eq (t, mk_bottom (fastype_of t));
+
+fun mk_defined t = mk_not (mk_undef t);
+
+fun mk_adm t =
+  Const (@{const_name adm}, fastype_of t --> boolT) $ t;
+
+fun mk_compact t =
+  Const (@{const_name compact}, fastype_of t --> boolT) $ t;
+
+fun mk_cont t =
+  Const (@{const_name cont}, fastype_of t --> boolT) $ t;
+
+fun mk_chain t =
+  Const (@{const_name chain}, Term.fastype_of t --> boolT) $ t;
+
+fun mk_lub t =
+  let
+    val T = Term.range_type (Term.fastype_of t);
+    val lub_const = Const (@{const_name lub}, (T --> boolT) --> T);
+    val UNIV_const = @{term "UNIV :: nat set"};
+    val image_type = (natT --> T) --> (natT --> boolT) --> T --> boolT;
+    val image_const = Const (@{const_name image}, image_type);
+  in
+    lub_const $ (image_const $ t $ UNIV_const)
+  end;
+
+
+(*** Continuous function space ***)
+
+fun mk_cfunT (T, U) = Type(@{type_name cfun}, [T, U]);
+
+val (op ->>) = mk_cfunT;
+val (op -->>) = Library.foldr mk_cfunT;
+
+fun dest_cfunT (Type(@{type_name cfun}, [T, U])) = (T, U)
+  | dest_cfunT T = raise TYPE ("dest_cfunT", [T], []);
+
+fun capply_const (S, T) =
+  Const(@{const_name Rep_cfun}, (S ->> T) --> (S --> T));
+
+fun cabs_const (S, T) =
+  Const(@{const_name Abs_cfun}, (S --> T) --> (S ->> T));
+
+fun mk_cabs t =
+  let val T = fastype_of t
+  in cabs_const (Term.domain_type T, Term.range_type T) $ t end
+
+(* builds the expression (% v1 v2 .. vn. rhs) *)
+fun lambdas [] rhs = rhs
+  | lambdas (v::vs) rhs = Term.lambda v (lambdas vs rhs);
+
+(* builds the expression (LAM v. rhs) *)
+fun big_lambda v rhs =
+  cabs_const (fastype_of v, fastype_of rhs) $ Term.lambda v rhs;
+
+(* builds the expression (LAM v1 v2 .. vn. rhs) *)
+fun big_lambdas [] rhs = rhs
+  | big_lambdas (v::vs) rhs = big_lambda v (big_lambdas vs rhs);
+
+fun mk_capply (t, u) =
+  let val (S, T) =
+    case fastype_of t of
+        Type(@{type_name cfun}, [S, T]) => (S, T)
+      | _ => raise TERM ("mk_capply " ^ ML_Syntax.print_list ML_Syntax.print_term [t, u], [t, u]);
+  in capply_const (S, T) $ t $ u end;
+
+val (op `) = mk_capply;
+
+val list_ccomb : term * term list -> term = Library.foldl mk_capply;
+
+fun mk_ID T = Const (@{const_name ID}, T ->> T);
+
+fun cfcomp_const (T, U, V) =
+  Const (@{const_name cfcomp}, (U ->> V) ->> (T ->> U) ->> (T ->> V));
+
+fun mk_cfcomp (f, g) =
+  let
+    val (U, V) = dest_cfunT (fastype_of f);
+    val (T, U') = dest_cfunT (fastype_of g);
+  in
+    if U = U'
+    then mk_capply (mk_capply (cfcomp_const (T, U, V), f), g)
+    else raise TYPE ("mk_cfcomp", [U, U'], [f, g])
+  end;
+
+fun strictify_const T = Const (@{const_name strictify}, T ->> T);
+fun mk_strictify t = strictify_const (fastype_of t) ` t;
+
+fun mk_strict t =
+  let val (T, U) = dest_cfunT (fastype_of t);
+  in mk_eq (t ` mk_bottom T, mk_bottom U) end;
+
+
+(*** Product type ***)
+
+val mk_prodT = HOLogic.mk_prodT
+
+fun mk_tupleT [] = HOLogic.unitT
+  | mk_tupleT [T] = T
+  | mk_tupleT (T :: Ts) = mk_prodT (T, mk_tupleT Ts);
+
+(* builds the expression (v1,v2,..,vn) *)
+fun mk_tuple [] = HOLogic.unit
+  | mk_tuple (t::[]) = t
+  | mk_tuple (t::ts) = HOLogic.mk_prod (t, mk_tuple ts);
+
+(* builds the expression (%(v1,v2,..,vn). rhs) *)
+fun lambda_tuple [] rhs = Term.lambda (Free("unit", HOLogic.unitT)) rhs
+  | lambda_tuple (v::[]) rhs = Term.lambda v rhs
+  | lambda_tuple (v::vs) rhs =
+      HOLogic.mk_split (Term.lambda v (lambda_tuple vs rhs));
+
+
+(*** Lifted cpo type ***)
+
+fun mk_upT T = Type(@{type_name "u"}, [T]);
+
+fun dest_upT (Type(@{type_name "u"}, [T])) = T
+  | dest_upT T = raise TYPE ("dest_upT", [T], []);
+
+fun up_const T = Const(@{const_name up}, T ->> mk_upT T);
+
+fun mk_up t = up_const (fastype_of t) ` t;
+
+fun fup_const (T, U) =
+  Const(@{const_name fup}, (T ->> U) ->> mk_upT T ->> U);
+
+fun mk_fup t = fup_const (dest_cfunT (fastype_of t)) ` t;
+
+fun from_up T = fup_const (T, T) ` mk_ID T;
+
+
+(*** Lifted unit type ***)
+
+val oneT = @{typ "one"};
+
+fun one_case_const T = Const (@{const_name one_case}, T ->> oneT ->> T);
+fun mk_one_case t = one_case_const (fastype_of t) ` t;
+
+
+(*** Strict product type ***)
+
+fun mk_sprodT (T, U) = Type(@{type_name sprod}, [T, U]);
+
+fun dest_sprodT (Type(@{type_name sprod}, [T, U])) = (T, U)
+  | dest_sprodT T = raise TYPE ("dest_sprodT", [T], []);
+
+fun spair_const (T, U) =
+  Const(@{const_name spair}, T ->> U ->> mk_sprodT (T, U));
+
+(* builds the expression (:t, u:) *)
+fun mk_spair (t, u) =
+  spair_const (fastype_of t, fastype_of u) ` t ` u;
+
+(* builds the expression (:t1,t2,..,tn:) *)
+fun mk_stuple [] = @{term "ONE"}
+  | mk_stuple (t::[]) = t
+  | mk_stuple (t::ts) = mk_spair (t, mk_stuple ts);
+
+fun sfst_const (T, U) =
+  Const(@{const_name sfst}, mk_sprodT (T, U) ->> T);
+
+fun ssnd_const (T, U) =
+  Const(@{const_name ssnd}, mk_sprodT (T, U) ->> U);
+
+fun ssplit_const (T, U, V) =
+  Const (@{const_name ssplit}, (T ->> U ->> V) ->> mk_sprodT (T, U) ->> V);
+
+fun mk_ssplit t =
+  let val (T, (U, V)) = apsnd dest_cfunT (dest_cfunT (fastype_of t));
+  in ssplit_const (T, U, V) ` t end;
+
+
+(*** Strict sum type ***)
+
+fun mk_ssumT (T, U) = Type(@{type_name ssum}, [T, U]);
+
+fun dest_ssumT (Type(@{type_name ssum}, [T, U])) = (T, U)
+  | dest_ssumT T = raise TYPE ("dest_ssumT", [T], []);
+
+fun sinl_const (T, U) = Const(@{const_name sinl}, T ->> mk_ssumT (T, U));
+fun sinr_const (T, U) = Const(@{const_name sinr}, U ->> mk_ssumT (T, U));
+
+(* builds the list [sinl(t1), sinl(sinr(t2)), ... sinr(...sinr(tn))] *)
+fun mk_sinjects ts =
+  let
+    val Ts = map fastype_of ts;
+    fun combine (t, T) (us, U) =
+      let
+        val v = sinl_const (T, U) ` t;
+        val vs = map (fn u => sinr_const (T, U) ` u) us;
+      in
+        (v::vs, mk_ssumT (T, U))
+      end
+    fun inj [] = raise Fail "mk_sinjects: empty list"
+      | inj ((t, T)::[]) = ([t], T)
+      | inj ((t, T)::ts) = combine (t, T) (inj ts);
+  in
+    fst (inj (ts ~~ Ts))
+  end;
+
+fun sscase_const (T, U, V) =
+  Const(@{const_name sscase},
+    (T ->> V) ->> (U ->> V) ->> mk_ssumT (T, U) ->> V);
+
+fun mk_sscase (t, u) =
+  let val (T, V) = dest_cfunT (fastype_of t);
+      val (U, V) = dest_cfunT (fastype_of u);
+  in sscase_const (T, U, V) ` t ` u end;
+
+fun from_sinl (T, U) =
+  sscase_const (T, U, T) ` mk_ID T ` mk_bottom (U ->> T);
+
+fun from_sinr (T, U) =
+  sscase_const (T, U, U) ` mk_bottom (T ->> U) ` mk_ID U;
+
+
+(*** pattern match monad type ***)
+
+fun mk_matchT T = Type (@{type_name "match"}, [T]);
+
+fun dest_matchT (Type(@{type_name "match"}, [T])) = T
+  | dest_matchT T = raise TYPE ("dest_matchT", [T], []);
+
+fun mk_fail T = Const (@{const_name "Fixrec.fail"}, mk_matchT T);
+
+fun succeed_const T = Const (@{const_name "Fixrec.succeed"}, T ->> mk_matchT T);
+fun mk_succeed t = succeed_const (fastype_of t) ` t;
+
+
+(*** lifted boolean type ***)
+
+val trT = @{typ "tr"};
+
+
+(*** theory of fixed points ***)
+
+fun mk_fix t =
+  let val (T, _) = dest_cfunT (fastype_of t)
+  in mk_capply (Const(@{const_name fix}, (T ->> T) ->> T), t) end;
+
+fun iterate_const T =
+  Const (@{const_name iterate}, natT --> (T ->> T) ->> (T ->> T));
+
+fun mk_iterate (n, f) =
+  let val (T, _) = dest_cfunT (Term.fastype_of f);
+  in (iterate_const T $ n) ` f ` mk_bottom T end;
+
+end;

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/HOLCF/Tr.thy	Sat Nov 27 16:08:10 2010 -0800
@@ -0,0 +1,199 @@
+(*  Title:      HOLCF/Tr.thy
+    Author:     Franz Regensburger
+*)
+
+header {* The type of lifted booleans *}
+
+theory Tr
+imports Lift
+begin
+
+subsection {* Type definition and constructors *}
+
+types
+  tr = "bool lift"
+
+translations
+  (type) "tr" <= (type) "bool lift"
+
+definition
+  TT :: "tr" where
+  "TT = Def True"
+
+definition
+  FF :: "tr" where
+  "FF = Def False"
+
+text {* Exhaustion and Elimination for type @{typ tr} *}
+
+lemma Exh_tr: "t = \<bottom> \<or> t = TT \<or> t = FF"
+unfolding FF_def TT_def by (induct t) auto
+
+lemma trE [case_names bottom TT FF]:
+  "\<lbrakk>p = \<bottom> \<Longrightarrow> Q; p = TT \<Longrightarrow> Q; p = FF \<Longrightarrow> Q\<rbrakk> \<Longrightarrow> Q"
+unfolding FF_def TT_def by (induct p) auto
+
+lemma tr_induct [case_names bottom TT FF]:
+  "\<lbrakk>P \<bottom>; P TT; P FF\<rbrakk> \<Longrightarrow> P x"
+by (cases x rule: trE) simp_all
+
+text {* distinctness for type @{typ tr} *}
+
+lemma dist_below_tr [simp]:
+  "\<not> TT \<sqsubseteq> \<bottom>" "\<not> FF \<sqsubseteq> \<bottom>" "\<not> TT \<sqsubseteq> FF" "\<not> FF \<sqsubseteq> TT"
+unfolding TT_def FF_def by simp_all
+
+lemma dist_eq_tr [simp]:
+  "TT \<noteq> \<bottom>" "FF \<noteq> \<bottom>" "TT \<noteq> FF" "\<bottom> \<noteq> TT" "\<bottom> \<noteq> FF" "FF \<noteq> TT"
+unfolding TT_def FF_def by simp_all
+
+lemma TT_below_iff [simp]: "TT \<sqsubseteq> x \<longleftrightarrow> x = TT"
+by (induct x rule: tr_induct) simp_all
+
+lemma FF_below_iff [simp]: "FF \<sqsubseteq> x \<longleftrightarrow> x = FF"
+by (induct x rule: tr_induct) simp_all
+
+lemma not_below_TT_iff [simp]: "\<not> (x \<sqsubseteq> TT) \<longleftrightarrow> x = FF"
+by (induct x rule: tr_induct) simp_all
+
+lemma not_below_FF_iff [simp]: "\<not> (x \<sqsubseteq> FF) \<longleftrightarrow> x = TT"
+by (induct x rule: tr_induct) simp_all
+
+
+subsection {* Case analysis *}
+
+default_sort pcpo
+
+definition tr_case :: "'a \<rightarrow> 'a \<rightarrow> tr \<rightarrow> 'a" where
+  "tr_case = (\<Lambda> t e (Def b). if b then t else e)"
+
+abbreviation
+  cifte_syn :: "[tr, 'c, 'c] \<Rightarrow> 'c"  ("(If (_)/ then (_)/ else (_))" [0, 0, 60] 60)
+where
+  "If b then e1 else e2 == tr_case\<cdot>e1\<cdot>e2\<cdot>b"
+
+translations
+  "\<Lambda> (XCONST TT). t" == "CONST tr_case\<cdot>t\<cdot>\<bottom>"
+  "\<Lambda> (XCONST FF). t" == "CONST tr_case\<cdot>\<bottom>\<cdot>t"
+
+lemma ifte_thms [simp]:
+  "If \<bottom> then e1 else e2 = \<bottom>"
+  "If FF then e1 else e2 = e2"
+  "If TT then e1 else e2 = e1"
+by (simp_all add: tr_case_def TT_def FF_def)
+
+
+subsection {* Boolean connectives *}
+
+definition
+  trand :: "tr \<rightarrow> tr \<rightarrow> tr" where
+  andalso_def: "trand = (\<Lambda> x y. If x then y else FF)"
+abbreviation
+  andalso_syn :: "tr \<Rightarrow> tr \<Rightarrow> tr"  ("_ andalso _" [36,35] 35)  where
+  "x andalso y == trand\<cdot>x\<cdot>y"
+
+definition
+  tror :: "tr \<rightarrow> tr \<rightarrow> tr" where
+  orelse_def: "tror = (\<Lambda> x y. If x then TT else y)"
+abbreviation
+  orelse_syn :: "tr \<Rightarrow> tr \<Rightarrow> tr"  ("_ orelse _"  [31,30] 30)  where
+  "x orelse y == tror\<cdot>x\<cdot>y"
+
+definition
+  neg :: "tr \<rightarrow> tr" where
+  "neg = flift2 Not"
+
+definition
+  If2 :: "[tr, 'c, 'c] \<Rightarrow> 'c" where
+  "If2 Q x y = (If Q then x else y)"
+
+text {* tactic for tr-thms with case split *}
+
+lemmas tr_defs = andalso_def orelse_def neg_def tr_case_def TT_def FF_def
+
+text {* lemmas about andalso, orelse, neg and if *}
+
+lemma andalso_thms [simp]:
+  "(TT andalso y) = y"
+  "(FF andalso y) = FF"
+  "(\<bottom> andalso y) = \<bottom>"
+  "(y andalso TT) = y"
+  "(y andalso y) = y"
+apply (unfold andalso_def, simp_all)
+apply (cases y rule: trE, simp_all)
+apply (cases y rule: trE, simp_all)
+done
+
+lemma orelse_thms [simp]:
+  "(TT orelse y) = TT"
+  "(FF orelse y) = y"
+  "(\<bottom> orelse y) = \<bottom>"
+  "(y orelse FF) = y"
+  "(y orelse y) = y"
+apply (unfold orelse_def, simp_all)
+apply (cases y rule: trE, simp_all)
+apply (cases y rule: trE, simp_all)
+done
+
+lemma neg_thms [simp]:
+  "neg\<cdot>TT = FF"
+  "neg\<cdot>FF = TT"
+  "neg\<cdot>\<bottom> = \<bottom>"
+by (simp_all add: neg_def TT_def FF_def)
+
+text {* split-tac for If via If2 because the constant has to be a constant *}
+
+lemma split_If2:
+  "P (If2 Q x y) = ((Q = \<bottom> \<longrightarrow> P \<bottom>) \<and> (Q = TT \<longrightarrow> P x) \<and> (Q = FF \<longrightarrow> P y))"
+apply (unfold If2_def)
+apply (rule_tac p = "Q" in trE)
+apply (simp_all)
+done
+
+ML {*
+val split_If_tac =
+  simp_tac (HOL_basic_ss addsimps [@{thm If2_def} RS sym])
+    THEN' (split_tac [@{thm split_If2}])
+*}
+
+subsection "Rewriting of HOLCF operations to HOL functions"
+
+lemma andalso_or:
+  "t \<noteq> \<bottom> \<Longrightarrow> ((t andalso s) = FF) = (t = FF \<or> s = FF)"
+apply (rule_tac p = "t" in trE)
+apply simp_all
+done
+
+lemma andalso_and:
+  "t \<noteq> \<bottom> \<Longrightarrow> ((t andalso s) \<noteq> FF) = (t \<noteq> FF \<and> s \<noteq> FF)"
+apply (rule_tac p = "t" in trE)
+apply simp_all
+done
+
+lemma Def_bool1 [simp]: "(Def x \<noteq> FF) = x"
+by (simp add: FF_def)
+
+lemma Def_bool2 [simp]: "(Def x = FF) = (\<not> x)"
+by (simp add: FF_def)
+
+lemma Def_bool3 [simp]: "(Def x = TT) = x"
+by (simp add: TT_def)
+
+lemma Def_bool4 [simp]: "(Def x \<noteq> TT) = (\<not> x)"
+by (simp add: TT_def)
+
+lemma If_and_if:
+  "(If Def P then A else B) = (if P then A else B)"
+apply (rule_tac p = "Def P" in trE)
+apply (auto simp add: TT_def[symmetric] FF_def[symmetric])
+done
+
+subsection {* Compactness *}
+
+lemma compact_TT: "compact TT"
+by (rule compact_chfin)
+
+lemma compact_FF: "compact FF"
+by (rule compact_chfin)
+
+end

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/HOLCF/Tutorial/Domain_ex.thy	Sat Nov 27 16:08:10 2010 -0800
@@ -0,0 +1,201 @@
+(*  Title:      HOLCF/ex/Domain_ex.thy
+    Author:     Brian Huffman
+*)
+
+header {* Domain package examples *}
+
+theory Domain_ex
+imports HOLCF
+begin
+
+text {* Domain constructors are strict by default. *}
+
+domain d1 = d1a | d1b "d1" "d1"
+
+lemma "d1b\<cdot>\<bottom>\<cdot>y = \<bottom>" by simp
+
+text {* Constructors can be made lazy using the @{text "lazy"} keyword. *}
+
+domain d2 = d2a | d2b (lazy "d2")
+
+lemma "d2b\<cdot>x \<noteq> \<bottom>" by simp
+
+text {* Strict and lazy arguments may be mixed arbitrarily. *}
+
+domain d3 = d3a | d3b (lazy "d2") "d2"
+
+lemma "P (d3b\<cdot>x\<cdot>y = \<bottom>) \<longleftrightarrow> P (y = \<bottom>)" by simp
+
+text {* Selectors can be used with strict or lazy constructor arguments. *}
+
+domain d4 = d4a | d4b (lazy d4b_left :: "d2") (d4b_right :: "d2")
+
+lemma "y \<noteq> \<bottom> \<Longrightarrow> d4b_left\<cdot>(d4b\<cdot>x\<cdot>y) = x" by simp
+
+text {* Mixfix declarations can be given for data constructors. *}
+
+domain d5 = d5a | d5b (lazy "d5") "d5" (infixl ":#:" 70)
+
+lemma "d5a \<noteq> x :#: y :#: z" by simp
+
+text {* Mixfix declarations can also be given for type constructors. *}
+
+domain ('a, 'b) lazypair (infixl ":*:" 25) =
+  lpair (lazy lfst :: 'a) (lazy lsnd :: 'b) (infixl ":*:" 75)
+
+lemma "\<forall>p::('a :*: 'b). p \<sqsubseteq> lfst\<cdot>p :*: lsnd\<cdot>p"
+by (rule allI, case_tac p, simp_all)
+
+text {* Non-recursive constructor arguments can have arbitrary types. *}
+
+domain ('a, 'b) d6 = d6 "int lift" "'a \<oplus> 'b u" (lazy "('a :*: 'b) \<times> ('b \<rightarrow> 'a)")
+
+text {*
+  Indirect recusion is allowed for sums, products, lifting, and the
+  continuous function space.  However, the domain package does not
+  generate an induction rule in terms of the constructors.
+*}
+
+domain 'a d7 = d7a "'a d7 \<oplus> int lift" | d7b "'a \<otimes> 'a d7" | d7c (lazy "'a d7 \<rightarrow> 'a")
+  -- "Indirect recursion detected, skipping proofs of (co)induction rules"
+
+text {* Note that @{text d7.induct} is absent. *}
+
+text {*
+  Indirect recursion is also allowed using previously-defined datatypes.
+*}
+
+domain 'a slist = SNil | SCons 'a "'a slist"
+
+domain 'a stree = STip | SBranch "'a stree slist"
+
+text {* Mutually-recursive datatypes can be defined using the @{text "and"} keyword. *}
+
+domain d8 = d8a | d8b "d9" and d9 = d9a | d9b (lazy "d8")
+
+text {* Non-regular recursion is not allowed. *}
+(*
+domain ('a, 'b) altlist = ANil | ACons 'a "('b, 'a) altlist"
+  -- "illegal direct recursion with different arguments"
+domain 'a nest = Nest1 'a | Nest2 "'a nest nest"
+  -- "illegal direct recursion with different arguments"
+*)
+
+text {*
+  Mutually-recursive datatypes must have all the same type arguments,
+  not necessarily in the same order.
+*}
+
+domain ('a, 'b) list1 = Nil1 | Cons1 'a "('b, 'a) list2"
+   and ('b, 'a) list2 = Nil2 | Cons2 'b "('a, 'b) list1"
+
+text {* Induction rules for flat datatypes have no admissibility side-condition. *}
+
+domain 'a flattree = Tip | Branch "'a flattree" "'a flattree"
+
+lemma "\<lbrakk>P \<bottom>; P Tip; \<And>x y. \<lbrakk>x \<noteq> \<bottom>; y \<noteq> \<bottom>; P x; P y\<rbrakk> \<Longrightarrow> P (Branch\<cdot>x\<cdot>y)\<rbrakk> \<Longrightarrow> P x"
+by (rule flattree.induct) -- "no admissibility requirement"
+
+text {* Trivial datatypes will produce a warning message. *}
+
+domain triv = Triv triv triv
+  -- "domain @{text Domain_ex.triv} is empty!"
+
+lemma "(x::triv) = \<bottom>" by (induct x, simp_all)
+
+text {* Lazy constructor arguments may have unpointed types. *}
+
+domain natlist = nnil | ncons (lazy "nat discr") natlist
+
+text {* Class constraints may be given for type parameters on the LHS. *}
+
+domain ('a::predomain) box = Box (lazy 'a)
+
+domain ('a::countable) stream = snil | scons (lazy "'a discr") "'a stream"
+
+
+subsection {* Generated constants and theorems *}
+
+domain 'a tree = Leaf (lazy 'a) | Node (left :: "'a tree") (right :: "'a tree")
+
+lemmas tree_abs_bottom_iff =
+  iso.abs_bottom_iff [OF iso.intro [OF tree.abs_iso tree.rep_iso]]
+
+text {* Rules about ismorphism *}
+term tree_rep
+term tree_abs
+thm tree.rep_iso
+thm tree.abs_iso
+thm tree.iso_rews
+
+text {* Rules about constructors *}
+term Leaf
+term Node
+thm Leaf_def Node_def
+thm tree.nchotomy
+thm tree.exhaust
+thm tree.compacts
+thm tree.con_rews
+thm tree.dist_les
+thm tree.dist_eqs
+thm tree.inverts
+thm tree.injects
+
+text {* Rules about case combinator *}
+term tree_case
+thm tree.tree_case_def
+thm tree.case_rews
+
+text {* Rules about selectors *}
+term left
+term right
+thm tree.sel_rews
+
+text {* Rules about discriminators *}
+term is_Leaf
+term is_Node
+thm tree.dis_rews
+
+text {* Rules about monadic pattern match combinators *}
+term match_Leaf
+term match_Node
+thm tree.match_rews
+
+text {* Rules about take function *}
+term tree_take
+thm tree.take_def
+thm tree.take_0
+thm tree.take_Suc
+thm tree.take_rews
+thm tree.chain_take
+thm tree.take_take
+thm tree.deflation_take
+thm tree.take_below
+thm tree.take_lemma
+thm tree.lub_take
+thm tree.reach
+thm tree.finite_induct
+
+text {* Rules about finiteness predicate *}
+term tree_finite
+thm tree.finite_def
+thm tree.finite (* only generated for flat datatypes *)
+
+text {* Rules about bisimulation predicate *}
+term tree_bisim
+thm tree.bisim_def
+thm tree.coinduct
+
+text {* Induction rule *}
+thm tree.induct
+
+
+subsection {* Known bugs *}
+
+text {* Declaring a mixfix with spaces causes some strange parse errors. *}
+(*
+domain xx = xx ("x y")
+  -- "Inner syntax error: unexpected end of input"
+*)
+
+end

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/HOLCF/Tutorial/Fixrec_ex.thy	Sat Nov 27 16:08:10 2010 -0800
@@ -0,0 +1,245 @@
+(*  Title:      HOLCF/ex/Fixrec_ex.thy
+    Author:     Brian Huffman
+*)
+
+header {* Fixrec package examples *}
+
+theory Fixrec_ex
+imports HOLCF
+begin
+
+subsection {* Basic @{text fixrec} examples *}
+
+text {*
+  Fixrec patterns can mention any constructor defined by the domain
+  package, as well as any of the following built-in constructors:
+  Pair, spair, sinl, sinr, up, ONE, TT, FF.
+*}
+
+text {* Typical usage is with lazy constructors. *}
+
+fixrec down :: "'a u \<rightarrow> 'a"
+where "down\<cdot>(up\<cdot>x) = x"
+
+text {* With strict constructors, rewrite rules may require side conditions. *}
+
+fixrec from_sinl :: "'a \<oplus> 'b \<rightarrow> 'a"
+where "x \<noteq> \<bottom> \<Longrightarrow> from_sinl\<cdot>(sinl\<cdot>x) = x"
+
+text {* Lifting can turn a strict constructor into a lazy one. *}
+
+fixrec from_sinl_up :: "'a u \<oplus> 'b \<rightarrow> 'a"
+where "from_sinl_up\<cdot>(sinl\<cdot>(up\<cdot>x)) = x"
+
+text {* Fixrec also works with the HOL pair constructor. *}
+
+fixrec down2 :: "'a u \<times> 'b u \<rightarrow> 'a \<times> 'b"
+where "down2\<cdot>(up\<cdot>x, up\<cdot>y) = (x, y)"
+
+
+subsection {* Examples using @{text fixrec_simp} *}
+
+text {* A type of lazy lists. *}
+
+domain 'a llist = lNil | lCons (lazy 'a) (lazy "'a llist")
+
+text {* A zip function for lazy lists. *}
+
+text {* Notice that the patterns are not exhaustive. *}
+
+fixrec
+  lzip :: "'a llist \<rightarrow> 'b llist \<rightarrow> ('a \<times> 'b) llist"
+where
+  "lzip\<cdot>(lCons\<cdot>x\<cdot>xs)\<cdot>(lCons\<cdot>y\<cdot>ys) = lCons\<cdot>(x, y)\<cdot>(lzip\<cdot>xs\<cdot>ys)"
+| "lzip\<cdot>lNil\<cdot>lNil = lNil"
+
+text {* @{text fixrec_simp} is useful for producing strictness theorems. *}
+text {* Note that pattern matching is done in left-to-right order. *}
+
+lemma lzip_stricts [simp]:
+  "lzip\<cdot>\<bottom>\<cdot>ys = \<bottom>"
+  "lzip\<cdot>lNil\<cdot>\<bottom> = \<bottom>"
+  "lzip\<cdot>(lCons\<cdot>x\<cdot>xs)\<cdot>\<bottom> = \<bottom>"
+by fixrec_simp+
+
+text {* @{text fixrec_simp} can also produce rules for missing cases. *}
+
+lemma lzip_undefs [simp]:
+  "lzip\<cdot>lNil\<cdot>(lCons\<cdot>y\<cdot>ys) = \<bottom>"
+  "lzip\<cdot>(lCons\<cdot>x\<cdot>xs)\<cdot>lNil = \<bottom>"
+by fixrec_simp+
+
+
+subsection {* Pattern matching with bottoms *}
+
+text {*
+  As an alternative to using @{text fixrec_simp}, it is also possible
+  to use bottom as a constructor pattern.  When using a bottom
+  pattern, the right-hand-side must also be bottom; otherwise, @{text
+  fixrec} will not be able to prove the equation.
+*}
+
+fixrec
+  from_sinr_up :: "'a \<oplus> 'b\<^sub>\<bottom> \<rightarrow> 'b"
+where
+  "from_sinr_up\<cdot>\<bottom> = \<bottom>"
+| "from_sinr_up\<cdot>(sinr\<cdot>(up\<cdot>x)) = x"
+
+text {*
+  If the function is already strict in that argument, then the bottom
+  pattern does not change the meaning of the function.  For example,
+  in the definition of @{term from_sinr_up}, the first equation is
+  actually redundant, and could have been proven separately by
+  @{text fixrec_simp}.
+*}
+
+text {*
+  A bottom pattern can also be used to make a function strict in a
+  certain argument, similar to a bang-pattern in Haskell.
+*}
+
+fixrec
+  seq :: "'a \<rightarrow> 'b \<rightarrow> 'b"
+where
+  "seq\<cdot>\<bottom>\<cdot>y = \<bottom>"
+| "x \<noteq> \<bottom> \<Longrightarrow> seq\<cdot>x\<cdot>y = y"
+
+
+subsection {* Skipping proofs of rewrite rules *}
+
+text {* Another zip function for lazy lists. *}
+
+text {*
+  Notice that this version has overlapping patterns.
+  The second equation cannot be proved as a theorem
+  because it only applies when the first pattern fails.
+*}
+
+fixrec
+  lzip2 :: "'a llist \<rightarrow> 'b llist \<rightarrow> ('a \<times> 'b) llist"
+where
+  "lzip2\<cdot>(lCons\<cdot>x\<cdot>xs)\<cdot>(lCons\<cdot>y\<cdot>ys) = lCons\<cdot>(x, y)\<cdot>(lzip2\<cdot>xs\<cdot>ys)"
+| (unchecked) "lzip2\<cdot>xs\<cdot>ys = lNil"
+
+text {*
+  Usually fixrec tries to prove all equations as theorems.
+  The "unchecked" option overrides this behavior, so fixrec
+  does not attempt to prove that particular equation.
+*}
+
+text {* Simp rules can be generated later using @{text fixrec_simp}. *}
+
+lemma lzip2_simps [simp]:
+  "lzip2\<cdot>(lCons\<cdot>x\<cdot>xs)\<cdot>lNil = lNil"
+  "lzip2\<cdot>lNil\<cdot>(lCons\<cdot>y\<cdot>ys) = lNil"
+  "lzip2\<cdot>lNil\<cdot>lNil = lNil"
+by fixrec_simp+
+
+lemma lzip2_stricts [simp]:
+  "lzip2\<cdot>\<bottom>\<cdot>ys = \<bottom>"
+  "lzip2\<cdot>(lCons\<cdot>x\<cdot>xs)\<cdot>\<bottom> = \<bottom>"
+by fixrec_simp+
+
+
+subsection {* Mutual recursion with @{text fixrec} *}
+
+text {* Tree and forest types. *}
+
+domain 'a tree = Leaf (lazy 'a) | Branch (lazy "'a forest")
+and    'a forest = Empty | Trees (lazy "'a tree") "'a forest"
+
+text {*
+  To define mutually recursive functions, give multiple type signatures
+  separated by the keyword @{text "and"}.
+*}
+
+fixrec
+  map_tree :: "('a \<rightarrow> 'b) \<rightarrow> ('a tree \<rightarrow> 'b tree)"
+and
+  map_forest :: "('a \<rightarrow> 'b) \<rightarrow> ('a forest \<rightarrow> 'b forest)"
+where
+  "map_tree\<cdot>f\<cdot>(Leaf\<cdot>x) = Leaf\<cdot>(f\<cdot>x)"
+| "map_tree\<cdot>f\<cdot>(Branch\<cdot>ts) = Branch\<cdot>(map_forest\<cdot>f\<cdot>ts)"
+| "map_forest\<cdot>f\<cdot>Empty = Empty"
+| "ts \<noteq> \<bottom> \<Longrightarrow>
+    map_forest\<cdot>f\<cdot>(Trees\<cdot>t\<cdot>ts) = Trees\<cdot>(map_tree\<cdot>f\<cdot>t)\<cdot>(map_forest\<cdot>f\<cdot>ts)"
+
+lemma map_tree_strict [simp]: "map_tree\<cdot>f\<cdot>\<bottom> = \<bottom>"
+by fixrec_simp
+
+lemma map_forest_strict [simp]: "map_forest\<cdot>f\<cdot>\<bottom> = \<bottom>"
+by fixrec_simp
+
+(*
+  Theorems generated:
+  @{text map_tree_def}  @{thm map_tree_def}
+  @{text map_forest_def}  @{thm map_forest_def}
+  @{text map_tree.unfold}  @{thm map_tree.unfold}
+  @{text map_forest.unfold}  @{thm map_forest.unfold}
+  @{text map_tree.simps}  @{thm map_tree.simps}
+  @{text map_forest.simps}  @{thm map_forest.simps}
+  @{text map_tree_map_forest.induct}  @{thm map_tree_map_forest.induct}
+*)
+
+
+subsection {* Looping simp rules *}
+
+text {*
+  The defining equations of a fixrec definition are declared as simp
+  rules by default.  In some cases, especially for constants with no
+  arguments or functions with variable patterns, the defining
+  equations may cause the simplifier to loop.  In these cases it will
+  be necessary to use a @{text "[simp del]"} declaration.
+*}
+
+fixrec
+  repeat :: "'a \<rightarrow> 'a llist"
+where
+  [simp del]: "repeat\<cdot>x = lCons\<cdot>x\<cdot>(repeat\<cdot>x)"
+
+text {*
+  We can derive other non-looping simp rules for @{const repeat} by
+  using the @{text subst} method with the @{text repeat.simps} rule.
+*}
+
+lemma repeat_simps [simp]:
+  "repeat\<cdot>x \<noteq> \<bottom>"
+  "repeat\<cdot>x \<noteq> lNil"
+  "repeat\<cdot>x = lCons\<cdot>y\<cdot>ys \<longleftrightarrow> x = y \<and> repeat\<cdot>x = ys"
+by (subst repeat.simps, simp)+
+
+lemma llist_case_repeat [simp]:
+  "llist_case\<cdot>z\<cdot>f\<cdot>(repeat\<cdot>x) = f\<cdot>x\<cdot>(repeat\<cdot>x)"
+by (subst repeat.simps, simp)
+
+text {*
+  For mutually-recursive constants, looping might only occur if all
+  equations are in the simpset at the same time.  In such cases it may
+  only be necessary to declare @{text "[simp del]"} on one equation.
+*}
+
+fixrec
+  inf_tree :: "'a tree" and inf_forest :: "'a forest"
+where
+  [simp del]: "inf_tree = Branch\<cdot>inf_forest"
+| "inf_forest = Trees\<cdot>inf_tree\<cdot>(Trees\<cdot>inf_tree\<cdot>Empty)"
+
+
+subsection {* Using @{text fixrec} inside locales *}
+
+locale test =
+  fixes foo :: "'a \<rightarrow> 'a"
+  assumes foo_strict: "foo\<cdot>\<bottom> = \<bottom>"
+begin
+
+fixrec
+  bar :: "'a u \<rightarrow> 'a"
+where
+  "bar\<cdot>(up\<cdot>x) = foo\<cdot>x"
+
+lemma bar_strict: "bar\<cdot>\<bottom> = \<bottom>"
+by fixrec_simp
+
+end
+
+end

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/HOLCF/Tutorial/New_Domain.thy	Sat Nov 27 16:08:10 2010 -0800
@@ -0,0 +1,90 @@
+(*  Title:      HOLCF/ex/New_Domain.thy
+    Author:     Brian Huffman
+*)
+
+header {* Definitional domain package *}
+
+theory New_Domain
+imports HOLCF
+begin
+
+text {*
+  UPDATE: The definitional back-end is now the default mode of the domain
+  package. This file should be merged with @{text Domain_ex.thy}.
+*}
+
+text {*
+  Provided that @{text domain} is the default sort, the @{text new_domain}
+  package should work with any type definition supported by the old
+  domain package.
+*}
+
+domain 'a llist = LNil | LCons (lazy 'a) (lazy "'a llist")
+
+text {*
+  The difference is that the new domain package is completely
+  definitional, and does not generate any axioms.  The following type
+  and constant definitions are not produced by the old domain package.
+*}
+
+thm type_definition_llist
+thm llist_abs_def llist_rep_def
+
+text {*
+  The new domain package also adds support for indirect recursion with
+  user-defined datatypes.  This definition of a tree datatype uses
+  indirect recursion through the lazy list type constructor.
+*}
+
+domain 'a ltree = Leaf (lazy 'a) | Branch (lazy "'a ltree llist")
+
+text {*
+  For indirect-recursive definitions, the domain package is not able to
+  generate a high-level induction rule.  (It produces a warning
+  message instead.)  The low-level reach lemma (now proved as a
+  theorem, no longer generated as an axiom) can be used to derive
+  other induction rules.
+*}
+
+thm ltree.reach
+
+text {*
+  The definition of the take function uses map functions associated with
+  each type constructor involved in the definition.  A map function
+  for the lazy list type has been generated by the new domain package.
+*}
+
+thm ltree.take_rews
+thm llist_map_def
+
+lemma ltree_induct:
+  fixes P :: "'a ltree \<Rightarrow> bool"
+  assumes adm: "adm P"
+  assumes bot: "P \<bottom>"
+  assumes Leaf: "\<And>x. P (Leaf\<cdot>x)"
+  assumes Branch: "\<And>f l. \<forall>x. P (f\<cdot>x) \<Longrightarrow> P (Branch\<cdot>(llist_map\<cdot>f\<cdot>l))"
+  shows "P x"
+proof -
+  have "P (\<Squnion>i. ltree_take i\<cdot>x)"
+  using adm
+  proof (rule admD)
+    fix i
+    show "P (ltree_take i\<cdot>x)"
+    proof (induct i arbitrary: x)
+      case (0 x)
+      show "P (ltree_take 0\<cdot>x)" by (simp add: bot)
+    next
+      case (Suc n x)
+      show "P (ltree_take (Suc n)\<cdot>x)"
+        apply (cases x)
+        apply (simp add: bot)
+        apply (simp add: Leaf)
+        apply (simp add: Branch Suc)
+        done
+    qed
+  qed (simp add: ltree.chain_take)
+  thus ?thesis
+    by (simp add: ltree.reach)
+qed
+
+end

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/HOLCF/Tutorial/ROOT.ML	Sat Nov 27 16:08:10 2010 -0800
@@ -0,0 +1,1 @@
+use_thys ["Domain_ex", "Fixrec_ex", "New_Domain"];

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/HOLCF/Tutorial/document/root.tex	Sat Nov 27 16:08:10 2010 -0800
@@ -0,0 +1,29 @@
+
+% HOLCF/document/root.tex
+
+\documentclass[11pt,a4paper]{article}
+\usepackage{graphicx,isabelle,isabellesym,latexsym}
+\usepackage[only,bigsqcap]{stmaryrd}
+\usepackage[latin1]{inputenc}
+\usepackage{pdfsetup}
+
+\urlstyle{rm}
+%\isabellestyle{it}
+\pagestyle{myheadings}
+
+\begin{document}
+
+\title{Isabelle/HOLCF Tutorial}
+\maketitle
+
+\tableofcontents
+
+%\newpage
+
+%\renewcommand{\isamarkupheader}[1]%
+%{\section{\isabellecontext: #1}\markright{THEORY~``\isabellecontext''}}
+
+\parindent 0pt\parskip 0.5ex
+\input{session}
+
+\end{document}

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/HOLCF/Universal.thy	Sat Nov 27 16:08:10 2010 -0800
@@ -0,0 +1,1014 @@
+(*  Title:      HOLCF/Universal.thy
+    Author:     Brian Huffman
+*)
+
+header {* A universal bifinite domain *}
+
+theory Universal
+imports Completion Deflation Nat_Bijection
+begin
+
+subsection {* Basis for universal domain *}
+
+subsubsection {* Basis datatype *}
+
+types ubasis = nat
+
+definition
+  node :: "nat \<Rightarrow> ubasis \<Rightarrow> ubasis set \<Rightarrow> ubasis"
+where
+  "node i a S = Suc (prod_encode (i, prod_encode (a, set_encode S)))"
+
+lemma node_not_0 [simp]: "node i a S \<noteq> 0"
+unfolding node_def by simp
+
+lemma node_gt_0 [simp]: "0 < node i a S"
+unfolding node_def by simp
+
+lemma node_inject [simp]:
+  "\<lbrakk>finite S; finite T\<rbrakk>
+    \<Longrightarrow> node i a S = node j b T \<longleftrightarrow> i = j \<and> a = b \<and> S = T"
+unfolding node_def by (simp add: prod_encode_eq set_encode_eq)
+
+lemma node_gt0: "i < node i a S"
+unfolding node_def less_Suc_eq_le
+by (rule le_prod_encode_1)
+
+lemma node_gt1: "a < node i a S"
+unfolding node_def less_Suc_eq_le
+by (rule order_trans [OF le_prod_encode_1 le_prod_encode_2])
+
+lemma nat_less_power2: "n < 2^n"
+by (induct n) simp_all
+
+lemma node_gt2: "\<lbrakk>finite S; b \<in> S\<rbrakk> \<Longrightarrow> b < node i a S"
+unfolding node_def less_Suc_eq_le set_encode_def
+apply (rule order_trans [OF _ le_prod_encode_2])
+apply (rule order_trans [OF _ le_prod_encode_2])
+apply (rule order_trans [where y="setsum (op ^ 2) {b}"])
+apply (simp add: nat_less_power2 [THEN order_less_imp_le])
+apply (erule setsum_mono2, simp, simp)
+done
+
+lemma eq_prod_encode_pairI:
+  "\<lbrakk>fst (prod_decode x) = a; snd (prod_decode x) = b\<rbrakk> \<Longrightarrow> x = prod_encode (a, b)"
+by (erule subst, erule subst, simp)
+
+lemma node_cases:
+  assumes 1: "x = 0 \<Longrightarrow> P"
+  assumes 2: "\<And>i a S. \<lbrakk>finite S; x = node i a S\<rbrakk> \<Longrightarrow> P"
+  shows "P"
+ apply (cases x)
+  apply (erule 1)
+ apply (rule 2)
+  apply (rule finite_set_decode)
+ apply (simp add: node_def)
+ apply (rule eq_prod_encode_pairI [OF refl])
+ apply (rule eq_prod_encode_pairI [OF refl refl])
+done
+
+lemma node_induct:
+  assumes 1: "P 0"
+  assumes 2: "\<And>i a S. \<lbrakk>P a; finite S; \<forall>b\<in>S. P b\<rbrakk> \<Longrightarrow> P (node i a S)"
+  shows "P x"
+ apply (induct x rule: nat_less_induct)
+ apply (case_tac n rule: node_cases)
+  apply (simp add: 1)
+ apply (simp add: 2 node_gt1 node_gt2)
+done
+
+subsubsection {* Basis ordering *}
+
+inductive
+  ubasis_le :: "nat \<Rightarrow> nat \<Rightarrow> bool"
+where
+  ubasis_le_refl: "ubasis_le a a"
+| ubasis_le_trans:
+    "\<lbrakk>ubasis_le a b; ubasis_le b c\<rbrakk> \<Longrightarrow> ubasis_le a c"
+| ubasis_le_lower:
+    "finite S \<Longrightarrow> ubasis_le a (node i a S)"
+| ubasis_le_upper:
+    "\<lbrakk>finite S; b \<in> S; ubasis_le a b\<rbrakk> \<Longrightarrow> ubasis_le (node i a S) b"
+
+lemma ubasis_le_minimal: "ubasis_le 0 x"
+apply (induct x rule: node_induct)
+apply (rule ubasis_le_refl)
+apply (erule ubasis_le_trans)
+apply (erule ubasis_le_lower)
+done
+
+interpretation udom: preorder ubasis_le
+apply default
+apply (rule ubasis_le_refl)
+apply (erule (1) ubasis_le_trans)
+done
+
+subsubsection {* Generic take function *}
+
+function
+  ubasis_until :: "(ubasis \<Rightarrow> bool) \<Rightarrow> ubasis \<Rightarrow> ubasis"
+where
+  "ubasis_until P 0 = 0"
+| "finite S \<Longrightarrow> ubasis_until P (node i a S) =
+    (if P (node i a S) then node i a S else ubasis_until P a)"
+    apply clarify
+    apply (rule_tac x=b in node_cases)
+     apply simp
+    apply simp
+    apply fast
+   apply simp
+  apply simp
+ apply simp
+done
+
+termination ubasis_until
+apply (relation "measure snd")
+apply (rule wf_measure)
+apply (simp add: node_gt1)
+done
+
+lemma ubasis_until: "P 0 \<Longrightarrow> P (ubasis_until P x)"
+by (induct x rule: node_induct) simp_all
+
+lemma ubasis_until': "0 < ubasis_until P x \<Longrightarrow> P (ubasis_until P x)"
+by (induct x rule: node_induct) auto
+
+lemma ubasis_until_same: "P x \<Longrightarrow> ubasis_until P x = x"
+by (induct x rule: node_induct) simp_all
+
+lemma ubasis_until_idem:
+  "P 0 \<Longrightarrow> ubasis_until P (ubasis_until P x) = ubasis_until P x"
+by (rule ubasis_until_same [OF ubasis_until])
+
+lemma ubasis_until_0:
+  "\<forall>x. x \<noteq> 0 \<longrightarrow> \<not> P x \<Longrightarrow> ubasis_until P x = 0"
+by (induct x rule: node_induct) simp_all
+
+lemma ubasis_until_less: "ubasis_le (ubasis_until P x) x"
+apply (induct x rule: node_induct)
+apply (simp add: ubasis_le_refl)
+apply (simp add: ubasis_le_refl)
+apply (rule impI)
+apply (erule ubasis_le_trans)
+apply (erule ubasis_le_lower)
+done
+
+lemma ubasis_until_chain:
+  assumes PQ: "\<And>x. P x \<Longrightarrow> Q x"
+  shows "ubasis_le (ubasis_until P x) (ubasis_until Q x)"
+apply (induct x rule: node_induct)
+apply (simp add: ubasis_le_refl)
+apply (simp add: ubasis_le_refl)
+apply (simp add: PQ)
+apply clarify
+apply (rule ubasis_le_trans)
+apply (rule ubasis_until_less)
+apply (erule ubasis_le_lower)
+done
+
+lemma ubasis_until_mono:
+  assumes "\<And>i a S b. \<lbrakk>finite S; P (node i a S); b \<in> S; ubasis_le a b\<rbrakk> \<Longrightarrow> P b"
+  shows "ubasis_le a b \<Longrightarrow> ubasis_le (ubasis_until P a) (ubasis_until P b)"
+proof (induct set: ubasis_le)
+  case (ubasis_le_refl a) show ?case by (rule ubasis_le.ubasis_le_refl)
+next
+  case (ubasis_le_trans a b c) thus ?case by - (rule ubasis_le.ubasis_le_trans)
+next
+  case (ubasis_le_lower S a i) thus ?case
+    apply (clarsimp simp add: ubasis_le_refl)
+    apply (rule ubasis_le_trans [OF ubasis_until_less])
+    apply (erule ubasis_le.ubasis_le_lower)
+    done
+next
+  case (ubasis_le_upper S b a i) thus ?case
+    apply clarsimp
+    apply (subst ubasis_until_same)
+     apply (erule (3) prems)
+    apply (erule (2) ubasis_le.ubasis_le_upper)
+    done
+qed
+
+lemma finite_range_ubasis_until:
+  "finite {x. P x} \<Longrightarrow> finite (range (ubasis_until P))"
+apply (rule finite_subset [where B="insert 0 {x. P x}"])
+apply (clarsimp simp add: ubasis_until')
+apply simp
+done
+
+
+subsection {* Defining the universal domain by ideal completion *}
+
+typedef (open) udom = "{S. udom.ideal S}"
+by (fast intro: udom.ideal_principal)
+
+instantiation udom :: below
+begin
+
+definition
+  "x \<sqsubseteq> y \<longleftrightarrow> Rep_udom x \<subseteq> Rep_udom y"
+
+instance ..
+end
+
+instance udom :: po
+using type_definition_udom below_udom_def
+by (rule udom.typedef_ideal_po)
+
+instance udom :: cpo
+using type_definition_udom below_udom_def
+by (rule udom.typedef_ideal_cpo)
+
+definition
+  udom_principal :: "nat \<Rightarrow> udom" where
+  "udom_principal t = Abs_udom {u. ubasis_le u t}"
+
+lemma ubasis_countable: "\<exists>f::ubasis \<Rightarrow> nat. inj f"
+by (rule exI, rule inj_on_id)
+
+interpretation udom:
+  ideal_completion ubasis_le udom_principal Rep_udom
+using type_definition_udom below_udom_def
+using udom_principal_def ubasis_countable
+by (rule udom.typedef_ideal_completion)
+
+text {* Universal domain is pointed *}
+
+lemma udom_minimal: "udom_principal 0 \<sqsubseteq> x"
+apply (induct x rule: udom.principal_induct)
+apply (simp, simp add: ubasis_le_minimal)
+done
+
+instance udom :: pcpo
+by intro_classes (fast intro: udom_minimal)
+
+lemma inst_udom_pcpo: "\<bottom> = udom_principal 0"
+by (rule udom_minimal [THEN UU_I, symmetric])
+
+
+subsection {* Compact bases of domains *}
+
+typedef (open) 'a compact_basis = "{x::'a::pcpo. compact x}"
+by auto
+
+lemma compact_Rep_compact_basis: "compact (Rep_compact_basis a)"
+by (rule Rep_compact_basis [unfolded mem_Collect_eq])
+
+instantiation compact_basis :: (pcpo) below
+begin
+
+definition
+  compact_le_def:
+    "(op \<sqsubseteq>) \<equiv> (\<lambda>x y. Rep_compact_basis x \<sqsubseteq> Rep_compact_basis y)"
+
+instance ..
+end
+
+instance compact_basis :: (pcpo) po
+using type_definition_compact_basis compact_le_def
+by (rule typedef_po)
+
+definition
+  approximants :: "'a \<Rightarrow> 'a compact_basis set" where
+  "approximants = (\<lambda>x. {a. Rep_compact_basis a \<sqsubseteq> x})"
+
+definition
+  compact_bot :: "'a::pcpo compact_basis" where
+  "compact_bot = Abs_compact_basis \<bottom>"
+
+lemma Rep_compact_bot [simp]: "Rep_compact_basis compact_bot = \<bottom>"
+unfolding compact_bot_def by (simp add: Abs_compact_basis_inverse)
+
+lemma compact_bot_minimal [simp]: "compact_bot \<sqsubseteq> a"
+unfolding compact_le_def Rep_compact_bot by simp
+
+
+subsection {* Universality of \emph{udom} *}
+
+text {* We use a locale to parameterize the construction over a chain
+of approx functions on the type to be embedded. *}
+
+locale approx_chain =
+  fixes approx :: "nat \<Rightarrow> 'a::pcpo \<rightarrow> 'a"
+  assumes chain_approx [simp]: "chain (\<lambda>i. approx i)"
+  assumes lub_approx [simp]: "(\<Squnion>i. approx i) = ID"
+  assumes finite_deflation_approx: "\<And>i. finite_deflation (approx i)"
+begin
+
+subsubsection {* Choosing a maximal element from a finite set *}
+
+lemma finite_has_maximal:
+  fixes A :: "'a compact_basis set"
+  shows "\<lbrakk>finite A; A \<noteq> {}\<rbrakk> \<Longrightarrow> \<exists>x\<in>A. \<forall>y\<in>A. x \<sqsubseteq> y \<longrightarrow> x = y"
+proof (induct rule: finite_ne_induct)
+  case (singleton x)
+    show ?case by simp
+next
+  case (insert a A)
+  from `\<exists>x\<in>A. \<forall>y\<in>A. x \<sqsubseteq> y \<longrightarrow> x = y`
+  obtain x where x: "x \<in> A"
+           and x_eq: "\<And>y. \<lbrakk>y \<in> A; x \<sqsubseteq> y\<rbrakk> \<Longrightarrow> x = y" by fast
+  show ?case
+  proof (intro bexI ballI impI)
+    fix y
+    assume "y \<in> insert a A" and "(if x \<sqsubseteq> a then a else x) \<sqsubseteq> y"
+    thus "(if x \<sqsubseteq> a then a else x) = y"
+      apply auto
+      apply (frule (1) below_trans)
+      apply (frule (1) x_eq)
+      apply (rule below_antisym, assumption)
+      apply simp
+      apply (erule (1) x_eq)
+      done
+  next
+    show "(if x \<sqsubseteq> a then a else x) \<in> insert a A"
+      by (simp add: x)
+  qed
+qed
+
+definition
+  choose :: "'a compact_basis set \<Rightarrow> 'a compact_basis"
+where
+  "choose A = (SOME x. x \<in> {x\<in>A. \<forall>y\<in>A. x \<sqsubseteq> y \<longrightarrow> x = y})"
+
+lemma choose_lemma:
+  "\<lbrakk>finite A; A \<noteq> {}\<rbrakk> \<Longrightarrow> choose A \<in> {x\<in>A. \<forall>y\<in>A. x \<sqsubseteq> y \<longrightarrow> x = y}"
+unfolding choose_def
+apply (rule someI_ex)
+apply (frule (1) finite_has_maximal, fast)
+done
+
+lemma maximal_choose:
+  "\<lbrakk>finite A; y \<in> A; choose A \<sqsubseteq> y\<rbrakk> \<Longrightarrow> choose A = y"
+apply (cases "A = {}", simp)
+apply (frule (1) choose_lemma, simp)
+done
+
+lemma choose_in: "\<lbrakk>finite A; A \<noteq> {}\<rbrakk> \<Longrightarrow> choose A \<in> A"
+by (frule (1) choose_lemma, simp)
+
+function
+  choose_pos :: "'a compact_basis set \<Rightarrow> 'a compact_basis \<Rightarrow> nat"
+where
+  "choose_pos A x =
+    (if finite A \<and> x \<in> A \<and> x \<noteq> choose A
+      then Suc (choose_pos (A - {choose A}) x) else 0)"
+by auto
+
+termination choose_pos
+apply (relation "measure (card \<circ> fst)", simp)
+apply clarsimp
+apply (rule card_Diff1_less)
+apply assumption
+apply (erule choose_in)
+apply clarsimp
+done
+
+declare choose_pos.simps [simp del]
+
+lemma choose_pos_choose: "finite A \<Longrightarrow> choose_pos A (choose A) = 0"
+by (simp add: choose_pos.simps)
+
+lemma inj_on_choose_pos [OF refl]:
+  "\<lbrakk>card A = n; finite A\<rbrakk> \<Longrightarrow> inj_on (choose_pos A) A"
+ apply (induct n arbitrary: A)
+  apply simp
+ apply (case_tac "A = {}", simp)
+ apply (frule (1) choose_in)
+ apply (rule inj_onI)
+ apply (drule_tac x="A - {choose A}" in meta_spec, simp)
+ apply (simp add: choose_pos.simps)
+ apply (simp split: split_if_asm)
+ apply (erule (1) inj_onD, simp, simp)
+done
+
+lemma choose_pos_bounded [OF refl]:
+  "\<lbrakk>card A = n; finite A; x \<in> A\<rbrakk> \<Longrightarrow> choose_pos A x < n"
+apply (induct n arbitrary: A)
+apply simp
+ apply (case_tac "A = {}", simp)
+ apply (frule (1) choose_in)
+apply (subst choose_pos.simps)
+apply simp
+done
+
+lemma choose_pos_lessD:
+  "\<lbrakk>choose_pos A x < choose_pos A y; finite A; x \<in> A; y \<in> A\<rbrakk> \<Longrightarrow> \<not> x \<sqsubseteq> y"
+ apply (induct A x arbitrary: y rule: choose_pos.induct)
+ apply simp
+ apply (case_tac "x = choose A")
+  apply simp
+  apply (rule notI)
+  apply (frule (2) maximal_choose)
+  apply simp
+ apply (case_tac "y = choose A")
+  apply (simp add: choose_pos_choose)
+ apply (drule_tac x=y in meta_spec)
+ apply simp
+ apply (erule meta_mp)
+ apply (simp add: choose_pos.simps)
+done
+
+subsubsection {* Properties of approx function *}
+
+lemma deflation_approx: "deflation (approx i)"
+using finite_deflation_approx by (rule finite_deflation_imp_deflation)
+
+lemma approx_idem: "approx i\<cdot>(approx i\<cdot>x) = approx i\<cdot>x"
+using deflation_approx by (rule deflation.idem)
+
+lemma approx_below: "approx i\<cdot>x \<sqsubseteq> x"
+using deflation_approx by (rule deflation.below)
+
+lemma finite_range_approx: "finite (range (\<lambda>x. approx i\<cdot>x))"
+apply (rule finite_deflation.finite_range)
+apply (rule finite_deflation_approx)
+done
+
+lemma compact_approx: "compact (approx n\<cdot>x)"
+apply (rule finite_deflation.compact)
+apply (rule finite_deflation_approx)
+done
+
+lemma compact_eq_approx: "compact x \<Longrightarrow> \<exists>i. approx i\<cdot>x = x"
+by (rule admD2, simp_all)
+
+subsubsection {* Compact basis take function *}
+
+primrec
+  cb_take :: "nat \<Rightarrow> 'a compact_basis \<Rightarrow> 'a compact_basis" where
+  "cb_take 0 = (\<lambda>x. compact_bot)"
+| "cb_take (Suc n) = (\<lambda>a. Abs_compact_basis (approx n\<cdot>(Rep_compact_basis a)))"
+
+declare cb_take.simps [simp del]
+
+lemma cb_take_zero [simp]: "cb_take 0 a = compact_bot"
+by (simp only: cb_take.simps)
+
+lemma Rep_cb_take:
+  "Rep_compact_basis (cb_take (Suc n) a) = approx n\<cdot>(Rep_compact_basis a)"
+by (simp add: Abs_compact_basis_inverse cb_take.simps(2) compact_approx)
+
+lemmas approx_Rep_compact_basis = Rep_cb_take [symmetric]
+
+lemma cb_take_covers: "\<exists>n. cb_take n x = x"
+apply (subgoal_tac "\<exists>n. cb_take (Suc n) x = x", fast)
+apply (simp add: Rep_compact_basis_inject [symmetric])
+apply (simp add: Rep_cb_take)
+apply (rule compact_eq_approx)
+apply (rule compact_Rep_compact_basis)
+done
+
+lemma cb_take_less: "cb_take n x \<sqsubseteq> x"
+unfolding compact_le_def
+by (cases n, simp, simp add: Rep_cb_take approx_below)
+
+lemma cb_take_idem: "cb_take n (cb_take n x) = cb_take n x"
+unfolding Rep_compact_basis_inject [symmetric]
+by (cases n, simp, simp add: Rep_cb_take approx_idem)
+
+lemma cb_take_mono: "x \<sqsubseteq> y \<Longrightarrow> cb_take n x \<sqsubseteq> cb_take n y"
+unfolding compact_le_def
+by (cases n, simp, simp add: Rep_cb_take monofun_cfun_arg)
+
+lemma cb_take_chain_le: "m \<le> n \<Longrightarrow> cb_take m x \<sqsubseteq> cb_take n x"
+unfolding compact_le_def
+apply (cases m, simp, cases n, simp)
+apply (simp add: Rep_cb_take, rule chain_mono, simp, simp)
+done
+
+lemma finite_range_cb_take: "finite (range (cb_take n))"
+apply (cases n)
+apply (subgoal_tac "range (cb_take 0) = {compact_bot}", simp, force)
+apply (rule finite_imageD [where f="Rep_compact_basis"])
+apply (rule finite_subset [where B="range (\<lambda>x. approx (n - 1)\<cdot>x)"])
+apply (clarsimp simp add: Rep_cb_take)
+apply (rule finite_range_approx)
+apply (rule inj_onI, simp add: Rep_compact_basis_inject)
+done
+
+subsubsection {* Rank of basis elements *}
+
+definition
+  rank :: "'a compact_basis \<Rightarrow> nat"
+where
+  "rank x = (LEAST n. cb_take n x = x)"
+
+lemma compact_approx_rank: "cb_take (rank x) x = x"
+unfolding rank_def
+apply (rule LeastI_ex)
+apply (rule cb_take_covers)
+done
+
+lemma rank_leD: "rank x \<le> n \<Longrightarrow> cb_take n x = x"
+apply (rule below_antisym [OF cb_take_less])
+apply (subst compact_approx_rank [symmetric])
+apply (erule cb_take_chain_le)
+done
+
+lemma rank_leI: "cb_take n x = x \<Longrightarrow> rank x \<le> n"
+unfolding rank_def by (rule Least_le)
+
+lemma rank_le_iff: "rank x \<le> n \<longleftrightarrow> cb_take n x = x"
+by (rule iffI [OF rank_leD rank_leI])
+
+lemma rank_compact_bot [simp]: "rank compact_bot = 0"
+using rank_leI [of 0 compact_bot] by simp
+
+lemma rank_eq_0_iff [simp]: "rank x = 0 \<longleftrightarrow> x = compact_bot"
+using rank_le_iff [of x 0] by auto
+
+definition
+  rank_le :: "'a compact_basis \<Rightarrow> 'a compact_basis set"
+where
+  "rank_le x = {y. rank y \<le> rank x}"
+
+definition
+  rank_lt :: "'a compact_basis \<Rightarrow> 'a compact_basis set"
+where
+  "rank_lt x = {y. rank y < rank x}"
+
+definition
+  rank_eq :: "'a compact_basis \<Rightarrow> 'a compact_basis set"
+where
+  "rank_eq x = {y. rank y = rank x}"
+
+lemma rank_eq_cong: "rank x = rank y \<Longrightarrow> rank_eq x = rank_eq y"
+unfolding rank_eq_def by simp
+
+lemma rank_lt_cong: "rank x = rank y \<Longrightarrow> rank_lt x = rank_lt y"
+unfolding rank_lt_def by simp
+
+lemma rank_eq_subset: "rank_eq x \<subseteq> rank_le x"
+unfolding rank_eq_def rank_le_def by auto
+
+lemma rank_lt_subset: "rank_lt x \<subseteq> rank_le x"
+unfolding rank_lt_def rank_le_def by auto
+
+lemma finite_rank_le: "finite (rank_le x)"
+unfolding rank_le_def
+apply (rule finite_subset [where B="range (cb_take (rank x))"])
+apply clarify
+apply (rule range_eqI)
+apply (erule rank_leD [symmetric])
+apply (rule finite_range_cb_take)
+done
+
+lemma finite_rank_eq: "finite (rank_eq x)"
+by (rule finite_subset [OF rank_eq_subset finite_rank_le])
+
+lemma finite_rank_lt: "finite (rank_lt x)"
+by (rule finite_subset [OF rank_lt_subset finite_rank_le])
+
+lemma rank_lt_Int_rank_eq: "rank_lt x \<inter> rank_eq x = {}"
+unfolding rank_lt_def rank_eq_def rank_le_def by auto
+
+lemma rank_lt_Un_rank_eq: "rank_lt x \<union> rank_eq x = rank_le x"
+unfolding rank_lt_def rank_eq_def rank_le_def by auto
+
+subsubsection {* Sequencing basis elements *}
+
+definition
+  place :: "'a compact_basis \<Rightarrow> nat"
+where
+  "place x = card (rank_lt x) + choose_pos (rank_eq x) x"
+
+lemma place_bounded: "place x < card (rank_le x)"
+unfolding place_def
+ apply (rule ord_less_eq_trans)
+  apply (rule add_strict_left_mono)
+  apply (rule choose_pos_bounded)
+   apply (rule finite_rank_eq)
+  apply (simp add: rank_eq_def)
+ apply (subst card_Un_disjoint [symmetric])
+    apply (rule finite_rank_lt)
+   apply (rule finite_rank_eq)
+  apply (rule rank_lt_Int_rank_eq)
+ apply (simp add: rank_lt_Un_rank_eq)
+done
+
+lemma place_ge: "card (rank_lt x) \<le> place x"
+unfolding place_def by simp
+
+lemma place_rank_mono:
+  fixes x y :: "'a compact_basis"
+  shows "rank x < rank y \<Longrightarrow> place x < place y"
+apply (rule less_le_trans [OF place_bounded])
+apply (rule order_trans [OF _ place_ge])
+apply (rule card_mono)
+apply (rule finite_rank_lt)
+apply (simp add: rank_le_def rank_lt_def subset_eq)
+done
+
+lemma place_eqD: "place x = place y \<Longrightarrow> x = y"
+ apply (rule linorder_cases [where x="rank x" and y="rank y"])
+   apply (drule place_rank_mono, simp)
+  apply (simp add: place_def)
+  apply (rule inj_on_choose_pos [where A="rank_eq x", THEN inj_onD])
+     apply (rule finite_rank_eq)
+    apply (simp cong: rank_lt_cong rank_eq_cong)
+   apply (simp add: rank_eq_def)
+  apply (simp add: rank_eq_def)
+ apply (drule place_rank_mono, simp)
+done
+
+lemma inj_place: "inj place"
+by (rule inj_onI, erule place_eqD)
+
+subsubsection {* Embedding and projection on basis elements *}
+
+definition
+  sub :: "'a compact_basis \<Rightarrow> 'a compact_basis"
+where
+  "sub x = (case rank x of 0 \<Rightarrow> compact_bot | Suc k \<Rightarrow> cb_take k x)"
+
+lemma rank_sub_less: "x \<noteq> compact_bot \<Longrightarrow> rank (sub x) < rank x"
+unfolding sub_def
+apply (cases "rank x", simp)
+apply (simp add: less_Suc_eq_le)
+apply (rule rank_leI)
+apply (rule cb_take_idem)
+done
+
+lemma place_sub_less: "x \<noteq> compact_bot \<Longrightarrow> place (sub x) < place x"
+apply (rule place_rank_mono)
+apply (erule rank_sub_less)
+done
+
+lemma sub_below: "sub x \<sqsubseteq> x"
+unfolding sub_def by (cases "rank x", simp_all add: cb_take_less)
+
+lemma rank_less_imp_below_sub: "\<lbrakk>x \<sqsubseteq> y; rank x < rank y\<rbrakk> \<Longrightarrow> x \<sqsubseteq> sub y"
+unfolding sub_def
+apply (cases "rank y", simp)
+apply (simp add: less_Suc_eq_le)
+apply (subgoal_tac "cb_take nat x \<sqsubseteq> cb_take nat y")
+apply (simp add: rank_leD)
+apply (erule cb_take_mono)
+done
+
+function
+  basis_emb :: "'a compact_basis \<Rightarrow> ubasis"
+where
+  "basis_emb x = (if x = compact_bot then 0 else
+    node (place x) (basis_emb (sub x))
+      (basis_emb ` {y. place y < place x \<and> x \<sqsubseteq> y}))"
+by auto
+
+termination basis_emb
+apply (relation "measure place", simp)
+apply (simp add: place_sub_less)
+apply simp
+done
+
+declare basis_emb.simps [simp del]
+
+lemma basis_emb_compact_bot [simp]: "basis_emb compact_bot = 0"
+by (simp add: basis_emb.simps)
+
+lemma fin1: "finite {y. place y < place x \<and> x \<sqsubseteq> y}"
+apply (subst Collect_conj_eq)
+apply (rule finite_Int)
+apply (rule disjI1)
+apply (subgoal_tac "finite (place -` {n. n < place x})", simp)
+apply (rule finite_vimageI [OF _ inj_place])
+apply (simp add: lessThan_def [symmetric])
+done
+
+lemma fin2: "finite (basis_emb ` {y. place y < place x \<and> x \<sqsubseteq> y})"
+by (rule finite_imageI [OF fin1])
+
+lemma rank_place_mono:
+  "\<lbrakk>place x < place y; x \<sqsubseteq> y\<rbrakk> \<Longrightarrow> rank x < rank y"
+apply (rule linorder_cases, assumption)
+apply (simp add: place_def cong: rank_lt_cong rank_eq_cong)
+apply (drule choose_pos_lessD)
+apply (rule finite_rank_eq)
+apply (simp add: rank_eq_def)
+apply (simp add: rank_eq_def)
+apply simp
+apply (drule place_rank_mono, simp)
+done
+
+lemma basis_emb_mono:
+  "x \<sqsubseteq> y \<Longrightarrow> ubasis_le (basis_emb x) (basis_emb y)"
+proof (induct "max (place x) (place y)" arbitrary: x y rule: less_induct)
+  case less
+  show ?case proof (rule linorder_cases)
+    assume "place x < place y"
+    then have "rank x < rank y"
+      using `x \<sqsubseteq> y` by (rule rank_place_mono)
+    with `place x < place y` show ?case
+      apply (case_tac "y = compact_bot", simp)
+      apply (simp add: basis_emb.simps [of y])
+      apply (rule ubasis_le_trans [OF _ ubasis_le_lower [OF fin2]])
+      apply (rule less)
+       apply (simp add: less_max_iff_disj)
+       apply (erule place_sub_less)
+      apply (erule rank_less_imp_below_sub [OF `x \<sqsubseteq> y`])
+      done
+  next
+    assume "place x = place y"
+    hence "x = y" by (rule place_eqD)
+    thus ?case by (simp add: ubasis_le_refl)
+  next
+    assume "place x > place y"
+    with `x \<sqsubseteq> y` show ?case
+      apply (case_tac "x = compact_bot", simp add: ubasis_le_minimal)
+      apply (simp add: basis_emb.simps [of x])
+      apply (rule ubasis_le_upper [OF fin2], simp)
+      apply (rule less)
+       apply (simp add: less_max_iff_disj)
+       apply (erule place_sub_less)
+      apply (erule rev_below_trans)
+      apply (rule sub_below)
+      done
+  qed
+qed
+
+lemma inj_basis_emb: "inj basis_emb"
+ apply (rule inj_onI)
+ apply (case_tac "x = compact_bot")
+  apply (case_tac [!] "y = compact_bot")
+    apply simp
+   apply (simp add: basis_emb.simps)
+  apply (simp add: basis_emb.simps)
+ apply (simp add: basis_emb.simps)
+ apply (simp add: fin2 inj_eq [OF inj_place])
+done
+
+definition
+  basis_prj :: "ubasis \<Rightarrow> 'a compact_basis"
+where
+  "basis_prj x = inv basis_emb
+    (ubasis_until (\<lambda>x. x \<in> range (basis_emb :: 'a compact_basis \<Rightarrow> ubasis)) x)"
+
+lemma basis_prj_basis_emb: "\<And>x. basis_prj (basis_emb x) = x"
+unfolding basis_prj_def
+ apply (subst ubasis_until_same)
+  apply (rule rangeI)
+ apply (rule inv_f_f)
+ apply (rule inj_basis_emb)
+done
+
+lemma basis_prj_node:
+  "\<lbrakk>finite S; node i a S \<notin> range (basis_emb :: 'a compact_basis \<Rightarrow> nat)\<rbrakk>
+    \<Longrightarrow> basis_prj (node i a S) = (basis_prj a :: 'a compact_basis)"
+unfolding basis_prj_def by simp
+
+lemma basis_prj_0: "basis_prj 0 = compact_bot"
+apply (subst basis_emb_compact_bot [symmetric])
+apply (rule basis_prj_basis_emb)
+done
+
+lemma node_eq_basis_emb_iff:
+  "finite S \<Longrightarrow> node i a S = basis_emb x \<longleftrightarrow>
+    x \<noteq> compact_bot \<and> i = place x \<and> a = basis_emb (sub x) \<and>
+        S = basis_emb ` {y. place y < place x \<and> x \<sqsubseteq> y}"
+apply (cases "x = compact_bot", simp)
+apply (simp add: basis_emb.simps [of x])
+apply (simp add: fin2)
+done
+
+lemma basis_prj_mono: "ubasis_le a b \<Longrightarrow> basis_prj a \<sqsubseteq> basis_prj b"
+proof (induct a b rule: ubasis_le.induct)
+  case (ubasis_le_refl a) show ?case by (rule below_refl)
+next
+  case (ubasis_le_trans a b c) thus ?case by - (rule below_trans)
+next
+  case (ubasis_le_lower S a i) thus ?case
+    apply (cases "node i a S \<in> range (basis_emb :: 'a compact_basis \<Rightarrow> nat)")
+     apply (erule rangeE, rename_tac x)
+     apply (simp add: basis_prj_basis_emb)
+     apply (simp add: node_eq_basis_emb_iff)
+     apply (simp add: basis_prj_basis_emb)
+     apply (rule sub_below)
+    apply (simp add: basis_prj_node)
+    done
+next
+  case (ubasis_le_upper S b a i) thus ?case
+    apply (cases "node i a S \<in> range (basis_emb :: 'a compact_basis \<Rightarrow> nat)")
+     apply (erule rangeE, rename_tac x)
+     apply (simp add: basis_prj_basis_emb)
+     apply (clarsimp simp add: node_eq_basis_emb_iff)
+     apply (simp add: basis_prj_basis_emb)
+    apply (simp add: basis_prj_node)
+    done
+qed
+
+lemma basis_emb_prj_less: "ubasis_le (basis_emb (basis_prj x)) x"
+unfolding basis_prj_def
+ apply (subst f_inv_into_f [where f=basis_emb])
+  apply (rule ubasis_until)
+  apply (rule range_eqI [where x=compact_bot])
+  apply simp
+ apply (rule ubasis_until_less)
+done
+
+end
+
+sublocale approx_chain \<subseteq> compact_basis!:
+  ideal_completion below Rep_compact_basis
+    "approximants :: 'a \<Rightarrow> 'a compact_basis set"
+proof
+  fix w :: "'a"
+  show "below.ideal (approximants w)"
+  proof (rule below.idealI)
+    show "\<exists>x. x \<in> approximants w"
+      unfolding approximants_def
+      apply (rule_tac x="Abs_compact_basis (approx 0\<cdot>w)" in exI)
+      apply (simp add: Abs_compact_basis_inverse approx_below compact_approx)
+      done
+  next
+    fix x y :: "'a compact_basis"
+    assume "x \<in> approximants w" "y \<in> approximants w"
+    thus "\<exists>z \<in> approximants w. x \<sqsubseteq> z \<and> y \<sqsubseteq> z"
+      unfolding approximants_def
+      apply simp
+      apply (cut_tac a=x in compact_Rep_compact_basis)
+      apply (cut_tac a=y in compact_Rep_compact_basis)
+      apply (drule compact_eq_approx)
+      apply (drule compact_eq_approx)
+      apply (clarify, rename_tac i j)
+      apply (rule_tac x="Abs_compact_basis (approx (max i j)\<cdot>w)" in exI)
+      apply (simp add: compact_le_def)
+      apply (simp add: Abs_compact_basis_inverse approx_below compact_approx)
+      apply (erule subst, erule subst)
+      apply (simp add: monofun_cfun chain_mono [OF chain_approx])
+      done
+  next
+    fix x y :: "'a compact_basis"
+    assume "x \<sqsubseteq> y" "y \<in> approximants w" thus "x \<in> approximants w"
+      unfolding approximants_def
+      apply simp
+      apply (simp add: compact_le_def)
+      apply (erule (1) below_trans)
+      done
+  qed
+next
+  fix Y :: "nat \<Rightarrow> 'a"
+  assume Y: "chain Y"
+  show "approximants (\<Squnion>i. Y i) = (\<Union>i. approximants (Y i))"
+    unfolding approximants_def
+    apply safe
+    apply (simp add: compactD2 [OF compact_Rep_compact_basis Y])
+    apply (erule below_lub [OF Y])
+    done
+next
+  fix a :: "'a compact_basis"
+  show "approximants (Rep_compact_basis a) = {b. b \<sqsubseteq> a}"
+    unfolding approximants_def compact_le_def ..
+next
+  fix x y :: "'a"
+  assume "approximants x \<subseteq> approximants y" thus "x \<sqsubseteq> y"
+    apply (subgoal_tac "(\<Squnion>i. approx i\<cdot>x) \<sqsubseteq> y")
+    apply (simp add: lub_distribs)
+    apply (rule admD, simp, simp)
+    apply (drule_tac c="Abs_compact_basis (approx i\<cdot>x)" in subsetD)
+    apply (simp add: approximants_def Abs_compact_basis_inverse
+                     approx_below compact_approx)
+    apply (simp add: approximants_def Abs_compact_basis_inverse compact_approx)
+    done
+next
+  show "\<exists>f::'a compact_basis \<Rightarrow> nat. inj f"
+    by (rule exI, rule inj_place)
+qed
+
+subsubsection {* EP-pair from any bifinite domain into \emph{udom} *}
+
+context approx_chain begin
+
+definition
+  udom_emb :: "'a \<rightarrow> udom"
+where
+  "udom_emb = compact_basis.basis_fun (\<lambda>x. udom_principal (basis_emb x))"
+
+definition
+  udom_prj :: "udom \<rightarrow> 'a"
+where
+  "udom_prj = udom.basis_fun (\<lambda>x. Rep_compact_basis (basis_prj x))"
+
+lemma udom_emb_principal:
+  "udom_emb\<cdot>(Rep_compact_basis x) = udom_principal (basis_emb x)"
+unfolding udom_emb_def
+apply (rule compact_basis.basis_fun_principal)
+apply (rule udom.principal_mono)
+apply (erule basis_emb_mono)
+done
+
+lemma udom_prj_principal:
+  "udom_prj\<cdot>(udom_principal x) = Rep_compact_basis (basis_prj x)"
+unfolding udom_prj_def
+apply (rule udom.basis_fun_principal)
+apply (rule compact_basis.principal_mono)
+apply (erule basis_prj_mono)
+done
+
+lemma ep_pair_udom: "ep_pair udom_emb udom_prj"
+ apply default
+  apply (rule compact_basis.principal_induct, simp)
+  apply (simp add: udom_emb_principal udom_prj_principal)
+  apply (simp add: basis_prj_basis_emb)
+ apply (rule udom.principal_induct, simp)
+ apply (simp add: udom_emb_principal udom_prj_principal)
+ apply (rule basis_emb_prj_less)
+done
+
+end
+
+abbreviation "udom_emb \<equiv> approx_chain.udom_emb"
+abbreviation "udom_prj \<equiv> approx_chain.udom_prj"
+
+lemmas ep_pair_udom = approx_chain.ep_pair_udom
+
+subsection {* Chain of approx functions for type \emph{udom} *}
+
+definition
+  udom_approx :: "nat \<Rightarrow> udom \<rightarrow> udom"
+where
+  "udom_approx i =
+    udom.basis_fun (\<lambda>x. udom_principal (ubasis_until (\<lambda>y. y \<le> i) x))"
+
+lemma udom_approx_mono:
+  "ubasis_le a b \<Longrightarrow>
+    udom_principal (ubasis_until (\<lambda>y. y \<le> i) a) \<sqsubseteq>
+    udom_principal (ubasis_until (\<lambda>y. y \<le> i) b)"
+apply (rule udom.principal_mono)
+apply (rule ubasis_until_mono)
+apply (frule (2) order_less_le_trans [OF node_gt2])
+apply (erule order_less_imp_le)
+apply assumption
+done
+
+lemma adm_mem_finite: "\<lbrakk>cont f; finite S\<rbrakk> \<Longrightarrow> adm (\<lambda>x. f x \<in> S)"
+by (erule adm_subst, induct set: finite, simp_all)
+
+lemma udom_approx_principal:
+  "udom_approx i\<cdot>(udom_principal x) =
+    udom_principal (ubasis_until (\<lambda>y. y \<le> i) x)"
+unfolding udom_approx_def
+apply (rule udom.basis_fun_principal)
+apply (erule udom_approx_mono)
+done
+
+lemma finite_deflation_udom_approx: "finite_deflation (udom_approx i)"
+proof
+  fix x show "udom_approx i\<cdot>(udom_approx i\<cdot>x) = udom_approx i\<cdot>x"
+    by (induct x rule: udom.principal_induct, simp)
+       (simp add: udom_approx_principal ubasis_until_idem)
+next
+  fix x show "udom_approx i\<cdot>x \<sqsubseteq> x"
+    by (induct x rule: udom.principal_induct, simp)
+       (simp add: udom_approx_principal ubasis_until_less)
+next
+  have *: "finite (range (\<lambda>x. udom_principal (ubasis_until (\<lambda>y. y \<le> i) x)))"
+    apply (subst range_composition [where f=udom_principal])
+    apply (simp add: finite_range_ubasis_until)
+    done
+  show "finite {x. udom_approx i\<cdot>x = x}"
+    apply (rule finite_range_imp_finite_fixes)
+    apply (rule rev_finite_subset [OF *])
+    apply (clarsimp, rename_tac x)
+    apply (induct_tac x rule: udom.principal_induct)
+    apply (simp add: adm_mem_finite *)
+    apply (simp add: udom_approx_principal)
+    done
+qed
+
+interpretation udom_approx: finite_deflation "udom_approx i"
+by (rule finite_deflation_udom_approx)
+
+lemma chain_udom_approx [simp]: "chain (\<lambda>i. udom_approx i)"
+unfolding udom_approx_def
+apply (rule chainI)
+apply (rule udom.basis_fun_mono)
+apply (erule udom_approx_mono)
+apply (erule udom_approx_mono)
+apply (rule udom.principal_mono)
+apply (rule ubasis_until_chain, simp)
+done
+
+lemma lub_udom_approx [simp]: "(\<Squnion>i. udom_approx i) = ID"
+apply (rule cfun_eqI, simp add: contlub_cfun_fun)
+apply (rule below_antisym)
+apply (rule lub_below)
+apply (simp)
+apply (rule udom_approx.below)
+apply (rule_tac x=x in udom.principal_induct)
+apply (simp add: lub_distribs)
+apply (rule_tac i=a in below_lub)
+apply simp
+apply (simp add: udom_approx_principal)
+apply (simp add: ubasis_until_same ubasis_le_refl)
+done
+ 
+lemma udom_approx: "approx_chain udom_approx"
+proof
+  show "chain (\<lambda>i. udom_approx i)"
+    by (rule chain_udom_approx)
+  show "(\<Squnion>i. udom_approx i) = ID"
+    by (rule lub_udom_approx)
+qed
+
+hide_const (open) node
+
+end

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/HOLCF/Up.thy	Sat Nov 27 16:08:10 2010 -0800
@@ -0,0 +1,263 @@
+(*  Title:      HOLCF/Up.thy
+    Author:     Franz Regensburger
+    Author:     Brian Huffman
+*)
+
+header {* The type of lifted values *}
+
+theory Up
+imports Cfun
+begin
+
+default_sort cpo
+
+subsection {* Definition of new type for lifting *}
+
+datatype 'a u = Ibottom | Iup 'a
+
+type_notation (xsymbols)
+  u  ("(_\<^sub>\<bottom>)" [1000] 999)
+
+primrec Ifup :: "('a \<rightarrow> 'b::pcpo) \<Rightarrow> 'a u \<Rightarrow> 'b" where
+    "Ifup f Ibottom = \<bottom>"
+ |  "Ifup f (Iup x) = f\<cdot>x"
+
+subsection {* Ordering on lifted cpo *}
+
+instantiation u :: (cpo) below
+begin
+
+definition
+  below_up_def:
+    "(op \<sqsubseteq>) \<equiv> (\<lambda>x y. case x of Ibottom \<Rightarrow> True | Iup a \<Rightarrow>
+      (case y of Ibottom \<Rightarrow> False | Iup b \<Rightarrow> a \<sqsubseteq> b))"
+
+instance ..
+end
+
+lemma minimal_up [iff]: "Ibottom \<sqsubseteq> z"
+by (simp add: below_up_def)
+
+lemma not_Iup_below [iff]: "\<not> Iup x \<sqsubseteq> Ibottom"
+by (simp add: below_up_def)
+
+lemma Iup_below [iff]: "(Iup x \<sqsubseteq> Iup y) = (x \<sqsubseteq> y)"
+by (simp add: below_up_def)
+
+subsection {* Lifted cpo is a partial order *}
+
+instance u :: (cpo) po
+proof
+  fix x :: "'a u"
+  show "x \<sqsubseteq> x"
+    unfolding below_up_def by (simp split: u.split)
+next
+  fix x y :: "'a u"
+  assume "x \<sqsubseteq> y" "y \<sqsubseteq> x" thus "x = y"
+    unfolding below_up_def
+    by (auto split: u.split_asm intro: below_antisym)
+next
+  fix x y z :: "'a u"
+  assume "x \<sqsubseteq> y" "y \<sqsubseteq> z" thus "x \<sqsubseteq> z"
+    unfolding below_up_def
+    by (auto split: u.split_asm intro: below_trans)
+qed
+
+subsection {* Lifted cpo is a cpo *}
+
+lemma is_lub_Iup:
+  "range S <<| x \<Longrightarrow> range (\<lambda>i. Iup (S i)) <<| Iup x"
+unfolding is_lub_def is_ub_def ball_simps
+by (auto simp add: below_up_def split: u.split)
+
+lemma up_chain_lemma:
+  assumes Y: "chain Y" obtains "\<forall>i. Y i = Ibottom"
+  | A k where "\<forall>i. Iup (A i) = Y (i + k)" and "chain A" and "range Y <<| Iup (\<Squnion>i. A i)"
+proof (cases "\<exists>k. Y k \<noteq> Ibottom")
+  case True
+  then obtain k where k: "Y k \<noteq> Ibottom" ..
+  def A \<equiv> "\<lambda>i. THE a. Iup a = Y (i + k)"
+  have Iup_A: "\<forall>i. Iup (A i) = Y (i + k)"
+  proof
+    fix i :: nat
+    from Y le_add2 have "Y k \<sqsubseteq> Y (i + k)" by (rule chain_mono)
+    with k have "Y (i + k) \<noteq> Ibottom" by (cases "Y k", auto)
+    thus "Iup (A i) = Y (i + k)"
+      by (cases "Y (i + k)", simp_all add: A_def)
+  qed
+  from Y have chain_A: "chain A"
+    unfolding chain_def Iup_below [symmetric]
+    by (simp add: Iup_A)
+  hence "range A <<| (\<Squnion>i. A i)"
+    by (rule cpo_lubI)
+  hence "range (\<lambda>i. Iup (A i)) <<| Iup (\<Squnion>i. A i)"
+    by (rule is_lub_Iup)
+  hence "range (\<lambda>i. Y (i + k)) <<| Iup (\<Squnion>i. A i)"
+    by (simp only: Iup_A)
+  hence "range (\<lambda>i. Y i) <<| Iup (\<Squnion>i. A i)"
+    by (simp only: is_lub_range_shift [OF Y])
+  with Iup_A chain_A show ?thesis ..
+next
+  case False
+  then have "\<forall>i. Y i = Ibottom" by simp
+  then show ?thesis ..
+qed
+
+instance u :: (cpo) cpo
+proof
+  fix S :: "nat \<Rightarrow> 'a u"
+  assume S: "chain S"
+  thus "\<exists>x. range (\<lambda>i. S i) <<| x"
+  proof (rule up_chain_lemma)
+    assume "\<forall>i. S i = Ibottom"
+    hence "range (\<lambda>i. S i) <<| Ibottom"
+      by (simp add: is_lub_const)
+    thus ?thesis ..
+  next
+    fix A :: "nat \<Rightarrow> 'a"
+    assume "range S <<| Iup (\<Squnion>i. A i)"
+    thus ?thesis ..
+  qed
+qed
+
+subsection {* Lifted cpo is pointed *}
+
+instance u :: (cpo) pcpo
+by intro_classes fast
+
+text {* for compatibility with old HOLCF-Version *}
+lemma inst_up_pcpo: "\<bottom> = Ibottom"
+by (rule minimal_up [THEN UU_I, symmetric])
+
+subsection {* Continuity of \emph{Iup} and \emph{Ifup} *}
+
+text {* continuity for @{term Iup} *}
+
+lemma cont_Iup: "cont Iup"
+apply (rule contI)
+apply (rule is_lub_Iup)
+apply (erule cpo_lubI)
+done
+
+text {* continuity for @{term Ifup} *}
+
+lemma cont_Ifup1: "cont (\<lambda>f. Ifup f x)"
+by (induct x, simp_all)
+
+lemma monofun_Ifup2: "monofun (\<lambda>x. Ifup f x)"
+apply (rule monofunI)
+apply (case_tac x, simp)
+apply (case_tac y, simp)
+apply (simp add: monofun_cfun_arg)
+done
+
+lemma cont_Ifup2: "cont (\<lambda>x. Ifup f x)"
+proof (rule contI2)
+  fix Y assume Y: "chain Y" and Y': "chain (\<lambda>i. Ifup f (Y i))"
+  from Y show "Ifup f (\<Squnion>i. Y i) \<sqsubseteq> (\<Squnion>i. Ifup f (Y i))"
+  proof (rule up_chain_lemma)
+    fix A and k
+    assume A: "\<forall>i. Iup (A i) = Y (i + k)"
+    assume "chain A" and "range Y <<| Iup (\<Squnion>i. A i)"
+    hence "Ifup f (\<Squnion>i. Y i) = (\<Squnion>i. Ifup f (Iup (A i)))"
+      by (simp add: lub_eqI contlub_cfun_arg)
+    also have "\<dots> = (\<Squnion>i. Ifup f (Y (i + k)))"
+      by (simp add: A)
+    also have "\<dots> = (\<Squnion>i. Ifup f (Y i))"
+      using Y' by (rule lub_range_shift)
+    finally show ?thesis by simp
+  qed simp
+qed (rule monofun_Ifup2)
+
+subsection {* Continuous versions of constants *}
+
+definition
+  up  :: "'a \<rightarrow> 'a u" where
+  "up = (\<Lambda> x. Iup x)"
+
+definition
+  fup :: "('a \<rightarrow> 'b::pcpo) \<rightarrow> 'a u \<rightarrow> 'b" where
+  "fup = (\<Lambda> f p. Ifup f p)"
+
+translations
+  "case l of XCONST up\<cdot>x \<Rightarrow> t" == "CONST fup\<cdot>(\<Lambda> x. t)\<cdot>l"
+  "\<Lambda>(XCONST up\<cdot>x). t" == "CONST fup\<cdot>(\<Lambda> x. t)"
+
+text {* continuous versions of lemmas for @{typ "('a)u"} *}
+
+lemma Exh_Up: "z = \<bottom> \<or> (\<exists>x. z = up\<cdot>x)"
+apply (induct z)
+apply (simp add: inst_up_pcpo)
+apply (simp add: up_def cont_Iup)
+done
+
+lemma up_eq [simp]: "(up\<cdot>x = up\<cdot>y) = (x = y)"
+by (simp add: up_def cont_Iup)
+
+lemma up_inject: "up\<cdot>x = up\<cdot>y \<Longrightarrow> x = y"
+by simp
+
+lemma up_defined [simp]: "up\<cdot>x \<noteq> \<bottom>"
+by (simp add: up_def cont_Iup inst_up_pcpo)
+
+lemma not_up_less_UU: "\<not> up\<cdot>x \<sqsubseteq> \<bottom>"
+by simp (* FIXME: remove? *)
+
+lemma up_below [simp]: "up\<cdot>x \<sqsubseteq> up\<cdot>y \<longleftrightarrow> x \<sqsubseteq> y"
+by (simp add: up_def cont_Iup)
+
+lemma upE [case_names bottom up, cases type: u]:
+  "\<lbrakk>p = \<bottom> \<Longrightarrow> Q; \<And>x. p = up\<cdot>x \<Longrightarrow> Q\<rbrakk> \<Longrightarrow> Q"
+apply (cases p)
+apply (simp add: inst_up_pcpo)
+apply (simp add: up_def cont_Iup)
+done
+
+lemma up_induct [case_names bottom up, induct type: u]:
+  "\<lbrakk>P \<bottom>; \<And>x. P (up\<cdot>x)\<rbrakk> \<Longrightarrow> P x"
+by (cases x, simp_all)
+
+text {* lifting preserves chain-finiteness *}
+
+lemma up_chain_cases:
+  assumes Y: "chain Y" obtains "\<forall>i. Y i = \<bottom>"
+  | A k where "\<forall>i. up\<cdot>(A i) = Y (i + k)" and "chain A" and "(\<Squnion>i. Y i) = up\<cdot>(\<Squnion>i. A i)"
+apply (rule up_chain_lemma [OF Y])
+apply (simp_all add: inst_up_pcpo up_def cont_Iup lub_eqI)
+done
+
+lemma compact_up: "compact x \<Longrightarrow> compact (up\<cdot>x)"
+apply (rule compactI2)
+apply (erule up_chain_cases)
+apply simp
+apply (drule (1) compactD2, simp)
+apply (erule exE)
+apply (drule_tac f="up" and x="x" in monofun_cfun_arg)
+apply (simp, erule exI)
+done
+
+lemma compact_upD: "compact (up\<cdot>x) \<Longrightarrow> compact x"
+unfolding compact_def
+by (drule adm_subst [OF cont_Rep_cfun2 [where f=up]], simp)
+
+lemma compact_up_iff [simp]: "compact (up\<cdot>x) = compact x"
+by (safe elim!: compact_up compact_upD)
+
+instance u :: (chfin) chfin
+apply intro_classes
+apply (erule compact_imp_max_in_chain)
+apply (rule_tac p="\<Squnion>i. Y i" in upE, simp_all)
+done
+
+text {* properties of fup *}
+
+lemma fup1 [simp]: "fup\<cdot>f\<cdot>\<bottom> = \<bottom>"
+by (simp add: fup_def cont_Ifup1 cont_Ifup2 inst_up_pcpo cont2cont_LAM)
+
+lemma fup2 [simp]: "fup\<cdot>f\<cdot>(up\<cdot>x) = f\<cdot>x"
+by (simp add: up_def fup_def cont_Iup cont_Ifup1 cont_Ifup2 cont2cont_LAM)
+
+lemma fup3 [simp]: "fup\<cdot>up\<cdot>x = x"
+by (cases x, simp_all)
+
+end

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/HOLCF/UpperPD.thy	Sat Nov 27 16:08:10 2010 -0800
@@ -0,0 +1,529 @@
+(*  Title:      HOLCF/UpperPD.thy
+    Author:     Brian Huffman
+*)
+
+header {* Upper powerdomain *}
+
+theory UpperPD
+imports CompactBasis
+begin
+
+subsection {* Basis preorder *}
+
+definition
+  upper_le :: "'a pd_basis \<Rightarrow> 'a pd_basis \<Rightarrow> bool" (infix "\<le>\<sharp>" 50) where
+  "upper_le = (\<lambda>u v. \<forall>y\<in>Rep_pd_basis v. \<exists>x\<in>Rep_pd_basis u. x \<sqsubseteq> y)"
+
+lemma upper_le_refl [simp]: "t \<le>\<sharp> t"
+unfolding upper_le_def by fast
+
+lemma upper_le_trans: "\<lbrakk>t \<le>\<sharp> u; u \<le>\<sharp> v\<rbrakk> \<Longrightarrow> t \<le>\<sharp> v"
+unfolding upper_le_def
+apply (rule ballI)
+apply (drule (1) bspec, erule bexE)
+apply (drule (1) bspec, erule bexE)
+apply (erule rev_bexI)
+apply (erule (1) below_trans)
+done
+
+interpretation upper_le: preorder upper_le
+by (rule preorder.intro, rule upper_le_refl, rule upper_le_trans)
+
+lemma upper_le_minimal [simp]: "PDUnit compact_bot \<le>\<sharp> t"
+unfolding upper_le_def Rep_PDUnit by simp
+
+lemma PDUnit_upper_mono: "x \<sqsubseteq> y \<Longrightarrow> PDUnit x \<le>\<sharp> PDUnit y"
+unfolding upper_le_def Rep_PDUnit by simp
+
+lemma PDPlus_upper_mono: "\<lbrakk>s \<le>\<sharp> t; u \<le>\<sharp> v\<rbrakk> \<Longrightarrow> PDPlus s u \<le>\<sharp> PDPlus t v"
+unfolding upper_le_def Rep_PDPlus by fast
+
+lemma PDPlus_upper_le: "PDPlus t u \<le>\<sharp> t"
+unfolding upper_le_def Rep_PDPlus by fast
+
+lemma upper_le_PDUnit_PDUnit_iff [simp]:
+  "(PDUnit a \<le>\<sharp> PDUnit b) = (a \<sqsubseteq> b)"
+unfolding upper_le_def Rep_PDUnit by fast
+
+lemma upper_le_PDPlus_PDUnit_iff:
+  "(PDPlus t u \<le>\<sharp> PDUnit a) = (t \<le>\<sharp> PDUnit a \<or> u \<le>\<sharp> PDUnit a)"
+unfolding upper_le_def Rep_PDPlus Rep_PDUnit by fast
+
+lemma upper_le_PDPlus_iff: "(t \<le>\<sharp> PDPlus u v) = (t \<le>\<sharp> u \<and> t \<le>\<sharp> v)"
+unfolding upper_le_def Rep_PDPlus by fast
+
+lemma upper_le_induct [induct set: upper_le]:
+  assumes le: "t \<le>\<sharp> u"
+  assumes 1: "\<And>a b. a \<sqsubseteq> b \<Longrightarrow> P (PDUnit a) (PDUnit b)"
+  assumes 2: "\<And>t u a. P t (PDUnit a) \<Longrightarrow> P (PDPlus t u) (PDUnit a)"
+  assumes 3: "\<And>t u v. \<lbrakk>P t u; P t v\<rbrakk> \<Longrightarrow> P t (PDPlus u v)"
+  shows "P t u"
+using le apply (induct u arbitrary: t rule: pd_basis_induct)
+apply (erule rev_mp)
+apply (induct_tac t rule: pd_basis_induct)
+apply (simp add: 1)
+apply (simp add: upper_le_PDPlus_PDUnit_iff)
+apply (simp add: 2)
+apply (subst PDPlus_commute)
+apply (simp add: 2)
+apply (simp add: upper_le_PDPlus_iff 3)
+done
+
+
+subsection {* Type definition *}
+
+typedef (open) 'a upper_pd =
+  "{S::'a pd_basis set. upper_le.ideal S}"
+by (fast intro: upper_le.ideal_principal)
+
+instantiation upper_pd :: ("domain") below
+begin
+
+definition
+  "x \<sqsubseteq> y \<longleftrightarrow> Rep_upper_pd x \<subseteq> Rep_upper_pd y"
+
+instance ..
+end
+
+instance upper_pd :: ("domain") po
+using type_definition_upper_pd below_upper_pd_def
+by (rule upper_le.typedef_ideal_po)
+
+instance upper_pd :: ("domain") cpo
+using type_definition_upper_pd below_upper_pd_def
+by (rule upper_le.typedef_ideal_cpo)
+
+definition
+  upper_principal :: "'a pd_basis \<Rightarrow> 'a upper_pd" where
+  "upper_principal t = Abs_upper_pd {u. u \<le>\<sharp> t}"
+
+interpretation upper_pd:
+  ideal_completion upper_le upper_principal Rep_upper_pd
+using type_definition_upper_pd below_upper_pd_def
+using upper_principal_def pd_basis_countable
+by (rule upper_le.typedef_ideal_completion)
+
+text {* Upper powerdomain is pointed *}
+
+lemma upper_pd_minimal: "upper_principal (PDUnit compact_bot) \<sqsubseteq> ys"
+by (induct ys rule: upper_pd.principal_induct, simp, simp)
+
+instance upper_pd :: ("domain") pcpo
+by intro_classes (fast intro: upper_pd_minimal)
+
+lemma inst_upper_pd_pcpo: "\<bottom> = upper_principal (PDUnit compact_bot)"
+by (rule upper_pd_minimal [THEN UU_I, symmetric])
+
+
+subsection {* Monadic unit and plus *}
+
+definition
+  upper_unit :: "'a \<rightarrow> 'a upper_pd" where
+  "upper_unit = compact_basis.basis_fun (\<lambda>a. upper_principal (PDUnit a))"
+
+definition
+  upper_plus :: "'a upper_pd \<rightarrow> 'a upper_pd \<rightarrow> 'a upper_pd" where
+  "upper_plus = upper_pd.basis_fun (\<lambda>t. upper_pd.basis_fun (\<lambda>u.
+      upper_principal (PDPlus t u)))"
+
+abbreviation
+  upper_add :: "'a upper_pd \<Rightarrow> 'a upper_pd \<Rightarrow> 'a upper_pd"
+    (infixl "+\<sharp>" 65) where
+  "xs +\<sharp> ys == upper_plus\<cdot>xs\<cdot>ys"
+
+syntax
+  "_upper_pd" :: "args \<Rightarrow> 'a upper_pd" ("{_}\<sharp>")
+
+translations
+  "{x,xs}\<sharp>" == "{x}\<sharp> +\<sharp> {xs}\<sharp>"
+  "{x}\<sharp>" == "CONST upper_unit\<cdot>x"
+
+lemma upper_unit_Rep_compact_basis [simp]:
+  "{Rep_compact_basis a}\<sharp> = upper_principal (PDUnit a)"
+unfolding upper_unit_def
+by (simp add: compact_basis.basis_fun_principal PDUnit_upper_mono)
+
+lemma upper_plus_principal [simp]:
+  "upper_principal t +\<sharp> upper_principal u = upper_principal (PDPlus t u)"
+unfolding upper_plus_def
+by (simp add: upper_pd.basis_fun_principal
+    upper_pd.basis_fun_mono PDPlus_upper_mono)
+
+interpretation upper_add: semilattice upper_add proof
+  fix xs ys zs :: "'a upper_pd"
+  show "(xs +\<sharp> ys) +\<sharp> zs = xs +\<sharp> (ys +\<sharp> zs)"
+    apply (induct xs ys arbitrary: zs rule: upper_pd.principal_induct2, simp, simp)
+    apply (rule_tac x=zs in upper_pd.principal_induct, simp)
+    apply (simp add: PDPlus_assoc)
+    done
+  show "xs +\<sharp> ys = ys +\<sharp> xs"
+    apply (induct xs ys rule: upper_pd.principal_induct2, simp, simp)
+    apply (simp add: PDPlus_commute)
+    done
+  show "xs +\<sharp> xs = xs"
+    apply (induct xs rule: upper_pd.principal_induct, simp)
+    apply (simp add: PDPlus_absorb)
+    done
+qed
+
+lemmas upper_plus_assoc = upper_add.assoc
+lemmas upper_plus_commute = upper_add.commute
+lemmas upper_plus_absorb = upper_add.idem
+lemmas upper_plus_left_commute = upper_add.left_commute
+lemmas upper_plus_left_absorb = upper_add.left_idem
+
+text {* Useful for @{text "simp add: upper_plus_ac"} *}
+lemmas upper_plus_ac =
+  upper_plus_assoc upper_plus_commute upper_plus_left_commute
+
+text {* Useful for @{text "simp only: upper_plus_aci"} *}
+lemmas upper_plus_aci =
+  upper_plus_ac upper_plus_absorb upper_plus_left_absorb
+
+lemma upper_plus_below1: "xs +\<sharp> ys \<sqsubseteq> xs"
+apply (induct xs ys rule: upper_pd.principal_induct2, simp, simp)
+apply (simp add: PDPlus_upper_le)
+done
+
+lemma upper_plus_below2: "xs +\<sharp> ys \<sqsubseteq> ys"
+by (subst upper_plus_commute, rule upper_plus_below1)
+
+lemma upper_plus_greatest: "\<lbrakk>xs \<sqsubseteq> ys; xs \<sqsubseteq> zs\<rbrakk> \<Longrightarrow> xs \<sqsubseteq> ys +\<sharp> zs"
+apply (subst upper_plus_absorb [of xs, symmetric])
+apply (erule (1) monofun_cfun [OF monofun_cfun_arg])
+done
+
+lemma upper_below_plus_iff [simp]:
+  "xs \<sqsubseteq> ys +\<sharp> zs \<longleftrightarrow> xs \<sqsubseteq> ys \<and> xs \<sqsubseteq> zs"
+apply safe
+apply (erule below_trans [OF _ upper_plus_below1])
+apply (erule below_trans [OF _ upper_plus_below2])
+apply (erule (1) upper_plus_greatest)
+done
+
+lemma upper_plus_below_unit_iff [simp]:
+  "xs +\<sharp> ys \<sqsubseteq> {z}\<sharp> \<longleftrightarrow> xs \<sqsubseteq> {z}\<sharp> \<or> ys \<sqsubseteq> {z}\<sharp>"
+apply (induct xs rule: upper_pd.principal_induct, simp)
+apply (induct ys rule: upper_pd.principal_induct, simp)
+apply (induct z rule: compact_basis.principal_induct, simp)
+apply (simp add: upper_le_PDPlus_PDUnit_iff)
+done
+
+lemma upper_unit_below_iff [simp]: "{x}\<sharp> \<sqsubseteq> {y}\<sharp> \<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
+
+lemmas upper_pd_below_simps =
+  upper_unit_below_iff
+  upper_below_plus_iff
+  upper_plus_below_unit_iff
+
+lemma upper_unit_eq_iff [simp]: "{x}\<sharp> = {y}\<sharp> \<longleftrightarrow> x = y"
+unfolding po_eq_conv by simp
+
+lemma upper_unit_strict [simp]: "{\<bottom>}\<sharp> = \<bottom>"
+using upper_unit_Rep_compact_basis [of compact_bot]
+by (simp add: inst_upper_pd_pcpo)
+
+lemma upper_plus_strict1 [simp]: "\<bottom> +\<sharp> ys = \<bottom>"
+by (rule UU_I, rule upper_plus_below1)
+
+lemma upper_plus_strict2 [simp]: "xs +\<sharp> \<bottom> = \<bottom>"
+by (rule UU_I, rule upper_plus_below2)
+
+lemma upper_unit_bottom_iff [simp]: "{x}\<sharp> = \<bottom> \<longleftrightarrow> x = \<bottom>"
+unfolding upper_unit_strict [symmetric] by (rule upper_unit_eq_iff)
+
+lemma upper_plus_bottom_iff [simp]:
+  "xs +\<sharp> ys = \<bottom> \<longleftrightarrow> xs = \<bottom> \<or> ys = \<bottom>"
+apply (rule iffI)
+apply (erule rev_mp)
+apply (rule upper_pd.principal_induct2 [where x=xs and y=ys], simp, simp)
+apply (simp add: inst_upper_pd_pcpo upper_pd.principal_eq_iff
+                 upper_le_PDPlus_PDUnit_iff)
+apply auto
+done
+
+lemma compact_upper_unit: "compact x \<Longrightarrow> compact {x}\<sharp>"
+by (auto dest!: compact_basis.compact_imp_principal)
+
+lemma compact_upper_unit_iff [simp]: "compact {x}\<sharp> \<longleftrightarrow> compact x"
+apply (safe elim!: compact_upper_unit)
+apply (simp only: compact_def upper_unit_below_iff [symmetric])
+apply (erule adm_subst [OF cont_Rep_cfun2])
+done
+
+lemma compact_upper_plus [simp]:
+  "\<lbrakk>compact xs; compact ys\<rbrakk> \<Longrightarrow> compact (xs +\<sharp> ys)"
+by (auto dest!: upper_pd.compact_imp_principal)
+
+
+subsection {* Induction rules *}
+
+lemma upper_pd_induct1:
+  assumes P: "adm P"
+  assumes unit: "\<And>x. P {x}\<sharp>"
+  assumes insert: "\<And>x ys. \<lbrakk>P {x}\<sharp>; P ys\<rbrakk> \<Longrightarrow> P ({x}\<sharp> +\<sharp> ys)"
+  shows "P (xs::'a upper_pd)"
+apply (induct xs rule: upper_pd.principal_induct, rule P)
+apply (induct_tac a rule: pd_basis_induct1)
+apply (simp only: upper_unit_Rep_compact_basis [symmetric])
+apply (rule unit)
+apply (simp only: upper_unit_Rep_compact_basis [symmetric]
+                  upper_plus_principal [symmetric])
+apply (erule insert [OF unit])
+done
+
+lemma upper_pd_induct
+  [case_names adm upper_unit upper_plus, induct type: upper_pd]:
+  assumes P: "adm P"
+  assumes unit: "\<And>x. P {x}\<sharp>"
+  assumes plus: "\<And>xs ys. \<lbrakk>P xs; P ys\<rbrakk> \<Longrightarrow> P (xs +\<sharp> ys)"
+  shows "P (xs::'a upper_pd)"
+apply (induct xs rule: upper_pd.principal_induct, rule P)
+apply (induct_tac a rule: pd_basis_induct)
+apply (simp only: upper_unit_Rep_compact_basis [symmetric] unit)
+apply (simp only: upper_plus_principal [symmetric] plus)
+done
+
+
+subsection {* Monadic bind *}
+
+definition
+  upper_bind_basis ::
+  "'a pd_basis \<Rightarrow> ('a \<rightarrow> 'b upper_pd) \<rightarrow> 'b upper_pd" where
+  "upper_bind_basis = fold_pd
+    (\<lambda>a. \<Lambda> f. f\<cdot>(Rep_compact_basis a))
+    (\<lambda>x y. \<Lambda> f. x\<cdot>f +\<sharp> y\<cdot>f)"
+
+lemma ACI_upper_bind:
+  "class.ab_semigroup_idem_mult (\<lambda>x y. \<Lambda> f. x\<cdot>f +\<sharp> y\<cdot>f)"
+apply unfold_locales
+apply (simp add: upper_plus_assoc)
+apply (simp add: upper_plus_commute)
+apply (simp add: eta_cfun)
+done
+
+lemma upper_bind_basis_simps [simp]:
+  "upper_bind_basis (PDUnit a) =
+    (\<Lambda> f. f\<cdot>(Rep_compact_basis a))"
+  "upper_bind_basis (PDPlus t u) =
+    (\<Lambda> f. upper_bind_basis t\<cdot>f +\<sharp> upper_bind_basis u\<cdot>f)"
+unfolding upper_bind_basis_def
+apply -
+apply (rule fold_pd_PDUnit [OF ACI_upper_bind])
+apply (rule fold_pd_PDPlus [OF ACI_upper_bind])
+done
+
+lemma upper_bind_basis_mono:
+  "t \<le>\<sharp> u \<Longrightarrow> upper_bind_basis t \<sqsubseteq> upper_bind_basis u"
+unfolding cfun_below_iff
+apply (erule upper_le_induct, safe)
+apply (simp add: monofun_cfun)
+apply (simp add: below_trans [OF upper_plus_below1])
+apply simp
+done
+
+definition
+  upper_bind :: "'a upper_pd \<rightarrow> ('a \<rightarrow> 'b upper_pd) \<rightarrow> 'b upper_pd" where
+  "upper_bind = upper_pd.basis_fun upper_bind_basis"
+
+lemma upper_bind_principal [simp]:
+  "upper_bind\<cdot>(upper_principal t) = upper_bind_basis t"
+unfolding upper_bind_def
+apply (rule upper_pd.basis_fun_principal)
+apply (erule upper_bind_basis_mono)
+done
+
+lemma upper_bind_unit [simp]:
+  "upper_bind\<cdot>{x}\<sharp>\<cdot>f = f\<cdot>x"
+by (induct x rule: compact_basis.principal_induct, simp, simp)
+
+lemma upper_bind_plus [simp]:
+  "upper_bind\<cdot>(xs +\<sharp> ys)\<cdot>f = upper_bind\<cdot>xs\<cdot>f +\<sharp> upper_bind\<cdot>ys\<cdot>f"
+by (induct xs ys rule: upper_pd.principal_induct2, simp, simp, simp)
+
+lemma upper_bind_strict [simp]: "upper_bind\<cdot>\<bottom>\<cdot>f = f\<cdot>\<bottom>"
+unfolding upper_unit_strict [symmetric] by (rule upper_bind_unit)
+
+lemma upper_bind_bind:
+  "upper_bind\<cdot>(upper_bind\<cdot>xs\<cdot>f)\<cdot>g = upper_bind\<cdot>xs\<cdot>(\<Lambda> x. upper_bind\<cdot>(f\<cdot>x)\<cdot>g)"
+by (induct xs, simp_all)
+
+
+subsection {* Map *}
+
+definition
+  upper_map :: "('a \<rightarrow> 'b) \<rightarrow> 'a upper_pd \<rightarrow> 'b upper_pd" where
+  "upper_map = (\<Lambda> f xs. upper_bind\<cdot>xs\<cdot>(\<Lambda> x. {f\<cdot>x}\<sharp>))"
+
+lemma upper_map_unit [simp]:
+  "upper_map\<cdot>f\<cdot>{x}\<sharp> = {f\<cdot>x}\<sharp>"
+unfolding upper_map_def by simp
+
+lemma upper_map_plus [simp]:
+  "upper_map\<cdot>f\<cdot>(xs +\<sharp> ys) = upper_map\<cdot>f\<cdot>xs +\<sharp> upper_map\<cdot>f\<cdot>ys"
+unfolding upper_map_def by simp
+
+lemma upper_map_bottom [simp]: "upper_map\<cdot>f\<cdot>\<bottom> = {f\<cdot>\<bottom>}\<sharp>"
+unfolding upper_map_def by simp
+
+lemma upper_map_ident: "upper_map\<cdot>(\<Lambda> x. x)\<cdot>xs = xs"
+by (induct xs rule: upper_pd_induct, simp_all)
+
+lemma upper_map_ID: "upper_map\<cdot>ID = ID"
+by (simp add: cfun_eq_iff ID_def upper_map_ident)
+
+lemma upper_map_map:
+  "upper_map\<cdot>f\<cdot>(upper_map\<cdot>g\<cdot>xs) = upper_map\<cdot>(\<Lambda> x. f\<cdot>(g\<cdot>x))\<cdot>xs"
+by (induct xs rule: upper_pd_induct, simp_all)
+
+lemma ep_pair_upper_map: "ep_pair e p \<Longrightarrow> ep_pair (upper_map\<cdot>e) (upper_map\<cdot>p)"
+apply default
+apply (induct_tac x rule: upper_pd_induct, simp_all add: ep_pair.e_inverse)
+apply (induct_tac y rule: upper_pd_induct)
+apply (simp_all add: ep_pair.e_p_below monofun_cfun del: upper_below_plus_iff)
+done
+
+lemma deflation_upper_map: "deflation d \<Longrightarrow> deflation (upper_map\<cdot>d)"
+apply default
+apply (induct_tac x rule: upper_pd_induct, simp_all add: deflation.idem)
+apply (induct_tac x rule: upper_pd_induct)
+apply (simp_all add: deflation.below monofun_cfun del: upper_below_plus_iff)
+done
+
+(* FIXME: long proof! *)
+lemma finite_deflation_upper_map:
+  assumes "finite_deflation d" shows "finite_deflation (upper_map\<cdot>d)"
+proof (rule finite_deflation_intro)
+  interpret d: finite_deflation d by fact
+  have "deflation d" by fact
+  thus "deflation (upper_map\<cdot>d)" by (rule deflation_upper_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 (upper_principal ` Rep_pd_basis -` (Pow (Rep_compact_basis -` range (\<lambda>x. d\<cdot>x))))" by simp
+  hence "finite (range (\<lambda>xs. upper_map\<cdot>d\<cdot>xs))"
+    apply (rule rev_finite_subset)
+    apply clarsimp
+    apply (induct_tac xs rule: upper_pd.principal_induct)
+    apply (simp add: adm_mem_finite *)
+    apply (rename_tac t, induct_tac t rule: pd_basis_induct)
+    apply (simp only: upper_unit_Rep_compact_basis [symmetric] upper_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: upper_plus_principal [symmetric] upper_map_plus)
+    apply clarsimp
+    apply (rule imageI)
+    apply (rule vimageI2)
+    apply (simp add: Rep_PDPlus)
+    done
+  thus "finite {xs. upper_map\<cdot>d\<cdot>xs = xs}"
+    by (rule finite_range_imp_finite_fixes)
+qed
+
+subsection {* Upper powerdomain is a domain *}
+
+definition
+  upper_approx :: "nat \<Rightarrow> udom upper_pd \<rightarrow> udom upper_pd"
+where
+  "upper_approx = (\<lambda>i. upper_map\<cdot>(udom_approx i))"
+
+lemma upper_approx: "approx_chain upper_approx"
+using upper_map_ID finite_deflation_upper_map
+unfolding upper_approx_def by (rule approx_chain_lemma1)
+
+definition upper_defl :: "defl \<rightarrow> defl"
+where "upper_defl = defl_fun1 upper_approx upper_map"
+
+lemma cast_upper_defl:
+  "cast\<cdot>(upper_defl\<cdot>A) =
+    udom_emb upper_approx oo upper_map\<cdot>(cast\<cdot>A) oo udom_prj upper_approx"
+using upper_approx finite_deflation_upper_map
+unfolding upper_defl_def by (rule cast_defl_fun1)
+
+instantiation upper_pd :: ("domain") liftdomain
+begin
+
+definition
+  "emb = udom_emb upper_approx oo upper_map\<cdot>emb"
+
+definition
+  "prj = upper_map\<cdot>prj oo udom_prj upper_approx"
+
+definition
+  "defl (t::'a upper_pd itself) = upper_defl\<cdot>DEFL('a)"
+
+definition
+  "(liftemb :: 'a upper_pd u \<rightarrow> udom) = udom_emb u_approx oo u_map\<cdot>emb"
+
+definition
+  "(liftprj :: udom \<rightarrow> 'a upper_pd u) = u_map\<cdot>prj oo udom_prj u_approx"
+
+definition
+  "liftdefl (t::'a upper_pd itself) = u_defl\<cdot>DEFL('a upper_pd)"
+
+instance
+using liftemb_upper_pd_def liftprj_upper_pd_def liftdefl_upper_pd_def
+proof (rule liftdomain_class_intro)
+  show "ep_pair emb (prj :: udom \<rightarrow> 'a upper_pd)"
+    unfolding emb_upper_pd_def prj_upper_pd_def
+    using ep_pair_udom [OF upper_approx]
+    by (intro ep_pair_comp ep_pair_upper_map ep_pair_emb_prj)
+next
+  show "cast\<cdot>DEFL('a upper_pd) = emb oo (prj :: udom \<rightarrow> 'a upper_pd)"
+    unfolding emb_upper_pd_def prj_upper_pd_def defl_upper_pd_def cast_upper_defl
+    by (simp add: cast_DEFL oo_def cfun_eq_iff upper_map_map)
+qed
+
+end
+
+lemma DEFL_upper: "DEFL('a upper_pd) = upper_defl\<cdot>DEFL('a)"
+by (rule defl_upper_pd_def)
+
+
+subsection {* Join *}
+
+definition
+  upper_join :: "'a upper_pd upper_pd \<rightarrow> 'a upper_pd" where
+  "upper_join = (\<Lambda> xss. upper_bind\<cdot>xss\<cdot>(\<Lambda> xs. xs))"
+
+lemma upper_join_unit [simp]:
+  "upper_join\<cdot>{xs}\<sharp> = xs"
+unfolding upper_join_def by simp
+
+lemma upper_join_plus [simp]:
+  "upper_join\<cdot>(xss +\<sharp> yss) = upper_join\<cdot>xss +\<sharp> upper_join\<cdot>yss"
+unfolding upper_join_def by simp
+
+lemma upper_join_bottom [simp]: "upper_join\<cdot>\<bottom> = \<bottom>"
+unfolding upper_join_def by simp
+
+lemma upper_join_map_unit:
+  "upper_join\<cdot>(upper_map\<cdot>upper_unit\<cdot>xs) = xs"
+by (induct xs rule: upper_pd_induct, simp_all)
+
+lemma upper_join_map_join:
+  "upper_join\<cdot>(upper_map\<cdot>upper_join\<cdot>xsss) = upper_join\<cdot>(upper_join\<cdot>xsss)"
+by (induct xsss rule: upper_pd_induct, simp_all)
+
+lemma upper_join_map_map:
+  "upper_join\<cdot>(upper_map\<cdot>(upper_map\<cdot>f)\<cdot>xss) =
+   upper_map\<cdot>f\<cdot>(upper_join\<cdot>xss)"
+by (induct xss rule: upper_pd_induct, simp_all)
+
+end

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/HOLCF/document/root.tex	Sat Nov 27 16:08:10 2010 -0800
@@ -0,0 +1,35 @@
+
+% HOLCF/document/root.tex
+
+\documentclass[11pt,a4paper]{article}
+\usepackage{graphicx,isabelle,isabellesym,latexsym}
+\usepackage[only,bigsqcap]{stmaryrd}
+\usepackage[latin1]{inputenc}
+\usepackage{pdfsetup}
+
+\urlstyle{rm}
+\isabellestyle{it}
+\pagestyle{myheadings}
+\newcommand{\isasymas}{\textsf{as}}
+\newcommand{\isasymlazy}{\isamath{\sim}}
+
+\begin{document}
+
+\title{Isabelle/HOLCF --- Higher-Order Logic of Computable Functions}
+\maketitle
+
+\tableofcontents
+
+\begin{center}
+  \includegraphics[scale=0.45]{session_graph}
+\end{center}
+
+\newpage
+
+\renewcommand{\isamarkupheader}[1]%
+{\section{\isabellecontext: #1}\markright{THEORY~``\isabellecontext''}}
+
+\parindent 0pt\parskip 0.5ex
+\input{session}
+
+\end{document}

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/HOLCF/ex/Dagstuhl.thy	Sat Nov 27 16:08:10 2010 -0800
@@ -0,0 +1,92 @@
+theory Dagstuhl
+imports Stream
+begin
+
+axiomatization
+  y  :: "'a"
+
+definition
+  YS :: "'a stream" where
+  "YS = fix$(LAM x. y && x)"
+
+definition
+  YYS :: "'a stream" where
+  "YYS = fix$(LAM z. y && y && z)"
+
+lemma YS_def2: "YS = y && YS"
+  apply (rule trans)
+  apply (rule fix_eq2)
+  apply (rule YS_def [THEN eq_reflection])
+  apply (rule beta_cfun)
+  apply simp
+  done
+
+lemma YYS_def2: "YYS = y && y && YYS"
+  apply (rule trans)
+  apply (rule fix_eq2)
+  apply (rule YYS_def [THEN eq_reflection])
+  apply (rule beta_cfun)
+  apply simp
+  done
+
+
+lemma lemma3: "YYS << y && YYS"
+  apply (rule YYS_def [THEN eq_reflection, THEN def_fix_ind])
+  apply simp_all
+  apply (rule monofun_cfun_arg)
+  apply (rule monofun_cfun_arg)
+  apply assumption
+  done
+
+lemma lemma4: "y && YYS << YYS"
+  apply (subst YYS_def2)
+  back
+  apply (rule monofun_cfun_arg)
+  apply (rule lemma3)
+  done
+
+lemma lemma5: "y && YYS = YYS"
+  apply (rule below_antisym)
+  apply (rule lemma4)
+  apply (rule lemma3)
+  done
+
+lemma wir_moel: "YS = YYS"
+  apply (rule stream.take_lemma)
+  apply (induct_tac n)
+  apply (simp (no_asm))
+  apply (subst YS_def2)
+  apply (subst YYS_def2)
+  apply simp
+  apply (rule lemma5 [symmetric, THEN subst])
+  apply (rule refl)
+  done
+
+(* ------------------------------------------------------------------------ *)
+(* Zweite L"osung: Bernhard Möller                                          *)
+(* statt Beweis von  wir_moel "uber take_lemma beidseitige Inclusion        *)
+(* verwendet lemma5                                                         *)
+(* ------------------------------------------------------------------------ *)
+
+lemma lemma6: "YYS << YS"
+  apply (unfold YYS_def)
+  apply (rule fix_least)
+  apply (subst beta_cfun)
+  apply simp
+  apply (simp add: YS_def2 [symmetric])
+  done
+
+lemma lemma7: "YS << YYS"
+  apply (rule YS_def [THEN eq_reflection, THEN def_fix_ind])
+  apply simp_all
+  apply (subst lemma5 [symmetric])
+  apply (erule monofun_cfun_arg)
+  done
+
+lemma wir_moel': "YS = YYS"
+  apply (rule below_antisym)
+  apply (rule lemma7)
+  apply (rule lemma6)
+  done
+
+end

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/HOLCF/ex/Dnat.thy	Sat Nov 27 16:08:10 2010 -0800
@@ -0,0 +1,72 @@
+(*  Title:      HOLCF/Dnat.thy
+    Author:     Franz Regensburger
+
+Theory for the domain of natural numbers  dnat = one ++ dnat
+*)
+
+theory Dnat
+imports HOLCF
+begin
+
+domain dnat = dzero | dsucc (dpred :: dnat)
+
+definition
+  iterator :: "dnat -> ('a -> 'a) -> 'a -> 'a" where
+  "iterator = fix $ (LAM h n f x.
+    case n of dzero => x
+      | dsucc $ m => f $ (h $ m $ f $ x))"
+
+text {*
+  \medskip Expand fixed point properties.
+*}
+
+lemma iterator_def2:
+  "iterator = (LAM n f x. case n of dzero => x | dsucc$m => f$(iterator$m$f$x))"
+  apply (rule trans)
+  apply (rule fix_eq2)
+  apply (rule iterator_def [THEN eq_reflection])
+  apply (rule beta_cfun)
+  apply simp
+  done
+
+text {* \medskip Recursive properties. *}
+
+lemma iterator1: "iterator $ UU $ f $ x = UU"
+  apply (subst iterator_def2)
+  apply simp
+  done
+
+lemma iterator2: "iterator $ dzero $ f $ x = x"
+  apply (subst iterator_def2)
+  apply simp
+  done
+
+lemma iterator3: "n ~= UU ==> iterator $ (dsucc $ n) $ f $ x = f $ (iterator $ n $ f $ x)"
+  apply (rule trans)
+   apply (subst iterator_def2)
+   apply simp
+  apply (rule refl)
+  done
+
+lemmas iterator_rews = iterator1 iterator2 iterator3
+
+lemma dnat_flat: "ALL x y::dnat. x<<y --> x=UU | x=y"
+  apply (rule allI)
+  apply (induct_tac x)
+    apply fast
+   apply (rule allI)
+   apply (case_tac y)
+     apply simp
+    apply simp
+   apply simp
+  apply (rule allI)
+  apply (case_tac y)
+    apply (fast intro!: UU_I)
+   apply (thin_tac "ALL y. dnat << y --> dnat = UU | dnat = y")
+   apply simp
+  apply (simp (no_asm_simp))
+  apply (drule_tac x="dnata" in spec)
+  apply simp
+  done
+
+end

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/HOLCF/ex/Domain_Proofs.thy	Sat Nov 27 16:08:10 2010 -0800
@@ -0,0 +1,501 @@
+(*  Title:      HOLCF/ex/Domain_Proofs.thy
+    Author:     Brian Huffman
+*)
+
+header {* Internal domain package proofs done manually *}
+
+theory Domain_Proofs
+imports HOLCF
+begin
+
+(*
+
+The definitions and proofs below are for the following recursive
+datatypes:
+
+domain 'a foo = Foo1 | Foo2 (lazy 'a) (lazy "'a bar")
+   and 'a bar = Bar (lazy "'a baz \<rightarrow> tr")
+   and 'a baz = Baz (lazy "'a foo convex_pd \<rightarrow> tr")
+
+TODO: add another type parameter that is strict,
+to show the different handling of LIFTDEFL vs. DEFL.
+
+*)
+
+(********************************************************************)
+
+subsection {* Step 1: Define the new type combinators *}
+
+text {* Start with the one-step non-recursive version *}
+
+definition
+  foo_bar_baz_deflF ::
+    "defl \<rightarrow> defl \<times> defl \<times> defl \<rightarrow> defl \<times> defl \<times> defl"
+where
+  "foo_bar_baz_deflF = (\<Lambda> a. Abs_cfun (\<lambda>(t1, t2, t3). 
+    ( ssum_defl\<cdot>DEFL(one)\<cdot>(sprod_defl\<cdot>a\<cdot>(u_defl\<cdot>t2))
+    , u_defl\<cdot>(sfun_defl\<cdot>(u_defl\<cdot>t3)\<cdot>DEFL(tr))
+    , u_defl\<cdot>(sfun_defl\<cdot>(u_defl\<cdot>(convex_defl\<cdot>t1))\<cdot>DEFL(tr)))))"
+
+lemma foo_bar_baz_deflF_beta:
+  "foo_bar_baz_deflF\<cdot>a\<cdot>t =
+    ( ssum_defl\<cdot>DEFL(one)\<cdot>(sprod_defl\<cdot>a\<cdot>(u_defl\<cdot>(fst (snd t))))
+    , u_defl\<cdot>(sfun_defl\<cdot>(u_defl\<cdot>(snd (snd t)))\<cdot>DEFL(tr))
+    , u_defl\<cdot>(sfun_defl\<cdot>(u_defl\<cdot>(convex_defl\<cdot>(fst t)))\<cdot>DEFL(tr)))"
+unfolding foo_bar_baz_deflF_def
+by (simp add: split_def)
+
+text {* Individual type combinators are projected from the fixed point. *}
+
+definition foo_defl :: "defl \<rightarrow> defl"
+where "foo_defl = (\<Lambda> a. fst (fix\<cdot>(foo_bar_baz_deflF\<cdot>a)))"
+
+definition bar_defl :: "defl \<rightarrow> defl"
+where "bar_defl = (\<Lambda> a. fst (snd (fix\<cdot>(foo_bar_baz_deflF\<cdot>a))))"
+
+definition baz_defl :: "defl \<rightarrow> defl"
+where "baz_defl = (\<Lambda> a. snd (snd (fix\<cdot>(foo_bar_baz_deflF\<cdot>a))))"
+
+lemma defl_apply_thms:
+  "foo_defl\<cdot>a = fst (fix\<cdot>(foo_bar_baz_deflF\<cdot>a))"
+  "bar_defl\<cdot>a = fst (snd (fix\<cdot>(foo_bar_baz_deflF\<cdot>a)))"
+  "baz_defl\<cdot>a = snd (snd (fix\<cdot>(foo_bar_baz_deflF\<cdot>a)))"
+unfolding foo_defl_def bar_defl_def baz_defl_def by simp_all
+
+text {* Unfold rules for each combinator. *}
+
+lemma foo_defl_unfold:
+  "foo_defl\<cdot>a = ssum_defl\<cdot>DEFL(one)\<cdot>(sprod_defl\<cdot>a\<cdot>(u_defl\<cdot>(bar_defl\<cdot>a)))"
+unfolding defl_apply_thms by (subst fix_eq, simp add: foo_bar_baz_deflF_beta)
+
+lemma bar_defl_unfold: "bar_defl\<cdot>a = u_defl\<cdot>(sfun_defl\<cdot>(u_defl\<cdot>(baz_defl\<cdot>a))\<cdot>DEFL(tr))"
+unfolding defl_apply_thms by (subst fix_eq, simp add: foo_bar_baz_deflF_beta)
+
+lemma baz_defl_unfold: "baz_defl\<cdot>a = u_defl\<cdot>(sfun_defl\<cdot>(u_defl\<cdot>(convex_defl\<cdot>(foo_defl\<cdot>a)))\<cdot>DEFL(tr))"
+unfolding defl_apply_thms by (subst fix_eq, simp add: foo_bar_baz_deflF_beta)
+
+text "The automation for the previous steps will be quite similar to
+how the fixrec package works."
+
+(********************************************************************)
+
+subsection {* Step 2: Define types, prove class instances *}
+
+text {* Use @{text pcpodef} with the appropriate type combinator. *}
+
+pcpodef (open) 'a foo = "defl_set (foo_defl\<cdot>LIFTDEFL('a))"
+by (rule defl_set_bottom, rule adm_defl_set)
+
+pcpodef (open) 'a bar = "defl_set (bar_defl\<cdot>LIFTDEFL('a))"
+by (rule defl_set_bottom, rule adm_defl_set)
+
+pcpodef (open) 'a baz = "defl_set (baz_defl\<cdot>LIFTDEFL('a))"
+by (rule defl_set_bottom, rule adm_defl_set)
+
+text {* Prove rep instance using lemma @{text typedef_rep_class}. *}
+
+instantiation foo :: ("domain") liftdomain
+begin
+
+definition emb_foo :: "'a foo \<rightarrow> udom"
+where "emb_foo \<equiv> (\<Lambda> x. Rep_foo x)"
+
+definition prj_foo :: "udom \<rightarrow> 'a foo"
+where "prj_foo \<equiv> (\<Lambda> y. Abs_foo (cast\<cdot>(foo_defl\<cdot>LIFTDEFL('a))\<cdot>y))"
+
+definition defl_foo :: "'a foo itself \<Rightarrow> defl"
+where "defl_foo \<equiv> \<lambda>a. foo_defl\<cdot>LIFTDEFL('a)"
+
+definition
+  "(liftemb :: 'a foo u \<rightarrow> udom) \<equiv> udom_emb u_approx oo u_map\<cdot>emb"
+
+definition
+  "(liftprj :: udom \<rightarrow> 'a foo u) \<equiv> u_map\<cdot>prj oo udom_prj u_approx"
+
+definition
+  "liftdefl \<equiv> \<lambda>(t::'a foo itself). u_defl\<cdot>DEFL('a foo)"
+
+instance
+apply (rule typedef_liftdomain_class)
+apply (rule type_definition_foo)
+apply (rule below_foo_def)
+apply (rule emb_foo_def)
+apply (rule prj_foo_def)
+apply (rule defl_foo_def)
+apply (rule liftemb_foo_def)
+apply (rule liftprj_foo_def)
+apply (rule liftdefl_foo_def)
+done
+
+end
+
+instantiation bar :: ("domain") liftdomain
+begin
+
+definition emb_bar :: "'a bar \<rightarrow> udom"
+where "emb_bar \<equiv> (\<Lambda> x. Rep_bar x)"
+
+definition prj_bar :: "udom \<rightarrow> 'a bar"
+where "prj_bar \<equiv> (\<Lambda> y. Abs_bar (cast\<cdot>(bar_defl\<cdot>LIFTDEFL('a))\<cdot>y))"
+
+definition defl_bar :: "'a bar itself \<Rightarrow> defl"
+where "defl_bar \<equiv> \<lambda>a. bar_defl\<cdot>LIFTDEFL('a)"
+
+definition
+  "(liftemb :: 'a bar u \<rightarrow> udom) \<equiv> udom_emb u_approx oo u_map\<cdot>emb"
+
+definition
+  "(liftprj :: udom \<rightarrow> 'a bar u) \<equiv> u_map\<cdot>prj oo udom_prj u_approx"
+
+definition
+  "liftdefl \<equiv> \<lambda>(t::'a bar itself). u_defl\<cdot>DEFL('a bar)"
+
+instance
+apply (rule typedef_liftdomain_class)
+apply (rule type_definition_bar)
+apply (rule below_bar_def)
+apply (rule emb_bar_def)
+apply (rule prj_bar_def)
+apply (rule defl_bar_def)
+apply (rule liftemb_bar_def)
+apply (rule liftprj_bar_def)
+apply (rule liftdefl_bar_def)
+done
+
+end
+
+instantiation baz :: ("domain") liftdomain
+begin
+
+definition emb_baz :: "'a baz \<rightarrow> udom"
+where "emb_baz \<equiv> (\<Lambda> x. Rep_baz x)"
+
+definition prj_baz :: "udom \<rightarrow> 'a baz"
+where "prj_baz \<equiv> (\<Lambda> y. Abs_baz (cast\<cdot>(baz_defl\<cdot>LIFTDEFL('a))\<cdot>y))"
+
+definition defl_baz :: "'a baz itself \<Rightarrow> defl"
+where "defl_baz \<equiv> \<lambda>a. baz_defl\<cdot>LIFTDEFL('a)"
+
+definition
+  "(liftemb :: 'a baz u \<rightarrow> udom) \<equiv> udom_emb u_approx oo u_map\<cdot>emb"
+
+definition
+  "(liftprj :: udom \<rightarrow> 'a baz u) \<equiv> u_map\<cdot>prj oo udom_prj u_approx"
+
+definition
+  "liftdefl \<equiv> \<lambda>(t::'a baz itself). u_defl\<cdot>DEFL('a baz)"
+
+instance
+apply (rule typedef_liftdomain_class)
+apply (rule type_definition_baz)
+apply (rule below_baz_def)
+apply (rule emb_baz_def)
+apply (rule prj_baz_def)
+apply (rule defl_baz_def)
+apply (rule liftemb_baz_def)
+apply (rule liftprj_baz_def)
+apply (rule liftdefl_baz_def)
+done
+
+end
+
+text {* Prove DEFL rules using lemma @{text typedef_DEFL}. *}
+
+lemma DEFL_foo: "DEFL('a foo) = foo_defl\<cdot>LIFTDEFL('a)"
+apply (rule typedef_DEFL)
+apply (rule defl_foo_def)
+done
+
+lemma DEFL_bar: "DEFL('a bar) = bar_defl\<cdot>LIFTDEFL('a)"
+apply (rule typedef_DEFL)
+apply (rule defl_bar_def)
+done
+
+lemma DEFL_baz: "DEFL('a baz) = baz_defl\<cdot>LIFTDEFL('a)"
+apply (rule typedef_DEFL)
+apply (rule defl_baz_def)
+done
+
+text {* Prove DEFL equations using type combinator unfold lemmas. *}
+
+lemma DEFL_foo': "DEFL('a foo) = DEFL(one \<oplus> 'a\<^sub>\<bottom> \<otimes> ('a bar)\<^sub>\<bottom>)"
+unfolding DEFL_foo DEFL_bar DEFL_baz domain_defl_simps
+by (rule foo_defl_unfold)
+
+lemma DEFL_bar': "DEFL('a bar) = DEFL(('a baz \<rightarrow> tr)\<^sub>\<bottom>)"
+unfolding DEFL_foo DEFL_bar DEFL_baz domain_defl_simps
+by (rule bar_defl_unfold)
+
+lemma DEFL_baz': "DEFL('a baz) = DEFL(('a foo convex_pd \<rightarrow> tr)\<^sub>\<bottom>)"
+unfolding DEFL_foo DEFL_bar DEFL_baz domain_defl_simps
+by (rule baz_defl_unfold)
+
+(********************************************************************)
+
+subsection {* Step 3: Define rep and abs functions *}
+
+text {* Define them all using @{text prj} and @{text emb}! *}
+
+definition foo_rep :: "'a foo \<rightarrow> one \<oplus> ('a\<^sub>\<bottom> \<otimes> ('a bar)\<^sub>\<bottom>)"
+where "foo_rep \<equiv> prj oo emb"
+
+definition foo_abs :: "one \<oplus> ('a\<^sub>\<bottom> \<otimes> ('a bar)\<^sub>\<bottom>) \<rightarrow> 'a foo"
+where "foo_abs \<equiv> prj oo emb"
+
+definition bar_rep :: "'a bar \<rightarrow> ('a baz \<rightarrow> tr)\<^sub>\<bottom>"
+where "bar_rep \<equiv> prj oo emb"
+
+definition bar_abs :: "('a baz \<rightarrow> tr)\<^sub>\<bottom> \<rightarrow> 'a bar"
+where "bar_abs \<equiv> prj oo emb"
+
+definition baz_rep :: "'a baz \<rightarrow> ('a foo convex_pd \<rightarrow> tr)\<^sub>\<bottom>"
+where "baz_rep \<equiv> prj oo emb"
+
+definition baz_abs :: "('a foo convex_pd \<rightarrow> tr)\<^sub>\<bottom> \<rightarrow> 'a baz"
+where "baz_abs \<equiv> prj oo emb"
+
+text {* Prove isomorphism rules. *}
+
+lemma foo_abs_iso: "foo_rep\<cdot>(foo_abs\<cdot>x) = x"
+by (rule domain_abs_iso [OF DEFL_foo' foo_abs_def foo_rep_def])
+
+lemma foo_rep_iso: "foo_abs\<cdot>(foo_rep\<cdot>x) = x"
+by (rule domain_rep_iso [OF DEFL_foo' foo_abs_def foo_rep_def])
+
+lemma bar_abs_iso: "bar_rep\<cdot>(bar_abs\<cdot>x) = x"
+by (rule domain_abs_iso [OF DEFL_bar' bar_abs_def bar_rep_def])
+
+lemma bar_rep_iso: "bar_abs\<cdot>(bar_rep\<cdot>x) = x"
+by (rule domain_rep_iso [OF DEFL_bar' bar_abs_def bar_rep_def])
+
+lemma baz_abs_iso: "baz_rep\<cdot>(baz_abs\<cdot>x) = x"
+by (rule domain_abs_iso [OF DEFL_baz' baz_abs_def baz_rep_def])
+
+lemma baz_rep_iso: "baz_abs\<cdot>(baz_rep\<cdot>x) = x"
+by (rule domain_rep_iso [OF DEFL_baz' baz_abs_def baz_rep_def])
+
+text {* Prove isodefl rules using @{text isodefl_coerce}. *}
+
+lemma isodefl_foo_abs:
+  "isodefl d t \<Longrightarrow> isodefl (foo_abs oo d oo foo_rep) t"
+by (rule isodefl_abs_rep [OF DEFL_foo' foo_abs_def foo_rep_def])
+
+lemma isodefl_bar_abs:
+  "isodefl d t \<Longrightarrow> isodefl (bar_abs oo d oo bar_rep) t"
+by (rule isodefl_abs_rep [OF DEFL_bar' bar_abs_def bar_rep_def])
+
+lemma isodefl_baz_abs:
+  "isodefl d t \<Longrightarrow> isodefl (baz_abs oo d oo baz_rep) t"
+by (rule isodefl_abs_rep [OF DEFL_baz' baz_abs_def baz_rep_def])
+
+(********************************************************************)
+
+subsection {* Step 4: Define map functions, prove isodefl property *}
+
+text {* Start with the one-step non-recursive version. *}
+
+text {* Note that the type of the map function depends on which
+variables are used in positive and negative positions. *}
+
+definition
+  foo_bar_baz_mapF ::
+    "('a \<rightarrow> 'b) \<rightarrow>
+     ('a foo \<rightarrow> 'b foo) \<times> ('a bar \<rightarrow> 'b bar) \<times> ('b baz \<rightarrow> 'a baz) \<rightarrow>
+     ('a foo \<rightarrow> 'b foo) \<times> ('a bar \<rightarrow> 'b bar) \<times> ('b baz \<rightarrow> 'a baz)"
+where
+  "foo_bar_baz_mapF = (\<Lambda> f. Abs_cfun (\<lambda>(d1, d2, d3).
+    (
+      foo_abs oo
+        ssum_map\<cdot>ID\<cdot>(sprod_map\<cdot>(u_map\<cdot>f)\<cdot>(u_map\<cdot>d2))
+          oo foo_rep
+    ,
+      bar_abs oo u_map\<cdot>(cfun_map\<cdot>d3\<cdot>ID) oo bar_rep
+    ,
+      baz_abs oo u_map\<cdot>(cfun_map\<cdot>(convex_map\<cdot>d1)\<cdot>ID) oo baz_rep
+    )))"
+
+lemma foo_bar_baz_mapF_beta:
+  "foo_bar_baz_mapF\<cdot>f\<cdot>d =
+    (
+      foo_abs oo
+        ssum_map\<cdot>ID\<cdot>(sprod_map\<cdot>(u_map\<cdot>f)\<cdot>(u_map\<cdot>(fst (snd d))))
+          oo foo_rep
+    ,
+      bar_abs oo u_map\<cdot>(cfun_map\<cdot>(snd (snd d))\<cdot>ID) oo bar_rep
+    ,
+      baz_abs oo u_map\<cdot>(cfun_map\<cdot>(convex_map\<cdot>(fst d))\<cdot>ID) oo baz_rep
+    )"
+unfolding foo_bar_baz_mapF_def
+by (simp add: split_def)
+
+text {* Individual map functions are projected from the fixed point. *}
+
+definition foo_map :: "('a \<rightarrow> 'b) \<rightarrow> ('a foo \<rightarrow> 'b foo)"
+where "foo_map = (\<Lambda> f. fst (fix\<cdot>(foo_bar_baz_mapF\<cdot>f)))"
+
+definition bar_map :: "('a \<rightarrow> 'b) \<rightarrow> ('a bar \<rightarrow> 'b bar)"
+where "bar_map = (\<Lambda> f. fst (snd (fix\<cdot>(foo_bar_baz_mapF\<cdot>f))))"
+
+definition baz_map :: "('a \<rightarrow> 'b) \<rightarrow> ('b baz \<rightarrow> 'a baz)"
+where "baz_map = (\<Lambda> f. snd (snd (fix\<cdot>(foo_bar_baz_mapF\<cdot>f))))"
+
+lemma map_apply_thms:
+  "foo_map\<cdot>f = fst (fix\<cdot>(foo_bar_baz_mapF\<cdot>f))"
+  "bar_map\<cdot>f = fst (snd (fix\<cdot>(foo_bar_baz_mapF\<cdot>f)))"
+  "baz_map\<cdot>f = snd (snd (fix\<cdot>(foo_bar_baz_mapF\<cdot>f)))"
+unfolding foo_map_def bar_map_def baz_map_def by simp_all
+
+text {* Prove isodefl rules for all map functions simultaneously. *}
+
+lemma isodefl_foo_bar_baz:
+  assumes isodefl_d: "isodefl (u_map\<cdot>d) t"
+  shows
+  "isodefl (foo_map\<cdot>d) (foo_defl\<cdot>t) \<and>
+  isodefl (bar_map\<cdot>d) (bar_defl\<cdot>t) \<and>
+  isodefl (baz_map\<cdot>d) (baz_defl\<cdot>t)"
+unfolding map_apply_thms defl_apply_thms
+ apply (rule parallel_fix_ind)
+   apply (intro adm_conj adm_isodefl cont2cont_fst cont2cont_snd cont_id)
+  apply (simp only: fst_strict snd_strict isodefl_bottom simp_thms)
+ apply (simp only: foo_bar_baz_mapF_beta
+                   foo_bar_baz_deflF_beta
+                   fst_conv snd_conv)
+ apply (elim conjE)
+ apply (intro
+  conjI
+  isodefl_foo_abs
+  isodefl_bar_abs
+  isodefl_baz_abs
+  domain_isodefl
+  isodefl_ID_DEFL isodefl_LIFTDEFL
+  isodefl_d
+ )
+ apply assumption+
+done
+
+lemmas isodefl_foo = isodefl_foo_bar_baz [THEN conjunct1]
+lemmas isodefl_bar = isodefl_foo_bar_baz [THEN conjunct2, THEN conjunct1]
+lemmas isodefl_baz = isodefl_foo_bar_baz [THEN conjunct2, THEN conjunct2]
+
+text {* Prove map ID lemmas, using isodefl_DEFL_imp_ID *}
+
+lemma foo_map_ID: "foo_map\<cdot>ID = ID"
+apply (rule isodefl_DEFL_imp_ID)
+apply (subst DEFL_foo)
+apply (rule isodefl_foo)
+apply (rule isodefl_LIFTDEFL)
+done
+
+lemma bar_map_ID: "bar_map\<cdot>ID = ID"
+apply (rule isodefl_DEFL_imp_ID)
+apply (subst DEFL_bar)
+apply (rule isodefl_bar)
+apply (rule isodefl_LIFTDEFL)
+done
+
+lemma baz_map_ID: "baz_map\<cdot>ID = ID"
+apply (rule isodefl_DEFL_imp_ID)
+apply (subst DEFL_baz)
+apply (rule isodefl_baz)
+apply (rule isodefl_LIFTDEFL)
+done
+
+(********************************************************************)
+
+subsection {* Step 5: Define take functions, prove lub-take lemmas *}
+
+definition
+  foo_bar_baz_takeF ::
+    "('a foo \<rightarrow> 'a foo) \<times> ('a bar \<rightarrow> 'a bar) \<times> ('a baz \<rightarrow> 'a baz) \<rightarrow>
+     ('a foo \<rightarrow> 'a foo) \<times> ('a bar \<rightarrow> 'a bar) \<times> ('a baz \<rightarrow> 'a baz)"
+where
+  "foo_bar_baz_takeF = (\<Lambda> p.
+    ( foo_abs oo
+        ssum_map\<cdot>ID\<cdot>(sprod_map\<cdot>(u_map\<cdot>ID)\<cdot>(u_map\<cdot>(fst (snd p))))
+          oo foo_rep
+    , bar_abs oo
+        u_map\<cdot>(cfun_map\<cdot>(snd (snd p))\<cdot>ID) oo bar_rep
+    , baz_abs oo
+        u_map\<cdot>(cfun_map\<cdot>(convex_map\<cdot>(fst p))\<cdot>ID) oo baz_rep
+    ))"
+
+lemma foo_bar_baz_takeF_beta:
+  "foo_bar_baz_takeF\<cdot>p =
+    ( foo_abs oo
+        ssum_map\<cdot>ID\<cdot>(sprod_map\<cdot>(u_map\<cdot>ID)\<cdot>(u_map\<cdot>(fst (snd p))))
+          oo foo_rep
+    , bar_abs oo
+        u_map\<cdot>(cfun_map\<cdot>(snd (snd p))\<cdot>ID) oo bar_rep
+    , baz_abs oo
+        u_map\<cdot>(cfun_map\<cdot>(convex_map\<cdot>(fst p))\<cdot>ID) oo baz_rep
+    )"
+unfolding foo_bar_baz_takeF_def by (rule beta_cfun, simp)
+
+definition
+  foo_take :: "nat \<Rightarrow> 'a foo \<rightarrow> 'a foo"
+where
+  "foo_take = (\<lambda>n. fst (iterate n\<cdot>foo_bar_baz_takeF\<cdot>\<bottom>))"
+
+definition
+  bar_take :: "nat \<Rightarrow> 'a bar \<rightarrow> 'a bar"
+where
+  "bar_take = (\<lambda>n. fst (snd (iterate n\<cdot>foo_bar_baz_takeF\<cdot>\<bottom>)))"
+
+definition
+  baz_take :: "nat \<Rightarrow> 'a baz \<rightarrow> 'a baz"
+where
+  "baz_take = (\<lambda>n. snd (snd (iterate n\<cdot>foo_bar_baz_takeF\<cdot>\<bottom>)))"
+
+lemma chain_take_thms: "chain foo_take" "chain bar_take" "chain baz_take"
+unfolding foo_take_def bar_take_def baz_take_def
+by (intro ch2ch_fst ch2ch_snd chain_iterate)+
+
+lemma take_0_thms: "foo_take 0 = \<bottom>" "bar_take 0 = \<bottom>" "baz_take 0 = \<bottom>"
+unfolding foo_take_def bar_take_def baz_take_def
+by (simp only: iterate_0 fst_strict snd_strict)+
+
+lemma take_Suc_thms:
+  "foo_take (Suc n) =
+    foo_abs oo ssum_map\<cdot>ID\<cdot>(sprod_map\<cdot>(u_map\<cdot>ID)\<cdot>(u_map\<cdot>(bar_take n))) oo foo_rep"
+  "bar_take (Suc n) =
+    bar_abs oo u_map\<cdot>(cfun_map\<cdot>(baz_take n)\<cdot>ID) oo bar_rep"
+  "baz_take (Suc n) =
+    baz_abs oo u_map\<cdot>(cfun_map\<cdot>(convex_map\<cdot>(foo_take n))\<cdot>ID) oo baz_rep"
+unfolding foo_take_def bar_take_def baz_take_def
+by (simp only: iterate_Suc foo_bar_baz_takeF_beta fst_conv snd_conv)+
+
+lemma lub_take_lemma:
+  "(\<Squnion>n. foo_take n, \<Squnion>n. bar_take n, \<Squnion>n. baz_take n)
+    = (foo_map\<cdot>(ID::'a \<rightarrow> 'a), bar_map\<cdot>(ID::'a \<rightarrow> 'a), baz_map\<cdot>(ID::'a \<rightarrow> 'a))"
+apply (simp only: lub_Pair [symmetric] ch2ch_Pair chain_take_thms)
+apply (simp only: map_apply_thms pair_collapse)
+apply (simp only: fix_def2)
+apply (rule lub_eq)
+apply (rule nat.induct)
+apply (simp only: iterate_0 Pair_strict take_0_thms)
+apply (simp only: iterate_Suc Pair_fst_snd_eq fst_conv snd_conv
+                  foo_bar_baz_mapF_beta take_Suc_thms simp_thms)
+done
+
+lemma lub_foo_take: "(\<Squnion>n. foo_take n) = ID"
+apply (rule trans [OF _ foo_map_ID])
+using lub_take_lemma
+apply (elim Pair_inject)
+apply assumption
+done
+
+lemma lub_bar_take: "(\<Squnion>n. bar_take n) = ID"
+apply (rule trans [OF _ bar_map_ID])
+using lub_take_lemma
+apply (elim Pair_inject)
+apply assumption
+done
+
+lemma lub_baz_take: "(\<Squnion>n. baz_take n) = ID"
+apply (rule trans [OF _ baz_map_ID])
+using lub_take_lemma
+apply (elim Pair_inject)
+apply assumption
+done
+
+end

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/HOLCF/ex/Fix2.thy	Sat Nov 27 16:08:10 2010 -0800
@@ -0,0 +1,32 @@
+(*  Title:      HOLCF/ex/Fix2.thy
+    Author:     Franz Regensburger
+
+Show that fix is the unique least fixed-point operator.
+From axioms gix1_def,gix2_def it follows that fix = gix
+*)
+
+theory Fix2
+imports HOLCF
+begin
+
+axiomatization
+  gix :: "('a->'a)->'a" where
+  gix1_def: "F$(gix$F) = gix$F" and
+  gix2_def: "F$y=y ==> gix$F << y"
+
+
+lemma lemma1: "fix = gix"
+apply (rule cfun_eqI)
+apply (rule below_antisym)
+apply (rule fix_least)
+apply (rule gix1_def)
+apply (rule gix2_def)
+apply (rule fix_eq [symmetric])
+done
+
+lemma lemma2: "gix$F=lub(range(%i. iterate i$F$UU))"
+apply (rule lemma1 [THEN subst])
+apply (rule fix_def2)
+done
+
+end

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/HOLCF/ex/Focus_ex.thy	Sat Nov 27 16:08:10 2010 -0800
@@ -0,0 +1,258 @@
+(* Specification of the following loop back device
+
+
+          g
+           --------------------
+          |      -------       |
+       x  |     |       |      |  y
+    ------|---->|       |------| ----->
+          |  z  |   f   | z    |
+          |  -->|       |---   |
+          | |   |       |   |  |
+          | |    -------    |  |
+          | |               |  |
+          |  <--------------   |
+          |                    |
+           --------------------
+
+
+First step: Notation in Agent Network Description Language (ANDL)
+-----------------------------------------------------------------
+
+agent f
+        input  channel i1:'b i2: ('b,'c) tc
+        output channel o1:'c o2: ('b,'c) tc
+is
+        Rf(i1,i2,o1,o2)  (left open in the example)
+end f
+
+agent g
+        input  channel x:'b
+        output channel y:'c
+is network
+        (y,z) = f$(x,z)
+end network
+end g
+
+
+Remark: the type of the feedback depends at most on the types of the input and
+        output of g. (No type miracles inside g)
+
+Second step: Translation of ANDL specification to HOLCF Specification
+---------------------------------------------------------------------
+
+Specification of agent f ist translated to predicate is_f
+
+is_f :: ('b stream * ('b,'c) tc stream ->
+                'c stream * ('b,'c) tc stream) => bool
+
+is_f f  = !i1 i2 o1 o2.
+        f$(i1,i2) = (o1,o2) --> Rf(i1,i2,o1,o2)
+
+Specification of agent g is translated to predicate is_g which uses
+predicate is_net_g
+
+is_net_g :: ('b stream * ('b,'c) tc stream -> 'c stream * ('b,'c) tc stream) =>
+            'b stream => 'c stream => bool
+
+is_net_g f x y =
+        ? z. (y,z) = f$(x,z) &
+        !oy hz. (oy,hz) = f$(x,hz) --> z << hz
+
+
+is_g :: ('b stream -> 'c stream) => bool
+
+is_g g  = ? f. is_f f  & (!x y. g$x = y --> is_net_g f x y
+
+Third step: (show conservativity)
+-----------
+
+Suppose we have a model for the theory TH1 which contains the axiom
+
+        ? f. is_f f
+
+In this case there is also a model for the theory TH2 that enriches TH1 by
+axiom
+
+        ? g. is_g g
+
+The result is proved by showing that there is a definitional extension
+that extends TH1 by a definition of g.
+
+
+We define:
+
+def_g g  =
+         (? f. is_f f  &
+              g = (LAM x. fst (f$(x,fix$(LAM k. snd (f$(x,k)))))) )
+
+Now we prove:
+
+        (? f. is_f f ) --> (? g. is_g g)
+
+using the theorems
+
+loopback_eq)    def_g = is_g                    (real work)
+
+L1)             (? f. is_f f ) --> (? g. def_g g)  (trivial)
+
+*)
+
+theory Focus_ex
+imports Stream
+begin
+
+typedecl ('a, 'b) tc
+arities tc:: (pcpo, pcpo) pcpo
+
+axiomatization
+  Rf :: "('b stream * ('b,'c) tc stream * 'c stream * ('b,'c) tc stream) => bool"
+
+definition
+  is_f :: "('b stream * ('b,'c) tc stream -> 'c stream * ('b,'c) tc stream) => bool" where
+  "is_f f = (!i1 i2 o1 o2. f$(i1,i2) = (o1,o2) --> Rf(i1,i2,o1,o2))"
+
+definition
+  is_net_g :: "('b stream *('b,'c) tc stream -> 'c stream * ('b,'c) tc stream) =>
+    'b stream => 'c stream => bool" where
+  "is_net_g f x y == (? z.
+                        (y,z) = f$(x,z) &
+                        (!oy hz. (oy,hz) = f$(x,hz) --> z << hz))"
+
+definition
+  is_g :: "('b stream -> 'c stream) => bool" where
+  "is_g g  == (? f. is_f f  & (!x y. g$x = y --> is_net_g f x y))"
+
+definition
+  def_g :: "('b stream -> 'c stream) => bool" where
+  "def_g g == (? f. is_f f  & g = (LAM x. fst (f$(x,fix$(LAM  k. snd (f$(x,k)))))))"
+
+
+(* first some logical trading *)
+
+lemma lemma1:
+"is_g(g) =
+  (? f. is_f(f) &  (!x.(? z. (g$x,z) = f$(x,z) &
+                   (! w y. (y,w) = f$(x,w)  --> z << w))))"
+apply (simp add: is_g_def is_net_g_def)
+apply fast
+done
+
+lemma lemma2:
+"(? f. is_f(f) &  (!x. (? z. (g$x,z) = f$(x,z) &
+                  (!w y. (y,w) = f$(x,w)  --> z << w))))
+  =
+  (? f. is_f(f) &  (!x. ? z.
+        g$x = fst (f$(x,z)) &
+          z = snd (f$(x,z)) &
+        (! w y.  (y,w) = f$(x,w) --> z << w)))"
+apply (rule iffI)
+apply (erule exE)
+apply (rule_tac x = "f" in exI)
+apply (erule conjE)+
+apply (erule conjI)
+apply (intro strip)
+apply (erule allE)
+apply (erule exE)
+apply (rule_tac x = "z" in exI)
+apply (erule conjE)+
+apply (rule conjI)
+apply (rule_tac [2] conjI)
+prefer 3 apply (assumption)
+apply (drule sym)
+apply (simp)
+apply (drule sym)
+apply (simp)
+apply (erule exE)
+apply (rule_tac x = "f" in exI)
+apply (erule conjE)+
+apply (erule conjI)
+apply (intro strip)
+apply (erule allE)
+apply (erule exE)
+apply (rule_tac x = "z" in exI)
+apply (erule conjE)+
+apply (rule conjI)
+prefer 2 apply (assumption)
+apply (rule prod_eqI)
+apply simp
+apply simp
+done
+
+lemma lemma3: "def_g(g) --> is_g(g)"
+apply (tactic {* simp_tac (HOL_ss addsimps [@{thm def_g_def}, @{thm lemma1}, @{thm lemma2}]) 1 *})
+apply (rule impI)
+apply (erule exE)
+apply (rule_tac x = "f" in exI)
+apply (erule conjE)+
+apply (erule conjI)
+apply (intro strip)
+apply (rule_tac x = "fix$ (LAM k. snd (f$(x,k)))" in exI)
+apply (rule conjI)
+ apply (simp)
+ apply (rule prod_eqI, simp, simp)
+ apply (rule trans)
+  apply (rule fix_eq)
+ apply (simp (no_asm))
+apply (intro strip)
+apply (rule fix_least)
+apply (simp (no_asm))
+apply (erule exE)
+apply (drule sym)
+back
+apply simp
+done
+
+lemma lemma4: "is_g(g) --> def_g(g)"
+apply (tactic {* simp_tac (HOL_ss delsimps (@{thms HOL.ex_simps} @ @{thms HOL.all_simps})
+  addsimps [@{thm lemma1}, @{thm lemma2}, @{thm def_g_def}]) 1 *})
+apply (rule impI)
+apply (erule exE)
+apply (rule_tac x = "f" in exI)
+apply (erule conjE)+
+apply (erule conjI)
+apply (rule cfun_eqI)
+apply (erule_tac x = "x" in allE)
+apply (erule exE)
+apply (erule conjE)+
+apply (subgoal_tac "fix$ (LAM k. snd (f$(x, k))) = z")
+ apply simp
+apply (subgoal_tac "! w y. f$(x, w) = (y, w) --> z << w")
+apply (rule fix_eqI)
+apply simp
+apply (subgoal_tac "f$(x, za) = (fst (f$(x,za)) ,za)")
+apply fast
+apply (rule prod_eqI, simp, simp)
+apply (intro strip)
+apply (erule allE)+
+apply (erule mp)
+apply (erule sym)
+done
+
+(* now we assemble the result *)
+
+lemma loopback_eq: "def_g = is_g"
+apply (rule ext)
+apply (rule iffI)
+apply (erule lemma3 [THEN mp])
+apply (erule lemma4 [THEN mp])
+done
+
+lemma L2:
+"(? f.
+  is_f(f::'b stream * ('b,'c) tc stream -> 'c stream * ('b,'c) tc stream))
+  -->
+  (? g. def_g(g::'b stream -> 'c stream ))"
+apply (simp add: def_g_def)
+done
+
+theorem conservative_loopback:
+"(? f.
+  is_f(f::'b stream * ('b,'c) tc stream -> 'c stream * ('b,'c) tc stream))
+  -->
+  (? g. is_g(g::'b stream -> 'c stream ))"
+apply (rule loopback_eq [THEN subst])
+apply (rule L2)
+done
+
+end

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/HOLCF/ex/Hoare.thy	Sat Nov 27 16:08:10 2010 -0800
@@ -0,0 +1,425 @@
+(*  Title:      HOLCF/ex/hoare.thy
+    Author:     Franz Regensburger
+
+Theory for an example by C.A.R. Hoare
+
+p x = if b1 x
+         then p (g x)
+         else x fi
+
+q x = if b1 x orelse b2 x
+         then q (g x)
+         else x fi
+
+Prove: for all b1 b2 g .
+            q o p  = q
+
+In order to get a nice notation we fix the functions b1,b2 and g in the
+signature of this example
+
+*)
+
+theory Hoare
+imports HOLCF
+begin
+
+axiomatization
+  b1 :: "'a -> tr" and
+  b2 :: "'a -> tr" and
+  g :: "'a -> 'a"
+
+definition
+  p :: "'a -> 'a" where
+  "p = fix$(LAM f. LAM x. If b1$x then f$(g$x) else x)"
+
+definition
+  q :: "'a -> 'a" where
+  "q = fix$(LAM f. LAM x. If b1$x orelse b2$x then f$(g$x) else x)"
+
+
+(* --------- pure HOLCF logic, some little lemmas ------ *)
+
+lemma hoare_lemma2: "b~=TT ==> b=FF | b=UU"
+apply (rule Exh_tr [THEN disjE])
+apply blast+
+done
+
+lemma hoare_lemma3: " (ALL k. b1$(iterate k$g$x) = TT) | (EX k. b1$(iterate k$g$x)~=TT)"
+apply blast
+done
+
+lemma hoare_lemma4: "(EX k. b1$(iterate k$g$x) ~= TT) ==>  
+  EX k. b1$(iterate k$g$x) = FF | b1$(iterate k$g$x) = UU"
+apply (erule exE)
+apply (rule exI)
+apply (rule hoare_lemma2)
+apply assumption
+done
+
+lemma hoare_lemma5: "[|(EX k. b1$(iterate k$g$x) ~= TT); 
+    k=Least(%n. b1$(iterate n$g$x) ~= TT)|] ==>  
+  b1$(iterate k$g$x)=FF | b1$(iterate k$g$x)=UU"
+apply hypsubst
+apply (rule hoare_lemma2)
+apply (erule exE)
+apply (erule LeastI)
+done
+
+lemma hoare_lemma6: "b=UU ==> b~=TT"
+apply hypsubst
+apply (rule dist_eq_tr)
+done
+
+lemma hoare_lemma7: "b=FF ==> b~=TT"
+apply hypsubst
+apply (rule dist_eq_tr)
+done
+
+lemma hoare_lemma8: "[|(EX k. b1$(iterate k$g$x) ~= TT); 
+    k=Least(%n. b1$(iterate n$g$x) ~= TT)|] ==>  
+  ALL m. m < k --> b1$(iterate m$g$x)=TT"
+apply hypsubst
+apply (erule exE)
+apply (intro strip)
+apply (rule_tac p = "b1$ (iterate m$g$x) " in trE)
+prefer 2 apply (assumption)
+apply (rule le_less_trans [THEN less_irrefl [THEN notE]])
+prefer 2 apply (assumption)
+apply (rule Least_le)
+apply (erule hoare_lemma6)
+apply (rule le_less_trans [THEN less_irrefl [THEN notE]])
+prefer 2 apply (assumption)
+apply (rule Least_le)
+apply (erule hoare_lemma7)
+done
+
+
+lemma hoare_lemma28: "f$(y::'a)=(UU::tr) ==> f$UU = UU"
+by (rule strictI)
+
+
+(* ----- access to definitions ----- *)
+
+lemma p_def3: "p$x = If b1$x then p$(g$x) else x"
+apply (rule trans)
+apply (rule p_def [THEN eq_reflection, THEN fix_eq3])
+apply simp
+done
+
+lemma q_def3: "q$x = If b1$x orelse b2$x then q$(g$x) else x"
+apply (rule trans)
+apply (rule q_def [THEN eq_reflection, THEN fix_eq3])
+apply simp
+done
+
+(** --------- proofs about iterations of p and q ---------- **)
+
+lemma hoare_lemma9: "(ALL m. m< Suc k --> b1$(iterate m$g$x)=TT) --> 
+   p$(iterate k$g$x)=p$x"
+apply (induct_tac k)
+apply (simp (no_asm))
+apply (simp (no_asm))
+apply (intro strip)
+apply (rule_tac s = "p$ (iterate n$g$x) " in trans)
+apply (rule trans)
+apply (rule_tac [2] p_def3 [symmetric])
+apply (rule_tac s = "TT" and t = "b1$ (iterate n$g$x) " in ssubst)
+apply (rule mp)
+apply (erule spec)
+apply (simp (no_asm) add: less_Suc_eq)
+apply simp
+apply (erule mp)
+apply (intro strip)
+apply (rule mp)
+apply (erule spec)
+apply (erule less_trans)
+apply simp
+done
+
+lemma hoare_lemma24: "(ALL m. m< Suc k --> b1$(iterate m$g$x)=TT) -->  
+  q$(iterate k$g$x)=q$x"
+apply (induct_tac k)
+apply (simp (no_asm))
+apply (simp (no_asm) add: less_Suc_eq)
+apply (intro strip)
+apply (rule_tac s = "q$ (iterate n$g$x) " in trans)
+apply (rule trans)
+apply (rule_tac [2] q_def3 [symmetric])
+apply (rule_tac s = "TT" and t = "b1$ (iterate n$g$x) " in ssubst)
+apply blast
+apply simp
+apply (erule mp)
+apply (intro strip)
+apply (fast dest!: less_Suc_eq [THEN iffD1])
+done
+
+(* -------- results about p for case (EX k. b1$(iterate k$g$x)~=TT) ------- *)
+
+thm hoare_lemma8 [THEN hoare_lemma9 [THEN mp], standard]
+
+lemma hoare_lemma10:
+  "EX k. b1$(iterate k$g$x) ~= TT
+    ==> Suc k = (LEAST n. b1$(iterate n$g$x) ~= TT) ==> p$(iterate k$g$x) = p$x"
+  by (rule hoare_lemma8 [THEN hoare_lemma9 [THEN mp]])
+
+lemma hoare_lemma11: "(EX n. b1$(iterate n$g$x) ~= TT) ==> 
+  k=(LEAST n. b1$(iterate n$g$x) ~= TT) & b1$(iterate k$g$x)=FF  
+  --> p$x = iterate k$g$x"
+apply (case_tac "k")
+apply hypsubst
+apply (simp (no_asm))
+apply (intro strip)
+apply (erule conjE)
+apply (rule trans)
+apply (rule p_def3)
+apply simp
+apply hypsubst
+apply (intro strip)
+apply (erule conjE)
+apply (rule trans)
+apply (erule hoare_lemma10 [symmetric])
+apply assumption
+apply (rule trans)
+apply (rule p_def3)
+apply (rule_tac s = "TT" and t = "b1$ (iterate nat$g$x) " in ssubst)
+apply (rule hoare_lemma8 [THEN spec, THEN mp])
+apply assumption
+apply assumption
+apply (simp (no_asm))
+apply (simp (no_asm))
+apply (rule trans)
+apply (rule p_def3)
+apply (simp (no_asm) del: iterate_Suc add: iterate_Suc [symmetric])
+apply (erule_tac s = "FF" in ssubst)
+apply simp
+done
+
+lemma hoare_lemma12: "(EX n. b1$(iterate n$g$x) ~= TT) ==> 
+  k=Least(%n. b1$(iterate n$g$x)~=TT) & b1$(iterate k$g$x)=UU  
+  --> p$x = UU"
+apply (case_tac "k")
+apply hypsubst
+apply (simp (no_asm))
+apply (intro strip)
+apply (erule conjE)
+apply (rule trans)
+apply (rule p_def3)
+apply simp
+apply hypsubst
+apply (simp (no_asm))
+apply (intro strip)
+apply (erule conjE)
+apply (rule trans)
+apply (rule hoare_lemma10 [symmetric])
+apply assumption
+apply assumption
+apply (rule trans)
+apply (rule p_def3)
+apply (rule_tac s = "TT" and t = "b1$ (iterate nat$g$x) " in ssubst)
+apply (rule hoare_lemma8 [THEN spec, THEN mp])
+apply assumption
+apply assumption
+apply (simp (no_asm))
+apply (simp)
+apply (rule trans)
+apply (rule p_def3)
+apply simp
+done
+
+(* -------- results about p for case  (ALL k. b1$(iterate k$g$x)=TT) ------- *)
+
+lemma fernpass_lemma: "(ALL k. b1$(iterate k$g$x)=TT) ==> ALL k. p$(iterate k$g$x) = UU"
+apply (rule p_def [THEN eq_reflection, THEN def_fix_ind])
+apply simp
+apply simp
+apply (simp (no_asm))
+apply (rule allI)
+apply (rule_tac s = "TT" and t = "b1$ (iterate k$g$x) " in ssubst)
+apply (erule spec)
+apply (simp)
+apply (rule iterate_Suc [THEN subst])
+apply (erule spec)
+done
+
+lemma hoare_lemma16: "(ALL k. b1$(iterate k$g$x)=TT) ==> p$x = UU"
+apply (rule_tac F1 = "g" and t = "x" in iterate_0 [THEN subst])
+apply (erule fernpass_lemma [THEN spec])
+done
+
+(* -------- results about q for case  (ALL k. b1$(iterate k$g$x)=TT) ------- *)
+
+lemma hoare_lemma17: "(ALL k. b1$(iterate k$g$x)=TT) ==> ALL k. q$(iterate k$g$x) = UU"
+apply (rule q_def [THEN eq_reflection, THEN def_fix_ind])
+apply simp
+apply simp
+apply (rule allI)
+apply (simp (no_asm))
+apply (rule_tac s = "TT" and t = "b1$ (iterate k$g$x) " in ssubst)
+apply (erule spec)
+apply (simp)
+apply (rule iterate_Suc [THEN subst])
+apply (erule spec)
+done
+
+lemma hoare_lemma18: "(ALL k. b1$(iterate k$g$x)=TT) ==> q$x = UU"
+apply (rule_tac F1 = "g" and t = "x" in iterate_0 [THEN subst])
+apply (erule hoare_lemma17 [THEN spec])
+done
+
+lemma hoare_lemma19:
+  "(ALL k. (b1::'a->tr)$(iterate k$g$x)=TT) ==> b1$(UU::'a) = UU | (ALL y. b1$(y::'a)=TT)"
+apply (rule flat_codom)
+apply (rule_tac t = "x1" in iterate_0 [THEN subst])
+apply (erule spec)
+done
+
+lemma hoare_lemma20: "(ALL y. b1$(y::'a)=TT) ==> ALL k. q$(iterate k$g$(x::'a)) = UU"
+apply (rule q_def [THEN eq_reflection, THEN def_fix_ind])
+apply simp
+apply simp
+apply (rule allI)
+apply (simp (no_asm))
+apply (rule_tac s = "TT" and t = "b1$ (iterate k$g$ (x::'a))" in ssubst)
+apply (erule spec)
+apply (simp)
+apply (rule iterate_Suc [THEN subst])
+apply (erule spec)
+done
+
+lemma hoare_lemma21: "(ALL y. b1$(y::'a)=TT) ==> q$(x::'a) = UU"
+apply (rule_tac F1 = "g" and t = "x" in iterate_0 [THEN subst])
+apply (erule hoare_lemma20 [THEN spec])
+done
+
+lemma hoare_lemma22: "b1$(UU::'a)=UU ==> q$(UU::'a) = UU"
+apply (subst q_def3)
+apply simp
+done
+
+(* -------- results about q for case (EX k. b1$(iterate k$g$x) ~= TT) ------- *)
+
+lemma hoare_lemma25: "EX k. b1$(iterate k$g$x) ~= TT
+  ==> Suc k = (LEAST n. b1$(iterate n$g$x) ~= TT) ==> q$(iterate k$g$x) = q$x"
+  by (rule hoare_lemma8 [THEN hoare_lemma24 [THEN mp]])
+
+lemma hoare_lemma26: "(EX n. b1$(iterate n$g$x)~=TT) ==> 
+  k=Least(%n. b1$(iterate n$g$x) ~= TT) & b1$(iterate k$g$x) =FF  
+  --> q$x = q$(iterate k$g$x)"
+apply (case_tac "k")
+apply hypsubst
+apply (intro strip)
+apply (simp (no_asm))
+apply hypsubst
+apply (intro strip)
+apply (erule conjE)
+apply (rule trans)
+apply (rule hoare_lemma25 [symmetric])
+apply assumption
+apply assumption
+apply (rule trans)
+apply (rule q_def3)
+apply (rule_tac s = "TT" and t = "b1$ (iterate nat$g$x) " in ssubst)
+apply (rule hoare_lemma8 [THEN spec, THEN mp])
+apply assumption
+apply assumption
+apply (simp (no_asm))
+apply (simp (no_asm))
+done
+
+
+lemma hoare_lemma27: "(EX n. b1$(iterate n$g$x) ~= TT) ==> 
+  k=Least(%n. b1$(iterate n$g$x)~=TT) & b1$(iterate k$g$x)=UU  
+  --> q$x = UU"
+apply (case_tac "k")
+apply hypsubst
+apply (simp (no_asm))
+apply (intro strip)
+apply (erule conjE)
+apply (subst q_def3)
+apply (simp)
+apply hypsubst
+apply (simp (no_asm))
+apply (intro strip)
+apply (erule conjE)
+apply (rule trans)
+apply (rule hoare_lemma25 [symmetric])
+apply assumption
+apply assumption
+apply (rule trans)
+apply (rule q_def3)
+apply (rule_tac s = "TT" and t = "b1$ (iterate nat$g$x) " in ssubst)
+apply (rule hoare_lemma8 [THEN spec, THEN mp])
+apply assumption
+apply assumption
+apply (simp (no_asm))
+apply (simp)
+apply (rule trans)
+apply (rule q_def3)
+apply (simp)
+done
+
+(* ------- (ALL k. b1$(iterate k$g$x)=TT) ==> q o p = q   ----- *)
+
+lemma hoare_lemma23: "(ALL k. b1$(iterate k$g$x)=TT) ==> q$(p$x) = q$x"
+apply (subst hoare_lemma16)
+apply assumption
+apply (rule hoare_lemma19 [THEN disjE])
+apply assumption
+apply (simplesubst hoare_lemma18)
+apply assumption
+apply (simplesubst hoare_lemma22)
+apply assumption
+apply (rule refl)
+apply (simplesubst hoare_lemma21)
+apply assumption
+apply (simplesubst hoare_lemma21)
+apply assumption
+apply (rule refl)
+done
+
+(* ------------  EX k. b1~(iterate k$g$x) ~= TT ==> q o p = q   ----- *)
+
+lemma hoare_lemma29: "EX k. b1$(iterate k$g$x) ~= TT ==> q$(p$x) = q$x"
+apply (rule hoare_lemma5 [THEN disjE])
+apply assumption
+apply (rule refl)
+apply (subst hoare_lemma11 [THEN mp])
+apply assumption
+apply (rule conjI)
+apply (rule refl)
+apply assumption
+apply (rule hoare_lemma26 [THEN mp, THEN subst])
+apply assumption
+apply (rule conjI)
+apply (rule refl)
+apply assumption
+apply (rule refl)
+apply (subst hoare_lemma12 [THEN mp])
+apply assumption
+apply (rule conjI)
+apply (rule refl)
+apply assumption
+apply (subst hoare_lemma22)
+apply (subst hoare_lemma28)
+apply assumption
+apply (rule refl)
+apply (rule sym)
+apply (subst hoare_lemma27 [THEN mp])
+apply assumption
+apply (rule conjI)
+apply (rule refl)
+apply assumption
+apply (rule refl)
+done
+
+(* ------ the main proof q o p = q ------ *)
+
+theorem hoare_main: "q oo p = q"
+apply (rule cfun_eqI)
+apply (subst cfcomp2)
+apply (rule hoare_lemma3 [THEN disjE])
+apply (erule hoare_lemma23)
+apply (erule hoare_lemma29)
+done
+
+end

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/HOLCF/ex/Letrec.thy	Sat Nov 27 16:08:10 2010 -0800
@@ -0,0 +1,37 @@
+(*  Title:      HOLCF/ex/Letrec.thy
+    Author:     Brian Huffman
+*)
+
+header {* Recursive let bindings *}
+
+theory Letrec
+imports HOLCF
+begin
+
+default_sort pcpo
+
+definition
+  CLetrec :: "('a \<rightarrow> 'a \<times> 'b) \<rightarrow> 'b" where
+  "CLetrec = (\<Lambda> F. snd (F\<cdot>(\<mu> x. fst (F\<cdot>x))))"
+
+nonterminals
+  recbinds recbindt recbind
+
+syntax
+  "_recbind"  :: "['a, 'a] \<Rightarrow> recbind"               ("(2_ =/ _)" 10)
+  ""          :: "recbind \<Rightarrow> recbindt"               ("_")
+  "_recbindt" :: "[recbind, recbindt] \<Rightarrow> recbindt"   ("_,/ _")
+  ""          :: "recbindt \<Rightarrow> recbinds"              ("_")
+  "_recbinds" :: "[recbindt, recbinds] \<Rightarrow> recbinds"  ("_;/ _")
+  "_Letrec"   :: "[recbinds, 'a] \<Rightarrow> 'a"      ("(Letrec (_)/ in (_))" 10)
+
+translations
+  (recbindt) "x = a, (y,ys) = (b,bs)" == (recbindt) "(x,y,ys) = (a,b,bs)"
+  (recbindt) "x = a, y = b"          == (recbindt) "(x,y) = (a,b)"
+
+translations
+  "_Letrec (_recbinds b bs) e" == "_Letrec b (_Letrec bs e)"
+  "Letrec xs = a in (e,es)"    == "CONST CLetrec\<cdot>(\<Lambda> xs. (a,e,es))"
+  "Letrec xs = a in e"         == "CONST CLetrec\<cdot>(\<Lambda> xs. (a,e))"
+
+end

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/HOLCF/ex/Loop.thy	Sat Nov 27 16:08:10 2010 -0800
@@ -0,0 +1,200 @@
+(*  Title:      HOLCF/ex/Loop.thy
+    Author:     Franz Regensburger
+*)
+
+header {* Theory for a loop primitive like while *}
+
+theory Loop
+imports HOLCF
+begin
+
+definition
+  step  :: "('a -> tr)->('a -> 'a)->'a->'a" where
+  "step = (LAM b g x. If b$x then g$x else x)"
+
+definition
+  while :: "('a -> tr)->('a -> 'a)->'a->'a" where
+  "while = (LAM b g. fix$(LAM f x. If b$x then f$(g$x) else x))"
+
+(* ------------------------------------------------------------------------- *)
+(* access to definitions                                                     *)
+(* ------------------------------------------------------------------------- *)
+
+
+lemma step_def2: "step$b$g$x = If b$x then g$x else x"
+apply (unfold step_def)
+apply simp
+done
+
+lemma while_def2: "while$b$g = fix$(LAM f x. If b$x then f$(g$x) else x)"
+apply (unfold while_def)
+apply simp
+done
+
+
+(* ------------------------------------------------------------------------- *)
+(* rekursive properties of while                                             *)
+(* ------------------------------------------------------------------------- *)
+
+lemma while_unfold: "while$b$g$x = If b$x then while$b$g$(g$x) else x"
+apply (rule trans)
+apply (rule while_def2 [THEN fix_eq5])
+apply simp
+done
+
+lemma while_unfold2: "ALL x. while$b$g$x = while$b$g$(iterate k$(step$b$g)$x)"
+apply (induct_tac k)
+apply simp
+apply (rule allI)
+apply (rule trans)
+apply (rule while_unfold)
+apply (subst iterate_Suc2)
+apply (rule trans)
+apply (erule_tac [2] spec)
+apply (subst step_def2)
+apply (rule_tac p = "b$x" in trE)
+apply simp
+apply (subst while_unfold)
+apply (rule_tac s = "UU" and t = "b$UU" in ssubst)
+apply (erule strictI)
+apply simp
+apply simp
+apply simp
+apply (subst while_unfold)
+apply simp
+done
+
+lemma while_unfold3: "while$b$g$x = while$b$g$(step$b$g$x)"
+apply (rule_tac s = "while$b$g$ (iterate (Suc 0) $ (step$b$g) $x) " in trans)
+apply (rule while_unfold2 [THEN spec])
+apply simp
+done
+
+
+(* ------------------------------------------------------------------------- *)
+(* properties of while and iterations                                        *)
+(* ------------------------------------------------------------------------- *)
+
+lemma loop_lemma1: "[| EX y. b$y=FF; iterate k$(step$b$g)$x = UU |]
+     ==>iterate(Suc k)$(step$b$g)$x=UU"
+apply (simp (no_asm))
+apply (rule trans)
+apply (rule step_def2)
+apply simp
+apply (erule exE)
+apply (erule flat_codom [THEN disjE])
+apply simp_all
+done
+
+lemma loop_lemma2: "[|EX y. b$y=FF;iterate (Suc k)$(step$b$g)$x ~=UU |]==>
+      iterate k$(step$b$g)$x ~=UU"
+apply (blast intro: loop_lemma1)
+done
+
+lemma loop_lemma3 [rule_format (no_asm)]:
+  "[| ALL x. INV x & b$x=TT & g$x~=UU --> INV (g$x);
+         EX y. b$y=FF; INV x |]
+      ==> iterate k$(step$b$g)$x ~=UU --> INV (iterate k$(step$b$g)$x)"
+apply (induct_tac "k")
+apply (simp (no_asm_simp))
+apply (intro strip)
+apply (simp (no_asm) add: step_def2)
+apply (rule_tac p = "b$ (iterate n$ (step$b$g) $x) " in trE)
+apply (erule notE)
+apply (simp add: step_def2)
+apply (simp (no_asm_simp))
+apply (rule mp)
+apply (erule spec)
+apply (simp (no_asm_simp) del: iterate_Suc add: loop_lemma2)
+apply (rule_tac s = "iterate (Suc n) $ (step$b$g) $x"
+  and t = "g$ (iterate n$ (step$b$g) $x) " in ssubst)
+prefer 2 apply (assumption)
+apply (simp add: step_def2)
+apply (drule (1) loop_lemma2, simp)
+done
+
+lemma loop_lemma4 [rule_format]:
+  "ALL x. b$(iterate k$(step$b$g)$x)=FF --> while$b$g$x= iterate k$(step$b$g)$x"
+apply (induct_tac k)
+apply (simp (no_asm))
+apply (intro strip)
+apply (simplesubst while_unfold)
+apply simp
+apply (rule allI)
+apply (simplesubst iterate_Suc2)
+apply (intro strip)
+apply (rule trans)
+apply (rule while_unfold3)
+apply simp
+done
+
+lemma loop_lemma5 [rule_format (no_asm)]:
+  "ALL k. b$(iterate k$(step$b$g)$x) ~= FF ==>
+    ALL m. while$b$g$(iterate m$(step$b$g)$x)=UU"
+apply (simplesubst while_def2)
+apply (rule fix_ind)
+apply simp
+apply simp
+apply (rule allI)
+apply (simp (no_asm))
+apply (rule_tac p = "b$ (iterate m$ (step$b$g) $x) " in trE)
+apply (simp (no_asm_simp))
+apply (simp (no_asm_simp))
+apply (rule_tac s = "xa$ (iterate (Suc m) $ (step$b$g) $x) " in trans)
+apply (erule_tac [2] spec)
+apply (rule cfun_arg_cong)
+apply (rule trans)
+apply (rule_tac [2] iterate_Suc [symmetric])
+apply (simp add: step_def2)
+apply blast
+done
+
+lemma loop_lemma6: "ALL k. b$(iterate k$(step$b$g)$x) ~= FF ==> while$b$g$x=UU"
+apply (rule_tac t = "x" in iterate_0 [THEN subst])
+apply (erule loop_lemma5)
+done
+
+lemma loop_lemma7: "while$b$g$x ~= UU ==> EX k. b$(iterate k$(step$b$g)$x) = FF"
+apply (blast intro: loop_lemma6)
+done
+
+
+(* ------------------------------------------------------------------------- *)
+(* an invariant rule for loops                                               *)
+(* ------------------------------------------------------------------------- *)
+
+lemma loop_inv2:
+"[| (ALL y. INV y & b$y=TT & g$y ~= UU --> INV (g$y));
+    (ALL y. INV y & b$y=FF --> Q y);
+    INV x; while$b$g$x~=UU |] ==> Q (while$b$g$x)"
+apply (rule_tac P = "%k. b$ (iterate k$ (step$b$g) $x) =FF" in exE)
+apply (erule loop_lemma7)
+apply (simplesubst loop_lemma4)
+apply assumption
+apply (drule spec, erule mp)
+apply (rule conjI)
+prefer 2 apply (assumption)
+apply (rule loop_lemma3)
+apply assumption
+apply (blast intro: loop_lemma6)
+apply assumption
+apply (rotate_tac -1)
+apply (simp add: loop_lemma4)
+done
+
+lemma loop_inv:
+  assumes premP: "P(x)"
+    and premI: "!!y. P y ==> INV y"
+    and premTT: "!!y. [| INV y; b$y=TT; g$y~=UU|] ==> INV (g$y)"
+    and premFF: "!!y. [| INV y; b$y=FF|] ==> Q y"
+    and premW: "while$b$g$x ~= UU"
+  shows "Q (while$b$g$x)"
+apply (rule loop_inv2)
+apply (rule_tac [3] premP [THEN premI])
+apply (rule_tac [3] premW)
+apply (blast intro: premTT)
+apply (blast intro: premFF)
+done
+
+end
+

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/HOLCF/ex/Pattern_Match.thy	Sat Nov 27 16:08:10 2010 -0800
@@ -0,0 +1,609 @@
+(*  Title:      HOLCF/ex/Pattern_Match.thy
+    Author:     Brian Huffman
+*)
+
+header {* An experimental pattern-matching notation *}
+
+theory Pattern_Match
+imports HOLCF
+begin
+
+default_sort pcpo
+
+text {* FIXME: Find a proper way to un-hide constants. *}
+
+abbreviation fail :: "'a match"
+where "fail \<equiv> Fixrec.fail"
+
+abbreviation succeed :: "'a \<rightarrow> 'a match"
+where "succeed \<equiv> Fixrec.succeed"
+
+abbreviation run :: "'a match \<rightarrow> 'a"
+where "run \<equiv> Fixrec.run"
+
+subsection {* Fatbar combinator *}
+
+definition
+  fatbar :: "('a \<rightarrow> 'b match) \<rightarrow> ('a \<rightarrow> 'b match) \<rightarrow> ('a \<rightarrow> 'b match)" where
+  "fatbar = (\<Lambda> a b x. a\<cdot>x +++ b\<cdot>x)"
+
+abbreviation
+  fatbar_syn :: "['a \<rightarrow> 'b match, 'a \<rightarrow> 'b match] \<Rightarrow> 'a \<rightarrow> 'b match" (infixr "\<parallel>" 60)  where
+  "m1 \<parallel> m2 == fatbar\<cdot>m1\<cdot>m2"
+
+lemma fatbar1: "m\<cdot>x = \<bottom> \<Longrightarrow> (m \<parallel> ms)\<cdot>x = \<bottom>"
+by (simp add: fatbar_def)
+
+lemma fatbar2: "m\<cdot>x = fail \<Longrightarrow> (m \<parallel> ms)\<cdot>x = ms\<cdot>x"
+by (simp add: fatbar_def)
+
+lemma fatbar3: "m\<cdot>x = succeed\<cdot>y \<Longrightarrow> (m \<parallel> ms)\<cdot>x = succeed\<cdot>y"
+by (simp add: fatbar_def)
+
+lemmas fatbar_simps = fatbar1 fatbar2 fatbar3
+
+lemma run_fatbar1: "m\<cdot>x = \<bottom> \<Longrightarrow> run\<cdot>((m \<parallel> ms)\<cdot>x) = \<bottom>"
+by (simp add: fatbar_def)
+
+lemma run_fatbar2: "m\<cdot>x = fail \<Longrightarrow> run\<cdot>((m \<parallel> ms)\<cdot>x) = run\<cdot>(ms\<cdot>x)"
+by (simp add: fatbar_def)
+
+lemma run_fatbar3: "m\<cdot>x = succeed\<cdot>y \<Longrightarrow> run\<cdot>((m \<parallel> ms)\<cdot>x) = y"
+by (simp add: fatbar_def)
+
+lemmas run_fatbar_simps [simp] = run_fatbar1 run_fatbar2 run_fatbar3
+
+subsection {* Bind operator for match monad *}
+
+definition match_bind :: "'a match \<rightarrow> ('a \<rightarrow> 'b match) \<rightarrow> 'b match" where
+  "match_bind = (\<Lambda> m k. sscase\<cdot>(\<Lambda> _. fail)\<cdot>(fup\<cdot>k)\<cdot>(Rep_match m))"
+
+lemma match_bind_simps [simp]:
+  "match_bind\<cdot>\<bottom>\<cdot>k = \<bottom>"
+  "match_bind\<cdot>fail\<cdot>k = fail"
+  "match_bind\<cdot>(succeed\<cdot>x)\<cdot>k = k\<cdot>x"
+unfolding match_bind_def fail_def succeed_def
+by (simp_all add: cont2cont_Rep_match cont_Abs_match
+  Rep_match_strict Abs_match_inverse)
+
+subsection {* Case branch combinator *}
+
+definition
+  branch :: "('a \<rightarrow> 'b match) \<Rightarrow> ('b \<rightarrow> 'c) \<rightarrow> ('a \<rightarrow> 'c match)" where
+  "branch p \<equiv> \<Lambda> r x. match_bind\<cdot>(p\<cdot>x)\<cdot>(\<Lambda> y. succeed\<cdot>(r\<cdot>y))"
+
+lemma branch_simps:
+  "p\<cdot>x = \<bottom> \<Longrightarrow> branch p\<cdot>r\<cdot>x = \<bottom>"
+  "p\<cdot>x = fail \<Longrightarrow> branch p\<cdot>r\<cdot>x = fail"
+  "p\<cdot>x = succeed\<cdot>y \<Longrightarrow> branch p\<cdot>r\<cdot>x = succeed\<cdot>(r\<cdot>y)"
+by (simp_all add: branch_def)
+
+lemma branch_succeed [simp]: "branch succeed\<cdot>r\<cdot>x = succeed\<cdot>(r\<cdot>x)"
+by (simp add: branch_def)
+
+subsection {* Cases operator *}
+
+definition
+  cases :: "'a match \<rightarrow> 'a::pcpo" where
+  "cases = Fixrec.run"
+
+text {* rewrite rules for cases *}
+
+lemma cases_strict [simp]: "cases\<cdot>\<bottom> = \<bottom>"
+by (simp add: cases_def)
+
+lemma cases_fail [simp]: "cases\<cdot>fail = \<bottom>"
+by (simp add: cases_def)
+
+lemma cases_succeed [simp]: "cases\<cdot>(succeed\<cdot>x) = x"
+by (simp add: cases_def)
+
+subsection {* Case syntax *}
+
+nonterminals
+  Case_syn  Cases_syn
+
+syntax
+  "_Case_syntax":: "['a, Cases_syn] => 'b"               ("(Case _ of/ _)" 10)
+  "_Case1"      :: "['a, 'b] => Case_syn"                ("(2_ =>/ _)" 10)
+  ""            :: "Case_syn => Cases_syn"               ("_")
+  "_Case2"      :: "[Case_syn, Cases_syn] => Cases_syn"  ("_/ | _")
+
+syntax (xsymbols)
+  "_Case1"      :: "['a, 'b] => Case_syn"                ("(2_ \<Rightarrow>/ _)" 10)
+
+translations
+  "_Case_syntax x ms" == "CONST cases\<cdot>(ms\<cdot>x)"
+  "_Case2 m ms" == "m \<parallel> ms"
+
+text {* Parsing Case expressions *}
+
+syntax
+  "_pat" :: "'a"
+  "_variable" :: "'a"
+  "_noargs" :: "'a"
+
+translations
+  "_Case1 p r" => "CONST branch (_pat p)\<cdot>(_variable p r)"
+  "_variable (_args x y) r" => "CONST csplit\<cdot>(_variable x (_variable y r))"
+  "_variable _noargs r" => "CONST unit_when\<cdot>r"
+
+parse_translation {*
+(* rewrite (_pat x) => (succeed) *)
+(* rewrite (_variable x t) => (Abs_cfun (%x. t)) *)
+ [(@{syntax_const "_pat"}, fn _ => Syntax.const @{const_syntax Fixrec.succeed}),
+  mk_binder_tr (@{syntax_const "_variable"}, @{const_syntax Abs_cfun})];
+*}
+
+text {* Printing Case expressions *}
+
+syntax
+  "_match" :: "'a"
+
+print_translation {*
+  let
+    fun dest_LAM (Const (@{const_syntax Rep_cfun},_) $ Const (@{const_syntax unit_when},_) $ t) =
+          (Syntax.const @{syntax_const "_noargs"}, t)
+    |   dest_LAM (Const (@{const_syntax Rep_cfun},_) $ Const (@{const_syntax csplit},_) $ t) =
+          let
+            val (v1, t1) = dest_LAM t;
+            val (v2, t2) = dest_LAM t1;
+          in (Syntax.const @{syntax_const "_args"} $ v1 $ v2, t2) end
+    |   dest_LAM (Const (@{const_syntax Abs_cfun},_) $ t) =
+          let
+            val abs =
+              case t of Abs abs => abs
+                | _ => ("x", dummyT, incr_boundvars 1 t $ Bound 0);
+            val (x, t') = atomic_abs_tr' abs;
+          in (Syntax.const @{syntax_const "_variable"} $ x, t') end
+    |   dest_LAM _ = raise Match; (* too few vars: abort translation *)
+
+    fun Case1_tr' [Const(@{const_syntax branch},_) $ p, r] =
+          let val (v, t) = dest_LAM r in
+            Syntax.const @{syntax_const "_Case1"} $
+              (Syntax.const @{syntax_const "_match"} $ p $ v) $ t
+          end;
+
+  in [(@{const_syntax Rep_cfun}, Case1_tr')] end;
+*}
+
+translations
+  "x" <= "_match (CONST succeed) (_variable x)"
+
+
+subsection {* Pattern combinators for data constructors *}
+
+types ('a, 'b) pat = "'a \<rightarrow> 'b match"
+
+definition
+  cpair_pat :: "('a, 'c) pat \<Rightarrow> ('b, 'd) pat \<Rightarrow> ('a \<times> 'b, 'c \<times> 'd) pat" where
+  "cpair_pat p1 p2 = (\<Lambda>(x, y).
+    match_bind\<cdot>(p1\<cdot>x)\<cdot>(\<Lambda> a. match_bind\<cdot>(p2\<cdot>y)\<cdot>(\<Lambda> b. succeed\<cdot>(a, b))))"
+
+definition
+  spair_pat ::
+  "('a, 'c) pat \<Rightarrow> ('b, 'd) pat \<Rightarrow> ('a::pcpo \<otimes> 'b::pcpo, 'c \<times> 'd) pat" where
+  "spair_pat p1 p2 = (\<Lambda>(:x, y:). cpair_pat p1 p2\<cdot>(x, y))"
+
+definition
+  sinl_pat :: "('a, 'c) pat \<Rightarrow> ('a::pcpo \<oplus> 'b::pcpo, 'c) pat" where
+  "sinl_pat p = sscase\<cdot>p\<cdot>(\<Lambda> x. fail)"
+
+definition
+  sinr_pat :: "('b, 'c) pat \<Rightarrow> ('a::pcpo \<oplus> 'b::pcpo, 'c) pat" where
+  "sinr_pat p = sscase\<cdot>(\<Lambda> x. fail)\<cdot>p"
+
+definition
+  up_pat :: "('a, 'b) pat \<Rightarrow> ('a u, 'b) pat" where
+  "up_pat p = fup\<cdot>p"
+
+definition
+  TT_pat :: "(tr, unit) pat" where
+  "TT_pat = (\<Lambda> b. If b then succeed\<cdot>() else fail)"
+
+definition
+  FF_pat :: "(tr, unit) pat" where
+  "FF_pat = (\<Lambda> b. If b then fail else succeed\<cdot>())"
+
+definition
+  ONE_pat :: "(one, unit) pat" where
+  "ONE_pat = (\<Lambda> ONE. succeed\<cdot>())"
+
+text {* Parse translations (patterns) *}
+translations
+  "_pat (XCONST Pair x y)" => "CONST cpair_pat (_pat x) (_pat y)"
+  "_pat (XCONST spair\<cdot>x\<cdot>y)" => "CONST spair_pat (_pat x) (_pat y)"
+  "_pat (XCONST sinl\<cdot>x)" => "CONST sinl_pat (_pat x)"
+  "_pat (XCONST sinr\<cdot>x)" => "CONST sinr_pat (_pat x)"
+  "_pat (XCONST up\<cdot>x)" => "CONST up_pat (_pat x)"
+  "_pat (XCONST TT)" => "CONST TT_pat"
+  "_pat (XCONST FF)" => "CONST FF_pat"
+  "_pat (XCONST ONE)" => "CONST ONE_pat"
+
+text {* CONST version is also needed for constructors with special syntax *}
+translations
+  "_pat (CONST Pair x y)" => "CONST cpair_pat (_pat x) (_pat y)"
+  "_pat (CONST spair\<cdot>x\<cdot>y)" => "CONST spair_pat (_pat x) (_pat y)"
+
+text {* Parse translations (variables) *}
+translations
+  "_variable (XCONST Pair x y) r" => "_variable (_args x y) r"
+  "_variable (XCONST spair\<cdot>x\<cdot>y) r" => "_variable (_args x y) r"
+  "_variable (XCONST sinl\<cdot>x) r" => "_variable x r"
+  "_variable (XCONST sinr\<cdot>x) r" => "_variable x r"
+  "_variable (XCONST up\<cdot>x) r" => "_variable x r"
+  "_variable (XCONST TT) r" => "_variable _noargs r"
+  "_variable (XCONST FF) r" => "_variable _noargs r"
+  "_variable (XCONST ONE) r" => "_variable _noargs r"
+
+translations
+  "_variable (CONST Pair x y) r" => "_variable (_args x y) r"
+  "_variable (CONST spair\<cdot>x\<cdot>y) r" => "_variable (_args x y) r"
+
+text {* Print translations *}
+translations
+  "CONST Pair (_match p1 v1) (_match p2 v2)"
+      <= "_match (CONST cpair_pat p1 p2) (_args v1 v2)"
+  "CONST spair\<cdot>(_match p1 v1)\<cdot>(_match p2 v2)"
+      <= "_match (CONST spair_pat p1 p2) (_args v1 v2)"
+  "CONST sinl\<cdot>(_match p1 v1)" <= "_match (CONST sinl_pat p1) v1"
+  "CONST sinr\<cdot>(_match p1 v1)" <= "_match (CONST sinr_pat p1) v1"
+  "CONST up\<cdot>(_match p1 v1)" <= "_match (CONST up_pat p1) v1"
+  "CONST TT" <= "_match (CONST TT_pat) _noargs"
+  "CONST FF" <= "_match (CONST FF_pat) _noargs"
+  "CONST ONE" <= "_match (CONST ONE_pat) _noargs"
+
+lemma cpair_pat1:
+  "branch p\<cdot>r\<cdot>x = \<bottom> \<Longrightarrow> branch (cpair_pat p q)\<cdot>(csplit\<cdot>r)\<cdot>(x, y) = \<bottom>"
+apply (simp add: branch_def cpair_pat_def)
+apply (cases "p\<cdot>x", simp_all)
+done
+
+lemma cpair_pat2:
+  "branch p\<cdot>r\<cdot>x = fail \<Longrightarrow> branch (cpair_pat p q)\<cdot>(csplit\<cdot>r)\<cdot>(x, y) = fail"
+apply (simp add: branch_def cpair_pat_def)
+apply (cases "p\<cdot>x", simp_all)
+done
+
+lemma cpair_pat3:
+  "branch p\<cdot>r\<cdot>x = succeed\<cdot>s \<Longrightarrow>
+   branch (cpair_pat p q)\<cdot>(csplit\<cdot>r)\<cdot>(x, y) = branch q\<cdot>s\<cdot>y"
+apply (simp add: branch_def cpair_pat_def)
+apply (cases "p\<cdot>x", simp_all)
+apply (cases "q\<cdot>y", simp_all)
+done
+
+lemmas cpair_pat [simp] =
+  cpair_pat1 cpair_pat2 cpair_pat3
+
+lemma spair_pat [simp]:
+  "branch (spair_pat p1 p2)\<cdot>r\<cdot>\<bottom> = \<bottom>"
+  "\<lbrakk>x \<noteq> \<bottom>; y \<noteq> \<bottom>\<rbrakk>
+     \<Longrightarrow> branch (spair_pat p1 p2)\<cdot>r\<cdot>(:x, y:) =
+         branch (cpair_pat p1 p2)\<cdot>r\<cdot>(x, y)"
+by (simp_all add: branch_def spair_pat_def)
+
+lemma sinl_pat [simp]:
+  "branch (sinl_pat p)\<cdot>r\<cdot>\<bottom> = \<bottom>"
+  "x \<noteq> \<bottom> \<Longrightarrow> branch (sinl_pat p)\<cdot>r\<cdot>(sinl\<cdot>x) = branch p\<cdot>r\<cdot>x"
+  "y \<noteq> \<bottom> \<Longrightarrow> branch (sinl_pat p)\<cdot>r\<cdot>(sinr\<cdot>y) = fail"
+by (simp_all add: branch_def sinl_pat_def)
+
+lemma sinr_pat [simp]:
+  "branch (sinr_pat p)\<cdot>r\<cdot>\<bottom> = \<bottom>"
+  "x \<noteq> \<bottom> \<Longrightarrow> branch (sinr_pat p)\<cdot>r\<cdot>(sinl\<cdot>x) = fail"
+  "y \<noteq> \<bottom> \<Longrightarrow> branch (sinr_pat p)\<cdot>r\<cdot>(sinr\<cdot>y) = branch p\<cdot>r\<cdot>y"
+by (simp_all add: branch_def sinr_pat_def)
+
+lemma up_pat [simp]:
+  "branch (up_pat p)\<cdot>r\<cdot>\<bottom> = \<bottom>"
+  "branch (up_pat p)\<cdot>r\<cdot>(up\<cdot>x) = branch p\<cdot>r\<cdot>x"
+by (simp_all add: branch_def up_pat_def)
+
+lemma TT_pat [simp]:
+  "branch TT_pat\<cdot>(unit_when\<cdot>r)\<cdot>\<bottom> = \<bottom>"
+  "branch TT_pat\<cdot>(unit_when\<cdot>r)\<cdot>TT = succeed\<cdot>r"
+  "branch TT_pat\<cdot>(unit_when\<cdot>r)\<cdot>FF = fail"
+by (simp_all add: branch_def TT_pat_def)
+
+lemma FF_pat [simp]:
+  "branch FF_pat\<cdot>(unit_when\<cdot>r)\<cdot>\<bottom> = \<bottom>"
+  "branch FF_pat\<cdot>(unit_when\<cdot>r)\<cdot>TT = fail"
+  "branch FF_pat\<cdot>(unit_when\<cdot>r)\<cdot>FF = succeed\<cdot>r"
+by (simp_all add: branch_def FF_pat_def)
+
+lemma ONE_pat [simp]:
+  "branch ONE_pat\<cdot>(unit_when\<cdot>r)\<cdot>\<bottom> = \<bottom>"
+  "branch ONE_pat\<cdot>(unit_when\<cdot>r)\<cdot>ONE = succeed\<cdot>r"
+by (simp_all add: branch_def ONE_pat_def)
+
+
+subsection {* Wildcards, as-patterns, and lazy patterns *}
+
+definition
+  wild_pat :: "'a \<rightarrow> unit match" where
+  "wild_pat = (\<Lambda> x. succeed\<cdot>())"
+
+definition
+  as_pat :: "('a \<rightarrow> 'b match) \<Rightarrow> 'a \<rightarrow> ('a \<times> 'b) match" where
+  "as_pat p = (\<Lambda> x. match_bind\<cdot>(p\<cdot>x)\<cdot>(\<Lambda> a. succeed\<cdot>(x, a)))"
+
+definition
+  lazy_pat :: "('a \<rightarrow> 'b::pcpo match) \<Rightarrow> ('a \<rightarrow> 'b match)" where
+  "lazy_pat p = (\<Lambda> x. succeed\<cdot>(cases\<cdot>(p\<cdot>x)))"
+
+text {* Parse translations (patterns) *}
+translations
+  "_pat _" => "CONST wild_pat"
+
+text {* Parse translations (variables) *}
+translations
+  "_variable _ r" => "_variable _noargs r"
+
+text {* Print translations *}
+translations
+  "_" <= "_match (CONST wild_pat) _noargs"
+
+lemma wild_pat [simp]: "branch wild_pat\<cdot>(unit_when\<cdot>r)\<cdot>x = succeed\<cdot>r"
+by (simp add: branch_def wild_pat_def)
+
+lemma as_pat [simp]:
+  "branch (as_pat p)\<cdot>(csplit\<cdot>r)\<cdot>x = branch p\<cdot>(r\<cdot>x)\<cdot>x"
+apply (simp add: branch_def as_pat_def)
+apply (cases "p\<cdot>x", simp_all)
+done
+
+lemma lazy_pat [simp]:
+  "branch p\<cdot>r\<cdot>x = \<bottom> \<Longrightarrow> branch (lazy_pat p)\<cdot>r\<cdot>x = succeed\<cdot>(r\<cdot>\<bottom>)"
+  "branch p\<cdot>r\<cdot>x = fail \<Longrightarrow> branch (lazy_pat p)\<cdot>r\<cdot>x = succeed\<cdot>(r\<cdot>\<bottom>)"
+  "branch p\<cdot>r\<cdot>x = succeed\<cdot>s \<Longrightarrow> branch (lazy_pat p)\<cdot>r\<cdot>x = succeed\<cdot>s"
+apply (simp_all add: branch_def lazy_pat_def)
+apply (cases "p\<cdot>x", simp_all)+
+done
+
+subsection {* Examples *}
+
+term "Case t of (:up\<cdot>(sinl\<cdot>x), sinr\<cdot>y:) \<Rightarrow> (x, y)"
+
+term "\<Lambda> t. Case t of up\<cdot>(sinl\<cdot>a) \<Rightarrow> a | up\<cdot>(sinr\<cdot>b) \<Rightarrow> b"
+
+term "\<Lambda> t. Case t of (:up\<cdot>(sinl\<cdot>_), sinr\<cdot>x:) \<Rightarrow> x"
+
+subsection {* ML code for generating definitions *}
+
+ML {*
+local open HOLCF_Library in
+
+infixr 6 ->>;
+infix 9 ` ;
+
+val beta_rules =
+  @{thms beta_cfun cont_id cont_const cont2cont_APP cont2cont_LAM'} @
+  @{thms cont2cont_fst cont2cont_snd cont2cont_Pair};
+
+val beta_ss = HOL_basic_ss addsimps (simp_thms @ beta_rules);
+
+fun define_consts
+    (specs : (binding * term * mixfix) list)
+    (thy : theory)
+    : (term list * thm list) * theory =
+  let
+    fun mk_decl (b, t, mx) = (b, fastype_of t, mx);
+    val decls = map mk_decl specs;
+    val thy = Cont_Consts.add_consts decls thy;
+    fun mk_const (b, T, mx) = Const (Sign.full_name thy b, T);
+    val consts = map mk_const decls;
+    fun mk_def c (b, t, mx) =
+      (Binding.suffix_name "_def" b, Logic.mk_equals (c, t));
+    val defs = map2 mk_def consts specs;
+    val (def_thms, thy) =
+      Global_Theory.add_defs false (map Thm.no_attributes defs) thy;
+  in
+    ((consts, def_thms), thy)
+  end;
+
+fun prove
+    (thy : theory)
+    (defs : thm list)
+    (goal : term)
+    (tacs : {prems: thm list, context: Proof.context} -> tactic list)
+    : thm =
+  let
+    fun tac {prems, context} =
+      rewrite_goals_tac defs THEN
+      EVERY (tacs {prems = map (rewrite_rule defs) prems, context = context})
+  in
+    Goal.prove_global thy [] [] goal tac
+  end;
+
+fun get_vars_avoiding
+    (taken : string list)
+    (args : (bool * typ) list)
+    : (term list * term list) =
+  let
+    val Ts = map snd args;
+    val ns = Name.variant_list taken (Datatype_Prop.make_tnames Ts);
+    val vs = map Free (ns ~~ Ts);
+    val nonlazy = map snd (filter_out (fst o fst) (args ~~ vs));
+  in
+    (vs, nonlazy)
+  end;
+
+(******************************************************************************)
+(************** definitions and theorems for pattern combinators **************)
+(******************************************************************************)
+
+fun add_pattern_combinators
+    (bindings : binding list)
+    (spec : (term * (bool * typ) list) list)
+    (lhsT : typ)
+    (exhaust : thm)
+    (case_const : typ -> term)
+    (case_rews : thm list)
+    (thy : theory) =
+  let
+
+    (* utility functions *)
+    fun mk_pair_pat (p1, p2) =
+      let
+        val T1 = fastype_of p1;
+        val T2 = fastype_of p2;
+        val (U1, V1) = apsnd dest_matchT (dest_cfunT T1);
+        val (U2, V2) = apsnd dest_matchT (dest_cfunT T2);
+        val pat_typ = [T1, T2] --->
+            (mk_prodT (U1, U2) ->> mk_matchT (mk_prodT (V1, V2)));
+        val pat_const = Const (@{const_name cpair_pat}, pat_typ);
+      in
+        pat_const $ p1 $ p2
+      end;
+    fun mk_tuple_pat [] = succeed_const HOLogic.unitT
+      | mk_tuple_pat ps = foldr1 mk_pair_pat ps;
+    fun branch_const (T,U,V) = 
+      Const (@{const_name branch},
+        (T ->> mk_matchT U) --> (U ->> V) ->> T ->> mk_matchT V);
+
+    (* define pattern combinators *)
+    local
+      val tns = map (fst o dest_TFree) (snd (dest_Type lhsT));
+
+      fun pat_eqn (i, (bind, (con, args))) : binding * term * mixfix =
+        let
+          val pat_bind = Binding.suffix_name "_pat" bind;
+          val Ts = map snd args;
+          val Vs =
+              (map (K "'t") args)
+              |> Datatype_Prop.indexify_names
+              |> Name.variant_list tns
+              |> map (fn t => TFree (t, @{sort pcpo}));
+          val patNs = Datatype_Prop.indexify_names (map (K "pat") args);
+          val patTs = map2 (fn T => fn V => T ->> mk_matchT V) Ts Vs;
+          val pats = map Free (patNs ~~ patTs);
+          val fail = mk_fail (mk_tupleT Vs);
+          val (vs, nonlazy) = get_vars_avoiding patNs args;
+          val rhs = big_lambdas vs (mk_tuple_pat pats ` mk_tuple vs);
+          fun one_fun (j, (_, args')) =
+            let
+              val (vs', nonlazy) = get_vars_avoiding patNs args';
+            in if i = j then rhs else big_lambdas vs' fail end;
+          val funs = map_index one_fun spec;
+          val body = list_ccomb (case_const (mk_matchT (mk_tupleT Vs)), funs);
+        in
+          (pat_bind, lambdas pats body, NoSyn)
+        end;
+    in
+      val ((pat_consts, pat_defs), thy) =
+          define_consts (map_index pat_eqn (bindings ~~ spec)) thy
+    end;
+
+    (* syntax translations for pattern combinators *)
+    local
+      open Syntax
+      fun syntax c = Syntax.mark_const (fst (dest_Const c));
+      fun app s (l, r) = Syntax.mk_appl (Constant s) [l, r];
+      val capp = app @{const_syntax Rep_cfun};
+      val capps = Library.foldl capp
+
+      fun app_var x = Syntax.mk_appl (Constant "_variable") [x, Variable "rhs"];
+      fun app_pat x = Syntax.mk_appl (Constant "_pat") [x];
+      fun args_list [] = Constant "_noargs"
+        | args_list xs = foldr1 (app "_args") xs;
+      fun one_case_trans (pat, (con, args)) =
+        let
+          val cname = Constant (syntax con);
+          val pname = Constant (syntax pat);
+          val ns = 1 upto length args;
+          val xs = map (fn n => Variable ("x"^(string_of_int n))) ns;
+          val ps = map (fn n => Variable ("p"^(string_of_int n))) ns;
+          val vs = map (fn n => Variable ("v"^(string_of_int n))) ns;
+        in
+          [ParseRule (app_pat (capps (cname, xs)),
+                      mk_appl pname (map app_pat xs)),
+           ParseRule (app_var (capps (cname, xs)),
+                      app_var (args_list xs)),
+           PrintRule (capps (cname, ListPair.map (app "_match") (ps,vs)),
+                      app "_match" (mk_appl pname ps, args_list vs))]
+        end;
+      val trans_rules : Syntax.ast Syntax.trrule list =
+          maps one_case_trans (pat_consts ~~ spec);
+    in
+      val thy = Sign.add_trrules_i trans_rules thy;
+    end;
+
+    (* prove strictness and reduction rules of pattern combinators *)
+    local
+      val tns = map (fst o dest_TFree) (snd (dest_Type lhsT));
+      val rn = Name.variant tns "'r";
+      val R = TFree (rn, @{sort pcpo});
+      fun pat_lhs (pat, args) =
+        let
+          val Ts = map snd args;
+          val Vs =
+              (map (K "'t") args)
+              |> Datatype_Prop.indexify_names
+              |> Name.variant_list (rn::tns)
+              |> map (fn t => TFree (t, @{sort pcpo}));
+          val patNs = Datatype_Prop.indexify_names (map (K "pat") args);
+          val patTs = map2 (fn T => fn V => T ->> mk_matchT V) Ts Vs;
+          val pats = map Free (patNs ~~ patTs);
+          val k = Free ("rhs", mk_tupleT Vs ->> R);
+          val branch1 = branch_const (lhsT, mk_tupleT Vs, R);
+          val fun1 = (branch1 $ list_comb (pat, pats)) ` k;
+          val branch2 = branch_const (mk_tupleT Ts, mk_tupleT Vs, R);
+          val fun2 = (branch2 $ mk_tuple_pat pats) ` k;
+          val taken = "rhs" :: patNs;
+        in (fun1, fun2, taken) end;
+      fun pat_strict (pat, (con, args)) =
+        let
+          val (fun1, fun2, taken) = pat_lhs (pat, args);
+          val defs = @{thm branch_def} :: pat_defs;
+          val goal = mk_trp (mk_strict fun1);
+          val rules = @{thms match_bind_simps} @ case_rews;
+          val tacs = [simp_tac (beta_ss addsimps rules) 1];
+        in prove thy defs goal (K tacs) end;
+      fun pat_apps (i, (pat, (con, args))) =
+        let
+          val (fun1, fun2, taken) = pat_lhs (pat, args);
+          fun pat_app (j, (con', args')) =
+            let
+              val (vs, nonlazy) = get_vars_avoiding taken args';
+              val con_app = list_ccomb (con', vs);
+              val assms = map (mk_trp o mk_defined) nonlazy;
+              val rhs = if i = j then fun2 ` mk_tuple vs else mk_fail R;
+              val concl = mk_trp (mk_eq (fun1 ` con_app, rhs));
+              val goal = Logic.list_implies (assms, concl);
+              val defs = @{thm branch_def} :: pat_defs;
+              val rules = @{thms match_bind_simps} @ case_rews;
+              val tacs = [asm_simp_tac (beta_ss addsimps rules) 1];
+            in prove thy defs goal (K tacs) end;
+        in map_index pat_app spec end;
+    in
+      val pat_stricts = map pat_strict (pat_consts ~~ spec);
+      val pat_apps = flat (map_index pat_apps (pat_consts ~~ spec));
+    end;
+
+  in
+    (pat_stricts @ pat_apps, thy)
+  end
+
+end
+*}
+
+(*
+Cut from HOLCF/Tools/domain_constructors.ML
+in function add_domain_constructors:
+
+    ( * define and prove theorems for pattern combinators * )
+    val (pat_thms : thm list, thy : theory) =
+      let
+        val bindings = map #1 spec;
+        fun prep_arg (lazy, sel, T) = (lazy, T);
+        fun prep_con c (b, args, mx) = (c, map prep_arg args);
+        val pat_spec = map2 prep_con con_consts spec;
+      in
+        add_pattern_combinators bindings pat_spec lhsT
+          exhaust case_const cases thy
+      end
+
+*)
+
+end

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/HOLCF/ex/Powerdomain_ex.thy	Sat Nov 27 16:08:10 2010 -0800
@@ -0,0 +1,113 @@
+(*  Title:      HOLCF/ex/Powerdomain_ex.thy
+    Author:     Brian Huffman
+*)
+
+header {* Powerdomain examples *}
+
+theory Powerdomain_ex
+imports HOLCF
+begin
+
+subsection {* Monadic sorting example *}
+
+domain ordering = LT | EQ | GT
+
+definition
+  compare :: "int lift \<rightarrow> int lift \<rightarrow> ordering" where
+  "compare = (FLIFT x y. if x < y then LT else if x = y then EQ else GT)"
+
+definition
+  is_le :: "int lift \<rightarrow> int lift \<rightarrow> tr" where
+  "is_le = (\<Lambda> x y. case compare\<cdot>x\<cdot>y of LT \<Rightarrow> TT | EQ \<Rightarrow> TT | GT \<Rightarrow> FF)"
+
+definition
+  is_less :: "int lift \<rightarrow> int lift \<rightarrow> tr" where
+  "is_less = (\<Lambda> x y. case compare\<cdot>x\<cdot>y of LT \<Rightarrow> TT | EQ \<Rightarrow> FF | GT \<Rightarrow> FF)"
+
+definition
+  r1 :: "(int lift \<times> 'a) \<rightarrow> (int lift \<times> 'a) \<rightarrow> tr convex_pd" where
+  "r1 = (\<Lambda> (x,_) (y,_). case compare\<cdot>x\<cdot>y of
+          LT \<Rightarrow> {TT}\<natural> |
+          EQ \<Rightarrow> {TT, FF}\<natural> |
+          GT \<Rightarrow> {FF}\<natural>)"
+
+definition
+  r2 :: "(int lift \<times> 'a) \<rightarrow> (int lift \<times> 'a) \<rightarrow> tr convex_pd" where
+  "r2 = (\<Lambda> (x,_) (y,_). {is_le\<cdot>x\<cdot>y, is_less\<cdot>x\<cdot>y}\<natural>)"
+
+lemma r1_r2: "r1\<cdot>(x,a)\<cdot>(y,b) = (r2\<cdot>(x,a)\<cdot>(y,b) :: tr convex_pd)"
+apply (simp add: r1_def r2_def)
+apply (simp add: is_le_def is_less_def)
+apply (cases "compare\<cdot>x\<cdot>y")
+apply simp_all
+done
+
+
+subsection {* Picking a leaf from a tree *}
+
+domain 'a tree =
+  Node (lazy "'a tree") (lazy "'a tree") |
+  Leaf (lazy "'a")
+
+fixrec
+  mirror :: "'a tree \<rightarrow> 'a tree"
+where
+  mirror_Leaf: "mirror\<cdot>(Leaf\<cdot>a) = Leaf\<cdot>a"
+| mirror_Node: "mirror\<cdot>(Node\<cdot>l\<cdot>r) = Node\<cdot>(mirror\<cdot>r)\<cdot>(mirror\<cdot>l)"
+
+lemma mirror_strict [simp]: "mirror\<cdot>\<bottom> = \<bottom>"
+by fixrec_simp
+
+fixrec
+  pick :: "'a tree \<rightarrow> 'a convex_pd"
+where
+  pick_Leaf: "pick\<cdot>(Leaf\<cdot>a) = {a}\<natural>"
+| pick_Node: "pick\<cdot>(Node\<cdot>l\<cdot>r) = pick\<cdot>l +\<natural> pick\<cdot>r"
+
+lemma pick_strict [simp]: "pick\<cdot>\<bottom> = \<bottom>"
+by fixrec_simp
+
+lemma pick_mirror: "pick\<cdot>(mirror\<cdot>t) = pick\<cdot>t"
+by (induct t) (simp_all add: convex_plus_ac)
+
+fixrec tree1 :: "int lift tree"
+where "tree1 = Node\<cdot>(Node\<cdot>(Leaf\<cdot>(Def 1))\<cdot>(Leaf\<cdot>(Def 2)))
+                   \<cdot>(Node\<cdot>(Leaf\<cdot>(Def 3))\<cdot>(Leaf\<cdot>(Def 4)))"
+
+fixrec tree2 :: "int lift tree"
+where "tree2 = Node\<cdot>(Node\<cdot>(Leaf\<cdot>(Def 1))\<cdot>(Leaf\<cdot>(Def 2)))
+                   \<cdot>(Node\<cdot>\<bottom>\<cdot>(Leaf\<cdot>(Def 4)))"
+
+fixrec tree3 :: "int lift tree"
+where "tree3 = Node\<cdot>(Node\<cdot>(Leaf\<cdot>(Def 1))\<cdot>tree3)
+                   \<cdot>(Node\<cdot>(Leaf\<cdot>(Def 3))\<cdot>(Leaf\<cdot>(Def 4)))"
+
+declare tree1.simps tree2.simps tree3.simps [simp del]
+
+lemma pick_tree1:
+  "pick\<cdot>tree1 = {Def 1, Def 2, Def 3, Def 4}\<natural>"
+apply (subst tree1.simps)
+apply simp
+apply (simp add: convex_plus_ac)
+done
+
+lemma pick_tree2:
+  "pick\<cdot>tree2 = {Def 1, Def 2, \<bottom>, Def 4}\<natural>"
+apply (subst tree2.simps)
+apply simp
+apply (simp add: convex_plus_ac)
+done
+
+lemma pick_tree3:
+  "pick\<cdot>tree3 = {Def 1, \<bottom>, Def 3, Def 4}\<natural>"
+apply (subst tree3.simps)
+apply simp
+apply (induct rule: tree3.induct)
+apply simp
+apply simp
+apply (simp add: convex_plus_ac)
+apply simp
+apply (simp add: convex_plus_ac)
+done
+
+end

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/HOLCF/ex/ROOT.ML	Sat Nov 27 16:08:10 2010 -0800
@@ -0,0 +1,9 @@
+(*  Title:      HOLCF/ex/ROOT.ML
+
+Misc HOLCF examples.
+*)
+
+use_thys ["Dnat", "Dagstuhl", "Focus_ex", "Fix2", "Hoare",
+  "Loop", "Powerdomain_ex", "Domain_Proofs",
+  "Letrec",
+  "Pattern_Match"];

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/HOLCF/ex/hoare.txt	Sat Nov 27 16:08:10 2010 -0800
@@ -0,0 +1,97 @@
+Proves about loops and tail-recursive functions
+===============================================
+
+Problem A
+
+P = while B1       do S od
+Q = while B1 or B2 do S od
+
+Prove P;Q = Q    (provided B1, B2 have no side effects)
+
+------
+
+Looking at the denotational semantics of while, we get
+
+Problem B
+
+[|B1|]:State->Bool
+[|B2|]:State->Bool
+[|S |]:State->State
+f     :State->State
+
+p = fix LAM f.LAM x. if [| B1 |] x                  then f([| S |] x) else x fi
+q = fix LAM f.LAM x. if [| B1 |] x orelse [|b2 |] x then f([| S |] x) else x fi
+
+Prove q o p = q          rsp.       ALL x.q(p(x))=q(x)
+
+Remark: 1. Bool is the three-valued domain {UU,FF,TT} since tests B1 and B2 may
+           not terminate.
+        2. orelse is the sequential or like in ML
+
+----------
+
+If we abstract over the structure of stores we get
+
+Problem C
+
+b1:'a -> Bool
+b2:'a -> Bool
+g :'a ->'a
+h :'a ->'a
+
+p = fix LAM h.LAM x. if b1(x)              then h(g(x)) else x fi
+q = fix LAM h.LAM x. if b1(x) orelse b2(x) then h(g(x)) else x fi
+
+where g is an abstraction of [| S |]
+
+Prove q o p = q 
+
+Remark: there are no restrictions wrt. definedness or strictness for any of 
+        the involved functions.
+
+----------
+
+In a functional programming language the problem reads as follows:
+
+p(x) = if b1(x) 
+         then p(g(x))
+         else x fi
+
+q(x) = if b1(x) orelse b2(x) 
+         then q(g(x))
+         else x fi
+
+
+Prove:  q o p = q
+
+
+-------------
+
+In you like to test the problem in ML (bad guy) you have to introduce 
+formal parameters for b1,b2 and g.
+
+fun p b1 g x = if b1(x) 
+         then p b1 g (g(x))
+         else x;
+
+
+fun q b1 b2 g x = if b1(x) orelse b2(x) 
+         then q b1 b2 g (g(x))
+         else x;
+
+Prove: for all b1 b2 g . 
+            (q b1 b2 g) o (p b1 g) = (q b1 b2 g)
+
+===========
+
+It took 4 person-days to formulate and prove the problem C in the
+Isabelle logic HOLCF. The formalisation was done by conservative extension and
+all proof principles where derived from pure HOLCF.
+
+
+    
+
+
+
+
+

--- a/src/HOL/IsaMakefile	Sat Nov 27 14:34:54 2010 -0800
+++ b/src/HOL/IsaMakefile	Sat Nov 27 16:08:10 2010 -0800
@@ -20,6 +20,8 @@
   HOL-Proofs \
   HOL-Word \
   HOL4 \
+  HOLCF \
+  IOA \
   TLA \
   HOL-Base \
   HOL-Main \
@@ -35,9 +37,18 @@
   HOL-Hahn_Banach \
   HOL-Hoare \
   HOL-Hoare_Parallel \
+      HOLCF-FOCUS \
+      HOLCF-IMP \
+      HOLCF-Library \
+      HOLCF-Tutorial \
+      HOLCF-ex \
   HOL-IMP \
   HOL-IMPP \
   HOL-IOA \
+      IOA-ABP \
+      IOA-NTP \
+      IOA-Storage \
+      IOA-ex \
   HOL-Imperative_HOL \
   HOL-Import \
   HOL-Induct \
@@ -1381,6 +1392,222 @@
 	@$(ISABELLE_TOOL) usedir $(OUT)/HOL Predicate_Compile_Examples
 
 
+## HOLCF
+
+HOLCF: HOL $(OUT)/HOLCF
+
+$(OUT)/HOLCF: $(OUT)/HOL \
+  HOLCF/ROOT.ML \
+  HOLCF/Adm.thy \
+  HOLCF/Algebraic.thy \
+  HOLCF/Bifinite.thy \
+  HOLCF/Cfun.thy \
+  HOLCF/CompactBasis.thy \
+  HOLCF/Completion.thy \
+  HOLCF/Cont.thy \
+  HOLCF/ConvexPD.thy \
+  HOLCF/Cpodef.thy \
+  HOLCF/Cprod.thy \
+  HOLCF/Discrete.thy \
+  HOLCF/Deflation.thy \
+  HOLCF/Domain.thy \
+  HOLCF/Domain_Aux.thy \
+  HOLCF/Fixrec.thy \
+  HOLCF/Fix.thy \
+  HOLCF/Fun_Cpo.thy \
+  HOLCF/HOLCF.thy \
+  HOLCF/Lift.thy \
+  HOLCF/LowerPD.thy \
+  HOLCF/Map_Functions.thy \
+  HOLCF/One.thy \
+  HOLCF/Pcpo.thy \
+  HOLCF/Plain_HOLCF.thy \
+  HOLCF/Porder.thy \
+  HOLCF/Powerdomains.thy \
+  HOLCF/Product_Cpo.thy \
+  HOLCF/Sfun.thy \
+  HOLCF/Sprod.thy \
+  HOLCF/Ssum.thy \
+  HOLCF/Tr.thy \
+  HOLCF/Universal.thy \
+  HOLCF/UpperPD.thy \
+  HOLCF/Up.thy \
+  HOLCF/Tools/cont_consts.ML \
+  HOLCF/Tools/cont_proc.ML \
+  HOLCF/Tools/holcf_library.ML \
+  HOLCF/Tools/Domain/domain.ML \
+  HOLCF/Tools/Domain/domain_axioms.ML \
+  HOLCF/Tools/Domain/domain_constructors.ML \
+  HOLCF/Tools/Domain/domain_induction.ML \
+  HOLCF/Tools/Domain/domain_isomorphism.ML \
+  HOLCF/Tools/Domain/domain_take_proofs.ML \
+  HOLCF/Tools/cpodef.ML \
+  HOLCF/Tools/domaindef.ML \
+  HOLCF/Tools/fixrec.ML \
+  HOLCF/document/root.tex
+	@cd HOLCF; $(ISABELLE_TOOL) usedir -b -g true $(OUT)/HOL HOLCF
+
+
+## HOLCF-Tutorial
+
+HOLCF-Tutorial: HOLCF $(LOG)/HOLCF-Tutorial.gz
+
+$(LOG)/HOLCF-Tutorial.gz: $(OUT)/HOLCF \
+  HOLCF/Tutorial/Domain_ex.thy \
+  HOLCF/Tutorial/Fixrec_ex.thy \
+  HOLCF/Tutorial/New_Domain.thy \
+  HOLCF/Tutorial/document/root.tex \
+  HOLCF/Tutorial/ROOT.ML
+	@$(ISABELLE_TOOL) usedir $(OUT)/HOLCF Tutorial
+
+
+## HOLCF-Library
+
+HOLCF-Library: HOLCF $(LOG)/HOLCF-Library.gz
+
+$(LOG)/HOLCF-Library.gz: $(OUT)/HOLCF \
+  HOLCF/Library/Defl_Bifinite.thy \
+  HOLCF/Library/List_Cpo.thy \
+  HOLCF/Library/Stream.thy \
+  HOLCF/Library/Sum_Cpo.thy \
+  HOLCF/Library/HOLCF_Library.thy \
+  HOLCF/Library/ROOT.ML
+	@$(ISABELLE_TOOL) usedir $(OUT)/HOLCF Library
+
+
+## HOLCF-IMP
+
+HOLCF-IMP: HOLCF $(LOG)/HOLCF-IMP.gz
+
+$(LOG)/HOLCF-IMP.gz: $(OUT)/HOLCF IMP/HoareEx.thy \
+  HOLCF/IMP/Denotational.thy IMP/ROOT.ML IMP/document/root.tex
+	@$(ISABELLE_TOOL) usedir $(OUT)/HOLCF IMP
+
+
+## HOLCF-ex
+
+HOLCF-ex: HOLCF $(LOG)/HOLCF-ex.gz
+
+$(LOG)/HOLCF-ex.gz: $(OUT)/HOLCF \
+  HOLCF/../HOL/Library/Nat_Infinity.thy \
+  HOLCF/ex/Dagstuhl.thy \
+  HOLCF/ex/Dnat.thy \
+  HOLCF/ex/Domain_Proofs.thy \
+  HOLCF/ex/Fix2.thy \
+  HOLCF/ex/Focus_ex.thy \
+  HOLCF/ex/Hoare.thy \
+  HOLCF/ex/Letrec.thy \
+  HOLCF/ex/Loop.thy \
+  HOLCF/ex/Pattern_Match.thy \
+  HOLCF/ex/Powerdomain_ex.thy \
+  HOLCF/ex/ROOT.ML
+	@$(ISABELLE_TOOL) usedir $(OUT)/HOLCF ex
+
+
+## HOLCF-FOCUS
+
+HOLCF-FOCUS: HOLCF $(LOG)/HOLCF-FOCUS.gz
+
+$(LOG)/HOLCF-FOCUS.gz: $(OUT)/HOLCF \
+  HOLCF/Library/Stream.thy \
+  HOLCF/FOCUS/Fstreams.thy \
+  HOLCF/FOCUS/Fstream.thy FOCUS/FOCUS.thy \
+  HOLCF/FOCUS/Stream_adm.thy ../HOL/Library/Continuity.thy \
+  HOLCF/FOCUS/Buffer.thy FOCUS/Buffer_adm.thy
+	@$(ISABELLE_TOOL) usedir $(OUT)/HOLCF FOCUS
+
+## IOA
+
+IOA: HOLCF $(OUT)/IOA
+
+$(OUT)/IOA: $(OUT)/HOLCF \
+  HOLCF/IOA/ROOT.ML \
+  HOLCF/IOA/meta_theory/Traces.thy \
+  HOLCF/IOA/meta_theory/Asig.thy \
+  HOLCF/IOA/meta_theory/CompoScheds.thy \
+  HOLCF/IOA/meta_theory/CompoTraces.thy \
+  HOLCF/IOA/meta_theory/Seq.thy \
+  HOLCF/IOA/meta_theory/RefCorrectness.thy \
+  HOLCF/IOA/meta_theory/Automata.thy \
+  HOLCF/IOA/meta_theory/ShortExecutions.thy \
+  HOLCF/IOA/meta_theory/IOA.thy \
+  HOLCF/IOA/meta_theory/Sequence.thy \
+  HOLCF/IOA/meta_theory/CompoExecs.thy \
+  HOLCF/IOA/meta_theory/RefMappings.thy \
+  HOLCF/IOA/meta_theory/Compositionality.thy \
+  HOLCF/IOA/meta_theory/TL.thy \
+  HOLCF/IOA/meta_theory/TLS.thy \
+  HOLCF/IOA/meta_theory/LiveIOA.thy \
+  HOLCF/IOA/meta_theory/Pred.thy \
+  HOLCF/IOA/meta_theory/Abstraction.thy \
+  HOLCF/IOA/meta_theory/Simulations.thy \
+  HOLCF/IOA/meta_theory/SimCorrectness.thy
+	@cd HOLCF/IOA; $(ISABELLE_TOOL) usedir -b $(OUT)/HOLCF IOA
+
+## IOA-ABP
+
+IOA-ABP: IOA $(LOG)/IOA-ABP.gz
+
+$(LOG)/IOA-ABP.gz: $(OUT)/IOA \
+  HOLCF/IOA/ABP/Abschannel.thy \
+  HOLCF/IOA/ABP/Abschannel_finite.thy \
+  HOLCF/IOA/ABP/Action.thy \
+  HOLCF/IOA/ABP/Check.ML \
+  HOLCF/IOA/ABP/Correctness.thy \
+  HOLCF/IOA/ABP/Env.thy \
+  HOLCF/IOA/ABP/Impl.thy \
+  HOLCF/IOA/ABP/Impl_finite.thy \
+  HOLCF/IOA/ABP/Lemmas.thy \
+  HOLCF/IOA/ABP/Packet.thy \
+  HOLCF/IOA/ABP/ROOT.ML \
+  HOLCF/IOA/ABP/Receiver.thy \
+  HOLCF/IOA/ABP/Sender.thy \
+  HOLCF/IOA/ABP/Spec.thy
+	@cd HOLCF/IOA; $(ISABELLE_TOOL) usedir $(OUT)/IOA ABP
+
+## IOA-NTP
+
+IOA-NTP: IOA $(LOG)/IOA-NTP.gz
+
+$(LOG)/IOA-NTP.gz: $(OUT)/IOA \
+  HOLCF/IOA/NTP/Abschannel.thy \
+  HOLCF/IOA/NTP/Action.thy \
+  HOLCF/IOA/NTP/Correctness.thy \
+  HOLCF/IOA/NTP/Impl.thy \
+  HOLCF/IOA/NTP/Lemmas.thy \
+  HOLCF/IOA/NTP/Multiset.thy \
+  HOLCF/IOA/NTP/Packet.thy \
+  HOLCF/IOA/NTP/ROOT.ML \
+  HOLCF/IOA/NTP/Receiver.thy \
+  HOLCF/IOA/NTP/Sender.thy \
+  HOLCF/IOA/NTP/Spec.thy
+	@cd HOLCF/IOA; $(ISABELLE_TOOL) usedir $(OUT)/IOA NTP
+
+
+## IOA-Storage
+
+IOA-Storage: IOA $(LOG)/IOA-Storage.gz
+
+$(LOG)/IOA-Storage.gz: $(OUT)/IOA \
+  HOLCF/IOA/Storage/Action.thy \
+  HOLCF/IOA/Storage/Correctness.thy \
+  HOLCF/IOA/Storage/Impl.thy \
+  HOLCF/IOA/Storage/ROOT.ML \
+  HOLCF/IOA/Storage/Spec.thy
+	@cd HOLCF/IOA; $(ISABELLE_TOOL) usedir $(OUT)/IOA Storage
+
+
+## IOA-ex
+
+IOA-ex: IOA $(LOG)/IOA-ex.gz
+
+$(LOG)/IOA-ex.gz: $(OUT)/IOA \
+  HOLCF/IOA/ex/ROOT.ML \
+  HOLCF/IOA/ex/TrivEx.thy \
+  HOLCF/IOA/ex/TrivEx2.thy
+	@cd HOLCF/IOA; $(ISABELLE_TOOL) usedir $(OUT)/IOA ex
+
+
 ## clean
 
 clean:
@@ -1419,4 +1646,9 @@
 		$(OUT)/HOL-Main $(OUT)/HOL-Multivariate_Analysis	\
 		$(OUT)/HOL-NSA $(OUT)/HOL-Nominal $(OUT)/HOL-Plain	\
 		$(OUT)/HOL-Probability $(OUT)/HOL-Proofs		\
-		$(OUT)/HOL-Word $(OUT)/HOL4 $(OUT)/TLA
+		$(OUT)/HOL-Word $(OUT)/HOL4 $(OUT)/TLA			\
+		$(OUT)/HOLCF $(LOG)/HOLCF.gz $(LOG)/HOLCF-IMP.gz	\
+		$(LOG)/HOLCF-ex.gz $(LOG)/HOLCF-FOCUS.gz $(OUT)/IOA	\
+		$(LOG)/IOA.gz $(LOG)/IOA-ABP.gz $(LOG)/IOA-NTP.gz	\
+		$(LOG)/IOA-Storage.gz $(LOG)/HOLCF-Library.gz		\
+		$(LOG)/IOA-ex.gz $(LOG)/HOLCF-Tutorial.gz

--- a/src/HOLCF/Adm.thy	Sat Nov 27 14:34:54 2010 -0800
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,193 +0,0 @@
-(*  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

--- a/src/HOLCF/Algebraic.thy	Sat Nov 27 14:34:54 2010 -0800
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,214 +0,0 @@
-(*  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

--- a/src/HOLCF/Bifinite.thy	Sat Nov 27 14:34:54 2010 -0800
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,800 +0,0 @@
-(*  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

--- a/src/HOLCF/Cfun.thy	Sat Nov 27 14:34:54 2010 -0800
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,543 +0,0 @@
-(*  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

--- a/src/HOLCF/CompactBasis.thy	Sat Nov 27 14:34:54 2010 -0800
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,111 +0,0 @@
-(*  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

--- a/src/HOLCF/Completion.thy	Sat Nov 27 14:34:54 2010 -0800
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,433 +0,0 @@
-(*  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

--- a/src/HOLCF/Cont.thy	Sat Nov 27 14:34:54 2010 -0800
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,239 +0,0 @@
-(*  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

--- a/src/HOLCF/ConvexPD.thy	Sat Nov 27 14:34:54 2010 -0800
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,651 +0,0 @@
-(*  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

--- a/src/HOLCF/Cpodef.thy	Sat Nov 27 14:34:54 2010 -0800
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,285 +0,0 @@
-(*  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

--- a/src/HOLCF/Cprod.thy	Sat Nov 27 14:34:54 2010 -0800
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,43 +0,0 @@
-(*  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

--- a/src/HOLCF/Deflation.thy	Sat Nov 27 14:34:54 2010 -0800
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,408 +0,0 @@
-(*  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

--- a/src/HOLCF/Discrete.thy	Sat Nov 27 14:34:54 2010 -0800
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,38 +0,0 @@
-(*  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

--- a/src/HOLCF/Domain.thy	Sat Nov 27 14:34:54 2010 -0800
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,352 +0,0 @@
-(*  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

--- a/src/HOLCF/Domain_Aux.thy	Sat Nov 27 14:34:54 2010 -0800
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,361 +0,0 @@
-(*  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

--- a/src/HOLCF/FOCUS/Buffer.thy	Sat Nov 27 14:34:54 2010 -0800
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,381 +0,0 @@
-(*  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

--- a/src/HOLCF/FOCUS/Buffer_adm.thy	Sat Nov 27 14:34:54 2010 -0800
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,300 +0,0 @@
-(*  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
-
-

--- a/src/HOLCF/FOCUS/FOCUS.thy	Sat Nov 27 14:34:54 2010 -0800
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,29 +0,0 @@
-(*  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

--- a/src/HOLCF/FOCUS/Fstream.thy	Sat Nov 27 14:34:54 2010 -0800
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,263 +0,0 @@
-(*  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

--- a/src/HOLCF/FOCUS/Fstreams.thy	Sat Nov 27 14:34:54 2010 -0800
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,331 +0,0 @@
-(*  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

--- a/src/HOLCF/FOCUS/README.html	Sat Nov 27 14:34:54 2010 -0800
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,22 +0,0 @@
-<!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>

--- a/src/HOLCF/FOCUS/ROOT.ML	Sat Nov 27 14:34:54 2010 -0800
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,1 +0,0 @@
-use_thys ["Fstreams", "FOCUS", "Buffer_adm"];

--- a/src/HOLCF/FOCUS/Stream_adm.thy	Sat Nov 27 14:34:54 2010 -0800
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,225 +0,0 @@
-(*  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

--- a/src/HOLCF/Fix.thy	Sat Nov 27 14:34:54 2010 -0800
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,229 +0,0 @@
-(*  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

--- a/src/HOLCF/Fixrec.thy	Sat Nov 27 14:34:54 2010 -0800
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,252 +0,0 @@
-(*  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

--- a/src/HOLCF/Fun_Cpo.thy	Sat Nov 27 14:34:54 2010 -0800
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,179 +0,0 @@
-(*  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

--- a/src/HOLCF/HOLCF.thy	Sat Nov 27 14:34:54 2010 -0800
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,39 +0,0 @@
-(*  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/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

--- a/src/HOLCF/IMP/Denotational.thy	Sat Nov 27 14:34:54 2010 -0800
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,78 +0,0 @@
-(*  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 "../../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

--- a/src/HOLCF/IMP/HoareEx.thy	Sat Nov 27 14:34:54 2010 -0800
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,33 +0,0 @@
-(*  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

--- a/src/HOLCF/IMP/README.html	Sat Nov 27 14:34:54 2010 -0800
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,18 +0,0 @@
-<!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>

--- a/src/HOLCF/IMP/ROOT.ML	Sat Nov 27 14:34:54 2010 -0800
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,1 +0,0 @@
-use_thys ["HoareEx"];

--- a/src/HOLCF/IMP/document/root.bib	Sat Nov 27 14:34:54 2010 -0800
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,7 +0,0 @@
-@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}}
-

--- a/src/HOLCF/IMP/document/root.tex	Sat Nov 27 14:34:54 2010 -0800
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,36 +0,0 @@
-
-\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}

--- a/src/HOLCF/IOA/ABP/Abschannel.thy	Sat Nov 27 14:34:54 2010 -0800
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,89 +0,0 @@
-(*  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

--- a/src/HOLCF/IOA/ABP/Abschannel_finite.thy	Sat Nov 27 14:34:54 2010 -0800
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,61 +0,0 @@
-(*  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

--- a/src/HOLCF/IOA/ABP/Action.thy	Sat Nov 27 14:34:54 2010 -0800
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,16 +0,0 @@
-(*  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

--- a/src/HOLCF/IOA/ABP/Check.ML	Sat Nov 27 14:34:54 2010 -0800
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,178 +0,0 @@
-(*  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;

--- a/src/HOLCF/IOA/ABP/Correctness.thy	Sat Nov 27 14:34:54 2010 -0800
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,326 +0,0 @@
-(*  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

--- a/src/HOLCF/IOA/ABP/Env.thy	Sat Nov 27 14:34:54 2010 -0800
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,42 +0,0 @@
-(*  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

--- a/src/HOLCF/IOA/ABP/Impl.thy	Sat Nov 27 14:34:54 2010 -0800
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,35 +0,0 @@
-(*  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

--- a/src/HOLCF/IOA/ABP/Impl_finite.thy	Sat Nov 27 14:34:54 2010 -0800
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,37 +0,0 @@
-(*  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

--- a/src/HOLCF/IOA/ABP/Lemmas.thy	Sat Nov 27 14:34:54 2010 -0800
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,44 +0,0 @@
-(*  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))"
-  by (induct l) simp_all
-
-end

--- a/src/HOLCF/IOA/ABP/Packet.thy	Sat Nov 27 14:34:54 2010 -0800
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,22 +0,0 @@
-(*  Title:      HOLCF/IOA/ABP/Packet.thy
-    Author:     Olaf Müller
-*)
-
-header {* Packets *}
-
-theory Packet
-imports Main
-begin
-
-types
-  'msg packet = "bool * 'msg"
-
-definition
-  hdr :: "'msg packet => bool" where
-  "hdr = fst"
-
-definition
-  msg :: "'msg packet => 'msg" where
-  "msg = snd"
-
-end

--- a/src/HOLCF/IOA/ABP/ROOT.ML	Sat Nov 27 14:34:54 2010 -0800
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,7 +0,0 @@
-(*  Title:      HOLCF/IOA/ABP/ROOT.ML
-    Author:     Olaf Mueller
-
-This is the ROOT file for the Alternating Bit Protocol performed in
-I/O-Automata.
-*)
-use_thys ["Correctness"];

--- a/src/HOLCF/IOA/ABP/Read_me	Sat Nov 27 14:34:54 2010 -0800
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,10 +0,0 @@
-Isabelle Verification of the Alternating Bit Protocol by 
-combining IOA with Model Checking
-
--------------------------------------------------------------
-
-Correctness.ML contains the proof of the abstraction from unbounded
-channels to finite ones.
-
-Check.ML contains a simple ModelChecker prototype checking Spec against 
-the finite version of the ABP-protocol.

--- a/src/HOLCF/IOA/ABP/Receiver.thy	Sat Nov 27 14:34:54 2010 -0800
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,57 +0,0 @@
-(*  Title:      HOLCF/IOA/ABP/Receiver.thy
-    Author:     Olaf Müller
-*)
-
-header {* The implementation: receiver *}
-
-theory Receiver
-imports IOA Action Lemmas
-begin
-
-types
-  'm receiver_state = "'m list * bool"  -- {* messages, mode *}
-
-definition
-  rq :: "'m receiver_state => 'm list" where
-  "rq = fst"
-
-definition
-  rbit :: "'m receiver_state => bool" where
-  "rbit = snd"
-
-definition
-  receiver_asig :: "'m action signature" where
-  "receiver_asig =
-    (UN pkt. {R_pkt(pkt)},
-    (UN m. {R_msg(m)}) Un (UN b. {S_ack(b)}),
-    {})"
-
-definition
-  receiver_trans :: "('m action, 'm receiver_state)transition set" where
-  "receiver_trans =
-   {tr. let s = fst(tr);
-            t = snd(snd(tr))
-        in
-        case fst(snd(tr))
-        of
-        Next    =>  False |
-        S_msg(m) => False |
-        R_msg(m) => (rq(s) ~= [])  &
-                     m = hd(rq(s))  &
-                     rq(t) = tl(rq(s))   &
-                    rbit(t)=rbit(s)  |
-        S_pkt(pkt) => False |
-        R_pkt(pkt) => if (hdr(pkt) ~= rbit(s))&rq(s)=[] then
-                           rq(t) = (rq(s)@[msg(pkt)]) &rbit(t) = (~rbit(s)) else
-                           rq(t) =rq(s) & rbit(t)=rbit(s)  |
-        S_ack(b) => b = rbit(s)                        &
-                        rq(t) = rq(s)                    &
-                        rbit(t)=rbit(s) |
-        R_ack(b) => False}"
-
-definition
-  receiver_ioa :: "('m action, 'm receiver_state)ioa" where
-  "receiver_ioa =
-   (receiver_asig, {([],False)}, receiver_trans,{},{})"
-
-end

--- a/src/HOLCF/IOA/ABP/Sender.thy	Sat Nov 27 14:34:54 2010 -0800
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,55 +0,0 @@
-(*  Title:      HOLCF/IOA/ABP/Sender.thy
-    Author:     Olaf Müller
-*)
-
-header {* The implementation: sender *}
-
-theory Sender
-imports IOA Action Lemmas
-begin
-
-types
-  'm sender_state = "'m list  *  bool"  -- {* messages, Alternating Bit *}
-
-definition
-  sq :: "'m sender_state => 'm list" where
-  "sq = fst"
-
-definition
-  sbit :: "'m sender_state => bool" where
-  "sbit = snd"
-
-definition
-  sender_asig :: "'m action signature" where
-  "sender_asig = ((UN m. {S_msg(m)}) Un (UN b. {R_ack(b)}),
-                   UN pkt. {S_pkt(pkt)},
-                   {})"
-
-definition
-  sender_trans :: "('m action, 'm sender_state)transition set" where
-  "sender_trans =
-   {tr. let s = fst(tr);
-            t = snd(snd(tr))
-        in case fst(snd(tr))
-        of
-        Next     => if sq(s)=[] then t=s else False |
-        S_msg(m) => sq(t)=sq(s)@[m]   &
-                    sbit(t)=sbit(s)  |
-        R_msg(m) => False |
-        S_pkt(pkt) => sq(s) ~= []  &
-                       hdr(pkt) = sbit(s)      &
-                      msg(pkt) = hd(sq(s))    &
-                      sq(t) = sq(s)           &
-                      sbit(t) = sbit(s) |
-        R_pkt(pkt) => False |
-        S_ack(b)   => False |
-        R_ack(b)   => if b = sbit(s) then
-                       sq(t)=tl(sq(s)) & sbit(t)=(~sbit(s)) else
-                       sq(t)=sq(s) & sbit(t)=sbit(s)}"
-  
-definition
-  sender_ioa :: "('m action, 'm sender_state)ioa" where
-  "sender_ioa =
-   (sender_asig, {([],True)}, sender_trans,{},{})"
-
-end

--- a/src/HOLCF/IOA/ABP/Spec.thy	Sat Nov 27 14:34:54 2010 -0800
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,37 +0,0 @@
-(*  Title:      HOLCF/IOA/ABP/Spec.thy
-    Author:     Olaf Müller
-*)
-
-header {* The specification of reliable transmission *}
-
-theory Spec
-imports IOA Action
-begin
-
-definition
-  spec_sig :: "'m action signature" where
-  sig_def: "spec_sig = (UN m.{S_msg(m)},
-                       UN m.{R_msg(m)} Un {Next},
-                       {})"
-
-definition
-  spec_trans :: "('m action, 'm list)transition set" where
-  trans_def: "spec_trans =
-   {tr. let s = fst(tr);
-            t = snd(snd(tr))
-        in
-        case fst(snd(tr))
-        of
-        Next =>  t=s |            (* Note that there is condition as in Sender *)
-        S_msg(m) => t = s@[m]  |
-        R_msg(m) => s = (m#t)  |
-        S_pkt(pkt) => False |
-        R_pkt(pkt) => False |
-        S_ack(b) => False |
-        R_ack(b) => False}"
-
-definition
-  spec_ioa :: "('m action, 'm list)ioa" where
-  ioa_def: "spec_ioa = (spec_sig, {[]}, spec_trans)"
-
-end

--- a/src/HOLCF/IOA/NTP/Abschannel.thy	Sat Nov 27 14:34:54 2010 -0800
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,141 +0,0 @@
-(*  Title:      HOL/IOA/NTP/Abschannel.thy
-    Author:     Olaf Müller
-*)
-
-header {* The (faulty) transmission channel (both directions) *}
-
-theory Abschannel
-imports IOA Action
-begin
-
-datatype 'a abs_action = S 'a | R 'a
-
-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 multiset)transition set" where
-  "ch_trans =
-    {tr. let s = fst(tr);
-             t = snd(snd(tr))
-         in
-         case fst(snd(tr))
-           of S(b) => t = addm s b |
-              R(b) => count s b ~= 0 & t = delm s b}"
-
-definition
-  ch_ioa :: "('a abs_action, 'a multiset)ioa" where
-  "ch_ioa = (ch_asig, {{|}}, ch_trans,{},{})"
-
-definition
-  rsch_actions :: "'m action => bool abs_action option" where
-  "rsch_actions (akt) =
-          (case akt of
-           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)) |
-           C_m_s =>  None  |
-           C_m_r =>  None |
-           C_r_s =>  None  |
-           C_r_r(m) => None)"
-
-definition
-  srch_actions :: "'m action =>(bool * 'm) abs_action option" where
-  "srch_actions (akt) =
-          (case akt of
-           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 |
-           C_m_s => None |
-           C_m_r => None |
-           C_r_s => None |
-           C_r_r(m) => None)"
-
-definition
-  srch_ioa :: "('m action, 'm packet multiset)ioa" where
-  "srch_ioa = rename ch_ioa srch_actions"
-
-definition
-  rsch_ioa :: "('m action, bool multiset)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_wfair :: "('m action)set set" where
-  "srch_wfair = wfair_of(srch_ioa)"
-definition
-  srch_sfair :: "('m action)set set" where
-  "srch_sfair = sfair_of(srch_ioa)"
-definition
-  rsch_sfair :: "('m action)set set" where
-  "rsch_sfair = sfair_of(rsch_ioa)"
-definition
-  rsch_wfair :: "('m action)set set" where
-  "rsch_wfair = wfair_of(rsch_ioa)"
-
-definition
-  srch_trans :: "('m action, 'm packet multiset)transition set" where
-  "srch_trans = trans_of(srch_ioa)"
-definition
-  rsch_trans :: "('m action, bool multiset)transition set" where
-  "rsch_trans = trans_of(rsch_ioa)"
-
-
-lemmas unfold_renaming =
-  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 srch_trans_def rsch_trans_def ch_trans_def starts_of_def
-  trans_of_def asig_projections
-
-lemma in_srch_asig: 
-     "S_msg(m) ~: actions(srch_asig)        &     
-       R_msg(m) ~: actions(srch_asig)        &     
-       S_pkt(pkt) : actions(srch_asig)    &     
-       R_pkt(pkt) : actions(srch_asig)    &     
-       S_ack(b) ~: actions(srch_asig)     &     
-       R_ack(b) ~: actions(srch_asig)     &     
-       C_m_s ~: actions(srch_asig)           &     
-       C_m_r ~: actions(srch_asig)           &     
-       C_r_s ~: actions(srch_asig)  & C_r_r(m) ~: actions(srch_asig)"
-  by (simp add: unfold_renaming)
-
-lemma in_rsch_asig: 
-      "S_msg(m) ~: actions(rsch_asig)         &  
-       R_msg(m) ~: actions(rsch_asig)         &  
-       S_pkt(pkt) ~: actions(rsch_asig)    &  
-       R_pkt(pkt) ~: actions(rsch_asig)    &  
-       S_ack(b) : actions(rsch_asig)       &  
-       R_ack(b) : actions(rsch_asig)       &  
-       C_m_s ~: actions(rsch_asig)            &  
-       C_m_r ~: actions(rsch_asig)            &  
-       C_r_s ~: actions(rsch_asig)            &  
-       C_r_r(m) ~: actions(rsch_asig)"
-  by (simp add: unfold_renaming)
-
-lemma srch_ioa_thm: "srch_ioa =  
-    (srch_asig, {{|}}, srch_trans,srch_wfair,srch_sfair)"
-apply (simp (no_asm) add: srch_asig_def srch_trans_def asig_of_def trans_of_def wfair_of_def sfair_of_def srch_wfair_def srch_sfair_def)
-apply (simp (no_asm) add: unfold_renaming)
-done
-
-lemma rsch_ioa_thm: "rsch_ioa =  
-     (rsch_asig, {{|}}, rsch_trans,rsch_wfair,rsch_sfair)"
-apply (simp (no_asm) add: rsch_asig_def rsch_trans_def asig_of_def trans_of_def wfair_of_def sfair_of_def rsch_wfair_def rsch_sfair_def)
-apply (simp (no_asm) add: unfold_renaming)
-done
-
-end

--- a/src/HOLCF/IOA/NTP/Action.thy	Sat Nov 27 14:34:54 2010 -0800
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,16 +0,0 @@
-(*  Title:      HOL/IOA/NTP/Action.thy
-    Author:     Tobias Nipkow & Konrad Slind
-*)
-
-header {* The set of all actions of the system *}
-
-theory Action
-imports Packet
-begin
-
-datatype 'm action = S_msg 'm | R_msg 'm
-                   | S_pkt "'m packet" | R_pkt "'m packet"
-                   | S_ack bool | R_ack bool
-                   | C_m_s | C_m_r | C_r_s | C_r_r 'm
-
-end

--- a/src/HOLCF/IOA/NTP/Correctness.thy	Sat Nov 27 14:34:54 2010 -0800
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,105 +0,0 @@
-(*  Title:      HOL/IOA/NTP/Correctness.thy
-    Author:     Tobias Nipkow & Konrad Slind
-*)
-
-header {* The main correctness proof: Impl implements Spec *}
-
-theory Correctness
-imports Impl Spec
-begin
-
-definition
-  hom :: "'m impl_state => 'm list" where
-  "hom s = rq(rec(s)) @ (if rbit(rec s) = sbit(sen s) then sq(sen s)
-                         else tl(sq(sen s)))"
-
-declaration {* fn _ =>
-  (* repeated from Traces.ML *)
-  Classical.map_cs (fn cs => cs delSWrapper "split_all_tac")
-*}
-
-lemmas hom_ioas = Spec.ioa_def Spec.trans_def sender_trans_def receiver_trans_def impl_ioas
-  and impl_asigs = sender_asig_def receiver_asig_def srch_asig_def rsch_asig_def
-
-declare split_paired_All [simp del]
-
-
-text {*
-  A lemma about restricting the action signature of the implementation
-  to that of the specification.
-*}
-
-lemma externals_lemma: 
- "a:externals(asig_of(Automata.restrict impl_ioa (externals spec_sig))) =  
-  (case a of                   
-      S_msg(m) => True         
-    | R_msg(m) => True         
-    | S_pkt(pkt) => False   
-    | R_pkt(pkt) => False   
-    | S_ack(b) => False     
-    | R_ack(b) => False     
-    | C_m_s => False           
-    | C_m_r => False           
-    | C_r_s => False           
-    | C_r_r(m) => False)"
- apply (simp (no_asm) add: externals_def restrict_def restrict_asig_def Spec.sig_def asig_projections)
-
-  apply (induct_tac "a")
-  apply (simp_all (no_asm) add: actions_def asig_projections)
-  txt {* 2 *}
-  apply (simp (no_asm) add: impl_ioas)
-  apply (simp (no_asm) add: impl_asigs)
-  apply (simp (no_asm) add: asig_of_par asig_comp_def asig_projections)
-  apply (simp (no_asm) add: "transitions"(1) unfold_renaming)
-  txt {* 1 *}
-  apply (simp (no_asm) add: impl_ioas)
-  apply (simp (no_asm) add: impl_asigs)
-  apply (simp (no_asm) add: asig_of_par asig_comp_def asig_projections)
-  done
-
-lemmas sels = sbit_def sq_def ssending_def rbit_def rq_def rsending_def
-
-
-text {* Proof of correctness *}
-lemma ntp_correct:
-  "is_weak_ref_map hom (Automata.restrict impl_ioa (externals spec_sig)) spec_ioa"
-apply (unfold Spec.ioa_def is_weak_ref_map_def)
-apply (simp (no_asm) cong del: if_weak_cong split del: split_if add: Correctness.hom_def
-  cancel_restrict externals_lemma)
-apply (rule conjI)
- apply (simp (no_asm) add: hom_ioas)
- apply (simp (no_asm_simp) add: sels)
-apply (rule allI)+
-apply (rule imp_conj_lemma)
-
-apply (induct_tac "a")
-apply (simp_all (no_asm_simp) add: hom_ioas)
-apply (frule inv4)
-apply force
-
-apply (frule inv4)
-apply (frule inv2)
-apply (erule disjE)
-apply (simp (no_asm_simp))
-apply force
-
-apply (frule inv2)
-apply (erule disjE)
-
-apply (frule inv3)
-apply (case_tac "sq (sen (s))=[]")
-
-apply (simp add: hom_ioas)
-apply (blast dest!: add_leD1 [THEN leD])
-
-apply (case_tac "m = hd (sq (sen (s)))")
-
-apply force
-
-apply simp
-apply (blast dest!: add_leD1 [THEN leD])
-
-apply simp
-done
-
-end

--- a/src/HOLCF/IOA/NTP/Impl.thy	Sat Nov 27 14:34:54 2010 -0800
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,356 +0,0 @@
-(*  Title:      HOL/IOA/NTP/Impl.thy
-    Author:     Tobias Nipkow & Konrad Slind
-*)
-
-header {* The implementation *}
-
-theory Impl
-imports Sender Receiver Abschannel
-begin
-
-types 'm impl_state
-  = "'m sender_state * 'm receiver_state * 'm packet multiset * bool multiset"
-  (*  sender_state   *  receiver_state   *    srch_state      * rsch_state *)
-
-
-definition
-  impl_ioa :: "('m action, 'm impl_state)ioa" where
-  impl_def: "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 multiset" where "srch = fst o snd o snd"
-definition rsch :: "'m impl_state => bool multiset" where "rsch = snd o snd o snd"
-
-definition
-  hdr_sum :: "'m packet multiset => bool => nat" where
-  "hdr_sum M b == countm M (%pkt. hdr(pkt) = b)"
-
-(* Lemma 5.1 *)
-definition
-  "inv1(s) ==
-     (!b. count (rsent(rec s)) b = count (srcvd(sen s)) b + count (rsch s) b)
-   & (!b. count (ssent(sen s)) b
-          = hdr_sum (rrcvd(rec s)) b + hdr_sum (srch s) b)"
-
-(* Lemma 5.2 *)
-definition
-  "inv2(s) ==
-  (rbit(rec(s)) = sbit(sen(s)) &
-   ssending(sen(s)) &
-   count (rsent(rec s)) (~sbit(sen s)) <= count (ssent(sen s)) (~sbit(sen s)) &
-   count (ssent(sen s)) (~sbit(sen s)) <= count (rsent(rec s)) (sbit(sen s)))
-   |
-  (rbit(rec(s)) = (~sbit(sen(s))) &
-   rsending(rec(s)) &
-   count (ssent(sen s)) (~sbit(sen s)) <= count (rsent(rec s)) (sbit(sen s)) &
-   count (rsent(rec s)) (sbit(sen s)) <= count (ssent(sen s)) (sbit(sen s)))"
-
-(* Lemma 5.3 *)
-definition
-  "inv3(s) ==
-   rbit(rec(s)) = sbit(sen(s))
-   --> (!m. sq(sen(s))=[] | m ~= hd(sq(sen(s)))
-        -->  count (rrcvd(rec s)) (sbit(sen(s)),m)
-             + count (srch s) (sbit(sen(s)),m)
-            <= count (rsent(rec s)) (~sbit(sen s)))"
-
-(* Lemma 5.4 *)
-definition "inv4(s) == rbit(rec(s)) = (~sbit(sen(s))) --> sq(sen(s)) ~= []"
-
-
-subsection {* Invariants *}
-
-declare le_SucI [simp]
-
-lemmas impl_ioas =
-  impl_def sender_ioa_def receiver_ioa_def srch_ioa_thm [THEN eq_reflection]
-  rsch_ioa_thm [THEN eq_reflection]
-
-lemmas "transitions" =
-  sender_trans_def receiver_trans_def srch_trans_def rsch_trans_def
-
-
-lemmas [simp] =
-  ioa_triple_proj starts_of_par trans_of_par4 in_sender_asig
-  in_receiver_asig in_srch_asig in_rsch_asig
-
-declare let_weak_cong [cong]
-
-lemma [simp]:
-  "fst(x) = sen(x)"
-  "fst(snd(x)) = rec(x)"
-  "fst(snd(snd(x))) = srch(x)"
-  "snd(snd(snd(x))) = rsch(x)"
-  by (simp_all add: sen_def rec_def srch_def rsch_def)
-
-lemma [simp]:
-  "a:actions(sender_asig)
-  | a:actions(receiver_asig)
-  | a:actions(srch_asig)
-  | a:actions(rsch_asig)"
-  by (induct a) simp_all
-
-declare split_paired_All [simp del]
-
-
-(* Three Simp_sets in different sizes
-----------------------------------------------
-
-1) simpset() does not unfold the transition relations
-2) ss unfolds transition relations
-3) renname_ss unfolds transitions and the abstract channel *)
-
-ML {*
-val ss = @{simpset} addsimps @{thms "transitions"};
-val rename_ss = ss addsimps @{thms unfold_renaming};
-
-val tac     = asm_simp_tac (ss addcongs [@{thm conj_cong}] addsplits [@{thm split_if}])
-val tac_ren = asm_simp_tac (rename_ss addcongs [@{thm conj_cong}] addsplits [@{thm split_if}])
-*}
-
-
-subsubsection {* Invariant 1 *}
-
-lemma raw_inv1: "invariant impl_ioa inv1"
-
-apply (unfold impl_ioas)
-apply (rule invariantI)
-apply (simp add: inv1_def hdr_sum_def srcvd_def ssent_def rsent_def rrcvd_def)
-
-apply (simp (no_asm) del: trans_of_par4 add: imp_conjR inv1_def)
-
-txt {* Split proof in two *}
-apply (rule conjI)
-
-(* First half *)
-apply (simp add: Impl.inv1_def split del: split_if)
-apply (induct_tac a)
-
-apply (tactic "EVERY1[tac, tac, tac, tac]")
-apply (tactic "tac 1")
-apply (tactic "tac_ren 1")
-
-txt {* 5 + 1 *}
-
-apply (tactic "tac 1")
-apply (tactic "tac_ren 1")
-
-txt {* 4 + 1 *}
-apply (tactic {* EVERY1[tac, tac, tac, tac] *})
-
-
-txt {* Now the other half *}
-apply (simp add: Impl.inv1_def split del: split_if)
-apply (induct_tac a)
-apply (tactic "EVERY1 [tac, tac]")
-
-txt {* detour 1 *}
-apply (tactic "tac 1")
-apply (tactic "tac_ren 1")
-apply (rule impI)
-apply (erule conjE)+
-apply (simp (no_asm_simp) add: hdr_sum_def Multiset.count_def Multiset.countm_nonempty_def
-  split add: split_if)
-txt {* detour 2 *}
-apply (tactic "tac 1")
-apply (tactic "tac_ren 1")
-apply (rule impI)
-apply (erule conjE)+
-apply (simp add: Impl.hdr_sum_def Multiset.count_def Multiset.countm_nonempty_def
-  Multiset.delm_nonempty_def split add: split_if)
-apply (rule allI)
-apply (rule conjI)
-apply (rule impI)
-apply hypsubst
-apply (rule pred_suc [THEN iffD1])
-apply (drule less_le_trans)
-apply (cut_tac eq_packet_imp_eq_hdr [unfolded Packet.hdr_def, THEN countm_props])
-apply assumption
-apply assumption
-
-apply (rule countm_done_delm [THEN mp, symmetric])
-apply (rule refl)
-apply (simp (no_asm_simp) add: Multiset.count_def)
-
-apply (rule impI)
-apply (simp add: neg_flip)
-apply hypsubst
-apply (rule countm_spurious_delm)
-apply (simp (no_asm))
-
-apply (tactic "EVERY1 [tac, tac, tac, tac, tac, tac]")
-
-done
-
-
-
-subsubsection {* INVARIANT 2 *}
-
-lemma raw_inv2: "invariant impl_ioa inv2"
-
-  apply (rule invariantI1)
-  txt {* Base case *}
-  apply (simp add: inv2_def receiver_projections sender_projections impl_ioas)
-
-  apply (simp (no_asm_simp) add: impl_ioas split del: split_if)
-  apply (induct_tac "a")
-
-  txt {* 10 cases. First 4 are simple, since state doesn't change *}
-
-  ML_prf {* val tac2 = asm_full_simp_tac (ss addsimps [@{thm inv2_def}]) *}
-
-  txt {* 10 - 7 *}
-  apply (tactic "EVERY1 [tac2,tac2,tac2,tac2]")
-  txt {* 6 *}
-  apply (tactic {* forward_tac [rewrite_rule [@{thm Impl.inv1_def}]
-                               (@{thm raw_inv1} RS @{thm invariantE}) RS conjunct1] 1 *})
-
-  txt {* 6 - 5 *}
-  apply (tactic "EVERY1 [tac2,tac2]")
-
-  txt {* 4 *}
-  apply (tactic {* forward_tac [rewrite_rule [@{thm Impl.inv1_def}]
-                                (@{thm raw_inv1} RS @{thm invariantE}) RS conjunct1] 1 *})
-  apply (tactic "tac2 1")
-
-  txt {* 3 *}
-  apply (tactic {* forward_tac [rewrite_rule [@{thm Impl.inv1_def}]
-    (@{thm raw_inv1} RS @{thm invariantE})] 1 *})
-
-  apply (tactic "tac2 1")
-  apply (tactic {* fold_goals_tac [rewrite_rule [@{thm Packet.hdr_def}]
-    (@{thm Impl.hdr_sum_def})] *})
-  apply arith
-
-  txt {* 2 *}
-  apply (tactic "tac2 1")
-  apply (tactic {* forward_tac [rewrite_rule [@{thm Impl.inv1_def}]
-                               (@{thm raw_inv1} RS @{thm invariantE}) RS conjunct1] 1 *})
-  apply (intro strip)
-  apply (erule conjE)+
-  apply simp
-
-  txt {* 1 *}
-  apply (tactic "tac2 1")
-  apply (tactic {* forward_tac [rewrite_rule [@{thm Impl.inv1_def}]
-                               (@{thm raw_inv1} RS @{thm invariantE}) RS conjunct2] 1 *})
-  apply (intro strip)
-  apply (erule conjE)+
-  apply (tactic {* fold_goals_tac [rewrite_rule [@{thm Packet.hdr_def}] (@{thm Impl.hdr_sum_def})] *})
-  apply simp
-
-  done
-
-
-subsubsection {* INVARIANT 3 *}
-
-lemma raw_inv3: "invariant impl_ioa inv3"
-
-  apply (rule invariantI)
-  txt {* Base case *}
-  apply (simp add: Impl.inv3_def receiver_projections sender_projections impl_ioas)
-
-  apply (simp (no_asm_simp) add: impl_ioas split del: split_if)
-  apply (induct_tac "a")
-
-  ML_prf {* val tac3 = asm_full_simp_tac (ss addsimps [@{thm inv3_def}]) *}
-
-  txt {* 10 - 8 *}
-
-  apply (tactic "EVERY1[tac3,tac3,tac3]")
-
-  apply (tactic "tac_ren 1")
-  apply (intro strip, (erule conjE)+)
-  apply hypsubst
-  apply (erule exE)
-  apply simp
-
-  txt {* 7 *}
-  apply (tactic "tac3 1")
-  apply (tactic "tac_ren 1")
-  apply force
-
-  txt {* 6 - 3 *}
-
-  apply (tactic "EVERY1[tac3,tac3,tac3,tac3]")
-
-  txt {* 2 *}
-  apply (tactic "asm_full_simp_tac ss 1")
-  apply (simp (no_asm) add: inv3_def)
-  apply (intro strip, (erule conjE)+)
-  apply (rule imp_disjL [THEN iffD1])
-  apply (rule impI)
-  apply (tactic {* forward_tac [rewrite_rule [@{thm Impl.inv2_def}]
-    (@{thm raw_inv2} RS @{thm invariantE})] 1 *})
-  apply simp
-  apply (erule conjE)+
-  apply (rule_tac j = "count (ssent (sen s)) (~sbit (sen s))" and
-    k = "count (rsent (rec s)) (sbit (sen s))" in le_trans)
-  apply (tactic {* forward_tac [rewrite_rule [@{thm inv1_def}]
-                                (@{thm raw_inv1} RS @{thm invariantE}) RS conjunct2] 1 *})
-  apply (simp add: hdr_sum_def Multiset.count_def)
-  apply (rule add_le_mono)
-  apply (rule countm_props)
-  apply (simp (no_asm))
-  apply (rule countm_props)
-  apply (simp (no_asm))
-  apply assumption
-
-  txt {* 1 *}
-  apply (tactic "tac3 1")
-  apply (intro strip, (erule conjE)+)
-  apply (rule imp_disjL [THEN iffD1])
-  apply (rule impI)
-  apply (tactic {* forward_tac [rewrite_rule [@{thm Impl.inv2_def}]
-    (@{thm raw_inv2} RS @{thm invariantE})] 1 *})
-  apply simp
-  done
-
-
-subsubsection {* INVARIANT 4 *}
-
-lemma raw_inv4: "invariant impl_ioa inv4"
-
-  apply (rule invariantI)
-  txt {* Base case *}
-  apply (simp add: Impl.inv4_def receiver_projections sender_projections impl_ioas)
-
-  apply (simp (no_asm_simp) add: impl_ioas split del: split_if)
-  apply (induct_tac "a")
-
-  ML_prf {* val tac4 =  asm_full_simp_tac (ss addsimps [@{thm inv4_def}]) *}
-
-  txt {* 10 - 2 *}
-
-  apply (tactic "EVERY1[tac4,tac4,tac4,tac4,tac4,tac4,tac4,tac4,tac4]")
-
-  txt {* 2 b *}
-
-  apply (intro strip, (erule conjE)+)
-  apply (tactic {* forward_tac [rewrite_rule [@{thm Impl.inv2_def}]
-                               (@{thm raw_inv2} RS @{thm invariantE})] 1 *})
-  apply simp
-
-  txt {* 1 *}
-  apply (tactic "tac4 1")
-  apply (intro strip, (erule conjE)+)
-  apply (rule ccontr)
-  apply (tactic {* forward_tac [rewrite_rule [@{thm Impl.inv2_def}]
-                               (@{thm raw_inv2} RS @{thm invariantE})] 1 *})
-  apply (tactic {* forward_tac [rewrite_rule [@{thm Impl.inv3_def}]
-                               (@{thm raw_inv3} RS @{thm invariantE})] 1 *})
-  apply simp
-  apply (erule_tac x = "m" in allE)
-  apply simp
-  done
-
-
-text {* rebind them *}
-
-lemmas inv1 = raw_inv1 [THEN invariantE, unfolded inv1_def]
-  and inv2 = raw_inv2 [THEN invariantE, unfolded inv2_def]
-  and inv3 = raw_inv3 [THEN invariantE, unfolded inv3_def]
-  and inv4 = raw_inv4 [THEN invariantE, unfolded inv4_def]
-
-end

--- a/src/HOLCF/IOA/NTP/Lemmas.thy	Sat Nov 27 14:34:54 2010 -0800
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,32 +0,0 @@
-(*  Title:      HOL/IOA/NTP/Lemmas.thy
-    Author:     Tobias Nipkow & Konrad Slind
-*)
-
-theory Lemmas
-imports Main
-begin
-
-subsubsection {* Logic *}
-
-lemma neg_flip: "(X = (~ Y)) = ((~X) = Y)"
-  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
-
-
-subsection {* Arithmetic *}
-
-lemma pred_suc: "0<x ==> (x - 1 = y) = (x = Suc(y))"
-  by (simp add: diff_Suc split add: nat.split)
-
-lemmas [simp] = hd_append set_lemmas
-
-end

--- a/src/HOLCF/IOA/NTP/Multiset.thy	Sat Nov 27 14:34:54 2010 -0800
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,95 +0,0 @@
-(*  Title:      HOL/IOA/NTP/Multiset.thy
-    Author:     Tobias Nipkow & Konrad Slind
-*)
-
-header {* Axiomatic multisets *}
-
-theory Multiset
-imports Lemmas
-begin
-
-typedecl
-  'a multiset
-
-consts
-
-  "{|}"  :: "'a multiset"                        ("{|}")
-  addm   :: "['a multiset, 'a] => 'a multiset"
-  delm   :: "['a multiset, 'a] => 'a multiset"
-  countm :: "['a multiset, 'a => bool] => nat"
-  count  :: "['a multiset, 'a] => nat"
-
-axioms
-
-delm_empty_def:
-  "delm {|} x = {|}"
-
-delm_nonempty_def:
-  "delm (addm M x) y == (if x=y then M else addm (delm M y) x)"
-
-countm_empty_def:
-   "countm {|} P == 0"
-
-countm_nonempty_def:
-   "countm (addm M x) P == countm M P + (if P x then Suc 0 else 0)"
-
-count_def:
-   "count M x == countm M (%y. y = x)"
-
-"induction":
-   "[| P({|}); !!M x. P(M) ==> P(addm M x) |] ==> P(M)"
-
-lemma count_empty: 
-   "count {|} x = 0"
-  by (simp add: Multiset.count_def Multiset.countm_empty_def)
-
-lemma count_addm_simp: 
-     "count (addm M x) y = (if y=x then Suc(count M y) else count M y)"
-  by (simp add: Multiset.count_def Multiset.countm_nonempty_def)
-
-lemma count_leq_addm: "count M y <= count (addm M x) y"
-  by (simp add: count_addm_simp)
-
-lemma count_delm_simp: 
-     "count (delm M x) y = (if y=x then count M y - 1 else count M y)"
-apply (unfold Multiset.count_def)
-apply (rule_tac M = "M" in Multiset.induction)
-apply (simp (no_asm_simp) add: Multiset.delm_empty_def Multiset.countm_empty_def)
-apply (simp add: Multiset.delm_nonempty_def Multiset.countm_nonempty_def)
-apply safe
-apply simp
-done
-
-lemma countm_props: "!!M. (!x. P(x) --> Q(x)) ==> (countm M P <= countm M Q)"
-apply (rule_tac M = "M" in Multiset.induction)
- apply (simp (no_asm) add: Multiset.countm_empty_def)
-apply (simp (no_asm) add: Multiset.countm_nonempty_def)
-apply auto
-done
-
-lemma countm_spurious_delm: "!!P. ~P(obj) ==> countm M P = countm (delm M obj) P"
-  apply (rule_tac M = "M" in Multiset.induction)
-  apply (simp (no_asm) add: Multiset.delm_empty_def Multiset.countm_empty_def)
-  apply (simp (no_asm_simp) add: Multiset.countm_nonempty_def Multiset.delm_nonempty_def)
-  done
-
-
-lemma pos_count_imp_pos_countm [rule_format (no_asm)]: "!!P. P(x) ==> 0<count M x --> countm M P > 0"
-  apply (rule_tac M = "M" in Multiset.induction)
-  apply (simp (no_asm) add: Multiset.delm_empty_def Multiset.count_def Multiset.countm_empty_def)
-  apply (simp add: Multiset.count_def Multiset.delm_nonempty_def Multiset.countm_nonempty_def)
-  done
-
-lemma countm_done_delm: 
-   "!!P. P(x) ==> 0<count M x --> countm (delm M x) P = countm M P - 1"
-  apply (rule_tac M = "M" in Multiset.induction)
-  apply (simp (no_asm) add: Multiset.delm_empty_def Multiset.countm_empty_def)
-  apply (simp (no_asm_simp) add: count_addm_simp Multiset.delm_nonempty_def Multiset.countm_nonempty_def pos_count_imp_pos_countm)
-  apply auto
-  done
-
-
-declare count_addm_simp [simp] count_delm_simp [simp]
-  Multiset.countm_empty_def [simp] Multiset.delm_empty_def [simp] count_empty [simp]
-
-end

--- a/src/HOLCF/IOA/NTP/Packet.thy	Sat Nov 27 14:34:54 2010 -0800
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,27 +0,0 @@
-(*  Title:      HOL/IOA/NTP/Packet.thy
-    Author:     Tobias Nipkow & Konrad Slind
-*)
-
-theory Packet
-imports Multiset
-begin
-
-types
-  'msg packet = "bool * 'msg"
-
-definition
-  hdr :: "'msg packet => bool" where
-  "hdr == fst"
-
-definition
-  msg :: "'msg packet => 'msg" where
-  "msg == snd"
-
-
-text {* Instantiation of a tautology? *}
-lemma eq_packet_imp_eq_hdr: "!x. x = packet --> hdr(x) = hdr(packet)"
-  by simp
-
-declare hdr_def [simp] msg_def [simp]
-
-end

--- a/src/HOLCF/IOA/NTP/ROOT.ML	Sat Nov 27 14:34:54 2010 -0800
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,9 +0,0 @@
-(*  Title:      HOLCF/IOA/NTP/ROOT.ML
-    Author:     Tobias Nipkow & Konrad Slind
-
-This is the ROOT file for a network transmission protocol (NTP
-subdirectory), performed in the I/O automata formalization by Olaf
-Mueller.
-*)
-
-use_thys ["Correctness"];

--- a/src/HOLCF/IOA/NTP/Read_me	Sat Nov 27 14:34:54 2010 -0800
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,167 +0,0 @@
-Isabelle Verification of a protocol using IOA.
-
-------------------------------------------------------------------------------
-
-The System.
-
-The system being proved correct is a parallel composition of 4 processes:
-
-    Sender || Schannel || Receiver || Rchannel
-
-Accordingly, the system state is a 4-tuple:
-
-    (Sender_state, Schannel_state, Receiver_state, Rchannel_state)
-
-------------------------------------------------------------------------------
-Packets.
-
-The objects going over the medium from Sender to Receiver are modelled
-with the type
-
-    'm packet = bool * 'm
-
-This expresses that messages (modelled by polymorphic type "'m") are
-sent with a single header bit. Packet fields are accessed by
-
-    hdr<b,m> = b
-    mesg<b,m> = m
-------------------------------------------------------------------------------
-
-The Sender.
-
-The state of the process "Sender" is a 5-tuple:
-
-     1. messages : 'm list        (* sq *)
-     2. sent     : bool multiset  (* ssent *)
-     3. received : bool multiset  (* srcvd *)
-     4. header   : bool           (* sbit *)
-     5. mode     : bool           (* ssending *)
-
-
-The Receiver.
-
-The state of the process "Receiver" is a 5-tuple:
-
-     1. messages    : 'm list              (* rq *)
-     2. replies     : bool multiset        (* rsent *)
-     3. received    : 'm packet multiset   (* rrcvd *)
-     4. header      : bool                 (* rbit *)
-     5. mode        : bool                 (* rsending *)
-
-
-The Channels.
-
-The Sender and Receiver each have a proprietary channel, named
-"Schannel" and "Rchannel" respectively. The messages sent by the Sender
-and Receiver are never lost, but the channels may mix them
-up. Accordingly, multisets are used in modelling the state of the
-channels. The state of "Schannel" is modelled with the following type:
-
-    'm packet multiset
-
-The state of "Rchannel" is modelled with the following type:
-
-    bool multiset
-
-This expresses that replies from the Receiver are just one bit.
-
-Both Channels are instances of an abstract channel, that is modelled with
-the type 
-  
-    'a multiset.
-
-------------------------------------------------------------------------------
-
-The events.
-
-An `execution' of the system is modelled by a sequence of 
-
-    <system_state, action, system_state>
-
-transitions. The actions, or events, of the system are described by the
-following ML-style datatype declaration:
-
-    'm action = S_msg ('m)           (* Rqt for Sender to send mesg      *)
-              | R_msg ('m)           (* Mesg taken from Receiver's queue *)
-              | S_pkt_sr ('m packet) (* Packet arrives in Schannel       *)
-              | R_pkt_sr ('m packet) (* Packet leaves Schannel           *)
-              | S_pkt_rs (bool)      (* Packet arrives in Rchannel       *)
-              | R_pkt_rs (bool)      (* Packet leaves Rchannel           *)
-              | C_m_s                (* Change mode in Sender            *)
-              | C_m_r                (* Change mode in Receiver          *)
-              | C_r_s                (* Change round in Sender           *)
-              | C_r_r ('m)           (* Change round in Receiver         *)
-
-------------------------------------------------------------------------------
-
-The Specification.
-
-The abstract description of system behaviour is given by defining an
-IO/automaton named "Spec". The state of Spec is a message queue,
-modelled as an "'m list". The only actions performed in the abstract
-system are: "S_msg(m)" (putting message "m" at the end of the queue);
-and "R_msg(m)" (taking message "m" from the head of the queue).
-
-
-------------------------------------------------------------------------------
-
-The Verification.
-
-The verification proceeds by showing that a certain mapping ("hom") from
-the concrete system state to the abstract system state is a `weak
-possibilities map` from "Impl" to "Spec". 
-
-
-    hom : (S_state * Sch_state * R_state * Rch_state) -> queue
-
-The verification depends on several system invariants that relate the
-states of the 4 processes. These invariants must hold in all reachable
-states of the system. These invariants are difficult to make sense of;
-however, we attempt to give loose English paraphrases of them.
-
-Invariant 1.
-
-This expresses that no packets from the Receiver to the Sender are
-dropped by Rchannel. The analogous statement for Schannel is also true.
-
-    !b. R.replies b = S.received b + Rch b 
-    /\
-    !pkt. S.sent(hdr(pkt)) = R.received(hdr(b)) + Sch(pkt)
-
-
-Invariant 2.
-
-This expresses a complicated relationship about how many messages are
-sent and header bits.
-
-    R.header = S.header 
-    /\ S.mode = SENDING
-    /\ R.replies (flip S.header) <= S.sent (flip S.header)
-    /\ S.sent (flip S.header) <= R.replies header
-    OR
-    R.header = flip S.header
-    /\ R.mode = SENDING
-    /\ S.sent (flip S.header) <= R.replies S.header
-    /\ R.replies S.header <= S.sent S.header
-
-
-Invariant 3.
-
-The number of incoming messages in the Receiver plus the number of those
-messages in transit (in Schannel) is not greater than the number of
-replies, provided the message isn't current and the header bits agree.
-
-    let mesg = <S.header, m>
-    in
-    R.header = S.header
-    ==>
-    !m. (S.messages = [] \/ m ~= hd S.messages)
-        ==> R.received mesg + Sch mesg <= R.replies (flip S.header)
-
-
-Invariant 4.
-
-If the headers are opposite, then the Sender queue has a message in it.
-
-    R.header = flip S.header ==> S.messages ~= []
-

--- a/src/HOLCF/IOA/NTP/Receiver.thy	Sat Nov 27 14:34:54 2010 -0800
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,96 +0,0 @@
-(*  Title:      HOL/IOA/NTP/Receiver.thy
-    Author:     Tobias Nipkow & Konrad Slind
-*)
-
-header {* The implementation: receiver *}
-
-theory Receiver
-imports IOA Action
-begin
-
-types
-
-'m receiver_state
-= "'m list * bool multiset * 'm packet multiset * bool * bool"
-(* messages  #replies        #received            header mode *)
-
-definition rq :: "'m receiver_state => 'm list" where "rq == fst"
-definition rsent :: "'m receiver_state => bool multiset" where "rsent == fst o snd"
-definition rrcvd :: "'m receiver_state => 'm packet multiset" where "rrcvd == fst o snd o snd"
-definition rbit :: "'m receiver_state => bool" where "rbit == fst o snd o snd o snd"
-definition rsending :: "'m receiver_state => bool" where "rsending == snd o snd o snd o snd"
-
-definition
-  receiver_asig :: "'m action signature" where
-  "receiver_asig =
-   (UN pkt. {R_pkt(pkt)},
-    (UN m. {R_msg(m)}) Un (UN b. {S_ack(b)}),
-    insert C_m_r (UN m. {C_r_r(m)}))"
-
-definition
-  receiver_trans:: "('m action, 'm receiver_state)transition set" where
-"receiver_trans =
- {tr. let s = fst(tr);
-          t = snd(snd(tr))
-      in
-      case fst(snd(tr))
-      of
-      S_msg(m) => False |
-      R_msg(m) => rq(s) = (m # rq(t))   &
-                  rsent(t)=rsent(s)     &
-                  rrcvd(t)=rrcvd(s)     &
-                  rbit(t)=rbit(s)       &
-                  rsending(t)=rsending(s) |
-      S_pkt(pkt) => False |
-      R_pkt(pkt) => rq(t) = rq(s)                        &
-                       rsent(t) = rsent(s)                  &
-                       rrcvd(t) = addm (rrcvd s) pkt        &
-                       rbit(t) = rbit(s)                    &
-                       rsending(t) = rsending(s) |
-      S_ack(b) => b = rbit(s)                        &
-                     rq(t) = rq(s)                      &
-                     rsent(t) = addm (rsent s) (rbit s) &
-                     rrcvd(t) = rrcvd(s)                &
-                     rbit(t)=rbit(s)                    &
-                     rsending(s)                        &
-                     rsending(t) |
-      R_ack(b) => False |
-      C_m_s => False |
- C_m_r => count (rsent s) (~rbit s) < countm (rrcvd s) (%y. hdr(y)=rbit(s)) &
-             rq(t) = rq(s)                        &
-             rsent(t)=rsent(s)                    &
-             rrcvd(t)=rrcvd(s)                    &
-             rbit(t)=rbit(s)                      &
-             rsending(s)                          &
-             ~rsending(t) |
-    C_r_s => False |
- C_r_r(m) => count (rsent s) (rbit s) <= countm (rrcvd s) (%y. hdr(y)=rbit(s)) &
-             count (rsent s) (~rbit s) < count (rrcvd s) (rbit(s),m) &
-             rq(t) = rq(s)@[m]                         &
-             rsent(t)=rsent(s)                         &
-             rrcvd(t)=rrcvd(s)                         &
-             rbit(t) = (~rbit(s))                      &
-             ~rsending(s)                              &
-             rsending(t)}"
-
-definition
-  receiver_ioa  :: "('m action, 'm receiver_state)ioa" where
-  "receiver_ioa =
-    (receiver_asig, {([],{|},{|},False,False)}, receiver_trans,{},{})"
-
-lemma in_receiver_asig:
-  "S_msg(m) ~: actions(receiver_asig)"
-  "R_msg(m) : actions(receiver_asig)"
-  "S_pkt(pkt) ~: actions(receiver_asig)"
-  "R_pkt(pkt) : actions(receiver_asig)"
-  "S_ack(b) : actions(receiver_asig)"
-  "R_ack(b) ~: actions(receiver_asig)"
-  "C_m_s ~: actions(receiver_asig)"
-  "C_m_r : actions(receiver_asig)"
-  "C_r_s ~: actions(receiver_asig)"
-  "C_r_r(m) : actions(receiver_asig)"
-  by (simp_all add: receiver_asig_def actions_def asig_projections)
-
-lemmas receiver_projections = rq_def rsent_def rrcvd_def rbit_def rsending_def
-
-end

--- a/src/HOLCF/IOA/NTP/Sender.thy	Sat Nov 27 14:34:54 2010 -0800
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,92 +0,0 @@
-(*  Title:      HOL/IOA/NTP/Sender.thy
-    Author:     Tobias Nipkow & Konrad Slind
-*)
-
-header {* The implementation: sender *}
-
-theory Sender
-imports IOA Action
-begin
-
-types
-'m sender_state = "'m list * bool multiset * bool multiset * bool * bool"
-(*                messages   #sent           #received      header  mode *)
-
-definition sq :: "'m sender_state => 'm list" where "sq = fst"
-definition ssent :: "'m sender_state => bool multiset" where "ssent = fst o snd"
-definition srcvd :: "'m sender_state => bool multiset" where "srcvd = fst o snd o snd"
-definition sbit :: "'m sender_state => bool" where "sbit = fst o snd o snd o snd"
-definition ssending :: "'m sender_state => bool" where "ssending = snd o snd o snd o snd"
-
-definition
-  sender_asig :: "'m action signature" where
-  "sender_asig = ((UN m. {S_msg(m)}) Un (UN b. {R_ack(b)}),
-                   UN pkt. {S_pkt(pkt)},
-                   {C_m_s,C_r_s})"
-
-definition
-  sender_trans :: "('m action, 'm sender_state)transition set" where
-  "sender_trans =
- {tr. let s = fst(tr);
-          t = snd(snd(tr))
-      in case fst(snd(tr))
-      of
-      S_msg(m) => sq(t)=sq(s)@[m]   &
-                  ssent(t)=ssent(s) &
-                  srcvd(t)=srcvd(s) &
-                  sbit(t)=sbit(s)   &
-                  ssending(t)=ssending(s) |
-      R_msg(m) => False |
-      S_pkt(pkt) => hdr(pkt) = sbit(s)      &
-                       (? Q. sq(s) = (msg(pkt)#Q))  &
-                       sq(t) = sq(s)           &
-                       ssent(t) = addm (ssent s) (sbit s) &
-                       srcvd(t) = srcvd(s) &
-                       sbit(t) = sbit(s)   &
-                       ssending(s)         &
-                       ssending(t) |
-    R_pkt(pkt) => False |
-    S_ack(b)   => False |
-      R_ack(b) => sq(t)=sq(s)                  &
-                     ssent(t)=ssent(s)            &
-                     srcvd(t) = addm (srcvd s) b  &
-                     sbit(t)=sbit(s)              &
-                     ssending(t)=ssending(s) |
-      C_m_s => count (ssent s) (~sbit s) < count (srcvd s) (~sbit s) &
-               sq(t)=sq(s)       &
-               ssent(t)=ssent(s) &
-               srcvd(t)=srcvd(s) &
-               sbit(t)=sbit(s)   &
-               ssending(s)       &
-               ~ssending(t) |
-      C_m_r => False |
-      C_r_s => count (ssent s) (sbit s) <= count (srcvd s) (~sbit s) &
-               sq(t)=tl(sq(s))      &
-               ssent(t)=ssent(s)    &
-               srcvd(t)=srcvd(s)    &
-               sbit(t) = (~sbit(s)) &
-               ~ssending(s)         &
-               ssending(t) |
-      C_r_r(m) => False}"
-
-definition
-  sender_ioa :: "('m action, 'm sender_state)ioa" where
-  "sender_ioa =
-   (sender_asig, {([],{|},{|},False,True)}, sender_trans,{},{})"
-
-lemma in_sender_asig: 
-  "S_msg(m) : actions(sender_asig)"
-  "R_msg(m) ~: actions(sender_asig)"
-  "S_pkt(pkt) : actions(sender_asig)"
-  "R_pkt(pkt) ~: actions(sender_asig)"
-  "S_ack(b) ~: actions(sender_asig)"
-  "R_ack(b) : actions(sender_asig)"
-  "C_m_s : actions(sender_asig)"
-  "C_m_r ~: actions(sender_asig)"
-  "C_r_s : actions(sender_asig)"
-  "C_r_r(m) ~: actions(sender_asig)"
-  by (simp_all add: sender_asig_def actions_def asig_projections)
-
-lemmas sender_projections = sq_def ssent_def srcvd_def sbit_def ssending_def
-
-end

--- a/src/HOLCF/IOA/NTP/Spec.thy	Sat Nov 27 14:34:54 2010 -0800
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,40 +0,0 @@
-(*  Title:      HOL/IOA/NTP/Spec.thy
-    Author:     Tobias Nipkow & Konrad Slind
-*)
-
-header {* The specification of reliable transmission *}
-
-theory Spec
-imports IOA Action
-begin
-
-definition
-  spec_sig :: "'m action signature" where
-  sig_def: "spec_sig = (UN m.{S_msg(m)}, 
-                        UN m.{R_msg(m)}, 
-                        {})"
-
-definition
-  spec_trans :: "('m action, 'm list)transition set" where
-  trans_def: "spec_trans =
-   {tr. let s = fst(tr);                            
-            t = snd(snd(tr))                        
-        in                                          
-        case fst(snd(tr))                           
-        of                                          
-        S_msg(m) => t = s@[m]  |                    
-        R_msg(m) => s = (m#t)  |                    
-        S_pkt(pkt) => False |                    
-        R_pkt(pkt) => False |                    
-        S_ack(b) => False |                      
-        R_ack(b) => False |                      
-        C_m_s => False |                            
-        C_m_r => False |                            
-        C_r_s => False |                            
-        C_r_r(m) => False}"
-
-definition
-  spec_ioa :: "('m action, 'm list)ioa" where
-  ioa_def: "spec_ioa = (spec_sig, {[]}, spec_trans,{},{})"
-
-end

--- a/src/HOLCF/IOA/README.html	Sat Nov 27 14:34:54 2010 -0800
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,24 +0,0 @@
-<!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/IOA/README</TITLE>
-</HEAD>
-
-<BODY>
-
-<H3>IOA: A formalization of I/O automata in HOLCF</H3>
-
-Author:     Olaf M&uuml;ller<BR>
-Copyright   1997 Technische Universit&auml;t M&uuml;nchen<P>
-
-The distribution contains simulation relations, temporal logic, and an abstraction theory.
-Everything is based upon a domain-theoretic model of finite and infinite sequences. 
-<p>
-For details see the <A HREF="http://www4.informatik.tu-muenchen.de/~isabelle/IOA/">IOA project</a>.
-
-</BODY></HTML>
-
-

--- a/src/HOLCF/IOA/ROOT.ML	Sat Nov 27 14:34:54 2010 -0800
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,8 +0,0 @@
-(*  Title:      HOLCF/IOA/ROOT.ML
-    Author:     Olaf Mueller
-
-Formalization of a semantic model of I/O-Automata.  See README.html
-for details.
-*)
-
-use_thys ["meta_theory/Abstraction"];

--- a/src/HOLCF/IOA/Storage/Action.thy	Sat Nov 27 14:34:54 2010 -0800
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,16 +0,0 @@
-(*  Title:      HOLCF/IOA/ABP/Action.thy
-    Author:     Olaf Müller
-*)
-
-header {* The set of all actions of the system *}
-
-theory Action
-imports Main
-begin
-
-datatype action = New  | Loc nat | Free nat
-
-lemma [cong]: "!!x. x = y ==> action_case a b c x = action_case a b c y"
-  by simp
-
-end

--- a/src/HOLCF/IOA/Storage/Correctness.thy	Sat Nov 27 14:34:54 2010 -0800
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,75 +0,0 @@
-(*  Title:      HOL/IOA/example/Correctness.thy
-    Author:     Olaf Müller
-*)
-
-header {* Correctness Proof *}
-
-theory Correctness
-imports SimCorrectness Spec Impl
-begin
-
-default_sort type
-
-definition
-  sim_relation :: "((nat * bool) * (nat set * bool)) set" where
-  "sim_relation = {qua. let c = fst qua; a = snd qua ;
-                            k = fst c;   b = snd c;
-                            used = fst a; c = snd a
-                        in
-                        (! l:used. l < k) & b=c}"
-
-declare split_paired_Ex [simp del]
-
-
-(* Idea: instead of impl_con_lemma do not rewrite impl_ioa, but derive
-         simple lemmas asig_of impl_ioa = impl_sig, trans_of impl_ioa = impl_trans
-   Idea: ?ex. move .. should be generally replaced by a step via a subst tac if desired,
-         as this can be done globally *)
-
-lemma issimulation:
-      "is_simulation sim_relation impl_ioa spec_ioa"
-apply (simp (no_asm) add: is_simulation_def)
-apply (rule conjI)
-txt {* start states *}
-apply (auto)[1]
-apply (rule_tac x = " ({},False) " in exI)
-apply (simp add: sim_relation_def starts_of_def spec_ioa_def impl_ioa_def)
-txt {* main-part *}
-apply (rule allI)+
-apply (rule imp_conj_lemma)
-apply (rename_tac k b used c k' b' a)
-apply (induct_tac "a")
-apply (simp_all (no_asm) add: sim_relation_def impl_ioa_def impl_trans_def trans_of_def)
-apply auto
-txt {* NEW *}
-apply (rule_tac x = "(used,True)" in exI)
-apply simp
-apply (rule transition_is_ex)
-apply (simp (no_asm) add: spec_ioa_def spec_trans_def trans_of_def)
-txt {* LOC *}
-apply (rule_tac x = " (used Un {k},False) " in exI)
-apply (simp add: less_SucI)
-apply (rule transition_is_ex)
-apply (simp (no_asm) add: spec_ioa_def spec_trans_def trans_of_def)
-apply fast
-txt {* FREE *}
-apply (rule_tac x = " (used - {nat},c) " in exI)
-apply simp
-apply (rule transition_is_ex)
-apply (simp (no_asm) add: spec_ioa_def spec_trans_def trans_of_def)
-done
-
-
-lemma implementation:
-"impl_ioa =<| spec_ioa"
-apply (unfold ioa_implements_def)
-apply (rule conjI)
-apply (simp (no_asm) add: impl_sig_def spec_sig_def impl_ioa_def spec_ioa_def
-  asig_outputs_def asig_of_def asig_inputs_def)
-apply (rule trace_inclusion_for_simulations)
-apply (simp (no_asm) add: impl_sig_def spec_sig_def impl_ioa_def spec_ioa_def
-  externals_def asig_outputs_def asig_of_def asig_inputs_def)
-apply (rule issimulation)
-done
-
-end

--- a/src/HOLCF/IOA/Storage/Impl.thy	Sat Nov 27 14:34:54 2010 -0800
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,39 +0,0 @@
-(*  Title:      HOL/IOA/example/Spec.thy
-    Author:     Olaf Müller
-*)
-
-header {* The implementation of a memory *}
-
-theory Impl
-imports IOA Action
-begin
-
-definition
-  impl_sig :: "action signature" where
-  "impl_sig = (UN l.{Free l} Un {New},
-               UN l.{Loc l},
-               {})"
-
-definition
-  impl_trans :: "(action, nat  * bool)transition set" where
-  "impl_trans =
-    {tr. let s = fst(tr); k = fst s; b = snd s;
-             t = snd(snd(tr)); k' = fst t; b' = snd t
-         in
-         case fst(snd(tr))
-         of
-         New       => k' = k & b'  |
-         Loc l     => b & l= k & k'= (Suc k) & ~b' |
-         Free l    => k'=k & b'=b}"
-
-definition
-  impl_ioa :: "(action, nat * bool)ioa" where
-  "impl_ioa = (impl_sig, {(0,False)}, impl_trans,{},{})"
-
-lemma in_impl_asig:
-  "New : actions(impl_sig) &
-    Loc l : actions(impl_sig) &
-    Free l : actions(impl_sig) "
-  by (simp add: impl_sig_def actions_def asig_projections)
-
-end

--- a/src/HOLCF/IOA/Storage/ROOT.ML	Sat Nov 27 14:34:54 2010 -0800
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,6 +0,0 @@
-(*  Title:      HOLCF/IOA/Storage/ROOT.ML
-    Author:     Olaf Mueller
-
-Memory storage case study.
-*)
-use_thys ["Correctness"];

--- a/src/HOLCF/IOA/Storage/Spec.thy	Sat Nov 27 14:34:54 2010 -0800
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,33 +0,0 @@
-(*  Title:      HOL/IOA/example/Spec.thy
-    Author:     Olaf Müller
-*)
-
-header {* The specification of a memory *}
-
-theory Spec
-imports IOA Action
-begin
-
-definition
-  spec_sig :: "action signature" where
-  "spec_sig = (UN l.{Free l} Un {New},
-               UN l.{Loc l},
-               {})"
-
-definition
-  spec_trans :: "(action, nat set * bool)transition set" where
-  "spec_trans =
-   {tr. let s = fst(tr); used = fst s; c = snd s;
-            t = snd(snd(tr)); used' = fst t; c' = snd t
-        in
-        case fst(snd(tr))
-        of
-        New       => used' = used & c'  |
-        Loc l     => c & l~:used  & used'= used Un {l} & ~c'   |
-        Free l    => used'=used - {l} & c'=c}"
-
-definition
-  spec_ioa :: "(action, nat set * bool)ioa" where
-  "spec_ioa = (spec_sig, {({},False)}, spec_trans,{},{})"
-
-end

--- a/src/HOLCF/IOA/ex/ROOT.ML	Sat Nov 27 14:34:54 2010 -0800
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,5 +0,0 @@
-(*  Title:      HOLCF/IOA/ex/ROOT.ML
-    Author:     Olaf Mueller
-*)
-
-use_thys ["TrivEx", "TrivEx2"];

--- a/src/HOLCF/IOA/ex/TrivEx.thy	Sat Nov 27 14:34:54 2010 -0800
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,72 +0,0 @@
-(*  Title:      HOLCF/IOA/TrivEx.thy
-    Author:     Olaf Müller
-*)
-
-header {* Trivial Abstraction Example *}
-
-theory TrivEx
-imports Abstraction
-begin
-
-datatype action = INC
-
-definition
-  C_asig :: "action signature" where
-  "C_asig = ({},{INC},{})"
-definition
-  C_trans :: "(action, nat)transition set" where
-  "C_trans =
-   {tr. let s = fst(tr);
-            t = snd(snd(tr))
-        in case fst(snd(tr))
-        of
-        INC       => t = Suc(s)}"
-definition
-  C_ioa :: "(action, nat)ioa" where
-  "C_ioa = (C_asig, {0}, C_trans,{},{})"
-
-definition
-  A_asig :: "action signature" where
-  "A_asig = ({},{INC},{})"
-definition
-  A_trans :: "(action, bool)transition set" where
-  "A_trans =
-   {tr. let s = fst(tr);
-            t = snd(snd(tr))
-        in case fst(snd(tr))
-        of
-        INC       => t = True}"
-definition
-  A_ioa :: "(action, bool)ioa" where
-  "A_ioa = (A_asig, {False}, A_trans,{},{})"
-
-definition
-  h_abs :: "nat => bool" where
-  "h_abs n = (n~=0)"
-
-axiomatization where
-  MC_result: "validIOA A_ioa (<>[] <%(b,a,c). b>)"
-
-lemma h_abs_is_abstraction:
-  "is_abstraction h_abs C_ioa A_ioa"
-apply (unfold is_abstraction_def)
-apply (rule conjI)
-txt {* start states *}
-apply (simp (no_asm) add: h_abs_def starts_of_def C_ioa_def A_ioa_def)
-txt {* step case *}
-apply (rule allI)+
-apply (rule imp_conj_lemma)
-apply (simp (no_asm) add: trans_of_def C_ioa_def A_ioa_def C_trans_def A_trans_def)
-apply (induct_tac "a")
-apply (simp add: h_abs_def)
-done
-
-lemma TrivEx_abstraction: "validIOA C_ioa (<>[] <%(n,a,m). n~=0>)"
-apply (rule AbsRuleT1)
-apply (rule h_abs_is_abstraction)
-apply (rule MC_result)
-apply abstraction
-apply (simp add: h_abs_def)
-done
-
-end

--- a/src/HOLCF/IOA/ex/TrivEx2.thy	Sat Nov 27 14:34:54 2010 -0800
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,102 +0,0 @@
-(*  Title:      HOLCF/IOA/TrivEx.thy
-    Author:     Olaf Müller
-*)
-
-header {* Trivial Abstraction Example with fairness *}
-
-theory TrivEx2
-imports IOA Abstraction
-begin
-
-datatype action = INC
-
-definition
-  C_asig :: "action signature" where
-  "C_asig = ({},{INC},{})"
-definition
-  C_trans :: "(action, nat)transition set" where
-  "C_trans =
-   {tr. let s = fst(tr);
-            t = snd(snd(tr))
-        in case fst(snd(tr))
-        of
-        INC       => t = Suc(s)}"
-definition
-  C_ioa :: "(action, nat)ioa" where
-  "C_ioa = (C_asig, {0}, C_trans,{},{})"
-definition
-  C_live_ioa :: "(action, nat)live_ioa" where
-  "C_live_ioa = (C_ioa, WF C_ioa {INC})"
-
-definition
-  A_asig :: "action signature" where
-  "A_asig = ({},{INC},{})"
-definition
-  A_trans :: "(action, bool)transition set" where
-  "A_trans =
-   {tr. let s = fst(tr);
-            t = snd(snd(tr))
-        in case fst(snd(tr))
-        of
-        INC       => t = True}"
-definition
-  A_ioa :: "(action, bool)ioa" where
-  "A_ioa = (A_asig, {False}, A_trans,{},{})"
-definition
-  A_live_ioa :: "(action, bool)live_ioa" where
-  "A_live_ioa = (A_ioa, WF A_ioa {INC})"
-
-definition
-  h_abs :: "nat => bool" where
-  "h_abs n = (n~=0)"
-
-axiomatization where
-  MC_result: "validLIOA (A_ioa,WF A_ioa {INC}) (<>[] <%(b,a,c). b>)"
-
-
-lemma h_abs_is_abstraction:
-"is_abstraction h_abs C_ioa A_ioa"
-apply (unfold is_abstraction_def)
-apply (rule conjI)
-txt {* start states *}
-apply (simp (no_asm) add: h_abs_def starts_of_def C_ioa_def A_ioa_def)
-txt {* step case *}
-apply (rule allI)+
-apply (rule imp_conj_lemma)
-apply (simp (no_asm) add: trans_of_def C_ioa_def A_ioa_def C_trans_def A_trans_def)
-apply (induct_tac "a")
-apply (simp (no_asm) add: h_abs_def)
-done
-
-
-lemma Enabled_implication:
-    "!!s. Enabled A_ioa {INC} (h_abs s) ==> Enabled C_ioa {INC} s"
-  apply (unfold Enabled_def enabled_def h_abs_def A_ioa_def C_ioa_def A_trans_def
-    C_trans_def trans_of_def)
-  apply auto
-  done
-
-
-lemma h_abs_is_liveabstraction:
-"is_live_abstraction h_abs (C_ioa, WF C_ioa {INC}) (A_ioa, WF A_ioa {INC})"
-apply (unfold is_live_abstraction_def)
-apply auto
-txt {* is_abstraction *}
-apply (rule h_abs_is_abstraction)
-txt {* temp_weakening *}
-apply abstraction
-apply (erule Enabled_implication)
-done
-
-
-lemma TrivEx2_abstraction:
-  "validLIOA C_live_ioa (<>[] <%(n,a,m). n~=0>)"
-apply (unfold C_live_ioa_def)
-apply (rule AbsRuleT2)
-apply (rule h_abs_is_liveabstraction)
-apply (rule MC_result)
-apply abstraction
-apply (simp add: h_abs_def)
-done
-
-end

--- a/src/HOLCF/IOA/meta_theory/Abstraction.thy	Sat Nov 27 14:34:54 2010 -0800
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,615 +0,0 @@
-(*  Title:      HOLCF/IOA/meta_theory/Abstraction.thy
-    Author:     Olaf Müller
-*)
-
-header {* Abstraction Theory -- tailored for I/O automata *}
-
-theory Abstraction
-imports LiveIOA
-begin
-
-default_sort type
-
-definition
-  cex_abs :: "('s1 => 's2) => ('a,'s1)execution => ('a,'s2)execution" where
-  "cex_abs f ex = (f (fst ex), Map (%(a,t). (a,f t))$(snd ex))"
-definition
-  -- {* equals cex_abs on Sequences -- after ex2seq application *}
-  cex_absSeq :: "('s1 => 's2) => ('a option,'s1)transition Seq => ('a option,'s2)transition Seq" where
-  "cex_absSeq f = (%s. Map (%(s,a,t). (f s,a,f t))$s)"
-
-definition
-  is_abstraction ::"[('s1=>'s2),('a,'s1)ioa,('a,'s2)ioa] => bool" where
-  "is_abstraction f C A =
-   ((!s:starts_of(C). f(s):starts_of(A)) &
-   (!s t a. reachable C s & s -a--C-> t
-            --> (f s) -a--A-> (f t)))"
-
-definition
-  weakeningIOA :: "('a,'s2)ioa => ('a,'s1)ioa => ('s1 => 's2) => bool" where
-  "weakeningIOA A C h = (!ex. ex : executions C --> cex_abs h ex : executions A)"
-definition
-  temp_strengthening :: "('a,'s2)ioa_temp => ('a,'s1)ioa_temp => ('s1 => 's2) => bool" where
-  "temp_strengthening Q P h = (!ex. (cex_abs h ex |== Q) --> (ex |== P))"
-definition
-  temp_weakening :: "('a,'s2)ioa_temp => ('a,'s1)ioa_temp => ('s1 => 's2) => bool" where
-  "temp_weakening Q P h = temp_strengthening (.~ Q) (.~ P) h"
-
-definition
-  state_strengthening :: "('a,'s2)step_pred => ('a,'s1)step_pred => ('s1 => 's2) => bool" where
-  "state_strengthening Q P h = (!s t a.  Q (h(s),a,h(t)) --> P (s,a,t))"
-definition
-  state_weakening :: "('a,'s2)step_pred => ('a,'s1)step_pred => ('s1 => 's2) => bool" where
-  "state_weakening Q P h = state_strengthening (.~Q) (.~P) h"
-
-definition
-  is_live_abstraction :: "('s1 => 's2) => ('a,'s1)live_ioa => ('a,'s2)live_ioa => bool" where
-  "is_live_abstraction h CL AM =
-     (is_abstraction h (fst CL) (fst AM) &
-      temp_weakening (snd AM) (snd CL) h)"
-
-
-axiomatization where
-(* thm about ex2seq which is not provable by induction as ex2seq is not continous *)
-ex2seq_abs_cex:
-  "ex2seq (cex_abs h ex) = cex_absSeq h (ex2seq ex)"
-
-axiomatization where
-(* analog to the proved thm strength_Box - proof skipped as trivial *)
-weak_Box:
-"temp_weakening P Q h
- ==> temp_weakening ([] P) ([] Q) h"
-
-axiomatization where
-(* analog to the proved thm strength_Next - proof skipped as trivial *)
-weak_Next:
-"temp_weakening P Q h
- ==> temp_weakening (Next P) (Next Q) h"
-
-
-subsection "cex_abs"
-
-lemma cex_abs_UU: "cex_abs f (s,UU) = (f s, UU)"
-  by (simp add: cex_abs_def)
-
-lemma cex_abs_nil: "cex_abs f (s,nil) = (f s, nil)"
-  by (simp add: cex_abs_def)
-
-lemma cex_abs_cons: "cex_abs f (s,(a,t)>>ex) = (f s, (a,f t) >> (snd (cex_abs f (t,ex))))"
-  by (simp add: cex_abs_def)
-
-declare cex_abs_UU [simp] cex_abs_nil [simp] cex_abs_cons [simp]
-
-
-subsection "lemmas"
-
-lemma temp_weakening_def2: "temp_weakening Q P h = (! ex. (ex |== P) --> (cex_abs h ex |== Q))"
-  apply (simp add: temp_weakening_def temp_strengthening_def NOT_def temp_sat_def satisfies_def)
-  apply auto
-  done
-
-lemma state_weakening_def2: "state_weakening Q P h = (! s t a. P (s,a,t) --> Q (h(s),a,h(t)))"
-  apply (simp add: state_weakening_def state_strengthening_def NOT_def)
-  apply auto
-  done
-
-
-subsection "Abstraction Rules for Properties"
-
-lemma exec_frag_abstraction [rule_format]:
- "[| is_abstraction h C A |] ==>
-  !s. reachable C s & is_exec_frag C (s,xs)
-  --> is_exec_frag A (cex_abs h (s,xs))"
-apply (unfold cex_abs_def)
-apply simp
-apply (tactic {* pair_induct_tac @{context} "xs" [@{thm is_exec_frag_def}] 1 *})
-txt {* main case *}
-apply (auto dest: reachable.reachable_n simp add: is_abstraction_def)
-done
-
-
-lemma abs_is_weakening: "is_abstraction h C A ==> weakeningIOA A C h"
-apply (simp add: weakeningIOA_def)
-apply auto
-apply (simp add: executions_def)
-txt {* start state *}
-apply (rule conjI)
-apply (simp add: is_abstraction_def cex_abs_def)
-txt {* is-execution-fragment *}
-apply (erule exec_frag_abstraction)
-apply (simp add: reachable.reachable_0)
-done
-
-
-lemma AbsRuleT1: "[|is_abstraction h C A; validIOA A Q; temp_strengthening Q P h |]
-          ==> validIOA C P"
-apply (drule abs_is_weakening)
-apply (simp add: weakeningIOA_def validIOA_def temp_strengthening_def)
-apply (auto simp add: split_paired_all)
-done
-
-
-(* FIX: Nach TLS.ML *)
-
-lemma IMPLIES_temp_sat: "(ex |== P .--> Q) = ((ex |== P) --> (ex |== Q))"
-  by (simp add: IMPLIES_def temp_sat_def satisfies_def)
-
-lemma AND_temp_sat: "(ex |== P .& Q) = ((ex |== P) & (ex |== Q))"
-  by (simp add: AND_def temp_sat_def satisfies_def)
-
-lemma OR_temp_sat: "(ex |== P .| Q) = ((ex |== P) | (ex |== Q))"
-  by (simp add: OR_def temp_sat_def satisfies_def)
-
-lemma NOT_temp_sat: "(ex |== .~ P) = (~ (ex |== P))"
-  by (simp add: NOT_def temp_sat_def satisfies_def)
-
-declare IMPLIES_temp_sat [simp] AND_temp_sat [simp] OR_temp_sat [simp] NOT_temp_sat [simp]
-
-
-lemma AbsRuleT2:
-   "[|is_live_abstraction h (C,L) (A,M);
-          validLIOA (A,M) Q;  temp_strengthening Q P h |]
-          ==> validLIOA (C,L) P"
-apply (unfold is_live_abstraction_def)
-apply auto
-apply (drule abs_is_weakening)
-apply (simp add: weakeningIOA_def temp_weakening_def2 validLIOA_def validIOA_def temp_strengthening_def)
-apply (auto simp add: split_paired_all)
-done
-
-
-lemma AbsRuleTImprove:
-   "[|is_live_abstraction h (C,L) (A,M);
-          validLIOA (A,M) (H1 .--> Q);  temp_strengthening Q P h;
-          temp_weakening H1 H2 h; validLIOA (C,L) H2 |]
-          ==> validLIOA (C,L) P"
-apply (unfold is_live_abstraction_def)
-apply auto
-apply (drule abs_is_weakening)
-apply (simp add: weakeningIOA_def temp_weakening_def2 validLIOA_def validIOA_def temp_strengthening_def)
-apply (auto simp add: split_paired_all)
-done
-
-
-subsection "Correctness of safe abstraction"
-
-lemma abstraction_is_ref_map:
-"is_abstraction h C A ==> is_ref_map h C A"
-apply (unfold is_abstraction_def is_ref_map_def)
-apply auto
-apply (rule_tac x = "(a,h t) >>nil" in exI)
-apply (simp add: move_def)
-done
-
-
-lemma abs_safety: "[| inp(C)=inp(A); out(C)=out(A);
-                   is_abstraction h C A |]
-                ==> C =<| A"
-apply (simp add: ioa_implements_def)
-apply (rule trace_inclusion)
-apply (simp (no_asm) add: externals_def)
-apply (auto)[1]
-apply (erule abstraction_is_ref_map)
-done
-
-
-subsection "Correctness of life abstraction"
-
-(* Reduces to Filter (Map fst x) = Filter (Map fst (Map (%(a,t). (a,x)) x),
-   that is to special Map Lemma *)
-lemma traces_coincide_abs:
-  "ext C = ext A
-         ==> mk_trace C$xs = mk_trace A$(snd (cex_abs f (s,xs)))"
-apply (unfold cex_abs_def mk_trace_def filter_act_def)
-apply simp
-apply (tactic {* pair_induct_tac @{context} "xs" [] 1 *})
-done
-
-
-(* Does not work with abstraction_is_ref_map as proof of abs_safety, because
-   is_live_abstraction includes temp_strengthening which is necessarily based
-   on cex_abs and not on corresp_ex. Thus, the proof is redoone in a more specific
-   way for cex_abs *)
-lemma abs_liveness: "[| inp(C)=inp(A); out(C)=out(A);
-                   is_live_abstraction h (C,M) (A,L) |]
-                ==> live_implements (C,M) (A,L)"
-apply (simp add: is_live_abstraction_def live_implements_def livetraces_def liveexecutions_def)
-apply auto
-apply (rule_tac x = "cex_abs h ex" in exI)
-apply auto
-  (* Traces coincide *)
-  apply (tactic {* pair_tac @{context} "ex" 1 *})
-  apply (rule traces_coincide_abs)
-  apply (simp (no_asm) add: externals_def)
-  apply (auto)[1]
-
-  (* cex_abs is execution *)
-  apply (tactic {* pair_tac @{context} "ex" 1 *})
-  apply (simp add: executions_def)
-  (* start state *)
-  apply (rule conjI)
-  apply (simp add: is_abstraction_def cex_abs_def)
-  (* is-execution-fragment *)
-  apply (erule exec_frag_abstraction)
-  apply (simp add: reachable.reachable_0)
-
- (* Liveness *)
-apply (simp add: temp_weakening_def2)
- apply (tactic {* pair_tac @{context} "ex" 1 *})
-done
-
-(* FIX: NAch Traces.ML bringen *)
-
-lemma implements_trans:
-"[| A =<| B; B =<| C|] ==> A =<| C"
-by (auto simp add: ioa_implements_def)
-
-
-subsection "Abstraction Rules for Automata"
-
-lemma AbsRuleA1: "[| inp(C)=inp(A); out(C)=out(A);
-                   inp(Q)=inp(P); out(Q)=out(P);
-                   is_abstraction h1 C A;
-                   A =<| Q ;
-                   is_abstraction h2 Q P |]
-                ==> C =<| P"
-apply (drule abs_safety)
-apply assumption+
-apply (drule abs_safety)
-apply assumption+
-apply (erule implements_trans)
-apply (erule implements_trans)
-apply assumption
-done
-
-
-lemma AbsRuleA2: "!!LC. [| inp(C)=inp(A); out(C)=out(A);
-                   inp(Q)=inp(P); out(Q)=out(P);
-                   is_live_abstraction h1 (C,LC) (A,LA);
-                   live_implements (A,LA) (Q,LQ) ;
-                   is_live_abstraction h2 (Q,LQ) (P,LP) |]
-                ==> live_implements (C,LC) (P,LP)"
-apply (drule abs_liveness)
-apply assumption+
-apply (drule abs_liveness)
-apply assumption+
-apply (erule live_implements_trans)
-apply (erule live_implements_trans)
-apply assumption
-done
-
-
-declare split_paired_All [simp del]
-
-
-subsection "Localizing Temporal Strengthenings and Weakenings"
-
-lemma strength_AND:
-"[| temp_strengthening P1 Q1 h;
-          temp_strengthening P2 Q2 h |]
-       ==> temp_strengthening (P1 .& P2) (Q1 .& Q2) h"
-apply (unfold temp_strengthening_def)
-apply auto
-done
-
-lemma strength_OR:
-"[| temp_strengthening P1 Q1 h;
-          temp_strengthening P2 Q2 h |]
-       ==> temp_strengthening (P1 .| P2) (Q1 .| Q2) h"
-apply (unfold temp_strengthening_def)
-apply auto
-done
-
-lemma strength_NOT:
-"[| temp_weakening P Q h |]
-       ==> temp_strengthening (.~ P) (.~ Q) h"
-apply (unfold temp_strengthening_def)
-apply (simp add: temp_weakening_def2)
-apply auto
-done
-
-lemma strength_IMPLIES:
-"[| temp_weakening P1 Q1 h;
-          temp_strengthening P2 Q2 h |]
-       ==> temp_strengthening (P1 .--> P2) (Q1 .--> Q2) h"
-apply (unfold temp_strengthening_def)
-apply (simp add: temp_weakening_def2)
-done
-
-
-lemma weak_AND:
-"[| temp_weakening P1 Q1 h;
-          temp_weakening P2 Q2 h |]
-       ==> temp_weakening (P1 .& P2) (Q1 .& Q2) h"
-apply (simp add: temp_weakening_def2)
-done
-
-lemma weak_OR:
-"[| temp_weakening P1 Q1 h;
-          temp_weakening P2 Q2 h |]
-       ==> temp_weakening (P1 .| P2) (Q1 .| Q2) h"
-apply (simp add: temp_weakening_def2)
-done
-
-lemma weak_NOT:
-"[| temp_strengthening P Q h |]
-       ==> temp_weakening (.~ P) (.~ Q) h"
-apply (unfold temp_strengthening_def)
-apply (simp add: temp_weakening_def2)
-apply auto
-done
-
-lemma weak_IMPLIES:
-"[| temp_strengthening P1 Q1 h;
-          temp_weakening P2 Q2 h |]
-       ==> temp_weakening (P1 .--> P2) (Q1 .--> Q2) h"
-apply (unfold temp_strengthening_def)
-apply (simp add: temp_weakening_def2)
-done
-
-
-subsubsection {* Box *}
-
-(* FIX: should be same as nil_is_Conc2 when all nils are turned to right side !! *)
-lemma UU_is_Conc: "(UU = x @@ y) = (((x::'a Seq)= UU) | (x=nil & y=UU))"
-apply (tactic {* Seq_case_simp_tac @{context} "x" 1 *})
-done
-
-lemma ex2seqConc [rule_format]:
-"Finite s1 -->
-  (! ex. (s~=nil & s~=UU & ex2seq ex = s1 @@ s) --> (? ex'. s = ex2seq ex'))"
-apply (rule impI)
-apply (tactic {* Seq_Finite_induct_tac @{context} 1 *})
-apply blast
-(* main case *)
-apply clarify
-apply (tactic {* pair_tac @{context} "ex" 1 *})
-apply (tactic {* Seq_case_simp_tac @{context} "y" 1 *})
-(* UU case *)
-apply (simp add: nil_is_Conc)
-(* nil case *)
-apply (simp add: nil_is_Conc)
-(* cons case *)
-apply (tactic {* pair_tac @{context} "aa" 1 *})
-apply auto
-done
-
-(* important property of ex2seq: can be shiftet, as defined "pointwise" *)
-
-lemma ex2seq_tsuffix:
-"tsuffix s (ex2seq ex) ==> ? ex'. s = (ex2seq ex')"
-apply (unfold tsuffix_def suffix_def)
-apply auto
-apply (drule ex2seqConc)
-apply auto
-done
-
-
-(* FIX: NAch Sequence.ML bringen *)
-
-lemma Mapnil: "(Map f$s = nil) = (s=nil)"
-apply (tactic {* Seq_case_simp_tac @{context} "s" 1 *})
-done
-
-lemma MapUU: "(Map f$s = UU) = (s=UU)"
-apply (tactic {* Seq_case_simp_tac @{context} "s" 1 *})
-done
-
-
-(* important property of cex_absSeq: As it is a 1to1 correspondence,
-  properties carry over *)
-
-lemma cex_absSeq_tsuffix:
-"tsuffix s t ==> tsuffix (cex_absSeq h s) (cex_absSeq h t)"
-apply (unfold tsuffix_def suffix_def cex_absSeq_def)
-apply auto
-apply (simp add: Mapnil)
-apply (simp add: MapUU)
-apply (rule_tac x = "Map (% (s,a,t) . (h s,a, h t))$s1" in exI)
-apply (simp add: Map2Finite MapConc)
-done
-
-
-lemma strength_Box:
-"[| temp_strengthening P Q h |]
-       ==> temp_strengthening ([] P) ([] Q) h"
-apply (unfold temp_strengthening_def state_strengthening_def temp_sat_def satisfies_def Box_def)
-apply clarify
-apply (frule ex2seq_tsuffix)
-apply clarify
-apply (drule_tac h = "h" in cex_absSeq_tsuffix)
-apply (simp add: ex2seq_abs_cex)
-done
-
-
-subsubsection {* Init *}
-
-lemma strength_Init:
-"[| state_strengthening P Q h |]
-       ==> temp_strengthening (Init P) (Init Q) h"
-apply (unfold temp_strengthening_def state_strengthening_def
-  temp_sat_def satisfies_def Init_def unlift_def)
-apply auto
-apply (tactic {* pair_tac @{context} "ex" 1 *})
-apply (tactic {* Seq_case_simp_tac @{context} "y" 1 *})
-apply (tactic {* pair_tac @{context} "a" 1 *})
-done
-
-
-subsubsection {* Next *}
-
-lemma TL_ex2seq_UU:
-"(TL$(ex2seq (cex_abs h ex))=UU) = (TL$(ex2seq ex)=UU)"
-apply (tactic {* pair_tac @{context} "ex" 1 *})
-apply (tactic {* Seq_case_simp_tac @{context} "y" 1 *})
-apply (tactic {* pair_tac @{context} "a" 1 *})
-apply (tactic {* Seq_case_simp_tac @{context} "s" 1 *})
-apply (tactic {* pair_tac @{context} "a" 1 *})
-done
-
-lemma TL_ex2seq_nil:
-"(TL$(ex2seq (cex_abs h ex))=nil) = (TL$(ex2seq ex)=nil)"
-apply (tactic {* pair_tac @{context} "ex" 1 *})
-apply (tactic {* Seq_case_simp_tac @{context} "y" 1 *})
-apply (tactic {* pair_tac @{context} "a" 1 *})
-apply (tactic {* Seq_case_simp_tac @{context} "s" 1 *})
-apply (tactic {* pair_tac @{context} "a" 1 *})
-done
-
-(* FIX: put to Sequence Lemmas *)
-lemma MapTL: "Map f$(TL$s) = TL$(Map f$s)"
-apply (tactic {* Seq_induct_tac @{context} "s" [] 1 *})
-done
-
-(* important property of cex_absSeq: As it is a 1to1 correspondence,
-  properties carry over *)
-
-lemma cex_absSeq_TL:
-"cex_absSeq h (TL$s) = (TL$(cex_absSeq h s))"
-apply (unfold cex_absSeq_def)
-apply (simp add: MapTL)
-done
-
-(* important property of ex2seq: can be shiftet, as defined "pointwise" *)
-
-lemma TLex2seq: "[| (snd ex)~=UU ; (snd ex)~=nil |] ==> (? ex'. TL$(ex2seq ex) = ex2seq ex')"
-apply (tactic {* pair_tac @{context} "ex" 1 *})
-apply (tactic {* Seq_case_simp_tac @{context} "y" 1 *})
-apply (tactic {* pair_tac @{context} "a" 1 *})
-apply auto
-done
-
-
-lemma ex2seqnilTL: "(TL$(ex2seq ex)~=nil) = ((snd ex)~=nil & (snd ex)~=UU)"
-apply (tactic {* pair_tac @{context} "ex" 1 *})
-apply (tactic {* Seq_case_simp_tac @{context} "y" 1 *})
-apply (tactic {* pair_tac @{context} "a" 1 *})
-apply (tactic {* Seq_case_simp_tac @{context} "s" 1 *})
-apply (tactic {* pair_tac @{context} "a" 1 *})
-done
-
-
-lemma strength_Next:
-"[| temp_strengthening P Q h |]
-       ==> temp_strengthening (Next P) (Next Q) h"
-apply (unfold temp_strengthening_def state_strengthening_def temp_sat_def satisfies_def Next_def)
-apply simp
-apply auto
-apply (simp add: TL_ex2seq_nil TL_ex2seq_UU)
-apply (simp add: TL_ex2seq_nil TL_ex2seq_UU)
-apply (simp add: TL_ex2seq_nil TL_ex2seq_UU)
-apply (simp add: TL_ex2seq_nil TL_ex2seq_UU)
-(* cons case *)
-apply (simp add: TL_ex2seq_nil TL_ex2seq_UU ex2seq_abs_cex cex_absSeq_TL [symmetric] ex2seqnilTL)
-apply (erule conjE)
-apply (drule TLex2seq)
-apply assumption
-apply auto
-done
-
-
-text {* Localizing Temporal Weakenings     - 2 *}
-
-lemma weak_Init:
-"[| state_weakening P Q h |]
-       ==> temp_weakening (Init P) (Init Q) h"
-apply (simp add: temp_weakening_def2 state_weakening_def2
-  temp_sat_def satisfies_def Init_def unlift_def)
-apply auto
-apply (tactic {* pair_tac @{context} "ex" 1 *})
-apply (tactic {* Seq_case_simp_tac @{context} "y" 1 *})
-apply (tactic {* pair_tac @{context} "a" 1 *})
-done
-
-
-text {* Localizing Temproal Strengthenings - 3 *}
-
-lemma strength_Diamond:
-"[| temp_strengthening P Q h |]
-       ==> temp_strengthening (<> P) (<> Q) h"
-apply (unfold Diamond_def)
-apply (rule strength_NOT)
-apply (rule weak_Box)
-apply (erule weak_NOT)
-done
-
-lemma strength_Leadsto:
-"[| temp_weakening P1 P2 h;
-          temp_strengthening Q1 Q2 h |]
-       ==> temp_strengthening (P1 ~> Q1) (P2 ~> Q2) h"
-apply (unfold Leadsto_def)
-apply (rule strength_Box)
-apply (erule strength_IMPLIES)
-apply (erule strength_Diamond)
-done
-
-
-text {* Localizing Temporal Weakenings - 3 *}
-
-lemma weak_Diamond:
-"[| temp_weakening P Q h |]
-       ==> temp_weakening (<> P) (<> Q) h"
-apply (unfold Diamond_def)
-apply (rule weak_NOT)
-apply (rule strength_Box)
-apply (erule strength_NOT)
-done
-
-lemma weak_Leadsto:
-"[| temp_strengthening P1 P2 h;
-          temp_weakening Q1 Q2 h |]
-       ==> temp_weakening (P1 ~> Q1) (P2 ~> Q2) h"
-apply (unfold Leadsto_def)
-apply (rule weak_Box)
-apply (erule weak_IMPLIES)
-apply (erule weak_Diamond)
-done
-
-lemma weak_WF:
-  " !!A. [| !! s. Enabled A acts (h s) ==> Enabled C acts s|]
-    ==> temp_weakening (WF A acts) (WF C acts) h"
-apply (unfold WF_def)
-apply (rule weak_IMPLIES)
-apply (rule strength_Diamond)
-apply (rule strength_Box)
-apply (rule strength_Init)
-apply (rule_tac [2] weak_Box)
-apply (rule_tac [2] weak_Diamond)
-apply (rule_tac [2] weak_Init)
-apply (auto simp add: state_weakening_def state_strengthening_def
-  xt2_def plift_def option_lift_def NOT_def)
-done
-
-lemma weak_SF:
-  " !!A. [| !! s. Enabled A acts (h s) ==> Enabled C acts s|]
-    ==> temp_weakening (SF A acts) (SF C acts) h"
-apply (unfold SF_def)
-apply (rule weak_IMPLIES)
-apply (rule strength_Box)
-apply (rule strength_Diamond)
-apply (rule strength_Init)
-apply (rule_tac [2] weak_Box)
-apply (rule_tac [2] weak_Diamond)
-apply (rule_tac [2] weak_Init)
-apply (auto simp add: state_weakening_def state_strengthening_def
-  xt2_def plift_def option_lift_def NOT_def)
-done
-
-
-lemmas weak_strength_lemmas =
-  weak_OR weak_AND weak_NOT weak_IMPLIES weak_Box weak_Next weak_Init
-  weak_Diamond weak_Leadsto strength_OR strength_AND strength_NOT
-  strength_IMPLIES strength_Box strength_Next strength_Init
-  strength_Diamond strength_Leadsto weak_WF weak_SF
-
-ML {*
-fun abstraction_tac ctxt =
-  let val (cs, ss) = clasimpset_of ctxt in
-    SELECT_GOAL (auto_tac (cs addSIs @{thms weak_strength_lemmas},
-        ss addsimps [@{thm state_strengthening_def}, @{thm state_weakening_def}]))
-  end
-*}
-
-method_setup abstraction = {* Scan.succeed (SIMPLE_METHOD' o abstraction_tac) *} ""
-
-end

--- a/src/HOLCF/IOA/meta_theory/Asig.thy	Sat Nov 27 14:34:54 2010 -0800
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,101 +0,0 @@
-(*  Title:      HOL/IOA/meta_theory/Asig.thy
-    Author:     Olaf Müller, Tobias Nipkow & Konrad Slind
-*)
-
-header {* Action signatures *}
-
-theory Asig
-imports Main
-begin
-
-types
-  'a signature = "('a set * 'a set * 'a set)"
-
-definition
-  inputs :: "'action signature => 'action set" where
-  asig_inputs_def: "inputs = fst"
-
-definition
-  outputs :: "'action signature => 'action set" where
-  asig_outputs_def: "outputs = (fst o snd)"
-
-definition
-  internals :: "'action signature => 'action set" where
-  asig_internals_def: "internals = (snd o snd)"
-
-definition
-  actions :: "'action signature => 'action set" where
-  "actions(asig) = (inputs(asig) Un outputs(asig) Un internals(asig))"
-
-definition
-  externals :: "'action signature => 'action set" where
-  "externals(asig) = (inputs(asig) Un outputs(asig))"
-
-definition
-  locals :: "'action signature => 'action set" where
-  "locals asig = ((internals asig) Un (outputs asig))"
-
-definition
-  is_asig :: "'action signature => bool" where
-  "is_asig(triple) =
-     ((inputs(triple) Int outputs(triple) = {}) &
-      (outputs(triple) Int internals(triple) = {}) &
-      (inputs(triple) Int internals(triple) = {}))"
-
-definition
-  mk_ext_asig :: "'action signature => 'action signature" where
-  "mk_ext_asig(triple) = (inputs(triple), outputs(triple), {})"
-
-
-lemmas asig_projections = asig_inputs_def asig_outputs_def asig_internals_def
-
-lemma asig_triple_proj:
- "(outputs    (a,b,c) = b)   &
-  (inputs     (a,b,c) = a) &
-  (internals  (a,b,c) = c)"
-  apply (simp add: asig_projections)
-  done
-
-lemma int_and_ext_is_act: "[| a~:internals(S) ;a~:externals(S)|] ==> a~:actions(S)"
-apply (simp add: externals_def actions_def)
-done
-
-lemma ext_is_act: "[|a:externals(S)|] ==> a:actions(S)"
-apply (simp add: externals_def actions_def)
-done
-
-lemma int_is_act: "[|a:internals S|] ==> a:actions S"
-apply (simp add: asig_internals_def actions_def)
-done
-
-lemma inp_is_act: "[|a:inputs S|] ==> a:actions S"
-apply (simp add: asig_inputs_def actions_def)
-done
-
-lemma out_is_act: "[|a:outputs S|] ==> a:actions S"
-apply (simp add: asig_outputs_def actions_def)
-done
-
-lemma ext_and_act: "(x: actions S & x : externals S) = (x: externals S)"
-apply (fast intro!: ext_is_act)
-done
-
-lemma not_ext_is_int: "[|is_asig S;x: actions S|] ==> (x~:externals S) = (x: internals S)"
-apply (simp add: actions_def is_asig_def externals_def)
-apply blast
-done
-
-lemma not_ext_is_int_or_not_act: "is_asig S ==> (x~:externals S) = (x: internals S | x~:actions S)"
-apply (simp add: actions_def is_asig_def externals_def)
-apply blast
-done
-
-lemma int_is_not_ext:
- "[| is_asig (S); x:internals S |] ==> x~:externals S"
-apply (unfold externals_def actions_def is_asig_def)
-apply simp
-apply blast
-done
-
-
-end

--- a/src/HOLCF/IOA/meta_theory/Automata.thy	Sat Nov 27 14:34:54 2010 -0800
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,691 +0,0 @@
-(*  Title:      HOLCF/IOA/meta_theory/Automata.thy
-    Author:     Olaf Müller, Konrad Slind, Tobias Nipkow
-*)
-
-header {* The I/O automata of Lynch and Tuttle in HOLCF *}
-
-theory Automata
-imports Asig
-begin
-
-default_sort type
-
-types
-  ('a, 's) transition = "'s * 'a * 's"
-  ('a, 's) ioa = "'a signature * 's set * ('a,'s)transition set * ('a set set) * ('a set set)"
-
-consts
-
-  (* IO automata *)
-
-  asig_of        ::"('a,'s)ioa => 'a signature"
-  starts_of      ::"('a,'s)ioa => 's set"
-  trans_of       ::"('a,'s)ioa => ('a,'s)transition set"
-  wfair_of       ::"('a,'s)ioa => ('a set) set"
-  sfair_of       ::"('a,'s)ioa => ('a set) set"
-
-  is_asig_of     ::"('a,'s)ioa => bool"
-  is_starts_of   ::"('a,'s)ioa => bool"
-  is_trans_of    ::"('a,'s)ioa => bool"
-  input_enabled  ::"('a,'s)ioa => bool"
-  IOA            ::"('a,'s)ioa => bool"
-
-  (* constraints for fair IOA *)
-
-  fairIOA        ::"('a,'s)ioa => bool"
-  input_resistant::"('a,'s)ioa => bool"
-
-  (* enabledness of actions and action sets *)
-
-  enabled        ::"('a,'s)ioa => 'a => 's => bool"
-  Enabled    ::"('a,'s)ioa => 'a set => 's => bool"
-
-  (* action set keeps enabled until probably disabled by itself *)
-
-  en_persistent  :: "('a,'s)ioa => 'a set => bool"
-
- (* post_conditions for actions and action sets *)
-
-  was_enabled        ::"('a,'s)ioa => 'a => 's => bool"
-  set_was_enabled    ::"('a,'s)ioa => 'a set => 's => bool"
-
-  (* invariants *)
-  invariant     :: "[('a,'s)ioa, 's=>bool] => bool"
-
-  (* binary composition of action signatures and automata *)
-  asig_comp    ::"['a signature, 'a signature] => 'a signature"
-  compatible   ::"[('a,'s)ioa, ('a,'t)ioa] => bool"
-  par          ::"[('a,'s)ioa, ('a,'t)ioa] => ('a,'s*'t)ioa"  (infixr "||" 10)
-
-  (* hiding and restricting *)
-  hide_asig     :: "['a signature, 'a set] => 'a signature"
-  hide          :: "[('a,'s)ioa, 'a set] => ('a,'s)ioa"
-  restrict_asig :: "['a signature, 'a set] => 'a signature"
-  restrict      :: "[('a,'s)ioa, 'a set] => ('a,'s)ioa"
-
-  (* renaming *)
-  rename_set    :: "'a set => ('c => 'a option) => 'c set"
-  rename        :: "('a, 'b)ioa => ('c => 'a option) => ('c,'b)ioa"
-
-notation (xsymbols)
-  par  (infixr "\<parallel>" 10)
-
-
-inductive
-  reachable :: "('a, 's) ioa => 's => bool"
-  for C :: "('a, 's) ioa"
-  where
-    reachable_0:  "s : starts_of C ==> reachable C s"
-  | reachable_n:  "[| reachable C s; (s, a, t) : trans_of C |] ==> reachable C t"
-
-abbreviation
-  trans_of_syn  ("_ -_--_-> _" [81,81,81,81] 100) where
-  "s -a--A-> t == (s,a,t):trans_of A"
-
-notation (xsymbols)
-  trans_of_syn  ("_ \<midarrow>_\<midarrow>_\<longrightarrow> _" [81,81,81,81] 100)
-
-abbreviation "act A == actions (asig_of A)"
-abbreviation "ext A == externals (asig_of A)"
-abbreviation int where "int A == internals (asig_of A)"
-abbreviation "inp A == inputs (asig_of A)"
-abbreviation "out A == outputs (asig_of A)"
-abbreviation "local A == locals (asig_of A)"
-
-defs
-
-(* --------------------------------- IOA ---------------------------------*)
-
-asig_of_def:   "asig_of == fst"
-starts_of_def: "starts_of == (fst o snd)"
-trans_of_def:  "trans_of == (fst o snd o snd)"
-wfair_of_def:  "wfair_of == (fst o snd o snd o snd)"
-sfair_of_def:  "sfair_of == (snd o snd o snd o snd)"
-
-is_asig_of_def:
-  "is_asig_of A == is_asig (asig_of A)"
-
-is_starts_of_def:
-  "is_starts_of A ==  (~ starts_of A = {})"
-
-is_trans_of_def:
-  "is_trans_of A ==
-    (!triple. triple:(trans_of A) --> fst(snd(triple)):actions(asig_of A))"
-
-input_enabled_def:
-  "input_enabled A ==
-    (!a. (a:inputs(asig_of A)) --> (!s1. ? s2. (s1,a,s2):(trans_of A)))"
-
-
-ioa_def:
-  "IOA A == (is_asig_of A    &
-             is_starts_of A  &
-             is_trans_of A   &
-             input_enabled A)"
-
-
-invariant_def: "invariant A P == (!s. reachable A s --> P(s))"
-
-
-(* ------------------------- parallel composition --------------------------*)
-
-
-compatible_def:
-  "compatible A B ==
-  (((out A Int out B) = {}) &
-   ((int A Int act B) = {}) &
-   ((int B Int act A) = {}))"
-
-asig_comp_def:
-  "asig_comp a1 a2 ==
-     (((inputs(a1) Un inputs(a2)) - (outputs(a1) Un outputs(a2)),
-       (outputs(a1) Un outputs(a2)),
-       (internals(a1) Un internals(a2))))"
-
-par_def:
-  "(A || B) ==
-      (asig_comp (asig_of A) (asig_of B),
-       {pr. fst(pr):starts_of(A) & snd(pr):starts_of(B)},
-       {tr. let s = fst(tr); a = fst(snd(tr)); t = snd(snd(tr))
-            in (a:act A | a:act B) &
-               (if a:act A then
-                  (fst(s),a,fst(t)):trans_of(A)
-                else fst(t) = fst(s))
-               &
-               (if a:act B then
-                  (snd(s),a,snd(t)):trans_of(B)
-                else snd(t) = snd(s))},
-        wfair_of A Un wfair_of B,
-        sfair_of A Un sfair_of B)"
-
-
-(* ------------------------ hiding -------------------------------------------- *)
-
-restrict_asig_def:
-  "restrict_asig asig actns ==
-    (inputs(asig) Int actns,
-     outputs(asig) Int actns,
-     internals(asig) Un (externals(asig) - actns))"
-
-(* Notice that for wfair_of and sfair_of nothing has to be changed, as
-   changes from the outputs to the internals does not touch the locals as
-   a whole, which is of importance for fairness only *)
-
-restrict_def:
-  "restrict A actns ==
-    (restrict_asig (asig_of A) actns,
-     starts_of A,
-     trans_of A,
-     wfair_of A,
-     sfair_of A)"
-
-hide_asig_def:
-  "hide_asig asig actns ==
-    (inputs(asig) - actns,
-     outputs(asig) - actns,
-     internals(asig) Un actns)"
-
-hide_def:
-  "hide A actns ==
-    (hide_asig (asig_of A) actns,
-     starts_of A,
-     trans_of A,
-     wfair_of A,
-     sfair_of A)"
-
-(* ------------------------- renaming ------------------------------------------- *)
-
-rename_set_def:
-  "rename_set A ren == {b. ? x. Some x = ren b & x : A}"
-
-rename_def:
-"rename ioa ren ==
-  ((rename_set (inp ioa) ren,
-    rename_set (out ioa) ren,
-    rename_set (int ioa) ren),
-   starts_of ioa,
-   {tr. let s = fst(tr); a = fst(snd(tr));  t = snd(snd(tr))
-        in
-        ? x. Some(x) = ren(a) & (s,x,t):trans_of ioa},
-   {rename_set s ren | s. s: wfair_of ioa},
-   {rename_set s ren | s. s: sfair_of ioa})"
-
-(* ------------------------- fairness ----------------------------- *)
-
-fairIOA_def:
-  "fairIOA A == (! S : wfair_of A. S<= local A) &
-                (! S : sfair_of A. S<= local A)"
-
-input_resistant_def:
-  "input_resistant A == ! W : sfair_of A. ! s a t.
-                        reachable A s & reachable A t & a:inp A &
-                        Enabled A W s & s -a--A-> t
-                        --> Enabled A W t"
-
-enabled_def:
-  "enabled A a s == ? t. s-a--A-> t"
-
-Enabled_def:
-  "Enabled A W s == ? w:W. enabled A w s"
-
-en_persistent_def:
-  "en_persistent A W == ! s a t. Enabled A W s &
-                                 a ~:W &
-                                 s -a--A-> t
-                                 --> Enabled A W t"
-was_enabled_def:
-  "was_enabled A a t == ? s. s-a--A-> t"
-
-set_was_enabled_def:
-  "set_was_enabled A W t == ? w:W. was_enabled A w t"
-
-
-declare split_paired_Ex [simp del]
-
-lemmas ioa_projections = asig_of_def starts_of_def trans_of_def wfair_of_def sfair_of_def
-
-
-subsection "asig_of, starts_of, trans_of"
-
-lemma ioa_triple_proj: 
- "((asig_of (x,y,z,w,s)) = x)   &  
-  ((starts_of (x,y,z,w,s)) = y) &  
-  ((trans_of (x,y,z,w,s)) = z)  &  
-  ((wfair_of (x,y,z,w,s)) = w) &  
-  ((sfair_of (x,y,z,w,s)) = s)"
-  apply (simp add: ioa_projections)
-  done
-
-lemma trans_in_actions: 
-  "[| is_trans_of A; (s1,a,s2):trans_of(A) |] ==> a:act A"
-apply (unfold is_trans_of_def actions_def is_asig_def)
-  apply (erule allE, erule impE, assumption)
-  apply simp
-done
-
-lemma starts_of_par: 
-"starts_of(A || B) = {p. fst(p):starts_of(A) & snd(p):starts_of(B)}"
-  apply (simp add: par_def ioa_projections)
-done
-
-lemma trans_of_par: 
-"trans_of(A || B) = {tr. let s = fst(tr); a = fst(snd(tr)); t = snd(snd(tr))  
-             in (a:act A | a:act B) &  
-                (if a:act A then        
-                   (fst(s),a,fst(t)):trans_of(A)  
-                 else fst(t) = fst(s))             
-                &                                   
-                (if a:act B then                     
-                   (snd(s),a,snd(t)):trans_of(B)      
-                 else snd(t) = snd(s))}"
-
-apply (simp add: par_def ioa_projections)
-done
-
-
-subsection "actions and par"
-
-lemma actions_asig_comp: 
-  "actions(asig_comp a b) = actions(a) Un actions(b)"
-  apply (simp (no_asm) add: actions_def asig_comp_def asig_projections)
-  apply blast
-  done
-
-lemma asig_of_par: "asig_of(A || B) = asig_comp (asig_of A) (asig_of B)"
-  apply (simp add: par_def ioa_projections)
-  done
-
-
-lemma externals_of_par: "ext (A1||A2) =     
-   (ext A1) Un (ext A2)"
-apply (simp add: externals_def asig_of_par asig_comp_def
-  asig_inputs_def asig_outputs_def Un_def set_diff_eq)
-apply blast
-done
-
-lemma actions_of_par: "act (A1||A2) =     
-   (act A1) Un (act A2)"
-apply (simp add: actions_def asig_of_par asig_comp_def
-  asig_inputs_def asig_outputs_def asig_internals_def Un_def set_diff_eq)
-apply blast
-done
-
-lemma inputs_of_par: "inp (A1||A2) = 
-          ((inp A1) Un (inp A2)) - ((out A1) Un (out A2))"
-apply (simp add: actions_def asig_of_par asig_comp_def
-  asig_inputs_def asig_outputs_def Un_def set_diff_eq)
-done
-
-lemma outputs_of_par: "out (A1||A2) = 
-          (out A1) Un (out A2)"
-apply (simp add: actions_def asig_of_par asig_comp_def
-  asig_outputs_def Un_def set_diff_eq)
-done
-
-lemma internals_of_par: "int (A1||A2) = 
-          (int A1) Un (int A2)"
-apply (simp add: actions_def asig_of_par asig_comp_def
-  asig_inputs_def asig_outputs_def asig_internals_def Un_def set_diff_eq)
-done
-
-
-subsection "actions and compatibility"
-
-lemma compat_commute: "compatible A B = compatible B A"
-apply (simp add: compatible_def Int_commute)
-apply auto
-done
-
-lemma ext1_is_not_int2: 
- "[| compatible A1 A2; a:ext A1|] ==> a~:int A2"
-apply (unfold externals_def actions_def compatible_def)
-apply simp
-apply blast
-done
-
-(* just commuting the previous one: better commute compatible *)
-lemma ext2_is_not_int1: 
- "[| compatible A2 A1 ; a:ext A1|] ==> a~:int A2"
-apply (unfold externals_def actions_def compatible_def)
-apply simp
-apply blast
-done
-
-lemmas ext1_ext2_is_not_act2 = ext1_is_not_int2 [THEN int_and_ext_is_act, standard]
-lemmas ext1_ext2_is_not_act1 = ext2_is_not_int1 [THEN int_and_ext_is_act, standard]
-
-lemma intA_is_not_extB: 
- "[| compatible A B; x:int A |] ==> x~:ext B"
-apply (unfold externals_def actions_def compatible_def)
-apply simp
-apply blast
-done
-
-lemma intA_is_not_actB: 
-"[| compatible A B; a:int A |] ==> a ~: act B"
-apply (unfold externals_def actions_def compatible_def is_asig_def asig_of_def)
-apply simp
-apply blast
-done
-
-(* the only one that needs disjointness of outputs and of internals and _all_ acts *)
-lemma outAactB_is_inpB: 
-"[| compatible A B; a:out A ;a:act B|] ==> a : inp B"
-apply (unfold asig_outputs_def asig_internals_def actions_def asig_inputs_def 
-    compatible_def is_asig_def asig_of_def)
-apply simp
-apply blast
-done
-
-(* needed for propagation of input_enabledness from A,B to A||B *)
-lemma inpAAactB_is_inpBoroutB: 
-"[| compatible A B; a:inp A ;a:act B|] ==> a : inp B | a: out B"
-apply (unfold asig_outputs_def asig_internals_def actions_def asig_inputs_def 
-    compatible_def is_asig_def asig_of_def)
-apply simp
-apply blast
-done
-
-
-subsection "input_enabledness and par"
-
-
-(* ugly case distinctions. Heart of proof:
-     1. inpAAactB_is_inpBoroutB ie. internals are really hidden.
-     2. inputs_of_par: outputs are no longer inputs of par. This is important here *)
-lemma input_enabled_par: 
-"[| compatible A B; input_enabled A; input_enabled B|]  
-      ==> input_enabled (A||B)"
-apply (unfold input_enabled_def)
-apply (simp add: Let_def inputs_of_par trans_of_par)
-apply (tactic "safe_tac (global_claset_of @{theory Fun})")
-apply (simp add: inp_is_act)
-prefer 2
-apply (simp add: inp_is_act)
-(* a: inp A *)
-apply (case_tac "a:act B")
-(* a:act B *)
-apply (erule_tac x = "a" in allE)
-apply simp
-apply (drule inpAAactB_is_inpBoroutB)
-apply assumption
-apply assumption
-apply (erule_tac x = "a" in allE)
-apply simp
-apply (erule_tac x = "aa" in allE)
-apply (erule_tac x = "b" in allE)
-apply (erule exE)
-apply (erule exE)
-apply (rule_tac x = " (s2,s2a) " in exI)
-apply (simp add: inp_is_act)
-(* a~: act B*)
-apply (simp add: inp_is_act)
-apply (erule_tac x = "a" in allE)
-apply simp
-apply (erule_tac x = "aa" in allE)
-apply (erule exE)
-apply (rule_tac x = " (s2,b) " in exI)
-apply simp
-
-(* a:inp B *)
-apply (case_tac "a:act A")
-(* a:act A *)
-apply (erule_tac x = "a" in allE)
-apply (erule_tac x = "a" in allE)
-apply (simp add: inp_is_act)
-apply (frule_tac A1 = "A" in compat_commute [THEN iffD1])
-apply (drule inpAAactB_is_inpBoroutB)
-back
-apply assumption
-apply assumption
-apply simp
-apply (erule_tac x = "aa" in allE)
-apply (erule_tac x = "b" in allE)
-apply (erule exE)
-apply (erule exE)
-apply (rule_tac x = " (s2,s2a) " in exI)
-apply (simp add: inp_is_act)
-(* a~: act B*)
-apply (simp add: inp_is_act)
-apply (erule_tac x = "a" in allE)
-apply (erule_tac x = "a" in allE)
-apply simp
-apply (erule_tac x = "b" in allE)
-apply (erule exE)
-apply (rule_tac x = " (aa,s2) " in exI)
-apply simp
-done
-
-
-subsection "invariants"
-
-lemma invariantI:
-  "[| !!s. s:starts_of(A) ==> P(s);      
-      !!s t a. [|reachable A s; P(s)|] ==> (s,a,t): trans_of(A) --> P(t) |]  
-   ==> invariant A P"
-apply (unfold invariant_def)
-apply (rule allI)
-apply (rule impI)
-apply (rule_tac x = "s" in reachable.induct)
-apply assumption
-apply blast
-apply blast
-done
-
-lemma invariantI1:
- "[| !!s. s : starts_of(A) ==> P(s);  
-     !!s t a. reachable A s ==> P(s) --> (s,a,t):trans_of(A) --> P(t)  
-  |] ==> invariant A P"
-  apply (blast intro: invariantI)
-  done
-
-lemma invariantE: "[| invariant A P; reachable A s |] ==> P(s)"
-  apply (unfold invariant_def)
-  apply blast
-  done
-
-
-subsection "restrict"
-
-
-lemmas reachable_0 = reachable.reachable_0
-  and reachable_n = reachable.reachable_n
-
-lemma cancel_restrict_a: "starts_of(restrict ioa acts) = starts_of(ioa) &      
-          trans_of(restrict ioa acts) = trans_of(ioa)"
-apply (simp add: restrict_def ioa_projections)
-done
-
-lemma cancel_restrict_b: "reachable (restrict ioa acts) s = reachable ioa s"
-apply (rule iffI)
-apply (erule reachable.induct)
-apply (simp add: cancel_restrict_a reachable_0)
-apply (erule reachable_n)
-apply (simp add: cancel_restrict_a)
-(* <--  *)
-apply (erule reachable.induct)
-apply (rule reachable_0)
-apply (simp add: cancel_restrict_a)
-apply (erule reachable_n)
-apply (simp add: cancel_restrict_a)
-done
-
-lemma acts_restrict: "act (restrict A acts) = act A"
-apply (simp (no_asm) add: actions_def asig_internals_def
-  asig_outputs_def asig_inputs_def externals_def asig_of_def restrict_def restrict_asig_def)
-apply auto
-done
-
-lemma cancel_restrict: "starts_of(restrict ioa acts) = starts_of(ioa) &      
-          trans_of(restrict ioa acts) = trans_of(ioa) &  
-          reachable (restrict ioa acts) s = reachable ioa s &  
-          act (restrict A acts) = act A"
-  apply (simp (no_asm) add: cancel_restrict_a cancel_restrict_b acts_restrict)
-  done
-
-
-subsection "rename"
-
-lemma trans_rename: "s -a--(rename C f)-> t ==> (? x. Some(x) = f(a) & s -x--C-> t)"
-apply (simp add: Let_def rename_def trans_of_def)
-done
-
-
-lemma reachable_rename: "[| reachable (rename C g) s |] ==> reachable C s"
-apply (erule reachable.induct)
-apply (rule reachable_0)
-apply (simp add: rename_def ioa_projections)
-apply (drule trans_rename)
-apply (erule exE)
-apply (erule conjE)
-apply (erule reachable_n)
-apply assumption
-done
-
-
-subsection "trans_of(A||B)"
-
-
-lemma trans_A_proj: "[|(s,a,t):trans_of (A||B); a:act A|]  
-              ==> (fst s,a,fst t):trans_of A"
-apply (simp add: Let_def par_def trans_of_def)
-done
-
-lemma trans_B_proj: "[|(s,a,t):trans_of (A||B); a:act B|]  
-              ==> (snd s,a,snd t):trans_of B"
-apply (simp add: Let_def par_def trans_of_def)
-done
-
-lemma trans_A_proj2: "[|(s,a,t):trans_of (A||B); a~:act A|] 
-              ==> fst s = fst t"
-apply (simp add: Let_def par_def trans_of_def)
-done
-
-lemma trans_B_proj2: "[|(s,a,t):trans_of (A||B); a~:act B|] 
-              ==> snd s = snd t"
-apply (simp add: Let_def par_def trans_of_def)
-done
-
-lemma trans_AB_proj: "(s,a,t):trans_of (A||B)  
-               ==> a :act A | a :act B"
-apply (simp add: Let_def par_def trans_of_def)
-done
-
-lemma trans_AB: "[|a:act A;a:act B; 
-       (fst s,a,fst t):trans_of A;(snd s,a,snd t):trans_of B|] 
-   ==> (s,a,t):trans_of (A||B)"
-apply (simp add: Let_def par_def trans_of_def)
-done
-
-lemma trans_A_notB: "[|a:act A;a~:act B; 
-       (fst s,a,fst t):trans_of A;snd s=snd t|] 
-   ==> (s,a,t):trans_of (A||B)"
-apply (simp add: Let_def par_def trans_of_def)
-done
-
-lemma trans_notA_B: "[|a~:act A;a:act B; 
-       (snd s,a,snd t):trans_of B;fst s=fst t|] 
-   ==> (s,a,t):trans_of (A||B)"
-apply (simp add: Let_def par_def trans_of_def)
-done
-
-lemmas trans_of_defs1 = trans_AB trans_A_notB trans_notA_B
-  and trans_of_defs2 = trans_A_proj trans_B_proj trans_A_proj2 trans_B_proj2 trans_AB_proj
-
-
-lemma trans_of_par4: 
-"((s,a,t) : trans_of(A || B || C || D)) =                                     
-  ((a:actions(asig_of(A)) | a:actions(asig_of(B)) | a:actions(asig_of(C)) |   
-    a:actions(asig_of(D))) &                                                  
-   (if a:actions(asig_of(A)) then (fst(s),a,fst(t)):trans_of(A)               
-    else fst t=fst s) &                                                       
-   (if a:actions(asig_of(B)) then (fst(snd(s)),a,fst(snd(t))):trans_of(B)     
-    else fst(snd(t))=fst(snd(s))) &                                           
-   (if a:actions(asig_of(C)) then                                             
-      (fst(snd(snd(s))),a,fst(snd(snd(t)))):trans_of(C)                       
-    else fst(snd(snd(t)))=fst(snd(snd(s)))) &                                 
-   (if a:actions(asig_of(D)) then                                             
-      (snd(snd(snd(s))),a,snd(snd(snd(t)))):trans_of(D)                       
-    else snd(snd(snd(t)))=snd(snd(snd(s)))))"
-  apply (simp (no_asm) add: par_def actions_asig_comp Pair_fst_snd_eq Let_def ioa_projections)
-  done
-
-
-subsection "proof obligation generator for IOA requirements"
-
-(* without assumptions on A and B because is_trans_of is also incorporated in ||def *)
-lemma is_trans_of_par: "is_trans_of (A||B)"
-apply (unfold is_trans_of_def)
-apply (simp add: Let_def actions_of_par trans_of_par)
-done
-
-lemma is_trans_of_restrict: 
-"is_trans_of A ==> is_trans_of (restrict A acts)"
-apply (unfold is_trans_of_def)
-apply (simp add: cancel_restrict acts_restrict)
-done
-
-lemma is_trans_of_rename: 
-"is_trans_of A ==> is_trans_of (rename A f)"
-apply (unfold is_trans_of_def restrict_def restrict_asig_def)
-apply (simp add: Let_def actions_def trans_of_def asig_internals_def
-  asig_outputs_def asig_inputs_def externals_def asig_of_def rename_def rename_set_def)
-apply blast
-done
-
-lemma is_asig_of_par: "[| is_asig_of A; is_asig_of B; compatible A B|]   
-          ==> is_asig_of (A||B)"
-apply (simp add: is_asig_of_def asig_of_par asig_comp_def compatible_def
-  asig_internals_def asig_outputs_def asig_inputs_def actions_def is_asig_def)
-apply (simp add: asig_of_def)
-apply auto
-done
-
-lemma is_asig_of_restrict: 
-"is_asig_of A ==> is_asig_of (restrict A f)"
-apply (unfold is_asig_of_def is_asig_def asig_of_def restrict_def restrict_asig_def 
-           asig_internals_def asig_outputs_def asig_inputs_def externals_def o_def)
-apply simp
-apply auto
-done
-
-lemma is_asig_of_rename: "is_asig_of A ==> is_asig_of (rename A f)"
-apply (simp add: is_asig_of_def rename_def rename_set_def asig_internals_def
-  asig_outputs_def asig_inputs_def actions_def is_asig_def asig_of_def)
-apply auto
-apply (drule_tac [!] s = "Some ?x" in sym)
-apply auto
-done
-
-lemmas [simp] = is_asig_of_par is_asig_of_restrict
-  is_asig_of_rename is_trans_of_par is_trans_of_restrict is_trans_of_rename
-
-
-lemma compatible_par: 
-"[|compatible A B; compatible A C |]==> compatible A (B||C)"
-apply (unfold compatible_def)
-apply (simp add: internals_of_par outputs_of_par actions_of_par)
-apply auto
-done
-
-(*  better derive by previous one and compat_commute *)
-lemma compatible_par2: 
-"[|compatible A C; compatible B C |]==> compatible (A||B) C"
-apply (unfold compatible_def)
-apply (simp add: internals_of_par outputs_of_par actions_of_par)
-apply auto
-done
-
-lemma compatible_restrict: 
-"[| compatible A B; (ext B - S) Int ext A = {}|]  
-      ==> compatible A (restrict B S)"
-apply (unfold compatible_def)
-apply (simp add: ioa_triple_proj asig_triple_proj externals_def
-  restrict_def restrict_asig_def actions_def)
-apply auto
-done
-
-
-declare split_paired_Ex [simp]
-
-end

--- a/src/HOLCF/IOA/meta_theory/CompoExecs.thy	Sat Nov 27 14:34:54 2010 -0800
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,303 +0,0 @@
-(*  Title:      HOLCF/IOA/meta_theory/CompoExecs.thy
-    Author:     Olaf Müller
-*)
-
-header {* Compositionality on Execution level *}
-
-theory CompoExecs
-imports Traces
-begin
-
-definition
-  ProjA2 :: "('a,'s * 't)pairs -> ('a,'s)pairs" where
-  "ProjA2 = Map (%x.(fst x,fst(snd x)))"
-
-definition
-  ProjA :: "('a,'s * 't)execution => ('a,'s)execution" where
-  "ProjA ex = (fst (fst ex), ProjA2$(snd ex))"
-
-definition
-  ProjB2 :: "('a,'s * 't)pairs -> ('a,'t)pairs" where
-  "ProjB2 = Map (%x.(fst x,snd(snd x)))"
-
-definition
-  ProjB :: "('a,'s * 't)execution => ('a,'t)execution" where
-  "ProjB ex = (snd (fst ex), ProjB2$(snd ex))"
-
-definition
-  Filter_ex2 :: "'a signature => ('a,'s)pairs -> ('a,'s)pairs" where
-  "Filter_ex2 sig = Filter (%x. fst x:actions sig)"
-
-definition
-  Filter_ex :: "'a signature => ('a,'s)execution => ('a,'s)execution" where
-  "Filter_ex sig ex = (fst ex,Filter_ex2 sig$(snd ex))"
-
-definition
-  stutter2 :: "'a signature => ('a,'s)pairs -> ('s => tr)" where
-  "stutter2 sig = (fix$(LAM h ex. (%s. case ex of
-      nil => TT
-    | x##xs => (flift1
-            (%p.(If Def ((fst p)~:actions sig)
-                 then Def (s=(snd p))
-                 else TT)
-                andalso (h$xs) (snd p))
-             $x)
-   )))"
-
-definition
-  stutter :: "'a signature => ('a,'s)execution => bool" where
-  "stutter sig ex = ((stutter2 sig$(snd ex)) (fst ex) ~= FF)"
-
-definition
-  par_execs :: "[('a,'s)execution_module,('a,'t)execution_module] => ('a,'s*'t)execution_module" where
-  "par_execs ExecsA ExecsB =
-      (let exA = fst ExecsA; sigA = snd ExecsA;
-           exB = fst ExecsB; sigB = snd ExecsB
-       in
-       (    {ex. Filter_ex sigA (ProjA ex) : exA}
-        Int {ex. Filter_ex sigB (ProjB ex) : exB}
-        Int {ex. stutter sigA (ProjA ex)}
-        Int {ex. stutter sigB (ProjB ex)}
-        Int {ex. Forall (%x. fst x:(actions sigA Un actions sigB)) (snd ex)},
-        asig_comp sigA sigB))"
-
-
-lemmas [simp del] = split_paired_All
-
-
-section "recursive equations of operators"
-
-
-(* ---------------------------------------------------------------- *)
-(*                               ProjA2                             *)
-(* ---------------------------------------------------------------- *)
-
-
-lemma ProjA2_UU: "ProjA2$UU = UU"
-apply (simp add: ProjA2_def)
-done
-
-lemma ProjA2_nil: "ProjA2$nil = nil"
-apply (simp add: ProjA2_def)
-done
-
-lemma ProjA2_cons: "ProjA2$((a,t)>>xs) = (a,fst t) >> ProjA2$xs"
-apply (simp add: ProjA2_def)
-done
-
-
-(* ---------------------------------------------------------------- *)
-(*                               ProjB2                             *)
-(* ---------------------------------------------------------------- *)
-
-
-lemma ProjB2_UU: "ProjB2$UU = UU"
-apply (simp add: ProjB2_def)
-done
-
-lemma ProjB2_nil: "ProjB2$nil = nil"
-apply (simp add: ProjB2_def)
-done
-
-lemma ProjB2_cons: "ProjB2$((a,t)>>xs) = (a,snd t) >> ProjB2$xs"
-apply (simp add: ProjB2_def)
-done
-
-
-
-(* ---------------------------------------------------------------- *)
-(*                             Filter_ex2                           *)
-(* ---------------------------------------------------------------- *)
-
-
-lemma Filter_ex2_UU: "Filter_ex2 sig$UU=UU"
-apply (simp add: Filter_ex2_def)
-done
-
-lemma Filter_ex2_nil: "Filter_ex2 sig$nil=nil"
-apply (simp add: Filter_ex2_def)
-done
-
-lemma Filter_ex2_cons: "Filter_ex2 sig$(at >> xs) =
-             (if (fst at:actions sig)
-                  then at >> (Filter_ex2 sig$xs)
-                  else        Filter_ex2 sig$xs)"
-
-apply (simp add: Filter_ex2_def)
-done
-
-
-(* ---------------------------------------------------------------- *)
-(*                             stutter2                             *)
-(* ---------------------------------------------------------------- *)
-
-
-lemma stutter2_unfold: "stutter2 sig = (LAM ex. (%s. case ex of
-       nil => TT
-     | x##xs => (flift1
-             (%p.(If Def ((fst p)~:actions sig)
-                  then Def (s=(snd p))
-                  else TT)
-                 andalso (stutter2 sig$xs) (snd p))
-              $x)
-            ))"
-apply (rule trans)
-apply (rule fix_eq2)
-apply (simp only: stutter2_def)
-apply (rule beta_cfun)
-apply (simp add: flift1_def)
-done
-
-lemma stutter2_UU: "(stutter2 sig$UU) s=UU"
-apply (subst stutter2_unfold)
-apply simp
-done
-
-lemma stutter2_nil: "(stutter2 sig$nil) s = TT"
-apply (subst stutter2_unfold)
-apply simp
-done
-
-lemma stutter2_cons: "(stutter2 sig$(at>>xs)) s =
-               ((if (fst at)~:actions sig then Def (s=snd at) else TT)
-                 andalso (stutter2 sig$xs) (snd at))"
-apply (rule trans)
-apply (subst stutter2_unfold)
-apply (simp add: Consq_def flift1_def If_and_if)
-apply simp
-done
-
-
-declare stutter2_UU [simp] stutter2_nil [simp] stutter2_cons [simp]
-
-
-(* ---------------------------------------------------------------- *)
-(*                             stutter                              *)
-(* ---------------------------------------------------------------- *)
-
-lemma stutter_UU: "stutter sig (s, UU)"
-apply (simp add: stutter_def)
-done
-
-lemma stutter_nil: "stutter sig (s, nil)"
-apply (simp add: stutter_def)
-done
-
-lemma stutter_cons: "stutter sig (s, (a,t)>>ex) =
-      ((a~:actions sig --> (s=t)) & stutter sig (t,ex))"
-apply (simp add: stutter_def)
-done
-
-(* ----------------------------------------------------------------------------------- *)
-
-declare stutter2_UU [simp del] stutter2_nil [simp del] stutter2_cons [simp del]
-
-lemmas compoex_simps = ProjA2_UU ProjA2_nil ProjA2_cons
-  ProjB2_UU ProjB2_nil ProjB2_cons
-  Filter_ex2_UU Filter_ex2_nil Filter_ex2_cons
-  stutter_UU stutter_nil stutter_cons
-
-declare compoex_simps [simp]
-
-
-
-(* ------------------------------------------------------------------ *)
-(*                      The following lemmata aim for                 *)
-(*             COMPOSITIONALITY   on    EXECUTION     Level           *)
-(* ------------------------------------------------------------------ *)
-
-
-(* --------------------------------------------------------------------- *)
-(*  Lemma_1_1a : is_ex_fr propagates from A||B to Projections A and B    *)
-(* --------------------------------------------------------------------- *)
-
-lemma lemma_1_1a: "!s. is_exec_frag (A||B) (s,xs)
-       -->  is_exec_frag A (fst s, Filter_ex2 (asig_of A)$(ProjA2$xs)) &
-            is_exec_frag B (snd s, Filter_ex2 (asig_of B)$(ProjB2$xs))"
-
-apply (tactic {* pair_induct_tac @{context} "xs" [@{thm is_exec_frag_def}] 1 *})
-(* main case *)
-apply (auto simp add: trans_of_defs2)
-done
-
-
-(* --------------------------------------------------------------------- *)
-(*  Lemma_1_1b : is_ex_fr (A||B) implies stuttering on Projections       *)
-(* --------------------------------------------------------------------- *)
-
-lemma lemma_1_1b: "!s. is_exec_frag (A||B) (s,xs)
-       --> stutter (asig_of A) (fst s,ProjA2$xs)  &
-           stutter (asig_of B) (snd s,ProjB2$xs)"
-
-apply (tactic {* pair_induct_tac @{context} "xs"
-  [@{thm stutter_def}, @{thm is_exec_frag_def}] 1 *})
-(* main case *)
-apply (auto simp add: trans_of_defs2)
-done
-
-
-(* --------------------------------------------------------------------- *)
-(*  Lemma_1_1c : Executions of A||B have only  A- or B-actions           *)
-(* --------------------------------------------------------------------- *)
-
-lemma lemma_1_1c: "!s. (is_exec_frag (A||B) (s,xs)
-   --> Forall (%x. fst x:act (A||B)) xs)"
-
-apply (tactic {* pair_induct_tac @{context} "xs" [@{thm Forall_def}, @{thm sforall_def},
-  @{thm is_exec_frag_def}] 1 *})
-(* main case *)
-apply auto
-apply (simp add: trans_of_defs2 actions_asig_comp asig_of_par)
-done
-
-
-(* ----------------------------------------------------------------------- *)
-(*  Lemma_1_2 : ex A, exB, stuttering and forall a:A|B implies ex (A||B)   *)
-(* ----------------------------------------------------------------------- *)
-
-lemma lemma_1_2:
-"!s. is_exec_frag A (fst s,Filter_ex2 (asig_of A)$(ProjA2$xs)) &
-     is_exec_frag B (snd s,Filter_ex2 (asig_of B)$(ProjB2$xs)) &
-     stutter (asig_of A) (fst s,(ProjA2$xs)) &
-     stutter (asig_of B) (snd s,(ProjB2$xs)) &
-     Forall (%x. fst x:act (A||B)) xs
-     --> is_exec_frag (A||B) (s,xs)"
-
-apply (tactic {* pair_induct_tac @{context} "xs" [@{thm Forall_def}, @{thm sforall_def},
-  @{thm is_exec_frag_def}, @{thm stutter_def}] 1 *})
-apply (auto simp add: trans_of_defs1 actions_asig_comp asig_of_par)
-done
-
-
-subsection {* COMPOSITIONALITY on EXECUTION Level -- Main Theorem *}
-
-lemma compositionality_ex:
-"(ex:executions(A||B)) =
- (Filter_ex (asig_of A) (ProjA ex) : executions A &
-  Filter_ex (asig_of B) (ProjB ex) : executions B &
-  stutter (asig_of A) (ProjA ex) & stutter (asig_of B) (ProjB ex) &
-  Forall (%x. fst x:act (A||B)) (snd ex))"
-
-apply (simp (no_asm) add: executions_def ProjB_def Filter_ex_def ProjA_def starts_of_par)
-apply (tactic {* pair_tac @{context} "ex" 1 *})
-apply (rule iffI)
-(* ==>  *)
-apply (erule conjE)+
-apply (simp add: lemma_1_1a lemma_1_1b lemma_1_1c)
-(* <==  *)
-apply (erule conjE)+
-apply (simp add: lemma_1_2)
-done
-
-
-subsection {* COMPOSITIONALITY on EXECUTION Level -- for Modules *}
-
-lemma compositionality_ex_modules:
-  "Execs (A||B) = par_execs (Execs A) (Execs B)"
-apply (unfold Execs_def par_execs_def)
-apply (simp add: asig_of_par)
-apply (rule set_eqI)
-apply (simp add: compositionality_ex actions_of_par)
-done
-
-end

--- a/src/HOLCF/IOA/meta_theory/CompoScheds.thy	Sat Nov 27 14:34:54 2010 -0800
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,553 +0,0 @@
-(*  Title:      HOLCF/IOA/meta_theory/CompoScheds.thy
-    Author:     Olaf Müller
-*)
-
-header {* Compositionality on Schedule level *}
-
-theory CompoScheds
-imports CompoExecs
-begin
-
-definition
-  mkex2 :: "('a,'s)ioa => ('a,'t)ioa => 'a Seq ->
-              ('a,'s)pairs -> ('a,'t)pairs ->
-              ('s => 't => ('a,'s*'t)pairs)" where
-  "mkex2 A B = (fix$(LAM h sch exA exB. (%s t. case sch of
-       nil => nil
-    | x##xs =>
-      (case x of
-        UU => UU
-      | Def y =>
-         (if y:act A then
-             (if y:act B then
-                (case HD$exA of
-                   UU => UU
-                 | Def a => (case HD$exB of
-                              UU => UU
-                            | Def b =>
-                   (y,(snd a,snd b))>>
-                     (h$xs$(TL$exA)$(TL$exB)) (snd a) (snd b)))
-              else
-                (case HD$exA of
-                   UU => UU
-                 | Def a =>
-                   (y,(snd a,t))>>(h$xs$(TL$exA)$exB) (snd a) t)
-              )
-          else
-             (if y:act B then
-                (case HD$exB of
-                   UU => UU
-                 | Def b =>
-                   (y,(s,snd b))>>(h$xs$exA$(TL$exB)) s (snd b))
-             else
-               UU
-             )
-         )
-       ))))"
-
-definition
-  mkex :: "('a,'s)ioa => ('a,'t)ioa => 'a Seq =>
-              ('a,'s)execution => ('a,'t)execution =>('a,'s*'t)execution" where
-  "mkex A B sch exA exB =
-       ((fst exA,fst exB),
-        (mkex2 A B$sch$(snd exA)$(snd exB)) (fst exA) (fst exB))"
-
-definition
-  par_scheds ::"['a schedule_module,'a schedule_module] => 'a schedule_module" where
-  "par_scheds SchedsA SchedsB =
-      (let schA = fst SchedsA; sigA = snd SchedsA;
-           schB = fst SchedsB; sigB = snd SchedsB
-       in
-       (    {sch. Filter (%a. a:actions sigA)$sch : schA}
-        Int {sch. Filter (%a. a:actions sigB)$sch : schB}
-        Int {sch. Forall (%x. x:(actions sigA Un actions sigB)) sch},
-        asig_comp sigA sigB))"
-
-
-subsection "mkex rewrite rules"
-
-
-lemma mkex2_unfold:
-"mkex2 A B = (LAM sch exA exB. (%s t. case sch of
-      nil => nil
-   | x##xs =>
-     (case x of
-       UU => UU
-     | Def y =>
-        (if y:act A then
-            (if y:act B then
-               (case HD$exA of
-                  UU => UU
-                | Def a => (case HD$exB of
-                             UU => UU
-                           | Def b =>
-                  (y,(snd a,snd b))>>
-                    (mkex2 A B$xs$(TL$exA)$(TL$exB)) (snd a) (snd b)))
-             else
-               (case HD$exA of
-                  UU => UU
-                | Def a =>
-                  (y,(snd a,t))>>(mkex2 A B$xs$(TL$exA)$exB) (snd a) t)
-             )
-         else
-            (if y:act B then
-               (case HD$exB of
-                  UU => UU
-                | Def b =>
-                  (y,(s,snd b))>>(mkex2 A B$xs$exA$(TL$exB)) s (snd b))
-            else
-              UU
-            )
-        )
-      )))"
-apply (rule trans)
-apply (rule fix_eq2)
-apply (simp only: mkex2_def)
-apply (rule beta_cfun)
-apply simp
-done
-
-lemma mkex2_UU: "(mkex2 A B$UU$exA$exB) s t = UU"
-apply (subst mkex2_unfold)
-apply simp
-done
-
-lemma mkex2_nil: "(mkex2 A B$nil$exA$exB) s t= nil"
-apply (subst mkex2_unfold)
-apply simp
-done
-
-lemma mkex2_cons_1: "[| x:act A; x~:act B; HD$exA=Def a|]
-    ==> (mkex2 A B$(x>>sch)$exA$exB) s t =
-        (x,snd a,t) >> (mkex2 A B$sch$(TL$exA)$exB) (snd a) t"
-apply (rule trans)
-apply (subst mkex2_unfold)
-apply (simp add: Consq_def If_and_if)
-apply (simp add: Consq_def)
-done
-
-lemma mkex2_cons_2: "[| x~:act A; x:act B; HD$exB=Def b|]
-    ==> (mkex2 A B$(x>>sch)$exA$exB) s t =
-        (x,s,snd b) >> (mkex2 A B$sch$exA$(TL$exB)) s (snd b)"
-apply (rule trans)
-apply (subst mkex2_unfold)
-apply (simp add: Consq_def If_and_if)
-apply (simp add: Consq_def)
-done
-
-lemma mkex2_cons_3: "[| x:act A; x:act B; HD$exA=Def a;HD$exB=Def b|]
-    ==> (mkex2 A B$(x>>sch)$exA$exB) s t =
-         (x,snd a,snd b) >>
-            (mkex2 A B$sch$(TL$exA)$(TL$exB)) (snd a) (snd b)"
-apply (rule trans)
-apply (subst mkex2_unfold)
-apply (simp add: Consq_def If_and_if)
-apply (simp add: Consq_def)
-done
-
-declare mkex2_UU [simp] mkex2_nil [simp] mkex2_cons_1 [simp]
-  mkex2_cons_2 [simp] mkex2_cons_3 [simp]
-
-
-subsection {* mkex *}
-
-lemma mkex_UU: "mkex A B UU  (s,exA) (t,exB) = ((s,t),UU)"
-apply (simp add: mkex_def)
-done
-
-lemma mkex_nil: "mkex A B nil (s,exA) (t,exB) = ((s,t),nil)"
-apply (simp add: mkex_def)
-done
-
-lemma mkex_cons_1: "[| x:act A; x~:act B |]
-    ==> mkex A B (x>>sch) (s,a>>exA) (t,exB)  =
-        ((s,t), (x,snd a,t) >> snd (mkex A B sch (snd a,exA) (t,exB)))"
-apply (simp (no_asm) add: mkex_def)
-apply (cut_tac exA = "a>>exA" in mkex2_cons_1)
-apply auto
-done
-
-lemma mkex_cons_2: "[| x~:act A; x:act B |]
-    ==> mkex A B (x>>sch) (s,exA) (t,b>>exB) =
-        ((s,t), (x,s,snd b) >> snd (mkex A B sch (s,exA) (snd b,exB)))"
-apply (simp (no_asm) add: mkex_def)
-apply (cut_tac exB = "b>>exB" in mkex2_cons_2)
-apply auto
-done
-
-lemma mkex_cons_3: "[| x:act A; x:act B |]
-    ==>  mkex A B (x>>sch) (s,a>>exA) (t,b>>exB) =
-         ((s,t), (x,snd a,snd b) >> snd (mkex A B sch (snd a,exA) (snd b,exB)))"
-apply (simp (no_asm) add: mkex_def)
-apply (cut_tac exB = "b>>exB" and exA = "a>>exA" in mkex2_cons_3)
-apply auto
-done
-
-declare mkex2_UU [simp del] mkex2_nil [simp del]
-  mkex2_cons_1 [simp del] mkex2_cons_2 [simp del] mkex2_cons_3 [simp del]
-
-lemmas composch_simps = mkex_UU mkex_nil mkex_cons_1 mkex_cons_2 mkex_cons_3
-
-declare composch_simps [simp]
-
-
-subsection {* COMPOSITIONALITY on SCHEDULE Level *}
-
-subsubsection "Lemmas for ==>"
-
-(* --------------------------------------------------------------------- *)
-(*    Lemma_2_1 :  tfilter(ex) and filter_act are commutative            *)
-(* --------------------------------------------------------------------- *)
-
-lemma lemma_2_1a:
-   "filter_act$(Filter_ex2 (asig_of A)$xs)=
-    Filter (%a. a:act A)$(filter_act$xs)"
-
-apply (unfold filter_act_def Filter_ex2_def)
-apply (simp (no_asm) add: MapFilter o_def)
-done
-
-
-(* --------------------------------------------------------------------- *)
-(*    Lemma_2_2 : State-projections do not affect filter_act             *)
-(* --------------------------------------------------------------------- *)
-
-lemma lemma_2_1b:
-   "filter_act$(ProjA2$xs) =filter_act$xs &
-    filter_act$(ProjB2$xs) =filter_act$xs"
-apply (tactic {* pair_induct_tac @{context} "xs" [] 1 *})
-done
-
-
-(* --------------------------------------------------------------------- *)
-(*             Schedules of A||B have only  A- or B-actions              *)
-(* --------------------------------------------------------------------- *)
-
-(* very similar to lemma_1_1c, but it is not checking if every action element of
-   an ex is in A or B, but after projecting it onto the action schedule. Of course, this
-   is the same proposition, but we cannot change this one, when then rather lemma_1_1c  *)
-
-lemma sch_actions_in_AorB: "!s. is_exec_frag (A||B) (s,xs)
-   --> Forall (%x. x:act (A||B)) (filter_act$xs)"
-
-apply (tactic {* pair_induct_tac @{context} "xs" [@{thm is_exec_frag_def}, @{thm Forall_def},
-  @{thm sforall_def}] 1 *})
-(* main case *)
-apply auto
-apply (simp add: trans_of_defs2 actions_asig_comp asig_of_par)
-done
-
-
-subsubsection "Lemmas for <=="
-
-(*---------------------------------------------------------------------------
-    Filtering actions out of mkex(sch,exA,exB) yields the oracle sch
-                             structural induction
-  --------------------------------------------------------------------------- *)
-
-lemma Mapfst_mkex_is_sch: "! exA exB s t.
-  Forall (%x. x:act (A||B)) sch  &
-  Filter (%a. a:act A)$sch << filter_act$exA &
-  Filter (%a. a:act B)$sch << filter_act$exB
-  --> filter_act$(snd (mkex A B sch (s,exA) (t,exB))) = sch"
-
-apply (tactic {* Seq_induct_tac @{context} "sch" [@{thm Filter_def}, @{thm Forall_def},
-  @{thm sforall_def}, @{thm mkex_def}] 1 *})
-
-(* main case *)
-(* splitting into 4 cases according to a:A, a:B *)
-apply auto
-
-(* Case y:A, y:B *)
-apply (tactic {* Seq_case_simp_tac @{context} "exA" 1 *})
-(* Case exA=UU, Case exA=nil*)
-(* These UU and nil cases are the only places where the assumption filter A sch<<f_act exA
-   is used! --> to generate a contradiction using  ~a>>ss<< UU(nil), using theorems
-   Cons_not_less_UU and Cons_not_less_nil  *)
-apply (tactic {* Seq_case_simp_tac @{context} "exB" 1 *})
-(* Case exA=a>>x, exB=b>>y *)
-(* here it is important that Seq_case_simp_tac uses no !full!_simp_tac for the cons case,
-   as otherwise mkex_cons_3 would  not be rewritten without use of rotate_tac: then tactic
-   would not be generally applicable *)
-apply simp
-
-(* Case y:A, y~:B *)
-apply (tactic {* Seq_case_simp_tac @{context} "exA" 1 *})
-apply simp
-
-(* Case y~:A, y:B *)
-apply (tactic {* Seq_case_simp_tac @{context} "exB" 1 *})
-apply simp
-
-(* Case y~:A, y~:B *)
-apply (simp add: asig_of_par actions_asig_comp)
-done
-
-
-(* generalizing the proof above to a tactic *)
-
-ML {*
-
-local
-  val defs = [@{thm Filter_def}, @{thm Forall_def}, @{thm sforall_def}, @{thm mkex_def},
-    @{thm stutter_def}]
-  val asigs = [@{thm asig_of_par}, @{thm actions_asig_comp}]
-in
-
-fun mkex_induct_tac ctxt sch exA exB =
-  let val ss = simpset_of ctxt in
-    EVERY1[Seq_induct_tac ctxt sch defs,
-           asm_full_simp_tac ss,
-           SELECT_GOAL (safe_tac (global_claset_of @{theory Fun})),
-           Seq_case_simp_tac ctxt exA,
-           Seq_case_simp_tac ctxt exB,
-           asm_full_simp_tac ss,
-           Seq_case_simp_tac ctxt exA,
-           asm_full_simp_tac ss,
-           Seq_case_simp_tac ctxt exB,
-           asm_full_simp_tac ss,
-           asm_full_simp_tac (ss addsimps asigs)
-          ]
-  end
-
-end
-*}
-
-
-(*---------------------------------------------------------------------------
-               Projection of mkex(sch,exA,exB) onto A stutters on A
-                             structural induction
-  --------------------------------------------------------------------------- *)
-
-lemma stutterA_mkex: "! exA exB s t.
-  Forall (%x. x:act (A||B)) sch &
-  Filter (%a. a:act A)$sch << filter_act$exA &
-  Filter (%a. a:act B)$sch << filter_act$exB
-  --> stutter (asig_of A) (s,ProjA2$(snd (mkex A B sch (s,exA) (t,exB))))"
-
-apply (tactic {* mkex_induct_tac @{context} "sch" "exA" "exB" *})
-done
-
-
-lemma stutter_mkex_on_A: "[|
-  Forall (%x. x:act (A||B)) sch ;
-  Filter (%a. a:act A)$sch << filter_act$(snd exA) ;
-  Filter (%a. a:act B)$sch << filter_act$(snd exB) |]
-  ==> stutter (asig_of A) (ProjA (mkex A B sch exA exB))"
-
-apply (cut_tac stutterA_mkex)
-apply (simp add: stutter_def ProjA_def mkex_def)
-apply (erule allE)+
-apply (drule mp)
-prefer 2 apply (assumption)
-apply simp
-done
-
-
-(*---------------------------------------------------------------------------
-               Projection of mkex(sch,exA,exB) onto B stutters on B
-                             structural induction
-  --------------------------------------------------------------------------- *)
-
-lemma stutterB_mkex: "! exA exB s t.
-  Forall (%x. x:act (A||B)) sch &
-  Filter (%a. a:act A)$sch << filter_act$exA &
-  Filter (%a. a:act B)$sch << filter_act$exB
-  --> stutter (asig_of B) (t,ProjB2$(snd (mkex A B sch (s,exA) (t,exB))))"
-apply (tactic {* mkex_induct_tac @{context} "sch" "exA" "exB" *})
-done
-
-
-lemma stutter_mkex_on_B: "[|
-  Forall (%x. x:act (A||B)) sch ;
-  Filter (%a. a:act A)$sch << filter_act$(snd exA) ;
-  Filter (%a. a:act B)$sch << filter_act$(snd exB) |]
-  ==> stutter (asig_of B) (ProjB (mkex A B sch exA exB))"
-apply (cut_tac stutterB_mkex)
-apply (simp add: stutter_def ProjB_def mkex_def)
-apply (erule allE)+
-apply (drule mp)
-prefer 2 apply (assumption)
-apply simp
-done
-
-
-(*---------------------------------------------------------------------------
-     Filter of mkex(sch,exA,exB) to A after projection onto A is exA
-        --  using zip$(proj1$exA)$(proj2$exA) instead of exA    --
-        --           because of admissibility problems          --
-                             structural induction
-  --------------------------------------------------------------------------- *)
-
-lemma filter_mkex_is_exA_tmp: "! exA exB s t.
-  Forall (%x. x:act (A||B)) sch &
-  Filter (%a. a:act A)$sch << filter_act$exA  &
-  Filter (%a. a:act B)$sch << filter_act$exB
-  --> Filter_ex2 (asig_of A)$(ProjA2$(snd (mkex A B sch (s,exA) (t,exB)))) =
-      Zip$(Filter (%a. a:act A)$sch)$(Map snd$exA)"
-apply (tactic {* mkex_induct_tac @{context} "sch" "exB" "exA" *})
-done
-
-(*---------------------------------------------------------------------------
-                      zip$(proj1$y)$(proj2$y) = y   (using the lift operations)
-                    lemma for admissibility problems
-  --------------------------------------------------------------------------- *)
-
-lemma Zip_Map_fst_snd: "Zip$(Map fst$y)$(Map snd$y) = y"
-apply (tactic {* Seq_induct_tac @{context} "y" [] 1 *})
-done
-
-
-(*---------------------------------------------------------------------------
-      filter A$sch = proj1$ex   -->  zip$(filter A$sch)$(proj2$ex) = ex
-         lemma for eliminating non admissible equations in assumptions
-  --------------------------------------------------------------------------- *)
-
-lemma trick_against_eq_in_ass: "!! sch ex.
-  Filter (%a. a:act AB)$sch = filter_act$ex
-  ==> ex = Zip$(Filter (%a. a:act AB)$sch)$(Map snd$ex)"
-apply (simp add: filter_act_def)
-apply (rule Zip_Map_fst_snd [symmetric])
-done
-
-(*---------------------------------------------------------------------------
-     Filter of mkex(sch,exA,exB) to A after projection onto A is exA
-                       using the above trick
-  --------------------------------------------------------------------------- *)
-
-
-lemma filter_mkex_is_exA: "!!sch exA exB.
-  [| Forall (%a. a:act (A||B)) sch ;
-  Filter (%a. a:act A)$sch = filter_act$(snd exA)  ;
-  Filter (%a. a:act B)$sch = filter_act$(snd exB) |]
-  ==> Filter_ex (asig_of A) (ProjA (mkex A B sch exA exB)) = exA"
-apply (simp add: ProjA_def Filter_ex_def)
-apply (tactic {* pair_tac @{context} "exA" 1 *})
-apply (tactic {* pair_tac @{context} "exB" 1 *})
-apply (rule conjI)
-apply (simp (no_asm) add: mkex_def)
-apply (simplesubst trick_against_eq_in_ass)
-back
-apply assumption
-apply (simp add: filter_mkex_is_exA_tmp)
-done
-
-
-(*---------------------------------------------------------------------------
-     Filter of mkex(sch,exA,exB) to B after projection onto B is exB
-        --  using zip$(proj1$exB)$(proj2$exB) instead of exB    --
-        --           because of admissibility problems          --
-                             structural induction
-  --------------------------------------------------------------------------- *)
-
-lemma filter_mkex_is_exB_tmp: "! exA exB s t.
-  Forall (%x. x:act (A||B)) sch &
-  Filter (%a. a:act A)$sch << filter_act$exA  &
-  Filter (%a. a:act B)$sch << filter_act$exB
-  --> Filter_ex2 (asig_of B)$(ProjB2$(snd (mkex A B sch (s,exA) (t,exB)))) =
-      Zip$(Filter (%a. a:act B)$sch)$(Map snd$exB)"
-
-(* notice necessary change of arguments exA and exB *)
-apply (tactic {* mkex_induct_tac @{context} "sch" "exA" "exB" *})
-done
-
-
-(*---------------------------------------------------------------------------
-     Filter of mkex(sch,exA,exB) to A after projection onto B is exB
-                       using the above trick
-  --------------------------------------------------------------------------- *)
-
-
-lemma filter_mkex_is_exB: "!!sch exA exB.
-  [| Forall (%a. a:act (A||B)) sch ;
-  Filter (%a. a:act A)$sch = filter_act$(snd exA)  ;
-  Filter (%a. a:act B)$sch = filter_act$(snd exB) |]
-  ==> Filter_ex (asig_of B) (ProjB (mkex A B sch exA exB)) = exB"
-apply (simp add: ProjB_def Filter_ex_def)
-apply (tactic {* pair_tac @{context} "exA" 1 *})
-apply (tactic {* pair_tac @{context} "exB" 1 *})
-apply (rule conjI)
-apply (simp (no_asm) add: mkex_def)
-apply (simplesubst trick_against_eq_in_ass)
-back
-apply assumption
-apply (simp add: filter_mkex_is_exB_tmp)
-done
-
-(* --------------------------------------------------------------------- *)
-(*                    mkex has only  A- or B-actions                    *)
-(* --------------------------------------------------------------------- *)
-
-
-lemma mkex_actions_in_AorB: "!s t exA exB.
-  Forall (%x. x : act (A || B)) sch &
-  Filter (%a. a:act A)$sch << filter_act$exA  &
-  Filter (%a. a:act B)$sch << filter_act$exB
-   --> Forall (%x. fst x : act (A ||B))
-         (snd (mkex A B sch (s,exA) (t,exB)))"
-apply (tactic {* mkex_induct_tac @{context} "sch" "exA" "exB" *})
-done
-
-
-(* ------------------------------------------------------------------ *)
-(*           COMPOSITIONALITY   on    SCHEDULE      Level             *)
-(*                          Main Theorem                              *)
-(* ------------------------------------------------------------------ *)
-
-lemma compositionality_sch:
-"(sch : schedules (A||B)) =
-  (Filter (%a. a:act A)$sch : schedules A &
-   Filter (%a. a:act B)$sch : schedules B &
-   Forall (%x. x:act (A||B)) sch)"
-apply (simp (no_asm) add: schedules_def has_schedule_def)
-apply auto
-(* ==> *)
-apply (rule_tac x = "Filter_ex (asig_of A) (ProjA ex) " in bexI)
-prefer 2
-apply (simp add: compositionality_ex)
-apply (simp (no_asm) add: Filter_ex_def ProjA_def lemma_2_1a lemma_2_1b)
-apply (rule_tac x = "Filter_ex (asig_of B) (ProjB ex) " in bexI)
-prefer 2
-apply (simp add: compositionality_ex)
-apply (simp (no_asm) add: Filter_ex_def ProjB_def lemma_2_1a lemma_2_1b)
-apply (simp add: executions_def)
-apply (tactic {* pair_tac @{context} "ex" 1 *})
-apply (erule conjE)
-apply (simp add: sch_actions_in_AorB)
-
-(* <== *)
-
-(* mkex is exactly the construction of exA||B out of exA, exB, and the oracle sch,
-   we need here *)
-apply (rename_tac exA exB)
-apply (rule_tac x = "mkex A B sch exA exB" in bexI)
-(* mkex actions are just the oracle *)
-apply (tactic {* pair_tac @{context} "exA" 1 *})
-apply (tactic {* pair_tac @{context} "exB" 1 *})
-apply (simp add: Mapfst_mkex_is_sch)
-
-(* mkex is an execution -- use compositionality on ex-level *)
-apply (simp add: compositionality_ex)
-apply (simp add: stutter_mkex_on_A stutter_mkex_on_B filter_mkex_is_exB filter_mkex_is_exA)
-apply (tactic {* pair_tac @{context} "exA" 1 *})
-apply (tactic {* pair_tac @{context} "exB" 1 *})
-apply (simp add: mkex_actions_in_AorB)
-done
-
-
-subsection {* COMPOSITIONALITY on SCHEDULE Level -- for Modules *}
-
-lemma compositionality_sch_modules:
-  "Scheds (A||B) = par_scheds (Scheds A) (Scheds B)"
-
-apply (unfold Scheds_def par_scheds_def)
-apply (simp add: asig_of_par)
-apply (rule set_eqI)
-apply (simp add: compositionality_sch actions_of_par)
-done
-
-
-declare compoex_simps [simp del]
-declare composch_simps [simp del]
-
-end

--- a/src/HOLCF/IOA/meta_theory/CompoTraces.thy	Sat Nov 27 14:34:54 2010 -0800
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,973 +0,0 @@
-(*  Title:      HOLCF/IOA/meta_theory/CompoTraces.thy
-    Author:     Olaf Müller
-*) 
-
-header {* Compositionality on Trace level *}
-
-theory CompoTraces
-imports CompoScheds ShortExecutions
-begin
- 
-
-consts  
-
- mksch      ::"('a,'s)ioa => ('a,'t)ioa => 'a Seq -> 'a Seq -> 'a Seq -> 'a Seq" 
- par_traces ::"['a trace_module,'a trace_module] => 'a trace_module"
-
-defs
-
-mksch_def:
-  "mksch A B == (fix$(LAM h tr schA schB. case tr of 
-       nil => nil
-    | x##xs => 
-      (case x of 
-        UU => UU
-      | Def y => 
-         (if y:act A then 
-             (if y:act B then 
-                   ((Takewhile (%a. a:int A)$schA)
-                      @@ (Takewhile (%a. a:int B)$schB)
-                           @@ (y>>(h$xs
-                                    $(TL$(Dropwhile (%a. a:int A)$schA))
-                                    $(TL$(Dropwhile (%a. a:int B)$schB))
-                    )))
-              else
-                 ((Takewhile (%a. a:int A)$schA)
-                  @@ (y>>(h$xs
-                           $(TL$(Dropwhile (%a. a:int A)$schA))
-                           $schB)))
-              )
-          else 
-             (if y:act B then 
-                 ((Takewhile (%a. a:int B)$schB)
-                     @@ (y>>(h$xs
-                              $schA
-                              $(TL$(Dropwhile (%a. a:int B)$schB))
-                              )))
-             else
-               UU
-             )
-         )
-       )))"
-
-
-par_traces_def:
-  "par_traces TracesA TracesB == 
-       let trA = fst TracesA; sigA = snd TracesA; 
-           trB = fst TracesB; sigB = snd TracesB       
-       in
-       (    {tr. Filter (%a. a:actions sigA)$tr : trA}
-        Int {tr. Filter (%a. a:actions sigB)$tr : trB}
-        Int {tr. Forall (%x. x:(externals sigA Un externals sigB)) tr},
-        asig_comp sigA sigB)"
-
-axioms
-
-finiteR_mksch:
-  "Finite (mksch A B$tr$x$y) --> Finite tr"
-
-
-declaration {* fn _ => Simplifier.map_ss (fn ss => ss setmksym (K (K NONE))) *}
-
-
-subsection "mksch rewrite rules"
-
-lemma mksch_unfold:
-"mksch A B = (LAM tr schA schB. case tr of 
-       nil => nil
-    | x##xs => 
-      (case x of  
-        UU => UU  
-      | Def y => 
-         (if y:act A then 
-             (if y:act B then 
-                   ((Takewhile (%a. a:int A)$schA) 
-                         @@(Takewhile (%a. a:int B)$schB) 
-                              @@(y>>(mksch A B$xs   
-                                       $(TL$(Dropwhile (%a. a:int A)$schA))  
-                                       $(TL$(Dropwhile (%a. a:int B)$schB))  
-                    )))   
-              else  
-                 ((Takewhile (%a. a:int A)$schA)  
-                      @@ (y>>(mksch A B$xs  
-                              $(TL$(Dropwhile (%a. a:int A)$schA))  
-                              $schB)))  
-              )   
-          else    
-             (if y:act B then  
-                 ((Takewhile (%a. a:int B)$schB)  
-                       @@ (y>>(mksch A B$xs   
-                              $schA   
-                              $(TL$(Dropwhile (%a. a:int B)$schB))  
-                              )))  
-             else  
-               UU  
-             )  
-         )  
-       ))"
-apply (rule trans)
-apply (rule fix_eq2)
-apply (rule mksch_def)
-apply (rule beta_cfun)
-apply simp
-done
-
-lemma mksch_UU: "mksch A B$UU$schA$schB = UU"
-apply (subst mksch_unfold)
-apply simp
-done
-
-lemma mksch_nil: "mksch A B$nil$schA$schB = nil"
-apply (subst mksch_unfold)
-apply simp
-done
-
-lemma mksch_cons1: "[|x:act A;x~:act B|]   
-    ==> mksch A B$(x>>tr)$schA$schB =  
-          (Takewhile (%a. a:int A)$schA)  
-          @@ (x>>(mksch A B$tr$(TL$(Dropwhile (%a. a:int A)$schA))  
-                              $schB))"
-apply (rule trans)
-apply (subst mksch_unfold)
-apply (simp add: Consq_def If_and_if)
-apply (simp add: Consq_def)
-done
-
-lemma mksch_cons2: "[|x~:act A;x:act B|]  
-    ==> mksch A B$(x>>tr)$schA$schB =  
-         (Takewhile (%a. a:int B)$schB)   
-          @@ (x>>(mksch A B$tr$schA$(TL$(Dropwhile (%a. a:int B)$schB))   
-                             ))"
-apply (rule trans)
-apply (subst mksch_unfold)
-apply (simp add: Consq_def If_and_if)
-apply (simp add: Consq_def)
-done
-
-lemma mksch_cons3: "[|x:act A;x:act B|]  
-    ==> mksch A B$(x>>tr)$schA$schB =  
-             (Takewhile (%a. a:int A)$schA)  
-          @@ ((Takewhile (%a. a:int B)$schB)   
-          @@ (x>>(mksch A B$tr$(TL$(Dropwhile (%a. a:int A)$schA))  
-                             $(TL$(Dropwhile (%a. a:int B)$schB))))   
-              )"
-apply (rule trans)
-apply (subst mksch_unfold)
-apply (simp add: Consq_def If_and_if)
-apply (simp add: Consq_def)
-done
-
-lemmas compotr_simps = mksch_UU mksch_nil mksch_cons1 mksch_cons2 mksch_cons3
-
-declare compotr_simps [simp]
-
-
-subsection {* COMPOSITIONALITY on TRACE Level *}
-
-subsubsection "Lemmata for ==>"
-
-(* Consequence out of ext1_ext2_is_not_act1(2), which in turn are consequences out of
-   the compatibility of IOA, in particular out of the condition that internals are
-   really hidden. *)
-
-lemma compatibility_consequence1: "(eB & ~eA --> ~A) -->        
-          (A & (eA | eB)) = (eA & A)"
-apply fast
-done
-
-
-(* very similar to above, only the commutativity of | is used to make a slight change *)
-
-lemma compatibility_consequence2: "(eB & ~eA --> ~A) -->        
-          (A & (eB | eA)) = (eA & A)"
-apply fast
-done
-
-
-subsubsection "Lemmata for <=="
-
-(* Lemma for substitution of looping assumption in another specific assumption *)
-lemma subst_lemma1: "[| f << (g x) ; x=(h x) |] ==> f << g (h x)"
-by (erule subst)
-
-(* Lemma for substitution of looping assumption in another specific assumption *)
-lemma subst_lemma2: "[| (f x) = y >> g; x=(h x) |] ==> (f (h x)) = y >> g"
-by (erule subst)
-
-lemma ForallAorB_mksch [rule_format]:
-  "!!A B. compatible A B ==>  
-    ! schA schB. Forall (%x. x:act (A||B)) tr  
-    --> Forall (%x. x:act (A||B)) (mksch A B$tr$schA$schB)"
-apply (tactic {* Seq_induct_tac @{context} "tr"
-  [@{thm Forall_def}, @{thm sforall_def}, @{thm mksch_def}] 1 *})
-apply auto
-apply (simp add: actions_of_par)
-apply (case_tac "a:act A")
-apply (case_tac "a:act B")
-(* a:A, a:B *)
-apply simp
-apply (rule Forall_Conc_impl [THEN mp])
-apply (simp add: intA_is_not_actB int_is_act)
-apply (rule Forall_Conc_impl [THEN mp])
-apply (simp add: intA_is_not_actB int_is_act)
-(* a:A,a~:B *)
-apply simp
-apply (rule Forall_Conc_impl [THEN mp])
-apply (simp add: intA_is_not_actB int_is_act)
-apply (case_tac "a:act B")
-(* a~:A, a:B *)
-apply simp
-apply (rule Forall_Conc_impl [THEN mp])
-apply (simp add: intA_is_not_actB int_is_act)
-(* a~:A,a~:B *)
-apply auto
-done
-
-lemma ForallBnAmksch [rule_format (no_asm)]: "!!A B. compatible B A  ==>  
-    ! schA schB.  (Forall (%x. x:act B & x~:act A) tr  
-    --> Forall (%x. x:act B & x~:act A) (mksch A B$tr$schA$schB))"
-apply (tactic {* Seq_induct_tac @{context} "tr"
-  [@{thm Forall_def}, @{thm sforall_def}, @{thm mksch_def}] 1 *})
-apply auto
-apply (rule Forall_Conc_impl [THEN mp])
-apply (simp add: intA_is_not_actB int_is_act)
-done
-
-lemma ForallAnBmksch [rule_format (no_asm)]: "!!A B. compatible A B ==>  
-    ! schA schB.  (Forall (%x. x:act A & x~:act B) tr  
-    --> Forall (%x. x:act A & x~:act B) (mksch A B$tr$schA$schB))"
-apply (tactic {* Seq_induct_tac @{context} "tr"
-  [@{thm Forall_def}, @{thm sforall_def}, @{thm mksch_def}] 1 *})
-apply auto
-apply (rule Forall_Conc_impl [THEN mp])
-apply (simp add: intA_is_not_actB int_is_act)
-done
-
-(* safe-tac makes too many case distinctions with this lemma in the next proof *)
-declare FiniteConc [simp del]
-
-lemma FiniteL_mksch [rule_format (no_asm)]: "[| Finite tr; is_asig(asig_of A); is_asig(asig_of B) |] ==>  
-    ! x y. Forall (%x. x:act A) x & Forall (%x. x:act B) y &  
-           Filter (%a. a:ext A)$x = Filter (%a. a:act A)$tr &  
-           Filter (%a. a:ext B)$y = Filter (%a. a:act B)$tr & 
-           Forall (%x. x:ext (A||B)) tr  
-           --> Finite (mksch A B$tr$x$y)"
-
-apply (erule Seq_Finite_ind)
-apply simp
-(* main case *)
-apply simp
-apply auto
-
-(* a: act A; a: act B *)
-apply (frule sym [THEN eq_imp_below, THEN divide_Seq])
-apply (frule sym [THEN eq_imp_below, THEN divide_Seq])
-back
-apply (erule conjE)+
-(* Finite (tw iA x) and Finite (tw iB y) *)
-apply (simp add: not_ext_is_int_or_not_act FiniteConc)
-(* now for conclusion IH applicable, but assumptions have to be transformed *)
-apply (drule_tac x = "x" and g = "Filter (%a. a:act A) $s" in subst_lemma2)
-apply assumption
-apply (drule_tac x = "y" and g = "Filter (%a. a:act B) $s" in subst_lemma2)
-apply assumption
-(* IH *)
-apply (simp add: not_ext_is_int_or_not_act ForallTL ForallDropwhile)
-
-(* a: act B; a~: act A *)
-apply (frule sym [THEN eq_imp_below, THEN divide_Seq])
-
-apply (erule conjE)+
-(* Finite (tw iB y) *)
-apply (simp add: not_ext_is_int_or_not_act FiniteConc)
-(* now for conclusion IH applicable, but assumptions have to be transformed *)
-apply (drule_tac x = "y" and g = "Filter (%a. a:act B) $s" in subst_lemma2)
-apply assumption
-(* IH *)
-apply (simp add: not_ext_is_int_or_not_act ForallTL ForallDropwhile)
-
-(* a~: act B; a: act A *)
-apply (frule sym [THEN eq_imp_below, THEN divide_Seq])
-
-apply (erule conjE)+
-(* Finite (tw iA x) *)
-apply (simp add: not_ext_is_int_or_not_act FiniteConc)
-(* now for conclusion IH applicable, but assumptions have to be transformed *)
-apply (drule_tac x = "x" and g = "Filter (%a. a:act A) $s" in subst_lemma2)
-apply assumption
-(* IH *)
-apply (simp add: not_ext_is_int_or_not_act ForallTL ForallDropwhile)
-
-(* a~: act B; a~: act A *)
-apply (fastsimp intro!: ext_is_act simp: externals_of_par)
-done
-
-declare FiniteConc [simp]
-
-declare FilterConc [simp del]
-
-lemma reduceA_mksch1 [rule_format (no_asm)]: " [| Finite bs; is_asig(asig_of A); is_asig(asig_of B);compatible A B|] ==>   
- ! y. Forall (%x. x:act B) y & Forall (%x. x:act B & x~:act A) bs & 
-     Filter (%a. a:ext B)$y = Filter (%a. a:act B)$(bs @@ z)  
-     --> (? y1 y2.  (mksch A B$(bs @@ z)$x$y) = (y1 @@ (mksch A B$z$x$y2)) &  
-                    Forall (%x. x:act B & x~:act A) y1 &  
-                    Finite y1 & y = (y1 @@ y2) &  
-                    Filter (%a. a:ext B)$y1 = bs)"
-apply (frule_tac A1 = "A" in compat_commute [THEN iffD1])
-apply (erule Seq_Finite_ind)
-apply (rule allI)+
-apply (rule impI)
-apply (rule_tac x = "nil" in exI)
-apply (rule_tac x = "y" in exI)
-apply simp
-(* main case *)
-apply (rule allI)+
-apply (rule impI)
-apply simp
-apply (erule conjE)+
-apply simp
-(* divide_Seq on s *)
-apply (frule sym [THEN eq_imp_below, THEN divide_Seq])
-apply (erule conjE)+
-(* transform assumption f eB y = f B (s@z) *)
-apply (drule_tac x = "y" and g = "Filter (%a. a:act B) $ (s@@z) " in subst_lemma2)
-apply assumption
-apply (simp add: not_ext_is_int_or_not_act FilterConc)
-(* apply IH *)
-apply (erule_tac x = "TL$ (Dropwhile (%a. a:int B) $y) " in allE)
-apply (simp add: ForallTL ForallDropwhile FilterConc)
-apply (erule exE)+
-apply (erule conjE)+
-apply (simp add: FilterConc)
-(* for replacing IH in conclusion *)
-apply (rotate_tac -2)
-(* instantiate y1a and y2a *)
-apply (rule_tac x = "Takewhile (%a. a:int B) $y @@ a>>y1" in exI)
-apply (rule_tac x = "y2" in exI)
-(* elminate all obligations up to two depending on Conc_assoc *)
-apply (simp add: intA_is_not_actB int_is_act int_is_not_ext FilterConc)
-apply (simp (no_asm) add: Conc_assoc FilterConc)
-done
-
-lemmas reduceA_mksch = conjI [THEN [6] conjI [THEN [5] reduceA_mksch1]]
-
-lemma reduceB_mksch1 [rule_format]:
-" [| Finite a_s; is_asig(asig_of A); is_asig(asig_of B);compatible A B|] ==>   
- ! x. Forall (%x. x:act A) x & Forall (%x. x:act A & x~:act B) a_s & 
-     Filter (%a. a:ext A)$x = Filter (%a. a:act A)$(a_s @@ z)  
-     --> (? x1 x2.  (mksch A B$(a_s @@ z)$x$y) = (x1 @@ (mksch A B$z$x2$y)) &  
-                    Forall (%x. x:act A & x~:act B) x1 &  
-                    Finite x1 & x = (x1 @@ x2) &  
-                    Filter (%a. a:ext A)$x1 = a_s)"
-apply (frule_tac A1 = "A" in compat_commute [THEN iffD1])
-apply (erule Seq_Finite_ind)
-apply (rule allI)+
-apply (rule impI)
-apply (rule_tac x = "nil" in exI)
-apply (rule_tac x = "x" in exI)
-apply simp
-(* main case *)
-apply (rule allI)+
-apply (rule impI)
-apply simp
-apply (erule conjE)+
-apply simp
-(* divide_Seq on s *)
-apply (frule sym [THEN eq_imp_below, THEN divide_Seq])
-apply (erule conjE)+
-(* transform assumption f eA x = f A (s@z) *)
-apply (drule_tac x = "x" and g = "Filter (%a. a:act A) $ (s@@z) " in subst_lemma2)
-apply assumption
-apply (simp add: not_ext_is_int_or_not_act FilterConc)
-(* apply IH *)
-apply (erule_tac x = "TL$ (Dropwhile (%a. a:int A) $x) " in allE)
-apply (simp add: ForallTL ForallDropwhile FilterConc)
-apply (erule exE)+
-apply (erule conjE)+
-apply (simp add: FilterConc)
-(* for replacing IH in conclusion *)
-apply (rotate_tac -2)
-(* instantiate y1a and y2a *)
-apply (rule_tac x = "Takewhile (%a. a:int A) $x @@ a>>x1" in exI)
-apply (rule_tac x = "x2" in exI)
-(* elminate all obligations up to two depending on Conc_assoc *)
-apply (simp add: intA_is_not_actB int_is_act int_is_not_ext FilterConc)
-apply (simp (no_asm) add: Conc_assoc FilterConc)
-done
-
-lemmas reduceB_mksch = conjI [THEN [6] conjI [THEN [5] reduceB_mksch1]]
-
-declare FilterConc [simp]
-
-
-subsection "Filtering external actions out of mksch(tr,schA,schB) yields the oracle tr"
-
-lemma FilterA_mksch_is_tr: 
-"!! A B. [| compatible A B; compatible B A; 
-            is_asig(asig_of A); is_asig(asig_of B) |] ==>  
-  ! schA schB. Forall (%x. x:act A) schA & Forall (%x. x:act B) schB &  
-  Forall (%x. x:ext (A||B)) tr &  
-  Filter (%a. a:act A)$tr << Filter (%a. a:ext A)$schA & 
-  Filter (%a. a:act B)$tr << Filter (%a. a:ext B)$schB   
-  --> Filter (%a. a:ext (A||B))$(mksch A B$tr$schA$schB) = tr"
-
-apply (tactic {* Seq_induct_tac @{context} "tr"
-  [@{thm Forall_def}, @{thm sforall_def}, @{thm mksch_def}] 1 *})
-(* main case *)
-(* splitting into 4 cases according to a:A, a:B *)
-apply auto
-
-(* Case a:A, a:B *)
-apply (frule divide_Seq)
-apply (frule divide_Seq)
-back
-apply (erule conjE)+
-(* filtering internals of A in schA and of B in schB is nil *)
-apply (simp add: not_ext_is_int_or_not_act externals_of_par intA_is_not_extB int_is_not_ext)
-(* conclusion of IH ok, but assumptions of IH have to be transformed *)
-apply (drule_tac x = "schA" in subst_lemma1)
-apply assumption
-apply (drule_tac x = "schB" in subst_lemma1)
-apply assumption
-(* IH *)
-apply (simp add: not_ext_is_int_or_not_act ForallTL ForallDropwhile)
-
-(* Case a:A, a~:B *)
-apply (frule divide_Seq)
-apply (erule conjE)+
-(* filtering internals of A is nil *)
-apply (simp add: not_ext_is_int_or_not_act externals_of_par intA_is_not_extB int_is_not_ext)
-apply (drule_tac x = "schA" in subst_lemma1)
-apply assumption
-apply (simp add: not_ext_is_int_or_not_act ForallTL ForallDropwhile)
-
-(* Case a:B, a~:A *)
-apply (frule divide_Seq)
-apply (erule conjE)+
-(* filtering internals of A is nil *)
-apply (simp add: not_ext_is_int_or_not_act externals_of_par intA_is_not_extB int_is_not_ext)
-apply (drule_tac x = "schB" in subst_lemma1)
-back
-apply assumption
-apply (simp add: not_ext_is_int_or_not_act ForallTL ForallDropwhile)
-
-(* Case a~:A, a~:B *)
-apply (fastsimp intro!: ext_is_act simp: externals_of_par)
-done
-
-
-subsection" Filter of mksch(tr,schA,schB) to A is schA -- take lemma proof"
-
-lemma FilterAmksch_is_schA: "!! A B. [| compatible A B; compatible B A;  
-  is_asig(asig_of A); is_asig(asig_of B) |] ==>  
-  Forall (%x. x:ext (A||B)) tr &  
-  Forall (%x. x:act A) schA & Forall (%x. x:act B) schB &  
-  Filter (%a. a:ext A)$schA = Filter (%a. a:act A)$tr & 
-  Filter (%a. a:ext B)$schB = Filter (%a. a:act B)$tr & 
-  LastActExtsch A schA & LastActExtsch B schB   
-  --> Filter (%a. a:act A)$(mksch A B$tr$schA$schB) = schA"
-apply (intro strip)
-apply (rule seq.take_lemma)
-apply (rule mp)
-prefer 2 apply assumption
-back back back back
-apply (rule_tac x = "schA" in spec)
-apply (rule_tac x = "schB" in spec)
-apply (rule_tac x = "tr" in spec)
-apply (tactic "thin_tac' 5 1")
-apply (rule nat_less_induct)
-apply (rule allI)+
-apply (rename_tac tr schB schA)
-apply (intro strip)
-apply (erule conjE)+
-
-apply (case_tac "Forall (%x. x:act B & x~:act A) tr")
-
-apply (rule seq_take_lemma [THEN iffD2, THEN spec])
-apply (tactic "thin_tac' 5 1")
-
-
-apply (case_tac "Finite tr")
-
-(* both sides of this equation are nil *)
-apply (subgoal_tac "schA=nil")
-apply (simp (no_asm_simp))
-(* first side: mksch = nil *)
-apply (auto intro!: ForallQFilterPnil ForallBnAmksch FiniteL_mksch)[1]
-(* second side: schA = nil *)
-apply (erule_tac A = "A" in LastActExtimplnil)
-apply (simp (no_asm_simp))
-apply (erule_tac Q = "%x. x:act B & x~:act A" in ForallQFilterPnil)
-apply assumption
-apply fast
-
-(* case ~ Finite s *)
-
-(* both sides of this equation are UU *)
-apply (subgoal_tac "schA=UU")
-apply (simp (no_asm_simp))
-(* first side: mksch = UU *)
-apply (auto intro!: ForallQFilterPUU finiteR_mksch [THEN mp, COMP rev_contrapos] ForallBnAmksch)[1]
-(* schA = UU *)
-apply (erule_tac A = "A" in LastActExtimplUU)
-apply (simp (no_asm_simp))
-apply (erule_tac Q = "%x. x:act B & x~:act A" in ForallQFilterPUU)
-apply assumption
-apply fast
-
-(* case" ~ Forall (%x.x:act B & x~:act A) s" *)
-
-apply (drule divide_Seq3)
-
-apply (erule exE)+
-apply (erule conjE)+
-apply hypsubst
-
-(* bring in lemma reduceA_mksch *)
-apply (frule_tac x = "schA" and y = "schB" and A = "A" and B = "B" in reduceA_mksch)
-apply assumption+
-apply (erule exE)+
-apply (erule conjE)+
-
-(* use reduceA_mksch to rewrite conclusion *)
-apply hypsubst
-apply simp
-
-(* eliminate the B-only prefix *)
-
-apply (subgoal_tac " (Filter (%a. a :act A) $y1) = nil")
-apply (erule_tac [2] ForallQFilterPnil)
-prefer 2 apply assumption
-prefer 2 apply fast
-
-(* Now real recursive step follows (in y) *)
-
-apply simp
-apply (case_tac "x:act A")
-apply (case_tac "x~:act B")
-apply (rotate_tac -2)
-apply simp
-
-apply (subgoal_tac "Filter (%a. a:act A & a:ext B) $y1=nil")
-apply (rotate_tac -1)
-apply simp
-(* eliminate introduced subgoal 2 *)
-apply (erule_tac [2] ForallQFilterPnil)
-prefer 2 apply assumption
-prefer 2 apply fast
-
-(* bring in divide Seq for s *)
-apply (frule sym [THEN eq_imp_below, THEN divide_Seq])
-apply (erule conjE)+
-
-(* subst divide_Seq in conclusion, but only at the righest occurence *)
-apply (rule_tac t = "schA" in ssubst)
-back
-back
-back
-apply assumption
-
-(* reduce trace_takes from n to strictly smaller k *)
-apply (rule take_reduction)
-
-(* f A (tw iA) = tw ~eA *)
-apply (simp add: int_is_act not_ext_is_int_or_not_act)
-apply (rule refl)
-apply (simp add: int_is_act not_ext_is_int_or_not_act)
-apply (rotate_tac -11)
-
-(* now conclusion fulfills induction hypothesis, but assumptions are not ready *)
-
-(* assumption Forall tr *)
-(* assumption schB *)
-apply (simp add: ext_and_act)
-(* assumption schA *)
-apply (drule_tac x = "schA" and g = "Filter (%a. a:act A) $rs" in subst_lemma2)
-apply assumption
-apply (simp add: int_is_not_ext)
-(* assumptions concerning LastActExtsch, cannot be rewritten, as LastActExtsmalli are looping  *)
-apply (drule_tac sch = "schA" and P = "%a. a:int A" in LastActExtsmall1)
-apply (frule_tac ?sch1.0 = "y1" in LastActExtsmall2)
-apply assumption
-
-(* assumption Forall schA *)
-apply (drule_tac s = "schA" and P = "Forall (%x. x:act A) " in subst)
-apply assumption
-apply (simp add: int_is_act)
-
-(* case x:actions(asig_of A) & x: actions(asig_of B) *)
-
-
-apply (rotate_tac -2)
-apply simp
-
-apply (subgoal_tac "Filter (%a. a:act A & a:ext B) $y1=nil")
-apply (rotate_tac -1)
-apply simp
-(* eliminate introduced subgoal 2 *)
-apply (erule_tac [2] ForallQFilterPnil)
-prefer 2 apply (assumption)
-prefer 2 apply (fast)
-
-(* bring in divide Seq for s *)
-apply (frule sym [THEN eq_imp_below, THEN divide_Seq])
-apply (erule conjE)+
-
-(* subst divide_Seq in conclusion, but only at the righest occurence *)
-apply (rule_tac t = "schA" in ssubst)
-back
-back
-back
-apply assumption
-
-(* f A (tw iA) = tw ~eA *)
-apply (simp add: int_is_act not_ext_is_int_or_not_act)
-
-(* rewrite assumption forall and schB *)
-apply (rotate_tac 13)
-apply (simp add: ext_and_act)
-
-(* divide_Seq for schB2 *)
-apply (frule_tac y = "y2" in sym [THEN eq_imp_below, THEN divide_Seq])
-apply (erule conjE)+
-(* assumption schA *)
-apply (drule_tac x = "schA" and g = "Filter (%a. a:act A) $rs" in subst_lemma2)
-apply assumption
-apply (simp add: int_is_not_ext)
-
-(* f A (tw iB schB2) = nil *)
-apply (simp add: int_is_not_ext not_ext_is_int_or_not_act intA_is_not_actB)
-
-
-(* reduce trace_takes from n to strictly smaller k *)
-apply (rule take_reduction)
-apply (rule refl)
-apply (rule refl)
-
-(* now conclusion fulfills induction hypothesis, but assumptions are not all ready *)
-
-(* assumption schB *)
-apply (drule_tac x = "y2" and g = "Filter (%a. a:act B) $rs" in subst_lemma2)
-apply assumption
-apply (simp add: intA_is_not_actB int_is_not_ext)
-
-(* conclusions concerning LastActExtsch, cannot be rewritten, as LastActExtsmalli are looping  *)
-apply (drule_tac sch = "schA" and P = "%a. a:int A" in LastActExtsmall1)
-apply (frule_tac ?sch1.0 = "y1" in LastActExtsmall2)
-apply assumption
-apply (drule_tac sch = "y2" and P = "%a. a:int B" in LastActExtsmall1)
-
-(* assumption Forall schA, and Forall schA are performed by ForallTL,ForallDropwhile *)
-apply (simp add: ForallTL ForallDropwhile)
-
-(* case x~:A & x:B  *)
-(* cannot occur, as just this case has been scheduled out before as the B-only prefix *)
-apply (case_tac "x:act B")
-apply fast
-
-(* case x~:A & x~:B  *)
-(* cannot occur because of assumption: Forall (a:ext A | a:ext B) *)
-apply (rotate_tac -9)
-(* reduce forall assumption from tr to (x>>rs) *)
-apply (simp add: externals_of_par)
-apply (fast intro!: ext_is_act)
-
-done
-
-
-
-subsection" Filter of mksch(tr,schA,schB) to B is schB -- take lemma proof"
-
-lemma FilterBmksch_is_schB: "!! A B. [| compatible A B; compatible B A;  
-  is_asig(asig_of A); is_asig(asig_of B) |] ==>  
-  Forall (%x. x:ext (A||B)) tr &  
-  Forall (%x. x:act A) schA & Forall (%x. x:act B) schB &  
-  Filter (%a. a:ext A)$schA = Filter (%a. a:act A)$tr & 
-  Filter (%a. a:ext B)$schB = Filter (%a. a:act B)$tr & 
-  LastActExtsch A schA & LastActExtsch B schB   
-  --> Filter (%a. a:act B)$(mksch A B$tr$schA$schB) = schB"
-apply (intro strip)
-apply (rule seq.take_lemma)
-apply (rule mp)
-prefer 2 apply assumption
-back back back back
-apply (rule_tac x = "schA" in spec)
-apply (rule_tac x = "schB" in spec)
-apply (rule_tac x = "tr" in spec)
-apply (tactic "thin_tac' 5 1")
-apply (rule nat_less_induct)
-apply (rule allI)+
-apply (rename_tac tr schB schA)
-apply (intro strip)
-apply (erule conjE)+
-
-apply (case_tac "Forall (%x. x:act A & x~:act B) tr")
-
-apply (rule seq_take_lemma [THEN iffD2, THEN spec])
-apply (tactic "thin_tac' 5 1")
-
-apply (case_tac "Finite tr")
-
-(* both sides of this equation are nil *)
-apply (subgoal_tac "schB=nil")
-apply (simp (no_asm_simp))
-(* first side: mksch = nil *)
-apply (auto intro!: ForallQFilterPnil ForallAnBmksch FiniteL_mksch)[1]
-(* second side: schA = nil *)
-apply (erule_tac A = "B" in LastActExtimplnil)
-apply (simp (no_asm_simp))
-apply (erule_tac Q = "%x. x:act A & x~:act B" in ForallQFilterPnil)
-apply assumption
-apply fast
-
-(* case ~ Finite tr *)
-
-(* both sides of this equation are UU *)
-apply (subgoal_tac "schB=UU")
-apply (simp (no_asm_simp))
-(* first side: mksch = UU *)
-apply (force intro!: ForallQFilterPUU finiteR_mksch [THEN mp, COMP rev_contrapos] ForallAnBmksch)
-(* schA = UU *)
-apply (erule_tac A = "B" in LastActExtimplUU)
-apply (simp (no_asm_simp))
-apply (erule_tac Q = "%x. x:act A & x~:act B" in ForallQFilterPUU)
-apply assumption
-apply fast
-
-(* case" ~ Forall (%x.x:act B & x~:act A) s" *)
-
-apply (drule divide_Seq3)
-
-apply (erule exE)+
-apply (erule conjE)+
-apply hypsubst
-
-(* bring in lemma reduceB_mksch *)
-apply (frule_tac y = "schB" and x = "schA" and A = "A" and B = "B" in reduceB_mksch)
-apply assumption+
-apply (erule exE)+
-apply (erule conjE)+
-
-(* use reduceB_mksch to rewrite conclusion *)
-apply hypsubst
-apply simp
-
-(* eliminate the A-only prefix *)
-
-apply (subgoal_tac "(Filter (%a. a :act B) $x1) = nil")
-apply (erule_tac [2] ForallQFilterPnil)
-prefer 2 apply (assumption)
-prefer 2 apply (fast)
-
-(* Now real recursive step follows (in x) *)
-
-apply simp
-apply (case_tac "x:act B")
-apply (case_tac "x~:act A")
-apply (rotate_tac -2)
-apply simp
-
-apply (subgoal_tac "Filter (%a. a:act B & a:ext A) $x1=nil")
-apply (rotate_tac -1)
-apply simp
-(* eliminate introduced subgoal 2 *)
-apply (erule_tac [2] ForallQFilterPnil)
-prefer 2 apply (assumption)
-prefer 2 apply (fast)
-
-(* bring in divide Seq for s *)
-apply (frule sym [THEN eq_imp_below, THEN divide_Seq])
-apply (erule conjE)+
-
-(* subst divide_Seq in conclusion, but only at the righest occurence *)
-apply (rule_tac t = "schB" in ssubst)
-back
-back
-back
-apply assumption
-
-(* reduce trace_takes from n to strictly smaller k *)
-apply (rule take_reduction)
-
-(* f B (tw iB) = tw ~eB *)
-apply (simp add: int_is_act not_ext_is_int_or_not_act)
-apply (rule refl)
-apply (simp add: int_is_act not_ext_is_int_or_not_act)
-apply (rotate_tac -11)
-
-(* now conclusion fulfills induction hypothesis, but assumptions are not ready *)
-
-(* assumption schA *)
-apply (simp add: ext_and_act)
-(* assumption schB *)
-apply (drule_tac x = "schB" and g = "Filter (%a. a:act B) $rs" in subst_lemma2)
-apply assumption
-apply (simp add: int_is_not_ext)
-(* assumptions concerning LastActExtsch, cannot be rewritten, as LastActExtsmalli are looping  *)
-apply (drule_tac sch = "schB" and P = "%a. a:int B" in LastActExtsmall1)
-apply (frule_tac ?sch1.0 = "x1" in LastActExtsmall2)
-apply assumption
-
-(* assumption Forall schB *)
-apply (drule_tac s = "schB" and P = "Forall (%x. x:act B) " in subst)
-apply assumption
-apply (simp add: int_is_act)
-
-(* case x:actions(asig_of A) & x: actions(asig_of B) *)
-
-apply (rotate_tac -2)
-apply simp
-
-apply (subgoal_tac "Filter (%a. a:act B & a:ext A) $x1=nil")
-apply (rotate_tac -1)
-apply simp
-(* eliminate introduced subgoal 2 *)
-apply (erule_tac [2] ForallQFilterPnil)
-prefer 2 apply (assumption)
-prefer 2 apply (fast)
-
-(* bring in divide Seq for s *)
-apply (frule sym [THEN eq_imp_below, THEN divide_Seq])
-apply (erule conjE)+
-
-(* subst divide_Seq in conclusion, but only at the righest occurence *)
-apply (rule_tac t = "schB" in ssubst)
-back
-back
-back
-apply assumption
-
-(* f B (tw iB) = tw ~eB *)
-apply (simp add: int_is_act not_ext_is_int_or_not_act)
-
-(* rewrite assumption forall and schB *)
-apply (rotate_tac 13)
-apply (simp add: ext_and_act)
-
-(* divide_Seq for schB2 *)
-apply (frule_tac y = "x2" in sym [THEN eq_imp_below, THEN divide_Seq])
-apply (erule conjE)+
-(* assumption schA *)
-apply (drule_tac x = "schB" and g = "Filter (%a. a:act B) $rs" in subst_lemma2)
-apply assumption
-apply (simp add: int_is_not_ext)
-
-(* f B (tw iA schA2) = nil *)
-apply (simp add: int_is_not_ext not_ext_is_int_or_not_act intA_is_not_actB)
-
-
-(* reduce trace_takes from n to strictly smaller k *)
-apply (rule take_reduction)
-apply (rule refl)
-apply (rule refl)
-
-(* now conclusion fulfills induction hypothesis, but assumptions are not all ready *)
-
-(* assumption schA *)
-apply (drule_tac x = "x2" and g = "Filter (%a. a:act A) $rs" in subst_lemma2)
-apply assumption
-apply (simp add: intA_is_not_actB int_is_not_ext)
-
-(* conclusions concerning LastActExtsch, cannot be rewritten, as LastActExtsmalli are looping  *)
-apply (drule_tac sch = "schB" and P = "%a. a:int B" in LastActExtsmall1)
-apply (frule_tac ?sch1.0 = "x1" in LastActExtsmall2)
-apply assumption
-apply (drule_tac sch = "x2" and P = "%a. a:int A" in LastActExtsmall1)
-
-(* assumption Forall schA, and Forall schA are performed by ForallTL,ForallDropwhile *)
-apply (simp add: ForallTL ForallDropwhile)
-
-(* case x~:B & x:A  *)
-(* cannot occur, as just this case has been scheduled out before as the B-only prefix *)
-apply (case_tac "x:act A")
-apply fast
-
-(* case x~:B & x~:A  *)
-(* cannot occur because of assumption: Forall (a:ext A | a:ext B) *)
-apply (rotate_tac -9)
-(* reduce forall assumption from tr to (x>>rs) *)
-apply (simp add: externals_of_par)
-apply (fast intro!: ext_is_act)
-
-done
-
-
-subsection "COMPOSITIONALITY on TRACE Level -- Main Theorem"
-
-lemma compositionality_tr: 
-"!! A B. [| is_trans_of A; is_trans_of B; compatible A B; compatible B A;  
-            is_asig(asig_of A); is_asig(asig_of B)|]  
-        ==>  (tr: traces(A||B)) =  
-             (Filter (%a. a:act A)$tr : traces A & 
-              Filter (%a. a:act B)$tr : traces B & 
-              Forall (%x. x:ext(A||B)) tr)"
-
-apply (simp (no_asm) add: traces_def has_trace_def)
-apply auto
-
-(* ==> *)
-(* There is a schedule of A *)
-apply (rule_tac x = "Filter (%a. a:act A) $sch" in bexI)
-prefer 2
-apply (simp add: compositionality_sch)
-apply (simp add: compatibility_consequence1 externals_of_par ext1_ext2_is_not_act1)
-(* There is a schedule of B *)
-apply (rule_tac x = "Filter (%a. a:act B) $sch" in bexI)
-prefer 2
-apply (simp add: compositionality_sch)
-apply (simp add: compatibility_consequence2 externals_of_par ext1_ext2_is_not_act2)
-(* Traces of A||B have only external actions from A or B *)
-apply (rule ForallPFilterP)
-
-(* <== *)
-
-(* replace schA and schB by Cut(schA) and Cut(schB) *)
-apply (drule exists_LastActExtsch)
-apply assumption
-apply (drule exists_LastActExtsch)
-apply assumption
-apply (erule exE)+
-apply (erule conjE)+
-(* Schedules of A(B) have only actions of A(B) *)
-apply (drule scheds_in_sig)
-apply assumption
-apply (drule scheds_in_sig)
-apply assumption
-
-apply (rename_tac h1 h2 schA schB)
-(* mksch is exactly the construction of trA||B out of schA, schB, and the oracle tr,
-   we need here *)
-apply (rule_tac x = "mksch A B$tr$schA$schB" in bexI)
-
-(* External actions of mksch are just the oracle *)
-apply (simp add: FilterA_mksch_is_tr)
-
-(* mksch is a schedule -- use compositionality on sch-level *)
-apply (simp add: compositionality_sch)
-apply (simp add: FilterAmksch_is_schA FilterBmksch_is_schB)
-apply (erule ForallAorB_mksch)
-apply (erule ForallPForallQ)
-apply (erule ext_is_act)
-done
-
-
-
-subsection {* COMPOSITIONALITY on TRACE Level -- for Modules *}
-
-lemma compositionality_tr_modules: 
-
-"!! A B. [| is_trans_of A; is_trans_of B; compatible A B; compatible B A;  
-            is_asig(asig_of A); is_asig(asig_of B)|]  
- ==> Traces (A||B) = par_traces (Traces A) (Traces B)"
-
-apply (unfold Traces_def par_traces_def)
-apply (simp add: asig_of_par)
-apply (rule set_eqI)
-apply (simp add: compositionality_tr externals_of_par)
-done
-
-
-declaration {* fn _ => Simplifier.map_ss (fn ss => ss setmksym (K (SOME o symmetric_fun))) *}
-
-
-end

--- a/src/HOLCF/IOA/meta_theory/Compositionality.thy	Sat Nov 27 14:34:54 2010 -0800
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,75 +0,0 @@
-(*  Title:      HOLCF/IOA/meta_theory/Compositionality.thy
-    Author:     Olaf Müller
-*)
-
-header {* Compositionality of I/O automata *}
-theory Compositionality
-imports CompoTraces
-begin
-
-lemma compatibility_consequence3: "[|eA --> A ; eB & ~eA --> ~A|] ==> (eA | eB) --> A=eA"
-apply auto
-done
-
-
-lemma Filter_actAisFilter_extA: 
-"!! A B. [| compatible A B; Forall (%a. a: ext A | a: ext B) tr |] ==>  
-            Filter (%a. a: act A)$tr= Filter (%a. a: ext A)$tr"
-apply (rule ForallPFilterQR)
-(* i.e.: [| (! x. P x --> (Q x = R x)) ; Forall P tr |] ==> Filter Q$tr = Filter R$tr *)
-prefer 2 apply (assumption)
-apply (rule compatibility_consequence3)
-apply (simp_all add: ext_is_act ext1_ext2_is_not_act1)
-done
-
-
-(* the next two theorems are only necessary, as there is no theorem ext (A||B) = ext (B||A) *)
-
-lemma compatibility_consequence4: "[|eA --> A ; eB & ~eA --> ~A|] ==> (eB | eA) --> A=eA"
-apply auto
-done
-
-lemma Filter_actAisFilter_extA2: "[| compatible A B; Forall (%a. a: ext B | a: ext A) tr |] ==>  
-            Filter (%a. a: act A)$tr= Filter (%a. a: ext A)$tr"
-apply (rule ForallPFilterQR)
-prefer 2 apply (assumption)
-apply (rule compatibility_consequence4)
-apply (simp_all add: ext_is_act ext1_ext2_is_not_act1)
-done
-
-
-subsection " Main Compositionality Theorem "
-
-lemma compositionality: "[| is_trans_of A1; is_trans_of A2; is_trans_of B1; is_trans_of B2; 
-             is_asig_of A1; is_asig_of A2;  
-             is_asig_of B1; is_asig_of B2;  
-             compatible A1 B1; compatible A2 B2;  
-             A1 =<| A2;  
-             B1 =<| B2 |]  
-         ==> (A1 || B1) =<| (A2 || B2)"
-apply (simp add: is_asig_of_def)
-apply (frule_tac A1 = "A1" in compat_commute [THEN iffD1])
-apply (frule_tac A1 = "A2" in compat_commute [THEN iffD1])
-apply (simp add: ioa_implements_def inputs_of_par outputs_of_par externals_of_par)
-apply auto
-apply (simp add: compositionality_tr)
-apply (subgoal_tac "ext A1 = ext A2 & ext B1 = ext B2")
-prefer 2
-apply (simp add: externals_def)
-apply (erule conjE)+
-(* rewrite with proven subgoal *)
-apply (simp add: externals_of_par)
-apply auto
-
-(* 2 goals, the 3rd has been solved automatically *)
-(* 1: Filter A2 x : traces A2 *)
-apply (drule_tac A = "traces A1" in subsetD)
-apply assumption
-apply (simp add: Filter_actAisFilter_extA)
-(* 2: Filter B2 x : traces B2 *)
-apply (drule_tac A = "traces B1" in subsetD)
-apply assumption
-apply (simp add: Filter_actAisFilter_extA2)
-done
-
-end

--- a/src/HOLCF/IOA/meta_theory/Deadlock.thy	Sat Nov 27 14:34:54 2010 -0800
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,92 +0,0 @@
-(*  Title:      HOLCF/IOA/meta_theory/Deadlock.thy
-    Author:     Olaf Müller
-*)
-
-header {* Deadlock freedom of I/O Automata *}
-
-theory Deadlock
-imports RefCorrectness CompoScheds
-begin
-
-text {* input actions may always be added to a schedule *}
-
-lemma scheds_input_enabled:
-  "[| Filter (%x. x:act A)$sch : schedules A; a:inp A; input_enabled A; Finite sch|]  
-          ==> Filter (%x. x:act A)$sch @@ a>>nil : schedules A"
-apply (simp add: schedules_def has_schedule_def)
-apply auto
-apply (frule inp_is_act)
-apply (simp add: executions_def)
-apply (tactic {* pair_tac @{context} "ex" 1 *})
-apply (rename_tac s ex)
-apply (subgoal_tac "Finite ex")
-prefer 2
-apply (simp add: filter_act_def)
-defer
-apply (rule_tac [2] Map2Finite [THEN iffD1])
-apply (rule_tac [2] t = "Map fst$ex" in subst)
-prefer 2 apply (assumption)
-apply (erule_tac [2] FiniteFilter)
-(* subgoal 1 *)
-apply (frule exists_laststate)
-apply (erule allE)
-apply (erule exE)
-(* using input-enabledness *)
-apply (simp add: input_enabled_def)
-apply (erule conjE)+
-apply (erule_tac x = "a" in allE)
-apply simp
-apply (erule_tac x = "u" in allE)
-apply (erule exE)
-(* instantiate execution *)
-apply (rule_tac x = " (s,ex @@ (a,s2) >>nil) " in exI)
-apply (simp add: filter_act_def MapConc)
-apply (erule_tac t = "u" in lemma_2_1)
-apply simp
-apply (rule sym)
-apply assumption
-done
-
-text {*
-               Deadlock freedom: component B cannot block an out or int action
-                                 of component A in every schedule.
-    Needs compositionality on schedule level, input-enabledness, compatibility
-                    and distributivity of is_exec_frag over @@
-*}
-
-declare split_if [split del]
-lemma IOA_deadlock_free: "[| a : local A; Finite sch; sch : schedules (A||B);  
-             Filter (%x. x:act A)$(sch @@ a>>nil) : schedules A; compatible A B; input_enabled B |]  
-           ==> (sch @@ a>>nil) : schedules (A||B)"
-apply (simp add: compositionality_sch locals_def)
-apply (rule conjI)
-(* a : act (A||B) *)
-prefer 2
-apply (simp add: actions_of_par)
-apply (blast dest: int_is_act out_is_act)
-
-(* Filter B (sch@@[a]) : schedules B *)
-
-apply (case_tac "a:int A")
-apply (drule intA_is_not_actB)
-apply (assumption) (* --> a~:act B *)
-apply simp
-
-(* case a~:int A , i.e. a:out A *)
-apply (case_tac "a~:act B")
-apply simp
-(* case a:act B *)
-apply simp
-apply (subgoal_tac "a:out A")
-prefer 2 apply (blast)
-apply (drule outAactB_is_inpB)
-apply assumption
-apply assumption
-apply (rule scheds_input_enabled)
-apply simp
-apply assumption+
-done
-
-declare split_if [split]
-
-end

--- a/src/HOLCF/IOA/meta_theory/IOA.thy	Sat Nov 27 14:34:54 2010 -0800
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,11 +0,0 @@
-(*  Title:      HOLCF/IOA/meta_theory/IOA.thy
-    Author:     Olaf Müller
-*)
-
-header {* The theory of I/O automata in HOLCF *}
-
-theory IOA
-imports SimCorrectness Compositionality Deadlock
-begin
-
-end

--- a/src/HOLCF/IOA/meta_theory/LiveIOA.thy	Sat Nov 27 14:34:54 2010 -0800
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,82 +0,0 @@
-(*  Title:      HOLCF/IOA/meta_theory/LiveIOA.thy
-    Author:     Olaf Müller
-*)
-
-header {* Live I/O automata -- specified by temproal formulas *}
-
-theory LiveIOA
-imports TLS
-begin
-
-default_sort type
-
-types
-  ('a, 's) live_ioa = "('a,'s)ioa * ('a,'s)ioa_temp"
-
-definition
-  validLIOA :: "('a,'s)live_ioa => ('a,'s)ioa_temp  => bool" where
-  "validLIOA AL P = validIOA (fst AL) ((snd AL) .--> P)"
-
-definition
-  WF :: "('a,'s)ioa => 'a set => ('a,'s)ioa_temp" where
-  "WF A acts = (<> [] <%(s,a,t) . Enabled A acts s> .--> [] <> <xt2 (plift (%a. a : acts))>)"
-definition
-  SF :: "('a,'s)ioa => 'a set => ('a,'s)ioa_temp" where
-  "SF A acts = ([] <> <%(s,a,t) . Enabled A acts s> .--> [] <> <xt2 (plift (%a. a : acts))>)"
-
-definition
-  liveexecutions :: "('a,'s)live_ioa => ('a,'s)execution set" where
-  "liveexecutions AP = {exec. exec : executions (fst AP) & (exec |== (snd AP))}"
-definition
-  livetraces :: "('a,'s)live_ioa => 'a trace set" where
-  "livetraces AP = {mk_trace (fst AP)$(snd ex) | ex. ex:liveexecutions AP}"
-definition
-  live_implements :: "('a,'s1)live_ioa => ('a,'s2)live_ioa => bool" where
-  "live_implements CL AM = ((inp (fst CL) = inp (fst AM)) &
-                            (out (fst CL) = out (fst AM)) &
-                            livetraces CL <= livetraces AM)"
-definition
-  is_live_ref_map :: "('s1 => 's2) => ('a,'s1)live_ioa => ('a,'s2)live_ioa => bool" where
-  "is_live_ref_map f CL AM =
-           (is_ref_map f (fst CL ) (fst AM) &
-            (! exec : executions (fst CL). (exec |== (snd CL)) -->
-                                           ((corresp_ex (fst AM) f exec) |== (snd AM))))"
-
-
-lemma live_implements_trans:
-"!!LC. [| live_implements (A,LA) (B,LB); live_implements (B,LB) (C,LC) |]
-      ==> live_implements (A,LA) (C,LC)"
-apply (unfold live_implements_def)
-apply auto
-done
-
-
-subsection "Correctness of live refmap"
-
-lemma live_implements: "[| inp(C)=inp(A); out(C)=out(A);
-                   is_live_ref_map f (C,M) (A,L) |]
-                ==> live_implements (C,M) (A,L)"
-apply (simp add: is_live_ref_map_def live_implements_def livetraces_def liveexecutions_def)
-apply auto
-apply (rule_tac x = "corresp_ex A f ex" in exI)
-apply auto
-  (* Traces coincide, Lemma 1 *)
-  apply (tactic {* pair_tac @{context} "ex" 1 *})
-  apply (erule lemma_1 [THEN spec, THEN mp])
-  apply (simp (no_asm) add: externals_def)
-  apply (auto)[1]
-  apply (simp add: executions_def reachable.reachable_0)
-
-  (* corresp_ex is execution, Lemma 2 *)
-  apply (tactic {* pair_tac @{context} "ex" 1 *})
-  apply (simp add: executions_def)
-  (* start state *)
-  apply (rule conjI)
-  apply (simp add: is_ref_map_def corresp_ex_def)
-  (* is-execution-fragment *)
-  apply (erule lemma_2 [THEN spec, THEN mp])
-  apply (simp add: reachable.reachable_0)
-
-done
-
-end

--- a/src/HOLCF/IOA/meta_theory/Pred.thy	Sat Nov 27 14:34:54 2010 -0800
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,69 +0,0 @@
-(*  Title:      HOLCF/IOA/meta_theory/Pred.thy
-    Author:     Olaf Müller
-*)
-
-header {* Logical Connectives lifted to predicates *}
-
-theory Pred
-imports Main
-begin
-
-default_sort type
-
-types
-  'a predicate = "'a => bool"
-
-consts
-
-satisfies    ::"'a  => 'a predicate => bool"    ("_ |= _" [100,9] 8)
-valid        ::"'a predicate => bool"           (*  ("|-") *)
-
-NOT          ::"'a predicate => 'a predicate"  (".~ _" [40] 40)
-AND          ::"'a predicate => 'a predicate => 'a predicate"    (infixr ".&" 35)
-OR           ::"'a predicate => 'a predicate => 'a predicate"    (infixr ".|" 30)
-IMPLIES      ::"'a predicate => 'a predicate => 'a predicate"    (infixr ".-->" 25)
-
-
-notation (output)
-  NOT  ("~ _" [40] 40) and
-  AND  (infixr "&" 35) and
-  OR  (infixr "|" 30) and
-  IMPLIES  (infixr "-->" 25)
-
-notation (xsymbols output)
-  NOT  ("\<not> _" [40] 40) and
-  AND  (infixr "\<and>" 35) and
-  OR  (infixr "\<or>" 30) and
-  IMPLIES  (infixr "\<longrightarrow>" 25)
-
-notation (xsymbols)
-  satisfies  ("_ \<Turnstile> _" [100,9] 8)
-
-notation (HTML output)
-  NOT  ("\<not> _" [40] 40) and
-  AND  (infixr "\<and>" 35) and
-  OR  (infixr "\<or>" 30)
-
-
-defs
-
-satisfies_def:
-   "s |= P  == P s"
-
-(* priority einfuegen, da clash mit |=, wenn graphisches Symbol *)
-valid_def:
-   "valid P == (! s. (s |= P))"
-
-NOT_def:
-  "NOT P s ==  ~ (P s)"
-
-AND_def:
-  "(P .& Q) s == (P s) & (Q s)"
-
-OR_def:
-  "(P .| Q) s ==  (P s) | (Q s)"
-
-IMPLIES_def:
-  "(P .--> Q) s == (P s) --> (Q s)"
-
-end

--- a/src/HOLCF/IOA/meta_theory/RefCorrectness.thy	Sat Nov 27 14:34:54 2010 -0800
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,371 +0,0 @@
-(*  Title:      HOLCF/IOA/meta_theory/RefCorrectness.thy
-    Author:     Olaf Müller
-*)
-
-header {* Correctness of Refinement Mappings in HOLCF/IOA *}
-
-theory RefCorrectness
-imports RefMappings
-begin
-
-definition
-  corresp_exC :: "('a,'s2)ioa => ('s1 => 's2) => ('a,'s1)pairs
-                   -> ('s1 => ('a,'s2)pairs)" where
-  "corresp_exC A f = (fix$(LAM h ex. (%s. case ex of
-      nil =>  nil
-    | x##xs => (flift1 (%pr. (@cex. move A cex (f s) (fst pr) (f (snd pr)))
-                              @@ ((h$xs) (snd pr)))
-                        $x) )))"
-definition
-  corresp_ex :: "('a,'s2)ioa => ('s1 => 's2) =>
-                  ('a,'s1)execution => ('a,'s2)execution" where
-  "corresp_ex A f ex = (f (fst ex),(corresp_exC A f$(snd ex)) (fst ex))"
-
-definition
-  is_fair_ref_map :: "('s1 => 's2) => ('a,'s1)ioa => ('a,'s2)ioa => bool" where
-  "is_fair_ref_map f C A =
-      (is_ref_map f C A &
-       (! ex : executions(C). fair_ex C ex --> fair_ex A (corresp_ex A f ex)))"
-
-(* Axioms for fair trace inclusion proof support, not for the correctness proof
-   of refinement mappings!
-   Note: Everything is superseded by LiveIOA.thy! *)
-
-axiomatization where
-corresp_laststate:
-  "Finite ex ==> laststate (corresp_ex A f (s,ex)) = f (laststate (s,ex))"
-
-axiomatization where
-corresp_Finite:
-  "Finite (snd (corresp_ex A f (s,ex))) = Finite ex"
-
-axiomatization where
-FromAtoC:
-  "fin_often (%x. P (snd x)) (snd (corresp_ex A f (s,ex))) ==> fin_often (%y. P (f (snd y))) ex"
-
-axiomatization where
-FromCtoA:
-  "inf_often (%y. P (fst y)) ex ==> inf_often (%x. P (fst x)) (snd (corresp_ex A f (s,ex)))"
-
-
-(* Proof by case on inf W in ex: If so, ok. If not, only fin W in ex, ie there is
-   an index i from which on no W in ex. But W inf enabled, ie at least once after i
-   W is enabled. As W does not occur after i and W is enabling_persistent, W keeps
-   enabled until infinity, ie. indefinitely *)
-axiomatization where
-persistent:
-  "[|inf_often (%x. Enabled A W (snd x)) ex; en_persistent A W|]
-   ==> inf_often (%x. fst x :W) ex | fin_often (%x. ~Enabled A W (snd x)) ex"
-
-axiomatization where
-infpostcond:
-  "[| is_exec_frag A (s,ex); inf_often (%x. fst x:W) ex|]
-    ==> inf_often (% x. set_was_enabled A W (snd x)) ex"
-
-
-subsection "corresp_ex"
-
-lemma corresp_exC_unfold: "corresp_exC A f  = (LAM ex. (%s. case ex of
-       nil =>  nil
-     | x##xs => (flift1 (%pr. (@cex. move A cex (f s) (fst pr) (f (snd pr)))
-                               @@ ((corresp_exC A f $xs) (snd pr)))
-                         $x) ))"
-apply (rule trans)
-apply (rule fix_eq2)
-apply (simp only: corresp_exC_def)
-apply (rule beta_cfun)
-apply (simp add: flift1_def)
-done
-
-lemma corresp_exC_UU: "(corresp_exC A f$UU) s=UU"
-apply (subst corresp_exC_unfold)
-apply simp
-done
-
-lemma corresp_exC_nil: "(corresp_exC A f$nil) s = nil"
-apply (subst corresp_exC_unfold)
-apply simp
-done
-
-lemma corresp_exC_cons: "(corresp_exC A f$(at>>xs)) s =
-           (@cex. move A cex (f s) (fst at) (f (snd at)))
-           @@ ((corresp_exC A f$xs) (snd at))"
-apply (rule trans)
-apply (subst corresp_exC_unfold)
-apply (simp add: Consq_def flift1_def)
-apply simp
-done
-
-
-declare corresp_exC_UU [simp] corresp_exC_nil [simp] corresp_exC_cons [simp]
-
-
-
-subsection "properties of move"
-
-lemma move_is_move:
-   "[|is_ref_map f C A; reachable C s; (s,a,t):trans_of C|] ==>
-      move A (@x. move A x (f s) a (f t)) (f s) a (f t)"
-apply (unfold is_ref_map_def)
-apply (subgoal_tac "? ex. move A ex (f s) a (f t) ")
-prefer 2
-apply simp
-apply (erule exE)
-apply (rule someI)
-apply assumption
-done
-
-lemma move_subprop1:
-   "[|is_ref_map f C A; reachable C s; (s,a,t):trans_of C|] ==>
-     is_exec_frag A (f s,@x. move A x (f s) a (f t))"
-apply (cut_tac move_is_move)
-defer
-apply assumption+
-apply (simp add: move_def)
-done
-
-lemma move_subprop2:
-   "[|is_ref_map f C A; reachable C s; (s,a,t):trans_of C|] ==>
-     Finite ((@x. move A x (f s) a (f t)))"
-apply (cut_tac move_is_move)
-defer
-apply assumption+
-apply (simp add: move_def)
-done
-
-lemma move_subprop3:
-   "[|is_ref_map f C A; reachable C s; (s,a,t):trans_of C|] ==>
-     laststate (f s,@x. move A x (f s) a (f t)) = (f t)"
-apply (cut_tac move_is_move)
-defer
-apply assumption+
-apply (simp add: move_def)
-done
-
-lemma move_subprop4:
-   "[|is_ref_map f C A; reachable C s; (s,a,t):trans_of C|] ==>
-      mk_trace A$((@x. move A x (f s) a (f t))) =
-        (if a:ext A then a>>nil else nil)"
-apply (cut_tac move_is_move)
-defer
-apply assumption+
-apply (simp add: move_def)
-done
-
-
-(* ------------------------------------------------------------------ *)
-(*                   The following lemmata contribute to              *)
-(*                 TRACE INCLUSION Part 1: Traces coincide            *)
-(* ------------------------------------------------------------------ *)
-
-section "Lemmata for <=="
-
-(* --------------------------------------------------- *)
-(*   Lemma 1.1: Distribution of mk_trace and @@        *)
-(* --------------------------------------------------- *)
-
-lemma mk_traceConc: "mk_trace C$(ex1 @@ ex2)= (mk_trace C$ex1) @@ (mk_trace C$ex2)"
-apply (simp add: mk_trace_def filter_act_def MapConc)
-done
-
-
-
-(* ------------------------------------------------------
-                 Lemma 1 :Traces coincide
-   ------------------------------------------------------- *)
-declare split_if [split del]
-
-lemma lemma_1:
-  "[|is_ref_map f C A; ext C = ext A|] ==>
-         !s. reachable C s & is_exec_frag C (s,xs) -->
-             mk_trace C$xs = mk_trace A$(snd (corresp_ex A f (s,xs)))"
-apply (unfold corresp_ex_def)
-apply (tactic {* pair_induct_tac @{context} "xs" [@{thm is_exec_frag_def}] 1 *})
-(* cons case *)
-apply (auto simp add: mk_traceConc)
-apply (frule reachable.reachable_n)
-apply assumption
-apply (erule_tac x = "y" in allE)
-apply (simp add: move_subprop4 split add: split_if)
-done
-
-declare split_if [split]
-
-(* ------------------------------------------------------------------ *)
-(*                   The following lemmata contribute to              *)
-(*              TRACE INCLUSION Part 2: corresp_ex is execution       *)
-(* ------------------------------------------------------------------ *)
-
-section "Lemmata for ==>"
-
-(* -------------------------------------------------- *)
-(*                   Lemma 2.1                        *)
-(* -------------------------------------------------- *)
-
-lemma lemma_2_1 [rule_format (no_asm)]:
-"Finite xs -->
- (!s .is_exec_frag A (s,xs) & is_exec_frag A (t,ys) &
-      t = laststate (s,xs)
-  --> is_exec_frag A (s,xs @@ ys))"
-
-apply (rule impI)
-apply (tactic {* Seq_Finite_induct_tac @{context} 1 *})
-(* main case *)
-apply (auto simp add: split_paired_all)
-done
-
-
-(* ----------------------------------------------------------- *)
-(*               Lemma 2 : corresp_ex is execution             *)
-(* ----------------------------------------------------------- *)
-
-
-
-lemma lemma_2:
- "[| is_ref_map f C A |] ==>
-  !s. reachable C s & is_exec_frag C (s,xs)
-  --> is_exec_frag A (corresp_ex A f (s,xs))"
-
-apply (unfold corresp_ex_def)
-
-apply simp
-apply (tactic {* pair_induct_tac @{context} "xs" [@{thm is_exec_frag_def}] 1 *})
-(* main case *)
-apply auto
-apply (rule_tac t = "f y" in lemma_2_1)
-
-(* Finite *)
-apply (erule move_subprop2)
-apply assumption+
-apply (rule conjI)
-
-(* is_exec_frag *)
-apply (erule move_subprop1)
-apply assumption+
-apply (rule conjI)
-
-(* Induction hypothesis  *)
-(* reachable_n looping, therefore apply it manually *)
-apply (erule_tac x = "y" in allE)
-apply simp
-apply (frule reachable.reachable_n)
-apply assumption
-apply simp
-(* laststate *)
-apply (erule move_subprop3 [symmetric])
-apply assumption+
-done
-
-
-subsection "Main Theorem: TRACE - INCLUSION"
-
-lemma trace_inclusion:
-  "[| ext C = ext A; is_ref_map f C A |]
-           ==> traces C <= traces A"
-
-  apply (unfold traces_def)
-
-  apply (simp (no_asm) add: has_trace_def2)
-  apply auto
-
-  (* give execution of abstract automata *)
-  apply (rule_tac x = "corresp_ex A f ex" in bexI)
-
-  (* Traces coincide, Lemma 1 *)
-  apply (tactic {* pair_tac @{context} "ex" 1 *})
-  apply (erule lemma_1 [THEN spec, THEN mp])
-  apply assumption+
-  apply (simp add: executions_def reachable.reachable_0)
-
-  (* corresp_ex is execution, Lemma 2 *)
-  apply (tactic {* pair_tac @{context} "ex" 1 *})
-  apply (simp add: executions_def)
-  (* start state *)
-  apply (rule conjI)
-  apply (simp add: is_ref_map_def corresp_ex_def)
-  (* is-execution-fragment *)
-  apply (erule lemma_2 [THEN spec, THEN mp])
-  apply (simp add: reachable.reachable_0)
-  done
-
-
-subsection "Corollary:  FAIR TRACE - INCLUSION"
-
-lemma fininf: "(~inf_often P s) = fin_often P s"
-apply (unfold fin_often_def)
-apply auto
-done
-
-
-lemma WF_alt: "is_wfair A W (s,ex) =
-  (fin_often (%x. ~Enabled A W (snd x)) ex --> inf_often (%x. fst x :W) ex)"
-apply (simp add: is_wfair_def fin_often_def)
-apply auto
-done
-
-lemma WF_persistent: "[|is_wfair A W (s,ex); inf_often (%x. Enabled A W (snd x)) ex;
-          en_persistent A W|]
-    ==> inf_often (%x. fst x :W) ex"
-apply (drule persistent)
-apply assumption
-apply (simp add: WF_alt)
-apply auto
-done
-
-
-lemma fair_trace_inclusion: "!! C A.
-          [| is_ref_map f C A; ext C = ext A;
-          !! ex. [| ex:executions C; fair_ex C ex|] ==> fair_ex A (corresp_ex A f ex) |]
-          ==> fairtraces C <= fairtraces A"
-apply (simp (no_asm) add: fairtraces_def fairexecutions_def)
-apply auto
-apply (rule_tac x = "corresp_ex A f ex" in exI)
-apply auto
-
-  (* Traces coincide, Lemma 1 *)
-  apply (tactic {* pair_tac @{context} "ex" 1 *})
-  apply (erule lemma_1 [THEN spec, THEN mp])
-  apply assumption+
-  apply (simp add: executions_def reachable.reachable_0)
-
-  (* corresp_ex is execution, Lemma 2 *)
-  apply (tactic {* pair_tac @{context} "ex" 1 *})
-  apply (simp add: executions_def)
-  (* start state *)
-  apply (rule conjI)
-  apply (simp add: is_ref_map_def corresp_ex_def)
-  (* is-execution-fragment *)
-  apply (erule lemma_2 [THEN spec, THEN mp])
-  apply (simp add: reachable.reachable_0)
-
-done
-
-lemma fair_trace_inclusion2: "!! C A.
-          [| inp(C) = inp(A); out(C)=out(A);
-             is_fair_ref_map f C A |]
-          ==> fair_implements C A"
-apply (simp add: is_fair_ref_map_def fair_implements_def fairtraces_def fairexecutions_def)
-apply auto
-apply (rule_tac x = "corresp_ex A f ex" in exI)
-apply auto
-
-  (* Traces coincide, Lemma 1 *)
-  apply (tactic {* pair_tac @{context} "ex" 1 *})
-  apply (erule lemma_1 [THEN spec, THEN mp])
-  apply (simp (no_asm) add: externals_def)
-  apply (auto)[1]
-  apply (simp add: executions_def reachable.reachable_0)
-
-  (* corresp_ex is execution, Lemma 2 *)
-  apply (tactic {* pair_tac @{context} "ex" 1 *})
-  apply (simp add: executions_def)
-  (* start state *)
-  apply (rule conjI)
-  apply (simp add: is_ref_map_def corresp_ex_def)
-  (* is-execution-fragment *)
-  apply (erule lemma_2 [THEN spec, THEN mp])
-  apply (simp add: reachable.reachable_0)
-
-done
-
-end

--- a/src/HOLCF/IOA/meta_theory/RefMappings.thy	Sat Nov 27 14:34:54 2010 -0800
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,129 +0,0 @@
-(*  Title:      HOLCF/IOA/meta_theory/RefMappings.thy
-    Author:     Olaf Müller
-*)
-
-header {* Refinement Mappings in HOLCF/IOA *}
-
-theory RefMappings
-imports Traces
-begin
-
-default_sort type
-
-definition
-  move :: "[('a,'s)ioa,('a,'s)pairs,'s,'a,'s] => bool" where
-  "move ioa ex s a t =
-    (is_exec_frag ioa (s,ex) &  Finite ex &
-     laststate (s,ex)=t  &
-     mk_trace ioa$ex = (if a:ext(ioa) then a>>nil else nil))"
-
-definition
-  is_ref_map :: "[('s1=>'s2),('a,'s1)ioa,('a,'s2)ioa] => bool" where
-  "is_ref_map f C A =
-   ((!s:starts_of(C). f(s):starts_of(A)) &
-   (!s t a. reachable C s &
-            s -a--C-> t
-            --> (? ex. move A ex (f s) a (f t))))"
-
-definition
-  is_weak_ref_map :: "[('s1=>'s2),('a,'s1)ioa,('a,'s2)ioa] => bool" where
-  "is_weak_ref_map f C A =
-   ((!s:starts_of(C). f(s):starts_of(A)) &
-   (!s t a. reachable C s &
-            s -a--C-> t
-            --> (if a:ext(C)
-                 then (f s) -a--A-> (f t)
-                 else (f s)=(f t))))"
-
-
-subsection "transitions and moves"
-
-
-lemma transition_is_ex: "s -a--A-> t ==> ? ex. move A ex s a t"
-apply (rule_tac x = " (a,t) >>nil" in exI)
-apply (simp add: move_def)
-done
-
-
-lemma nothing_is_ex: "(~a:ext A) & s=t ==> ? ex. move A ex s a t"
-apply (rule_tac x = "nil" in exI)
-apply (simp add: move_def)
-done
-
-
-lemma ei_transitions_are_ex: "(s -a--A-> s') & (s' -a'--A-> s'') & (~a':ext A)  
-         ==> ? ex. move A ex s a s''"
-apply (rule_tac x = " (a,s') >> (a',s'') >>nil" in exI)
-apply (simp add: move_def)
-done
-
-
-lemma eii_transitions_are_ex: "(s1 -a1--A-> s2) & (s2 -a2--A-> s3) & (s3 -a3--A-> s4) & 
-      (~a2:ext A) & (~a3:ext A) ==>  
-      ? ex. move A ex s1 a1 s4"
-apply (rule_tac x = " (a1,s2) >> (a2,s3) >> (a3,s4) >>nil" in exI)
-apply (simp add: move_def)
-done
-
-
-subsection "weak_ref_map and ref_map"
-
-lemma weak_ref_map2ref_map:
-  "[| ext C = ext A;  
-     is_weak_ref_map f C A |] ==> is_ref_map f C A"
-apply (unfold is_weak_ref_map_def is_ref_map_def)
-apply auto
-apply (case_tac "a:ext A")
-apply (auto intro: transition_is_ex nothing_is_ex)
-done
-
-
-lemma imp_conj_lemma: "(P ==> Q-->R) ==> P&Q --> R"
-  by blast
-
-declare split_if [split del]
-declare if_weak_cong [cong del]
-
-lemma rename_through_pmap: "[| is_weak_ref_map f C A |]  
-      ==> (is_weak_ref_map f (rename C g) (rename A g))"
-apply (simp add: is_weak_ref_map_def)
-apply (rule conjI)
-(* 1: start states *)
-apply (simp add: rename_def rename_set_def starts_of_def)
-(* 2: reachable transitions *)
-apply (rule allI)+
-apply (rule imp_conj_lemma)
-apply (simp (no_asm) add: rename_def rename_set_def)
-apply (simp add: externals_def asig_inputs_def asig_outputs_def asig_of_def trans_of_def)
-apply safe
-apply (simplesubst split_if)
- apply (rule conjI)
- apply (rule impI)
- apply (erule disjE)
- apply (erule exE)
-apply (erule conjE)
-(* x is input *)
- apply (drule sym)
- apply (drule sym)
-apply simp
-apply hypsubst+
-apply (frule reachable_rename)
-apply simp
-(* x is output *)
- apply (erule exE)
-apply (erule conjE)
- apply (drule sym)
- apply (drule sym)
-apply simp
-apply hypsubst+
-apply (frule reachable_rename)
-apply simp
-(* x is internal *)
-apply (frule reachable_rename)
-apply auto
-done
-
-declare split_if [split]
-declare if_weak_cong [cong]
-
-end

--- a/src/HOLCF/IOA/meta_theory/Seq.thy	Sat Nov 27 14:34:54 2010 -0800
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,328 +0,0 @@
-(*  Title:      HOLCF/IOA/meta_theory/Seq.thy
-    Author:     Olaf Müller
-*)
-
-header {* Partial, Finite and Infinite Sequences (lazy lists), modeled as domain *}
-
-theory Seq
-imports HOLCF
-begin
-
-default_sort pcpo
-
-domain (unsafe) 'a seq = nil  ("nil") | cons (HD :: 'a) (lazy TL :: "'a seq")  (infixr "##" 65)
-
-(*
-   sfilter       :: "('a -> tr) -> 'a seq -> 'a seq"
-   smap          :: "('a -> 'b) -> 'a seq -> 'b seq"
-   sforall       :: "('a -> tr) => 'a seq => bool"
-   sforall2      :: "('a -> tr) -> 'a seq -> tr"
-   slast         :: "'a seq     -> 'a"
-   sconc         :: "'a seq     -> 'a seq -> 'a seq"
-   sdropwhile    :: "('a -> tr)  -> 'a seq -> 'a seq"
-   stakewhile    :: "('a -> tr)  -> 'a seq -> 'a seq"
-   szip          :: "'a seq      -> 'b seq -> ('a*'b) seq"
-   sflat        :: "('a seq) seq  -> 'a seq"
-
-   sfinite       :: "'a seq set"
-   Partial       :: "'a seq => bool"
-   Infinite      :: "'a seq => bool"
-
-   nproj        :: "nat => 'a seq => 'a"
-   sproj        :: "nat => 'a seq => 'a seq"
-*)
-
-inductive
-  Finite :: "'a seq => bool"
-  where
-    sfinite_0:  "Finite nil"
-  | sfinite_n:  "[| Finite tr; a~=UU |] ==> Finite (a##tr)"
-
-declare Finite.intros [simp]
-
-definition
-  Partial :: "'a seq => bool"
-where
-  "Partial x  == (seq_finite x) & ~(Finite x)"
-
-definition
-  Infinite :: "'a seq => bool"
-where
-  "Infinite x == ~(seq_finite x)"
-
-
-subsection {* recursive equations of operators *}
-
-subsubsection {* smap *}
-
-fixrec
-  smap :: "('a -> 'b) -> 'a seq -> 'b seq"
-where
-  smap_nil: "smap$f$nil=nil"
-| smap_cons: "[|x~=UU|] ==> smap$f$(x##xs)= (f$x)##smap$f$xs"
-
-lemma smap_UU [simp]: "smap$f$UU=UU"
-by fixrec_simp
-
-subsubsection {* sfilter *}
-
-fixrec
-   sfilter :: "('a -> tr) -> 'a seq -> 'a seq"
-where
-  sfilter_nil: "sfilter$P$nil=nil"
-| sfilter_cons:
-    "x~=UU ==> sfilter$P$(x##xs)=
-              (If P$x then x##(sfilter$P$xs) else sfilter$P$xs)"
-
-lemma sfilter_UU [simp]: "sfilter$P$UU=UU"
-by fixrec_simp
-
-subsubsection {* sforall2 *}
-
-fixrec
-  sforall2 :: "('a -> tr) -> 'a seq -> tr"
-where
-  sforall2_nil: "sforall2$P$nil=TT"
-| sforall2_cons:
-    "x~=UU ==> sforall2$P$(x##xs)= ((P$x) andalso sforall2$P$xs)"
-
-lemma sforall2_UU [simp]: "sforall2$P$UU=UU"
-by fixrec_simp
-
-definition
-  sforall_def: "sforall P t == (sforall2$P$t ~=FF)"
-
-subsubsection {* stakewhile *}
-
-fixrec
-  stakewhile :: "('a -> tr)  -> 'a seq -> 'a seq"
-where
-  stakewhile_nil: "stakewhile$P$nil=nil"
-| stakewhile_cons:
-    "x~=UU ==> stakewhile$P$(x##xs) =
-              (If P$x then x##(stakewhile$P$xs) else nil)"
-
-lemma stakewhile_UU [simp]: "stakewhile$P$UU=UU"
-by fixrec_simp
-
-subsubsection {* sdropwhile *}
-
-fixrec
-  sdropwhile :: "('a -> tr) -> 'a seq -> 'a seq"
-where
-  sdropwhile_nil: "sdropwhile$P$nil=nil"
-| sdropwhile_cons:
-    "x~=UU ==> sdropwhile$P$(x##xs) =
-              (If P$x then sdropwhile$P$xs else x##xs)"
-
-lemma sdropwhile_UU [simp]: "sdropwhile$P$UU=UU"
-by fixrec_simp
-
-subsubsection {* slast *}
-
-fixrec
-  slast :: "'a seq -> 'a"
-where
-  slast_nil: "slast$nil=UU"
-| slast_cons:
-    "x~=UU ==> slast$(x##xs)= (If is_nil$xs then x else slast$xs)"
-
-lemma slast_UU [simp]: "slast$UU=UU"
-by fixrec_simp
-
-subsubsection {* sconc *}
-
-fixrec
-  sconc :: "'a seq -> 'a seq -> 'a seq"
-where
-  sconc_nil: "sconc$nil$y = y"
-| sconc_cons':
-    "x~=UU ==> sconc$(x##xs)$y = x##(sconc$xs$y)"
-
-abbreviation
-  sconc_syn :: "'a seq => 'a seq => 'a seq"  (infixr "@@" 65) where
-  "xs @@ ys == sconc $ xs $ ys"
-
-lemma sconc_UU [simp]: "UU @@ y=UU"
-by fixrec_simp
-
-lemma sconc_cons [simp]: "(x##xs) @@ y=x##(xs @@ y)"
-apply (cases "x=UU")
-apply simp_all
-done
-
-declare sconc_cons' [simp del]
-
-subsubsection {* sflat *}
-
-fixrec
-  sflat :: "('a seq) seq -> 'a seq"
-where
-  sflat_nil: "sflat$nil=nil"
-| sflat_cons': "x~=UU ==> sflat$(x##xs)= x@@(sflat$xs)"
-
-lemma sflat_UU [simp]: "sflat$UU=UU"
-by fixrec_simp
-
-lemma sflat_cons [simp]: "sflat$(x##xs)= x@@(sflat$xs)"
-by (cases "x=UU", simp_all)
-
-declare sflat_cons' [simp del]
-
-subsubsection {* szip *}
-
-fixrec
-  szip :: "'a seq -> 'b seq -> ('a*'b) seq"
-where
-  szip_nil: "szip$nil$y=nil"
-| szip_cons_nil: "x~=UU ==> szip$(x##xs)$nil=UU"
-| szip_cons:
-    "[| x~=UU; y~=UU|] ==> szip$(x##xs)$(y##ys) = (x,y)##szip$xs$ys"
-
-lemma szip_UU1 [simp]: "szip$UU$y=UU"
-by fixrec_simp
-
-lemma szip_UU2 [simp]: "x~=nil ==> szip$x$UU=UU"
-by (cases x, simp_all, fixrec_simp)
-
-
-subsection "scons, nil"
-
-lemma scons_inject_eq:
- "[|x~=UU;y~=UU|]==> (x##xs=y##ys) = (x=y & xs=ys)"
-by simp
-
-lemma nil_less_is_nil: "nil<<x ==> nil=x"
-apply (cases x)
-apply simp
-apply simp
-apply simp
-done
-
-subsection "sfilter, sforall, sconc"
-
-lemma if_and_sconc [simp]: "(if b then tr1 else tr2) @@ tr
-        = (if b then tr1 @@ tr else tr2 @@ tr)"
-by simp
-
-
-lemma sfiltersconc: "sfilter$P$(x @@ y) = (sfilter$P$x @@ sfilter$P$y)"
-apply (induct x)
-(* adm *)
-apply simp
-(* base cases *)
-apply simp
-apply simp
-(* main case *)
-apply (rule_tac p="P$a" in trE)
-apply simp
-apply simp
-apply simp
-done
-
-lemma sforallPstakewhileP: "sforall P (stakewhile$P$x)"
-apply (simp add: sforall_def)
-apply (induct x)
-(* adm *)
-apply simp
-(* base cases *)
-apply simp
-apply simp
-(* main case *)
-apply (rule_tac p="P$a" in trE)
-apply simp
-apply simp
-apply simp
-done
-
-lemma forallPsfilterP: "sforall P (sfilter$P$x)"
-apply (simp add: sforall_def)
-apply (induct x)
-(* adm *)
-apply simp
-(* base cases *)
-apply simp
-apply simp
-(* main case *)
-apply (rule_tac p="P$a" in trE)
-apply simp
-apply simp
-apply simp
-done
-
-
-subsection "Finite"
-
-(* ----------------------------------------------------  *)
-(* Proofs of rewrite rules for Finite:                  *)
-(* 1. Finite(nil),   (by definition)                    *)
-(* 2. ~Finite(UU),                                      *)
-(* 3. a~=UU==> Finite(a##x)=Finite(x)                  *)
-(* ----------------------------------------------------  *)
-
-lemma Finite_UU_a: "Finite x --> x~=UU"
-apply (rule impI)
-apply (erule Finite.induct)
- apply simp
-apply simp
-done
-
-lemma Finite_UU [simp]: "~(Finite UU)"
-apply (cut_tac x="UU" in Finite_UU_a)
-apply fast
-done
-
-lemma Finite_cons_a: "Finite x --> a~=UU --> x=a##xs --> Finite xs"
-apply (intro strip)
-apply (erule Finite.cases)
-apply fastsimp
-apply simp
-done
-
-lemma Finite_cons: "a~=UU ==>(Finite (a##x)) = (Finite x)"
-apply (rule iffI)
-apply (erule (1) Finite_cons_a [rule_format])
-apply fast
-apply simp
-done
-
-lemma Finite_upward: "\<lbrakk>Finite x; x \<sqsubseteq> y\<rbrakk> \<Longrightarrow> Finite y"
-apply (induct arbitrary: y set: Finite)
-apply (case_tac y, simp, simp, simp)
-apply (case_tac y, simp, simp)
-apply simp
-done
-
-lemma adm_Finite [simp]: "adm Finite"
-by (rule adm_upward, rule Finite_upward)
-
-
-subsection "induction"
-
-
-(*--------------------------------   *)
-(* Extensions to Induction Theorems  *)
-(*--------------------------------   *)
-
-
-lemma seq_finite_ind_lemma:
-  assumes "(!!n. P(seq_take n$s))"
-  shows "seq_finite(s) -->P(s)"
-apply (unfold seq.finite_def)
-apply (intro strip)
-apply (erule exE)
-apply (erule subst)
-apply (rule prems)
-done
-
-
-lemma seq_finite_ind: "!!P.[|P(UU);P(nil);
-   !! x s1.[|x~=UU;P(s1)|] ==> P(x##s1)
-   |] ==> seq_finite(s) --> P(s)"
-apply (rule seq_finite_ind_lemma)
-apply (erule seq.finite_induct)
- apply assumption
-apply simp
-done
-
-end

--- a/src/HOLCF/IOA/meta_theory/Sequence.thy	Sat Nov 27 14:34:54 2010 -0800
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,1118 +0,0 @@
-(*  Title:      HOLCF/IOA/meta_theory/Sequence.thy
-    Author:     Olaf Müller
-
-Sequences over flat domains with lifted elements.
-*)
-
-theory Sequence
-imports Seq
-begin
-
-default_sort type
-
-types 'a Seq = "'a lift seq"
-
-consts
-
-  Consq            ::"'a            => 'a Seq -> 'a Seq"
-  Filter           ::"('a => bool)  => 'a Seq -> 'a Seq"
-  Map              ::"('a => 'b)    => 'a Seq -> 'b Seq"
-  Forall           ::"('a => bool)  => 'a Seq => bool"
-  Last             ::"'a Seq        -> 'a lift"
-  Dropwhile        ::"('a => bool)  => 'a Seq -> 'a Seq"
-  Takewhile        ::"('a => bool)  => 'a Seq -> 'a Seq"
-  Zip              ::"'a Seq        -> 'b Seq -> ('a * 'b) Seq"
-  Flat             ::"('a Seq) seq   -> 'a Seq"
-
-  Filter2          ::"('a => bool)  => 'a Seq -> 'a Seq"
-
-abbreviation
-  Consq_syn  ("(_/>>_)"  [66,65] 65) where
-  "a>>s == Consq a$s"
-
-notation (xsymbols)
-  Consq_syn  ("(_\<leadsto>_)"  [66,65] 65)
-
-
-(* list Enumeration *)
-syntax
-  "_totlist"      :: "args => 'a Seq"              ("[(_)!]")
-  "_partlist"     :: "args => 'a Seq"              ("[(_)?]")
-translations
-  "[x, xs!]"     == "x>>[xs!]"
-  "[x!]"         == "x>>nil"
-  "[x, xs?]"     == "x>>[xs?]"
-  "[x?]"         == "x>>CONST UU"
-
-defs
-
-Consq_def:     "Consq a == LAM s. Def a ## s"
-
-Filter_def:    "Filter P == sfilter$(flift2 P)"
-
-Map_def:       "Map f  == smap$(flift2 f)"
-
-Forall_def:    "Forall P == sforall (flift2 P)"
-
-Last_def:      "Last == slast"
-
-Dropwhile_def: "Dropwhile P == sdropwhile$(flift2 P)"
-
-Takewhile_def: "Takewhile P == stakewhile$(flift2 P)"
-
-Flat_def:      "Flat == sflat"
-
-Zip_def:
-  "Zip == (fix$(LAM h t1 t2. case t1 of
-               nil   => nil
-             | x##xs => (case t2 of
-                          nil => UU
-                        | y##ys => (case x of
-                                      UU  => UU
-                                    | Def a => (case y of
-                                                  UU => UU
-                                                | Def b => Def (a,b)##(h$xs$ys))))))"
-
-Filter2_def:    "Filter2 P == (fix$(LAM h t. case t of
-            nil => nil
-          | x##xs => (case x of UU => UU | Def y => (if P y
-                     then x##(h$xs)
-                     else     h$xs))))"
-
-declare andalso_and [simp]
-declare andalso_or [simp]
-
-subsection "recursive equations of operators"
-
-subsubsection "Map"
-
-lemma Map_UU: "Map f$UU =UU"
-by (simp add: Map_def)
-
-lemma Map_nil: "Map f$nil =nil"
-by (simp add: Map_def)
-
-lemma Map_cons: "Map f$(x>>xs)=(f x) >> Map f$xs"
-by (simp add: Map_def Consq_def flift2_def)
-
-
-subsubsection {* Filter *}
-
-lemma Filter_UU: "Filter P$UU =UU"
-by (simp add: Filter_def)
-
-lemma Filter_nil: "Filter P$nil =nil"
-by (simp add: Filter_def)
-
-lemma Filter_cons:
-  "Filter P$(x>>xs)= (if P x then x>>(Filter P$xs) else Filter P$xs)"
-by (simp add: Filter_def Consq_def flift2_def If_and_if)
-
-
-subsubsection {* Forall *}
-
-lemma Forall_UU: "Forall P UU"
-by (simp add: Forall_def sforall_def)
-
-lemma Forall_nil: "Forall P nil"
-by (simp add: Forall_def sforall_def)
-
-lemma Forall_cons: "Forall P (x>>xs)= (P x & Forall P xs)"
-by (simp add: Forall_def sforall_def Consq_def flift2_def)
-
-
-subsubsection {* Conc *}
-
-lemma Conc_cons: "(x>>xs) @@ y = x>>(xs @@y)"
-by (simp add: Consq_def)
-
-
-subsubsection {* Takewhile *}
-
-lemma Takewhile_UU: "Takewhile P$UU =UU"
-by (simp add: Takewhile_def)
-
-lemma Takewhile_nil: "Takewhile P$nil =nil"
-by (simp add: Takewhile_def)
-
-lemma Takewhile_cons:
-  "Takewhile P$(x>>xs)= (if P x then x>>(Takewhile P$xs) else nil)"
-by (simp add: Takewhile_def Consq_def flift2_def If_and_if)
-
-
-subsubsection {* DropWhile *}
-
-lemma Dropwhile_UU: "Dropwhile P$UU =UU"
-by (simp add: Dropwhile_def)
-
-lemma Dropwhile_nil: "Dropwhile P$nil =nil"
-by (simp add: Dropwhile_def)
-
-lemma Dropwhile_cons:
-  "Dropwhile P$(x>>xs)= (if P x then Dropwhile P$xs else x>>xs)"
-by (simp add: Dropwhile_def Consq_def flift2_def If_and_if)
-
-
-subsubsection {* Last *}
-
-lemma Last_UU: "Last$UU =UU"
-by (simp add: Last_def)
-
-lemma Last_nil: "Last$nil =UU"
-by (simp add: Last_def)
-
-lemma Last_cons: "Last$(x>>xs)= (if xs=nil then Def x else Last$xs)"
-apply (simp add: Last_def Consq_def)
-apply (cases xs)
-apply simp_all
-done
-
-
-subsubsection {* Flat *}
-
-lemma Flat_UU: "Flat$UU =UU"
-by (simp add: Flat_def)
-
-lemma Flat_nil: "Flat$nil =nil"
-by (simp add: Flat_def)
-
-lemma Flat_cons: "Flat$(x##xs)= x @@ (Flat$xs)"
-by (simp add: Flat_def Consq_def)
-
-
-subsubsection {* Zip *}
-
-lemma Zip_unfold:
-"Zip = (LAM t1 t2. case t1 of
-                nil   => nil
-              | x##xs => (case t2 of
-                           nil => UU
-                         | y##ys => (case x of
-                                       UU  => UU
-                                     | Def a => (case y of
-                                                   UU => UU
-                                                 | Def b => Def (a,b)##(Zip$xs$ys)))))"
-apply (rule trans)
-apply (rule fix_eq2)
-apply (rule Zip_def)
-apply (rule beta_cfun)
-apply simp
-done
-
-lemma Zip_UU1: "Zip$UU$y =UU"
-apply (subst Zip_unfold)
-apply simp
-done
-
-lemma Zip_UU2: "x~=nil ==> Zip$x$UU =UU"
-apply (subst Zip_unfold)
-apply simp
-apply (cases x)
-apply simp_all
-done
-
-lemma Zip_nil: "Zip$nil$y =nil"
-apply (subst Zip_unfold)
-apply simp
-done
-
-lemma Zip_cons_nil: "Zip$(x>>xs)$nil= UU"
-apply (subst Zip_unfold)
-apply (simp add: Consq_def)
-done
-
-lemma Zip_cons: "Zip$(x>>xs)$(y>>ys)= (x,y) >> Zip$xs$ys"
-apply (rule trans)
-apply (subst Zip_unfold)
-apply simp
-apply (simp add: Consq_def)
-done
-
-lemmas [simp del] =
-  sfilter_UU sfilter_nil sfilter_cons
-  smap_UU smap_nil smap_cons
-  sforall2_UU sforall2_nil sforall2_cons
-  slast_UU slast_nil slast_cons
-  stakewhile_UU  stakewhile_nil  stakewhile_cons
-  sdropwhile_UU  sdropwhile_nil  sdropwhile_cons
-  sflat_UU sflat_nil sflat_cons
-  szip_UU1 szip_UU2 szip_nil szip_cons_nil szip_cons
-
-lemmas [simp] =
-  Filter_UU Filter_nil Filter_cons
-  Map_UU Map_nil Map_cons
-  Forall_UU Forall_nil Forall_cons
-  Last_UU Last_nil Last_cons
-  Conc_cons
-  Takewhile_UU Takewhile_nil Takewhile_cons
-  Dropwhile_UU Dropwhile_nil Dropwhile_cons
-  Zip_UU1 Zip_UU2 Zip_nil Zip_cons_nil Zip_cons
-
-
-
-section "Cons"
-
-lemma Consq_def2: "a>>s = (Def a)##s"
-apply (simp add: Consq_def)
-done
-
-lemma Seq_exhaust: "x = UU | x = nil | (? a s. x = a >> s)"
-apply (simp add: Consq_def2)
-apply (cut_tac seq.nchotomy)
-apply (fast dest: not_Undef_is_Def [THEN iffD1])
-done
-
-
-lemma Seq_cases:
-"!!P. [| x = UU ==> P; x = nil ==> P; !!a s. x = a >> s  ==> P |] ==> P"
-apply (cut_tac x="x" in Seq_exhaust)
-apply (erule disjE)
-apply simp
-apply (erule disjE)
-apply simp
-apply (erule exE)+
-apply simp
-done
-
-(*
-fun Seq_case_tac s i = rule_tac x",s)] Seq_cases i
-          THEN hyp_subst_tac i THEN hyp_subst_tac (i+1) THEN hyp_subst_tac (i+2);
-*)
-(* on a>>s only simp_tac, as full_simp_tac is uncomplete and often causes errors *)
-(*
-fun Seq_case_simp_tac s i = Seq_case_tac s i THEN Asm_simp_tac (i+2)
-                                             THEN Asm_full_simp_tac (i+1)
-                                             THEN Asm_full_simp_tac i;
-*)
-
-lemma Cons_not_UU: "a>>s ~= UU"
-apply (subst Consq_def2)
-apply simp
-done
-
-
-lemma Cons_not_less_UU: "~(a>>x) << UU"
-apply (rule notI)
-apply (drule below_antisym)
-apply simp
-apply (simp add: Cons_not_UU)
-done
-
-lemma Cons_not_less_nil: "~a>>s << nil"
-apply (simp add: Consq_def2)
-done
-
-lemma Cons_not_nil: "a>>s ~= nil"
-apply (simp add: Consq_def2)
-done
-
-lemma Cons_not_nil2: "nil ~= a>>s"
-apply (simp add: Consq_def2)
-done
-
-lemma Cons_inject_eq: "(a>>s = b>>t) = (a = b & s = t)"
-apply (simp only: Consq_def2)
-apply (simp add: scons_inject_eq)
-done
-
-lemma Cons_inject_less_eq: "(a>>s<<b>>t) = (a = b & s<<t)"
-apply (simp add: Consq_def2)
-done
-
-lemma seq_take_Cons: "seq_take (Suc n)$(a>>x) = a>> (seq_take n$x)"
-apply (simp add: Consq_def)
-done
-
-lemmas [simp] =
-  Cons_not_nil2 Cons_inject_eq Cons_inject_less_eq seq_take_Cons
-  Cons_not_UU Cons_not_less_UU Cons_not_less_nil Cons_not_nil
-
-
-subsection "induction"
-
-lemma Seq_induct:
-"!! P. [| adm P; P UU; P nil; !! a s. P s ==> P (a>>s)|] ==> P x"
-apply (erule (2) seq.induct)
-apply defined
-apply (simp add: Consq_def)
-done
-
-lemma Seq_FinitePartial_ind:
-"!! P.[|P UU;P nil; !! a s. P s ==> P(a>>s) |]
-                ==> seq_finite x --> P x"
-apply (erule (1) seq_finite_ind)
-apply defined
-apply (simp add: Consq_def)
-done
-
-lemma Seq_Finite_ind:
-"!! P.[| Finite x; P nil; !! a s. [| Finite s; P s|] ==> P (a>>s) |] ==> P x"
-apply (erule (1) Finite.induct)
-apply defined
-apply (simp add: Consq_def)
-done
-
-
-(* rws are definitions to be unfolded for admissibility check *)
-(*
-fun Seq_induct_tac s rws i = rule_tac x",s)] Seq_induct i
-                         THEN (REPEAT_DETERM (CHANGED (Asm_simp_tac (i+1))))
-                         THEN simp add: rws) i;
-
-fun Seq_Finite_induct_tac i = erule Seq_Finite_ind i
-                              THEN (REPEAT_DETERM (CHANGED (Asm_simp_tac i)));
-
-fun pair_tac s = rule_tac p",s)] PairE
-                          THEN' hyp_subst_tac THEN' Simp_tac;
-*)
-(* induction on a sequence of pairs with pairsplitting and simplification *)
-(*
-fun pair_induct_tac s rws i =
-           rule_tac x",s)] Seq_induct i
-           THEN pair_tac "a" (i+3)
-           THEN (REPEAT_DETERM (CHANGED (Simp_tac (i+1))))
-           THEN simp add: rws) i;
-*)
-
-
-(* ------------------------------------------------------------------------------------ *)
-
-subsection "HD,TL"
-
-lemma HD_Cons [simp]: "HD$(x>>y) = Def x"
-apply (simp add: Consq_def)
-done
-
-lemma TL_Cons [simp]: "TL$(x>>y) = y"
-apply (simp add: Consq_def)
-done
-
-(* ------------------------------------------------------------------------------------ *)
-
-subsection "Finite, Partial, Infinite"
-
-lemma Finite_Cons [simp]: "Finite (a>>xs) = Finite xs"
-apply (simp add: Consq_def2 Finite_cons)
-done
-
-lemma FiniteConc_1: "Finite (x::'a Seq) ==> Finite y --> Finite (x@@y)"
-apply (erule Seq_Finite_ind, simp_all)
-done
-
-lemma FiniteConc_2:
-"Finite (z::'a Seq) ==> !x y. z= x@@y --> (Finite x & Finite y)"
-apply (erule Seq_Finite_ind)
-(* nil*)
-apply (intro strip)
-apply (rule_tac x="x" in Seq_cases, simp_all)
-(* cons *)
-apply (intro strip)
-apply (rule_tac x="x" in Seq_cases, simp_all)
-apply (rule_tac x="y" in Seq_cases, simp_all)
-done
-
-lemma FiniteConc [simp]: "Finite(x@@y) = (Finite (x::'a Seq) & Finite y)"
-apply (rule iffI)
-apply (erule FiniteConc_2 [rule_format])
-apply (rule refl)
-apply (rule FiniteConc_1 [rule_format])
-apply auto
-done
-
-
-lemma FiniteMap1: "Finite s ==> Finite (Map f$s)"
-apply (erule Seq_Finite_ind, simp_all)
-done
-
-lemma FiniteMap2: "Finite s ==> ! t. (s = Map f$t) --> Finite t"
-apply (erule Seq_Finite_ind)
-apply (intro strip)
-apply (rule_tac x="t" in Seq_cases, simp_all)
-(* main case *)
-apply auto
-apply (rule_tac x="t" in Seq_cases, simp_all)
-done
-
-lemma Map2Finite: "Finite (Map f$s) = Finite s"
-apply auto
-apply (erule FiniteMap2 [rule_format])
-apply (rule refl)
-apply (erule FiniteMap1)
-done
-
-
-lemma FiniteFilter: "Finite s ==> Finite (Filter P$s)"
-apply (erule Seq_Finite_ind, simp_all)
-done
-
-
-(* ----------------------------------------------------------------------------------- *)
-
-subsection "Conc"
-
-lemma Conc_cong: "!! x::'a Seq. Finite x ==> ((x @@ y) = (x @@ z)) = (y = z)"
-apply (erule Seq_Finite_ind, simp_all)
-done
-
-lemma Conc_assoc: "(x @@ y) @@ z = (x::'a Seq) @@ y @@ z"
-apply (rule_tac x="x" in Seq_induct, simp_all)
-done
-
-lemma nilConc [simp]: "s@@ nil = s"
-apply (induct s)
-apply simp
-apply simp
-apply simp
-apply simp
-done
-
-
-(* should be same as nil_is_Conc2 when all nils are turned to right side !! *)
-lemma nil_is_Conc: "(nil = x @@ y) = ((x::'a Seq)= nil & y = nil)"
-apply (rule_tac x="x" in Seq_cases)
-apply auto
-done
-
-lemma nil_is_Conc2: "(x @@ y = nil) = ((x::'a Seq)= nil & y = nil)"
-apply (rule_tac x="x" in Seq_cases)
-apply auto
-done
-
-
-(* ------------------------------------------------------------------------------------ *)
-
-subsection "Last"
-
-lemma Finite_Last1: "Finite s ==> s~=nil --> Last$s~=UU"
-apply (erule Seq_Finite_ind, simp_all)
-done
-
-lemma Finite_Last2: "Finite s ==> Last$s=UU --> s=nil"
-apply (erule Seq_Finite_ind, simp_all)
-apply fast
-done
-
-
-(* ------------------------------------------------------------------------------------ *)
-
-
-subsection "Filter, Conc"
-
-
-lemma FilterPQ: "Filter P$(Filter Q$s) = Filter (%x. P x & Q x)$s"
-apply (rule_tac x="s" in Seq_induct, simp_all)
-done
-
-lemma FilterConc: "Filter P$(x @@ y) = (Filter P$x @@ Filter P$y)"
-apply (simp add: Filter_def sfiltersconc)
-done
-
-(* ------------------------------------------------------------------------------------ *)
-
-subsection "Map"
-
-lemma MapMap: "Map f$(Map g$s) = Map (f o g)$s"
-apply (rule_tac x="s" in Seq_induct, simp_all)
-done
-
-lemma MapConc: "Map f$(x@@y) = (Map f$x) @@ (Map f$y)"
-apply (rule_tac x="x" in Seq_induct, simp_all)
-done
-
-lemma MapFilter: "Filter P$(Map f$x) = Map f$(Filter (P o f)$x)"
-apply (rule_tac x="x" in Seq_induct, simp_all)
-done
-
-lemma nilMap: "nil = (Map f$s) --> s= nil"
-apply (rule_tac x="s" in Seq_cases, simp_all)
-done
-
-
-lemma ForallMap: "Forall P (Map f$s) = Forall (P o f) s"
-apply (rule_tac x="s" in Seq_induct)
-apply (simp add: Forall_def sforall_def)
-apply simp_all
-done
-
-
-
-
-(* ------------------------------------------------------------------------------------ *)
-
-subsection "Forall"
-
-
-lemma ForallPForallQ1: "Forall P ys & (! x. P x --> Q x)
-         --> Forall Q ys"
-apply (rule_tac x="ys" in Seq_induct)
-apply (simp add: Forall_def sforall_def)
-apply simp_all
-done
-
-lemmas ForallPForallQ =
-  ForallPForallQ1 [THEN mp, OF conjI, OF _ allI, OF _ impI]
-
-lemma Forall_Conc_impl: "(Forall P x & Forall P y) --> Forall P (x @@ y)"
-apply (rule_tac x="x" in Seq_induct)
-apply (simp add: Forall_def sforall_def)
-apply simp_all
-done
-
-lemma Forall_Conc [simp]:
-  "Finite x ==> Forall P (x @@ y) = (Forall P x & Forall P y)"
-apply (erule Seq_Finite_ind, simp_all)
-done
-
-lemma ForallTL1: "Forall P s  --> Forall P (TL$s)"
-apply (rule_tac x="s" in Seq_induct)
-apply (simp add: Forall_def sforall_def)
-apply simp_all
-done
-
-lemmas ForallTL = ForallTL1 [THEN mp]
-
-lemma ForallDropwhile1: "Forall P s  --> Forall P (Dropwhile Q$s)"
-apply (rule_tac x="s" in Seq_induct)
-apply (simp add: Forall_def sforall_def)
-apply simp_all
-done
-
-lemmas ForallDropwhile = ForallDropwhile1 [THEN mp]
-
-
-(* only admissible in t, not if done in s *)
-
-lemma Forall_prefix: "! s. Forall P s --> t<<s --> Forall P t"
-apply (rule_tac x="t" in Seq_induct)
-apply (simp add: Forall_def sforall_def)
-apply simp_all
-apply (intro strip)
-apply (rule_tac x="sa" in Seq_cases)
-apply simp
-apply auto
-done
-
-lemmas Forall_prefixclosed = Forall_prefix [rule_format]
-
-lemma Forall_postfixclosed:
-  "[| Finite h; Forall P s; s= h @@ t |] ==> Forall P t"
-apply auto
-done
-
-
-lemma ForallPFilterQR1:
-  "((! x. P x --> (Q x = R x)) & Forall P tr) --> Filter Q$tr = Filter R$tr"
-apply (rule_tac x="tr" in Seq_induct)
-apply (simp add: Forall_def sforall_def)
-apply simp_all
-done
-
-lemmas ForallPFilterQR = ForallPFilterQR1 [THEN mp, OF conjI, OF allI]
-
-
-(* ------------------------------------------------------------------------------------- *)
-
-subsection "Forall, Filter"
-
-
-lemma ForallPFilterP: "Forall P (Filter P$x)"
-apply (simp add: Filter_def Forall_def forallPsfilterP)
-done
-
-(* holds also in other direction, then equal to forallPfilterP *)
-lemma ForallPFilterPid1: "Forall P x --> Filter P$x = x"
-apply (rule_tac x="x" in Seq_induct)
-apply (simp add: Forall_def sforall_def Filter_def)
-apply simp_all
-done
-
-lemmas ForallPFilterPid = ForallPFilterPid1 [THEN mp]
-
-
-(* holds also in other direction *)
-lemma ForallnPFilterPnil1: "!! ys . Finite ys ==>
-   Forall (%x. ~P x) ys --> Filter P$ys = nil "
-apply (erule Seq_Finite_ind, simp_all)
-done
-
-lemmas ForallnPFilterPnil = ForallnPFilterPnil1 [THEN mp]
-
-
-(* holds also in other direction *)
-lemma ForallnPFilterPUU1: "~Finite ys & Forall (%x. ~P x) ys
-                  --> Filter P$ys = UU "
-apply (rule_tac x="ys" in Seq_induct)
-apply (simp add: Forall_def sforall_def)
-apply simp_all
-done
-
-lemmas ForallnPFilterPUU = ForallnPFilterPUU1 [THEN mp, OF conjI]
-
-
-(* inverse of ForallnPFilterPnil *)
-
-lemma FilternPnilForallP1: "!! ys . Filter P$ys = nil -->
-   (Forall (%x. ~P x) ys & Finite ys)"
-apply (rule_tac x="ys" in Seq_induct)
-(* adm *)
-apply (simp add: Forall_def sforall_def)
-(* base cases *)
-apply simp
-apply simp
-(* main case *)
-apply simp
-done
-
-lemmas FilternPnilForallP = FilternPnilForallP1 [THEN mp]
-
-(* inverse of ForallnPFilterPUU. proved apply 2 lemmas because of adm problems *)
-
-lemma FilterUU_nFinite_lemma1: "Finite ys ==> Filter P$ys ~= UU"
-apply (erule Seq_Finite_ind, simp_all)
-done
-
-lemma FilterUU_nFinite_lemma2: "~ Forall (%x. ~P x) ys --> Filter P$ys ~= UU"
-apply (rule_tac x="ys" in Seq_induct)
-apply (simp add: Forall_def sforall_def)
-apply simp_all
-done
-
-lemma FilternPUUForallP:
-  "Filter P$ys = UU ==> (Forall (%x. ~P x) ys  & ~Finite ys)"
-apply (rule conjI)
-apply (cut_tac FilterUU_nFinite_lemma2 [THEN mp, COMP rev_contrapos])
-apply auto
-apply (blast dest!: FilterUU_nFinite_lemma1)
-done
-
-
-lemma ForallQFilterPnil:
-  "!! Q P.[| Forall Q ys; Finite ys; !!x. Q x ==> ~P x|]
-    ==> Filter P$ys = nil"
-apply (erule ForallnPFilterPnil)
-apply (erule ForallPForallQ)
-apply auto
-done
-
-lemma ForallQFilterPUU:
- "!! Q P. [| ~Finite ys; Forall Q ys;  !!x. Q x ==> ~P x|]
-    ==> Filter P$ys = UU "
-apply (erule ForallnPFilterPUU)
-apply (erule ForallPForallQ)
-apply auto
-done
-
-
-
-(* ------------------------------------------------------------------------------------- *)
-
-subsection "Takewhile, Forall, Filter"
-
-
-lemma ForallPTakewhileP [simp]: "Forall P (Takewhile P$x)"
-apply (simp add: Forall_def Takewhile_def sforallPstakewhileP)
-done
-
-
-lemma ForallPTakewhileQ [simp]:
-"!! P. [| !!x. Q x==> P x |] ==> Forall P (Takewhile Q$x)"
-apply (rule ForallPForallQ)
-apply (rule ForallPTakewhileP)
-apply auto
-done
-
-
-lemma FilterPTakewhileQnil [simp]:
-  "!! Q P.[| Finite (Takewhile Q$ys); !!x. Q x ==> ~P x |]
-   ==> Filter P$(Takewhile Q$ys) = nil"
-apply (erule ForallnPFilterPnil)
-apply (rule ForallPForallQ)
-apply (rule ForallPTakewhileP)
-apply auto
-done
-
-lemma FilterPTakewhileQid [simp]:
- "!! Q P. [| !!x. Q x ==> P x |] ==>
-            Filter P$(Takewhile Q$ys) = (Takewhile Q$ys)"
-apply (rule ForallPFilterPid)
-apply (rule ForallPForallQ)
-apply (rule ForallPTakewhileP)
-apply auto
-done
-
-
-lemma Takewhile_idempotent: "Takewhile P$(Takewhile P$s) = Takewhile P$s"
-apply (rule_tac x="s" in Seq_induct)
-apply (simp add: Forall_def sforall_def)
-apply simp_all
-done
-
-lemma ForallPTakewhileQnP [simp]:
- "Forall P s --> Takewhile (%x. Q x | (~P x))$s = Takewhile Q$s"
-apply (rule_tac x="s" in Seq_induct)
-apply (simp add: Forall_def sforall_def)
-apply simp_all
-done
-
-lemma ForallPDropwhileQnP [simp]:
- "Forall P s --> Dropwhile (%x. Q x | (~P x))$s = Dropwhile Q$s"
-apply (rule_tac x="s" in Seq_induct)
-apply (simp add: Forall_def sforall_def)
-apply simp_all
-done
-
-
-lemma TakewhileConc1:
- "Forall P s --> Takewhile P$(s @@ t) = s @@ (Takewhile P$t)"
-apply (rule_tac x="s" in Seq_induct)
-apply (simp add: Forall_def sforall_def)
-apply simp_all
-done
-
-lemmas TakewhileConc = TakewhileConc1 [THEN mp]
-
-lemma DropwhileConc1:
- "Finite s ==> Forall P s --> Dropwhile P$(s @@ t) = Dropwhile P$t"
-apply (erule Seq_Finite_ind, simp_all)
-done
-
-lemmas DropwhileConc = DropwhileConc1 [THEN mp]
-
-
-
-(* ----------------------------------------------------------------------------------- *)
-
-subsection "coinductive characterizations of Filter"
-
-
-lemma divide_Seq_lemma:
- "HD$(Filter P$y) = Def x
-    --> y = ((Takewhile (%x. ~P x)$y) @@ (x >> TL$(Dropwhile (%a.~P a)$y))) 
-             & Finite (Takewhile (%x. ~ P x)$y)  & P x"
-
-(* FIX: pay attention: is only admissible with chain-finite package to be added to
-        adm test and Finite f x admissibility *)
-apply (rule_tac x="y" in Seq_induct)
-apply (simp add: adm_subst [OF _ adm_Finite])
-apply simp
-apply simp
-apply (case_tac "P a")
- apply simp
- apply blast
-(* ~ P a *)
-apply simp
-done
-
-lemma divide_Seq: "(x>>xs) << Filter P$y 
-   ==> y = ((Takewhile (%a. ~ P a)$y) @@ (x >> TL$(Dropwhile (%a.~P a)$y)))
-      & Finite (Takewhile (%a. ~ P a)$y)  & P x"
-apply (rule divide_Seq_lemma [THEN mp])
-apply (drule_tac f="HD" and x="x>>xs" in  monofun_cfun_arg)
-apply simp
-done
-
-
-lemma nForall_HDFilter:
- "~Forall P y --> (? x. HD$(Filter (%a. ~P a)$y) = Def x)"
-unfolding not_Undef_is_Def [symmetric]
-apply (induct y rule: Seq_induct)
-apply (simp add: Forall_def sforall_def)
-apply simp_all
-done
-
-
-lemma divide_Seq2: "~Forall P y
-  ==> ? x. y= (Takewhile P$y @@ (x >> TL$(Dropwhile P$y))) &
-      Finite (Takewhile P$y) & (~ P x)"
-apply (drule nForall_HDFilter [THEN mp])
-apply safe
-apply (rule_tac x="x" in exI)
-apply (cut_tac P1="%x. ~ P x" in divide_Seq_lemma [THEN mp])
-apply auto
-done
-
-
-lemma divide_Seq3: "~Forall P y
-  ==> ? x bs rs. y= (bs @@ (x>>rs)) & Finite bs & Forall P bs & (~ P x)"
-apply (drule divide_Seq2)
-(*Auto_tac no longer proves it*)
-apply fastsimp
-done
-
-lemmas [simp] = FilterPQ FilterConc Conc_cong
-
-
-(* ------------------------------------------------------------------------------------- *)
-
-
-subsection "take_lemma"
-
-lemma seq_take_lemma: "(!n. seq_take n$x = seq_take n$x') = (x = x')"
-apply (rule iffI)
-apply (rule seq.take_lemma)
-apply auto
-done
-
-lemma take_reduction1:
-"  ! n. ((! k. k < n --> seq_take k$y1 = seq_take k$y2)
-    --> seq_take n$(x @@ (t>>y1)) =  seq_take n$(x @@ (t>>y2)))"
-apply (rule_tac x="x" in Seq_induct)
-apply simp_all
-apply (intro strip)
-apply (case_tac "n")
-apply auto
-apply (case_tac "n")
-apply auto
-done
-
-
-lemma take_reduction:
- "!! n.[| x=y; s=t; !! k. k<n ==> seq_take k$y1 = seq_take k$y2|]
-  ==> seq_take n$(x @@ (s>>y1)) =  seq_take n$(y @@ (t>>y2))"
-apply (auto intro!: take_reduction1 [rule_format])
-done
-
-(* ------------------------------------------------------------------
-          take-lemma and take_reduction for << instead of =
-   ------------------------------------------------------------------ *)
-
-lemma take_reduction_less1:
-"  ! n. ((! k. k < n --> seq_take k$y1 << seq_take k$y2)
-    --> seq_take n$(x @@ (t>>y1)) <<  seq_take n$(x @@ (t>>y2)))"
-apply (rule_tac x="x" in Seq_induct)
-apply simp_all
-apply (intro strip)
-apply (case_tac "n")
-apply auto
-apply (case_tac "n")
-apply auto
-done
-
-
-lemma take_reduction_less:
- "!! n.[| x=y; s=t;!! k. k<n ==> seq_take k$y1 << seq_take k$y2|]
-  ==> seq_take n$(x @@ (s>>y1)) <<  seq_take n$(y @@ (t>>y2))"
-apply (auto intro!: take_reduction_less1 [rule_format])
-done
-
-lemma take_lemma_less1:
-  assumes "!! n. seq_take n$s1 << seq_take n$s2"
-  shows "s1<<s2"
-apply (rule_tac t="s1" in seq.reach [THEN subst])
-apply (rule_tac t="s2" in seq.reach [THEN subst])
-apply (rule lub_mono)
-apply (rule seq.chain_take [THEN ch2ch_Rep_cfunL])
-apply (rule seq.chain_take [THEN ch2ch_Rep_cfunL])
-apply (rule assms)
-done
-
-
-lemma take_lemma_less: "(!n. seq_take n$x << seq_take n$x') = (x << x')"
-apply (rule iffI)
-apply (rule take_lemma_less1)
-apply auto
-apply (erule monofun_cfun_arg)
-done
-
-(* ------------------------------------------------------------------
-          take-lemma proof principles
-   ------------------------------------------------------------------ *)
-
-lemma take_lemma_principle1:
- "!! Q. [|!! s. [| Forall Q s; A s |] ==> (f s) = (g s) ;
-            !! s1 s2 y. [| Forall Q s1; Finite s1; ~ Q y; A (s1 @@ y>>s2)|]
-                          ==> (f (s1 @@ y>>s2)) = (g (s1 @@ y>>s2)) |]
-               ==> A x --> (f x)=(g x)"
-apply (case_tac "Forall Q x")
-apply (auto dest!: divide_Seq3)
-done
-
-lemma take_lemma_principle2:
-  "!! Q. [|!! s. [| Forall Q s; A s |] ==> (f s) = (g s) ;
-           !! s1 s2 y. [| Forall Q s1; Finite s1; ~ Q y; A (s1 @@ y>>s2)|]
-                          ==> ! n. seq_take n$(f (s1 @@ y>>s2))
-                                 = seq_take n$(g (s1 @@ y>>s2)) |]
-               ==> A x --> (f x)=(g x)"
-apply (case_tac "Forall Q x")
-apply (auto dest!: divide_Seq3)
-apply (rule seq.take_lemma)
-apply auto
-done
-
-
-(* Note: in the following proofs the ordering of proof steps is very
-         important, as otherwise either (Forall Q s1) would be in the IH as
-         assumption (then rule useless) or it is not possible to strengthen
-         the IH apply doing a forall closure of the sequence t (then rule also useless).
-         This is also the reason why the induction rule (nat_less_induct or nat_induct) has to
-         to be imbuilt into the rule, as induction has to be done early and the take lemma
-         has to be used in the trivial direction afterwards for the (Forall Q x) case.  *)
-
-lemma take_lemma_induct:
-"!! Q. [|!! s. [| Forall Q s; A s |] ==> (f s) = (g s) ;
-         !! s1 s2 y n. [| ! t. A t --> seq_take n$(f t) = seq_take n$(g t);
-                          Forall Q s1; Finite s1; ~ Q y; A (s1 @@ y>>s2) |]
-                          ==>   seq_take (Suc n)$(f (s1 @@ y>>s2))
-                              = seq_take (Suc n)$(g (s1 @@ y>>s2)) |]
-               ==> A x --> (f x)=(g x)"
-apply (rule impI)
-apply (rule seq.take_lemma)
-apply (rule mp)
-prefer 2 apply assumption
-apply (rule_tac x="x" in spec)
-apply (rule nat.induct)
-apply simp
-apply (rule allI)
-apply (case_tac "Forall Q xa")
-apply (force intro!: seq_take_lemma [THEN iffD2, THEN spec])
-apply (auto dest!: divide_Seq3)
-done
-
-
-lemma take_lemma_less_induct:
-"!! Q. [|!! s. [| Forall Q s; A s |] ==> (f s) = (g s) ;
-        !! s1 s2 y n. [| ! t m. m < n --> A t --> seq_take m$(f t) = seq_take m$(g t);
-                          Forall Q s1; Finite s1; ~ Q y; A (s1 @@ y>>s2) |]
-                          ==>   seq_take n$(f (s1 @@ y>>s2))
-                              = seq_take n$(g (s1 @@ y>>s2)) |]
-               ==> A x --> (f x)=(g x)"
-apply (rule impI)
-apply (rule seq.take_lemma)
-apply (rule mp)
-prefer 2 apply assumption
-apply (rule_tac x="x" in spec)
-apply (rule nat_less_induct)
-apply (rule allI)
-apply (case_tac "Forall Q xa")
-apply (force intro!: seq_take_lemma [THEN iffD2, THEN spec])
-apply (auto dest!: divide_Seq3)
-done
-
-
-
-lemma take_lemma_in_eq_out:
-"!! Q. [| A UU  ==> (f UU) = (g UU) ;
-          A nil ==> (f nil) = (g nil) ;
-          !! s y n. [| ! t. A t --> seq_take n$(f t) = seq_take n$(g t);
-                     A (y>>s) |]
-                     ==>   seq_take (Suc n)$(f (y>>s))
-                         = seq_take (Suc n)$(g (y>>s)) |]
-               ==> A x --> (f x)=(g x)"
-apply (rule impI)
-apply (rule seq.take_lemma)
-apply (rule mp)
-prefer 2 apply assumption
-apply (rule_tac x="x" in spec)
-apply (rule nat.induct)
-apply simp
-apply (rule allI)
-apply (rule_tac x="xa" in Seq_cases)
-apply simp_all
-done
-
-
-(* ------------------------------------------------------------------------------------ *)
-
-subsection "alternative take_lemma proofs"
-
-
-(* --------------------------------------------------------------- *)
-(*              Alternative Proof of FilterPQ                      *)
-(* --------------------------------------------------------------- *)
-
-declare FilterPQ [simp del]
-
-
-(* In general: How to do this case without the same adm problems
-   as for the entire proof ? *)
-lemma Filter_lemma1: "Forall (%x.~(P x & Q x)) s
-          --> Filter P$(Filter Q$s) =
-              Filter (%x. P x & Q x)$s"
-
-apply (rule_tac x="s" in Seq_induct)
-apply (simp add: Forall_def sforall_def)
-apply simp_all
-done
-
-lemma Filter_lemma2: "Finite s ==>
-          (Forall (%x. (~P x) | (~ Q x)) s
-          --> Filter P$(Filter Q$s) = nil)"
-apply (erule Seq_Finite_ind, simp_all)
-done
-
-lemma Filter_lemma3: "Finite s ==>
-          Forall (%x. (~P x) | (~ Q x)) s
-          --> Filter (%x. P x & Q x)$s = nil"
-apply (erule Seq_Finite_ind, simp_all)
-done
-
-
-lemma FilterPQ_takelemma: "Filter P$(Filter Q$s) = Filter (%x. P x & Q x)$s"
-apply (rule_tac A1="%x. True" and
-                 Q1="%x.~(P x & Q x)" and x1="s" in
-                 take_lemma_induct [THEN mp])
-(* better support for A = %x. True *)
-apply (simp add: Filter_lemma1)
-apply (simp add: Filter_lemma2 Filter_lemma3)
-apply simp
-done
-
-declare FilterPQ [simp]
-
-
-(* --------------------------------------------------------------- *)
-(*              Alternative Proof of MapConc                       *)
-(* --------------------------------------------------------------- *)
-
-
-
-lemma MapConc_takelemma: "Map f$(x@@y) = (Map f$x) @@ (Map f$y)"
-apply (rule_tac A1="%x. True" and x1="x" in
-    take_lemma_in_eq_out [THEN mp])
-apply auto
-done
-
-
-ML {*
-
-fun Seq_case_tac ctxt s i =
-  res_inst_tac ctxt [(("x", 0), s)] @{thm Seq_cases} i
-  THEN hyp_subst_tac i THEN hyp_subst_tac (i+1) THEN hyp_subst_tac (i+2);
-
-(* on a>>s only simp_tac, as full_simp_tac is uncomplete and often causes errors *)
-fun Seq_case_simp_tac ctxt s i =
-  let val ss = simpset_of ctxt in
-    Seq_case_tac ctxt s i
-    THEN asm_simp_tac ss (i+2)
-    THEN asm_full_simp_tac ss (i+1)
-    THEN asm_full_simp_tac ss i
-  end;
-
-(* rws are definitions to be unfolded for admissibility check *)
-fun Seq_induct_tac ctxt s rws i =
-  let val ss = simpset_of ctxt in
-    res_inst_tac ctxt [(("x", 0), s)] @{thm Seq_induct} i
-    THEN (REPEAT_DETERM (CHANGED (asm_simp_tac ss (i+1))))
-    THEN simp_tac (ss addsimps rws) i
-  end;
-
-fun Seq_Finite_induct_tac ctxt i =
-  etac @{thm Seq_Finite_ind} i
-  THEN (REPEAT_DETERM (CHANGED (asm_simp_tac (simpset_of ctxt) i)));
-
-fun pair_tac ctxt s =
-  res_inst_tac ctxt [(("p", 0), s)] @{thm PairE}
-  THEN' hyp_subst_tac THEN' asm_full_simp_tac (simpset_of ctxt);
-
-(* induction on a sequence of pairs with pairsplitting and simplification *)
-fun pair_induct_tac ctxt s rws i =
-  let val ss = simpset_of ctxt in
-    res_inst_tac ctxt [(("x", 0), s)] @{thm Seq_induct} i
-    THEN pair_tac ctxt "a" (i+3)
-    THEN (REPEAT_DETERM (CHANGED (simp_tac ss (i+1))))
-    THEN simp_tac (ss addsimps rws) i
-  end;
-
-*}
-
-end

--- a/src/HOLCF/IOA/meta_theory/ShortExecutions.thy	Sat Nov 27 14:34:54 2010 -0800
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,278 +0,0 @@
-(*  Title:      HOLCF/IOA/meta_theory/ShortExecutions.thy
-    Author:     Olaf Müller
-*)
-
-theory ShortExecutions
-imports Traces
-begin
-
-text {*
-  Some properties about @{text "Cut ex"}, defined as follows:
-
-  For every execution ex there is another shorter execution @{text "Cut ex"}
-  that has the same trace as ex, but its schedule ends with an external action.
-*}
-
-definition
-  oraclebuild :: "('a => bool) => 'a Seq -> 'a Seq -> 'a Seq" where
-  "oraclebuild P = (fix$(LAM h s t. case t of
-       nil => nil
-    | x##xs =>
-      (case x of
-        UU => UU
-      | Def y => (Takewhile (%x.~P x)$s)
-                  @@ (y>>(h$(TL$(Dropwhile (%x.~ P x)$s))$xs))
-      )
-    ))"
-
-definition
-  Cut :: "('a => bool) => 'a Seq => 'a Seq" where
-  "Cut P s = oraclebuild P$s$(Filter P$s)"
-
-definition
-  LastActExtsch :: "('a,'s)ioa => 'a Seq => bool" where
-  "LastActExtsch A sch = (Cut (%x. x: ext A) sch = sch)"
-
-(* LastActExtex      ::"('a,'s)ioa => ('a,'s) pairs  => bool"*)
-(* LastActExtex_def:
-  "LastActExtex A ex == LastActExtsch A (filter_act$ex)" *)
-
-axiomatization where
-  Cut_prefixcl_Finite: "Finite s ==> (? y. s = Cut P s @@ y)"
-
-axiomatization where
-  LastActExtsmall1: "LastActExtsch A sch ==> LastActExtsch A (TL$(Dropwhile P$sch))"
-
-axiomatization where
-  LastActExtsmall2: "[| Finite sch1; LastActExtsch A (sch1 @@ sch2) |] ==> LastActExtsch A sch2"
-
-
-ML {*
-fun thin_tac' j =
-  rotate_tac (j - 1) THEN'
-  etac thin_rl THEN'
-  rotate_tac (~ (j - 1))
-*}
-
-
-subsection "oraclebuild rewrite rules"
-
-
-lemma oraclebuild_unfold:
-"oraclebuild P = (LAM s t. case t of
-       nil => nil
-    | x##xs =>
-      (case x of
-        UU => UU
-      | Def y => (Takewhile (%a.~ P a)$s)
-                  @@ (y>>(oraclebuild P$(TL$(Dropwhile (%a.~ P a)$s))$xs))
-      )
-    )"
-apply (rule trans)
-apply (rule fix_eq2)
-apply (simp only: oraclebuild_def)
-apply (rule beta_cfun)
-apply simp
-done
-
-lemma oraclebuild_UU: "oraclebuild P$sch$UU = UU"
-apply (subst oraclebuild_unfold)
-apply simp
-done
-
-lemma oraclebuild_nil: "oraclebuild P$sch$nil = nil"
-apply (subst oraclebuild_unfold)
-apply simp
-done
-
-lemma oraclebuild_cons: "oraclebuild P$s$(x>>t) =
-          (Takewhile (%a.~ P a)$s)
-           @@ (x>>(oraclebuild P$(TL$(Dropwhile (%a.~ P a)$s))$t))"
-apply (rule trans)
-apply (subst oraclebuild_unfold)
-apply (simp add: Consq_def)
-apply (simp add: Consq_def)
-done
-
-
-subsection "Cut rewrite rules"
-
-lemma Cut_nil:
-"[| Forall (%a.~ P a) s; Finite s|]
-            ==> Cut P s =nil"
-apply (unfold Cut_def)
-apply (subgoal_tac "Filter P$s = nil")
-apply (simp (no_asm_simp) add: oraclebuild_nil)
-apply (rule ForallQFilterPnil)
-apply assumption+
-done
-
-lemma Cut_UU:
-"[| Forall (%a.~ P a) s; ~Finite s|]
-            ==> Cut P s =UU"
-apply (unfold Cut_def)
-apply (subgoal_tac "Filter P$s= UU")
-apply (simp (no_asm_simp) add: oraclebuild_UU)
-apply (rule ForallQFilterPUU)
-apply assumption+
-done
-
-lemma Cut_Cons:
-"[| P t;  Forall (%x.~ P x) ss; Finite ss|]
-            ==> Cut P (ss @@ (t>> rs))
-                 = ss @@ (t >> Cut P rs)"
-apply (unfold Cut_def)
-apply (simp add: ForallQFilterPnil oraclebuild_cons TakewhileConc DropwhileConc)
-done
-
-
-subsection "Cut lemmas for main theorem"
-
-lemma FilterCut: "Filter P$s = Filter P$(Cut P s)"
-apply (rule_tac A1 = "%x. True" and Q1 = "%x.~ P x" and x1 = "s" in take_lemma_induct [THEN mp])
-prefer 3 apply (fast)
-apply (case_tac "Finite s")
-apply (simp add: Cut_nil ForallQFilterPnil)
-apply (simp add: Cut_UU ForallQFilterPUU)
-(* main case *)
-apply (simp add: Cut_Cons ForallQFilterPnil)
-done
-
-
-lemma Cut_idemp: "Cut P (Cut P s) = (Cut P s)"
-apply (rule_tac A1 = "%x. True" and Q1 = "%x.~ P x" and x1 = "s" in
-  take_lemma_less_induct [THEN mp])
-prefer 3 apply (fast)
-apply (case_tac "Finite s")
-apply (simp add: Cut_nil ForallQFilterPnil)
-apply (simp add: Cut_UU ForallQFilterPUU)
-(* main case *)
-apply (simp add: Cut_Cons ForallQFilterPnil)
-apply (rule take_reduction)
-apply auto
-done
-
-
-lemma MapCut: "Map f$(Cut (P o f) s) = Cut P (Map f$s)"
-apply (rule_tac A1 = "%x. True" and Q1 = "%x.~ P (f x) " and x1 = "s" in
-  take_lemma_less_induct [THEN mp])
-prefer 3 apply (fast)
-apply (case_tac "Finite s")
-apply (simp add: Cut_nil)
-apply (rule Cut_nil [symmetric])
-apply (simp add: ForallMap o_def)
-apply (simp add: Map2Finite)
-(* csae ~ Finite s *)
-apply (simp add: Cut_UU)
-apply (rule Cut_UU)
-apply (simp add: ForallMap o_def)
-apply (simp add: Map2Finite)
-(* main case *)
-apply (simp add: Cut_Cons MapConc ForallMap FiniteMap1 o_def)
-apply (rule take_reduction)
-apply auto
-done
-
-
-lemma Cut_prefixcl_nFinite [rule_format (no_asm)]: "~Finite s --> Cut P s << s"
-apply (intro strip)
-apply (rule take_lemma_less [THEN iffD1])
-apply (intro strip)
-apply (rule mp)
-prefer 2 apply (assumption)
-apply (tactic "thin_tac' 1 1")
-apply (rule_tac x = "s" in spec)
-apply (rule nat_less_induct)
-apply (intro strip)
-apply (rename_tac na n s)
-apply (case_tac "Forall (%x. ~ P x) s")
-apply (rule take_lemma_less [THEN iffD2, THEN spec])
-apply (simp add: Cut_UU)
-(* main case *)
-apply (drule divide_Seq3)
-apply (erule exE)+
-apply (erule conjE)+
-apply hypsubst
-apply (simp add: Cut_Cons)
-apply (rule take_reduction_less)
-(* auto makes also reasoning about Finiteness of parts of s ! *)
-apply auto
-done
-
-
-lemma execThruCut: "!!ex .is_exec_frag A (s,ex) ==> is_exec_frag A (s,Cut P ex)"
-apply (case_tac "Finite ex")
-apply (cut_tac s = "ex" and P = "P" in Cut_prefixcl_Finite)
-apply assumption
-apply (erule exE)
-apply (rule exec_prefix2closed)
-apply (erule_tac s = "ex" and t = "Cut P ex @@ y" in subst)
-apply assumption
-apply (erule exec_prefixclosed)
-apply (erule Cut_prefixcl_nFinite)
-done
-
-
-subsection "Main Cut Theorem"
-
-lemma exists_LastActExtsch:
- "[|sch : schedules A ; tr = Filter (%a. a:ext A)$sch|]
-    ==> ? sch. sch : schedules A &
-               tr = Filter (%a. a:ext A)$sch &
-               LastActExtsch A sch"
-
-apply (unfold schedules_def has_schedule_def)
-apply auto
-apply (rule_tac x = "filter_act$ (Cut (%a. fst a:ext A) (snd ex))" in exI)
-apply (simp add: executions_def)
-apply (tactic {* pair_tac @{context} "ex" 1 *})
-apply auto
-apply (rule_tac x = " (x,Cut (%a. fst a:ext A) y) " in exI)
-apply (simp (no_asm_simp))
-
-(* Subgoal 1: Lemma:  propagation of execution through Cut *)
-
-apply (simp add: execThruCut)
-
-(* Subgoal 2:  Lemma:  Filter P s = Filter P (Cut P s) *)
-
-apply (simp (no_asm) add: filter_act_def)
-apply (subgoal_tac "Map fst$ (Cut (%a. fst a: ext A) y) = Cut (%a. a:ext A) (Map fst$y) ")
-
-apply (rule_tac [2] MapCut [unfolded o_def])
-apply (simp add: FilterCut [symmetric])
-
-(* Subgoal 3: Lemma: Cut idempotent  *)
-
-apply (simp (no_asm) add: LastActExtsch_def filter_act_def)
-apply (subgoal_tac "Map fst$ (Cut (%a. fst a: ext A) y) = Cut (%a. a:ext A) (Map fst$y) ")
-apply (rule_tac [2] MapCut [unfolded o_def])
-apply (simp add: Cut_idemp)
-done
-
-
-subsection "Further Cut lemmas"
-
-lemma LastActExtimplnil:
-  "[| LastActExtsch A sch; Filter (%x. x:ext A)$sch = nil |]
-    ==> sch=nil"
-apply (unfold LastActExtsch_def)
-apply (drule FilternPnilForallP)
-apply (erule conjE)
-apply (drule Cut_nil)
-apply assumption
-apply simp
-done
-
-lemma LastActExtimplUU:
-  "[| LastActExtsch A sch; Filter (%x. x:ext A)$sch = UU |]
-    ==> sch=UU"
-apply (unfold LastActExtsch_def)
-apply (drule FilternPUUForallP)
-apply (erule conjE)
-apply (drule Cut_UU)
-apply assumption
-apply simp
-done
-
-end

--- a/src/HOLCF/IOA/meta_theory/SimCorrectness.thy	Sat Nov 27 14:34:54 2010 -0800
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,292 +0,0 @@
-(*  Title:      HOLCF/IOA/meta_theory/SimCorrectness.thy
-    Author:     Olaf Müller
-*)
-
-header {* Correctness of Simulations in HOLCF/IOA *}
-
-theory SimCorrectness
-imports Simulations
-begin
-
-definition
-  (* Note: s2 instead of s1 in last argument type !! *)
-  corresp_ex_simC :: "('a,'s2)ioa => (('s1 * 's2)set) => ('a,'s1)pairs
-                   -> ('s2 => ('a,'s2)pairs)" where
-  "corresp_ex_simC A R = (fix$(LAM h ex. (%s. case ex of
-      nil =>  nil
-    | x##xs => (flift1 (%pr. let a = (fst pr); t = (snd pr);
-                                 T' = @t'. ? ex1. (t,t'):R & move A ex1 s a t'
-                             in
-                                (@cex. move A cex s a T')
-                                 @@ ((h$xs) T'))
-                        $x) )))"
-
-definition
-  corresp_ex_sim :: "('a,'s2)ioa => (('s1 *'s2)set) =>
-                      ('a,'s1)execution => ('a,'s2)execution" where
-  "corresp_ex_sim A R ex == let S'= (@s'.(fst ex,s'):R & s': starts_of A)
-                            in
-                               (S',(corresp_ex_simC A R$(snd ex)) S')"
-
-
-subsection "corresp_ex_sim"
-
-lemma corresp_ex_simC_unfold: "corresp_ex_simC A R  = (LAM ex. (%s. case ex of
-       nil =>  nil
-     | x##xs => (flift1 (%pr. let a = (fst pr); t = (snd pr);
-                                  T' = @t'. ? ex1. (t,t'):R & move A ex1 s a t'
-                              in
-                                 (@cex. move A cex s a T')
-                               @@ ((corresp_ex_simC A R $xs) T'))
-                         $x) ))"
-apply (rule trans)
-apply (rule fix_eq2)
-apply (simp only: corresp_ex_simC_def)
-apply (rule beta_cfun)
-apply (simp add: flift1_def)
-done
-
-lemma corresp_ex_simC_UU: "(corresp_ex_simC A R$UU) s=UU"
-apply (subst corresp_ex_simC_unfold)
-apply simp
-done
-
-lemma corresp_ex_simC_nil: "(corresp_ex_simC A R$nil) s = nil"
-apply (subst corresp_ex_simC_unfold)
-apply simp
-done
-
-lemma corresp_ex_simC_cons: "(corresp_ex_simC A R$((a,t)>>xs)) s =
-           (let T' = @t'. ? ex1. (t,t'):R & move A ex1 s a t'
-            in
-             (@cex. move A cex s a T')
-              @@ ((corresp_ex_simC A R$xs) T'))"
-apply (rule trans)
-apply (subst corresp_ex_simC_unfold)
-apply (simp add: Consq_def flift1_def)
-apply simp
-done
-
-
-declare corresp_ex_simC_UU [simp] corresp_ex_simC_nil [simp] corresp_ex_simC_cons [simp]
-
-
-subsection "properties of move"
-
-declare Let_def [simp del]
-
-lemma move_is_move_sim:
-   "[|is_simulation R C A; reachable C s; s -a--C-> t; (s,s'):R|] ==>
-      let T' = @t'. ? ex1. (t,t'):R & move A ex1 s' a t' in
-      (t,T'): R & move A (@ex2. move A ex2 s' a T') s' a T'"
-apply (unfold is_simulation_def)
-
-(* Does not perform conditional rewriting on assumptions automatically as
-   usual. Instantiate all variables per hand. Ask Tobias?? *)
-apply (subgoal_tac "? t' ex. (t,t') :R & move A ex s' a t'")
-prefer 2
-apply simp
-apply (erule conjE)
-apply (erule_tac x = "s" in allE)
-apply (erule_tac x = "s'" in allE)
-apply (erule_tac x = "t" in allE)
-apply (erule_tac x = "a" in allE)
-apply simp
-(* Go on as usual *)
-apply (erule exE)
-apply (drule_tac x = "t'" and P = "%t'. ? ex. (t,t') :R & move A ex s' a t'" in someI)
-apply (erule exE)
-apply (erule conjE)
-apply (simp add: Let_def)
-apply (rule_tac x = "ex" in someI)
-apply (erule conjE)
-apply assumption
-done
-
-declare Let_def [simp]
-
-lemma move_subprop1_sim:
-   "[|is_simulation R C A; reachable C s; s-a--C-> t; (s,s'):R|] ==>
-    let T' = @t'. ? ex1. (t,t'):R & move A ex1 s' a t' in
-     is_exec_frag A (s',@x. move A x s' a T')"
-apply (cut_tac move_is_move_sim)
-defer
-apply assumption+
-apply (simp add: move_def)
-done
-
-lemma move_subprop2_sim:
-   "[|is_simulation R C A; reachable C s; s-a--C-> t; (s,s'):R|] ==>
-    let T' = @t'. ? ex1. (t,t'):R & move A ex1 s' a t' in
-    Finite (@x. move A x s' a T')"
-apply (cut_tac move_is_move_sim)
-defer
-apply assumption+
-apply (simp add: move_def)
-done
-
-lemma move_subprop3_sim:
-   "[|is_simulation R C A; reachable C s; s-a--C-> t; (s,s'):R|] ==>
-    let T' = @t'. ? ex1. (t,t'):R & move A ex1 s' a t' in
-     laststate (s',@x. move A x s' a T') = T'"
-apply (cut_tac move_is_move_sim)
-defer
-apply assumption+
-apply (simp add: move_def)
-done
-
-lemma move_subprop4_sim:
-   "[|is_simulation R C A; reachable C s; s-a--C-> t; (s,s'):R|] ==>
-    let T' = @t'. ? ex1. (t,t'):R & move A ex1 s' a t' in
-      mk_trace A$((@x. move A x s' a T')) =
-        (if a:ext A then a>>nil else nil)"
-apply (cut_tac move_is_move_sim)
-defer
-apply assumption+
-apply (simp add: move_def)
-done
-
-lemma move_subprop5_sim:
-   "[|is_simulation R C A; reachable C s; s-a--C-> t; (s,s'):R|] ==>
-    let T' = @t'. ? ex1. (t,t'):R & move A ex1 s' a t' in
-      (t,T'):R"
-apply (cut_tac move_is_move_sim)
-defer
-apply assumption+
-apply (simp add: move_def)
-done
-
-
-subsection {* TRACE INCLUSION Part 1: Traces coincide *}
-
-subsubsection "Lemmata for <=="
-
-(* ------------------------------------------------------
-                 Lemma 1 :Traces coincide
-   ------------------------------------------------------- *)
-
-declare split_if [split del]
-lemma traces_coincide_sim [rule_format (no_asm)]:
-  "[|is_simulation R C A; ext C = ext A|] ==>
-         !s s'. reachable C s & is_exec_frag C (s,ex) & (s,s'): R -->
-             mk_trace C$ex = mk_trace A$((corresp_ex_simC A R$ex) s')"
-
-apply (tactic {* pair_induct_tac @{context} "ex" [@{thm is_exec_frag_def}] 1 *})
-(* cons case *)
-apply auto
-apply (rename_tac ex a t s s')
-apply (simp add: mk_traceConc)
-apply (frule reachable.reachable_n)
-apply assumption
-apply (erule_tac x = "t" in allE)
-apply (erule_tac x = "@t'. ? ex1. (t,t') :R & move A ex1 s' a t'" in allE)
-apply (simp add: move_subprop5_sim [unfolded Let_def]
-  move_subprop4_sim [unfolded Let_def] split add: split_if)
-done
-declare split_if [split]
-
-
-(* ----------------------------------------------------------- *)
-(*               Lemma 2 : corresp_ex_sim is execution         *)
-(* ----------------------------------------------------------- *)
-
-
-lemma correspsim_is_execution [rule_format (no_asm)]:
- "[| is_simulation R C A |] ==>
-  !s s'. reachable C s & is_exec_frag C (s,ex) & (s,s'):R
-  --> is_exec_frag A (s',(corresp_ex_simC A R$ex) s')"
-
-apply (tactic {* pair_induct_tac @{context} "ex" [@{thm is_exec_frag_def}] 1 *})
-(* main case *)
-apply auto
-apply (rename_tac ex a t s s')
-apply (rule_tac t = "@t'. ? ex1. (t,t') :R & move A ex1 s' a t'" in lemma_2_1)
-
-(* Finite *)
-apply (erule move_subprop2_sim [unfolded Let_def])
-apply assumption+
-apply (rule conjI)
-
-(* is_exec_frag *)
-apply (erule move_subprop1_sim [unfolded Let_def])
-apply assumption+
-apply (rule conjI)
-
-(* Induction hypothesis  *)
-(* reachable_n looping, therefore apply it manually *)
-apply (erule_tac x = "t" in allE)
-apply (erule_tac x = "@t'. ? ex1. (t,t') :R & move A ex1 s' a t'" in allE)
-apply simp
-apply (frule reachable.reachable_n)
-apply assumption
-apply (simp add: move_subprop5_sim [unfolded Let_def])
-(* laststate *)
-apply (erule move_subprop3_sim [unfolded Let_def, symmetric])
-apply assumption+
-done
-
-
-subsection "Main Theorem: TRACE - INCLUSION"
-
-(* -------------------------------------------------------------------------------- *)
-
-  (* generate condition (s,S'):R & S':starts_of A, the first being intereting
-     for the induction cases concerning the two lemmas correpsim_is_execution and
-     traces_coincide_sim, the second for the start state case.
-     S':= @s'. (s,s'):R & s':starts_of A, where s:starts_of C  *)
-
-lemma simulation_starts:
-"[| is_simulation R C A; s:starts_of C |]
-  ==> let S' = @s'. (s,s'):R & s':starts_of A in
-      (s,S'):R & S':starts_of A"
-  apply (simp add: is_simulation_def corresp_ex_sim_def Int_non_empty Image_def)
-  apply (erule conjE)+
-  apply (erule ballE)
-  prefer 2 apply (blast)
-  apply (erule exE)
-  apply (rule someI2)
-  apply assumption
-  apply blast
-  done
-
-lemmas sim_starts1 = simulation_starts [unfolded Let_def, THEN conjunct1, standard]
-lemmas sim_starts2 = simulation_starts [unfolded Let_def, THEN conjunct2, standard]
-
-
-lemma trace_inclusion_for_simulations:
-  "[| ext C = ext A; is_simulation R C A |]
-           ==> traces C <= traces A"
-
-  apply (unfold traces_def)
-
-  apply (simp (no_asm) add: has_trace_def2)
-  apply auto
-
-  (* give execution of abstract automata *)
-  apply (rule_tac x = "corresp_ex_sim A R ex" in bexI)
-
-  (* Traces coincide, Lemma 1 *)
-  apply (tactic {* pair_tac @{context} "ex" 1 *})
-  apply (rename_tac s ex)
-  apply (simp (no_asm) add: corresp_ex_sim_def)
-  apply (rule_tac s = "s" in traces_coincide_sim)
-  apply assumption+
-  apply (simp add: executions_def reachable.reachable_0 sim_starts1)
-
-  (* corresp_ex_sim is execution, Lemma 2 *)
-  apply (tactic {* pair_tac @{context} "ex" 1 *})
-  apply (simp add: executions_def)
-  apply (rename_tac s ex)
-
-  (* start state *)
-  apply (rule conjI)
-  apply (simp add: sim_starts2 corresp_ex_sim_def)
-
-  (* is-execution-fragment *)
-  apply (simp add: corresp_ex_sim_def)
-  apply (rule_tac s = s in correspsim_is_execution)
-  apply assumption
-  apply (simp add: reachable.reachable_0 sim_starts1)
-  done
-
-end

--- a/src/HOLCF/IOA/meta_theory/Simulations.thy	Sat Nov 27 14:34:54 2010 -0800
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,85 +0,0 @@
-(*  Title:      HOLCF/IOA/meta_theory/Simulations.thy
-    Author:     Olaf Müller
-*)
-
-header {* Simulations in HOLCF/IOA *}
-
-theory Simulations
-imports RefCorrectness
-begin
-
-default_sort type
-
-definition
-  is_simulation :: "[('s1 * 's2)set,('a,'s1)ioa,('a,'s2)ioa] => bool" where
-  "is_simulation R C A =
-   ((!s:starts_of C. R``{s} Int starts_of A ~= {}) &
-   (!s s' t a. reachable C s &
-               s -a--C-> t   &
-               (s,s') : R
-               --> (? t' ex. (t,t'):R & move A ex s' a t')))"
-
-definition
-  is_backward_simulation :: "[('s1 * 's2)set,('a,'s1)ioa,('a,'s2)ioa] => bool" where
-  "is_backward_simulation R C A =
-   ((!s:starts_of C. R``{s} <= starts_of A) &
-   (!s t t' a. reachable C s &
-               s -a--C-> t   &
-               (t,t') : R
-               --> (? ex s'. (s,s'):R & move A ex s' a t')))"
-
-definition
-  is_forw_back_simulation :: "[('s1 * 's2 set)set,('a,'s1)ioa,('a,'s2)ioa] => bool" where
-  "is_forw_back_simulation R C A =
-   ((!s:starts_of C. ? S'. (s,S'):R & S'<= starts_of A) &
-   (!s S' t a. reachable C s &
-               s -a--C-> t   &
-               (s,S') : R
-               --> (? T'. (t,T'):R & (! t':T'. ? s':S'. ? ex. move A ex s' a t'))))"
-
-definition
-  is_back_forw_simulation :: "[('s1 * 's2 set)set,('a,'s1)ioa,('a,'s2)ioa] => bool" where
-  "is_back_forw_simulation R C A =
-   ((!s:starts_of C. ! S'. (s,S'):R --> S' Int starts_of A ~={}) &
-   (!s t T' a. reachable C s &
-               s -a--C-> t   &
-               (t,T') : R
-               --> (? S'. (s,S'):R & (! s':S'. ? t':T'. ? ex. move A ex s' a t'))))"
-
-definition
-  is_history_relation :: "[('s1 * 's2)set,('a,'s1)ioa,('a,'s2)ioa] => bool" where
-  "is_history_relation R C A = (is_simulation R C A &
-                                is_ref_map (%x.(@y. (x,y):(R^-1))) A C)"
-
-definition
-  is_prophecy_relation :: "[('s1 * 's2)set,('a,'s1)ioa,('a,'s2)ioa] => bool" where
-  "is_prophecy_relation R C A = (is_backward_simulation R C A &
-                                 is_ref_map (%x.(@y. (x,y):(R^-1))) A C)"
-
-
-lemma set_non_empty: "(A~={}) = (? x. x:A)"
-apply auto
-done
-
-lemma Int_non_empty: "(A Int B ~= {}) = (? x. x: A & x:B)"
-apply (simp add: set_non_empty)
-done
-
-
-lemma Sim_start_convert:
-"(R``{x} Int S ~= {}) = (? y. (x,y):R & y:S)"
-apply (unfold Image_def)
-apply (simp add: Int_non_empty)
-done
-
-declare Sim_start_convert [simp]
-
-
-lemma ref_map_is_simulation:
-"!! f. is_ref_map f C A ==> is_simulation {p. (snd p) = f (fst p)} C A"
-
-apply (unfold is_ref_map_def is_simulation_def)
-apply simp
-done
-
-end

--- a/src/HOLCF/IOA/meta_theory/TL.thy	Sat Nov 27 14:34:54 2010 -0800
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,203 +0,0 @@
-(*  Title:      HOLCF/IOA/meta_theory/TLS.thy
-    Author:     Olaf Müller
-*)
-
-header {* A General Temporal Logic *}
-
-theory TL
-imports Pred Sequence
-begin
-
-default_sort type
-
-types
-  'a temporal = "'a Seq predicate"
-
-
-consts
-suffix     :: "'a Seq => 'a Seq => bool"
-tsuffix    :: "'a Seq => 'a Seq => bool"
-
-validT     :: "'a Seq predicate => bool"
-
-unlift     ::  "'a lift => 'a"
-
-Init         ::"'a predicate => 'a temporal"          ("<_>" [0] 1000)
-
-Box          ::"'a temporal => 'a temporal"   ("[] (_)" [80] 80)
-Diamond      ::"'a temporal => 'a temporal"   ("<> (_)" [80] 80)
-Next         ::"'a temporal => 'a temporal"
-Leadsto      ::"'a temporal => 'a temporal => 'a temporal"  (infixr "~>" 22)
-
-notation (xsymbols)
-  Box  ("\<box> (_)" [80] 80) and
-  Diamond  ("\<diamond> (_)" [80] 80) and
-  Leadsto  (infixr "\<leadsto>" 22)
-
-defs
-
-unlift_def:
-  "unlift x == (case x of Def y   => y)"
-
-(* this means that for nil and UU the effect is unpredictable *)
-Init_def:
-  "Init P s ==  (P (unlift (HD$s)))"
-
-suffix_def:
-  "suffix s2 s == ? s1. (Finite s1  & s = s1 @@ s2)"
-
-tsuffix_def:
-  "tsuffix s2 s == s2 ~= nil & s2 ~= UU & suffix s2 s"
-
-Box_def:
-  "([] P) s == ! s2. tsuffix s2 s --> P s2"
-
-Next_def:
-  "(Next P) s == if (TL$s=UU | TL$s=nil) then (P s) else P (TL$s)"
-
-Diamond_def:
-  "<> P == .~ ([] (.~ P))"
-
-Leadsto_def:
-   "P ~> Q == ([] (P .--> (<> Q)))"
-
-validT_def:
-  "validT P == ! s. s~=UU & s~=nil --> (s |= P)"
-
-
-lemma simple: "[] <> (.~ P) = (.~ <> [] P)"
-apply (rule ext)
-apply (simp add: Diamond_def NOT_def Box_def)
-done
-
-lemma Boxnil: "nil |= [] P"
-apply (simp add: satisfies_def Box_def tsuffix_def suffix_def nil_is_Conc)
-done
-
-lemma Diamondnil: "~(nil |= <> P)"
-apply (simp add: Diamond_def satisfies_def NOT_def)
-apply (cut_tac Boxnil)
-apply (simp add: satisfies_def)
-done
-
-lemma Diamond_def2: "(<> F) s = (? s2. tsuffix s2 s & F s2)"
-apply (simp add: Diamond_def NOT_def Box_def)
-done
-
-
-
-subsection "TLA Axiomatization by Merz"
-
-lemma suffix_refl: "suffix s s"
-apply (simp add: suffix_def)
-apply (rule_tac x = "nil" in exI)
-apply auto
-done
-
-lemma reflT: "s~=UU & s~=nil --> (s |= [] F .--> F)"
-apply (simp add: satisfies_def IMPLIES_def Box_def)
-apply (rule impI)+
-apply (erule_tac x = "s" in allE)
-apply (simp add: tsuffix_def suffix_refl)
-done
-
-
-lemma suffix_trans: "[| suffix y x ; suffix z y |]  ==> suffix z x"
-apply (simp add: suffix_def)
-apply auto
-apply (rule_tac x = "s1 @@ s1a" in exI)
-apply auto
-apply (simp (no_asm) add: Conc_assoc)
-done
-
-lemma transT: "s |= [] F .--> [] [] F"
-apply (simp (no_asm) add: satisfies_def IMPLIES_def Box_def tsuffix_def)
-apply auto
-apply (drule suffix_trans)
-apply assumption
-apply (erule_tac x = "s2a" in allE)
-apply auto
-done
-
-
-lemma normalT: "s |= [] (F .--> G) .--> [] F .--> [] G"
-apply (simp (no_asm) add: satisfies_def IMPLIES_def Box_def)
-done
-
-
-subsection "TLA Rules by Lamport"
-
-lemma STL1a: "validT P ==> validT ([] P)"
-apply (simp add: validT_def satisfies_def Box_def tsuffix_def)
-done
-
-lemma STL1b: "valid P ==> validT (Init P)"
-apply (simp add: valid_def validT_def satisfies_def Init_def)
-done
-
-lemma STL1: "valid P ==> validT ([] (Init P))"
-apply (rule STL1a)
-apply (erule STL1b)
-done
-
-(* Note that unlift and HD is not at all used !!! *)
-lemma STL4: "valid (P .--> Q)  ==> validT ([] (Init P) .--> [] (Init Q))"
-apply (simp add: valid_def validT_def satisfies_def IMPLIES_def Box_def Init_def)
-done
-
-
-subsection "LTL Axioms by Manna/Pnueli"
-
-lemma tsuffix_TL [rule_format (no_asm)]: 
-"s~=UU & s~=nil --> tsuffix s2 (TL$s) --> tsuffix s2 s"
-apply (unfold tsuffix_def suffix_def)
-apply auto
-apply (tactic {* Seq_case_simp_tac @{context} "s" 1 *})
-apply (rule_tac x = "a>>s1" in exI)
-apply auto
-done
-
-lemmas tsuffix_TL2 = conjI [THEN tsuffix_TL]
-
-declare split_if [split del]
-lemma LTL1: 
-   "s~=UU & s~=nil --> (s |= [] F .--> (F .& (Next ([] F))))"
-apply (unfold Next_def satisfies_def NOT_def IMPLIES_def AND_def Box_def)
-apply auto
-(* []F .--> F *)
-apply (erule_tac x = "s" in allE)
-apply (simp add: tsuffix_def suffix_refl)
-(* []F .--> Next [] F *)
-apply (simp split add: split_if)
-apply auto
-apply (drule tsuffix_TL2)
-apply assumption+
-apply auto
-done
-declare split_if [split]
-
-
-lemma LTL2a: 
-    "s |= .~ (Next F) .--> (Next (.~ F))"
-apply (unfold Next_def satisfies_def NOT_def IMPLIES_def)
-apply simp
-done
-
-lemma LTL2b: 
-    "s |= (Next (.~ F)) .--> (.~ (Next F))"
-apply (unfold Next_def satisfies_def NOT_def IMPLIES_def)
-apply simp
-done
-
-lemma LTL3: 
-"ex |= (Next (F .--> G)) .--> (Next F) .--> (Next G)"
-apply (unfold Next_def satisfies_def NOT_def IMPLIES_def)
-apply simp
-done
-
-
-lemma ModusPonens: "[| validT (P .--> Q); validT P |] ==> validT Q"
-apply (simp add: validT_def satisfies_def IMPLIES_def)
-done
-
-end

--- a/src/HOLCF/IOA/meta_theory/TLS.thy	Sat Nov 27 14:34:54 2010 -0800
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,201 +0,0 @@
-(*  Title:      HOLCF/IOA/meta_theory/TLS.thy
-    Author:     Olaf Müller
-*)
-
-header {* Temporal Logic of Steps -- tailored for I/O automata *}
-
-theory TLS
-imports IOA TL
-begin
-
-default_sort type
-
-types
-  ('a, 's) ioa_temp  = "('a option,'s)transition temporal"
-  ('a, 's) step_pred = "('a option,'s)transition predicate"
-  's state_pred      = "'s predicate"
-
-consts
-
-option_lift :: "('a => 'b) => 'b => ('a option => 'b)"
-plift       :: "('a => bool) => ('a option => bool)"
-
-temp_sat   :: "('a,'s)execution => ('a,'s)ioa_temp => bool"    (infixr "|==" 22)
-xt1        :: "'s predicate => ('a,'s)step_pred"
-xt2        :: "'a option predicate => ('a,'s)step_pred"
-
-validTE    :: "('a,'s)ioa_temp => bool"
-validIOA   :: "('a,'s)ioa => ('a,'s)ioa_temp => bool"
-
-mkfin      :: "'a Seq => 'a Seq"
-
-ex2seq     :: "('a,'s)execution => ('a option,'s)transition Seq"
-ex2seqC    :: "('a,'s)pairs -> ('s => ('a option,'s)transition Seq)"
-
-
-defs
-
-mkfin_def:
-  "mkfin s == if Partial s then @t. Finite t & s = t @@ UU
-                           else s"
-
-option_lift_def:
-  "option_lift f s y == case y of None => s | Some x => (f x)"
-
-(* plift is used to determine that None action is always false in
-   transition predicates *)
-plift_def:
-  "plift P == option_lift P False"
-
-temp_sat_def:
-  "ex |== P == ((ex2seq ex) |= P)"
-
-xt1_def:
-  "xt1 P tr == P (fst tr)"
-
-xt2_def:
-  "xt2 P tr == P (fst (snd tr))"
-
-ex2seq_def:
-  "ex2seq ex == ((ex2seqC $(mkfin (snd ex))) (fst ex))"
-
-ex2seqC_def:
-  "ex2seqC == (fix$(LAM h ex. (%s. case ex of
-      nil =>  (s,None,s)>>nil
-    | x##xs => (flift1 (%pr.
-                (s,Some (fst pr), snd pr)>> (h$xs) (snd pr))
-                $x)
-      )))"
-
-validTE_def:
-  "validTE P == ! ex. (ex |== P)"
-
-validIOA_def:
-  "validIOA A P == ! ex : executions A . (ex |== P)"
-
-
-axioms
-
-mkfin_UU:
-  "mkfin UU = nil"
-
-mkfin_nil:
-  "mkfin nil =nil"
-
-mkfin_cons:
-  "(mkfin (a>>s)) = (a>>(mkfin s))"
-
-
-lemmas [simp del] = HOL.ex_simps HOL.all_simps split_paired_Ex
-
-declaration {* fn _ => Classical.map_cs (fn cs => cs delSWrapper "split_all_tac") *}
-
-
-subsection {* ex2seqC *}
-
-lemma ex2seqC_unfold: "ex2seqC  = (LAM ex. (%s. case ex of  
-       nil =>  (s,None,s)>>nil    
-     | x##xs => (flift1 (%pr.  
-                 (s,Some (fst pr), snd pr)>> (ex2seqC$xs) (snd pr))   
-                 $x)   
-       ))"
-apply (rule trans)
-apply (rule fix_eq2)
-apply (rule ex2seqC_def)
-apply (rule beta_cfun)
-apply (simp add: flift1_def)
-done
-
-lemma ex2seqC_UU: "(ex2seqC $UU) s=UU"
-apply (subst ex2seqC_unfold)
-apply simp
-done
-
-lemma ex2seqC_nil: "(ex2seqC $nil) s = (s,None,s)>>nil"
-apply (subst ex2seqC_unfold)
-apply simp
-done
-
-lemma ex2seqC_cons: "(ex2seqC $((a,t)>>xs)) s =  
-           (s,Some a,t)>> ((ex2seqC$xs) t)"
-apply (rule trans)
-apply (subst ex2seqC_unfold)
-apply (simp add: Consq_def flift1_def)
-apply (simp add: Consq_def flift1_def)
-done
-
-declare ex2seqC_UU [simp] ex2seqC_nil [simp] ex2seqC_cons [simp]
-
-
-
-declare mkfin_UU [simp] mkfin_nil [simp] mkfin_cons [simp]
-
-lemma ex2seq_UU: "ex2seq (s, UU) = (s,None,s)>>nil"
-apply (simp add: ex2seq_def)
-done
-
-lemma ex2seq_nil: "ex2seq (s, nil) = (s,None,s)>>nil"
-apply (simp add: ex2seq_def)
-done
-
-lemma ex2seq_cons: "ex2seq (s, (a,t)>>ex) = (s,Some a,t) >> ex2seq (t, ex)"
-apply (simp add: ex2seq_def)
-done
-
-declare ex2seqC_UU [simp del] ex2seqC_nil [simp del] ex2seqC_cons [simp del]
-declare ex2seq_UU [simp] ex2seq_nil [simp] ex2seq_cons [simp]
-
-
-lemma ex2seq_nUUnnil: "ex2seq exec ~= UU & ex2seq exec ~= nil"
-apply (tactic {* pair_tac @{context} "exec" 1 *})
-apply (tactic {* Seq_case_simp_tac @{context} "y" 1 *})
-apply (tactic {* pair_tac @{context} "a" 1 *})
-done
-
-
-subsection {* Interface TL -- TLS *}
-
-(* uses the fact that in executions states overlap, which is lost in 
-   after the translation via ex2seq !! *)
-
-lemma TL_TLS: 
- "[| ! s a t. (P s) & s-a--A-> t --> (Q t) |] 
-   ==> ex |== (Init (%(s,a,t). P s) .& Init (%(s,a,t). s -a--A-> t)  
-              .--> (Next (Init (%(s,a,t).Q s))))"
-apply (unfold Init_def Next_def temp_sat_def satisfies_def IMPLIES_def AND_def)
-
-apply clarify
-apply (simp split add: split_if)
-(* TL = UU *)
-apply (rule conjI)
-apply (tactic {* pair_tac @{context} "ex" 1 *})
-apply (tactic {* Seq_case_simp_tac @{context} "y" 1 *})
-apply (tactic {* pair_tac @{context} "a" 1 *})
-apply (tactic {* Seq_case_simp_tac @{context} "s" 1 *})
-apply (tactic {* pair_tac @{context} "a" 1 *})
-(* TL = nil *)
-apply (rule conjI)
-apply (tactic {* pair_tac @{context} "ex" 1 *})
-apply (tactic {* Seq_case_tac @{context} "y" 1 *})
-apply (simp add: unlift_def)
-apply fast
-apply (simp add: unlift_def)
-apply fast
-apply (simp add: unlift_def)
-apply (tactic {* pair_tac @{context} "a" 1 *})
-apply (tactic {* Seq_case_simp_tac @{context} "s" 1 *})
-apply (tactic {* pair_tac @{context} "a" 1 *})
-(* TL =cons *)
-apply (simp add: unlift_def)
-
-apply (tactic {* pair_tac @{context} "ex" 1 *})
-apply (tactic {* Seq_case_simp_tac @{context} "y" 1 *})
-apply (tactic {* pair_tac @{context} "a" 1 *})
-apply (tactic {* Seq_case_simp_tac @{context} "s" 1 *})
-apply blast
-apply fastsimp
-apply (tactic {* pair_tac @{context} "a" 1 *})
- apply fastsimp
-done
-
-end

--- a/src/HOLCF/IOA/meta_theory/Traces.thy	Sat Nov 27 14:34:54 2010 -0800
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,410 +0,0 @@
-(*  Title:      HOLCF/IOA/meta_theory/Traces.thy
-    Author:     Olaf Müller
-*)
-
-header {* Executions and Traces of I/O automata in HOLCF *}
-
-theory Traces
-imports Sequence Automata
-begin
-
-default_sort type
-
-types
-   ('a,'s)pairs            =    "('a * 's) Seq"
-   ('a,'s)execution        =    "'s * ('a,'s)pairs"
-   'a trace                =    "'a Seq"
-
-   ('a,'s)execution_module = "('a,'s)execution set * 'a signature"
-   'a schedule_module      = "'a trace set * 'a signature"
-   'a trace_module         = "'a trace set * 'a signature"
-
-consts
-
-   (* Executions *)
-
-  is_exec_fragC ::"('a,'s)ioa => ('a,'s)pairs -> 's => tr"
-  is_exec_frag  ::"[('a,'s)ioa, ('a,'s)execution] => bool"
-  has_execution ::"[('a,'s)ioa, ('a,'s)execution] => bool"
-  executions    :: "('a,'s)ioa => ('a,'s)execution set"
-
-  (* Schedules and traces *)
-  filter_act    ::"('a,'s)pairs -> 'a trace"
-  has_schedule  :: "[('a,'s)ioa, 'a trace] => bool"
-  has_trace     :: "[('a,'s)ioa, 'a trace] => bool"
-  schedules     :: "('a,'s)ioa => 'a trace set"
-  traces        :: "('a,'s)ioa => 'a trace set"
-  mk_trace      :: "('a,'s)ioa => ('a,'s)pairs -> 'a trace"
-
-  laststate    ::"('a,'s)execution => 's"
-
-  (* A predicate holds infinitely (finitely) often in a sequence *)
-
-  inf_often      ::"('a => bool) => 'a Seq => bool"
-  fin_often      ::"('a => bool) => 'a Seq => bool"
-
-  (* fairness of executions *)
-
-  wfair_ex       ::"('a,'s)ioa => ('a,'s)execution => bool"
-  sfair_ex       ::"('a,'s)ioa => ('a,'s)execution => bool"
-  is_wfair       ::"('a,'s)ioa => 'a set => ('a,'s)execution => bool"
-  is_sfair       ::"('a,'s)ioa => 'a set => ('a,'s)execution => bool"
-  fair_ex        ::"('a,'s)ioa => ('a,'s)execution => bool"
-
-  (* fair behavior sets *)
-
-  fairexecutions ::"('a,'s)ioa => ('a,'s)execution set"
-  fairtraces     ::"('a,'s)ioa => 'a trace set"
-
-  (* Notions of implementation *)
-  ioa_implements :: "[('a,'s1)ioa, ('a,'s2)ioa] => bool"   (infixr "=<|" 12)
-  fair_implements  :: "('a,'s1)ioa => ('a,'s2)ioa => bool"
-
-  (* Execution, schedule and trace modules *)
-  Execs         ::  "('a,'s)ioa => ('a,'s)execution_module"
-  Scheds        ::  "('a,'s)ioa => 'a schedule_module"
-  Traces        ::  "('a,'s)ioa => 'a trace_module"
-
-
-defs
-
-
-(*  ------------------- Executions ------------------------------ *)
-
-
-is_exec_frag_def:
-  "is_exec_frag A ex ==  ((is_exec_fragC A$(snd ex)) (fst ex) ~= FF)"
-
-
-is_exec_fragC_def:
-  "is_exec_fragC A ==(fix$(LAM h ex. (%s. case ex of
-      nil => TT
-    | x##xs => (flift1
-            (%p. Def ((s,p):trans_of A) andalso (h$xs) (snd p))
-             $x)
-   )))"
-
-
-
-executions_def:
-  "executions ioa == {e. ((fst e) : starts_of(ioa)) &
-                         is_exec_frag ioa e}"
-
-
-(*  ------------------- Schedules ------------------------------ *)
-
-
-filter_act_def:
-  "filter_act == Map fst"
-
-has_schedule_def:
-  "has_schedule ioa sch ==
-     (? ex:executions ioa. sch = filter_act$(snd ex))"
-
-schedules_def:
-  "schedules ioa == {sch. has_schedule ioa sch}"
-
-
-(*  ------------------- Traces ------------------------------ *)
-
-has_trace_def:
-  "has_trace ioa tr ==
-     (? sch:schedules ioa. tr = Filter (%a. a:ext(ioa))$sch)"
-
-traces_def:
-  "traces ioa == {tr. has_trace ioa tr}"
-
-
-mk_trace_def:
-  "mk_trace ioa == LAM tr.
-     Filter (%a. a:ext(ioa))$(filter_act$tr)"
-
-
-(*  ------------------- Fair Traces ------------------------------ *)
-
-laststate_def:
-  "laststate ex == case Last$(snd ex) of
-                      UU  => fst ex
-                    | Def at => snd at"
-
-inf_often_def:
-  "inf_often P s == Infinite (Filter P$s)"
-
-(*  filtering P yields a finite or partial sequence *)
-fin_often_def:
-  "fin_often P s == ~inf_often P s"
-
-(* Note that partial execs cannot be wfair as the inf_often predicate in the
-   else branch prohibits it. However they can be sfair in the case when all W
-   are only finitely often enabled: Is this the right model?
-   See LiveIOA for solution conforming with the literature and superseding this one *)
-wfair_ex_def:
-  "wfair_ex A ex == ! W : wfair_of A.
-                      if   Finite (snd ex)
-                      then ~Enabled A W (laststate ex)
-                      else is_wfair A W ex"
-
-is_wfair_def:
-  "is_wfair A W ex == (inf_often (%x. fst x:W) (snd ex)
-                     | inf_often (%x.~Enabled A W (snd x)) (snd ex))"
-
-sfair_ex_def:
-  "sfair_ex A ex == ! W : sfair_of A.
-                      if   Finite (snd ex)
-                      then ~Enabled A W (laststate ex)
-                      else is_sfair A W ex"
-
-is_sfair_def:
-  "is_sfair A W ex ==  (inf_often (%x. fst x:W) (snd ex)
-                      | fin_often (%x. Enabled A W (snd x)) (snd ex))"
-
-fair_ex_def:
-  "fair_ex A ex == wfair_ex A ex & sfair_ex A ex"
-
-fairexecutions_def:
-  "fairexecutions A == {ex. ex:executions A & fair_ex A ex}"
-
-fairtraces_def:
-  "fairtraces A == {mk_trace A$(snd ex) | ex. ex:fairexecutions A}"
-
-
-(*  ------------------- Implementation ------------------------------ *)
-
-ioa_implements_def:
-  "ioa1 =<| ioa2 ==
-    (((inputs(asig_of(ioa1)) = inputs(asig_of(ioa2))) &
-     (outputs(asig_of(ioa1)) = outputs(asig_of(ioa2)))) &
-      traces(ioa1) <= traces(ioa2))"
-
-fair_implements_def:
-  "fair_implements C A == inp(C) = inp(A) &  out(C)=out(A) &
-                          fairtraces(C) <= fairtraces(A)"
-
-(*  ------------------- Modules ------------------------------ *)
-
-Execs_def:
-  "Execs A  == (executions A, asig_of A)"
-
-Scheds_def:
-  "Scheds A == (schedules A, asig_of A)"
-
-Traces_def:
-  "Traces A == (traces A,asig_of A)"
-
-
-lemmas [simp del] = HOL.ex_simps HOL.all_simps split_paired_Ex
-declare Let_def [simp]
-declaration {* fn _ => Classical.map_cs (fn cs => cs delSWrapper "split_all_tac") *}
-
-lemmas exec_rws = executions_def is_exec_frag_def
-
-
-
-subsection "recursive equations of operators"
-
-(* ---------------------------------------------------------------- *)
-(*                               filter_act                         *)
-(* ---------------------------------------------------------------- *)
-
-
-lemma filter_act_UU: "filter_act$UU = UU"
-apply (simp add: filter_act_def)
-done
-
-lemma filter_act_nil: "filter_act$nil = nil"
-apply (simp add: filter_act_def)
-done
-
-lemma filter_act_cons: "filter_act$(x>>xs) = (fst x) >> filter_act$xs"
-apply (simp add: filter_act_def)
-done
-
-declare filter_act_UU [simp] filter_act_nil [simp] filter_act_cons [simp]
-
-
-(* ---------------------------------------------------------------- *)
-(*                             mk_trace                             *)
-(* ---------------------------------------------------------------- *)
-
-lemma mk_trace_UU: "mk_trace A$UU=UU"
-apply (simp add: mk_trace_def)
-done
-
-lemma mk_trace_nil: "mk_trace A$nil=nil"
-apply (simp add: mk_trace_def)
-done
-
-lemma mk_trace_cons: "mk_trace A$(at >> xs) =     
-             (if ((fst at):ext A)            
-                  then (fst at) >> (mk_trace A$xs)     
-                  else mk_trace A$xs)"
-
-apply (simp add: mk_trace_def)
-done
-
-declare mk_trace_UU [simp] mk_trace_nil [simp] mk_trace_cons [simp]
-
-(* ---------------------------------------------------------------- *)
-(*                             is_exec_fragC                             *)
-(* ---------------------------------------------------------------- *)
-
-
-lemma is_exec_fragC_unfold: "is_exec_fragC A = (LAM ex. (%s. case ex of  
-       nil => TT  
-     | x##xs => (flift1   
-             (%p. Def ((s,p):trans_of A) andalso (is_exec_fragC A$xs) (snd p))  
-              $x)  
-    ))"
-apply (rule trans)
-apply (rule fix_eq2)
-apply (rule is_exec_fragC_def)
-apply (rule beta_cfun)
-apply (simp add: flift1_def)
-done
-
-lemma is_exec_fragC_UU: "(is_exec_fragC A$UU) s=UU"
-apply (subst is_exec_fragC_unfold)
-apply simp
-done
-
-lemma is_exec_fragC_nil: "(is_exec_fragC A$nil) s = TT"
-apply (subst is_exec_fragC_unfold)
-apply simp
-done
-
-lemma is_exec_fragC_cons: "(is_exec_fragC A$(pr>>xs)) s =  
-                         (Def ((s,pr):trans_of A)  
-                 andalso (is_exec_fragC A$xs)(snd pr))"
-apply (rule trans)
-apply (subst is_exec_fragC_unfold)
-apply (simp add: Consq_def flift1_def)
-apply simp
-done
-
-
-declare is_exec_fragC_UU [simp] is_exec_fragC_nil [simp] is_exec_fragC_cons [simp]
-
-
-(* ---------------------------------------------------------------- *)
-(*                        is_exec_frag                              *)
-(* ---------------------------------------------------------------- *)
-
-lemma is_exec_frag_UU: "is_exec_frag A (s, UU)"
-apply (simp add: is_exec_frag_def)
-done
-
-lemma is_exec_frag_nil: "is_exec_frag A (s, nil)"
-apply (simp add: is_exec_frag_def)
-done
-
-lemma is_exec_frag_cons: "is_exec_frag A (s, (a,t)>>ex) =  
-                                (((s,a,t):trans_of A) &  
-                                is_exec_frag A (t, ex))"
-apply (simp add: is_exec_frag_def)
-done
-
-
-(* Delsimps [is_exec_fragC_UU,is_exec_fragC_nil,is_exec_fragC_cons]; *)
-declare is_exec_frag_UU [simp] is_exec_frag_nil [simp] is_exec_frag_cons [simp]
-
-(* ---------------------------------------------------------------------------- *)
-                           section "laststate"
-(* ---------------------------------------------------------------------------- *)
-
-lemma laststate_UU: "laststate (s,UU) = s"
-apply (simp add: laststate_def)
-done
-
-lemma laststate_nil: "laststate (s,nil) = s"
-apply (simp add: laststate_def)
-done
-
-lemma laststate_cons: "!! ex. Finite ex ==> laststate (s,at>>ex) = laststate (snd at,ex)"
-apply (simp (no_asm) add: laststate_def)
-apply (case_tac "ex=nil")
-apply (simp (no_asm_simp))
-apply (simp (no_asm_simp))
-apply (drule Finite_Last1 [THEN mp])
-apply assumption
-apply defined
-done
-
-declare laststate_UU [simp] laststate_nil [simp] laststate_cons [simp]
-
-lemma exists_laststate: "!!ex. Finite ex ==> (! s. ? u. laststate (s,ex)=u)"
-apply (tactic "Seq_Finite_induct_tac @{context} 1")
-done
-
-
-subsection "has_trace, mk_trace"
-
-(* alternative definition of has_trace tailored for the refinement proof, as it does not 
-   take the detour of schedules *)
-
-lemma has_trace_def2: 
-"has_trace A b = (? ex:executions A. b = mk_trace A$(snd ex))"
-apply (unfold executions_def mk_trace_def has_trace_def schedules_def has_schedule_def)
-apply auto
-done
-
-
-subsection "signatures and executions, schedules"
-
-(* All executions of A have only actions of A. This is only true because of the 
-   predicate state_trans (part of the predicate IOA): We have no dependent types.
-   For executions of parallel automata this assumption is not needed, as in par_def
-   this condition is included once more. (see Lemmas 1.1.1c in CompoExecs for example) *)
-
-lemma execfrag_in_sig: 
-  "!! A. is_trans_of A ==>  
-  ! s. is_exec_frag A (s,xs) --> Forall (%a. a:act A) (filter_act$xs)"
-apply (tactic {* pair_induct_tac @{context} "xs" [@{thm is_exec_frag_def},
-  @{thm Forall_def}, @{thm sforall_def}] 1 *})
-(* main case *)
-apply (auto simp add: is_trans_of_def)
-done
-
-lemma exec_in_sig: 
-  "!! A.[|  is_trans_of A; x:executions A |] ==>  
-  Forall (%a. a:act A) (filter_act$(snd x))"
-apply (simp add: executions_def)
-apply (tactic {* pair_tac @{context} "x" 1 *})
-apply (rule execfrag_in_sig [THEN spec, THEN mp])
-apply auto
-done
-
-lemma scheds_in_sig: 
-  "!! A.[|  is_trans_of A; x:schedules A |] ==>  
-    Forall (%a. a:act A) x"
-apply (unfold schedules_def has_schedule_def)
-apply (fast intro!: exec_in_sig)
-done
-
-
-subsection "executions are prefix closed"
-
-(* only admissible in y, not if done in x !! *)
-lemma execfrag_prefixclosed: "!x s. is_exec_frag A (s,x) & y<<x  --> is_exec_frag A (s,y)"
-apply (tactic {* pair_induct_tac @{context} "y" [@{thm is_exec_frag_def}] 1 *})
-apply (intro strip)
-apply (tactic {* Seq_case_simp_tac @{context} "xa" 1 *})
-apply (tactic {* pair_tac @{context} "a" 1 *})
-apply auto
-done
-
-lemmas exec_prefixclosed =
-  conjI [THEN execfrag_prefixclosed [THEN spec, THEN spec, THEN mp], standard]
-
-
-(* second prefix notion for Finite x *)
-
-lemma exec_prefix2closed [rule_format]:
-  "! y s. is_exec_frag A (s,x@@y) --> is_exec_frag A (s,x)"
-apply (tactic {* pair_induct_tac @{context} "x" [@{thm is_exec_frag_def}] 1 *})
-apply (intro strip)
-apply (tactic {* Seq_case_simp_tac @{context} "s" 1 *})
-apply (tactic {* pair_tac @{context} "a" 1 *})
-apply auto
-done
-
-end

--- a/src/HOLCF/IsaMakefile	Sat Nov 27 14:34:54 2010 -0800
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,224 +0,0 @@
-#
-# IsaMakefile for HOLCF
-#
-
-## targets
-
-default: HOLCF
-images: HOLCF IOA
-test: \
-  HOLCF-FOCUS \
-  HOLCF-IMP \
-  HOLCF-Library \
-  HOLCF-Tutorial \
-  HOLCF-ex \
-  IOA-ABP \
-  IOA-NTP \
-  IOA-Storage \
-  IOA-ex
-all: images test
-
-
-## global settings
-
-SRC = $(ISABELLE_HOME)/src
-OUT = $(ISABELLE_OUTPUT)
-LOG = $(OUT)/log
-
-
-## HOLCF
-
-HOLCF: HOL $(OUT)/HOLCF
-
-HOL:
-	@cd $(SRC)/HOL; $(ISABELLE_TOOL) make HOL
-
-$(OUT)/HOLCF: $(OUT)/HOL \
-  ROOT.ML \
-  Adm.thy \
-  Algebraic.thy \
-  Bifinite.thy \
-  Cfun.thy \
-  CompactBasis.thy \
-  Completion.thy \
-  Cont.thy \
-  ConvexPD.thy \
-  Cpodef.thy \
-  Cprod.thy \
-  Discrete.thy \
-  Deflation.thy \
-  Domain.thy \
-  Domain_Aux.thy \
-  Fixrec.thy \
-  Fix.thy \
-  Fun_Cpo.thy \
-  HOLCF.thy \
-  Lift.thy \
-  LowerPD.thy \
-  Map_Functions.thy \
-  One.thy \
-  Pcpo.thy \
-  Plain_HOLCF.thy \
-  Porder.thy \
-  Powerdomains.thy \
-  Product_Cpo.thy \
-  Sfun.thy \
-  Sprod.thy \
-  Ssum.thy \
-  Tr.thy \
-  Universal.thy \
-  UpperPD.thy \
-  Up.thy \
-  Tools/cont_consts.ML \
-  Tools/cont_proc.ML \
-  Tools/holcf_library.ML \
-  Tools/Domain/domain.ML \
-  Tools/Domain/domain_axioms.ML \
-  Tools/Domain/domain_constructors.ML \
-  Tools/Domain/domain_induction.ML \
-  Tools/Domain/domain_isomorphism.ML \
-  Tools/Domain/domain_take_proofs.ML \
-  Tools/cpodef.ML \
-  Tools/domaindef.ML \
-  Tools/fixrec.ML \
-  document/root.tex
-	@$(ISABELLE_TOOL) usedir -b -g true -r $(OUT)/HOL HOLCF
-
-
-## HOLCF-Tutorial
-
-HOLCF-Tutorial: HOLCF $(LOG)/HOLCF-Tutorial.gz
-
-$(LOG)/HOLCF-Tutorial.gz: $(OUT)/HOLCF \
-  Tutorial/Domain_ex.thy \
-  Tutorial/Fixrec_ex.thy \
-  Tutorial/New_Domain.thy \
-  Tutorial/document/root.tex \
-  Tutorial/ROOT.ML
-	@$(ISABELLE_TOOL) usedir $(OUT)/HOLCF Tutorial
-
-
-## HOLCF-Library
-
-HOLCF-Library: HOLCF $(LOG)/HOLCF-Library.gz
-
-$(LOG)/HOLCF-Library.gz: $(OUT)/HOLCF \
-  Library/Defl_Bifinite.thy \
-  Library/List_Cpo.thy \
-  Library/Stream.thy \
-  Library/Sum_Cpo.thy \
-  Library/HOLCF_Library.thy \
-  Library/ROOT.ML
-	@$(ISABELLE_TOOL) usedir $(OUT)/HOLCF Library
-
-
-## HOLCF-IMP
-
-HOLCF-IMP: HOLCF $(LOG)/HOLCF-IMP.gz
-
-$(LOG)/HOLCF-IMP.gz: $(OUT)/HOLCF IMP/HoareEx.thy \
-  IMP/Denotational.thy IMP/ROOT.ML IMP/document/root.tex
-	@$(ISABELLE_TOOL) usedir $(OUT)/HOLCF IMP
-
-
-## HOLCF-ex
-
-HOLCF-ex: HOLCF $(LOG)/HOLCF-ex.gz
-
-$(LOG)/HOLCF-ex.gz: $(OUT)/HOLCF \
-  ../HOL/Library/Nat_Infinity.thy \
-  ex/Dagstuhl.thy \
-  ex/Dnat.thy \
-  ex/Domain_Proofs.thy \
-  ex/Fix2.thy \
-  ex/Focus_ex.thy \
-  ex/Hoare.thy \
-  ex/Letrec.thy \
-  ex/Loop.thy \
-  ex/Pattern_Match.thy \
-  ex/Powerdomain_ex.thy \
-  ex/ROOT.ML
-	@$(ISABELLE_TOOL) usedir $(OUT)/HOLCF ex
-
-
-## HOLCF-FOCUS
-
-HOLCF-FOCUS: HOLCF $(LOG)/HOLCF-FOCUS.gz
-
-$(LOG)/HOLCF-FOCUS.gz: $(OUT)/HOLCF \
-  Library/Stream.thy \
-  FOCUS/Fstreams.thy \
-  FOCUS/Fstream.thy FOCUS/FOCUS.thy \
-  FOCUS/Stream_adm.thy ../HOL/Library/Continuity.thy \
-  FOCUS/Buffer.thy FOCUS/Buffer_adm.thy
-	@$(ISABELLE_TOOL) usedir $(OUT)/HOLCF FOCUS
-
-## IOA
-
-IOA: HOLCF $(OUT)/IOA
-
-$(OUT)/IOA: $(OUT)/HOLCF IOA/ROOT.ML IOA/meta_theory/Traces.thy        \
-  IOA/meta_theory/Asig.thy IOA/meta_theory/CompoScheds.thy	       \
-  IOA/meta_theory/CompoTraces.thy IOA/meta_theory/Seq.thy	       \
-  IOA/meta_theory/RefCorrectness.thy IOA/meta_theory/Automata.thy      \
-  IOA/meta_theory/ShortExecutions.thy IOA/meta_theory/IOA.thy	       \
-  IOA/meta_theory/Sequence.thy IOA/meta_theory/CompoExecs.thy	       \
-  IOA/meta_theory/RefMappings.thy IOA/meta_theory/Compositionality.thy \
-  IOA/meta_theory/TL.thy IOA/meta_theory/TLS.thy		       \
-  IOA/meta_theory/LiveIOA.thy IOA/meta_theory/Pred.thy		       \
-  IOA/meta_theory/Abstraction.thy IOA/meta_theory/Simulations.thy      \
-  IOA/meta_theory/SimCorrectness.thy
-	@cd IOA; $(ISABELLE_TOOL) usedir -b $(OUT)/HOLCF IOA
-
-
-## IOA-ABP
-
-IOA-ABP: IOA $(LOG)/IOA-ABP.gz
-
-$(LOG)/IOA-ABP.gz: $(OUT)/IOA IOA/ABP/Abschannel.thy \
-  IOA/ABP/Abschannel_finite.thy IOA/ABP/Action.thy \
-  IOA/ABP/Check.ML IOA/ABP/Correctness.thy \
-  IOA/ABP/Env.thy IOA/ABP/Impl.thy IOA/ABP/Impl_finite.thy \
-  IOA/ABP/Lemmas.thy IOA/ABP/Packet.thy \
-  IOA/ABP/ROOT.ML IOA/ABP/Receiver.thy IOA/ABP/Sender.thy \
-  IOA/ABP/Spec.thy
-	@cd IOA; $(ISABELLE_TOOL) usedir $(OUT)/IOA ABP
-
-## IOA-NTP
-
-IOA-NTP: IOA $(LOG)/IOA-NTP.gz
-
-$(LOG)/IOA-NTP.gz: $(OUT)/IOA \
-  IOA/NTP/Abschannel.thy IOA/NTP/Action.thy IOA/NTP/Correctness.thy \
-  IOA/NTP/Impl.thy IOA/NTP/Lemmas.thy IOA/NTP/Multiset.thy \
-  IOA/NTP/Packet.thy IOA/NTP/ROOT.ML IOA/NTP/Receiver.thy IOA/NTP/Sender.thy \
-  IOA/NTP/Spec.thy
-	@cd IOA; $(ISABELLE_TOOL) usedir $(OUT)/IOA NTP
-
-
-## IOA-Storage
-
-IOA-Storage: IOA $(LOG)/IOA-Storage.gz
-
-$(LOG)/IOA-Storage.gz: $(OUT)/IOA IOA/Storage/Action.thy \
-  IOA/Storage/Correctness.thy IOA/Storage/Impl.thy \
-  IOA/Storage/ROOT.ML IOA/Storage/Spec.thy
-	@cd IOA; $(ISABELLE_TOOL) usedir $(OUT)/IOA Storage
-
-
-## IOA-ex
-
-IOA-ex: IOA $(LOG)/IOA-ex.gz
-
-$(LOG)/IOA-ex.gz: $(OUT)/IOA IOA/ex/ROOT.ML IOA/ex/TrivEx.thy IOA/ex/TrivEx2.thy
-	@cd IOA; $(ISABELLE_TOOL) usedir $(OUT)/IOA ex
-
-
-## clean
-
-clean:
-	@rm -f $(OUT)/HOLCF $(LOG)/HOLCF.gz $(LOG)/HOLCF-IMP.gz	\
-	  $(LOG)/HOLCF-ex.gz $(LOG)/HOLCF-FOCUS.gz $(OUT)/IOA	\
-	  $(LOG)/IOA.gz $(LOG)/IOA-ABP.gz $(LOG)/IOA-NTP.gz	\
-	  $(LOG)/IOA-Storage.gz $(LOG)/HOLCF-Library.gz		\
-	  $(LOG)/IOA-ex.gz $(LOG)/HOLCF-Tutorial.gz

--- a/src/HOLCF/Library/Defl_Bifinite.thy	Sat Nov 27 14:34:54 2010 -0800
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,661 +0,0 @@
-(*  Title:      HOLCF/Library/Defl_Bifinite.thy
-    Author:     Brian Huffman
-*)
-
-header {* Algebraic deflations are a bifinite domain *}
-
-theory Defl_Bifinite
-imports HOLCF Infinite_Set
-begin
-
-subsection {* Lemmas about MOST *}
-
-default_sort type
-
-lemma MOST_INFM:
-  assumes inf: "infinite (UNIV::'a set)"
-  shows "MOST x::'a. P x \<Longrightarrow> INFM x::'a. P x"
-  unfolding Alm_all_def Inf_many_def
-  apply (auto simp add: Collect_neg_eq)
-  apply (drule (1) finite_UnI)
-  apply (simp add: Compl_partition2 inf)
-  done
-
-lemma MOST_SucI: "MOST n. P n \<Longrightarrow> MOST n. P (Suc n)"
-by (rule MOST_inj [OF _ inj_Suc])
-
-lemma MOST_SucD: "MOST n. P (Suc n) \<Longrightarrow> MOST n. P n"
-unfolding MOST_nat
-apply (clarify, rule_tac x="Suc m" in exI, clarify)
-apply (erule Suc_lessE, simp)
-done
-
-lemma MOST_Suc_iff: "(MOST n. P (Suc n)) \<longleftrightarrow> (MOST n. P n)"
-by (rule iffI [OF MOST_SucD MOST_SucI])
-
-lemma INFM_finite_Bex_distrib:
-  "finite A \<Longrightarrow> (INFM y. \<exists>x\<in>A. P x y) \<longleftrightarrow> (\<exists>x\<in>A. INFM y. P x y)"
-by (induct set: finite, simp, simp add: INFM_disj_distrib)
-
-lemma MOST_finite_Ball_distrib:
-  "finite A \<Longrightarrow> (MOST y. \<forall>x\<in>A. P x y) \<longleftrightarrow> (\<forall>x\<in>A. MOST y. P x y)"
-by (induct set: finite, simp, simp add: MOST_conj_distrib)
-
-lemma MOST_ge_nat: "MOST n::nat. m \<le> n"
-unfolding MOST_nat_le by fast
-
-subsection {* Eventually constant sequences *}
-
-definition
-  eventually_constant :: "(nat \<Rightarrow> 'a) \<Rightarrow> bool"
-where
-  "eventually_constant S = (\<exists>x. MOST i. S i = x)"
-
-lemma eventually_constant_MOST_MOST:
-  "eventually_constant S \<longleftrightarrow> (MOST m. MOST n. S n = S m)"
-unfolding eventually_constant_def MOST_nat
-apply safe
-apply (rule_tac x=m in exI, clarify)
-apply (rule_tac x=m in exI, clarify)
-apply simp
-apply fast
-done
-
-lemma eventually_constantI: "MOST i. S i = x \<Longrightarrow> eventually_constant S"
-unfolding eventually_constant_def by fast
-
-lemma eventually_constant_comp:
-  "eventually_constant (\<lambda>i. S i) \<Longrightarrow> eventually_constant (\<lambda>i. f (S i))"
-unfolding eventually_constant_def
-apply (erule exE, rule_tac x="f x" in exI)
-apply (erule MOST_mono, simp)
-done
-
-lemma eventually_constant_Suc_iff:
-  "eventually_constant (\<lambda>i. S (Suc i)) \<longleftrightarrow> eventually_constant (\<lambda>i. S i)"
-unfolding eventually_constant_def
-by (subst MOST_Suc_iff, rule refl)
-
-lemma eventually_constant_SucD:
-  "eventually_constant (\<lambda>i. S (Suc i)) \<Longrightarrow> eventually_constant (\<lambda>i. S i)"
-by (rule eventually_constant_Suc_iff [THEN iffD1])
-
-subsection {* Limits of eventually constant sequences *}
-
-definition
-  eventual :: "(nat \<Rightarrow> 'a) \<Rightarrow> 'a" where
-  "eventual S = (THE x. MOST i. S i = x)"
-
-lemma eventual_eqI: "MOST i. S i = x \<Longrightarrow> eventual S = x"
-unfolding eventual_def
-apply (rule the_equality, assumption)
-apply (rename_tac y)
-apply (subgoal_tac "MOST i::nat. y = x", simp)
-apply (erule MOST_rev_mp)
-apply (erule MOST_rev_mp)
-apply simp
-done
-
-lemma MOST_eq_eventual:
-  "eventually_constant S \<Longrightarrow> MOST i. S i = eventual S"
-unfolding eventually_constant_def
-by (erule exE, simp add: eventual_eqI)
-
-lemma eventual_mem_range:
-  "eventually_constant S \<Longrightarrow> eventual S \<in> range S"
-apply (drule MOST_eq_eventual)
-apply (simp only: MOST_nat_le, clarify)
-apply (drule spec, drule mp, rule order_refl)
-apply (erule range_eqI [OF sym])
-done
-
-lemma eventually_constant_MOST_iff:
-  assumes S: "eventually_constant S"
-  shows "(MOST n. P (S n)) \<longleftrightarrow> P (eventual S)"
-apply (subgoal_tac "(MOST n. P (S n)) \<longleftrightarrow> (MOST n::nat. P (eventual S))")
-apply simp
-apply (rule iffI)
-apply (rule MOST_rev_mp [OF MOST_eq_eventual [OF S]])
-apply (erule MOST_mono, force)
-apply (rule MOST_rev_mp [OF MOST_eq_eventual [OF S]])
-apply (erule MOST_mono, simp)
-done
-
-lemma MOST_eventual:
-  "\<lbrakk>eventually_constant S; MOST n. P (S n)\<rbrakk> \<Longrightarrow> P (eventual S)"
-proof -
-  assume "eventually_constant S"
-  hence "MOST n. S n = eventual S"
-    by (rule MOST_eq_eventual)
-  moreover assume "MOST n. P (S n)"
-  ultimately have "MOST n. S n = eventual S \<and> P (S n)"
-    by (rule MOST_conj_distrib [THEN iffD2, OF conjI])
-  hence "MOST n::nat. P (eventual S)"
-    by (rule MOST_mono) auto
-  thus ?thesis by simp
-qed
-
-lemma eventually_constant_MOST_Suc_eq:
-  "eventually_constant S \<Longrightarrow> MOST n. S (Suc n) = S n"
-apply (drule MOST_eq_eventual)
-apply (frule MOST_Suc_iff [THEN iffD2])
-apply (erule MOST_rev_mp)
-apply (erule MOST_rev_mp)
-apply simp
-done
-
-lemma eventual_comp:
-  "eventually_constant S \<Longrightarrow> eventual (\<lambda>i. f (S i)) = f (eventual (\<lambda>i. S i))"
-apply (rule eventual_eqI)
-apply (rule MOST_mono)
-apply (erule MOST_eq_eventual)
-apply simp
-done
-
-subsection {* Constructing finite deflations by iteration *}
-
-default_sort cpo
-
-lemma le_Suc_induct:
-  assumes le: "i \<le> j"
-  assumes step: "\<And>i. P i (Suc i)"
-  assumes refl: "\<And>i. P i i"
-  assumes trans: "\<And>i j k. \<lbrakk>P i j; P j k\<rbrakk> \<Longrightarrow> P i k"
-  shows "P i j"
-proof (cases "i = j")
-  assume "i = j"
-  thus "P i j" by (simp add: refl)
-next
-  assume "i \<noteq> j"
-  with le have "i < j" by simp
-  thus "P i j" using step trans by (rule less_Suc_induct)
-qed
-
-definition
-  eventual_iterate :: "('a \<rightarrow> 'a::cpo) \<Rightarrow> ('a \<rightarrow> 'a)"
-where
-  "eventual_iterate f = eventual (\<lambda>n. iterate n\<cdot>f)"
-
-text {* A pre-deflation is like a deflation, but not idempotent. *}
-
-locale pre_deflation =
-  fixes f :: "'a \<rightarrow> 'a::cpo"
-  assumes below: "\<And>x. f\<cdot>x \<sqsubseteq> x"
-  assumes finite_range: "finite (range (\<lambda>x. f\<cdot>x))"
-begin
-
-lemma iterate_below: "iterate i\<cdot>f\<cdot>x \<sqsubseteq> x"
-by (induct i, simp_all add: below_trans [OF below])
-
-lemma iterate_fixed: "f\<cdot>x = x \<Longrightarrow> iterate i\<cdot>f\<cdot>x = x"
-by (induct i, simp_all)
-
-lemma antichain_iterate_app: "i \<le> j \<Longrightarrow> iterate j\<cdot>f\<cdot>x \<sqsubseteq> iterate i\<cdot>f\<cdot>x"
-apply (erule le_Suc_induct)
-apply (simp add: below)
-apply (rule below_refl)
-apply (erule (1) below_trans)
-done
-
-lemma finite_range_iterate_app: "finite (range (\<lambda>i. iterate i\<cdot>f\<cdot>x))"
-proof (rule finite_subset)
-  show "range (\<lambda>i. iterate i\<cdot>f\<cdot>x) \<subseteq> insert x (range (\<lambda>x. f\<cdot>x))"
-    by (clarify, case_tac i, simp_all)
-  show "finite (insert x (range (\<lambda>x. f\<cdot>x)))"
-    by (simp add: finite_range)
-qed
-
-lemma eventually_constant_iterate_app:
-  "eventually_constant (\<lambda>i. iterate i\<cdot>f\<cdot>x)"
-unfolding eventually_constant_def MOST_nat_le
-proof -
-  let ?Y = "\<lambda>i. iterate i\<cdot>f\<cdot>x"
-  have "\<exists>j. \<forall>k. ?Y j \<sqsubseteq> ?Y k"
-    apply (rule finite_range_has_max)
-    apply (erule antichain_iterate_app)
-    apply (rule finite_range_iterate_app)
-    done
-  then obtain j where j: "\<And>k. ?Y j \<sqsubseteq> ?Y k" by fast
-  show "\<exists>z m. \<forall>n\<ge>m. ?Y n = z"
-  proof (intro exI allI impI)
-    fix k
-    assume "j \<le> k"
-    hence "?Y k \<sqsubseteq> ?Y j" by (rule antichain_iterate_app)
-    also have "?Y j \<sqsubseteq> ?Y k" by (rule j)
-    finally show "?Y k = ?Y j" .
-  qed
-qed
-
-lemma eventually_constant_iterate:
-  "eventually_constant (\<lambda>n. iterate n\<cdot>f)"
-proof -
-  have "\<forall>y\<in>range (\<lambda>x. f\<cdot>x). eventually_constant (\<lambda>i. iterate i\<cdot>f\<cdot>y)"
-    by (simp add: eventually_constant_iterate_app)
-  hence "\<forall>y\<in>range (\<lambda>x. f\<cdot>x). MOST i. MOST j. iterate j\<cdot>f\<cdot>y = iterate i\<cdot>f\<cdot>y"
-    unfolding eventually_constant_MOST_MOST .
-  hence "MOST i. MOST j. \<forall>y\<in>range (\<lambda>x. f\<cdot>x). iterate j\<cdot>f\<cdot>y = iterate i\<cdot>f\<cdot>y"
-    by (simp only: MOST_finite_Ball_distrib [OF finite_range])
-  hence "MOST i. MOST j. \<forall>x. iterate j\<cdot>f\<cdot>(f\<cdot>x) = iterate i\<cdot>f\<cdot>(f\<cdot>x)"
-    by simp
-  hence "MOST i. MOST j. \<forall>x. iterate (Suc j)\<cdot>f\<cdot>x = iterate (Suc i)\<cdot>f\<cdot>x"
-    by (simp only: iterate_Suc2)
-  hence "MOST i. MOST j. iterate (Suc j)\<cdot>f = iterate (Suc i)\<cdot>f"
-    by (simp only: cfun_eq_iff)
-  hence "eventually_constant (\<lambda>i. iterate (Suc i)\<cdot>f)"
-    unfolding eventually_constant_MOST_MOST .
-  thus "eventually_constant (\<lambda>i. iterate i\<cdot>f)"
-    by (rule eventually_constant_SucD)
-qed
-
-abbreviation
-  d :: "'a \<rightarrow> 'a"
-where
-  "d \<equiv> eventual_iterate f"
-
-lemma MOST_d: "MOST n. P (iterate n\<cdot>f) \<Longrightarrow> P d"
-unfolding eventual_iterate_def
-using eventually_constant_iterate by (rule MOST_eventual)
-
-lemma f_d: "f\<cdot>(d\<cdot>x) = d\<cdot>x"
-apply (rule MOST_d)
-apply (subst iterate_Suc [symmetric])
-apply (rule eventually_constant_MOST_Suc_eq)
-apply (rule eventually_constant_iterate_app)
-done
-
-lemma d_fixed_iff: "d\<cdot>x = x \<longleftrightarrow> f\<cdot>x = x"
-proof
-  assume "d\<cdot>x = x"
-  with f_d [where x=x]
-  show "f\<cdot>x = x" by simp
-next
-  assume f: "f\<cdot>x = x"
-  have "\<forall>n. iterate n\<cdot>f\<cdot>x = x"
-    by (rule allI, rule nat.induct, simp, simp add: f)
-  hence "MOST n. iterate n\<cdot>f\<cdot>x = x"
-    by (rule ALL_MOST)
-  thus "d\<cdot>x = x"
-    by (rule MOST_d)
-qed
-
-lemma finite_deflation_d: "finite_deflation d"
-proof
-  fix x :: 'a
-  have "d \<in> range (\<lambda>n. iterate n\<cdot>f)"
-    unfolding eventual_iterate_def
-    using eventually_constant_iterate
-    by (rule eventual_mem_range)
-  then obtain n where n: "d = iterate n\<cdot>f" ..
-  have "iterate n\<cdot>f\<cdot>(d\<cdot>x) = d\<cdot>x"
-    using f_d by (rule iterate_fixed)
-  thus "d\<cdot>(d\<cdot>x) = d\<cdot>x"
-    by (simp add: n)
-next
-  fix x :: 'a
-  show "d\<cdot>x \<sqsubseteq> x"
-    by (rule MOST_d, simp add: iterate_below)
-next
-  from finite_range
-  have "finite {x. f\<cdot>x = x}"
-    by (rule finite_range_imp_finite_fixes)
-  thus "finite {x. d\<cdot>x = x}"
-    by (simp add: d_fixed_iff)
-qed
-
-lemma deflation_d: "deflation d"
-using finite_deflation_d
-by (rule finite_deflation_imp_deflation)
-
-end
-
-lemma finite_deflation_eventual_iterate:
-  "pre_deflation d \<Longrightarrow> finite_deflation (eventual_iterate d)"
-by (rule pre_deflation.finite_deflation_d)
-
-lemma pre_deflation_oo:
-  assumes "finite_deflation d"
-  assumes f: "\<And>x. f\<cdot>x \<sqsubseteq> x"
-  shows "pre_deflation (d oo f)"
-proof
-  interpret d: finite_deflation d by fact
-  fix x
-  show "\<And>x. (d oo f)\<cdot>x \<sqsubseteq> x"
-    by (simp, rule below_trans [OF d.below f])
-  show "finite (range (\<lambda>x. (d oo f)\<cdot>x))"
-    by (rule finite_subset [OF _ d.finite_range], auto)
-qed
-
-lemma eventual_iterate_oo_fixed_iff:
-  assumes "finite_deflation d"
-  assumes f: "\<And>x. f\<cdot>x \<sqsubseteq> x"
-  shows "eventual_iterate (d oo f)\<cdot>x = x \<longleftrightarrow> d\<cdot>x = x \<and> f\<cdot>x = x"
-proof -
-  interpret d: finite_deflation d by fact
-  let ?e = "d oo f"
-  interpret e: pre_deflation "d oo f"
-    using `finite_deflation d` f
-    by (rule pre_deflation_oo)
-  let ?g = "eventual (\<lambda>n. iterate n\<cdot>?e)"
-  show ?thesis
-    apply (subst e.d_fixed_iff)
-    apply simp
-    apply safe
-    apply (erule subst)
-    apply (rule d.idem)
-    apply (rule below_antisym)
-    apply (rule f)
-    apply (erule subst, rule d.below)
-    apply simp
-    done
-qed
-
-lemma eventual_mono:
-  assumes A: "eventually_constant A"
-  assumes B: "eventually_constant B"
-  assumes below: "\<And>n. A n \<sqsubseteq> B n"
-  shows "eventual A \<sqsubseteq> eventual B"
-proof -
-  from A have "MOST n. A n = eventual A"
-    by (rule MOST_eq_eventual)
-  then have "MOST n. eventual A \<sqsubseteq> B n"
-    by (rule MOST_mono) (erule subst, rule below)
-  with B show "eventual A \<sqsubseteq> eventual B"
-    by (rule MOST_eventual)
-qed
-
-lemma eventual_iterate_mono:
-  assumes f: "pre_deflation f" and g: "pre_deflation g" and "f \<sqsubseteq> g"
-  shows "eventual_iterate f \<sqsubseteq> eventual_iterate g"
-unfolding eventual_iterate_def
-apply (rule eventual_mono)
-apply (rule pre_deflation.eventually_constant_iterate [OF f])
-apply (rule pre_deflation.eventually_constant_iterate [OF g])
-apply (rule monofun_cfun_arg [OF `f \<sqsubseteq> g`])
-done
-
-lemma cont2cont_eventual_iterate_oo:
-  assumes d: "finite_deflation d"
-  assumes cont: "cont f" and below: "\<And>x y. f x\<cdot>y \<sqsubseteq> y"
-  shows "cont (\<lambda>x. eventual_iterate (d oo f x))"
-    (is "cont ?e")
-proof (rule contI2)
-  show "monofun ?e"
-    apply (rule monofunI)
-    apply (rule eventual_iterate_mono)
-    apply (rule pre_deflation_oo [OF d below])
-    apply (rule pre_deflation_oo [OF d below])
-    apply (rule monofun_cfun_arg)
-    apply (erule cont2monofunE [OF cont])
-    done
-next
-  fix Y :: "nat \<Rightarrow> 'b"
-  assume Y: "chain Y"
-  with cont have fY: "chain (\<lambda>i. f (Y i))"
-    by (rule ch2ch_cont)
-  assume eY: "chain (\<lambda>i. ?e (Y i))"
-  have lub_below: "\<And>x. f (\<Squnion>i. Y i)\<cdot>x \<sqsubseteq> x"
-    by (rule admD [OF _ Y], simp add: cont, rule below)
-  have "deflation (?e (\<Squnion>i. Y i))"
-    apply (rule pre_deflation.deflation_d)
-    apply (rule pre_deflation_oo [OF d lub_below])
-    done
-  then show "?e (\<Squnion>i. Y i) \<sqsubseteq> (\<Squnion>i. ?e (Y i))"
-  proof (rule deflation.belowI)
-    fix x :: 'a
-    assume "?e (\<Squnion>i. Y i)\<cdot>x = x"
-    hence "d\<cdot>x = x" and "f (\<Squnion>i. Y i)\<cdot>x = x"
-      by (simp_all add: eventual_iterate_oo_fixed_iff [OF d lub_below])
-    hence "(\<Squnion>i. f (Y i)\<cdot>x) = x"
-      apply (simp only: cont2contlubE [OF cont Y])
-      apply (simp only: contlub_cfun_fun [OF fY])
-      done
-    have "compact (d\<cdot>x)"
-      using d by (rule finite_deflation.compact)
-    then have "compact x"
-      using `d\<cdot>x = x` by simp
-    then have "compact (\<Squnion>i. f (Y i)\<cdot>x)"
-      using `(\<Squnion>i. f (Y i)\<cdot>x) = x` by simp
-    then have "\<exists>n. max_in_chain n (\<lambda>i. f (Y i)\<cdot>x)"
-      by - (rule compact_imp_max_in_chain, simp add: fY, assumption)
-    then obtain n where n: "max_in_chain n (\<lambda>i. f (Y i)\<cdot>x)" ..
-    then have "f (Y n)\<cdot>x = x"
-      using `(\<Squnion>i. f (Y i)\<cdot>x) = x` fY by (simp add: maxinch_is_thelub)
-    with `d\<cdot>x = x` have "?e (Y n)\<cdot>x = x"
-      by (simp add: eventual_iterate_oo_fixed_iff [OF d below])
-    moreover have "?e (Y n)\<cdot>x \<sqsubseteq> (\<Squnion>i. ?e (Y i)\<cdot>x)"
-      by (rule is_ub_thelub, simp add: eY)
-    ultimately have "x \<sqsubseteq> (\<Squnion>i. ?e (Y i))\<cdot>x"
-      by (simp add: contlub_cfun_fun eY)
-    also have "(\<Squnion>i. ?e (Y i))\<cdot>x \<sqsubseteq> x"
-      apply (rule deflation.below)
-      apply (rule admD [OF adm_deflation eY])
-      apply (rule pre_deflation.deflation_d)
-      apply (rule pre_deflation_oo [OF d below])
-      done
-    finally show "(\<Squnion>i. ?e (Y i))\<cdot>x = x" ..
-  qed
-qed
-
-subsection {* Take function for finite deflations *}
-
-definition
-  defl_take :: "nat \<Rightarrow> (udom \<rightarrow> udom) \<Rightarrow> (udom \<rightarrow> udom)"
-where
-  "defl_take i d = eventual_iterate (udom_approx i oo d)"
-
-lemma finite_deflation_defl_take:
-  "deflation d \<Longrightarrow> finite_deflation (defl_take i d)"
-unfolding defl_take_def
-apply (rule pre_deflation.finite_deflation_d)
-apply (rule pre_deflation_oo)
-apply (rule finite_deflation_udom_approx)
-apply (erule deflation.below)
-done
-
-lemma deflation_defl_take:
-  "deflation d \<Longrightarrow> deflation (defl_take i d)"
-apply (rule finite_deflation_imp_deflation)
-apply (erule finite_deflation_defl_take)
-done
-
-lemma defl_take_fixed_iff:
-  "deflation d \<Longrightarrow> defl_take i d\<cdot>x = x \<longleftrightarrow> udom_approx i\<cdot>x = x \<and> d\<cdot>x = x"
-unfolding defl_take_def
-apply (rule eventual_iterate_oo_fixed_iff)
-apply (rule finite_deflation_udom_approx)
-apply (erule deflation.below)
-done
-
-lemma defl_take_below:
-  "\<lbrakk>a \<sqsubseteq> b; deflation a; deflation b\<rbrakk> \<Longrightarrow> defl_take i a \<sqsubseteq> defl_take i b"
-apply (rule deflation.belowI)
-apply (erule deflation_defl_take)
-apply (simp add: defl_take_fixed_iff)
-apply (erule (1) deflation.belowD)
-apply (erule conjunct2)
-done
-
-lemma cont2cont_defl_take:
-  assumes cont: "cont f" and below: "\<And>x y. f x\<cdot>y \<sqsubseteq> y"
-  shows "cont (\<lambda>x. defl_take i (f x))"
-unfolding defl_take_def
-using finite_deflation_udom_approx assms
-by (rule cont2cont_eventual_iterate_oo)
-
-definition
-  fd_take :: "nat \<Rightarrow> fin_defl \<Rightarrow> fin_defl"
-where
-  "fd_take i d = Abs_fin_defl (defl_take i (Rep_fin_defl d))"
-
-lemma Rep_fin_defl_fd_take:
-  "Rep_fin_defl (fd_take i d) = defl_take i (Rep_fin_defl d)"
-unfolding fd_take_def
-apply (rule Abs_fin_defl_inverse [unfolded mem_Collect_eq])
-apply (rule finite_deflation_defl_take)
-apply (rule deflation_Rep_fin_defl)
-done
-
-lemma fd_take_fixed_iff:
-  "Rep_fin_defl (fd_take i d)\<cdot>x = x \<longleftrightarrow>
-    udom_approx i\<cdot>x = x \<and> Rep_fin_defl d\<cdot>x = x"
-unfolding Rep_fin_defl_fd_take
-apply (rule defl_take_fixed_iff)
-apply (rule deflation_Rep_fin_defl)
-done
-
-lemma fd_take_below: "fd_take n d \<sqsubseteq> d"
-apply (rule fin_defl_belowI)
-apply (simp add: fd_take_fixed_iff)
-done
-
-lemma fd_take_idem: "fd_take n (fd_take n d) = fd_take n d"
-apply (rule fin_defl_eqI)
-apply (simp add: fd_take_fixed_iff)
-done
-
-lemma fd_take_mono: "a \<sqsubseteq> b \<Longrightarrow> fd_take n a \<sqsubseteq> fd_take n b"
-apply (rule fin_defl_belowI)
-apply (simp add: fd_take_fixed_iff)
-apply (simp add: fin_defl_belowD)
-done
-
-lemma approx_fixed_le_lemma: "\<lbrakk>i \<le> j; udom_approx i\<cdot>x = x\<rbrakk> \<Longrightarrow> udom_approx j\<cdot>x = x"
-apply (rule deflation.belowD)
-apply (rule finite_deflation_imp_deflation)
-apply (rule finite_deflation_udom_approx)
-apply (erule chain_mono [OF chain_udom_approx])
-apply assumption
-done
-
-lemma fd_take_chain: "m \<le> n \<Longrightarrow> fd_take m a \<sqsubseteq> fd_take n a"
-apply (rule fin_defl_belowI)
-apply (simp add: fd_take_fixed_iff)
-apply (simp add: approx_fixed_le_lemma)
-done
-
-lemma finite_range_fd_take: "finite (range (fd_take n))"
-apply (rule finite_imageD [where f="\<lambda>a. {x. Rep_fin_defl a\<cdot>x = x}"])
-apply (rule finite_subset [where B="Pow {x. udom_approx n\<cdot>x = x}"])
-apply (clarify, simp add: fd_take_fixed_iff)
-apply (simp add: finite_deflation.finite_fixes [OF finite_deflation_udom_approx])
-apply (rule inj_onI, clarify)
-apply (simp add: set_eq_iff fin_defl_eqI)
-done
-
-lemma fd_take_covers: "\<exists>n. fd_take n a = a"
-apply (rule_tac x=
-  "Max ((\<lambda>x. LEAST n. udom_approx n\<cdot>x = x) ` {x. Rep_fin_defl a\<cdot>x = x})" in exI)
-apply (rule below_antisym)
-apply (rule fd_take_below)
-apply (rule fin_defl_belowI)
-apply (simp add: fd_take_fixed_iff)
-apply (rule approx_fixed_le_lemma)
-apply (rule Max_ge)
-apply (rule finite_imageI)
-apply (rule Rep_fin_defl.finite_fixes)
-apply (rule imageI)
-apply (erule CollectI)
-apply (rule LeastI_ex)
-apply (rule approx_chain.compact_eq_approx [OF udom_approx])
-apply (erule subst)
-apply (rule Rep_fin_defl.compact)
-done
-
-subsection {* Chain of approx functions on algebraic deflations *}
-
-definition
-  defl_approx :: "nat \<Rightarrow> defl \<rightarrow> defl"
-where
-  "defl_approx = (\<lambda>i. defl.basis_fun (\<lambda>d. defl_principal (fd_take i d)))"
-
-lemma defl_approx_principal:
-  "defl_approx i\<cdot>(defl_principal d) = defl_principal (fd_take i d)"
-unfolding defl_approx_def
-by (simp add: defl.basis_fun_principal fd_take_mono)
-
-lemma defl_approx: "approx_chain defl_approx"
-proof
-  show chain: "chain defl_approx"
-    unfolding defl_approx_def
-    by (simp add: chainI defl.basis_fun_mono fd_take_mono fd_take_chain)
-  show idem: "\<And>i x. defl_approx i\<cdot>(defl_approx i\<cdot>x) = defl_approx i\<cdot>x"
-    apply (induct_tac x rule: defl.principal_induct, simp)
-    apply (simp add: defl_approx_principal fd_take_idem)
-    done
-  show below: "\<And>i x. defl_approx i\<cdot>x \<sqsubseteq> x"
-    apply (induct_tac x rule: defl.principal_induct, simp)
-    apply (simp add: defl_approx_principal fd_take_below)
-    done
-  show lub: "(\<Squnion>i. defl_approx i) = ID"
-    apply (rule cfun_eqI, rule below_antisym)
-    apply (simp add: contlub_cfun_fun chain lub_below_iff chain below)
-    apply (induct_tac x rule: defl.principal_induct, simp)
-    apply (simp add: contlub_cfun_fun chain)
-    apply (simp add: compact_below_lub_iff defl.compact_principal chain)
-    apply (simp add: defl_approx_principal)
-    apply (subgoal_tac "\<exists>i. fd_take i a = a", metis below_refl)
-    apply (rule fd_take_covers)
-    done
-  show "\<And>i. finite {x. defl_approx i\<cdot>x = x}"
-    apply (rule finite_range_imp_finite_fixes)
-    apply (rule_tac B="defl_principal ` range (fd_take i)" in rev_finite_subset)
-    apply (simp add: finite_range_fd_take)
-    apply (clarsimp, rename_tac x)
-    apply (induct_tac x rule: defl.principal_induct)
-    apply (simp add: adm_mem_finite finite_range_fd_take)
-    apply (simp add: defl_approx_principal)
-    done
-qed
-
-subsection {* Algebraic deflations are a bifinite domain *}
-
-instantiation defl :: liftdomain
-begin
-
-definition
-  "emb = udom_emb defl_approx"
-
-definition
-  "prj = udom_prj defl_approx"
-
-definition
-  "defl (t::defl itself) =
-    (\<Squnion>i. defl_principal (Abs_fin_defl (emb oo defl_approx i oo prj)))"
-
-definition
-  "(liftemb :: defl u \<rightarrow> udom) = udom_emb u_approx oo u_map\<cdot>emb"
-
-definition
-  "(liftprj :: udom \<rightarrow> defl u) = u_map\<cdot>prj oo udom_prj u_approx"
-
-definition
-  "liftdefl (t::defl itself) = u_defl\<cdot>DEFL(defl)"
-
-instance
-using liftemb_defl_def liftprj_defl_def liftdefl_defl_def
-proof (rule liftdomain_class_intro)
-  show ep: "ep_pair emb (prj :: udom \<rightarrow> defl)"
-    unfolding emb_defl_def prj_defl_def
-    by (rule ep_pair_udom [OF defl_approx])
-  show "cast\<cdot>DEFL(defl) = emb oo (prj :: udom \<rightarrow> defl)"
-    unfolding defl_defl_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 approx_chain.finite_deflation_approx [OF defl_approx]
-                     ep_pair.finite_deflation_e_d_p [OF ep])
-    apply (intro monofun_cfun below_refl)
-    apply (rule chainE)
-    apply (rule approx_chain.chain_approx [OF defl_approx])
-    apply (subst cast_defl_principal)
-    apply (simp add: Abs_fin_defl_inverse approx_chain.finite_deflation_approx [OF defl_approx]
-                     ep_pair.finite_deflation_e_d_p [OF ep])
-    apply (simp add: lub_distribs approx_chain.chain_approx [OF defl_approx]
-                     approx_chain.lub_approx [OF defl_approx])
-    done
-qed
-
-end
-
-end

--- a/src/HOLCF/Library/HOLCF_Library.thy	Sat Nov 27 14:34:54 2010 -0800
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,9 +0,0 @@
-theory HOLCF_Library
-imports
-  Defl_Bifinite
-  List_Cpo
-  Stream
-  Sum_Cpo
-begin
-
-end

--- a/src/HOLCF/Library/List_Cpo.thy	Sat Nov 27 14:34:54 2010 -0800
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,268 +0,0 @@
-(*  Title:      HOLCF/Library/List_Cpo.thy
-    Author:     Brian Huffman
-*)
-
-header {* Lists as a complete partial order *}
-
-theory List_Cpo
-imports HOLCF
-begin
-
-subsection {* Lists are a partial order *}
-
-instantiation list :: (po) po
-begin
-
-definition
-  "xs \<sqsubseteq> ys \<longleftrightarrow> list_all2 (op \<sqsubseteq>) xs ys"
-
-instance proof
-  fix xs :: "'a list"
-  from below_refl show "xs \<sqsubseteq> xs"
-    unfolding below_list_def
-    by (rule list_all2_refl)
-next
-  fix xs ys zs :: "'a list"
-  assume "xs \<sqsubseteq> ys" and "ys \<sqsubseteq> zs"
-  with below_trans show "xs \<sqsubseteq> zs"
-    unfolding below_list_def
-    by (rule list_all2_trans)
-next
-  fix xs ys zs :: "'a list"
-  assume "xs \<sqsubseteq> ys" and "ys \<sqsubseteq> xs"
-  with below_antisym show "xs = ys"
-    unfolding below_list_def
-    by (rule list_all2_antisym)
-qed
-
-end
-
-lemma below_list_simps [simp]:
-  "[] \<sqsubseteq> []"
-  "x # xs \<sqsubseteq> y # ys \<longleftrightarrow> x \<sqsubseteq> y \<and> xs \<sqsubseteq> ys"
-  "\<not> [] \<sqsubseteq> y # ys"
-  "\<not> x # xs \<sqsubseteq> []"
-by (simp_all add: below_list_def)
-
-lemma Nil_below_iff [simp]: "[] \<sqsubseteq> xs \<longleftrightarrow> xs = []"
-by (cases xs, simp_all)
-
-lemma below_Nil_iff [simp]: "xs \<sqsubseteq> [] \<longleftrightarrow> xs = []"
-by (cases xs, simp_all)
-
-lemma list_below_induct [consumes 1, case_names Nil Cons]:
-  assumes "xs \<sqsubseteq> ys"
-  assumes 1: "P [] []"
-  assumes 2: "\<And>x y xs ys. \<lbrakk>x \<sqsubseteq> y; xs \<sqsubseteq> ys; P xs ys\<rbrakk> \<Longrightarrow> P (x # xs) (y # ys)"
-  shows "P xs ys"
-using `xs \<sqsubseteq> ys`
-proof (induct xs arbitrary: ys)
-  case Nil thus ?case by (simp add: 1)
-next
-  case (Cons x xs) thus ?case by (cases ys, simp_all add: 2)
-qed
-
-lemma list_below_cases:
-  assumes "xs \<sqsubseteq> ys"
-  obtains "xs = []" and "ys = []" |
-    x y xs' ys' where "xs = x # xs'" and "ys = y # ys'"
-using assms by (cases xs, simp, cases ys, auto)
-
-text "Thanks to Joachim Breitner"
-
-lemma list_Cons_below:
-  assumes "a # as \<sqsubseteq> xs"
-  obtains b and bs where "a \<sqsubseteq> b" and "as \<sqsubseteq> bs" and "xs = b # bs"
-  using assms by (cases xs, auto)
-
-lemma list_below_Cons:
-  assumes "xs \<sqsubseteq> b # bs"
-  obtains a and as where "a \<sqsubseteq> b" and "as \<sqsubseteq> bs" and "xs = a # as"
-  using assms by (cases xs, auto)
-
-lemma hd_mono: "xs \<sqsubseteq> ys \<Longrightarrow> hd xs \<sqsubseteq> hd ys"
-by (cases xs, simp, cases ys, simp, simp)
-
-lemma tl_mono: "xs \<sqsubseteq> ys \<Longrightarrow> tl xs \<sqsubseteq> tl ys"
-by (cases xs, simp, cases ys, simp, simp)
-
-lemma ch2ch_hd [simp]: "chain (\<lambda>i. S i) \<Longrightarrow> chain (\<lambda>i. hd (S i))"
-by (rule chainI, rule hd_mono, erule chainE)
-
-lemma ch2ch_tl [simp]: "chain (\<lambda>i. S i) \<Longrightarrow> chain (\<lambda>i. tl (S i))"
-by (rule chainI, rule tl_mono, erule chainE)
-
-lemma below_same_length: "xs \<sqsubseteq> ys \<Longrightarrow> length xs = length ys"
-unfolding below_list_def by (rule list_all2_lengthD)
-
-lemma list_chain_induct [consumes 1, case_names Nil Cons]:
-  assumes "chain S"
-  assumes 1: "P (\<lambda>i. [])"
-  assumes 2: "\<And>A B. chain A \<Longrightarrow> chain B \<Longrightarrow> P B \<Longrightarrow> P (\<lambda>i. A i # B i)"
-  shows "P S"
-using `chain S`
-proof (induct "S 0" arbitrary: S)
-  case Nil
-  have "\<forall>i. S 0 \<sqsubseteq> S i" by (simp add: chain_mono [OF `chain S`])
-  with Nil have "\<forall>i. S i = []" by simp
-  thus ?case by (simp add: 1)
-next
-  case (Cons x xs)
-  have "\<forall>i. S 0 \<sqsubseteq> S i" by (simp add: chain_mono [OF `chain S`])
-  hence *: "\<forall>i. S i \<noteq> []" by (rule all_forward, insert Cons) auto
-  have "chain (\<lambda>i. hd (S i))" and "chain (\<lambda>i. tl (S i))"
-    using `chain S` by simp_all
-  moreover have "P (\<lambda>i. tl (S i))"
-    using `chain S` and `x # xs = S 0` [symmetric]
-    by (simp add: Cons(1))
-  ultimately have "P (\<lambda>i. hd (S i) # tl (S i))"
-    by (rule 2)
-  thus "P S" by (simp add: *)
-qed
-
-lemma list_chain_cases:
-  assumes S: "chain S"
-  obtains "S = (\<lambda>i. [])" |
-    A B where "chain A" and "chain B" and "S = (\<lambda>i. A i # B i)"
-using S by (induct rule: list_chain_induct) simp_all
-
-subsection {* Lists are a complete partial order *}
-
-lemma is_lub_Cons:
-  assumes A: "range A <<| x"
-  assumes B: "range B <<| xs"
-  shows "range (\<lambda>i. A i # B i) <<| x # xs"
-using assms
-unfolding is_lub_def is_ub_def
-by (clarsimp, case_tac u, simp_all)
-
-instance list :: (cpo) cpo
-proof
-  fix S :: "nat \<Rightarrow> 'a list"
-  assume "chain S" thus "\<exists>x. range S <<| x"
-  proof (induct rule: list_chain_induct)
-    case Nil thus ?case by (auto intro: is_lub_const)
-  next
-    case (Cons A B) thus ?case by (auto intro: is_lub_Cons cpo_lubI)
-  qed
-qed
-
-subsection {* Continuity of list operations *}
-
-lemma cont2cont_Cons [simp, cont2cont]:
-  assumes f: "cont (\<lambda>x. f x)"
-  assumes g: "cont (\<lambda>x. g x)"
-  shows "cont (\<lambda>x. f x # g x)"
-apply (rule contI)
-apply (rule is_lub_Cons)
-apply (erule contE [OF f])
-apply (erule contE [OF g])
-done
-
-lemma lub_Cons:
-  fixes A :: "nat \<Rightarrow> 'a::cpo"
-  assumes A: "chain A" and B: "chain B"
-  shows "(\<Squnion>i. A i # B i) = (\<Squnion>i. A i) # (\<Squnion>i. B i)"
-by (intro lub_eqI is_lub_Cons cpo_lubI A B)
-
-lemma cont2cont_list_case:
-  assumes f: "cont (\<lambda>x. f x)"
-  assumes g: "cont (\<lambda>x. g x)"
-  assumes h1: "\<And>y ys. cont (\<lambda>x. h x y ys)"
-  assumes h2: "\<And>x ys. cont (\<lambda>y. h x y ys)"
-  assumes h3: "\<And>x y. cont (\<lambda>ys. h x y ys)"
-  shows "cont (\<lambda>x. case f x of [] \<Rightarrow> g x | y # ys \<Rightarrow> h x y ys)"
-apply (rule cont_apply [OF f])
-apply (rule contI)
-apply (erule list_chain_cases)
-apply (simp add: is_lub_const)
-apply (simp add: lub_Cons)
-apply (simp add: cont2contlubE [OF h2])
-apply (simp add: cont2contlubE [OF h3])
-apply (simp add: diag_lub ch2ch_cont [OF h2] ch2ch_cont [OF h3])
-apply (rule cpo_lubI, rule chainI, rule below_trans)
-apply (erule cont2monofunE [OF h2 chainE])
-apply (erule cont2monofunE [OF h3 chainE])
-apply (case_tac y, simp_all add: g h1)
-done
-
-lemma cont2cont_list_case' [simp, cont2cont]:
-  assumes f: "cont (\<lambda>x. f x)"
-  assumes g: "cont (\<lambda>x. g x)"
-  assumes h: "cont (\<lambda>p. h (fst p) (fst (snd p)) (snd (snd p)))"
-  shows "cont (\<lambda>x. case f x of [] \<Rightarrow> g x | y # ys \<Rightarrow> h x y ys)"
-using assms by (simp add: cont2cont_list_case prod_cont_iff)
-
-text {* The simple version (due to Joachim Breitner) is needed if the
-  element type of the list is not a cpo. *}
-
-lemma cont2cont_list_case_simple [simp, cont2cont]:
-  assumes "cont (\<lambda>x. f1 x)"
-  assumes "\<And>y ys. cont (\<lambda>x. f2 x y ys)"
-  shows "cont (\<lambda>x. case l of [] \<Rightarrow> f1 x | y # ys \<Rightarrow> f2 x y ys)"
-using assms by (cases l) auto
-
-text {* Lemma for proving continuity of recursive list functions: *}
-
-lemma list_contI:
-  fixes f :: "'a::cpo list \<Rightarrow> 'b::cpo"
-  assumes f: "\<And>x xs. f (x # xs) = g x xs (f xs)"
-  assumes g1: "\<And>xs y. cont (\<lambda>x. g x xs y)"
-  assumes g2: "\<And>x y. cont (\<lambda>xs. g x xs y)"
-  assumes g3: "\<And>x xs. cont (\<lambda>y. g x xs y)"
-  shows "cont f"
-proof (rule contI2)
-  obtain h where h: "\<And>x xs y. g x xs y = h\<cdot>x\<cdot>xs\<cdot>y"
-  proof
-    fix x xs y show "g x xs y = (\<Lambda> x xs y. g x xs y)\<cdot>x\<cdot>xs\<cdot>y"
-    by (simp add: cont2cont_LAM g1 g2 g3)
-  qed
-  show mono: "monofun f"
-    apply (rule monofunI)
-    apply (erule list_below_induct)
-    apply simp
-    apply (simp add: f h monofun_cfun)
-    done
-  fix Y :: "nat \<Rightarrow> 'a list"
-  assume "chain Y" thus "f (\<Squnion>i. Y i) \<sqsubseteq> (\<Squnion>i. f (Y i))"
-    apply (induct rule: list_chain_induct)
-    apply simp
-    apply (simp add: lub_Cons f h)
-    apply (simp add: contlub_cfun [symmetric] ch2ch_monofun [OF mono])
-    apply (simp add: monofun_cfun)
-    done
-qed
-
-text {* There are probably lots of other list operations that also
-deserve to have continuity lemmas.  I'll add more as they are
-needed. *}
-
-subsection {* Using lists with fixrec *}
-
-definition
-  match_Nil :: "'a::cpo list \<rightarrow> 'b match \<rightarrow> 'b match"
-where
-  "match_Nil = (\<Lambda> xs k. case xs of [] \<Rightarrow> k | y # ys \<Rightarrow> Fixrec.fail)"
-
-definition
-  match_Cons :: "'a::cpo list \<rightarrow> ('a \<rightarrow> 'a list \<rightarrow> 'b match) \<rightarrow> 'b match"
-where
-  "match_Cons = (\<Lambda> xs k. case xs of [] \<Rightarrow> Fixrec.fail | y # ys \<Rightarrow> k\<cdot>y\<cdot>ys)"
-
-lemma match_Nil_simps [simp]:
-  "match_Nil\<cdot>[]\<cdot>k = k"
-  "match_Nil\<cdot>(x # xs)\<cdot>k = Fixrec.fail"
-unfolding match_Nil_def by simp_all
-
-lemma match_Cons_simps [simp]:
-  "match_Cons\<cdot>[]\<cdot>k = Fixrec.fail"
-  "match_Cons\<cdot>(x # xs)\<cdot>k = k\<cdot>x\<cdot>xs"
-unfolding match_Cons_def by simp_all
-
-setup {*
-  Fixrec.add_matchers
-    [ (@{const_name Nil}, @{const_name match_Nil}),
-      (@{const_name Cons}, @{const_name match_Cons}) ]
-*}
-
-end

--- a/src/HOLCF/Library/ROOT.ML	Sat Nov 27 14:34:54 2010 -0800
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,1 +0,0 @@
-use_thys ["HOLCF_Library"];

--- a/src/HOLCF/Library/Stream.thy	Sat Nov 27 14:34:54 2010 -0800
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,967 +0,0 @@
-(*  Title:      HOLCF/ex/Stream.thy
-    Author:     Franz Regensburger, David von Oheimb, Borislav Gajanovic
-*)
-
-header {* General Stream domain *}
-
-theory Stream
-imports HOLCF Nat_Infinity
-begin
-
-default_sort pcpo
-
-domain (unsafe) 'a stream = scons (ft::'a) (lazy rt::"'a stream") (infixr "&&" 65)
-
-definition
-  smap :: "('a \<rightarrow> 'b) \<rightarrow> 'a stream \<rightarrow> 'b stream" where
-  "smap = fix\<cdot>(\<Lambda> h f s. case s of x && xs \<Rightarrow> f\<cdot>x && h\<cdot>f\<cdot>xs)"
-
-definition
-  sfilter :: "('a \<rightarrow> tr) \<rightarrow> 'a stream \<rightarrow> 'a stream" where
-  "sfilter = fix\<cdot>(\<Lambda> h p s. case s of x && xs \<Rightarrow>
-                                     If p\<cdot>x then x && h\<cdot>p\<cdot>xs else h\<cdot>p\<cdot>xs)"
-
-definition
-  slen :: "'a stream \<Rightarrow> inat"  ("#_" [1000] 1000) where
-  "#s = (if stream_finite s then Fin (LEAST n. stream_take n\<cdot>s = s) else \<infinity>)"
-
-
-(* concatenation *)
-
-definition
-  i_rt :: "nat => 'a stream => 'a stream" where (* chops the first i elements *)
-  "i_rt = (%i s. iterate i$rt$s)"
-
-definition
-  i_th :: "nat => 'a stream => 'a" where (* the i-th element *)
-  "i_th = (%i s. ft$(i_rt i s))"
-
-definition
-  sconc :: "'a stream => 'a stream => 'a stream"  (infixr "ooo" 65) where
-  "s1 ooo s2 = (case #s1 of
-                  Fin n \<Rightarrow> (SOME s. (stream_take n$s=s1) & (i_rt n s = s2))
-               | \<infinity>     \<Rightarrow> s1)"
-
-primrec constr_sconc' :: "nat => 'a stream => 'a stream => 'a stream"
-where
-  constr_sconc'_0:   "constr_sconc' 0 s1 s2 = s2"
-| constr_sconc'_Suc: "constr_sconc' (Suc n) s1 s2 = ft$s1 &&
-                                                    constr_sconc' n (rt$s1) s2"
-
-definition
-  constr_sconc  :: "'a stream => 'a stream => 'a stream" where (* constructive *)
-  "constr_sconc s1 s2 = (case #s1 of
-                          Fin n \<Rightarrow> constr_sconc' n s1 s2
-                        | \<infinity>    \<Rightarrow> s1)"
-
-
-(* ----------------------------------------------------------------------- *)
-(* theorems about scons                                                    *)
-(* ----------------------------------------------------------------------- *)
-
-
-section "scons"
-
-lemma scons_eq_UU: "(a && s = UU) = (a = UU)"
-by simp
-
-lemma scons_not_empty: "[| a && x = UU; a ~= UU |] ==> R"
-by simp
-
-lemma stream_exhaust_eq: "(x ~= UU) = (EX a y. a ~= UU &  x = a && y)"
-by (cases x, auto)
-
-lemma stream_neq_UU: "x~=UU ==> EX a a_s. x=a&&a_s & a~=UU"
-by (simp add: stream_exhaust_eq,auto)
-
-lemma stream_prefix:
-  "[| a && s << t; a ~= UU  |] ==> EX b tt. t = b && tt &  b ~= UU &  s << tt"
-by (cases t, auto)
-
-lemma stream_prefix':
-  "b ~= UU ==> x << b && z =
-   (x = UU |  (EX a y. x = a && y &  a ~= UU &  a << b &  y << z))"
-by (cases x, auto)
-
-
-(*
-lemma stream_prefix1: "[| x<<y; xs<<ys |] ==> x&&xs << y&&ys"
-by (insert stream_prefix' [of y "x&&xs" ys],force)
-*)
-
-lemma stream_flat_prefix:
-  "[| x && xs << y && ys; (x::'a::flat) ~= UU|] ==> x = y & xs << ys"
-apply (case_tac "y=UU",auto)
-by (drule ax_flat,simp)
-
-
-
-
-(* ----------------------------------------------------------------------- *)
-(* theorems about stream_case                                              *)
-(* ----------------------------------------------------------------------- *)
-
-section "stream_case"
-
-
-lemma stream_case_strictf: "stream_case$UU$s=UU"
-by (cases s, auto)
-
-
-
-(* ----------------------------------------------------------------------- *)
-(* theorems about ft and rt                                                *)
-(* ----------------------------------------------------------------------- *)
-
-
-section "ft & rt"
-
-
-lemma ft_defin: "s~=UU ==> ft$s~=UU"
-by simp
-
-lemma rt_strict_rev: "rt$s~=UU ==> s~=UU"
-by auto
-
-lemma surjectiv_scons: "(ft$s)&&(rt$s)=s"
-by (cases s, auto)
-
-lemma monofun_rt_mult: "x << s ==> iterate i$rt$x << iterate i$rt$s"
-by (rule monofun_cfun_arg)
-
-
-
-(* ----------------------------------------------------------------------- *)
-(* theorems about stream_take                                              *)
-(* ----------------------------------------------------------------------- *)
-
-
-section "stream_take"
-
-
-lemma stream_reach2: "(LUB i. stream_take i$s) = s"
-by (rule stream.reach)
-
-lemma chain_stream_take: "chain (%i. stream_take i$s)"
-by simp
-
-lemma stream_take_prefix [simp]: "stream_take n$s << s"
-apply (insert stream_reach2 [of s])
-apply (erule subst) back
-apply (rule is_ub_thelub)
-by (simp only: chain_stream_take)
-
-lemma stream_take_more [rule_format]:
-  "ALL x. stream_take n$x = x --> stream_take (Suc n)$x = x"
-apply (induct_tac n,auto)
-apply (case_tac "x=UU",auto)
-by (drule stream_exhaust_eq [THEN iffD1],auto)
-
-lemma stream_take_lemma3 [rule_format]:
-  "ALL x xs. x~=UU --> stream_take n$(x && xs) = x && xs --> stream_take n$xs=xs"
-apply (induct_tac n,clarsimp)
-(*apply (drule sym, erule scons_not_empty, simp)*)
-apply (clarify, rule stream_take_more)
-apply (erule_tac x="x" in allE)
-by (erule_tac x="xs" in allE,simp)
-
-lemma stream_take_lemma4:
-  "ALL x xs. stream_take n$xs=xs --> stream_take (Suc n)$(x && xs) = x && xs"
-by auto
-
-lemma stream_take_idempotent [rule_format, simp]:
- "ALL s. stream_take n$(stream_take n$s) = stream_take n$s"
-apply (induct_tac n, auto)
-apply (case_tac "s=UU", auto)
-by (drule stream_exhaust_eq [THEN iffD1], auto)
-
-lemma stream_take_take_Suc [rule_format, simp]:
-  "ALL s. stream_take n$(stream_take (Suc n)$s) =
-                                    stream_take n$s"
-apply (induct_tac n, auto)
-apply (case_tac "s=UU", auto)
-by (drule stream_exhaust_eq [THEN iffD1], auto)
-
-lemma mono_stream_take_pred:
-  "stream_take (Suc n)$s1 << stream_take (Suc n)$s2 ==>
-                       stream_take n$s1 << stream_take n$s2"
-by (insert monofun_cfun_arg [of "stream_take (Suc n)$s1"
-  "stream_take (Suc n)$s2" "stream_take n"], auto)
-(*
-lemma mono_stream_take_pred:
-  "stream_take (Suc n)$s1 << stream_take (Suc n)$s2 ==>
-                       stream_take n$s1 << stream_take n$s2"
-by (drule mono_stream_take [of _ _ n],simp)
-*)
-
-lemma stream_take_lemma10 [rule_format]:
-  "ALL k<=n. stream_take n$s1 << stream_take n$s2
-                             --> stream_take k$s1 << stream_take k$s2"
-apply (induct_tac n,simp,clarsimp)
-apply (case_tac "k=Suc n",blast)
-apply (erule_tac x="k" in allE)
-by (drule mono_stream_take_pred,simp)
-
-lemma stream_take_le_mono : "k<=n ==> stream_take k$s1 << stream_take n$s1"
-apply (insert chain_stream_take [of s1])
-by (drule chain_mono,auto)
-
-lemma mono_stream_take: "s1 << s2 ==> stream_take n$s1 << stream_take n$s2"
-by (simp add: monofun_cfun_arg)
-
-(*
-lemma stream_take_prefix [simp]: "stream_take n$s << s"
-apply (subgoal_tac "s=(LUB n. stream_take n$s)")
- apply (erule ssubst, rule is_ub_thelub)
- apply (simp only: chain_stream_take)
-by (simp only: stream_reach2)
-*)
-
-lemma stream_take_take_less:"stream_take k$(stream_take n$s) << stream_take k$s"
-by (rule monofun_cfun_arg,auto)
-
-
-(* ------------------------------------------------------------------------- *)
-(* special induction rules                                                   *)
-(* ------------------------------------------------------------------------- *)
-
-
-section "induction"
-
-lemma stream_finite_ind:
- "[| stream_finite x; P UU; !!a s. [| a ~= UU; P s |] ==> P (a && s) |] ==> P x"
-apply (simp add: stream.finite_def,auto)
-apply (erule subst)
-by (drule stream.finite_induct [of P _ x], auto)
-
-lemma stream_finite_ind2:
-"[| P UU; !! x. x ~= UU ==> P (x && UU); !! y z s. [| y ~= UU; z ~= UU; P s |] ==> P (y && z && s )|] ==>
-                                 !s. P (stream_take n$s)"
-apply (rule nat_less_induct [of _ n],auto)
-apply (case_tac n, auto) 
-apply (case_tac nat, auto) 
-apply (case_tac "s=UU",clarsimp)
-apply (drule stream_exhaust_eq [THEN iffD1],clarsimp)
-apply (case_tac "s=UU",clarsimp)
-apply (drule stream_exhaust_eq [THEN iffD1],clarsimp)
-apply (case_tac "y=UU",clarsimp)
-by (drule stream_exhaust_eq [THEN iffD1],clarsimp)
-
-lemma stream_ind2:
-"[| adm P; P UU; !!a. a ~= UU ==> P (a && UU); !!a b s. [| a ~= UU; b ~= UU; P s |] ==> P (a && b && s) |] ==> P x"
-apply (insert stream.reach [of x],erule subst)
-apply (erule admD, rule chain_stream_take)
-apply (insert stream_finite_ind2 [of P])
-by simp
-
-
-
-(* ----------------------------------------------------------------------- *)
-(* simplify use of coinduction                                             *)
-(* ----------------------------------------------------------------------- *)
-
-
-section "coinduction"
-
-lemma stream_coind_lemma2: "!s1 s2. R s1 s2 --> ft$s1 = ft$s2 &  R (rt$s1) (rt$s2) ==> stream_bisim R"
- apply (simp add: stream.bisim_def,clarsimp)
- apply (drule spec, drule spec, drule (1) mp)
- apply (case_tac "x", simp)
- apply (case_tac "y", simp)
-by auto
-
-
-
-(* ----------------------------------------------------------------------- *)
-(* theorems about stream_finite                                            *)
-(* ----------------------------------------------------------------------- *)
-
-
-section "stream_finite"
-
-lemma stream_finite_UU [simp]: "stream_finite UU"
-by (simp add: stream.finite_def)
-
-lemma stream_finite_UU_rev: "~  stream_finite s ==> s ~= UU"
-by (auto simp add: stream.finite_def)
-
-lemma stream_finite_lemma1: "stream_finite xs ==> stream_finite (x && xs)"
-apply (simp add: stream.finite_def,auto)
-apply (rule_tac x="Suc n" in exI)
-by (simp add: stream_take_lemma4)
-
-lemma stream_finite_lemma2: "[| x ~= UU; stream_finite (x && xs) |] ==> stream_finite xs"
-apply (simp add: stream.finite_def, auto)
-apply (rule_tac x="n" in exI)
-by (erule stream_take_lemma3,simp)
-
-lemma stream_finite_rt_eq: "stream_finite (rt$s) = stream_finite s"
-apply (cases s, auto)
-apply (rule stream_finite_lemma1, simp)
-by (rule stream_finite_lemma2,simp)
-
-lemma stream_finite_less: "stream_finite s ==> !t. t<<s --> stream_finite t"
-apply (erule stream_finite_ind [of s], auto)
-apply (case_tac "t=UU", auto)
-apply (drule stream_exhaust_eq [THEN iffD1],auto)
-apply (erule_tac x="y" in allE, simp)
-by (rule stream_finite_lemma1, simp)
-
-lemma stream_take_finite [simp]: "stream_finite (stream_take n$s)"
-apply (simp add: stream.finite_def)
-by (rule_tac x="n" in exI,simp)
-
-lemma adm_not_stream_finite: "adm (%x. ~ stream_finite x)"
-apply (rule adm_upward)
-apply (erule contrapos_nn)
-apply (erule (1) stream_finite_less [rule_format])
-done
-
-
-
-(* ----------------------------------------------------------------------- *)
-(* theorems about stream length                                            *)
-(* ----------------------------------------------------------------------- *)
-
-
-section "slen"
-
-lemma slen_empty [simp]: "#\<bottom> = 0"
-by (simp add: slen_def stream.finite_def zero_inat_def Least_equality)
-
-lemma slen_scons [simp]: "x ~= \<bottom> ==> #(x&&xs) = iSuc (#xs)"
-apply (case_tac "stream_finite (x && xs)")
-apply (simp add: slen_def, auto)
-apply (simp add: stream.finite_def, auto simp add: iSuc_Fin)
-apply (rule Least_Suc2, auto)
-(*apply (drule sym)*)
-(*apply (drule sym scons_eq_UU [THEN iffD1],simp)*)
-apply (erule stream_finite_lemma2, simp)
-apply (simp add: slen_def, auto)
-by (drule stream_finite_lemma1,auto)
-
-lemma slen_less_1_eq: "(#x < Fin (Suc 0)) = (x = \<bottom>)"
-by (cases x, auto simp add: Fin_0 iSuc_Fin[THEN sym])
-
-lemma slen_empty_eq: "(#x = 0) = (x = \<bottom>)"
-by (cases x, auto)
-
-lemma slen_scons_eq: "(Fin (Suc n) < #x) = (? a y. x = a && y &  a ~= \<bottom> &  Fin n < #y)"
-apply (auto, case_tac "x=UU",auto)
-apply (drule stream_exhaust_eq [THEN iffD1], auto)
-apply (case_tac "#y") apply simp_all
-apply (case_tac "#y") apply simp_all
-done
-
-lemma slen_iSuc: "#x = iSuc n --> (? a y. x = a&&y &  a ~= \<bottom> &  #y = n)"
-by (cases x, auto)
-
-lemma slen_stream_take_finite [simp]: "#(stream_take n$s) ~= \<infinity>"
-by (simp add: slen_def)
-
-lemma slen_scons_eq_rev: "(#x < Fin (Suc (Suc n))) = (!a y. x ~= a && y |  a = \<bottom> |  #y < Fin (Suc n))"
- apply (cases x, auto)
-   apply (simp add: zero_inat_def)
-  apply (case_tac "#stream") apply (simp_all add: iSuc_Fin)
- apply (case_tac "#stream") apply (simp_all add: iSuc_Fin)
-done
-
-lemma slen_take_lemma4 [rule_format]:
-  "!s. stream_take n$s ~= s --> #(stream_take n$s) = Fin n"
-apply (induct n, auto simp add: Fin_0)
-apply (case_tac "s=UU", simp)
-by (drule stream_exhaust_eq [THEN iffD1], auto simp add: iSuc_Fin)
-
-(*
-lemma stream_take_idempotent [simp]:
- "stream_take n$(stream_take n$s) = stream_take n$s"
-apply (case_tac "stream_take n$s = s")
-apply (auto,insert slen_take_lemma4 [of n s]);
-by (auto,insert slen_take_lemma1 [of "stream_take n$s" n],simp)
-
-lemma stream_take_take_Suc [simp]: "stream_take n$(stream_take (Suc n)$s) =
-                                    stream_take n$s"
-apply (simp add: po_eq_conv,auto)
- apply (simp add: stream_take_take_less)
-apply (subgoal_tac "stream_take n$s = stream_take n$(stream_take n$s)")
- apply (erule ssubst)
- apply (rule_tac monofun_cfun_arg)
- apply (insert chain_stream_take [of s])
-by (simp add: chain_def,simp)
-*)
-
-lemma slen_take_eq: "ALL x. (Fin n < #x) = (stream_take n\<cdot>x ~= x)"
-apply (induct_tac n, auto)
-apply (simp add: Fin_0, clarsimp)
-apply (drule not_sym)
-apply (drule slen_empty_eq [THEN iffD1], simp)
-apply (case_tac "x=UU", simp)
-apply (drule stream_exhaust_eq [THEN iffD1], clarsimp)
-apply (erule_tac x="y" in allE, auto)
-apply (simp_all add: not_less iSuc_Fin)
-apply (case_tac "#y") apply simp_all
-apply (case_tac "x=UU", simp)
-apply (drule stream_exhaust_eq [THEN iffD1], clarsimp)
-apply (erule_tac x="y" in allE, simp)
-apply (case_tac "#y") by simp_all
-
-lemma slen_take_eq_rev: "(#x <= Fin n) = (stream_take n\<cdot>x = x)"
-by (simp add: linorder_not_less [symmetric] slen_take_eq)
-
-lemma slen_take_lemma1: "#x = Fin n ==> stream_take n\<cdot>x = x"
-by (rule slen_take_eq_rev [THEN iffD1], auto)
-
-lemma slen_rt_mono: "#s2 <= #s1 ==> #(rt$s2) <= #(rt$s1)"
-apply (cases s1)
- by (cases s2, simp+)+
-
-lemma slen_take_lemma5: "#(stream_take n$s) <= Fin n"
-apply (case_tac "stream_take n$s = s")
- apply (simp add: slen_take_eq_rev)
-by (simp add: slen_take_lemma4)
-
-lemma slen_take_lemma2: "!x. ~stream_finite x --> #(stream_take i\<cdot>x) = Fin i"
-apply (simp add: stream.finite_def, auto)
-by (simp add: slen_take_lemma4)
-
-lemma slen_infinite: "stream_finite x = (#x ~= Infty)"
-by (simp add: slen_def)
-
-lemma slen_mono_lemma: "stream_finite s ==> ALL t. s << t --> #s <= #t"
-apply (erule stream_finite_ind [of s], auto)
-apply (case_tac "t=UU", auto)
-apply (drule stream_exhaust_eq [THEN iffD1], auto)
-done
-
-lemma slen_mono: "s << t ==> #s <= #t"
-apply (case_tac "stream_finite t")
-apply (frule stream_finite_less)
-apply (erule_tac x="s" in allE, simp)
-apply (drule slen_mono_lemma, auto)
-by (simp add: slen_def)
-
-lemma iterate_lemma: "F$(iterate n$F$x) = iterate n$F$(F$x)"
-by (insert iterate_Suc2 [of n F x], auto)
-
-lemma slen_rt_mult [rule_format]: "!x. Fin (i + j) <= #x --> Fin j <= #(iterate i$rt$x)"
-apply (induct i, auto)
-apply (case_tac "x=UU", auto simp add: zero_inat_def)
-apply (drule stream_exhaust_eq [THEN iffD1], auto)
-apply (erule_tac x="y" in allE, auto)
-apply (simp add: not_le) apply (case_tac "#y") apply (simp_all add: iSuc_Fin)
-by (simp add: iterate_lemma)
-
-lemma slen_take_lemma3 [rule_format]:
-  "!(x::'a::flat stream) y. Fin n <= #x --> x << y --> stream_take n\<cdot>x = stream_take n\<cdot>y"
-apply (induct_tac n, auto)
-apply (case_tac "x=UU", auto)
-apply (simp add: zero_inat_def)
-apply (simp add: Suc_ile_eq)
-apply (case_tac "y=UU", clarsimp)
-apply (drule stream_exhaust_eq [THEN iffD1], clarsimp)+
-apply (erule_tac x="ya" in allE, simp)
-by (drule ax_flat, simp)
-
-lemma slen_strict_mono_lemma:
-  "stream_finite t ==> !s. #(s::'a::flat stream) = #t &  s << t --> s = t"
-apply (erule stream_finite_ind, auto)
-apply (case_tac "sa=UU", auto)
-apply (drule stream_exhaust_eq [THEN iffD1], clarsimp)
-by (drule ax_flat, simp)
-
-lemma slen_strict_mono: "[|stream_finite t; s ~= t; s << (t::'a::flat stream) |] ==> #s < #t"
-by (auto simp add: slen_mono less_le dest: slen_strict_mono_lemma)
-
-lemma stream_take_Suc_neq: "stream_take (Suc n)$s ~=s ==>
-                     stream_take n$s ~= stream_take (Suc n)$s"
-apply auto
-apply (subgoal_tac "stream_take n$s ~=s")
- apply (insert slen_take_lemma4 [of n s],auto)
-apply (cases s, simp)
-by (simp add: slen_take_lemma4 iSuc_Fin)
-
-(* ----------------------------------------------------------------------- *)
-(* theorems about smap                                                     *)
-(* ----------------------------------------------------------------------- *)
-
-
-section "smap"
-
-lemma smap_unfold: "smap = (\<Lambda> f t. case t of x&&xs \<Rightarrow> f$x && smap$f$xs)"
-by (insert smap_def [where 'a='a and 'b='b, THEN eq_reflection, THEN fix_eq2], auto)
-
-lemma smap_empty [simp]: "smap\<cdot>f\<cdot>\<bottom> = \<bottom>"
-by (subst smap_unfold, simp)
-
-lemma smap_scons [simp]: "x~=\<bottom> ==> smap\<cdot>f\<cdot>(x&&xs) = (f\<cdot>x)&&(smap\<cdot>f\<cdot>xs)"
-by (subst smap_unfold, force)
-
-
-
-(* ----------------------------------------------------------------------- *)
-(* theorems about sfilter                                                  *)
-(* ----------------------------------------------------------------------- *)
-
-section "sfilter"
-
-lemma sfilter_unfold:
- "sfilter = (\<Lambda> p s. case s of x && xs \<Rightarrow>
-  If p\<cdot>x then x && sfilter\<cdot>p\<cdot>xs else sfilter\<cdot>p\<cdot>xs)"
-by (insert sfilter_def [where 'a='a, THEN eq_reflection, THEN fix_eq2], auto)
-
-lemma strict_sfilter: "sfilter\<cdot>\<bottom> = \<bottom>"
-apply (rule cfun_eqI)
-apply (subst sfilter_unfold, auto)
-apply (case_tac "x=UU", auto)
-by (drule stream_exhaust_eq [THEN iffD1], auto)
-
-lemma sfilter_empty [simp]: "sfilter\<cdot>f\<cdot>\<bottom> = \<bottom>"
-by (subst sfilter_unfold, force)
-
-lemma sfilter_scons [simp]:
-  "x ~= \<bottom> ==> sfilter\<cdot>f\<cdot>(x && xs) =
-                           If f\<cdot>x then x && sfilter\<cdot>f\<cdot>xs else sfilter\<cdot>f\<cdot>xs"
-by (subst sfilter_unfold, force)
-
-
-(* ----------------------------------------------------------------------- *)
-   section "i_rt"
-(* ----------------------------------------------------------------------- *)
-
-lemma i_rt_UU [simp]: "i_rt n UU = UU"
-  by (induct n) (simp_all add: i_rt_def)
-
-lemma i_rt_0 [simp]: "i_rt 0 s = s"
-by (simp add: i_rt_def)
-
-lemma i_rt_Suc [simp]: "a ~= UU ==> i_rt (Suc n) (a&&s) = i_rt n s"
-by (simp add: i_rt_def iterate_Suc2 del: iterate_Suc)
-
-lemma i_rt_Suc_forw: "i_rt (Suc n) s = i_rt n (rt$s)"
-by (simp only: i_rt_def iterate_Suc2)
-
-lemma i_rt_Suc_back:"i_rt (Suc n) s = rt$(i_rt n s)"
-by (simp only: i_rt_def,auto)
-
-lemma i_rt_mono: "x << s ==> i_rt n x  << i_rt n s"
-by (simp add: i_rt_def monofun_rt_mult)
-
-lemma i_rt_ij_lemma: "Fin (i + j) <= #x ==> Fin j <= #(i_rt i x)"
-by (simp add: i_rt_def slen_rt_mult)
-
-lemma slen_i_rt_mono: "#s2 <= #s1 ==> #(i_rt n s2) <= #(i_rt n s1)"
-apply (induct_tac n,auto)
-apply (simp add: i_rt_Suc_back)
-by (drule slen_rt_mono,simp)
-
-lemma i_rt_take_lemma1 [rule_format]: "ALL s. i_rt n (stream_take n$s) = UU"
-apply (induct_tac n)
- apply (simp add: i_rt_Suc_back,auto)
-apply (case_tac "s=UU",auto)
-by (drule stream_exhaust_eq [THEN iffD1],auto)
-
-lemma i_rt_slen: "(i_rt n s = UU) = (stream_take n$s = s)"
-apply auto
- apply (insert i_rt_ij_lemma [of n "Suc 0" s])
- apply (subgoal_tac "#(i_rt n s)=0")
-  apply (case_tac "stream_take n$s = s",simp+)
-  apply (insert slen_take_eq [rule_format,of n s],simp)
-  apply (cases "#s") apply (simp_all add: zero_inat_def)
-  apply (simp add: slen_take_eq)
-  apply (cases "#s")
-  using i_rt_take_lemma1 [of n s]
-  apply (simp_all add: zero_inat_def)
-  done
-
-lemma i_rt_lemma_slen: "#s=Fin n ==> i_rt n s = UU"
-by (simp add: i_rt_slen slen_take_lemma1)
-
-lemma stream_finite_i_rt [simp]: "stream_finite (i_rt n s) = stream_finite s"
-apply (induct_tac n, auto)
- apply (cases s, auto simp del: i_rt_Suc)
-by (simp add: i_rt_Suc_back stream_finite_rt_eq)+
-
-lemma take_i_rt_len_lemma: "ALL sl x j t. Fin sl = #x & n <= sl &
-                            #(stream_take n$x) = Fin t & #(i_rt n x)= Fin j
-                                              --> Fin (j + t) = #x"
-apply (induct n, auto)
- apply (simp add: zero_inat_def)
-apply (case_tac "x=UU",auto)
- apply (simp add: zero_inat_def)
-apply (drule stream_exhaust_eq [THEN iffD1],clarsimp)
-apply (subgoal_tac "EX k. Fin k = #y",clarify)
- apply (erule_tac x="k" in allE)
- apply (erule_tac x="y" in allE,auto)
- apply (erule_tac x="THE p. Suc p = t" in allE,auto)
-   apply (simp add: iSuc_def split: inat.splits)
-  apply (simp add: iSuc_def split: inat.splits)
-  apply (simp only: the_equality)
- apply (simp add: iSuc_def split: inat.splits)
- apply force
-apply (simp add: iSuc_def split: inat.splits)
-done
-
-lemma take_i_rt_len:
-"[| Fin sl = #x; n <= sl; #(stream_take n$x) = Fin t; #(i_rt n x) = Fin j |] ==>
-    Fin (j + t) = #x"
-by (blast intro: take_i_rt_len_lemma [rule_format])
-
-
-(* ----------------------------------------------------------------------- *)
-   section "i_th"
-(* ----------------------------------------------------------------------- *)
-
-lemma i_th_i_rt_step:
-"[| i_th n s1 << i_th n s2; i_rt (Suc n) s1 << i_rt (Suc n) s2 |] ==>
-   i_rt n s1 << i_rt n s2"
-apply (simp add: i_th_def i_rt_Suc_back)
-apply (cases "i_rt n s1", simp)
-apply (cases "i_rt n s2", auto)
-done
-
-lemma i_th_stream_take_Suc [rule_format]:
- "ALL s. i_th n (stream_take (Suc n)$s) = i_th n s"
-apply (induct_tac n,auto)
- apply (simp add: i_th_def)
- apply (case_tac "s=UU",auto)
- apply (drule stream_exhaust_eq [THEN iffD1],auto)
-apply (case_tac "s=UU",simp add: i_th_def)
-apply (drule stream_exhaust_eq [THEN iffD1],auto)
-by (simp add: i_th_def i_rt_Suc_forw)
-
-lemma i_th_last: "i_th n s && UU = i_rt n (stream_take (Suc n)$s)"
-apply (insert surjectiv_scons [of "i_rt n (stream_take (Suc n)$s)"])
-apply (rule i_th_stream_take_Suc [THEN subst])
-apply (simp add: i_th_def  i_rt_Suc_back [symmetric])
-by (simp add: i_rt_take_lemma1)
-
-lemma i_th_last_eq:
-"i_th n s1 = i_th n s2 ==> i_rt n (stream_take (Suc n)$s1) = i_rt n (stream_take (Suc n)$s2)"
-apply (insert i_th_last [of n s1])
-apply (insert i_th_last [of n s2])
-by auto
-
-lemma i_th_prefix_lemma:
-"[| k <= n; stream_take (Suc n)$s1 << stream_take (Suc n)$s2 |] ==>
-    i_th k s1 << i_th k s2"
-apply (insert i_th_stream_take_Suc [of k s1, THEN sym])
-apply (insert i_th_stream_take_Suc [of k s2, THEN sym],auto)
-apply (simp add: i_th_def)
-apply (rule monofun_cfun, auto)
-apply (rule i_rt_mono)
-by (blast intro: stream_take_lemma10)
-
-lemma take_i_rt_prefix_lemma1:
-  "stream_take (Suc n)$s1 << stream_take (Suc n)$s2 ==>
-   i_rt (Suc n) s1 << i_rt (Suc n) s2 ==>
-   i_rt n s1 << i_rt n s2 & stream_take n$s1 << stream_take n$s2"
-apply auto
- apply (insert i_th_prefix_lemma [of n n s1 s2])
- apply (rule i_th_i_rt_step,auto)
-by (drule mono_stream_take_pred,simp)
-
-lemma take_i_rt_prefix_lemma:
-"[| stream_take n$s1 << stream_take n$s2; i_rt n s1 << i_rt n s2 |] ==> s1 << s2"
-apply (case_tac "n=0",simp)
-apply (auto)
-apply (subgoal_tac "stream_take 0$s1 << stream_take 0$s2 &
-                    i_rt 0 s1 << i_rt 0 s2")
- defer 1
- apply (rule zero_induct,blast)
- apply (blast dest: take_i_rt_prefix_lemma1)
-by simp
-
-lemma streams_prefix_lemma: "(s1 << s2) =
-  (stream_take n$s1 << stream_take n$s2 & i_rt n s1 << i_rt n s2)"
-apply auto
-  apply (simp add: monofun_cfun_arg)
- apply (simp add: i_rt_mono)
-by (erule take_i_rt_prefix_lemma,simp)
-
-lemma streams_prefix_lemma1:
- "[| stream_take n$s1 = stream_take n$s2; i_rt n s1 = i_rt n s2 |] ==> s1 = s2"
-apply (simp add: po_eq_conv,auto)
- apply (insert streams_prefix_lemma)
- by blast+
-
-
-(* ----------------------------------------------------------------------- *)
-   section "sconc"
-(* ----------------------------------------------------------------------- *)
-
-lemma UU_sconc [simp]: " UU ooo s = s "
-by (simp add: sconc_def zero_inat_def)
-
-lemma scons_neq_UU: "a~=UU ==> a && s ~=UU"
-by auto
-
-lemma singleton_sconc [rule_format, simp]: "x~=UU --> (x && UU) ooo y = x && y"
-apply (simp add: sconc_def zero_inat_def iSuc_def split: inat.splits, auto)
-apply (rule someI2_ex,auto)
- apply (rule_tac x="x && y" in exI,auto)
-apply (simp add: i_rt_Suc_forw)
-apply (case_tac "xa=UU",simp)
-by (drule stream_exhaust_eq [THEN iffD1],auto)
-
-lemma ex_sconc [rule_format]:
-  "ALL k y. #x = Fin k --> (EX w. stream_take k$w = x & i_rt k w = y)"
-apply (case_tac "#x")
- apply (rule stream_finite_ind [of x],auto)
-  apply (simp add: stream.finite_def)
-  apply (drule slen_take_lemma1,blast)
- apply (simp_all add: zero_inat_def iSuc_def split: inat.splits)
-apply (erule_tac x="y" in allE,auto)
-by (rule_tac x="a && w" in exI,auto)
-
-lemma rt_sconc1: "Fin n = #x ==> i_rt n (x ooo y) = y"
-apply (simp add: sconc_def split: inat.splits, arith?,auto)
-apply (rule someI2_ex,auto)
-by (drule ex_sconc,simp)
-
-lemma sconc_inj2: "\<lbrakk>Fin n = #x; x ooo y = x ooo z\<rbrakk> \<Longrightarrow> y = z"
-apply (frule_tac y=y in rt_sconc1)
-by (auto elim: rt_sconc1)
-
-lemma sconc_UU [simp]:"s ooo UU = s"
-apply (case_tac "#s")
- apply (simp add: sconc_def)
- apply (rule someI2_ex)
-  apply (rule_tac x="s" in exI)
-  apply auto
-   apply (drule slen_take_lemma1,auto)
-  apply (simp add: i_rt_lemma_slen)
- apply (drule slen_take_lemma1,auto)
- apply (simp add: i_rt_slen)
-by (simp add: sconc_def)
-
-lemma stream_take_sconc [simp]: "Fin n = #x ==> stream_take n$(x ooo y) = x"
-apply (simp add: sconc_def)
-apply (cases "#x")
-apply auto
-apply (rule someI2_ex, auto)
-by (drule ex_sconc,simp)
-
-lemma scons_sconc [rule_format,simp]: "a~=UU --> (a && x) ooo y = a && x ooo y"
-apply (cases "#x",auto)
- apply (simp add: sconc_def iSuc_Fin)
- apply (rule someI2_ex)
-  apply (drule ex_sconc, simp)
- apply (rule someI2_ex, auto)
-  apply (simp add: i_rt_Suc_forw)
-  apply (rule_tac x="a && x" in exI, auto)
- apply (case_tac "xa=UU",auto)
- apply (drule stream_exhaust_eq [THEN iffD1],auto)
- apply (drule streams_prefix_lemma1,simp+)
-by (simp add: sconc_def)
-
-lemma ft_sconc: "x ~= UU ==> ft$(x ooo y) = ft$x"
-by (cases x, auto)
-
-lemma sconc_assoc: "(x ooo y) ooo z = x ooo y ooo z"
-apply (case_tac "#x")
- apply (rule stream_finite_ind [of x],auto simp del: scons_sconc)
-  apply (simp add: stream.finite_def del: scons_sconc)
-  apply (drule slen_take_lemma1,auto simp del: scons_sconc)
- apply (case_tac "a = UU", auto)
-by (simp add: sconc_def)
-
-
-(* ----------------------------------------------------------------------- *)
-
-lemma cont_sconc_lemma1: "stream_finite x \<Longrightarrow> cont (\<lambda>y. x ooo y)"
-by (erule stream_finite_ind, simp_all)
-
-lemma cont_sconc_lemma2: "\<not> stream_finite x \<Longrightarrow> cont (\<lambda>y. x ooo y)"
-by (simp add: sconc_def slen_def)
-
-lemma cont_sconc: "cont (\<lambda>y. x ooo y)"
-apply (cases "stream_finite x")
-apply (erule cont_sconc_lemma1)
-apply (erule cont_sconc_lemma2)
-done
-
-lemma sconc_mono: "y << y' ==> x ooo y << x ooo y'"
-by (rule cont_sconc [THEN cont2mono, THEN monofunE])
-
-lemma sconc_mono1 [simp]: "x << x ooo y"
-by (rule sconc_mono [of UU, simplified])
-
-(* ----------------------------------------------------------------------- *)
-
-lemma empty_sconc [simp]: "(x ooo y = UU) = (x = UU & y = UU)"
-apply (case_tac "#x",auto)
-   apply (insert sconc_mono1 [of x y])
-   by auto
-
-(* ----------------------------------------------------------------------- *)
-
-lemma rt_sconc [rule_format, simp]: "s~=UU --> rt$(s ooo x) = rt$s ooo x"
-by (cases s, auto)
-
-lemma i_th_sconc_lemma [rule_format]:
-  "ALL x y. Fin n < #x --> i_th n (x ooo y) = i_th n x"
-apply (induct_tac n, auto)
-apply (simp add: Fin_0 i_th_def)
-apply (simp add: slen_empty_eq ft_sconc)
-apply (simp add: i_th_def)
-apply (case_tac "x=UU",auto)
-apply (drule stream_exhaust_eq [THEN iffD1], auto)
-apply (erule_tac x="ya" in allE)
-apply (case_tac "#ya") by simp_all
-
-
-
-(* ----------------------------------------------------------------------- *)
-
-lemma sconc_lemma [rule_format, simp]: "ALL s. stream_take n$s ooo i_rt n s = s"
-apply (induct_tac n,auto)
-apply (case_tac "s=UU",auto)
-by (drule stream_exhaust_eq [THEN iffD1],auto)
-
-(* ----------------------------------------------------------------------- *)
-   subsection "pointwise equality"
-(* ----------------------------------------------------------------------- *)
-
-lemma ex_last_stream_take_scons: "stream_take (Suc n)$s =
-                     stream_take n$s ooo i_rt n (stream_take (Suc n)$s)"
-by (insert sconc_lemma [of n "stream_take (Suc n)$s"],simp)
-
-lemma i_th_stream_take_eq:
-"!!n. ALL n. i_th n s1 = i_th n s2 ==> stream_take n$s1 = stream_take n$s2"
-apply (induct_tac n,auto)
-apply (subgoal_tac "stream_take (Suc na)$s1 =
-                    stream_take na$s1 ooo i_rt na (stream_take (Suc na)$s1)")
- apply (subgoal_tac "i_rt na (stream_take (Suc na)$s1) =
-                    i_rt na (stream_take (Suc na)$s2)")
-  apply (subgoal_tac "stream_take (Suc na)$s2 =
-                    stream_take na$s2 ooo i_rt na (stream_take (Suc na)$s2)")
-   apply (insert ex_last_stream_take_scons,simp)
-  apply blast
- apply (erule_tac x="na" in allE)
- apply (insert i_th_last_eq [of _ s1 s2])
-by blast+
-
-lemma pointwise_eq_lemma[rule_format]: "ALL n. i_th n s1 = i_th n s2 ==> s1 = s2"
-by (insert i_th_stream_take_eq [THEN stream.take_lemma],blast)
-
-(* ----------------------------------------------------------------------- *)
-   subsection "finiteness"
-(* ----------------------------------------------------------------------- *)
-
-lemma slen_sconc_finite1:
-  "[| #(x ooo y) = Infty; Fin n = #x |] ==> #y = Infty"
-apply (case_tac "#y ~= Infty",auto)
-apply (drule_tac y=y in rt_sconc1)
-apply (insert stream_finite_i_rt [of n "x ooo y"])
-by (simp add: slen_infinite)
-
-lemma slen_sconc_infinite1: "#x=Infty ==> #(x ooo y) = Infty"
-by (simp add: sconc_def)
-
-lemma slen_sconc_infinite2: "#y=Infty ==> #(x ooo y) = Infty"
-apply (case_tac "#x")
- apply (simp add: sconc_def)
- apply (rule someI2_ex)
-  apply (drule ex_sconc,auto)
- apply (erule contrapos_pp)
- apply (insert stream_finite_i_rt)
- apply (fastsimp simp add: slen_infinite,auto)
-by (simp add: sconc_def)
-
-lemma sconc_finite: "(#x~=Infty & #y~=Infty) = (#(x ooo y)~=Infty)"
-apply auto
-  apply (metis not_Infty_eq slen_sconc_finite1)
- apply (metis not_Infty_eq slen_sconc_infinite1)
-apply (metis not_Infty_eq slen_sconc_infinite2)
-done
-
-(* ----------------------------------------------------------------------- *)
-
-lemma slen_sconc_mono3: "[| Fin n = #x; Fin k = #(x ooo y) |] ==> n <= k"
-apply (insert slen_mono [of "x" "x ooo y"])
-apply (cases "#x") apply simp_all
-apply (cases "#(x ooo y)") apply simp_all
-done
-
-(* ----------------------------------------------------------------------- *)
-   subsection "finite slen"
-(* ----------------------------------------------------------------------- *)
-
-lemma slen_sconc: "[| Fin n = #x; Fin m = #y |] ==> #(x ooo y) = Fin (n + m)"
-apply (case_tac "#(x ooo y)")
- apply (frule_tac y=y in rt_sconc1)
- apply (insert take_i_rt_len [of "THE j. Fin j = #(x ooo y)" "x ooo y" n n m],simp)
- apply (insert slen_sconc_mono3 [of n x _ y],simp)
-by (insert sconc_finite [of x y],auto)
-
-(* ----------------------------------------------------------------------- *)
-   subsection "flat prefix"
-(* ----------------------------------------------------------------------- *)
-
-lemma sconc_prefix: "(s1::'a::flat stream) << s2 ==> EX t. s1 ooo t = s2"
-apply (case_tac "#s1")
- apply (subgoal_tac "stream_take nat$s1 = stream_take nat$s2")
-  apply (rule_tac x="i_rt nat s2" in exI)
-  apply (simp add: sconc_def)
-  apply (rule someI2_ex)
-   apply (drule ex_sconc)
-   apply (simp,clarsimp,drule streams_prefix_lemma1)
-   apply (simp+,rule slen_take_lemma3 [of _ s1 s2])
-  apply (simp+,rule_tac x="UU" in exI)
-apply (insert slen_take_lemma3 [of _ s1 s2])
-by (rule stream.take_lemma,simp)
-
-(* ----------------------------------------------------------------------- *)
-   subsection "continuity"
-(* ----------------------------------------------------------------------- *)
-
-lemma chain_sconc: "chain S ==> chain (%i. (x ooo S i))"
-by (simp add: chain_def,auto simp add: sconc_mono)
-
-lemma chain_scons: "chain S ==> chain (%i. a && S i)"
-apply (simp add: chain_def,auto)
-by (rule monofun_cfun_arg,simp)
-
-lemma contlub_scons_lemma: "chain S ==> (LUB i. a && S i) = a && (LUB i. S i)"
-by (rule cont2contlubE [OF cont_Rep_cfun2, symmetric])
-
-lemma finite_lub_sconc: "chain Y ==> (stream_finite x) ==>
-                        (LUB i. x ooo Y i) = (x ooo (LUB i. Y i))"
-apply (rule stream_finite_ind [of x])
- apply (auto)
-apply (subgoal_tac "(LUB i. a && (s ooo Y i)) = a && (LUB i. s ooo Y i)")
- by (force,blast dest: contlub_scons_lemma chain_sconc)
-
-lemma contlub_sconc_lemma:
-  "chain Y ==> (LUB i. x ooo Y i) = (x ooo (LUB i. Y i))"
-apply (case_tac "#x=Infty")
- apply (simp add: sconc_def)
-apply (drule finite_lub_sconc,auto simp add: slen_infinite)
-done
-
-lemma monofun_sconc: "monofun (%y. x ooo y)"
-by (simp add: monofun_def sconc_mono)
-
-
-(* ----------------------------------------------------------------------- *)
-   section "constr_sconc"
-(* ----------------------------------------------------------------------- *)
-
-lemma constr_sconc_UUs [simp]: "constr_sconc UU s = s"
-by (simp add: constr_sconc_def zero_inat_def)
-
-lemma "x ooo y = constr_sconc x y"
-apply (case_tac "#x")
- apply (rule stream_finite_ind [of x],auto simp del: scons_sconc)
-  defer 1
-  apply (simp add: constr_sconc_def del: scons_sconc)
-  apply (case_tac "#s")
-   apply (simp add: iSuc_Fin)
-   apply (case_tac "a=UU",auto simp del: scons_sconc)
-   apply (simp)
-  apply (simp add: sconc_def)
- apply (simp add: constr_sconc_def)
-apply (simp add: stream.finite_def)
-by (drule slen_take_lemma1,auto)
-
-end

--- a/src/HOLCF/Library/Sum_Cpo.thy	Sat Nov 27 14:34:54 2010 -0800
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,292 +0,0 @@
-(*  Title:      HOLCF/Sum_Cpo.thy
-    Author:     Brian Huffman
-*)
-
-header {* The cpo of disjoint sums *}
-
-theory Sum_Cpo
-imports HOLCF
-begin
-
-subsection {* Ordering on sum type *}
-
-instantiation sum :: (below, below) below
-begin
-
-definition below_sum_def:
-  "x \<sqsubseteq> y \<equiv> case x of
-         Inl a \<Rightarrow> (case y of Inl b \<Rightarrow> a \<sqsubseteq> b | Inr b \<Rightarrow> False) |
-         Inr a \<Rightarrow> (case y of Inl b \<Rightarrow> False | Inr b \<Rightarrow> a \<sqsubseteq> b)"
-
-instance ..
-end
-
-lemma Inl_below_Inl [simp]: "Inl x \<sqsubseteq> Inl y \<longleftrightarrow> x \<sqsubseteq> y"
-unfolding below_sum_def by simp
-
-lemma Inr_below_Inr [simp]: "Inr x \<sqsubseteq> Inr y \<longleftrightarrow> x \<sqsubseteq> y"
-unfolding below_sum_def by simp
-
-lemma Inl_below_Inr [simp]: "\<not> Inl x \<sqsubseteq> Inr y"
-unfolding below_sum_def by simp
-
-lemma Inr_below_Inl [simp]: "\<not> Inr x \<sqsubseteq> Inl y"
-unfolding below_sum_def by simp
-
-lemma Inl_mono: "x \<sqsubseteq> y \<Longrightarrow> Inl x \<sqsubseteq> Inl y"
-by simp
-
-lemma Inr_mono: "x \<sqsubseteq> y \<Longrightarrow> Inr x \<sqsubseteq> Inr y"
-by simp
-
-lemma Inl_belowE: "\<lbrakk>Inl a \<sqsubseteq> x; \<And>b. \<lbrakk>x = Inl b; a \<sqsubseteq> b\<rbrakk> \<Longrightarrow> R\<rbrakk> \<Longrightarrow> R"
-by (cases x, simp_all)
-
-lemma Inr_belowE: "\<lbrakk>Inr a \<sqsubseteq> x; \<And>b. \<lbrakk>x = Inr b; a \<sqsubseteq> b\<rbrakk> \<Longrightarrow> R\<rbrakk> \<Longrightarrow> R"
-by (cases x, simp_all)
-
-lemmas sum_below_elims = Inl_belowE Inr_belowE
-
-lemma sum_below_cases:
-  "\<lbrakk>x \<sqsubseteq> y;
-    \<And>a b. \<lbrakk>x = Inl a; y = Inl b; a \<sqsubseteq> b\<rbrakk> \<Longrightarrow> R;
-    \<And>a b. \<lbrakk>x = Inr a; y = Inr b; a \<sqsubseteq> b\<rbrakk> \<Longrightarrow> R\<rbrakk>
-      \<Longrightarrow> R"
-by (cases x, safe elim!: sum_below_elims, auto)
-
-subsection {* Sum type is a complete partial order *}
-
-instance sum :: (po, po) po
-proof
-  fix x :: "'a + 'b"
-  show "x \<sqsubseteq> x"
-    by (induct x, simp_all)
-next
-  fix x y :: "'a + 'b"
-  assume "x \<sqsubseteq> y" and "y \<sqsubseteq> x" thus "x = y"
-    by (induct x, auto elim!: sum_below_elims intro: below_antisym)
-next
-  fix x y z :: "'a + 'b"
-  assume "x \<sqsubseteq> y" and "y \<sqsubseteq> z" thus "x \<sqsubseteq> z"
-    by (induct x, auto elim!: sum_below_elims intro: below_trans)
-qed
-
-lemma monofun_inv_Inl: "monofun (\<lambda>p. THE a. p = Inl a)"
-by (rule monofunI, erule sum_below_cases, simp_all)
-
-lemma monofun_inv_Inr: "monofun (\<lambda>p. THE b. p = Inr b)"
-by (rule monofunI, erule sum_below_cases, simp_all)
-
-lemma sum_chain_cases:
-  assumes Y: "chain Y"
-  assumes A: "\<And>A. \<lbrakk>chain A; Y = (\<lambda>i. Inl (A i))\<rbrakk> \<Longrightarrow> R"
-  assumes B: "\<And>B. \<lbrakk>chain B; Y = (\<lambda>i. Inr (B i))\<rbrakk> \<Longrightarrow> R"
-  shows "R"
- apply (cases "Y 0")
-  apply (rule A)
-   apply (rule ch2ch_monofun [OF monofun_inv_Inl Y])
-  apply (rule ext)
-  apply (cut_tac j=i in chain_mono [OF Y le0], simp)
-  apply (erule Inl_belowE, simp)
- apply (rule B)
-  apply (rule ch2ch_monofun [OF monofun_inv_Inr Y])
- apply (rule ext)
- apply (cut_tac j=i in chain_mono [OF Y le0], simp)
- apply (erule Inr_belowE, simp)
-done
-
-lemma is_lub_Inl: "range S <<| x \<Longrightarrow> range (\<lambda>i. Inl (S i)) <<| Inl x"
- apply (rule is_lubI)
-  apply (rule ub_rangeI)
-  apply (simp add: is_lub_rangeD1)
- apply (frule ub_rangeD [where i=arbitrary])
- apply (erule Inl_belowE, simp)
- apply (erule is_lubD2)
- apply (rule ub_rangeI)
- apply (drule ub_rangeD, simp)
-done
-
-lemma is_lub_Inr: "range S <<| x \<Longrightarrow> range (\<lambda>i. Inr (S i)) <<| Inr x"
- apply (rule is_lubI)
-  apply (rule ub_rangeI)
-  apply (simp add: is_lub_rangeD1)
- apply (frule ub_rangeD [where i=arbitrary])
- apply (erule Inr_belowE, simp)
- apply (erule is_lubD2)
- apply (rule ub_rangeI)
- apply (drule ub_rangeD, simp)
-done
-
-instance sum :: (cpo, cpo) cpo
- apply intro_classes
- apply (erule sum_chain_cases, safe)
-  apply (rule exI)
-  apply (rule is_lub_Inl)
-  apply (erule cpo_lubI)
- apply (rule exI)
- apply (rule is_lub_Inr)
- apply (erule cpo_lubI)
-done
-
-subsection {* Continuity of \emph{Inl}, \emph{Inr}, and case function *}
-
-lemma cont_Inl: "cont Inl"
-by (intro contI is_lub_Inl cpo_lubI)
-
-lemma cont_Inr: "cont Inr"
-by (intro contI is_lub_Inr cpo_lubI)
-
-lemmas cont2cont_Inl [simp, cont2cont] = cont_compose [OF cont_Inl]
-lemmas cont2cont_Inr [simp, cont2cont] = cont_compose [OF cont_Inr]
-
-lemmas ch2ch_Inl [simp] = ch2ch_cont [OF cont_Inl]
-lemmas ch2ch_Inr [simp] = ch2ch_cont [OF cont_Inr]
-
-lemmas lub_Inl = cont2contlubE [OF cont_Inl, symmetric]
-lemmas lub_Inr = cont2contlubE [OF cont_Inr, symmetric]
-
-lemma cont_sum_case1:
-  assumes f: "\<And>a. cont (\<lambda>x. f x a)"
-  assumes g: "\<And>b. cont (\<lambda>x. g x b)"
-  shows "cont (\<lambda>x. case y of Inl a \<Rightarrow> f x a | Inr b \<Rightarrow> g x b)"
-by (induct y, simp add: f, simp add: g)
-
-lemma cont_sum_case2: "\<lbrakk>cont f; cont g\<rbrakk> \<Longrightarrow> cont (sum_case f g)"
-apply (rule contI)
-apply (erule sum_chain_cases)
-apply (simp add: cont2contlubE [OF cont_Inl, symmetric] contE)
-apply (simp add: cont2contlubE [OF cont_Inr, symmetric] contE)
-done
-
-lemma cont2cont_sum_case:
-  assumes f1: "\<And>a. cont (\<lambda>x. f x a)" and f2: "\<And>x. cont (\<lambda>a. f x a)"
-  assumes g1: "\<And>b. cont (\<lambda>x. g x b)" and g2: "\<And>x. cont (\<lambda>b. g x b)"
-  assumes h: "cont (\<lambda>x. h x)"
-  shows "cont (\<lambda>x. case h x of Inl a \<Rightarrow> f x a | Inr b \<Rightarrow> g x b)"
-apply (rule cont_apply [OF h])
-apply (rule cont_sum_case2 [OF f2 g2])
-apply (rule cont_sum_case1 [OF f1 g1])
-done
-
-lemma cont2cont_sum_case' [simp, cont2cont]:
-  assumes f: "cont (\<lambda>p. f (fst p) (snd p))"
-  assumes g: "cont (\<lambda>p. g (fst p) (snd p))"
-  assumes h: "cont (\<lambda>x. h x)"
-  shows "cont (\<lambda>x. case h x of Inl a \<Rightarrow> f x a | Inr b \<Rightarrow> g x b)"
-using assms by (simp add: cont2cont_sum_case prod_cont_iff)
-
-subsection {* Compactness and chain-finiteness *}
-
-lemma compact_Inl: "compact a \<Longrightarrow> compact (Inl a)"
-apply (rule compactI2)
-apply (erule sum_chain_cases, safe)
-apply (simp add: lub_Inl)
-apply (erule (2) compactD2)
-apply (simp add: lub_Inr)
-done
-
-lemma compact_Inr: "compact a \<Longrightarrow> compact (Inr a)"
-apply (rule compactI2)
-apply (erule sum_chain_cases, safe)
-apply (simp add: lub_Inl)
-apply (simp add: lub_Inr)
-apply (erule (2) compactD2)
-done
-
-lemma compact_Inl_rev: "compact (Inl a) \<Longrightarrow> compact a"
-unfolding compact_def
-by (drule adm_subst [OF cont_Inl], simp)
-
-lemma compact_Inr_rev: "compact (Inr a) \<Longrightarrow> compact a"
-unfolding compact_def
-by (drule adm_subst [OF cont_Inr], simp)
-
-lemma compact_Inl_iff [simp]: "compact (Inl a) = compact a"
-by (safe elim!: compact_Inl compact_Inl_rev)
-
-lemma compact_Inr_iff [simp]: "compact (Inr a) = compact a"
-by (safe elim!: compact_Inr compact_Inr_rev)
-
-instance sum :: (chfin, chfin) chfin
-apply intro_classes
-apply (erule compact_imp_max_in_chain)
-apply (case_tac "\<Squnion>i. Y i", simp_all)
-done
-
-instance sum :: (discrete_cpo, discrete_cpo) discrete_cpo
-by intro_classes (simp add: below_sum_def split: sum.split)
-
-subsection {* Using sum types with fixrec *}
-
-definition
-  "match_Inl = (\<Lambda> x k. case x of Inl a \<Rightarrow> k\<cdot>a | Inr b \<Rightarrow> Fixrec.fail)"
-
-definition
-  "match_Inr = (\<Lambda> x k. case x of Inl a \<Rightarrow> Fixrec.fail | Inr b \<Rightarrow> k\<cdot>b)"
-
-lemma match_Inl_simps [simp]:
-  "match_Inl\<cdot>(Inl a)\<cdot>k = k\<cdot>a"
-  "match_Inl\<cdot>(Inr b)\<cdot>k = Fixrec.fail"
-unfolding match_Inl_def by simp_all
-
-lemma match_Inr_simps [simp]:
-  "match_Inr\<cdot>(Inl a)\<cdot>k = Fixrec.fail"
-  "match_Inr\<cdot>(Inr b)\<cdot>k = k\<cdot>b"
-unfolding match_Inr_def by simp_all
-
-setup {*
-  Fixrec.add_matchers
-    [ (@{const_name Inl}, @{const_name match_Inl}),
-      (@{const_name Inr}, @{const_name match_Inr}) ]
-*}
-
-subsection {* Disjoint sum is a predomain *}
-
-definition
-  "encode_sum_u =
-    (\<Lambda>(up\<cdot>x). case x of Inl a \<Rightarrow> sinl\<cdot>(up\<cdot>a) | Inr b \<Rightarrow> sinr\<cdot>(up\<cdot>b))"
-
-definition
-  "decode_sum_u = sscase\<cdot>(\<Lambda>(up\<cdot>a). up\<cdot>(Inl a))\<cdot>(\<Lambda>(up\<cdot>b). up\<cdot>(Inr b))"
-
-lemma decode_encode_sum_u [simp]: "decode_sum_u\<cdot>(encode_sum_u\<cdot>x) = x"
-unfolding decode_sum_u_def encode_sum_u_def
-by (case_tac x, simp, rename_tac y, case_tac y, simp_all)
-
-lemma encode_decode_sum_u [simp]: "encode_sum_u\<cdot>(decode_sum_u\<cdot>x) = x"
-unfolding decode_sum_u_def encode_sum_u_def
-apply (case_tac x, simp)
-apply (rename_tac a, case_tac a, simp, simp)
-apply (rename_tac b, case_tac b, simp, simp)
-done
-
-instantiation sum :: (predomain, predomain) predomain
-begin
-
-definition
-  "liftemb = (udom_emb ssum_approx oo ssum_map\<cdot>emb\<cdot>emb) oo encode_sum_u"
-
-definition
-  "liftprj =
-    decode_sum_u oo (ssum_map\<cdot>prj\<cdot>prj oo udom_prj ssum_approx)"
-
-definition
-  "liftdefl (t::('a + 'b) itself) = ssum_defl\<cdot>DEFL('a u)\<cdot>DEFL('b u)"
-
-instance proof
-  show "ep_pair liftemb (liftprj :: udom \<rightarrow> ('a + 'b) u)"
-    unfolding liftemb_sum_def liftprj_sum_def
-    apply (rule ep_pair_comp)
-    apply (rule ep_pair.intro, simp, simp)
-    apply (rule ep_pair_comp)
-    apply (intro ep_pair_ssum_map ep_pair_emb_prj)
-    apply (rule ep_pair_udom [OF ssum_approx])
-    done
-  show "cast\<cdot>LIFTDEFL('a + 'b) = liftemb oo (liftprj :: udom \<rightarrow> ('a + 'b) u)"
-    unfolding liftemb_sum_def liftprj_sum_def liftdefl_sum_def
-    by (simp add: cast_ssum_defl cast_DEFL cfcomp1 ssum_map_map)
-qed
-
-end
-
-end

--- a/src/HOLCF/Lift.thy	Sat Nov 27 14:34:54 2010 -0800
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,133 +0,0 @@
-(*  Title:      HOLCF/Lift.thy
-    Author:     Olaf Mueller
-*)
-
-header {* Lifting types of class type to flat pcpo's *}
-
-theory Lift
-imports Discrete Up
-begin
-
-default_sort type
-
-pcpodef (open) 'a lift = "UNIV :: 'a discr u set"
-by simp_all
-
-lemmas inst_lift_pcpo = Abs_lift_strict [symmetric]
-
-definition
-  Def :: "'a \<Rightarrow> 'a lift" where
-  "Def x = Abs_lift (up\<cdot>(Discr x))"
-
-subsection {* Lift as a datatype *}
-
-lemma lift_induct: "\<lbrakk>P \<bottom>; \<And>x. P (Def x)\<rbrakk> \<Longrightarrow> P y"
-apply (induct y)
-apply (rule_tac p=y in upE)
-apply (simp add: Abs_lift_strict)
-apply (case_tac x)
-apply (simp add: Def_def)
-done
-
-rep_datatype "\<bottom>\<Colon>'a lift" Def
-  by (erule lift_induct) (simp_all add: Def_def Abs_lift_inject inst_lift_pcpo)
-
-lemmas lift_distinct1 = lift.distinct(1)
-lemmas lift_distinct2 = lift.distinct(2)
-lemmas Def_not_UU = lift.distinct(2)
-lemmas Def_inject = lift.inject
-
-
-text {* @{term UU} and @{term Def} *}
-
-lemma not_Undef_is_Def: "(x \<noteq> \<bottom>) = (\<exists>y. x = Def y)"
-  by (cases x) simp_all
-
-lemma lift_definedE: "\<lbrakk>x \<noteq> \<bottom>; \<And>a. x = Def a \<Longrightarrow> R\<rbrakk> \<Longrightarrow> R"
-  by (cases x) simp_all
-
-text {*
-  For @{term "x ~= UU"} in assumptions @{text defined} replaces @{text
-  x} by @{text "Def a"} in conclusion. *}
-
-method_setup defined = {*
-  Scan.succeed (fn ctxt => SIMPLE_METHOD'
-    (etac @{thm lift_definedE} THEN' asm_simp_tac (simpset_of ctxt)))
-*} ""
-
-lemma DefE: "Def x = \<bottom> \<Longrightarrow> R"
-  by simp
-
-lemma DefE2: "\<lbrakk>x = Def s; x = \<bottom>\<rbrakk> \<Longrightarrow> R"
-  by simp
-
-lemma Def_below_Def: "Def x \<sqsubseteq> Def y \<longleftrightarrow> x = y"
-by (simp add: below_lift_def Def_def Abs_lift_inverse)
-
-lemma Def_below_iff [simp]: "Def x \<sqsubseteq> y \<longleftrightarrow> Def x = y"
-by (induct y, simp, simp add: Def_below_Def)
-
-
-subsection {* Lift is flat *}
-
-instance lift :: (type) flat
-proof
-  fix x y :: "'a lift"
-  assume "x \<sqsubseteq> y" thus "x = \<bottom> \<or> x = y"
-    by (induct x) auto
-qed
-
-subsection {* Continuity of @{const lift_case} *}
-
-lemma lift_case_eq: "lift_case \<bottom> f x = fup\<cdot>(\<Lambda> y. f (undiscr y))\<cdot>(Rep_lift x)"
-apply (induct x, unfold lift.cases)
-apply (simp add: Rep_lift_strict)
-apply (simp add: Def_def Abs_lift_inverse)
-done
-
-lemma cont2cont_lift_case [simp]:
-  "\<lbrakk>\<And>y. cont (\<lambda>x. f x y); cont g\<rbrakk> \<Longrightarrow> cont (\<lambda>x. lift_case \<bottom> (f x) (g x))"
-unfolding lift_case_eq by (simp add: cont_Rep_lift [THEN cont_compose])
-
-subsection {* Further operations *}
-
-definition
-  flift1 :: "('a \<Rightarrow> 'b::pcpo) \<Rightarrow> ('a lift \<rightarrow> 'b)"  (binder "FLIFT " 10)  where
-  "flift1 = (\<lambda>f. (\<Lambda> x. lift_case \<bottom> f x))"
-
-translations
-  "\<Lambda>(XCONST Def x). t" => "CONST flift1 (\<lambda>x. t)"
-  "\<Lambda>(CONST Def x). FLIFT y. t" <= "FLIFT x y. t"
-  "\<Lambda>(CONST Def x). t" <= "FLIFT x. t"
-
-definition
-  flift2 :: "('a \<Rightarrow> 'b) \<Rightarrow> ('a lift \<rightarrow> 'b lift)" where
-  "flift2 f = (FLIFT x. Def (f x))"
-
-lemma flift1_Def [simp]: "flift1 f\<cdot>(Def x) = (f x)"
-by (simp add: flift1_def)
-
-lemma flift2_Def [simp]: "flift2 f\<cdot>(Def x) = Def (f x)"
-by (simp add: flift2_def)
-
-lemma flift1_strict [simp]: "flift1 f\<cdot>\<bottom> = \<bottom>"
-by (simp add: flift1_def)
-
-lemma flift2_strict [simp]: "flift2 f\<cdot>\<bottom> = \<bottom>"
-by (simp add: flift2_def)
-
-lemma flift2_defined [simp]: "x \<noteq> \<bottom> \<Longrightarrow> (flift2 f)\<cdot>x \<noteq> \<bottom>"
-by (erule lift_definedE, simp)
-
-lemma flift2_bottom_iff [simp]: "(flift2 f\<cdot>x = \<bottom>) = (x = \<bottom>)"
-by (cases x, simp_all)
-
-lemma FLIFT_mono:
-  "(\<And>x. f x \<sqsubseteq> g x) \<Longrightarrow> (FLIFT x. f x) \<sqsubseteq> (FLIFT x. g x)"
-by (rule cfun_belowI, case_tac x, simp_all)
-
-lemma cont2cont_flift1 [simp, cont2cont]:
-  "\<lbrakk>\<And>y. cont (\<lambda>x. f x y)\<rbrakk> \<Longrightarrow> cont (\<lambda>x. FLIFT y. f x y)"
-by (simp add: flift1_def cont2cont_LAM)
-
-end

--- a/src/HOLCF/LowerPD.thy	Sat Nov 27 14:34:54 2010 -0800
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,534 +0,0 @@
-(*  Title:      HOLCF/LowerPD.thy
-    Author:     Brian Huffman
-*)
-
-header {* Lower powerdomain *}
-
-theory LowerPD
-imports CompactBasis
-begin
-
-subsection {* Basis preorder *}
-
-definition
-  lower_le :: "'a pd_basis \<Rightarrow> 'a pd_basis \<Rightarrow> bool" (infix "\<le>\<flat>" 50) where
-  "lower_le = (\<lambda>u v. \<forall>x\<in>Rep_pd_basis u. \<exists>y\<in>Rep_pd_basis v. x \<sqsubseteq> y)"
-
-lemma lower_le_refl [simp]: "t \<le>\<flat> t"
-unfolding lower_le_def by fast
-
-lemma lower_le_trans: "\<lbrakk>t \<le>\<flat> u; u \<le>\<flat> v\<rbrakk> \<Longrightarrow> t \<le>\<flat> v"
-unfolding lower_le_def
-apply (rule ballI)
-apply (drule (1) bspec, erule bexE)
-apply (drule (1) bspec, erule bexE)
-apply (erule rev_bexI)
-apply (erule (1) below_trans)
-done
-
-interpretation lower_le: preorder lower_le
-by (rule preorder.intro, rule lower_le_refl, rule lower_le_trans)
-
-lemma lower_le_minimal [simp]: "PDUnit compact_bot \<le>\<flat> t"
-unfolding lower_le_def Rep_PDUnit
-by (simp, rule Rep_pd_basis_nonempty [folded ex_in_conv])
-
-lemma PDUnit_lower_mono: "x \<sqsubseteq> y \<Longrightarrow> PDUnit x \<le>\<flat> PDUnit y"
-unfolding lower_le_def Rep_PDUnit by fast
-
-lemma PDPlus_lower_mono: "\<lbrakk>s \<le>\<flat> t; u \<le>\<flat> v\<rbrakk> \<Longrightarrow> PDPlus s u \<le>\<flat> PDPlus t v"
-unfolding lower_le_def Rep_PDPlus by fast
-
-lemma PDPlus_lower_le: "t \<le>\<flat> PDPlus t u"
-unfolding lower_le_def Rep_PDPlus by fast
-
-lemma lower_le_PDUnit_PDUnit_iff [simp]:
-  "(PDUnit a \<le>\<flat> PDUnit b) = (a \<sqsubseteq> b)"
-unfolding lower_le_def Rep_PDUnit by fast
-
-lemma lower_le_PDUnit_PDPlus_iff:
-  "(PDUnit a \<le>\<flat> PDPlus t u) = (PDUnit a \<le>\<flat> t \<or> PDUnit a \<le>\<flat> u)"
-unfolding lower_le_def Rep_PDPlus Rep_PDUnit by fast
-
-lemma lower_le_PDPlus_iff: "(PDPlus t u \<le>\<flat> v) = (t \<le>\<flat> v \<and> u \<le>\<flat> v)"
-unfolding lower_le_def Rep_PDPlus by fast
-
-lemma lower_le_induct [induct set: lower_le]:
-  assumes le: "t \<le>\<flat> u"
-  assumes 1: "\<And>a b. a \<sqsubseteq> b \<Longrightarrow> P (PDUnit a) (PDUnit b)"
-  assumes 2: "\<And>t u a. P (PDUnit a) t \<Longrightarrow> P (PDUnit a) (PDPlus t u)"
-  assumes 3: "\<And>t u v. \<lbrakk>P t v; P u v\<rbrakk> \<Longrightarrow> P (PDPlus t u) v"
-  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_induct)
-apply (simp add: 1)
-apply (simp add: lower_le_PDUnit_PDPlus_iff)
-apply (simp add: 2)
-apply (subst PDPlus_commute)
-apply (simp add: 2)
-apply (simp add: lower_le_PDPlus_iff 3)
-done
-
-
-subsection {* Type definition *}
-
-typedef (open) 'a lower_pd =
-  "{S::'a pd_basis set. lower_le.ideal S}"
-by (fast intro: lower_le.ideal_principal)
-
-instantiation lower_pd :: ("domain") below
-begin
-
-definition
-  "x \<sqsubseteq> y \<longleftrightarrow> Rep_lower_pd x \<subseteq> Rep_lower_pd y"
-
-instance ..
-end
-
-instance lower_pd :: ("domain") po
-using type_definition_lower_pd below_lower_pd_def
-by (rule lower_le.typedef_ideal_po)
-
-instance lower_pd :: ("domain") cpo
-using type_definition_lower_pd below_lower_pd_def
-by (rule lower_le.typedef_ideal_cpo)
-
-definition
-  lower_principal :: "'a pd_basis \<Rightarrow> 'a lower_pd" where
-  "lower_principal t = Abs_lower_pd {u. u \<le>\<flat> t}"
-
-interpretation lower_pd:
-  ideal_completion lower_le lower_principal Rep_lower_pd
-using type_definition_lower_pd below_lower_pd_def
-using lower_principal_def pd_basis_countable
-by (rule lower_le.typedef_ideal_completion)
-
-text {* Lower powerdomain is pointed *}
-
-lemma lower_pd_minimal: "lower_principal (PDUnit compact_bot) \<sqsubseteq> ys"
-by (induct ys rule: lower_pd.principal_induct, simp, simp)
-
-instance lower_pd :: ("domain") pcpo
-by intro_classes (fast intro: lower_pd_minimal)
-
-lemma inst_lower_pd_pcpo: "\<bottom> = lower_principal (PDUnit compact_bot)"
-by (rule lower_pd_minimal [THEN UU_I, symmetric])
-
-
-subsection {* Monadic unit and plus *}
-
-definition
-  lower_unit :: "'a \<rightarrow> 'a lower_pd" where
-  "lower_unit = compact_basis.basis_fun (\<lambda>a. lower_principal (PDUnit a))"
-
-definition
-  lower_plus :: "'a lower_pd \<rightarrow> 'a lower_pd \<rightarrow> 'a lower_pd" where
-  "lower_plus = lower_pd.basis_fun (\<lambda>t. lower_pd.basis_fun (\<lambda>u.
-      lower_principal (PDPlus t u)))"
-
-abbreviation
-  lower_add :: "'a lower_pd \<Rightarrow> 'a lower_pd \<Rightarrow> 'a lower_pd"
-    (infixl "+\<flat>" 65) where
-  "xs +\<flat> ys == lower_plus\<cdot>xs\<cdot>ys"
-
-syntax
-  "_lower_pd" :: "args \<Rightarrow> 'a lower_pd" ("{_}\<flat>")
-
-translations
-  "{x,xs}\<flat>" == "{x}\<flat> +\<flat> {xs}\<flat>"
-  "{x}\<flat>" == "CONST lower_unit\<cdot>x"
-
-lemma lower_unit_Rep_compact_basis [simp]:
-  "{Rep_compact_basis a}\<flat> = lower_principal (PDUnit a)"
-unfolding lower_unit_def
-by (simp add: compact_basis.basis_fun_principal PDUnit_lower_mono)
-
-lemma lower_plus_principal [simp]:
-  "lower_principal t +\<flat> lower_principal u = lower_principal (PDPlus t u)"
-unfolding lower_plus_def
-by (simp add: lower_pd.basis_fun_principal
-    lower_pd.basis_fun_mono PDPlus_lower_mono)
-
-interpretation lower_add: semilattice lower_add proof
-  fix xs ys zs :: "'a lower_pd"
-  show "(xs +\<flat> ys) +\<flat> zs = xs +\<flat> (ys +\<flat> zs)"
-    apply (induct xs ys arbitrary: zs rule: lower_pd.principal_induct2, simp, simp)
-    apply (rule_tac x=zs in lower_pd.principal_induct, simp)
-    apply (simp add: PDPlus_assoc)
-    done
-  show "xs +\<flat> ys = ys +\<flat> xs"
-    apply (induct xs ys rule: lower_pd.principal_induct2, simp, simp)
-    apply (simp add: PDPlus_commute)
-    done
-  show "xs +\<flat> xs = xs"
-    apply (induct xs rule: lower_pd.principal_induct, simp)
-    apply (simp add: PDPlus_absorb)
-    done
-qed
-
-lemmas lower_plus_assoc = lower_add.assoc
-lemmas lower_plus_commute = lower_add.commute
-lemmas lower_plus_absorb = lower_add.idem
-lemmas lower_plus_left_commute = lower_add.left_commute
-lemmas lower_plus_left_absorb = lower_add.left_idem
-
-text {* Useful for @{text "simp add: lower_plus_ac"} *}
-lemmas lower_plus_ac =
-  lower_plus_assoc lower_plus_commute lower_plus_left_commute
-
-text {* Useful for @{text "simp only: lower_plus_aci"} *}
-lemmas lower_plus_aci =
-  lower_plus_ac lower_plus_absorb lower_plus_left_absorb
-
-lemma lower_plus_below1: "xs \<sqsubseteq> xs +\<flat> ys"
-apply (induct xs ys rule: lower_pd.principal_induct2, simp, simp)
-apply (simp add: PDPlus_lower_le)
-done
-
-lemma lower_plus_below2: "ys \<sqsubseteq> xs +\<flat> ys"
-by (subst lower_plus_commute, rule lower_plus_below1)
-
-lemma lower_plus_least: "\<lbrakk>xs \<sqsubseteq> zs; ys \<sqsubseteq> zs\<rbrakk> \<Longrightarrow> xs +\<flat> ys \<sqsubseteq> zs"
-apply (subst lower_plus_absorb [of zs, symmetric])
-apply (erule (1) monofun_cfun [OF monofun_cfun_arg])
-done
-
-lemma lower_plus_below_iff [simp]:
-  "xs +\<flat> ys \<sqsubseteq> zs \<longleftrightarrow> xs \<sqsubseteq> zs \<and> ys \<sqsubseteq> zs"
-apply safe
-apply (erule below_trans [OF lower_plus_below1])
-apply (erule below_trans [OF lower_plus_below2])
-apply (erule (1) lower_plus_least)
-done
-
-lemma lower_unit_below_plus_iff [simp]:
-  "{x}\<flat> \<sqsubseteq> ys +\<flat> zs \<longleftrightarrow> {x}\<flat> \<sqsubseteq> ys \<or> {x}\<flat> \<sqsubseteq> zs"
-apply (induct x rule: compact_basis.principal_induct, simp)
-apply (induct ys rule: lower_pd.principal_induct, simp)
-apply (induct zs rule: lower_pd.principal_induct, simp)
-apply (simp add: lower_le_PDUnit_PDPlus_iff)
-done
-
-lemma lower_unit_below_iff [simp]: "{x}\<flat> \<sqsubseteq> {y}\<flat> \<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
-
-lemmas lower_pd_below_simps =
-  lower_unit_below_iff
-  lower_plus_below_iff
-  lower_unit_below_plus_iff
-
-lemma lower_unit_eq_iff [simp]: "{x}\<flat> = {y}\<flat> \<longleftrightarrow> x = y"
-by (simp add: po_eq_conv)
-
-lemma lower_unit_strict [simp]: "{\<bottom>}\<flat> = \<bottom>"
-using lower_unit_Rep_compact_basis [of compact_bot]
-by (simp add: inst_lower_pd_pcpo)
-
-lemma lower_unit_bottom_iff [simp]: "{x}\<flat> = \<bottom> \<longleftrightarrow> x = \<bottom>"
-unfolding lower_unit_strict [symmetric] by (rule lower_unit_eq_iff)
-
-lemma lower_plus_bottom_iff [simp]:
-  "xs +\<flat> ys = \<bottom> \<longleftrightarrow> xs = \<bottom> \<and> ys = \<bottom>"
-apply safe
-apply (rule UU_I, erule subst, rule lower_plus_below1)
-apply (rule UU_I, erule subst, rule lower_plus_below2)
-apply (rule lower_plus_absorb)
-done
-
-lemma lower_plus_strict1 [simp]: "\<bottom> +\<flat> ys = ys"
-apply (rule below_antisym [OF _ lower_plus_below2])
-apply (simp add: lower_plus_least)
-done
-
-lemma lower_plus_strict2 [simp]: "xs +\<flat> \<bottom> = xs"
-apply (rule below_antisym [OF _ lower_plus_below1])
-apply (simp add: lower_plus_least)
-done
-
-lemma compact_lower_unit: "compact x \<Longrightarrow> compact {x}\<flat>"
-by (auto dest!: compact_basis.compact_imp_principal)
-
-lemma compact_lower_unit_iff [simp]: "compact {x}\<flat> \<longleftrightarrow> compact x"
-apply (safe elim!: compact_lower_unit)
-apply (simp only: compact_def lower_unit_below_iff [symmetric])
-apply (erule adm_subst [OF cont_Rep_cfun2])
-done
-
-lemma compact_lower_plus [simp]:
-  "\<lbrakk>compact xs; compact ys\<rbrakk> \<Longrightarrow> compact (xs +\<flat> ys)"
-by (auto dest!: lower_pd.compact_imp_principal)
-
-
-subsection {* Induction rules *}
-
-lemma lower_pd_induct1:
-  assumes P: "adm P"
-  assumes unit: "\<And>x. P {x}\<flat>"
-  assumes insert:
-    "\<And>x ys. \<lbrakk>P {x}\<flat>; P ys\<rbrakk> \<Longrightarrow> P ({x}\<flat> +\<flat> ys)"
-  shows "P (xs::'a lower_pd)"
-apply (induct xs rule: lower_pd.principal_induct, rule P)
-apply (induct_tac a rule: pd_basis_induct1)
-apply (simp only: lower_unit_Rep_compact_basis [symmetric])
-apply (rule unit)
-apply (simp only: lower_unit_Rep_compact_basis [symmetric]
-                  lower_plus_principal [symmetric])
-apply (erule insert [OF unit])
-done
-
-lemma lower_pd_induct
-  [case_names adm lower_unit lower_plus, induct type: lower_pd]:
-  assumes P: "adm P"
-  assumes unit: "\<And>x. P {x}\<flat>"
-  assumes plus: "\<And>xs ys. \<lbrakk>P xs; P ys\<rbrakk> \<Longrightarrow> P (xs +\<flat> ys)"
-  shows "P (xs::'a lower_pd)"
-apply (induct xs rule: lower_pd.principal_induct, rule P)
-apply (induct_tac a rule: pd_basis_induct)
-apply (simp only: lower_unit_Rep_compact_basis [symmetric] unit)
-apply (simp only: lower_plus_principal [symmetric] plus)
-done
-
-
-subsection {* Monadic bind *}
-
-definition
-  lower_bind_basis ::
-  "'a pd_basis \<Rightarrow> ('a \<rightarrow> 'b lower_pd) \<rightarrow> 'b lower_pd" where
-  "lower_bind_basis = fold_pd
-    (\<lambda>a. \<Lambda> f. f\<cdot>(Rep_compact_basis a))
-    (\<lambda>x y. \<Lambda> f. x\<cdot>f +\<flat> y\<cdot>f)"
-
-lemma ACI_lower_bind:
-  "class.ab_semigroup_idem_mult (\<lambda>x y. \<Lambda> f. x\<cdot>f +\<flat> y\<cdot>f)"
-apply unfold_locales
-apply (simp add: lower_plus_assoc)
-apply (simp add: lower_plus_commute)
-apply (simp add: eta_cfun)
-done
-
-lemma lower_bind_basis_simps [simp]:
-  "lower_bind_basis (PDUnit a) =
-    (\<Lambda> f. f\<cdot>(Rep_compact_basis a))"
-  "lower_bind_basis (PDPlus t u) =
-    (\<Lambda> f. lower_bind_basis t\<cdot>f +\<flat> lower_bind_basis u\<cdot>f)"
-unfolding lower_bind_basis_def
-apply -
-apply (rule fold_pd_PDUnit [OF ACI_lower_bind])
-apply (rule fold_pd_PDPlus [OF ACI_lower_bind])
-done
-
-lemma lower_bind_basis_mono:
-  "t \<le>\<flat> u \<Longrightarrow> lower_bind_basis t \<sqsubseteq> lower_bind_basis u"
-unfolding cfun_below_iff
-apply (erule lower_le_induct, safe)
-apply (simp add: monofun_cfun)
-apply (simp add: rev_below_trans [OF lower_plus_below1])
-apply simp
-done
-
-definition
-  lower_bind :: "'a lower_pd \<rightarrow> ('a \<rightarrow> 'b lower_pd) \<rightarrow> 'b lower_pd" where
-  "lower_bind = lower_pd.basis_fun lower_bind_basis"
-
-lemma lower_bind_principal [simp]:
-  "lower_bind\<cdot>(lower_principal t) = lower_bind_basis t"
-unfolding lower_bind_def
-apply (rule lower_pd.basis_fun_principal)
-apply (erule lower_bind_basis_mono)
-done
-
-lemma lower_bind_unit [simp]:
-  "lower_bind\<cdot>{x}\<flat>\<cdot>f = f\<cdot>x"
-by (induct x rule: compact_basis.principal_induct, simp, simp)
-
-lemma lower_bind_plus [simp]:
-  "lower_bind\<cdot>(xs +\<flat> ys)\<cdot>f = lower_bind\<cdot>xs\<cdot>f +\<flat> lower_bind\<cdot>ys\<cdot>f"
-by (induct xs ys rule: lower_pd.principal_induct2, simp, simp, simp)
-
-lemma lower_bind_strict [simp]: "lower_bind\<cdot>\<bottom>\<cdot>f = f\<cdot>\<bottom>"
-unfolding lower_unit_strict [symmetric] by (rule lower_bind_unit)
-
-lemma lower_bind_bind:
-  "lower_bind\<cdot>(lower_bind\<cdot>xs\<cdot>f)\<cdot>g = lower_bind\<cdot>xs\<cdot>(\<Lambda> x. lower_bind\<cdot>(f\<cdot>x)\<cdot>g)"
-by (induct xs, simp_all)
-
-
-subsection {* Map *}
-
-definition
-  lower_map :: "('a \<rightarrow> 'b) \<rightarrow> 'a lower_pd \<rightarrow> 'b lower_pd" where
-  "lower_map = (\<Lambda> f xs. lower_bind\<cdot>xs\<cdot>(\<Lambda> x. {f\<cdot>x}\<flat>))"
-
-lemma lower_map_unit [simp]:
-  "lower_map\<cdot>f\<cdot>{x}\<flat> = {f\<cdot>x}\<flat>"
-unfolding lower_map_def by simp
-
-lemma lower_map_plus [simp]:
-  "lower_map\<cdot>f\<cdot>(xs +\<flat> ys) = lower_map\<cdot>f\<cdot>xs +\<flat> lower_map\<cdot>f\<cdot>ys"
-unfolding lower_map_def by simp
-
-lemma lower_map_bottom [simp]: "lower_map\<cdot>f\<cdot>\<bottom> = {f\<cdot>\<bottom>}\<flat>"
-unfolding lower_map_def by simp
-
-lemma lower_map_ident: "lower_map\<cdot>(\<Lambda> x. x)\<cdot>xs = xs"
-by (induct xs rule: lower_pd_induct, simp_all)
-
-lemma lower_map_ID: "lower_map\<cdot>ID = ID"
-by (simp add: cfun_eq_iff ID_def lower_map_ident)
-
-lemma lower_map_map:
-  "lower_map\<cdot>f\<cdot>(lower_map\<cdot>g\<cdot>xs) = lower_map\<cdot>(\<Lambda> x. f\<cdot>(g\<cdot>x))\<cdot>xs"
-by (induct xs rule: lower_pd_induct, simp_all)
-
-lemma ep_pair_lower_map: "ep_pair e p \<Longrightarrow> ep_pair (lower_map\<cdot>e) (lower_map\<cdot>p)"
-apply default
-apply (induct_tac x rule: lower_pd_induct, simp_all add: ep_pair.e_inverse)
-apply (induct_tac y rule: lower_pd_induct)
-apply (simp_all add: ep_pair.e_p_below monofun_cfun del: lower_plus_below_iff)
-done
-
-lemma deflation_lower_map: "deflation d \<Longrightarrow> deflation (lower_map\<cdot>d)"
-apply default
-apply (induct_tac x rule: lower_pd_induct, simp_all add: deflation.idem)
-apply (induct_tac x rule: lower_pd_induct)
-apply (simp_all add: deflation.below monofun_cfun del: lower_plus_below_iff)
-done
-
-(* FIXME: long proof! *)
-lemma finite_deflation_lower_map:
-  assumes "finite_deflation d" shows "finite_deflation (lower_map\<cdot>d)"
-proof (rule finite_deflation_intro)
-  interpret d: finite_deflation d by fact
-  have "deflation d" by fact
-  thus "deflation (lower_map\<cdot>d)" by (rule deflation_lower_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 (lower_principal ` Rep_pd_basis -` (Pow (Rep_compact_basis -` range (\<lambda>x. d\<cdot>x))))" by simp
-  hence "finite (range (\<lambda>xs. lower_map\<cdot>d\<cdot>xs))"
-    apply (rule rev_finite_subset)
-    apply clarsimp
-    apply (induct_tac xs rule: lower_pd.principal_induct)
-    apply (simp add: adm_mem_finite *)
-    apply (rename_tac t, induct_tac t rule: pd_basis_induct)
-    apply (simp only: lower_unit_Rep_compact_basis [symmetric] lower_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: lower_plus_principal [symmetric] lower_map_plus)
-    apply clarsimp
-    apply (rule imageI)
-    apply (rule vimageI2)
-    apply (simp add: Rep_PDPlus)
-    done
-  thus "finite {xs. lower_map\<cdot>d\<cdot>xs = xs}"
-    by (rule finite_range_imp_finite_fixes)
-qed
-
-subsection {* Lower powerdomain is a domain *}
-
-definition
-  lower_approx :: "nat \<Rightarrow> udom lower_pd \<rightarrow> udom lower_pd"
-where
-  "lower_approx = (\<lambda>i. lower_map\<cdot>(udom_approx i))"
-
-lemma lower_approx: "approx_chain lower_approx"
-using lower_map_ID finite_deflation_lower_map
-unfolding lower_approx_def by (rule approx_chain_lemma1)
-
-definition lower_defl :: "defl \<rightarrow> defl"
-where "lower_defl = defl_fun1 lower_approx lower_map"
-
-lemma cast_lower_defl:
-  "cast\<cdot>(lower_defl\<cdot>A) =
-    udom_emb lower_approx oo lower_map\<cdot>(cast\<cdot>A) oo udom_prj lower_approx"
-using lower_approx finite_deflation_lower_map
-unfolding lower_defl_def by (rule cast_defl_fun1)
-
-instantiation lower_pd :: ("domain") liftdomain
-begin
-
-definition
-  "emb = udom_emb lower_approx oo lower_map\<cdot>emb"
-
-definition
-  "prj = lower_map\<cdot>prj oo udom_prj lower_approx"
-
-definition
-  "defl (t::'a lower_pd itself) = lower_defl\<cdot>DEFL('a)"
-
-definition
-  "(liftemb :: 'a lower_pd u \<rightarrow> udom) = udom_emb u_approx oo u_map\<cdot>emb"
-
-definition
-  "(liftprj :: udom \<rightarrow> 'a lower_pd u) = u_map\<cdot>prj oo udom_prj u_approx"
-
-definition
-  "liftdefl (t::'a lower_pd itself) = u_defl\<cdot>DEFL('a lower_pd)"
-
-instance
-using liftemb_lower_pd_def liftprj_lower_pd_def liftdefl_lower_pd_def
-proof (rule liftdomain_class_intro)
-  show "ep_pair emb (prj :: udom \<rightarrow> 'a lower_pd)"
-    unfolding emb_lower_pd_def prj_lower_pd_def
-    using ep_pair_udom [OF lower_approx]
-    by (intro ep_pair_comp ep_pair_lower_map ep_pair_emb_prj)
-next
-  show "cast\<cdot>DEFL('a lower_pd) = emb oo (prj :: udom \<rightarrow> 'a lower_pd)"
-    unfolding emb_lower_pd_def prj_lower_pd_def defl_lower_pd_def cast_lower_defl
-    by (simp add: cast_DEFL oo_def cfun_eq_iff lower_map_map)
-qed
-
-end
-
-lemma DEFL_lower: "DEFL('a lower_pd) = lower_defl\<cdot>DEFL('a)"
-by (rule defl_lower_pd_def)
-
-
-subsection {* Join *}
-
-definition
-  lower_join :: "'a lower_pd lower_pd \<rightarrow> 'a lower_pd" where
-  "lower_join = (\<Lambda> xss. lower_bind\<cdot>xss\<cdot>(\<Lambda> xs. xs))"
-
-lemma lower_join_unit [simp]:
-  "lower_join\<cdot>{xs}\<flat> = xs"
-unfolding lower_join_def by simp
-
-lemma lower_join_plus [simp]:
-  "lower_join\<cdot>(xss +\<flat> yss) = lower_join\<cdot>xss +\<flat> lower_join\<cdot>yss"
-unfolding lower_join_def by simp
-
-lemma lower_join_bottom [simp]: "lower_join\<cdot>\<bottom> = \<bottom>"
-unfolding lower_join_def by simp
-
-lemma lower_join_map_unit:
-  "lower_join\<cdot>(lower_map\<cdot>lower_unit\<cdot>xs) = xs"
-by (induct xs rule: lower_pd_induct, simp_all)
-
-lemma lower_join_map_join:
-  "lower_join\<cdot>(lower_map\<cdot>lower_join\<cdot>xsss) = lower_join\<cdot>(lower_join\<cdot>xsss)"
-by (induct xsss rule: lower_pd_induct, simp_all)
-
-lemma lower_join_map_map:
-  "lower_join\<cdot>(lower_map\<cdot>(lower_map\<cdot>f)\<cdot>xss) =
-   lower_map\<cdot>f\<cdot>(lower_join\<cdot>xss)"
-by (induct xss rule: lower_pd_induct, simp_all)
-
-end

--- a/src/HOLCF/Map_Functions.thy	Sat Nov 27 14:34:54 2010 -0800
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,464 +0,0 @@
-(*  Title:      HOLCF/Map_Functions.thy
-    Author:     Brian Huffman
-*)
-
-header {* Map functions for various types *}
-
-theory Map_Functions
-imports Deflation
-begin
-
-subsection {* Map operator for continuous function space *}
-
-default_sort cpo
-
-definition
-  cfun_map :: "('b \<rightarrow> 'a) \<rightarrow> ('c \<rightarrow> 'd) \<rightarrow> ('a \<rightarrow> 'c) \<rightarrow> ('b \<rightarrow> 'd)"
-where
-  "cfun_map = (\<Lambda> a b f x. b\<cdot>(f\<cdot>(a\<cdot>x)))"
-
-lemma cfun_map_beta [simp]: "cfun_map\<cdot>a\<cdot>b\<cdot>f\<cdot>x = b\<cdot>(f\<cdot>(a\<cdot>x))"
-unfolding cfun_map_def by simp
-
-lemma cfun_map_ID: "cfun_map\<cdot>ID\<cdot>ID = ID"
-unfolding cfun_eq_iff by simp
-
-lemma cfun_map_map:
-  "cfun_map\<cdot>f1\<cdot>g1\<cdot>(cfun_map\<cdot>f2\<cdot>g2\<cdot>p) =
-    cfun_map\<cdot>(\<Lambda> x. f2\<cdot>(f1\<cdot>x))\<cdot>(\<Lambda> x. g1\<cdot>(g2\<cdot>x))\<cdot>p"
-by (rule cfun_eqI) simp
-
-lemma ep_pair_cfun_map:
-  assumes "ep_pair e1 p1" and "ep_pair e2 p2"
-  shows "ep_pair (cfun_map\<cdot>p1\<cdot>e2) (cfun_map\<cdot>e1\<cdot>p2)"
-proof
-  interpret e1p1: ep_pair e1 p1 by fact
-  interpret e2p2: ep_pair e2 p2 by fact
-  fix f show "cfun_map\<cdot>e1\<cdot>p2\<cdot>(cfun_map\<cdot>p1\<cdot>e2\<cdot>f) = f"
-    by (simp add: cfun_eq_iff)
-  fix g show "cfun_map\<cdot>p1\<cdot>e2\<cdot>(cfun_map\<cdot>e1\<cdot>p2\<cdot>g) \<sqsubseteq> g"
-    apply (rule cfun_belowI, simp)
-    apply (rule below_trans [OF e2p2.e_p_below])
-    apply (rule monofun_cfun_arg)
-    apply (rule e1p1.e_p_below)
-    done
-qed
-
-lemma deflation_cfun_map:
-  assumes "deflation d1" and "deflation d2"
-  shows "deflation (cfun_map\<cdot>d1\<cdot>d2)"
-proof
-  interpret d1: deflation d1 by fact
-  interpret d2: deflation d2 by fact
-  fix f
-  show "cfun_map\<cdot>d1\<cdot>d2\<cdot>(cfun_map\<cdot>d1\<cdot>d2\<cdot>f) = cfun_map\<cdot>d1\<cdot>d2\<cdot>f"
-    by (simp add: cfun_eq_iff d1.idem d2.idem)
-  show "cfun_map\<cdot>d1\<cdot>d2\<cdot>f \<sqsubseteq> f"
-    apply (rule cfun_belowI, simp)
-    apply (rule below_trans [OF d2.below])
-    apply (rule monofun_cfun_arg)
-    apply (rule d1.below)
-    done
-qed
-
-lemma finite_range_cfun_map:
-  assumes a: "finite (range (\<lambda>x. a\<cdot>x))"
-  assumes b: "finite (range (\<lambda>y. b\<cdot>y))"
-  shows "finite (range (\<lambda>f. cfun_map\<cdot>a\<cdot>b\<cdot>f))"  (is "finite (range ?h)")
-proof (rule finite_imageD)
-  let ?f = "\<lambda>g. range (\<lambda>x. (a\<cdot>x, g\<cdot>x))"
-  show "finite (?f ` range ?h)"
-  proof (rule finite_subset)
-    let ?B = "Pow (range (\<lambda>x. a\<cdot>x) \<times> range (\<lambda>y. b\<cdot>y))"
-    show "?f ` range ?h \<subseteq> ?B"
-      by clarsimp
-    show "finite ?B"
-      by (simp add: a b)
-  qed
-  show "inj_on ?f (range ?h)"
-  proof (rule inj_onI, rule cfun_eqI, clarsimp)
-    fix x f g
-    assume "range (\<lambda>x. (a\<cdot>x, b\<cdot>(f\<cdot>(a\<cdot>x)))) = range (\<lambda>x. (a\<cdot>x, b\<cdot>(g\<cdot>(a\<cdot>x))))"
-    hence "range (\<lambda>x. (a\<cdot>x, b\<cdot>(f\<cdot>(a\<cdot>x)))) \<subseteq> range (\<lambda>x. (a\<cdot>x, b\<cdot>(g\<cdot>(a\<cdot>x))))"
-      by (rule equalityD1)
-    hence "(a\<cdot>x, b\<cdot>(f\<cdot>(a\<cdot>x))) \<in> range (\<lambda>x. (a\<cdot>x, b\<cdot>(g\<cdot>(a\<cdot>x))))"
-      by (simp add: subset_eq)
-    then obtain y where "(a\<cdot>x, b\<cdot>(f\<cdot>(a\<cdot>x))) = (a\<cdot>y, b\<cdot>(g\<cdot>(a\<cdot>y)))"
-      by (rule rangeE)
-    thus "b\<cdot>(f\<cdot>(a\<cdot>x)) = b\<cdot>(g\<cdot>(a\<cdot>x))"
-      by clarsimp
-  qed
-qed
-
-lemma finite_deflation_cfun_map:
-  assumes "finite_deflation d1" and "finite_deflation d2"
-  shows "finite_deflation (cfun_map\<cdot>d1\<cdot>d2)"
-proof (rule finite_deflation_intro)
-  interpret d1: finite_deflation d1 by fact
-  interpret d2: finite_deflation d2 by fact
-  have "deflation d1" and "deflation d2" by fact+
-  thus "deflation (cfun_map\<cdot>d1\<cdot>d2)" by (rule deflation_cfun_map)
-  have "finite (range (\<lambda>f. cfun_map\<cdot>d1\<cdot>d2\<cdot>f))"
-    using d1.finite_range d2.finite_range
-    by (rule finite_range_cfun_map)
-  thus "finite {f. cfun_map\<cdot>d1\<cdot>d2\<cdot>f = f}"
-    by (rule finite_range_imp_finite_fixes)
-qed
-
-text {* Finite deflations are compact elements of the function space *}
-
-lemma finite_deflation_imp_compact: "finite_deflation d \<Longrightarrow> compact d"
-apply (frule finite_deflation_imp_deflation)
-apply (subgoal_tac "compact (cfun_map\<cdot>d\<cdot>d\<cdot>d)")
-apply (simp add: cfun_map_def deflation.idem eta_cfun)
-apply (rule finite_deflation.compact)
-apply (simp only: finite_deflation_cfun_map)
-done
-
-subsection {* Map operator for product type *}
-
-definition
-  cprod_map :: "('a \<rightarrow> 'b) \<rightarrow> ('c \<rightarrow> 'd) \<rightarrow> 'a \<times> 'c \<rightarrow> 'b \<times> 'd"
-where
-  "cprod_map = (\<Lambda> f g p. (f\<cdot>(fst p), g\<cdot>(snd p)))"
-
-lemma cprod_map_Pair [simp]: "cprod_map\<cdot>f\<cdot>g\<cdot>(x, y) = (f\<cdot>x, g\<cdot>y)"
-unfolding cprod_map_def by simp
-
-lemma cprod_map_ID: "cprod_map\<cdot>ID\<cdot>ID = ID"
-unfolding cfun_eq_iff by auto
-
-lemma cprod_map_map:
-  "cprod_map\<cdot>f1\<cdot>g1\<cdot>(cprod_map\<cdot>f2\<cdot>g2\<cdot>p) =
-    cprod_map\<cdot>(\<Lambda> x. f1\<cdot>(f2\<cdot>x))\<cdot>(\<Lambda> x. g1\<cdot>(g2\<cdot>x))\<cdot>p"
-by (induct p) simp
-
-lemma ep_pair_cprod_map:
-  assumes "ep_pair e1 p1" and "ep_pair e2 p2"
-  shows "ep_pair (cprod_map\<cdot>e1\<cdot>e2) (cprod_map\<cdot>p1\<cdot>p2)"
-proof
-  interpret e1p1: ep_pair e1 p1 by fact
-  interpret e2p2: ep_pair e2 p2 by fact
-  fix x show "cprod_map\<cdot>p1\<cdot>p2\<cdot>(cprod_map\<cdot>e1\<cdot>e2\<cdot>x) = x"
-    by (induct x) simp
-  fix y show "cprod_map\<cdot>e1\<cdot>e2\<cdot>(cprod_map\<cdot>p1\<cdot>p2\<cdot>y) \<sqsubseteq> y"
-    by (induct y) (simp add: e1p1.e_p_below e2p2.e_p_below)
-qed
-
-lemma deflation_cprod_map:
-  assumes "deflation d1" and "deflation d2"
-  shows "deflation (cprod_map\<cdot>d1\<cdot>d2)"
-proof
-  interpret d1: deflation d1 by fact
-  interpret d2: deflation d2 by fact
-  fix x
-  show "cprod_map\<cdot>d1\<cdot>d2\<cdot>(cprod_map\<cdot>d1\<cdot>d2\<cdot>x) = cprod_map\<cdot>d1\<cdot>d2\<cdot>x"
-    by (induct x) (simp add: d1.idem d2.idem)
-  show "cprod_map\<cdot>d1\<cdot>d2\<cdot>x \<sqsubseteq> x"
-    by (induct x) (simp add: d1.below d2.below)
-qed
-
-lemma finite_deflation_cprod_map:
-  assumes "finite_deflation d1" and "finite_deflation d2"
-  shows "finite_deflation (cprod_map\<cdot>d1\<cdot>d2)"
-proof (rule finite_deflation_intro)
-  interpret d1: finite_deflation d1 by fact
-  interpret d2: finite_deflation d2 by fact
-  have "deflation d1" and "deflation d2" by fact+
-  thus "deflation (cprod_map\<cdot>d1\<cdot>d2)" by (rule deflation_cprod_map)
-  have "{p. cprod_map\<cdot>d1\<cdot>d2\<cdot>p = p} \<subseteq> {x. d1\<cdot>x = x} \<times> {y. d2\<cdot>y = y}"
-    by clarsimp
-  thus "finite {p. cprod_map\<cdot>d1\<cdot>d2\<cdot>p = p}"
-    by (rule finite_subset, simp add: d1.finite_fixes d2.finite_fixes)
-qed
-
-subsection {* Map function for lifted cpo *}
-
-definition
-  u_map :: "('a \<rightarrow> 'b) \<rightarrow> 'a u \<rightarrow> 'b u"
-where
-  "u_map = (\<Lambda> f. fup\<cdot>(up oo f))"
-
-lemma u_map_strict [simp]: "u_map\<cdot>f\<cdot>\<bottom> = \<bottom>"
-unfolding u_map_def by simp
-
-lemma u_map_up [simp]: "u_map\<cdot>f\<cdot>(up\<cdot>x) = up\<cdot>(f\<cdot>x)"
-unfolding u_map_def by simp
-
-lemma u_map_ID: "u_map\<cdot>ID = ID"
-unfolding u_map_def by (simp add: cfun_eq_iff eta_cfun)
-
-lemma u_map_map: "u_map\<cdot>f\<cdot>(u_map\<cdot>g\<cdot>p) = u_map\<cdot>(\<Lambda> x. f\<cdot>(g\<cdot>x))\<cdot>p"
-by (induct p) simp_all
-
-lemma ep_pair_u_map: "ep_pair e p \<Longrightarrow> ep_pair (u_map\<cdot>e) (u_map\<cdot>p)"
-apply default
-apply (case_tac x, simp, simp add: ep_pair.e_inverse)
-apply (case_tac y, simp, simp add: ep_pair.e_p_below)
-done
-
-lemma deflation_u_map: "deflation d \<Longrightarrow> deflation (u_map\<cdot>d)"
-apply default
-apply (case_tac x, simp, simp add: deflation.idem)
-apply (case_tac x, simp, simp add: deflation.below)
-done
-
-lemma finite_deflation_u_map:
-  assumes "finite_deflation d" shows "finite_deflation (u_map\<cdot>d)"
-proof (rule finite_deflation_intro)
-  interpret d: finite_deflation d by fact
-  have "deflation d" by fact
-  thus "deflation (u_map\<cdot>d)" by (rule deflation_u_map)
-  have "{x. u_map\<cdot>d\<cdot>x = x} \<subseteq> insert \<bottom> ((\<lambda>x. up\<cdot>x) ` {x. d\<cdot>x = x})"
-    by (rule subsetI, case_tac x, simp_all)
-  thus "finite {x. u_map\<cdot>d\<cdot>x = x}"
-    by (rule finite_subset, simp add: d.finite_fixes)
-qed
-
-subsection {* Map function for strict products *}
-
-default_sort pcpo
-
-definition
-  sprod_map :: "('a \<rightarrow> 'b) \<rightarrow> ('c \<rightarrow> 'd) \<rightarrow> 'a \<otimes> 'c \<rightarrow> 'b \<otimes> 'd"
-where
-  "sprod_map = (\<Lambda> f g. ssplit\<cdot>(\<Lambda> x y. (:f\<cdot>x, g\<cdot>y:)))"
-
-lemma sprod_map_strict [simp]: "sprod_map\<cdot>a\<cdot>b\<cdot>\<bottom> = \<bottom>"
-unfolding sprod_map_def by simp
-
-lemma sprod_map_spair [simp]:
-  "x \<noteq> \<bottom> \<Longrightarrow> y \<noteq> \<bottom> \<Longrightarrow> sprod_map\<cdot>f\<cdot>g\<cdot>(:x, y:) = (:f\<cdot>x, g\<cdot>y:)"
-by (simp add: sprod_map_def)
-
-lemma sprod_map_spair':
-  "f\<cdot>\<bottom> = \<bottom> \<Longrightarrow> g\<cdot>\<bottom> = \<bottom> \<Longrightarrow> sprod_map\<cdot>f\<cdot>g\<cdot>(:x, y:) = (:f\<cdot>x, g\<cdot>y:)"
-by (cases "x = \<bottom> \<or> y = \<bottom>") auto
-
-lemma sprod_map_ID: "sprod_map\<cdot>ID\<cdot>ID = ID"
-unfolding sprod_map_def by (simp add: cfun_eq_iff eta_cfun)
-
-lemma sprod_map_map:
-  "\<lbrakk>f1\<cdot>\<bottom> = \<bottom>; g1\<cdot>\<bottom> = \<bottom>\<rbrakk> \<Longrightarrow>
-    sprod_map\<cdot>f1\<cdot>g1\<cdot>(sprod_map\<cdot>f2\<cdot>g2\<cdot>p) =
-     sprod_map\<cdot>(\<Lambda> x. f1\<cdot>(f2\<cdot>x))\<cdot>(\<Lambda> x. g1\<cdot>(g2\<cdot>x))\<cdot>p"
-apply (induct p, simp)
-apply (case_tac "f2\<cdot>x = \<bottom>", simp)
-apply (case_tac "g2\<cdot>y = \<bottom>", simp)
-apply simp
-done
-
-lemma ep_pair_sprod_map:
-  assumes "ep_pair e1 p1" and "ep_pair e2 p2"
-  shows "ep_pair (sprod_map\<cdot>e1\<cdot>e2) (sprod_map\<cdot>p1\<cdot>p2)"
-proof
-  interpret e1p1: pcpo_ep_pair e1 p1 unfolding pcpo_ep_pair_def by fact
-  interpret e2p2: pcpo_ep_pair e2 p2 unfolding pcpo_ep_pair_def by fact
-  fix x show "sprod_map\<cdot>p1\<cdot>p2\<cdot>(sprod_map\<cdot>e1\<cdot>e2\<cdot>x) = x"
-    by (induct x) simp_all
-  fix y show "sprod_map\<cdot>e1\<cdot>e2\<cdot>(sprod_map\<cdot>p1\<cdot>p2\<cdot>y) \<sqsubseteq> y"
-    apply (induct y, simp)
-    apply (case_tac "p1\<cdot>x = \<bottom>", simp, case_tac "p2\<cdot>y = \<bottom>", simp)
-    apply (simp add: monofun_cfun e1p1.e_p_below e2p2.e_p_below)
-    done
-qed
-
-lemma deflation_sprod_map:
-  assumes "deflation d1" and "deflation d2"
-  shows "deflation (sprod_map\<cdot>d1\<cdot>d2)"
-proof
-  interpret d1: deflation d1 by fact
-  interpret d2: deflation d2 by fact
-  fix x
-  show "sprod_map\<cdot>d1\<cdot>d2\<cdot>(sprod_map\<cdot>d1\<cdot>d2\<cdot>x) = sprod_map\<cdot>d1\<cdot>d2\<cdot>x"
-    apply (induct x, simp)
-    apply (case_tac "d1\<cdot>x = \<bottom>", simp, case_tac "d2\<cdot>y = \<bottom>", simp)
-    apply (simp add: d1.idem d2.idem)
-    done
-  show "sprod_map\<cdot>d1\<cdot>d2\<cdot>x \<sqsubseteq> x"
-    apply (induct x, simp)
-    apply (simp add: monofun_cfun d1.below d2.below)
-    done
-qed
-
-lemma finite_deflation_sprod_map:
-  assumes "finite_deflation d1" and "finite_deflation d2"
-  shows "finite_deflation (sprod_map\<cdot>d1\<cdot>d2)"
-proof (rule finite_deflation_intro)
-  interpret d1: finite_deflation d1 by fact
-  interpret d2: finite_deflation d2 by fact
-  have "deflation d1" and "deflation d2" by fact+
-  thus "deflation (sprod_map\<cdot>d1\<cdot>d2)" by (rule deflation_sprod_map)
-  have "{x. sprod_map\<cdot>d1\<cdot>d2\<cdot>x = x} \<subseteq> insert \<bottom>
-        ((\<lambda>(x, y). (:x, y:)) ` ({x. d1\<cdot>x = x} \<times> {y. d2\<cdot>y = y}))"
-    by (rule subsetI, case_tac x, auto simp add: spair_eq_iff)
-  thus "finite {x. sprod_map\<cdot>d1\<cdot>d2\<cdot>x = x}"
-    by (rule finite_subset, simp add: d1.finite_fixes d2.finite_fixes)
-qed
-
-subsection {* Map function for strict sums *}
-
-definition
-  ssum_map :: "('a \<rightarrow> 'b) \<rightarrow> ('c \<rightarrow> 'd) \<rightarrow> 'a \<oplus> 'c \<rightarrow> 'b \<oplus> 'd"
-where
-  "ssum_map = (\<Lambda> f g. sscase\<cdot>(sinl oo f)\<cdot>(sinr oo g))"
-
-lemma ssum_map_strict [simp]: "ssum_map\<cdot>f\<cdot>g\<cdot>\<bottom> = \<bottom>"
-unfolding ssum_map_def by simp
-
-lemma ssum_map_sinl [simp]: "x \<noteq> \<bottom> \<Longrightarrow> ssum_map\<cdot>f\<cdot>g\<cdot>(sinl\<cdot>x) = sinl\<cdot>(f\<cdot>x)"
-unfolding ssum_map_def by simp
-
-lemma ssum_map_sinr [simp]: "x \<noteq> \<bottom> \<Longrightarrow> ssum_map\<cdot>f\<cdot>g\<cdot>(sinr\<cdot>x) = sinr\<cdot>(g\<cdot>x)"
-unfolding ssum_map_def by simp
-
-lemma ssum_map_sinl': "f\<cdot>\<bottom> = \<bottom> \<Longrightarrow> ssum_map\<cdot>f\<cdot>g\<cdot>(sinl\<cdot>x) = sinl\<cdot>(f\<cdot>x)"
-by (cases "x = \<bottom>") simp_all
-
-lemma ssum_map_sinr': "g\<cdot>\<bottom> = \<bottom> \<Longrightarrow> ssum_map\<cdot>f\<cdot>g\<cdot>(sinr\<cdot>x) = sinr\<cdot>(g\<cdot>x)"
-by (cases "x = \<bottom>") simp_all
-
-lemma ssum_map_ID: "ssum_map\<cdot>ID\<cdot>ID = ID"
-unfolding ssum_map_def by (simp add: cfun_eq_iff eta_cfun)
-
-lemma ssum_map_map:
-  "\<lbrakk>f1\<cdot>\<bottom> = \<bottom>; g1\<cdot>\<bottom> = \<bottom>\<rbrakk> \<Longrightarrow>
-    ssum_map\<cdot>f1\<cdot>g1\<cdot>(ssum_map\<cdot>f2\<cdot>g2\<cdot>p) =
-     ssum_map\<cdot>(\<Lambda> x. f1\<cdot>(f2\<cdot>x))\<cdot>(\<Lambda> x. g1\<cdot>(g2\<cdot>x))\<cdot>p"
-apply (induct p, simp)
-apply (case_tac "f2\<cdot>x = \<bottom>", simp, simp)
-apply (case_tac "g2\<cdot>y = \<bottom>", simp, simp)
-done
-
-lemma ep_pair_ssum_map:
-  assumes "ep_pair e1 p1" and "ep_pair e2 p2"
-  shows "ep_pair (ssum_map\<cdot>e1\<cdot>e2) (ssum_map\<cdot>p1\<cdot>p2)"
-proof
-  interpret e1p1: pcpo_ep_pair e1 p1 unfolding pcpo_ep_pair_def by fact
-  interpret e2p2: pcpo_ep_pair e2 p2 unfolding pcpo_ep_pair_def by fact
-  fix x show "ssum_map\<cdot>p1\<cdot>p2\<cdot>(ssum_map\<cdot>e1\<cdot>e2\<cdot>x) = x"
-    by (induct x) simp_all
-  fix y show "ssum_map\<cdot>e1\<cdot>e2\<cdot>(ssum_map\<cdot>p1\<cdot>p2\<cdot>y) \<sqsubseteq> y"
-    apply (induct y, simp)
-    apply (case_tac "p1\<cdot>x = \<bottom>", simp, simp add: e1p1.e_p_below)
-    apply (case_tac "p2\<cdot>y = \<bottom>", simp, simp add: e2p2.e_p_below)
-    done
-qed
-
-lemma deflation_ssum_map:
-  assumes "deflation d1" and "deflation d2"
-  shows "deflation (ssum_map\<cdot>d1\<cdot>d2)"
-proof
-  interpret d1: deflation d1 by fact
-  interpret d2: deflation d2 by fact
-  fix x
-  show "ssum_map\<cdot>d1\<cdot>d2\<cdot>(ssum_map\<cdot>d1\<cdot>d2\<cdot>x) = ssum_map\<cdot>d1\<cdot>d2\<cdot>x"
-    apply (induct x, simp)
-    apply (case_tac "d1\<cdot>x = \<bottom>", simp, simp add: d1.idem)
-    apply (case_tac "d2\<cdot>y = \<bottom>", simp, simp add: d2.idem)
-    done
-  show "ssum_map\<cdot>d1\<cdot>d2\<cdot>x \<sqsubseteq> x"
-    apply (induct x, simp)
-    apply (case_tac "d1\<cdot>x = \<bottom>", simp, simp add: d1.below)
-    apply (case_tac "d2\<cdot>y = \<bottom>", simp, simp add: d2.below)
-    done
-qed
-
-lemma finite_deflation_ssum_map:
-  assumes "finite_deflation d1" and "finite_deflation d2"
-  shows "finite_deflation (ssum_map\<cdot>d1\<cdot>d2)"
-proof (rule finite_deflation_intro)
-  interpret d1: finite_deflation d1 by fact
-  interpret d2: finite_deflation d2 by fact
-  have "deflation d1" and "deflation d2" by fact+
-  thus "deflation (ssum_map\<cdot>d1\<cdot>d2)" by (rule deflation_ssum_map)
-  have "{x. ssum_map\<cdot>d1\<cdot>d2\<cdot>x = x} \<subseteq>
-        (\<lambda>x. sinl\<cdot>x) ` {x. d1\<cdot>x = x} \<union>
-        (\<lambda>x. sinr\<cdot>x) ` {x. d2\<cdot>x = x} \<union> {\<bottom>}"
-    by (rule subsetI, case_tac x, simp_all)
-  thus "finite {x. ssum_map\<cdot>d1\<cdot>d2\<cdot>x = x}"
-    by (rule finite_subset, simp add: d1.finite_fixes d2.finite_fixes)
-qed
-
-subsection {* Map operator for strict function space *}
-
-definition
-  sfun_map :: "('b \<rightarrow> 'a) \<rightarrow> ('c \<rightarrow> 'd) \<rightarrow> ('a \<rightarrow>! 'c) \<rightarrow> ('b \<rightarrow>! 'd)"
-where
-  "sfun_map = (\<Lambda> a b. sfun_abs oo cfun_map\<cdot>a\<cdot>b oo sfun_rep)"
-
-lemma sfun_map_ID: "sfun_map\<cdot>ID\<cdot>ID = ID"
-  unfolding sfun_map_def
-  by (simp add: cfun_map_ID cfun_eq_iff)
-
-lemma sfun_map_map:
-  assumes "f2\<cdot>\<bottom> = \<bottom>" and "g2\<cdot>\<bottom> = \<bottom>" shows
-  "sfun_map\<cdot>f1\<cdot>g1\<cdot>(sfun_map\<cdot>f2\<cdot>g2\<cdot>p) =
-    sfun_map\<cdot>(\<Lambda> x. f2\<cdot>(f1\<cdot>x))\<cdot>(\<Lambda> x. g1\<cdot>(g2\<cdot>x))\<cdot>p"
-unfolding sfun_map_def
-by (simp add: cfun_eq_iff strictify_cancel assms cfun_map_map)
-
-lemma ep_pair_sfun_map:
-  assumes 1: "ep_pair e1 p1"
-  assumes 2: "ep_pair e2 p2"
-  shows "ep_pair (sfun_map\<cdot>p1\<cdot>e2) (sfun_map\<cdot>e1\<cdot>p2)"
-proof
-  interpret e1p1: pcpo_ep_pair e1 p1
-    unfolding pcpo_ep_pair_def by fact
-  interpret e2p2: pcpo_ep_pair e2 p2
-    unfolding pcpo_ep_pair_def by fact
-  fix f show "sfun_map\<cdot>e1\<cdot>p2\<cdot>(sfun_map\<cdot>p1\<cdot>e2\<cdot>f) = f"
-    unfolding sfun_map_def
-    apply (simp add: sfun_eq_iff strictify_cancel)
-    apply (rule ep_pair.e_inverse)
-    apply (rule ep_pair_cfun_map [OF 1 2])
-    done
-  fix g show "sfun_map\<cdot>p1\<cdot>e2\<cdot>(sfun_map\<cdot>e1\<cdot>p2\<cdot>g) \<sqsubseteq> g"
-    unfolding sfun_map_def
-    apply (simp add: sfun_below_iff strictify_cancel)
-    apply (rule ep_pair.e_p_below)
-    apply (rule ep_pair_cfun_map [OF 1 2])
-    done
-qed
-
-lemma deflation_sfun_map:
-  assumes 1: "deflation d1"
-  assumes 2: "deflation d2"
-  shows "deflation (sfun_map\<cdot>d1\<cdot>d2)"
-apply (simp add: sfun_map_def)
-apply (rule deflation.intro)
-apply simp
-apply (subst strictify_cancel)
-apply (simp add: cfun_map_def deflation_strict 1 2)
-apply (simp add: cfun_map_def deflation.idem 1 2)
-apply (simp add: sfun_below_iff)
-apply (subst strictify_cancel)
-apply (simp add: cfun_map_def deflation_strict 1 2)
-apply (rule deflation.below)
-apply (rule deflation_cfun_map [OF 1 2])
-done
-
-lemma finite_deflation_sfun_map:
-  assumes 1: "finite_deflation d1"
-  assumes 2: "finite_deflation d2"
-  shows "finite_deflation (sfun_map\<cdot>d1\<cdot>d2)"
-proof (intro finite_deflation_intro)
-  interpret d1: finite_deflation d1 by fact
-  interpret d2: finite_deflation d2 by fact
-  have "deflation d1" and "deflation d2" by fact+
-  thus "deflation (sfun_map\<cdot>d1\<cdot>d2)" by (rule deflation_sfun_map)
-  from 1 2 have "finite_deflation (cfun_map\<cdot>d1\<cdot>d2)"
-    by (rule finite_deflation_cfun_map)
-  then have "finite {f. cfun_map\<cdot>d1\<cdot>d2\<cdot>f = f}"
-    by (rule finite_deflation.finite_fixes)
-  moreover have "inj (\<lambda>f. sfun_rep\<cdot>f)"
-    by (rule inj_onI, simp add: sfun_eq_iff)
-  ultimately have "finite ((\<lambda>f. sfun_rep\<cdot>f) -` {f. cfun_map\<cdot>d1\<cdot>d2\<cdot>f = f})"
-    by (rule finite_vimageI)
-  then show "finite {f. sfun_map\<cdot>d1\<cdot>d2\<cdot>f = f}"
-    unfolding sfun_map_def sfun_eq_iff
-    by (simp add: strictify_cancel
-         deflation_strict `deflation d1` `deflation d2`)
-qed
-
-end

--- a/src/HOLCF/One.thy	Sat Nov 27 14:34:54 2010 -0800
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,72 +0,0 @@
-(*  Title:      HOLCF/One.thy
-    Author:     Oscar Slotosch
-*)
-
-header {* The unit domain *}
-
-theory One
-imports Lift
-begin
-
-types one = "unit lift"
-translations
-  (type) "one" <= (type) "unit lift" 
-
-definition
-  ONE :: "one"
-where
-  "ONE == Def ()"
-
-text {* Exhaustion and Elimination for type @{typ one} *}
-
-lemma Exh_one: "t = \<bottom> \<or> t = ONE"
-unfolding ONE_def by (induct t) simp_all
-
-lemma oneE [case_names bottom ONE]: "\<lbrakk>p = \<bottom> \<Longrightarrow> Q; p = ONE \<Longrightarrow> Q\<rbrakk> \<Longrightarrow> Q"
-unfolding ONE_def by (induct p) simp_all
-
-lemma one_induct [case_names bottom ONE]: "\<lbrakk>P \<bottom>; P ONE\<rbrakk> \<Longrightarrow> P x"
-by (cases x rule: oneE) simp_all
-
-lemma dist_below_one [simp]: "\<not> ONE \<sqsubseteq> \<bottom>"
-unfolding ONE_def by simp
-
-lemma below_ONE [simp]: "x \<sqsubseteq> ONE"
-by (induct x rule: one_induct) simp_all
-
-lemma ONE_below_iff [simp]: "ONE \<sqsubseteq> x \<longleftrightarrow> x = ONE"
-by (induct x rule: one_induct) simp_all
-
-lemma ONE_defined [simp]: "ONE \<noteq> \<bottom>"
-unfolding ONE_def by simp
-
-lemma one_neq_iffs [simp]:
-  "x \<noteq> ONE \<longleftrightarrow> x = \<bottom>"
-  "ONE \<noteq> x \<longleftrightarrow> x = \<bottom>"
-  "x \<noteq> \<bottom> \<longleftrightarrow> x = ONE"
-  "\<bottom> \<noteq> x \<longleftrightarrow> x = ONE"
-by (induct x rule: one_induct) simp_all
-
-lemma compact_ONE: "compact ONE"
-by (rule compact_chfin)
-
-text {* Case analysis function for type @{typ one} *}
-
-definition
-  one_case :: "'a::pcpo \<rightarrow> one \<rightarrow> 'a" where
-  "one_case = (\<Lambda> a x. seq\<cdot>x\<cdot>a)"
-
-translations
-  "case x of XCONST ONE \<Rightarrow> t" == "CONST one_case\<cdot>t\<cdot>x"
-  "\<Lambda> (XCONST ONE). t" == "CONST one_case\<cdot>t"
-
-lemma one_case1 [simp]: "(case \<bottom> of ONE \<Rightarrow> t) = \<bottom>"
-by (simp add: one_case_def)
-
-lemma one_case2 [simp]: "(case ONE of ONE \<Rightarrow> t) = t"
-by (simp add: one_case_def)
-
-lemma one_case3 [simp]: "(case x of ONE \<Rightarrow> ONE) = x"
-by (induct x rule: one_induct) simp_all
-
-end

--- a/src/HOLCF/Pcpo.thy	Sat Nov 27 14:34:54 2010 -0800
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,284 +0,0 @@
-(*  Title:      HOLCF/Pcpo.thy
-    Author:     Franz Regensburger
-*)
-
-header {* Classes cpo and pcpo *}
-
-theory Pcpo
-imports Porder
-begin
-
-subsection {* Complete partial orders *}
-
-text {* The class cpo of chain complete partial orders *}
-
-class cpo = po +
-  assumes cpo: "chain S \<Longrightarrow> \<exists>x. range S <<| x"
-begin
-
-text {* in cpo's everthing equal to THE lub has lub properties for every chain *}
-
-lemma cpo_lubI: "chain S \<Longrightarrow> range S <<| (\<Squnion>i. S i)"
-  by (fast dest: cpo elim: is_lub_lub)
-
-lemma thelubE: "\<lbrakk>chain S; (\<Squnion>i. S i) = l\<rbrakk> \<Longrightarrow> range S <<| l"
-  by (blast dest: cpo intro: is_lub_lub)
-
-text {* Properties of the lub *}
-
-lemma is_ub_thelub: "chain S \<Longrightarrow> S x \<sqsubseteq> (\<Squnion>i. S i)"
-  by (blast dest: cpo intro: is_lub_lub [THEN is_lub_rangeD1])
-
-lemma is_lub_thelub:
-  "\<lbrakk>chain S; range S <| x\<rbrakk> \<Longrightarrow> (\<Squnion>i. S i) \<sqsubseteq> x"
-  by (blast dest: cpo intro: is_lub_lub [THEN is_lubD2])
-
-lemma lub_below_iff: "chain S \<Longrightarrow> (\<Squnion>i. S i) \<sqsubseteq> x \<longleftrightarrow> (\<forall>i. S i \<sqsubseteq> x)"
-  by (simp add: is_lub_below_iff [OF cpo_lubI] is_ub_def)
-
-lemma lub_below: "\<lbrakk>chain S; \<And>i. S i \<sqsubseteq> x\<rbrakk> \<Longrightarrow> (\<Squnion>i. S i) \<sqsubseteq> x"
-  by (simp add: lub_below_iff)
-
-lemma below_lub: "\<lbrakk>chain S; x \<sqsubseteq> S i\<rbrakk> \<Longrightarrow> x \<sqsubseteq> (\<Squnion>i. S i)"
-  by (erule below_trans, erule is_ub_thelub)
-
-lemma lub_range_mono:
-  "\<lbrakk>range X \<subseteq> range Y; chain Y; chain X\<rbrakk>
-    \<Longrightarrow> (\<Squnion>i. X i) \<sqsubseteq> (\<Squnion>i. Y i)"
-apply (erule lub_below)
-apply (subgoal_tac "\<exists>j. X i = Y j")
-apply  clarsimp
-apply  (erule is_ub_thelub)
-apply auto
-done
-
-lemma lub_range_shift:
-  "chain Y \<Longrightarrow> (\<Squnion>i. Y (i + j)) = (\<Squnion>i. Y i)"
-apply (rule below_antisym)
-apply (rule lub_range_mono)
-apply    fast
-apply   assumption
-apply (erule chain_shift)
-apply (rule lub_below)
-apply assumption
-apply (rule_tac i="i" in below_lub)
-apply (erule chain_shift)
-apply (erule chain_mono)
-apply (rule le_add1)
-done
-
-lemma maxinch_is_thelub:
-  "chain Y \<Longrightarrow> max_in_chain i Y = ((\<Squnion>i. Y i) = Y i)"
-apply (rule iffI)
-apply (fast intro!: lub_eqI lub_finch1)
-apply (unfold max_in_chain_def)
-apply (safe intro!: below_antisym)
-apply (fast elim!: chain_mono)
-apply (drule sym)
-apply (force elim!: is_ub_thelub)
-done
-
-text {* the @{text "\<sqsubseteq>"} relation between two chains is preserved by their lubs *}
-
-lemma lub_mono:
-  "\<lbrakk>chain X; chain Y; \<And>i. X i \<sqsubseteq> Y i\<rbrakk> 
-    \<Longrightarrow> (\<Squnion>i. X i) \<sqsubseteq> (\<Squnion>i. Y i)"
-by (fast elim: lub_below below_lub)
-
-text {* the = relation between two chains is preserved by their lubs *}
-
-lemma lub_eq:
-  "(\<And>i. X i = Y i) \<Longrightarrow> (\<Squnion>i. X i) = (\<Squnion>i. Y i)"
-  by simp
-
-lemma ch2ch_lub:
-  assumes 1: "\<And>j. chain (\<lambda>i. Y i j)"
-  assumes 2: "\<And>i. chain (\<lambda>j. Y i j)"
-  shows "chain (\<lambda>i. \<Squnion>j. Y i j)"
-apply (rule chainI)
-apply (rule lub_mono [OF 2 2])
-apply (rule chainE [OF 1])
-done
-
-lemma diag_lub:
-  assumes 1: "\<And>j. chain (\<lambda>i. Y i j)"
-  assumes 2: "\<And>i. chain (\<lambda>j. Y i j)"
-  shows "(\<Squnion>i. \<Squnion>j. Y i j) = (\<Squnion>i. Y i i)"
-proof (rule below_antisym)
-  have 3: "chain (\<lambda>i. Y i i)"
-    apply (rule chainI)
-    apply (rule below_trans)
-    apply (rule chainE [OF 1])
-    apply (rule chainE [OF 2])
-    done
-  have 4: "chain (\<lambda>i. \<Squnion>j. Y i j)"
-    by (rule ch2ch_lub [OF 1 2])
-  show "(\<Squnion>i. \<Squnion>j. Y i j) \<sqsubseteq> (\<Squnion>i. Y i i)"
-    apply (rule lub_below [OF 4])
-    apply (rule lub_below [OF 2])
-    apply (rule below_lub [OF 3])
-    apply (rule below_trans)
-    apply (rule chain_mono [OF 1 le_maxI1])
-    apply (rule chain_mono [OF 2 le_maxI2])
-    done
-  show "(\<Squnion>i. Y i i) \<sqsubseteq> (\<Squnion>i. \<Squnion>j. Y i j)"
-    apply (rule lub_mono [OF 3 4])
-    apply (rule is_ub_thelub [OF 2])
-    done
-qed
-
-lemma ex_lub:
-  assumes 1: "\<And>j. chain (\<lambda>i. Y i j)"
-  assumes 2: "\<And>i. chain (\<lambda>j. Y i j)"
-  shows "(\<Squnion>i. \<Squnion>j. Y i j) = (\<Squnion>j. \<Squnion>i. Y i j)"
-  by (simp add: diag_lub 1 2)
-
-end
-
-subsection {* Pointed cpos *}
-
-text {* The class pcpo of pointed cpos *}
-
-class pcpo = cpo +
-  assumes least: "\<exists>x. \<forall>y. x \<sqsubseteq> y"
-begin
-
-definition UU :: 'a where
-  "UU = (THE x. \<forall>y. x \<sqsubseteq> y)"
-
-notation (xsymbols)
-  UU  ("\<bottom>")
-
-text {* derive the old rule minimal *}
- 
-lemma UU_least: "\<forall>z. \<bottom> \<sqsubseteq> z"
-apply (unfold UU_def)
-apply (rule theI')
-apply (rule ex_ex1I)
-apply (rule least)
-apply (blast intro: below_antisym)
-done
-
-lemma minimal [iff]: "\<bottom> \<sqsubseteq> x"
-by (rule UU_least [THEN spec])
-
-end
-
-text {* Simproc to rewrite @{term "\<bottom> = x"} to @{term "x = \<bottom>"}. *}
-
-setup {*
-  Reorient_Proc.add
-    (fn Const(@{const_name UU}, _) => true | _ => false)
-*}
-
-simproc_setup reorient_bottom ("\<bottom> = x") = Reorient_Proc.proc
-
-context pcpo
-begin
-
-text {* useful lemmas about @{term \<bottom>} *}
-
-lemma below_UU_iff [simp]: "(x \<sqsubseteq> \<bottom>) = (x = \<bottom>)"
-by (simp add: po_eq_conv)
-
-lemma eq_UU_iff: "(x = \<bottom>) = (x \<sqsubseteq> \<bottom>)"
-by simp
-
-lemma UU_I: "x \<sqsubseteq> \<bottom> \<Longrightarrow> x = \<bottom>"
-by (subst eq_UU_iff)
-
-lemma lub_eq_bottom_iff: "chain Y \<Longrightarrow> (\<Squnion>i. Y i) = \<bottom> \<longleftrightarrow> (\<forall>i. Y i = \<bottom>)"
-by (simp only: eq_UU_iff lub_below_iff)
-
-lemma chain_UU_I: "\<lbrakk>chain Y; (\<Squnion>i. Y i) = \<bottom>\<rbrakk> \<Longrightarrow> \<forall>i. Y i = \<bottom>"
-by (simp add: lub_eq_bottom_iff)
-
-lemma chain_UU_I_inverse: "\<forall>i::nat. Y i = \<bottom> \<Longrightarrow> (\<Squnion>i. Y i) = \<bottom>"
-by simp
-
-lemma chain_UU_I_inverse2: "(\<Squnion>i. Y i) \<noteq> \<bottom> \<Longrightarrow> \<exists>i::nat. Y i \<noteq> \<bottom>"
-  by (blast intro: chain_UU_I_inverse)
-
-lemma notUU_I: "\<lbrakk>x \<sqsubseteq> y; x \<noteq> \<bottom>\<rbrakk> \<Longrightarrow> y \<noteq> \<bottom>"
-  by (blast intro: UU_I)
-
-end
-
-subsection {* Chain-finite and flat cpos *}
-
-text {* further useful classes for HOLCF domains *}
-
-class chfin = po +
-  assumes chfin: "chain Y \<Longrightarrow> \<exists>n. max_in_chain n Y"
-begin
-
-subclass cpo
-apply default
-apply (frule chfin)
-apply (blast intro: lub_finch1)
-done
-
-lemma chfin2finch: "chain Y \<Longrightarrow> finite_chain Y"
-  by (simp add: chfin finite_chain_def)
-
-end
-
-class flat = pcpo +
-  assumes ax_flat: "x \<sqsubseteq> y \<Longrightarrow> x = \<bottom> \<or> x = y"
-begin
-
-subclass chfin
-apply default
-apply (unfold max_in_chain_def)
-apply (case_tac "\<forall>i. Y i = \<bottom>")
-apply simp
-apply simp
-apply (erule exE)
-apply (rule_tac x="i" in exI)
-apply clarify
-apply (blast dest: chain_mono ax_flat)
-done
-
-lemma flat_below_iff:
-  shows "(x \<sqsubseteq> y) = (x = \<bottom> \<or> x = y)"
-  by (safe dest!: ax_flat)
-
-lemma flat_eq: "a \<noteq> \<bottom> \<Longrightarrow> a \<sqsubseteq> b = (a = b)"
-  by (safe dest!: ax_flat)
-
-end
-
-subsection {* Discrete cpos *}
-
-class discrete_cpo = below +
-  assumes discrete_cpo [simp]: "x \<sqsubseteq> y \<longleftrightarrow> x = y"
-begin
-
-subclass po
-proof qed simp_all
-
-text {* In a discrete cpo, every chain is constant *}
-
-lemma discrete_chain_const:
-  assumes S: "chain S"
-  shows "\<exists>x. S = (\<lambda>i. x)"
-proof (intro exI ext)
-  fix i :: nat
-  have "S 0 \<sqsubseteq> S i" using S le0 by (rule chain_mono)
-  hence "S 0 = S i" by simp
-  thus "S i = S 0" by (rule sym)
-qed
-
-subclass chfin
-proof
-  fix S :: "nat \<Rightarrow> 'a"
-  assume S: "chain S"
-  hence "\<exists>x. S = (\<lambda>i. x)" by (rule discrete_chain_const)
-  hence "max_in_chain 0 S"
-    unfolding max_in_chain_def by auto
-  thus "\<exists>i. max_in_chain i S" ..
-qed
-
-end
-
-end

--- a/src/HOLCF/Plain_HOLCF.thy	Sat Nov 27 14:34:54 2010 -0800
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,15 +0,0 @@
-(*  Title:      HOLCF/Plain_HOLCF.thy
-    Author:     Brian Huffman
-*)
-
-header {* Plain HOLCF *}
-
-theory Plain_HOLCF
-imports Cfun Sfun Cprod Sprod Ssum Up Discrete Lift One Tr Fix
-begin
-
-text {*
-  Basic HOLCF concepts and types; does not include definition packages.
-*}
-
-end

--- a/src/HOLCF/Porder.thy	Sat Nov 27 14:34:54 2010 -0800
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,336 +0,0 @@
-(*  Title:      HOLCF/Porder.thy
-    Author:     Franz Regensburger and Brian Huffman
-*)
-
-header {* Partial orders *}
-
-theory Porder
-imports Main
-begin
-
-subsection {* Type class for partial orders *}
-
-class below =
-  fixes below :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
-begin
-
-notation
-  below (infix "<<" 50)
-
-notation (xsymbols)
-  below (infix "\<sqsubseteq>" 50)
-
-lemma below_eq_trans: "\<lbrakk>a \<sqsubseteq> b; b = c\<rbrakk> \<Longrightarrow> a \<sqsubseteq> c"
-  by (rule subst)
-
-lemma eq_below_trans: "\<lbrakk>a = b; b \<sqsubseteq> c\<rbrakk> \<Longrightarrow> a \<sqsubseteq> c"
-  by (rule ssubst)
-
-end
-
-class po = below +
-  assumes below_refl [iff]: "x \<sqsubseteq> x"
-  assumes below_trans: "x \<sqsubseteq> y \<Longrightarrow> y \<sqsubseteq> z \<Longrightarrow> x \<sqsubseteq> z"
-  assumes below_antisym: "x \<sqsubseteq> y \<Longrightarrow> y \<sqsubseteq> x \<Longrightarrow> x = y"
-begin
-
-lemma eq_imp_below: "x = y \<Longrightarrow> x \<sqsubseteq> y"
-  by simp
-
-lemma box_below: "a \<sqsubseteq> b \<Longrightarrow> c \<sqsubseteq> a \<Longrightarrow> b \<sqsubseteq> d \<Longrightarrow> c \<sqsubseteq> d"
-  by (rule below_trans [OF below_trans])
-
-lemma po_eq_conv: "x = y \<longleftrightarrow> x \<sqsubseteq> y \<and> y \<sqsubseteq> x"
-  by (fast intro!: below_antisym)
-
-lemma rev_below_trans: "y \<sqsubseteq> z \<Longrightarrow> x \<sqsubseteq> y \<Longrightarrow> x \<sqsubseteq> z"
-  by (rule below_trans)
-
-lemma not_below2not_eq: "\<not> x \<sqsubseteq> y \<Longrightarrow> x \<noteq> y"
-  by auto
-
-end
-
-lemmas HOLCF_trans_rules [trans] =
-  below_trans
-  below_antisym
-  below_eq_trans
-  eq_below_trans
-
-context po
-begin
-
-subsection {* Upper bounds *}
-
-definition is_ub :: "'a set \<Rightarrow> 'a \<Rightarrow> bool" (infix "<|" 55) where
-  "S <| x \<longleftrightarrow> (\<forall>y\<in>S. y \<sqsubseteq> x)"
-
-lemma is_ubI: "(\<And>x. x \<in> S \<Longrightarrow> x \<sqsubseteq> u) \<Longrightarrow> S <| u"
-  by (simp add: is_ub_def)
-
-lemma is_ubD: "\<lbrakk>S <| u; x \<in> S\<rbrakk> \<Longrightarrow> x \<sqsubseteq> u"
-  by (simp add: is_ub_def)
-
-lemma ub_imageI: "(\<And>x. x \<in> S \<Longrightarrow> f x \<sqsubseteq> u) \<Longrightarrow> (\<lambda>x. f x) ` S <| u"
-  unfolding is_ub_def by fast
-
-lemma ub_imageD: "\<lbrakk>f ` S <| u; x \<in> S\<rbrakk> \<Longrightarrow> f x \<sqsubseteq> u"
-  unfolding is_ub_def by fast
-
-lemma ub_rangeI: "(\<And>i. S i \<sqsubseteq> x) \<Longrightarrow> range S <| x"
-  unfolding is_ub_def by fast
-
-lemma ub_rangeD: "range S <| x \<Longrightarrow> S i \<sqsubseteq> x"
-  unfolding is_ub_def by fast
-
-lemma is_ub_empty [simp]: "{} <| u"
-  unfolding is_ub_def by fast
-
-lemma is_ub_insert [simp]: "(insert x A) <| y = (x \<sqsubseteq> y \<and> A <| y)"
-  unfolding is_ub_def by fast
-
-lemma is_ub_upward: "\<lbrakk>S <| x; x \<sqsubseteq> y\<rbrakk> \<Longrightarrow> S <| y"
-  unfolding is_ub_def by (fast intro: below_trans)
-
-subsection {* Least upper bounds *}
-
-definition is_lub :: "'a set \<Rightarrow> 'a \<Rightarrow> bool" (infix "<<|" 55) where
-  "S <<| x \<longleftrightarrow> S <| x \<and> (\<forall>u. S <| u \<longrightarrow> x \<sqsubseteq> u)"
-
-definition lub :: "'a set \<Rightarrow> 'a" where
-  "lub S = (THE x. S <<| x)"
-
-end
-
-syntax
-  "_BLub" :: "[pttrn, 'a set, 'b] \<Rightarrow> 'b" ("(3LUB _:_./ _)" [0,0, 10] 10)
-
-syntax (xsymbols)
-  "_BLub" :: "[pttrn, 'a set, 'b] \<Rightarrow> 'b" ("(3\<Squnion>_\<in>_./ _)" [0,0, 10] 10)
-
-translations
-  "LUB x:A. t" == "CONST lub ((%x. t) ` A)"
-
-context po
-begin
-
-abbreviation
-  Lub  (binder "LUB " 10) where
-  "LUB n. t n == lub (range t)"
-
-notation (xsymbols)
-  Lub  (binder "\<Squnion> " 10)
-
-text {* access to some definition as inference rule *}
-
-lemma is_lubD1: "S <<| x \<Longrightarrow> S <| x"
-  unfolding is_lub_def by fast
-
-lemma is_lubD2: "\<lbrakk>S <<| x; S <| u\<rbrakk> \<Longrightarrow> x \<sqsubseteq> u"
-  unfolding is_lub_def by fast
-
-lemma is_lubI: "\<lbrakk>S <| x; \<And>u. S <| u \<Longrightarrow> x \<sqsubseteq> u\<rbrakk> \<Longrightarrow> S <<| x"
-  unfolding is_lub_def by fast
-
-lemma is_lub_below_iff: "S <<| x \<Longrightarrow> x \<sqsubseteq> u \<longleftrightarrow> S <| u"
-  unfolding is_lub_def is_ub_def by (metis below_trans)
-
-text {* lubs are unique *}
-
-lemma is_lub_unique: "\<lbrakk>S <<| x; S <<| y\<rbrakk> \<Longrightarrow> x = y"
-  unfolding is_lub_def is_ub_def by (blast intro: below_antisym)
-
-text {* technical lemmas about @{term lub} and @{term is_lub} *}
-
-lemma is_lub_lub: "M <<| x \<Longrightarrow> M <<| lub M"
-  unfolding lub_def by (rule theI [OF _ is_lub_unique])
-
-lemma lub_eqI: "M <<| l \<Longrightarrow> lub M = l"
-  by (rule is_lub_unique [OF is_lub_lub])
-
-lemma is_lub_singleton: "{x} <<| x"
-  by (simp add: is_lub_def)
-
-lemma lub_singleton [simp]: "lub {x} = x"
-  by (rule is_lub_singleton [THEN lub_eqI])
-
-lemma is_lub_bin: "x \<sqsubseteq> y \<Longrightarrow> {x, y} <<| y"
-  by (simp add: is_lub_def)
-
-lemma lub_bin: "x \<sqsubseteq> y \<Longrightarrow> lub {x, y} = y"
-  by (rule is_lub_bin [THEN lub_eqI])
-
-lemma is_lub_maximal: "\<lbrakk>S <| x; x \<in> S\<rbrakk> \<Longrightarrow> S <<| x"
-  by (erule is_lubI, erule (1) is_ubD)
-
-lemma lub_maximal: "\<lbrakk>S <| x; x \<in> S\<rbrakk> \<Longrightarrow> lub S = x"
-  by (rule is_lub_maximal [THEN lub_eqI])
-
-subsection {* Countable chains *}
-
-definition chain :: "(nat \<Rightarrow> 'a) \<Rightarrow> bool" where
-  -- {* Here we use countable chains and I prefer to code them as functions! *}
-  "chain Y = (\<forall>i. Y i \<sqsubseteq> Y (Suc i))"
-
-lemma chainI: "(\<And>i. Y i \<sqsubseteq> Y (Suc i)) \<Longrightarrow> chain Y"
-  unfolding chain_def by fast
-
-lemma chainE: "chain Y \<Longrightarrow> Y i \<sqsubseteq> Y (Suc i)"
-  unfolding chain_def by fast
-
-text {* chains are monotone functions *}
-
-lemma chain_mono_less: "\<lbrakk>chain Y; i < j\<rbrakk> \<Longrightarrow> Y i \<sqsubseteq> Y j"
-  by (erule less_Suc_induct, erule chainE, erule below_trans)
-
-lemma chain_mono: "\<lbrakk>chain Y; i \<le> j\<rbrakk> \<Longrightarrow> Y i \<sqsubseteq> Y j"
-  by (cases "i = j", simp, simp add: chain_mono_less)
-
-lemma chain_shift: "chain Y \<Longrightarrow> chain (\<lambda>i. Y (i + j))"
-  by (rule chainI, simp, erule chainE)
-
-text {* technical lemmas about (least) upper bounds of chains *}
-
-lemma is_lub_rangeD1: "range S <<| x \<Longrightarrow> S i \<sqsubseteq> x"
-  by (rule is_lubD1 [THEN ub_rangeD])
-
-lemma is_ub_range_shift:
-  "chain S \<Longrightarrow> range (\<lambda>i. S (i + j)) <| x = range S <| x"
-apply (rule iffI)
-apply (rule ub_rangeI)
-apply (rule_tac y="S (i + j)" in below_trans)
-apply (erule chain_mono)
-apply (rule le_add1)
-apply (erule ub_rangeD)
-apply (rule ub_rangeI)
-apply (erule ub_rangeD)
-done
-
-lemma is_lub_range_shift:
-  "chain S \<Longrightarrow> range (\<lambda>i. S (i + j)) <<| x = range S <<| x"
-  by (simp add: is_lub_def is_ub_range_shift)
-
-text {* the lub of a constant chain is the constant *}
-
-lemma chain_const [simp]: "chain (\<lambda>i. c)"
-  by (simp add: chainI)
-
-lemma is_lub_const: "range (\<lambda>x. c) <<| c"
-by (blast dest: ub_rangeD intro: is_lubI ub_rangeI)
-
-lemma lub_const [simp]: "(\<Squnion>i. c) = c"
-  by (rule is_lub_const [THEN lub_eqI])
-
-subsection {* Finite chains *}
-
-definition max_in_chain :: "nat \<Rightarrow> (nat \<Rightarrow> 'a) \<Rightarrow> bool" where
-  -- {* finite chains, needed for monotony of continuous functions *}
-  "max_in_chain i C \<longleftrightarrow> (\<forall>j. i \<le> j \<longrightarrow> C i = C j)"
-
-definition finite_chain :: "(nat \<Rightarrow> 'a) \<Rightarrow> bool" where
-  "finite_chain C = (chain C \<and> (\<exists>i. max_in_chain i C))"
-
-text {* results about finite chains *}
-
-lemma max_in_chainI: "(\<And>j. i \<le> j \<Longrightarrow> Y i = Y j) \<Longrightarrow> max_in_chain i Y"
-  unfolding max_in_chain_def by fast
-
-lemma max_in_chainD: "\<lbrakk>max_in_chain i Y; i \<le> j\<rbrakk> \<Longrightarrow> Y i = Y j"
-  unfolding max_in_chain_def by fast
-
-lemma finite_chainI:
-  "\<lbrakk>chain C; max_in_chain i C\<rbrakk> \<Longrightarrow> finite_chain C"
-  unfolding finite_chain_def by fast
-
-lemma finite_chainE:
-  "\<lbrakk>finite_chain C; \<And>i. \<lbrakk>chain C; max_in_chain i C\<rbrakk> \<Longrightarrow> R\<rbrakk> \<Longrightarrow> R"
-  unfolding finite_chain_def by fast
-
-lemma lub_finch1: "\<lbrakk>chain C; max_in_chain i C\<rbrakk> \<Longrightarrow> range C <<| C i"
-apply (rule is_lubI)
-apply (rule ub_rangeI, rename_tac j)
-apply (rule_tac x=i and y=j in linorder_le_cases)
-apply (drule (1) max_in_chainD, simp)
-apply (erule (1) chain_mono)
-apply (erule ub_rangeD)
-done
-
-lemma lub_finch2:
-  "finite_chain C \<Longrightarrow> range C <<| C (LEAST i. max_in_chain i C)"
-apply (erule finite_chainE)
-apply (erule LeastI2 [where Q="\<lambda>i. range C <<| C i"])
-apply (erule (1) lub_finch1)
-done
-
-lemma finch_imp_finite_range: "finite_chain Y \<Longrightarrow> finite (range Y)"
- apply (erule finite_chainE)
- apply (rule_tac B="Y ` {..i}" in finite_subset)
-  apply (rule subsetI)
-  apply (erule rangeE, rename_tac j)
-  apply (rule_tac x=i and y=j in linorder_le_cases)
-   apply (subgoal_tac "Y j = Y i", simp)
-   apply (simp add: max_in_chain_def)
-  apply simp
- apply simp
-done
-
-lemma finite_range_has_max:
-  fixes f :: "nat \<Rightarrow> 'a" and r :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
-  assumes mono: "\<And>i j. i \<le> j \<Longrightarrow> r (f i) (f j)"
-  assumes finite_range: "finite (range f)"
-  shows "\<exists>k. \<forall>i. r (f i) (f k)"
-proof (intro exI allI)
-  fix i :: nat
-  let ?j = "LEAST k. f k = f i"
-  let ?k = "Max ((\<lambda>x. LEAST k. f k = x) ` range f)"
-  have "?j \<le> ?k"
-  proof (rule Max_ge)
-    show "finite ((\<lambda>x. LEAST k. f k = x) ` range f)"
-      using finite_range by (rule finite_imageI)
-    show "?j \<in> (\<lambda>x. LEAST k. f k = x) ` range f"
-      by (intro imageI rangeI)
-  qed
-  hence "r (f ?j) (f ?k)"
-    by (rule mono)
-  also have "f ?j = f i"
-    by (rule LeastI, rule refl)
-  finally show "r (f i) (f ?k)" .
-qed
-
-lemma finite_range_imp_finch:
-  "\<lbrakk>chain Y; finite (range Y)\<rbrakk> \<Longrightarrow> finite_chain Y"
- apply (subgoal_tac "\<exists>k. \<forall>i. Y i \<sqsubseteq> Y k")
-  apply (erule exE)
-  apply (rule finite_chainI, assumption)
-  apply (rule max_in_chainI)
-  apply (rule below_antisym)
-   apply (erule (1) chain_mono)
-  apply (erule spec)
- apply (rule finite_range_has_max)
-  apply (erule (1) chain_mono)
- apply assumption
-done
-
-lemma bin_chain: "x \<sqsubseteq> y \<Longrightarrow> chain (\<lambda>i. if i=0 then x else y)"
-  by (rule chainI, simp)
-
-lemma bin_chainmax:
-  "x \<sqsubseteq> y \<Longrightarrow> max_in_chain (Suc 0) (\<lambda>i. if i=0 then x else y)"
-  unfolding max_in_chain_def by simp
-
-lemma is_lub_bin_chain:
-  "x \<sqsubseteq> y \<Longrightarrow> range (\<lambda>i::nat. if i=0 then x else y) <<| y"
-apply (frule bin_chain)
-apply (drule bin_chainmax)
-apply (drule (1) lub_finch1)
-apply simp
-done
-
-text {* the maximal element in a chain is its lub *}
-
-lemma lub_chain_maxelem: "\<lbrakk>Y i = c; \<forall>i. Y i \<sqsubseteq> c\<rbrakk> \<Longrightarrow> lub (range Y) = c"
-  by (blast dest: ub_rangeD intro: lub_eqI is_lubI ub_rangeI)
-
-end
-
-end

--- a/src/HOLCF/Powerdomains.thy	Sat Nov 27 14:34:54 2010 -0800
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,51 +0,0 @@
-(*  Title:      HOLCF/Powerdomains.thy
-    Author:     Brian Huffman
-*)
-
-header {* Powerdomains *}
-
-theory Powerdomains
-imports ConvexPD Domain
-begin
-
-lemma isodefl_upper:
-  "isodefl d t \<Longrightarrow> isodefl (upper_map\<cdot>d) (upper_defl\<cdot>t)"
-apply (rule isodeflI)
-apply (simp add: cast_upper_defl cast_isodefl)
-apply (simp add: emb_upper_pd_def prj_upper_pd_def)
-apply (simp add: upper_map_map)
-done
-
-lemma isodefl_lower:
-  "isodefl d t \<Longrightarrow> isodefl (lower_map\<cdot>d) (lower_defl\<cdot>t)"
-apply (rule isodeflI)
-apply (simp add: cast_lower_defl cast_isodefl)
-apply (simp add: emb_lower_pd_def prj_lower_pd_def)
-apply (simp add: lower_map_map)
-done
-
-lemma isodefl_convex:
-  "isodefl d t \<Longrightarrow> isodefl (convex_map\<cdot>d) (convex_defl\<cdot>t)"
-apply (rule isodeflI)
-apply (simp add: cast_convex_defl cast_isodefl)
-apply (simp add: emb_convex_pd_def prj_convex_pd_def)
-apply (simp add: convex_map_map)
-done
-
-subsection {* Domain package setup for powerdomains *}
-
-lemmas [domain_defl_simps] = DEFL_upper DEFL_lower DEFL_convex
-lemmas [domain_map_ID] = upper_map_ID lower_map_ID convex_map_ID
-lemmas [domain_isodefl] = isodefl_upper isodefl_lower isodefl_convex
-
-lemmas [domain_deflation] =
-  deflation_upper_map deflation_lower_map deflation_convex_map
-
-setup {*
-  fold Domain_Take_Proofs.add_rec_type
-    [(@{type_name "upper_pd"}, [true]),
-     (@{type_name "lower_pd"}, [true]),
-     (@{type_name "convex_pd"}, [true])]
-*}
-
-end

--- a/src/HOLCF/Product_Cpo.thy	Sat Nov 27 14:34:54 2010 -0800
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,299 +0,0 @@
-(*  Title:      HOLCF/Product_Cpo.thy
-    Author:     Franz Regensburger
-*)
-
-header {* The cpo of cartesian products *}
-
-theory Product_Cpo
-imports Adm
-begin
-
-default_sort cpo
-
-subsection {* Unit type is a pcpo *}
-
-instantiation unit :: discrete_cpo
-begin
-
-definition
-  below_unit_def [simp]: "x \<sqsubseteq> (y::unit) \<longleftrightarrow> True"
-
-instance proof
-qed simp
-
-end
-
-instance unit :: pcpo
-by intro_classes simp
-
-
-subsection {* Product type is a partial order *}
-
-instantiation prod :: (below, below) below
-begin
-
-definition
-  below_prod_def: "(op \<sqsubseteq>) \<equiv> \<lambda>p1 p2. (fst p1 \<sqsubseteq> fst p2 \<and> snd p1 \<sqsubseteq> snd p2)"
-
-instance ..
-end
-
-instance prod :: (po, po) po
-proof
-  fix x :: "'a \<times> 'b"
-  show "x \<sqsubseteq> x"
-    unfolding below_prod_def by simp
-next
-  fix x y :: "'a \<times> 'b"
-  assume "x \<sqsubseteq> y" "y \<sqsubseteq> x" thus "x = y"
-    unfolding below_prod_def Pair_fst_snd_eq
-    by (fast intro: below_antisym)
-next
-  fix x y z :: "'a \<times> 'b"
-  assume "x \<sqsubseteq> y" "y \<sqsubseteq> z" thus "x \<sqsubseteq> z"
-    unfolding below_prod_def
-    by (fast intro: below_trans)
-qed
-
-subsection {* Monotonicity of \emph{Pair}, \emph{fst}, \emph{snd} *}
-
-lemma prod_belowI: "\<lbrakk>fst p \<sqsubseteq> fst q; snd p \<sqsubseteq> snd q\<rbrakk> \<Longrightarrow> p \<sqsubseteq> q"
-unfolding below_prod_def by simp
-
-lemma Pair_below_iff [simp]: "(a, b) \<sqsubseteq> (c, d) \<longleftrightarrow> a \<sqsubseteq> c \<and> b \<sqsubseteq> d"
-unfolding below_prod_def by simp
-
-text {* Pair @{text "(_,_)"}  is monotone in both arguments *}
-
-lemma monofun_pair1: "monofun (\<lambda>x. (x, y))"
-by (simp add: monofun_def)
-
-lemma monofun_pair2: "monofun (\<lambda>y. (x, y))"
-by (simp add: monofun_def)
-
-lemma monofun_pair:
-  "\<lbrakk>x1 \<sqsubseteq> x2; y1 \<sqsubseteq> y2\<rbrakk> \<Longrightarrow> (x1, y1) \<sqsubseteq> (x2, y2)"
-by simp
-
-lemma ch2ch_Pair [simp]:
-  "chain X \<Longrightarrow> chain Y \<Longrightarrow> chain (\<lambda>i. (X i, Y i))"
-by (rule chainI, simp add: chainE)
-
-text {* @{term fst} and @{term snd} are monotone *}
-
-lemma fst_monofun: "x \<sqsubseteq> y \<Longrightarrow> fst x \<sqsubseteq> fst y"
-unfolding below_prod_def by simp
-
-lemma snd_monofun: "x \<sqsubseteq> y \<Longrightarrow> snd x \<sqsubseteq> snd y"
-unfolding below_prod_def by simp
-
-lemma monofun_fst: "monofun fst"
-by (simp add: monofun_def below_prod_def)
-
-lemma monofun_snd: "monofun snd"
-by (simp add: monofun_def below_prod_def)
-
-lemmas ch2ch_fst [simp] = ch2ch_monofun [OF monofun_fst]
-
-lemmas ch2ch_snd [simp] = ch2ch_monofun [OF monofun_snd]
-
-lemma prod_chain_cases:
-  assumes "chain Y"
-  obtains A B
-  where "chain A" and "chain B" and "Y = (\<lambda>i. (A i, B i))"
-proof
-  from `chain Y` show "chain (\<lambda>i. fst (Y i))" by (rule ch2ch_fst)
-  from `chain Y` show "chain (\<lambda>i. snd (Y i))" by (rule ch2ch_snd)
-  show "Y = (\<lambda>i. (fst (Y i), snd (Y i)))" by simp
-qed
-
-subsection {* Product type is a cpo *}
-
-lemma is_lub_Pair:
-  "\<lbrakk>range A <<| x; range B <<| y\<rbrakk> \<Longrightarrow> range (\<lambda>i. (A i, B i)) <<| (x, y)"
-unfolding is_lub_def is_ub_def ball_simps below_prod_def by simp
-
-lemma lub_Pair:
-  "\<lbrakk>chain (A::nat \<Rightarrow> 'a::cpo); chain (B::nat \<Rightarrow> 'b::cpo)\<rbrakk>
-    \<Longrightarrow> (\<Squnion>i. (A i, B i)) = (\<Squnion>i. A i, \<Squnion>i. B i)"
-by (fast intro: lub_eqI is_lub_Pair elim: thelubE)
-
-lemma is_lub_prod:
-  fixes S :: "nat \<Rightarrow> ('a::cpo \<times> 'b::cpo)"
-  assumes S: "chain S"
-  shows "range S <<| (\<Squnion>i. fst (S i), \<Squnion>i. snd (S i))"
-using S by (auto elim: prod_chain_cases simp add: is_lub_Pair cpo_lubI)
-
-lemma lub_prod:
-  "chain (S::nat \<Rightarrow> 'a::cpo \<times> 'b::cpo)
-    \<Longrightarrow> (\<Squnion>i. S i) = (\<Squnion>i. fst (S i), \<Squnion>i. snd (S i))"
-by (rule is_lub_prod [THEN lub_eqI])
-
-instance prod :: (cpo, cpo) cpo
-proof
-  fix S :: "nat \<Rightarrow> ('a \<times> 'b)"
-  assume "chain S"
-  hence "range S <<| (\<Squnion>i. fst (S i), \<Squnion>i. snd (S i))"
-    by (rule is_lub_prod)
-  thus "\<exists>x. range S <<| x" ..
-qed
-
-instance prod :: (discrete_cpo, discrete_cpo) discrete_cpo
-proof
-  fix x y :: "'a \<times> 'b"
-  show "x \<sqsubseteq> y \<longleftrightarrow> x = y"
-    unfolding below_prod_def Pair_fst_snd_eq
-    by simp
-qed
-
-subsection {* Product type is pointed *}
-
-lemma minimal_prod: "(\<bottom>, \<bottom>) \<sqsubseteq> p"
-by (simp add: below_prod_def)
-
-instance prod :: (pcpo, pcpo) pcpo
-by intro_classes (fast intro: minimal_prod)
-
-lemma inst_prod_pcpo: "\<bottom> = (\<bottom>, \<bottom>)"
-by (rule minimal_prod [THEN UU_I, symmetric])
-
-lemma Pair_bottom_iff [simp]: "(x, y) = \<bottom> \<longleftrightarrow> x = \<bottom> \<and> y = \<bottom>"
-unfolding inst_prod_pcpo by simp
-
-lemma fst_strict [simp]: "fst \<bottom> = \<bottom>"
-unfolding inst_prod_pcpo by (rule fst_conv)
-
-lemma snd_strict [simp]: "snd \<bottom> = \<bottom>"
-unfolding inst_prod_pcpo by (rule snd_conv)
-
-lemma Pair_strict [simp]: "(\<bottom>, \<bottom>) = \<bottom>"
-by simp
-
-lemma split_strict [simp]: "split f \<bottom> = f \<bottom> \<bottom>"
-unfolding split_def by simp
-
-subsection {* Continuity of \emph{Pair}, \emph{fst}, \emph{snd} *}
-
-lemma cont_pair1: "cont (\<lambda>x. (x, y))"
-apply (rule contI)
-apply (rule is_lub_Pair)
-apply (erule cpo_lubI)
-apply (rule is_lub_const)
-done
-
-lemma cont_pair2: "cont (\<lambda>y. (x, y))"
-apply (rule contI)
-apply (rule is_lub_Pair)
-apply (rule is_lub_const)
-apply (erule cpo_lubI)
-done
-
-lemma cont_fst: "cont fst"
-apply (rule contI)
-apply (simp add: lub_prod)
-apply (erule cpo_lubI [OF ch2ch_fst])
-done
-
-lemma cont_snd: "cont snd"
-apply (rule contI)
-apply (simp add: lub_prod)
-apply (erule cpo_lubI [OF ch2ch_snd])
-done
-
-lemma cont2cont_Pair [simp, cont2cont]:
-  assumes f: "cont (\<lambda>x. f x)"
-  assumes g: "cont (\<lambda>x. g x)"
-  shows "cont (\<lambda>x. (f x, g x))"
-apply (rule cont_apply [OF f cont_pair1])
-apply (rule cont_apply [OF g cont_pair2])
-apply (rule cont_const)
-done
-
-lemmas cont2cont_fst [simp, cont2cont] = cont_compose [OF cont_fst]
-
-lemmas cont2cont_snd [simp, cont2cont] = cont_compose [OF cont_snd]
-
-lemma cont2cont_prod_case:
-  assumes f1: "\<And>a b. cont (\<lambda>x. f x a b)"
-  assumes f2: "\<And>x b. cont (\<lambda>a. f x a b)"
-  assumes f3: "\<And>x a. cont (\<lambda>b. f x a b)"
-  assumes g: "cont (\<lambda>x. g x)"
-  shows "cont (\<lambda>x. case g x of (a, b) \<Rightarrow> f x a b)"
-unfolding split_def
-apply (rule cont_apply [OF g])
-apply (rule cont_apply [OF cont_fst f2])
-apply (rule cont_apply [OF cont_snd f3])
-apply (rule cont_const)
-apply (rule f1)
-done
-
-lemma prod_contI:
-  assumes f1: "\<And>y. cont (\<lambda>x. f (x, y))"
-  assumes f2: "\<And>x. cont (\<lambda>y. f (x, y))"
-  shows "cont f"
-proof -
-  have "cont (\<lambda>(x, y). f (x, y))"
-    by (intro cont2cont_prod_case f1 f2 cont2cont)
-  thus "cont f"
-    by (simp only: split_eta)
-qed
-
-lemma prod_cont_iff:
-  "cont f \<longleftrightarrow> (\<forall>y. cont (\<lambda>x. f (x, y))) \<and> (\<forall>x. cont (\<lambda>y. f (x, y)))"
-apply safe
-apply (erule cont_compose [OF _ cont_pair1])
-apply (erule cont_compose [OF _ cont_pair2])
-apply (simp only: prod_contI)
-done
-
-lemma cont2cont_prod_case' [simp, cont2cont]:
-  assumes f: "cont (\<lambda>p. f (fst p) (fst (snd p)) (snd (snd p)))"
-  assumes g: "cont (\<lambda>x. g x)"
-  shows "cont (\<lambda>x. prod_case (f x) (g x))"
-using assms by (simp add: cont2cont_prod_case prod_cont_iff)
-
-text {* The simple version (due to Joachim Breitner) is needed if
-  either element type of the pair is not a cpo. *}
-
-lemma cont2cont_split_simple [simp, cont2cont]:
- assumes "\<And>a b. cont (\<lambda>x. f x a b)"
- shows "cont (\<lambda>x. case p of (a, b) \<Rightarrow> f x a b)"
-using assms by (cases p) auto
-
-text {* Admissibility of predicates on product types. *}
-
-lemma adm_prod_case [simp]:
-  assumes "adm (\<lambda>x. P x (fst (f x)) (snd (f x)))"
-  shows "adm (\<lambda>x. case f x of (a, b) \<Rightarrow> P x a b)"
-unfolding prod_case_beta using assms .
-
-subsection {* Compactness and chain-finiteness *}
-
-lemma fst_below_iff: "fst (x::'a \<times> 'b) \<sqsubseteq> y \<longleftrightarrow> x \<sqsubseteq> (y, snd x)"
-unfolding below_prod_def by simp
-
-lemma snd_below_iff: "snd (x::'a \<times> 'b) \<sqsubseteq> y \<longleftrightarrow> x \<sqsubseteq> (fst x, y)"
-unfolding below_prod_def by simp
-
-lemma compact_fst: "compact x \<Longrightarrow> compact (fst x)"
-by (rule compactI, simp add: fst_below_iff)
-
-lemma compact_snd: "compact x \<Longrightarrow> compact (snd x)"
-by (rule compactI, simp add: snd_below_iff)
-
-lemma compact_Pair: "\<lbrakk>compact x; compact y\<rbrakk> \<Longrightarrow> compact (x, y)"
-by (rule compactI, simp add: below_prod_def)
-
-lemma compact_Pair_iff [simp]: "compact (x, y) \<longleftrightarrow> compact x \<and> compact y"
-apply (safe intro!: compact_Pair)
-apply (drule compact_fst, simp)
-apply (drule compact_snd, simp)
-done
-
-instance prod :: (chfin, chfin) chfin
-apply intro_classes
-apply (erule compact_imp_max_in_chain)
-apply (case_tac "\<Squnion>i. Y i", simp)
-done
-
-end

--- a/src/HOLCF/README.html	Sat Nov 27 14:34:54 2010 -0800
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,45 +0,0 @@
-<!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>HOLCF: A higher-order version of LCF based on Isabelle/HOL</h3>
-
-HOLCF is the definitional extension of Church's Higher-Order Logic with
-Scott's Logic for Computable Functions that has been implemented in the
-theorem prover Isabelle.  This results in a flexible setup for reasoning
-about functional programs. HOLCF supports standard domain theory (in particular
-fixpoint reasoning and recursive domain equations) but also coinductive
-arguments about lazy datatypes.
-
-<p>
-
-The most recent description of HOLCF is found here:
-
-<ul>
-  <li><a href="/~nipkow/pubs/jfp99.html">HOLCF = HOL+LCF</a>
-</ul>
-
-A detailed description (in German) of the entire development can be found in:
-
-<ul>
-  <li><a href="http://www4.informatik.tu-muenchen.de/publ/papers/Diss_Regensbu.pdf">HOLCF: eine konservative Erweiterung von HOL um LCF</a>, <br>
-      Franz Regensburger.<br>
-      Dissertation Technische Universit&auml;t M&uuml;nchen.<br>
-      Year: 1994.
-</ul>
-
-A short survey is available in:
-<ul>
-  <li><a href="http://www4.informatik.tu-muenchen.de/publ/papers/Regensburger_HOLT1995.pdf">HOLCF: Higher Order Logic of Computable Functions</a><br>
-</ul>
-
-</body>
-
-</html>

--- a/src/HOLCF/ROOT.ML	Sat Nov 27 14:34:54 2010 -0800
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,9 +0,0 @@
-(*  Title:      HOLCF/ROOT.ML
-    Author:     Franz Regensburger
-
-HOLCF -- a semantic extension of HOL by the LCF logic.
-*)
-
-no_document use_thys ["Nat_Bijection", "Countable"];
-
-use_thys ["Plain_HOLCF", "Fixrec", "HOLCF"];

--- a/src/HOLCF/Sfun.thy	Sat Nov 27 14:34:54 2010 -0800
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,62 +0,0 @@
-(*  Title:      HOLCF/Sfun.thy
-    Author:     Brian Huffman
-*)
-
-header {* The Strict Function Type *}
-
-theory Sfun
-imports Cfun
-begin
-
-pcpodef (open) ('a, 'b) sfun (infixr "->!" 0)
-  = "{f :: 'a \<rightarrow> 'b. f\<cdot>\<bottom> = \<bottom>}"
-by simp_all
-
-type_notation (xsymbols)
-  sfun  (infixr "\<rightarrow>!" 0)
-
-text {* TODO: Define nice syntax for abstraction, application. *}
-
-definition
-  sfun_abs :: "('a \<rightarrow> 'b) \<rightarrow> ('a \<rightarrow>! 'b)"
-where
-  "sfun_abs = (\<Lambda> f. Abs_sfun (strictify\<cdot>f))"
-
-definition
-  sfun_rep :: "('a \<rightarrow>! 'b) \<rightarrow> 'a \<rightarrow> 'b"
-where
-  "sfun_rep = (\<Lambda> f. Rep_sfun f)"
-
-lemma sfun_rep_beta: "sfun_rep\<cdot>f = Rep_sfun f"
-  unfolding sfun_rep_def by (simp add: cont_Rep_sfun)
-
-lemma sfun_rep_strict1 [simp]: "sfun_rep\<cdot>\<bottom> = \<bottom>"
-  unfolding sfun_rep_beta by (rule Rep_sfun_strict)
-
-lemma sfun_rep_strict2 [simp]: "sfun_rep\<cdot>f\<cdot>\<bottom> = \<bottom>"
-  unfolding sfun_rep_beta by (rule Rep_sfun [simplified])
-
-lemma strictify_cancel: "f\<cdot>\<bottom> = \<bottom> \<Longrightarrow> strictify\<cdot>f = f"
-  by (simp add: cfun_eq_iff strictify_conv_if)
-
-lemma sfun_abs_sfun_rep [simp]: "sfun_abs\<cdot>(sfun_rep\<cdot>f) = f"
-  unfolding sfun_abs_def sfun_rep_def
-  apply (simp add: cont_Abs_sfun cont_Rep_sfun)
-  apply (simp add: Rep_sfun_inject [symmetric] Abs_sfun_inverse)
-  apply (simp add: cfun_eq_iff strictify_conv_if)
-  apply (simp add: Rep_sfun [simplified])
-  done
-
-lemma sfun_rep_sfun_abs [simp]: "sfun_rep\<cdot>(sfun_abs\<cdot>f) = strictify\<cdot>f"
-  unfolding sfun_abs_def sfun_rep_def
-  apply (simp add: cont_Abs_sfun cont_Rep_sfun)
-  apply (simp add: Abs_sfun_inverse)
-  done
-
-lemma sfun_eq_iff: "f = g \<longleftrightarrow> sfun_rep\<cdot>f = sfun_rep\<cdot>g"
-by (simp add: sfun_rep_def cont_Rep_sfun Rep_sfun_inject)
-
-lemma sfun_below_iff: "f \<sqsubseteq> g \<longleftrightarrow> sfun_rep\<cdot>f \<sqsubseteq> sfun_rep\<cdot>g"
-by (simp add: sfun_rep_def cont_Rep_sfun below_sfun_def)
-
-end

--- a/src/HOLCF/Sprod.thy	Sat Nov 27 14:34:54 2010 -0800
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,214 +0,0 @@
-(*  Title:      HOLCF/Sprod.thy
-    Author:     Franz Regensburger
-    Author:     Brian Huffman
-*)
-
-header {* The type of strict products *}
-
-theory Sprod
-imports Cfun
-begin
-
-default_sort pcpo
-
-subsection {* Definition of strict product type *}
-
-pcpodef ('a, 'b) sprod (infixr "**" 20) =
-        "{p::'a \<times> 'b. p = \<bottom> \<or> (fst p \<noteq> \<bottom> \<and> snd p \<noteq> \<bottom>)}"
-by simp_all
-
-instance sprod :: ("{chfin,pcpo}", "{chfin,pcpo}") chfin
-by (rule typedef_chfin [OF type_definition_sprod below_sprod_def])
-
-type_notation (xsymbols)
-  sprod  ("(_ \<otimes>/ _)" [21,20] 20)
-type_notation (HTML output)
-  sprod  ("(_ \<otimes>/ _)" [21,20] 20)
-
-subsection {* Definitions of constants *}
-
-definition
-  sfst :: "('a ** 'b) \<rightarrow> 'a" where
-  "sfst = (\<Lambda> p. fst (Rep_sprod p))"
-
-definition
-  ssnd :: "('a ** 'b) \<rightarrow> 'b" where
-  "ssnd = (\<Lambda> p. snd (Rep_sprod p))"
-
-definition
-  spair :: "'a \<rightarrow> 'b \<rightarrow> ('a ** 'b)" where
-  "spair = (\<Lambda> a b. Abs_sprod (seq\<cdot>b\<cdot>a, seq\<cdot>a\<cdot>b))"
-
-definition
-  ssplit :: "('a \<rightarrow> 'b \<rightarrow> 'c) \<rightarrow> ('a ** 'b) \<rightarrow> 'c" where
-  "ssplit = (\<Lambda> f p. seq\<cdot>p\<cdot>(f\<cdot>(sfst\<cdot>p)\<cdot>(ssnd\<cdot>p)))"
-
-syntax
-  "_stuple" :: "['a, args] => 'a ** 'b"  ("(1'(:_,/ _:'))")
-translations
-  "(:x, y, z:)" == "(:x, (:y, z:):)"
-  "(:x, y:)"    == "CONST spair\<cdot>x\<cdot>y"
-
-translations
-  "\<Lambda>(CONST spair\<cdot>x\<cdot>y). t" == "CONST ssplit\<cdot>(\<Lambda> x y. t)"
-
-subsection {* Case analysis *}
-
-lemma spair_sprod: "(seq\<cdot>b\<cdot>a, seq\<cdot>a\<cdot>b) \<in> sprod"
-by (simp add: sprod_def seq_conv_if)
-
-lemma Rep_sprod_spair: "Rep_sprod (:a, b:) = (seq\<cdot>b\<cdot>a, seq\<cdot>a\<cdot>b)"
-by (simp add: spair_def cont_Abs_sprod Abs_sprod_inverse spair_sprod)
-
-lemmas Rep_sprod_simps =
-  Rep_sprod_inject [symmetric] below_sprod_def
-  Pair_fst_snd_eq below_prod_def
-  Rep_sprod_strict Rep_sprod_spair
-
-lemma sprodE [case_names bottom spair, cases type: sprod]:
-  obtains "p = \<bottom>" | x y where "p = (:x, y:)" and "x \<noteq> \<bottom>" and "y \<noteq> \<bottom>"
-using Rep_sprod [of p] by (auto simp add: sprod_def Rep_sprod_simps)
-
-lemma sprod_induct [case_names bottom spair, induct type: sprod]:
-  "\<lbrakk>P \<bottom>; \<And>x y. \<lbrakk>x \<noteq> \<bottom>; y \<noteq> \<bottom>\<rbrakk> \<Longrightarrow> P (:x, y:)\<rbrakk> \<Longrightarrow> P x"
-by (cases x, simp_all)
-
-subsection {* Properties of \emph{spair} *}
-
-lemma spair_strict1 [simp]: "(:\<bottom>, y:) = \<bottom>"
-by (simp add: Rep_sprod_simps)
-
-lemma spair_strict2 [simp]: "(:x, \<bottom>:) = \<bottom>"
-by (simp add: Rep_sprod_simps)
-
-lemma spair_bottom_iff [simp]: "((:x, y:) = \<bottom>) = (x = \<bottom> \<or> y = \<bottom>)"
-by (simp add: Rep_sprod_simps seq_conv_if)
-
-lemma spair_below_iff:
-  "((:a, b:) \<sqsubseteq> (:c, d:)) = (a = \<bottom> \<or> b = \<bottom> \<or> (a \<sqsubseteq> c \<and> b \<sqsubseteq> d))"
-by (simp add: Rep_sprod_simps seq_conv_if)
-
-lemma spair_eq_iff:
-  "((:a, b:) = (:c, d:)) =
-    (a = c \<and> b = d \<or> (a = \<bottom> \<or> b = \<bottom>) \<and> (c = \<bottom> \<or> d = \<bottom>))"
-by (simp add: Rep_sprod_simps seq_conv_if)
-
-lemma spair_strict: "x = \<bottom> \<or> y = \<bottom> \<Longrightarrow> (:x, y:) = \<bottom>"
-by simp
-
-lemma spair_strict_rev: "(:x, y:) \<noteq> \<bottom> \<Longrightarrow> x \<noteq> \<bottom> \<and> y \<noteq> \<bottom>"
-by simp
-
-lemma spair_defined: "\<lbrakk>x \<noteq> \<bottom>; y \<noteq> \<bottom>\<rbrakk> \<Longrightarrow> (:x, y:) \<noteq> \<bottom>"
-by simp
-
-lemma spair_defined_rev: "(:x, y:) = \<bottom> \<Longrightarrow> x = \<bottom> \<or> y = \<bottom>"
-by simp
-
-lemma spair_below:
-  "\<lbrakk>x \<noteq> \<bottom>; y \<noteq> \<bottom>\<rbrakk> \<Longrightarrow> (:x, y:) \<sqsubseteq> (:a, b:) = (x \<sqsubseteq> a \<and> y \<sqsubseteq> b)"
-by (simp add: spair_below_iff)
-
-lemma spair_eq:
-  "\<lbrakk>x \<noteq> \<bottom>; y \<noteq> \<bottom>\<rbrakk> \<Longrightarrow> ((:x, y:) = (:a, b:)) = (x = a \<and> y = b)"
-by (simp add: spair_eq_iff)
-
-lemma spair_inject:
-  "\<lbrakk>x \<noteq> \<bottom>; y \<noteq> \<bottom>; (:x, y:) = (:a, b:)\<rbrakk> \<Longrightarrow> x = a \<and> y = b"
-by (rule spair_eq [THEN iffD1])
-
-lemma inst_sprod_pcpo2: "UU = (:UU,UU:)"
-by simp
-
-lemma sprodE2: "(\<And>x y. p = (:x, y:) \<Longrightarrow> Q) \<Longrightarrow> Q"
-by (cases p, simp only: inst_sprod_pcpo2, simp)
-
-subsection {* Properties of \emph{sfst} and \emph{ssnd} *}
-
-lemma sfst_strict [simp]: "sfst\<cdot>\<bottom> = \<bottom>"
-by (simp add: sfst_def cont_Rep_sprod Rep_sprod_strict)
-
-lemma ssnd_strict [simp]: "ssnd\<cdot>\<bottom> = \<bottom>"
-by (simp add: ssnd_def cont_Rep_sprod Rep_sprod_strict)
-
-lemma sfst_spair [simp]: "y \<noteq> \<bottom> \<Longrightarrow> sfst\<cdot>(:x, y:) = x"
-by (simp add: sfst_def cont_Rep_sprod Rep_sprod_spair)
-
-lemma ssnd_spair [simp]: "x \<noteq> \<bottom> \<Longrightarrow> ssnd\<cdot>(:x, y:) = y"
-by (simp add: ssnd_def cont_Rep_sprod Rep_sprod_spair)
-
-lemma sfst_bottom_iff [simp]: "(sfst\<cdot>p = \<bottom>) = (p = \<bottom>)"
-by (cases p, simp_all)
-
-lemma ssnd_bottom_iff [simp]: "(ssnd\<cdot>p = \<bottom>) = (p = \<bottom>)"
-by (cases p, simp_all)
-
-lemma sfst_defined: "p \<noteq> \<bottom> \<Longrightarrow> sfst\<cdot>p \<noteq> \<bottom>"
-by simp
-
-lemma ssnd_defined: "p \<noteq> \<bottom> \<Longrightarrow> ssnd\<cdot>p \<noteq> \<bottom>"
-by simp
-
-lemma spair_sfst_ssnd: "(:sfst\<cdot>p, ssnd\<cdot>p:) = p"
-by (cases p, simp_all)
-
-lemma below_sprod: "(x \<sqsubseteq> y) = (sfst\<cdot>x \<sqsubseteq> sfst\<cdot>y \<and> ssnd\<cdot>x \<sqsubseteq> ssnd\<cdot>y)"
-by (simp add: Rep_sprod_simps sfst_def ssnd_def cont_Rep_sprod)
-
-lemma eq_sprod: "(x = y) = (sfst\<cdot>x = sfst\<cdot>y \<and> ssnd\<cdot>x = ssnd\<cdot>y)"
-by (auto simp add: po_eq_conv below_sprod)
-
-lemma sfst_below_iff: "sfst\<cdot>x \<sqsubseteq> y \<longleftrightarrow> x \<sqsubseteq> (:y, ssnd\<cdot>x:)"
-apply (cases "x = \<bottom>", simp, cases "y = \<bottom>", simp)
-apply (simp add: below_sprod)
-done
-
-lemma ssnd_below_iff: "ssnd\<cdot>x \<sqsubseteq> y \<longleftrightarrow> x \<sqsubseteq> (:sfst\<cdot>x, y:)"
-apply (cases "x = \<bottom>", simp, cases "y = \<bottom>", simp)
-apply (simp add: below_sprod)
-done
-
-subsection {* Compactness *}
-
-lemma compact_sfst: "compact x \<Longrightarrow> compact (sfst\<cdot>x)"
-by (rule compactI, simp add: sfst_below_iff)
-
-lemma compact_ssnd: "compact x \<Longrightarrow> compact (ssnd\<cdot>x)"
-by (rule compactI, simp add: ssnd_below_iff)
-
-lemma compact_spair: "\<lbrakk>compact x; compact y\<rbrakk> \<Longrightarrow> compact (:x, y:)"
-by (rule compact_sprod, simp add: Rep_sprod_spair seq_conv_if)
-
-lemma compact_spair_iff:
-  "compact (:x, y:) = (x = \<bottom> \<or> y = \<bottom> \<or> (compact x \<and> compact y))"
-apply (safe elim!: compact_spair)
-apply (drule compact_sfst, simp)
-apply (drule compact_ssnd, simp)
-apply simp
-apply simp
-done
-
-subsection {* Properties of \emph{ssplit} *}
-
-lemma ssplit1 [simp]: "ssplit\<cdot>f\<cdot>\<bottom> = \<bottom>"
-by (simp add: ssplit_def)
-
-lemma ssplit2 [simp]: "\<lbrakk>x \<noteq> \<bottom>; y \<noteq> \<bottom>\<rbrakk> \<Longrightarrow> ssplit\<cdot>f\<cdot>(:x, y:) = f\<cdot>x\<cdot>y"
-by (simp add: ssplit_def)
-
-lemma ssplit3 [simp]: "ssplit\<cdot>spair\<cdot>z = z"
-by (cases z, simp_all)
-
-subsection {* Strict product preserves flatness *}
-
-instance sprod :: (flat, flat) flat
-proof
-  fix x y :: "'a \<otimes> 'b"
-  assume "x \<sqsubseteq> y" thus "x = \<bottom> \<or> x = y"
-    apply (induct x, simp)
-    apply (induct y, simp)
-    apply (simp add: spair_below_iff flat_below_iff)
-    done
-qed
-
-end

--- a/src/HOLCF/Ssum.thy	Sat Nov 27 14:34:54 2010 -0800
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,198 +0,0 @@
-(*  Title:      HOLCF/Ssum.thy
-    Author:     Franz Regensburger
-    Author:     Brian Huffman
-*)
-
-header {* The type of strict sums *}
-
-theory Ssum
-imports Tr
-begin
-
-default_sort pcpo
-
-subsection {* Definition of strict sum type *}
-
-pcpodef ('a, 'b) ssum (infixr "++" 10) = 
-  "{p :: tr \<times> ('a \<times> 'b). p = \<bottom> \<or>
-    (fst p = TT \<and> fst (snd p) \<noteq> \<bottom> \<and> snd (snd p) = \<bottom>) \<or>
-    (fst p = FF \<and> fst (snd p) = \<bottom> \<and> snd (snd p) \<noteq> \<bottom>) }"
-by simp_all
-
-instance ssum :: ("{chfin,pcpo}", "{chfin,pcpo}") chfin
-by (rule typedef_chfin [OF type_definition_ssum below_ssum_def])
-
-type_notation (xsymbols)
-  ssum  ("(_ \<oplus>/ _)" [21, 20] 20)
-type_notation (HTML output)
-  ssum  ("(_ \<oplus>/ _)" [21, 20] 20)
-
-
-subsection {* Definitions of constructors *}
-
-definition
-  sinl :: "'a \<rightarrow> ('a ++ 'b)" where
-  "sinl = (\<Lambda> a. Abs_ssum (seq\<cdot>a\<cdot>TT, a, \<bottom>))"
-
-definition
-  sinr :: "'b \<rightarrow> ('a ++ 'b)" where
-  "sinr = (\<Lambda> b. Abs_ssum (seq\<cdot>b\<cdot>FF, \<bottom>, b))"
-
-lemma sinl_ssum: "(seq\<cdot>a\<cdot>TT, a, \<bottom>) \<in> ssum"
-by (simp add: ssum_def seq_conv_if)
-
-lemma sinr_ssum: "(seq\<cdot>b\<cdot>FF, \<bottom>, b) \<in> ssum"
-by (simp add: ssum_def seq_conv_if)
-
-lemma Rep_ssum_sinl: "Rep_ssum (sinl\<cdot>a) = (seq\<cdot>a\<cdot>TT, a, \<bottom>)"
-by (simp add: sinl_def cont_Abs_ssum Abs_ssum_inverse sinl_ssum)
-
-lemma Rep_ssum_sinr: "Rep_ssum (sinr\<cdot>b) = (seq\<cdot>b\<cdot>FF, \<bottom>, b)"
-by (simp add: sinr_def cont_Abs_ssum Abs_ssum_inverse sinr_ssum)
-
-lemmas Rep_ssum_simps =
-  Rep_ssum_inject [symmetric] below_ssum_def
-  Pair_fst_snd_eq below_prod_def
-  Rep_ssum_strict Rep_ssum_sinl Rep_ssum_sinr
-
-subsection {* Properties of \emph{sinl} and \emph{sinr} *}
-
-text {* Ordering *}
-
-lemma sinl_below [simp]: "(sinl\<cdot>x \<sqsubseteq> sinl\<cdot>y) = (x \<sqsubseteq> y)"
-by (simp add: Rep_ssum_simps seq_conv_if)
-
-lemma sinr_below [simp]: "(sinr\<cdot>x \<sqsubseteq> sinr\<cdot>y) = (x \<sqsubseteq> y)"
-by (simp add: Rep_ssum_simps seq_conv_if)
-
-lemma sinl_below_sinr [simp]: "(sinl\<cdot>x \<sqsubseteq> sinr\<cdot>y) = (x = \<bottom>)"
-by (simp add: Rep_ssum_simps seq_conv_if)
-
-lemma sinr_below_sinl [simp]: "(sinr\<cdot>x \<sqsubseteq> sinl\<cdot>y) = (x = \<bottom>)"
-by (simp add: Rep_ssum_simps seq_conv_if)
-
-text {* Equality *}
-
-lemma sinl_eq [simp]: "(sinl\<cdot>x = sinl\<cdot>y) = (x = y)"
-by (simp add: po_eq_conv)
-
-lemma sinr_eq [simp]: "(sinr\<cdot>x = sinr\<cdot>y) = (x = y)"
-by (simp add: po_eq_conv)
-
-lemma sinl_eq_sinr [simp]: "(sinl\<cdot>x = sinr\<cdot>y) = (x = \<bottom> \<and> y = \<bottom>)"
-by (subst po_eq_conv, simp)
-
-lemma sinr_eq_sinl [simp]: "(sinr\<cdot>x = sinl\<cdot>y) = (x = \<bottom> \<and> y = \<bottom>)"
-by (subst po_eq_conv, simp)
-
-lemma sinl_inject: "sinl\<cdot>x = sinl\<cdot>y \<Longrightarrow> x = y"
-by (rule sinl_eq [THEN iffD1])
-
-lemma sinr_inject: "sinr\<cdot>x = sinr\<cdot>y \<Longrightarrow> x = y"
-by (rule sinr_eq [THEN iffD1])
-
-text {* Strictness *}
-
-lemma sinl_strict [simp]: "sinl\<cdot>\<bottom> = \<bottom>"
-by (simp add: Rep_ssum_simps)
-
-lemma sinr_strict [simp]: "sinr\<cdot>\<bottom> = \<bottom>"
-by (simp add: Rep_ssum_simps)
-
-lemma sinl_bottom_iff [simp]: "(sinl\<cdot>x = \<bottom>) = (x = \<bottom>)"
-using sinl_eq [of "x" "\<bottom>"] by simp
-
-lemma sinr_bottom_iff [simp]: "(sinr\<cdot>x = \<bottom>) = (x = \<bottom>)"
-using sinr_eq [of "x" "\<bottom>"] by simp
-
-lemma sinl_defined: "x \<noteq> \<bottom> \<Longrightarrow> sinl\<cdot>x \<noteq> \<bottom>"
-by simp
-
-lemma sinr_defined: "x \<noteq> \<bottom> \<Longrightarrow> sinr\<cdot>x \<noteq> \<bottom>"
-by simp
-
-text {* Compactness *}
-
-lemma compact_sinl: "compact x \<Longrightarrow> compact (sinl\<cdot>x)"
-by (rule compact_ssum, simp add: Rep_ssum_sinl)
-
-lemma compact_sinr: "compact x \<Longrightarrow> compact (sinr\<cdot>x)"
-by (rule compact_ssum, simp add: Rep_ssum_sinr)
-
-lemma compact_sinlD: "compact (sinl\<cdot>x) \<Longrightarrow> compact x"
-unfolding compact_def
-by (drule adm_subst [OF cont_Rep_cfun2 [where f=sinl]], simp)
-
-lemma compact_sinrD: "compact (sinr\<cdot>x) \<Longrightarrow> compact x"
-unfolding compact_def
-by (drule adm_subst [OF cont_Rep_cfun2 [where f=sinr]], simp)
-
-lemma compact_sinl_iff [simp]: "compact (sinl\<cdot>x) = compact x"
-by (safe elim!: compact_sinl compact_sinlD)
-
-lemma compact_sinr_iff [simp]: "compact (sinr\<cdot>x) = compact x"
-by (safe elim!: compact_sinr compact_sinrD)
-
-subsection {* Case analysis *}
-
-lemma ssumE [case_names bottom sinl sinr, cases type: ssum]:
-  obtains "p = \<bottom>"
-  | x where "p = sinl\<cdot>x" and "x \<noteq> \<bottom>"
-  | y where "p = sinr\<cdot>y" and "y \<noteq> \<bottom>"
-using Rep_ssum [of p] by (auto simp add: ssum_def Rep_ssum_simps)
-
-lemma ssum_induct [case_names bottom sinl sinr, induct type: ssum]:
-  "\<lbrakk>P \<bottom>;
-   \<And>x. x \<noteq> \<bottom> \<Longrightarrow> P (sinl\<cdot>x);
-   \<And>y. y \<noteq> \<bottom> \<Longrightarrow> P (sinr\<cdot>y)\<rbrakk> \<Longrightarrow> P x"
-by (cases x, simp_all)
-
-lemma ssumE2 [case_names sinl sinr]:
-  "\<lbrakk>\<And>x. p = sinl\<cdot>x \<Longrightarrow> Q; \<And>y. p = sinr\<cdot>y \<Longrightarrow> Q\<rbrakk> \<Longrightarrow> Q"
-by (cases p, simp only: sinl_strict [symmetric], simp, simp)
-
-lemma below_sinlD: "p \<sqsubseteq> sinl\<cdot>x \<Longrightarrow> \<exists>y. p = sinl\<cdot>y \<and> y \<sqsubseteq> x"
-by (cases p, rule_tac x="\<bottom>" in exI, simp_all)
-
-lemma below_sinrD: "p \<sqsubseteq> sinr\<cdot>x \<Longrightarrow> \<exists>y. p = sinr\<cdot>y \<and> y \<sqsubseteq> x"
-by (cases p, rule_tac x="\<bottom>" in exI, simp_all)
-
-subsection {* Case analysis combinator *}
-
-definition
-  sscase :: "('a \<rightarrow> 'c) \<rightarrow> ('b \<rightarrow> 'c) \<rightarrow> ('a ++ 'b) \<rightarrow> 'c" where
-  "sscase = (\<Lambda> f g s. (\<lambda>(t, x, y). If t then f\<cdot>x else g\<cdot>y) (Rep_ssum s))"
-
-translations
-  "case s of XCONST sinl\<cdot>x \<Rightarrow> t1 | XCONST sinr\<cdot>y \<Rightarrow> t2" == "CONST sscase\<cdot>(\<Lambda> x. t1)\<cdot>(\<Lambda> y. t2)\<cdot>s"
-
-translations
-  "\<Lambda>(XCONST sinl\<cdot>x). t" == "CONST sscase\<cdot>(\<Lambda> x. t)\<cdot>\<bottom>"
-  "\<Lambda>(XCONST sinr\<cdot>y). t" == "CONST sscase\<cdot>\<bottom>\<cdot>(\<Lambda> y. t)"
-
-lemma beta_sscase:
-  "sscase\<cdot>f\<cdot>g\<cdot>s = (\<lambda>(t, x, y). If t then f\<cdot>x else g\<cdot>y) (Rep_ssum s)"
-unfolding sscase_def by (simp add: cont_Rep_ssum [THEN cont_compose])
-
-lemma sscase1 [simp]: "sscase\<cdot>f\<cdot>g\<cdot>\<bottom> = \<bottom>"
-unfolding beta_sscase by (simp add: Rep_ssum_strict)
-
-lemma sscase2 [simp]: "x \<noteq> \<bottom> \<Longrightarrow> sscase\<cdot>f\<cdot>g\<cdot>(sinl\<cdot>x) = f\<cdot>x"
-unfolding beta_sscase by (simp add: Rep_ssum_sinl)
-
-lemma sscase3 [simp]: "y \<noteq> \<bottom> \<Longrightarrow> sscase\<cdot>f\<cdot>g\<cdot>(sinr\<cdot>y) = g\<cdot>y"
-unfolding beta_sscase by (simp add: Rep_ssum_sinr)
-
-lemma sscase4 [simp]: "sscase\<cdot>sinl\<cdot>sinr\<cdot>z = z"
-by (cases z, simp_all)
-
-subsection {* Strict sum preserves flatness *}
-
-instance ssum :: (flat, flat) flat
-apply (intro_classes, clarify)
-apply (case_tac x, simp)
-apply (case_tac y, simp_all add: flat_below_iff)
-apply (case_tac y, simp_all add: flat_below_iff)
-done
-
-end

--- a/src/HOLCF/Tools/Domain/domain.ML	Sat Nov 27 14:34:54 2010 -0800
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,266 +0,0 @@
-(*  Title:      HOLCF/Tools/Domain/domain.ML
-    Author:     David von Oheimb
-    Author:     Brian Huffman
-
-Theory extender for domain command, including theory syntax.
-*)
-
-signature DOMAIN =
-sig
-  val add_domain_cmd:
-      ((string * string option) list * binding * mixfix *
-       (binding * (bool * binding option * string) list * mixfix) list) list
-      -> theory -> theory
-
-  val add_domain:
-      ((string * sort) list * binding * mixfix *
-       (binding * (bool * binding option * typ) list * mixfix) list) list
-      -> theory -> theory
-
-  val add_new_domain_cmd:
-      ((string * string option) list * binding * mixfix *
-       (binding * (bool * binding option * string) list * mixfix) list) list
-      -> theory -> theory
-
-  val add_new_domain:
-      ((string * sort) list * binding * mixfix *
-       (binding * (bool * binding option * typ) list * mixfix) list) list
-      -> theory -> theory
-end;
-
-structure Domain :> DOMAIN =
-struct
-
-open HOLCF_Library;
-
-fun first  (x,_,_) = x;
-fun second (_,x,_) = x;
-fun third  (_,_,x) = x;
-
-(* ----- calls for building new thy and thms -------------------------------- *)
-
-type info =
-     Domain_Take_Proofs.iso_info list * Domain_Take_Proofs.take_induct_info;
-
-fun add_arity ((b, sorts, mx), sort) thy : theory =
-  thy
-  |> Sign.add_types [(b, length sorts, mx)]
-  |> AxClass.axiomatize_arity (Sign.full_name thy b, sorts, sort);
-
-fun gen_add_domain
-    (prep_sort : theory -> 'a -> sort)
-    (prep_typ : theory -> (string * sort) list -> 'b -> typ)
-    (add_isos : (binding * mixfix * (typ * typ)) list -> theory -> info * theory)
-    (arg_sort : bool -> sort)
-    (raw_specs : ((string * 'a) list * binding * mixfix *
-               (binding * (bool * binding option * 'b) list * mixfix) list) list)
-    (thy : theory) =
-  let
-    val dtnvs : (binding * typ list * mixfix) list =
-      let
-        fun prep_tvar (a, s) = TFree (a, prep_sort thy s);
-      in
-        map (fn (vs, dbind, mx, _) =>
-                (dbind, map prep_tvar vs, mx)) raw_specs
-      end;
-
-    fun thy_arity (dbind, tvars, mx) =
-      ((dbind, map (snd o dest_TFree) tvars, mx), arg_sort false);
-
-    (* this theory is used just for parsing and error checking *)
-    val tmp_thy = thy
-      |> Theory.copy
-      |> fold (add_arity o thy_arity) dtnvs;
-
-    val dbinds : binding list =
-        map (fn (_,dbind,_,_) => dbind) raw_specs;
-    val raw_rhss :
-        (binding * (bool * binding option * 'b) list * mixfix) list list =
-        map (fn (_,_,_,cons) => cons) raw_specs;
-    val dtnvs' : (string * typ list) list =
-        map (fn (dbind, vs, mx) => (Sign.full_name thy dbind, vs)) dtnvs;
-
-    val all_cons = map (Binding.name_of o first) (flat raw_rhss);
-    val test_dupl_cons =
-      case duplicates (op =) all_cons of 
-        [] => false | dups => error ("Duplicate constructors: " 
-                                      ^ commas_quote dups);
-    val all_sels =
-      (map Binding.name_of o map_filter second o maps second) (flat raw_rhss);
-    val test_dupl_sels =
-      case duplicates (op =) all_sels of
-        [] => false | dups => error("Duplicate selectors: "^commas_quote dups);
-
-    fun test_dupl_tvars s =
-      case duplicates (op =) (map(fst o dest_TFree)s) of
-        [] => false | dups => error("Duplicate type arguments: " 
-                                    ^commas_quote dups);
-    val test_dupl_tvars' = exists test_dupl_tvars (map snd dtnvs');
-
-    val sorts : (string * sort) list =
-      let val all_sorts = map (map dest_TFree o snd) dtnvs';
-      in
-        case distinct (eq_set (op =)) all_sorts of
-          [sorts] => sorts
-        | _ => error "Mutually recursive domains must have same type parameters"
-      end;
-
-    (* a lazy argument may have an unpointed type *)
-    (* unless the argument has a selector function *)
-    fun check_pcpo (lazy, sel, T) =
-      let val sort = arg_sort (lazy andalso is_none sel) in
-        if Sign.of_sort tmp_thy (T, sort) then ()
-        else error ("Constructor argument type is not of sort " ^
-                    Syntax.string_of_sort_global tmp_thy sort ^ ": " ^
-                    Syntax.string_of_typ_global tmp_thy T)
-      end;
-
-    (* test for free type variables, illegal sort constraints on rhs,
-       non-pcpo-types and invalid use of recursive type;
-       replace sorts in type variables on rhs *)
-    val rec_tab = Domain_Take_Proofs.get_rec_tab thy;
-    fun check_rec rec_ok (T as TFree (v,_))  =
-        if AList.defined (op =) sorts v then T
-        else error ("Free type variable " ^ quote v ^ " on rhs.")
-      | check_rec rec_ok (T as Type (s, Ts)) =
-        (case AList.lookup (op =) dtnvs' s of
-          NONE =>
-            let val rec_ok' = rec_ok andalso Symtab.defined rec_tab s;
-            in Type (s, map (check_rec rec_ok') Ts) end
-        | SOME typevars =>
-          if typevars <> Ts
-          then error ("Recursion of type " ^ 
-                      quote (Syntax.string_of_typ_global tmp_thy T) ^ 
-                      " with different arguments")
-          else if rec_ok then T
-          else error ("Illegal indirect recursion of type " ^ 
-                      quote (Syntax.string_of_typ_global tmp_thy T)))
-      | check_rec rec_ok (TVar _) = error "extender:check_rec";
-
-    fun prep_arg (lazy, sel, raw_T) =
-      let
-        val T = prep_typ tmp_thy sorts raw_T;
-        val _ = check_rec true T;
-        val _ = check_pcpo (lazy, sel, T);
-      in (lazy, sel, T) end;
-    fun prep_con (b, args, mx) = (b, map prep_arg args, mx);
-    fun prep_rhs cons = map prep_con cons;
-    val rhss : (binding * (bool * binding option * typ) list * mixfix) list list =
-        map prep_rhs raw_rhss;
-
-    fun mk_arg_typ (lazy, dest_opt, T) = if lazy then mk_upT T else T;
-    fun mk_con_typ (bind, args, mx) =
-        if null args then oneT else foldr1 mk_sprodT (map mk_arg_typ args);
-    fun mk_rhs_typ cons = foldr1 mk_ssumT (map mk_con_typ cons);
-
-    val absTs : typ list = map Type dtnvs';
-    val repTs : typ list = map mk_rhs_typ rhss;
-
-    val iso_spec : (binding * mixfix * (typ * typ)) list =
-        map (fn ((dbind, _, mx), eq) => (dbind, mx, eq))
-          (dtnvs ~~ (absTs ~~ repTs));
-
-    val ((iso_infos, take_info), thy) = add_isos iso_spec thy;
-
-    val (constr_infos, thy) =
-        thy
-          |> fold_map (fn ((dbind, cons), info) =>
-                Domain_Constructors.add_domain_constructors dbind cons info)
-             (dbinds ~~ rhss ~~ iso_infos);
-
-    val (take_rews, thy) =
-        Domain_Induction.comp_theorems
-          dbinds take_info constr_infos thy;
-  in
-    thy
-  end;
-
-fun define_isos (spec : (binding * mixfix * (typ * typ)) list) =
-  let
-    fun prep (dbind, mx, (lhsT, rhsT)) =
-      let val (dname, vs) = dest_Type lhsT;
-      in (map (fst o dest_TFree) vs, dbind, mx, rhsT, NONE) end;
-  in
-    Domain_Isomorphism.domain_isomorphism (map prep spec)
-  end;
-
-fun pcpo_arg lazy = if lazy then @{sort cpo} else @{sort pcpo};
-fun rep_arg lazy = if lazy then @{sort predomain} else @{sort "domain"};
-
-fun read_sort thy (SOME s) = Syntax.read_sort_global thy s
-  | read_sort thy NONE = Sign.defaultS thy;
-
-(* Adapted from src/HOL/Tools/Datatype/datatype_data.ML *)
-fun read_typ thy sorts str =
-  let
-    val ctxt = ProofContext.init_global thy
-      |> fold (Variable.declare_typ o TFree) sorts;
-  in Syntax.read_typ ctxt str end;
-
-fun cert_typ sign sorts raw_T =
-  let
-    val T = Type.no_tvars (Sign.certify_typ sign raw_T)
-      handle TYPE (msg, _, _) => error msg;
-    val sorts' = Term.add_tfreesT T sorts;
-    val _ =
-      case duplicates (op =) (map fst sorts') of
-        [] => ()
-      | dups => error ("Inconsistent sort constraints for " ^ commas dups)
-  in T end;
-
-val add_domain =
-    gen_add_domain (K I) cert_typ Domain_Axioms.add_axioms pcpo_arg;
-
-val add_new_domain =
-    gen_add_domain (K I) cert_typ define_isos rep_arg;
-
-val add_domain_cmd =
-    gen_add_domain read_sort read_typ Domain_Axioms.add_axioms pcpo_arg;
-
-val add_new_domain_cmd =
-    gen_add_domain read_sort read_typ define_isos rep_arg;
-
-
-(** outer syntax **)
-
-val _ = Keyword.keyword "lazy";
-val _ = Keyword.keyword "unsafe";
-
-val dest_decl : (bool * binding option * string) parser =
-  Parse.$$$ "(" |-- Scan.optional (Parse.$$$ "lazy" >> K true) false --
-    (Parse.binding >> SOME) -- (Parse.$$$ "::" |-- Parse.typ)  --| Parse.$$$ ")" >> Parse.triple1
-    || Parse.$$$ "(" |-- Parse.$$$ "lazy" |-- Parse.typ --| Parse.$$$ ")"
-    >> (fn t => (true,NONE,t))
-    || Parse.typ >> (fn t => (false,NONE,t));
-
-val cons_decl =
-  Parse.binding -- Scan.repeat dest_decl -- Parse.opt_mixfix;
-
-val domain_decl =
-  (Parse.type_args_constrained -- Parse.binding -- Parse.opt_mixfix) --
-    (Parse.$$$ "=" |-- Parse.enum1 "|" cons_decl);
-
-val domains_decl =
-  Scan.optional (Parse.$$$ "(" |-- (Parse.$$$ "unsafe" >> K true) --| Parse.$$$ ")") false --
-    Parse.and_list1 domain_decl;
-
-fun mk_domain
-    (unsafe : bool,
-     doms : ((((string * string option) list * binding) * mixfix) *
-             ((binding * (bool * binding option * string) list) * mixfix) list) list ) =
-  let
-    val specs : ((string * string option) list * binding * mixfix *
-                 (binding * (bool * binding option * string) list * mixfix) list) list =
-        map (fn (((vs, t), mx), cons) =>
-                (vs, t, mx, map (fn ((c, ds), mx) => (c, ds, mx)) cons)) doms;
-  in
-    if unsafe
-    then add_domain_cmd specs
-    else add_new_domain_cmd specs
-  end;
-
-val _ =
-  Outer_Syntax.command "domain" "define recursive domains (HOLCF)"
-    Keyword.thy_decl (domains_decl >> (Toplevel.theory o mk_domain));
-
-end;

--- a/src/HOLCF/Tools/Domain/domain_axioms.ML	Sat Nov 27 14:34:54 2010 -0800
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,138 +0,0 @@
-(*  Title:      HOLCF/Tools/Domain/domain_axioms.ML
-    Author:     David von Oheimb
-    Author:     Brian Huffman
-
-Syntax generator for domain command.
-*)
-
-signature DOMAIN_AXIOMS =
-sig
-  val axiomatize_isomorphism :
-      binding * (typ * typ) ->
-      theory -> Domain_Take_Proofs.iso_info * theory
-
-  val axiomatize_lub_take :
-      binding * term -> theory -> thm * theory
-
-  val add_axioms :
-      (binding * mixfix * (typ * typ)) list -> theory ->
-      (Domain_Take_Proofs.iso_info list
-       * Domain_Take_Proofs.take_induct_info) * theory
-end;
-
-
-structure Domain_Axioms : DOMAIN_AXIOMS =
-struct
-
-open HOLCF_Library;
-
-infixr 6 ->>;
-infix -->>;
-infix 9 `;
-
-fun axiomatize_isomorphism
-    (dbind : binding, (lhsT, rhsT))
-    (thy : theory)
-    : Domain_Take_Proofs.iso_info * theory =
-  let
-    val abs_bind = Binding.suffix_name "_abs" dbind;
-    val rep_bind = Binding.suffix_name "_rep" dbind;
-
-    val (abs_const, thy) =
-        Sign.declare_const ((abs_bind, rhsT ->> lhsT), NoSyn) thy;
-    val (rep_const, thy) =
-        Sign.declare_const ((rep_bind, lhsT ->> rhsT), NoSyn) thy;
-
-    val x = Free ("x", lhsT);
-    val y = Free ("y", rhsT);
-
-    val abs_iso_eqn =
-        Logic.all y (mk_trp (mk_eq (rep_const ` (abs_const ` y), y)));
-    val rep_iso_eqn =
-        Logic.all x (mk_trp (mk_eq (abs_const ` (rep_const ` x), x)));
-
-    val abs_iso_bind = Binding.qualified true "abs_iso" dbind;
-    val rep_iso_bind = Binding.qualified true "rep_iso" dbind;
-
-    val (abs_iso_thm, thy) = Specification.axiom ((abs_iso_bind, []), abs_iso_eqn) thy;
-    val (rep_iso_thm, thy) = Specification.axiom ((rep_iso_bind, []), rep_iso_eqn) thy;
-
-    val result =
-        {
-          absT = lhsT,
-          repT = rhsT,
-          abs_const = abs_const,
-          rep_const = rep_const,
-          abs_inverse = Drule.export_without_context abs_iso_thm,
-          rep_inverse = Drule.export_without_context rep_iso_thm
-        };
-  in
-    (result, thy)
-  end;
-
-fun axiomatize_lub_take
-    (dbind : binding, take_const : term)
-    (thy : theory)
-    : thm * theory =
-  let
-    val i = Free ("i", natT);
-    val T = (fst o dest_cfunT o range_type o fastype_of) take_const;
-
-    val lub_take_eqn =
-        mk_trp (mk_eq (mk_lub (lambda i (take_const $ i)), mk_ID T));
-
-    val lub_take_bind = Binding.qualified true "lub_take" dbind;
-
-    val (lub_take_thm, thy) = Specification.axiom ((lub_take_bind, []), lub_take_eqn) thy;
-  in
-    (lub_take_thm, thy)
-  end;
-
-fun add_axioms
-    (dom_eqns : (binding * mixfix * (typ * typ)) list)
-    (thy : theory) =
-  let
-
-    val dbinds = map #1 dom_eqns;
-
-    (* declare new types *)
-    fun thy_type (dbind, mx, (lhsT, _)) =
-        (dbind, (length o snd o dest_Type) lhsT, mx);
-    val thy = Sign.add_types (map thy_type dom_eqns) thy;
-
-    (* axiomatize type constructor arities *)
-    fun thy_arity (_, _, (lhsT, _)) =
-        let val (dname, tvars) = dest_Type lhsT;
-        in (dname, map (snd o dest_TFree) tvars, @{sort pcpo}) end;
-    val thy = fold (AxClass.axiomatize_arity o thy_arity) dom_eqns thy;
-
-    (* declare and axiomatize abs/rep *)
-    val (iso_infos, thy) =
-        fold_map axiomatize_isomorphism
-          (map (fn (dbind, _, eqn) => (dbind, eqn)) dom_eqns) thy;
-
-    (* define take functions *)
-    val (take_info, thy) =
-        Domain_Take_Proofs.define_take_functions
-          (dbinds ~~ iso_infos) thy;
-
-    (* declare lub_take axioms *)
-    val (lub_take_thms, thy) =
-        fold_map axiomatize_lub_take
-          (dbinds ~~ #take_consts take_info) thy;
-
-    (* prove additional take theorems *)
-    val (take_info2, thy) =
-        Domain_Take_Proofs.add_lub_take_theorems
-          (dbinds ~~ iso_infos) take_info lub_take_thms thy;
-
-    (* define map functions *)
-    val (map_info, thy) =
-        Domain_Isomorphism.define_map_functions
-          (dbinds ~~ iso_infos) thy;
-
-  in
-    ((iso_infos, take_info2), thy)
-  end;
-
-end; (* struct *)

--- a/src/HOLCF/Tools/Domain/domain_constructors.ML	Sat Nov 27 14:34:54 2010 -0800
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,975 +0,0 @@
-(*  Title:      HOLCF/Tools/Domain/domain_constructors.ML
-    Author:     Brian Huffman
-
-Defines constructor functions for a given domain isomorphism
-and proves related theorems.
-*)
-
-signature DOMAIN_CONSTRUCTORS =
-sig
-  type constr_info =
-    {
-      iso_info : Domain_Take_Proofs.iso_info,
-      con_specs : (term * (bool * typ) list) list,
-      con_betas : thm list,
-      nchotomy : thm,
-      exhaust : thm,
-      compacts : thm list,
-      con_rews : thm list,
-      inverts : thm list,
-      injects : thm list,
-      dist_les : thm list,
-      dist_eqs : thm list,
-      cases : thm list,
-      sel_rews : thm list,
-      dis_rews : thm list,
-      match_rews : thm list
-    }
-  val add_domain_constructors :
-      binding
-      -> (binding * (bool * binding option * typ) list * mixfix) list
-      -> Domain_Take_Proofs.iso_info
-      -> theory
-      -> constr_info * theory;
-end;
-
-
-structure Domain_Constructors :> DOMAIN_CONSTRUCTORS =
-struct
-
-open HOLCF_Library;
-
-infixr 6 ->>;
-infix -->>;
-infix 9 `;
-
-type constr_info =
-  {
-    iso_info : Domain_Take_Proofs.iso_info,
-    con_specs : (term * (bool * typ) list) list,
-    con_betas : thm list,
-    nchotomy : thm,
-    exhaust : thm,
-    compacts : thm list,
-    con_rews : thm list,
-    inverts : thm list,
-    injects : thm list,
-    dist_les : thm list,
-    dist_eqs : thm list,
-    cases : thm list,
-    sel_rews : thm list,
-    dis_rews : thm list,
-    match_rews : thm list
-  }
-
-(************************** miscellaneous functions ***************************)
-
-val simple_ss = HOL_basic_ss addsimps simp_thms;
-
-val beta_rules =
-  @{thms beta_cfun cont_id cont_const cont2cont_APP cont2cont_LAM'} @
-  @{thms cont2cont_fst cont2cont_snd cont2cont_Pair};
-
-val beta_ss = HOL_basic_ss addsimps (simp_thms @ beta_rules);
-
-fun define_consts
-    (specs : (binding * term * mixfix) list)
-    (thy : theory)
-    : (term list * thm list) * theory =
-  let
-    fun mk_decl (b, t, mx) = (b, fastype_of t, mx);
-    val decls = map mk_decl specs;
-    val thy = Cont_Consts.add_consts decls thy;
-    fun mk_const (b, T, mx) = Const (Sign.full_name thy b, T);
-    val consts = map mk_const decls;
-    fun mk_def c (b, t, mx) =
-      (Binding.suffix_name "_def" b, Logic.mk_equals (c, t));
-    val defs = map2 mk_def consts specs;
-    val (def_thms, thy) =
-      Global_Theory.add_defs false (map Thm.no_attributes defs) thy;
-  in
-    ((consts, def_thms), thy)
-  end;
-
-fun prove
-    (thy : theory)
-    (defs : thm list)
-    (goal : term)
-    (tacs : {prems: thm list, context: Proof.context} -> tactic list)
-    : thm =
-  let
-    fun tac {prems, context} =
-      rewrite_goals_tac defs THEN
-      EVERY (tacs {prems = map (rewrite_rule defs) prems, context = context})
-  in
-    Goal.prove_global thy [] [] goal tac
-  end;
-
-fun get_vars_avoiding
-    (taken : string list)
-    (args : (bool * typ) list)
-    : (term list * term list) =
-  let
-    val Ts = map snd args;
-    val ns = Name.variant_list taken (Datatype_Prop.make_tnames Ts);
-    val vs = map Free (ns ~~ Ts);
-    val nonlazy = map snd (filter_out (fst o fst) (args ~~ vs));
-  in
-    (vs, nonlazy)
-  end;
-
-fun get_vars args = get_vars_avoiding [] args;
-
-(************** generating beta reduction rules from definitions **************)
-
-local
-  fun arglist (Const _ $ Abs (s, T, t)) =
-      let
-        val arg = Free (s, T);
-        val (args, body) = arglist (subst_bound (arg, t));
-      in (arg :: args, body) end
-    | arglist t = ([], t);
-in
-  fun beta_of_def thy def_thm =
-      let
-        val (con, lam) = Logic.dest_equals (concl_of def_thm);
-        val (args, rhs) = arglist lam;
-        val lhs = list_ccomb (con, args);
-        val goal = mk_equals (lhs, rhs);
-        val cs = ContProc.cont_thms lam;
-        val betas = map (fn c => mk_meta_eq (c RS @{thm beta_cfun})) cs;
-      in
-        prove thy (def_thm::betas) goal (K [rtac reflexive_thm 1])
-      end;
-end;
-
-(******************************************************************************)
-(************* definitions and theorems for constructor functions *************)
-(******************************************************************************)
-
-fun add_constructors
-    (spec : (binding * (bool * typ) list * mixfix) list)
-    (abs_const : term)
-    (iso_locale : thm)
-    (thy : theory)
-    =
-  let
-
-    (* get theorems about rep and abs *)
-    val abs_strict = iso_locale RS @{thm iso.abs_strict};
-
-    (* get types of type isomorphism *)
-    val (rhsT, lhsT) = dest_cfunT (fastype_of abs_const);
-
-    fun vars_of args =
-      let
-        val Ts = map snd args;
-        val ns = Datatype_Prop.make_tnames Ts;
-      in
-        map Free (ns ~~ Ts)
-      end;
-
-    (* define constructor functions *)
-    val ((con_consts, con_defs), thy) =
-      let
-        fun one_arg (lazy, T) var = if lazy then mk_up var else var;
-        fun one_con (_,args,_) = mk_stuple (map2 one_arg args (vars_of args));
-        fun mk_abs t = abs_const ` t;
-        val rhss = map mk_abs (mk_sinjects (map one_con spec));
-        fun mk_def (bind, args, mx) rhs =
-          (bind, big_lambdas (vars_of args) rhs, mx);
-      in
-        define_consts (map2 mk_def spec rhss) thy
-      end;
-
-    (* prove beta reduction rules for constructors *)
-    val con_betas = map (beta_of_def thy) con_defs;
-
-    (* replace bindings with terms in constructor spec *)
-    val spec' : (term * (bool * typ) list) list =
-      let fun one_con con (b, args, mx) = (con, args);
-      in map2 one_con con_consts spec end;
-
-    (* prove exhaustiveness of constructors *)
-    local
-      fun arg2typ n (true,  T) = (n+1, mk_upT (TVar (("'a", n), @{sort cpo})))
-        | arg2typ n (false, T) = (n+1, TVar (("'a", n), @{sort pcpo}));
-      fun args2typ n [] = (n, oneT)
-        | args2typ n [arg] = arg2typ n arg
-        | args2typ n (arg::args) =
-          let
-            val (n1, t1) = arg2typ n arg;
-            val (n2, t2) = args2typ n1 args
-          in (n2, mk_sprodT (t1, t2)) end;
-      fun cons2typ n [] = (n, oneT)
-        | cons2typ n [con] = args2typ n (snd con)
-        | cons2typ n (con::cons) =
-          let
-            val (n1, t1) = args2typ n (snd con);
-            val (n2, t2) = cons2typ n1 cons
-          in (n2, mk_ssumT (t1, t2)) end;
-      val ct = ctyp_of thy (snd (cons2typ 1 spec'));
-      val thm1 = instantiate' [SOME ct] [] @{thm exh_start};
-      val thm2 = rewrite_rule (map mk_meta_eq @{thms ex_bottom_iffs}) thm1;
-      val thm3 = rewrite_rule [mk_meta_eq @{thm conj_assoc}] thm2;
-
-      val y = Free ("y", lhsT);
-      fun one_con (con, args) =
-        let
-          val (vs, nonlazy) = get_vars_avoiding ["y"] args;
-          val eqn = mk_eq (y, list_ccomb (con, vs));
-          val conj = foldr1 mk_conj (eqn :: map mk_defined nonlazy);
-        in Library.foldr mk_ex (vs, conj) end;
-      val goal = mk_trp (foldr1 mk_disj (mk_undef y :: map one_con spec'));
-      (* first rules replace "y = UU \/ P" with "rep$y = UU \/ P" *)
-      val tacs = [
-          rtac (iso_locale RS @{thm iso.casedist_rule}) 1,
-          rewrite_goals_tac [mk_meta_eq (iso_locale RS @{thm iso.iso_swap})],
-          rtac thm3 1];
-    in
-      val nchotomy = prove thy con_betas goal (K tacs);
-      val exhaust =
-          (nchotomy RS @{thm exh_casedist0})
-          |> rewrite_rule @{thms exh_casedists}
-          |> Drule.zero_var_indexes;
-    end;
-
-    (* prove compactness rules for constructors *)
-    val compacts =
-      let
-        val rules = @{thms compact_sinl compact_sinr compact_spair
-                           compact_up compact_ONE};
-        val tacs =
-          [rtac (iso_locale RS @{thm iso.compact_abs}) 1,
-           REPEAT (resolve_tac rules 1 ORELSE atac 1)];
-        fun con_compact (con, args) =
-          let
-            val vs = vars_of args;
-            val con_app = list_ccomb (con, vs);
-            val concl = mk_trp (mk_compact con_app);
-            val assms = map (mk_trp o mk_compact) vs;
-            val goal = Logic.list_implies (assms, concl);
-          in
-            prove thy con_betas goal (K tacs)
-          end;
-      in
-        map con_compact spec'
-      end;
-
-    (* prove strictness rules for constructors *)
-    local
-      fun con_strict (con, args) = 
-        let
-          val rules = abs_strict :: @{thms con_strict_rules};
-          val (vs, nonlazy) = get_vars args;
-          fun one_strict v' =
-            let
-              val UU = mk_bottom (fastype_of v');
-              val vs' = map (fn v => if v = v' then UU else v) vs;
-              val goal = mk_trp (mk_undef (list_ccomb (con, vs')));
-              val tacs = [simp_tac (HOL_basic_ss addsimps rules) 1];
-            in prove thy con_betas goal (K tacs) end;
-        in map one_strict nonlazy end;
-
-      fun con_defin (con, args) =
-        let
-          fun iff_disj (t, []) = HOLogic.mk_not t
-            | iff_disj (t, ts) = mk_eq (t, foldr1 HOLogic.mk_disj ts);
-          val (vs, nonlazy) = get_vars args;
-          val lhs = mk_undef (list_ccomb (con, vs));
-          val rhss = map mk_undef nonlazy;
-          val goal = mk_trp (iff_disj (lhs, rhss));
-          val rule1 = iso_locale RS @{thm iso.abs_bottom_iff};
-          val rules = rule1 :: @{thms con_bottom_iff_rules};
-          val tacs = [simp_tac (HOL_ss addsimps rules) 1];
-        in prove thy con_betas goal (K tacs) end;
-    in
-      val con_stricts = maps con_strict spec';
-      val con_defins = map con_defin spec';
-      val con_rews = con_stricts @ con_defins;
-    end;
-
-    (* prove injectiveness of constructors *)
-    local
-      fun pgterm rel (con, args) =
-        let
-          fun prime (Free (n, T)) = Free (n^"'", T)
-            | prime t             = t;
-          val (xs, nonlazy) = get_vars args;
-          val ys = map prime xs;
-          val lhs = rel (list_ccomb (con, xs), list_ccomb (con, ys));
-          val rhs = foldr1 mk_conj (ListPair.map rel (xs, ys));
-          val concl = mk_trp (mk_eq (lhs, rhs));
-          val zs = case args of [_] => [] | _ => nonlazy;
-          val assms = map (mk_trp o mk_defined) zs;
-          val goal = Logic.list_implies (assms, concl);
-        in prove thy con_betas goal end;
-      val cons' = filter (fn (_, args) => not (null args)) spec';
-    in
-      val inverts =
-        let
-          val abs_below = iso_locale RS @{thm iso.abs_below};
-          val rules1 = abs_below :: @{thms sinl_below sinr_below spair_below up_below};
-          val rules2 = @{thms up_defined spair_defined ONE_defined}
-          val rules = rules1 @ rules2;
-          val tacs = [asm_simp_tac (simple_ss addsimps rules) 1];
-        in map (fn c => pgterm mk_below c (K tacs)) cons' end;
-      val injects =
-        let
-          val abs_eq = iso_locale RS @{thm iso.abs_eq};
-          val rules1 = abs_eq :: @{thms sinl_eq sinr_eq spair_eq up_eq};
-          val rules2 = @{thms up_defined spair_defined ONE_defined}
-          val rules = rules1 @ rules2;
-          val tacs = [asm_simp_tac (simple_ss addsimps rules) 1];
-        in map (fn c => pgterm mk_eq c (K tacs)) cons' end;
-    end;
-
-    (* prove distinctness of constructors *)
-    local
-      fun map_dist (f : 'a -> 'a -> 'b) (xs : 'a list) : 'b list =
-        flat (map_index (fn (i, x) => map (f x) (nth_drop i xs)) xs);
-      fun prime (Free (n, T)) = Free (n^"'", T)
-        | prime t             = t;
-      fun iff_disj (t, []) = mk_not t
-        | iff_disj (t, ts) = mk_eq (t, foldr1 mk_disj ts);
-      fun iff_disj2 (t, [], us) = mk_not t
-        | iff_disj2 (t, ts, []) = mk_not t
-        | iff_disj2 (t, ts, us) =
-          mk_eq (t, mk_conj (foldr1 mk_disj ts, foldr1 mk_disj us));
-      fun dist_le (con1, args1) (con2, args2) =
-        let
-          val (vs1, zs1) = get_vars args1;
-          val (vs2, zs2) = get_vars args2 |> pairself (map prime);
-          val lhs = mk_below (list_ccomb (con1, vs1), list_ccomb (con2, vs2));
-          val rhss = map mk_undef zs1;
-          val goal = mk_trp (iff_disj (lhs, rhss));
-          val rule1 = iso_locale RS @{thm iso.abs_below};
-          val rules = rule1 :: @{thms con_below_iff_rules};
-          val tacs = [simp_tac (HOL_ss addsimps rules) 1];
-        in prove thy con_betas goal (K tacs) end;
-      fun dist_eq (con1, args1) (con2, args2) =
-        let
-          val (vs1, zs1) = get_vars args1;
-          val (vs2, zs2) = get_vars args2 |> pairself (map prime);
-          val lhs = mk_eq (list_ccomb (con1, vs1), list_ccomb (con2, vs2));
-          val rhss1 = map mk_undef zs1;
-          val rhss2 = map mk_undef zs2;
-          val goal = mk_trp (iff_disj2 (lhs, rhss1, rhss2));
-          val rule1 = iso_locale RS @{thm iso.abs_eq};
-          val rules = rule1 :: @{thms con_eq_iff_rules};
-          val tacs = [simp_tac (HOL_ss addsimps rules) 1];
-        in prove thy con_betas goal (K tacs) end;
-    in
-      val dist_les = map_dist dist_le spec';
-      val dist_eqs = map_dist dist_eq spec';
-    end;
-
-    val result =
-      {
-        con_consts = con_consts,
-        con_betas = con_betas,
-        nchotomy = nchotomy,
-        exhaust = exhaust,
-        compacts = compacts,
-        con_rews = con_rews,
-        inverts = inverts,
-        injects = injects,
-        dist_les = dist_les,
-        dist_eqs = dist_eqs
-      };
-  in
-    (result, thy)
-  end;
-
-(******************************************************************************)
-(**************** definition and theorems for case combinator *****************)
-(******************************************************************************)
-
-fun add_case_combinator
-    (spec : (term * (bool * typ) list) list)
-    (lhsT : typ)
-    (dbind : binding)
-    (con_betas : thm list)
-    (exhaust : thm)
-    (iso_locale : thm)
-    (rep_const : term)
-    (thy : theory)
-    : ((typ -> term) * thm list) * theory =
-  let
-
-    (* prove rep/abs rules *)
-    val rep_strict = iso_locale RS @{thm iso.rep_strict};
-    val abs_inverse = iso_locale RS @{thm iso.abs_iso};
-
-    (* calculate function arguments of case combinator *)
-    val tns = map fst (Term.add_tfreesT lhsT []);
-    val resultT = TFree (Name.variant tns "'t", @{sort pcpo});
-    fun fTs T = map (fn (_, args) => map snd args -->> T) spec;
-    val fns = Datatype_Prop.indexify_names (map (K "f") spec);
-    val fs = map Free (fns ~~ fTs resultT);
-    fun caseT T = fTs T -->> (lhsT ->> T);
-
-    (* definition of case combinator *)
-    local
-      val case_bind = Binding.suffix_name "_case" dbind;
-      fun lambda_arg (lazy, v) t =
-          (if lazy then mk_fup else I) (big_lambda v t);
-      fun lambda_args []      t = mk_one_case t
-        | lambda_args (x::[]) t = lambda_arg x t
-        | lambda_args (x::xs) t = mk_ssplit (lambda_arg x (lambda_args xs t));
-      fun one_con f (_, args) =
-        let
-          val Ts = map snd args;
-          val ns = Name.variant_list fns (Datatype_Prop.make_tnames Ts);
-          val vs = map Free (ns ~~ Ts);
-        in
-          lambda_args (map fst args ~~ vs) (list_ccomb (f, vs))
-        end;
-      fun mk_sscases [t] = mk_strictify t
-        | mk_sscases ts = foldr1 mk_sscase ts;
-      val body = mk_sscases (map2 one_con fs spec);
-      val rhs = big_lambdas fs (mk_cfcomp (body, rep_const));
-      val ((case_consts, case_defs), thy) =
-          define_consts [(case_bind, rhs, NoSyn)] thy;
-      val case_name = Sign.full_name thy case_bind;
-    in
-      val case_def = hd case_defs;
-      fun case_const T = Const (case_name, caseT T);
-      val case_app = list_ccomb (case_const resultT, fs);
-      val thy = thy;
-    end;
-
-    (* define syntax for case combinator *)
-    (* TODO: re-implement case syntax using a parse translation *)
-    local
-      open Syntax
-      fun syntax c = Syntax.mark_const (fst (dest_Const c));
-      fun xconst c = Long_Name.base_name (fst (dest_Const c));
-      fun c_ast authentic con =
-          Constant (if authentic then syntax con else xconst con);
-      fun showint n = string_of_int (n+1);
-      fun expvar n = Variable ("e" ^ showint n);
-      fun argvar n (m, _) = Variable ("a" ^ showint n ^ "_" ^ showint m);
-      fun argvars n args = map_index (argvar n) args;
-      fun app s (l, r) = mk_appl (Constant s) [l, r];
-      val cabs = app "_cabs";
-      val capp = app @{const_syntax Rep_cfun};
-      val capps = Library.foldl capp
-      fun con1 authentic n (con,args) =
-          Library.foldl capp (c_ast authentic con, argvars n args);
-      fun case1 authentic (n, c) =
-          app "_case1" (con1 authentic n c, expvar n);
-      fun arg1 (n, (con,args)) = List.foldr cabs (expvar n) (argvars n args);
-      fun when1 n (m, c) =
-          if n = m then arg1 (n, c) else (Constant @{const_syntax UU});
-      val case_constant = Constant (syntax (case_const dummyT));
-      fun case_trans authentic =
-          ParsePrintRule
-            (app "_case_syntax"
-              (Variable "x",
-               foldr1 (app "_case2") (map_index (case1 authentic) spec)),
-             capp (capps (case_constant, map_index arg1 spec), Variable "x"));
-      fun one_abscon_trans authentic (n, c) =
-          ParsePrintRule
-            (cabs (con1 authentic n c, expvar n),
-             capps (case_constant, map_index (when1 n) spec));
-      fun abscon_trans authentic =
-          map_index (one_abscon_trans authentic) spec;
-      val trans_rules : ast Syntax.trrule list =
-          case_trans false :: case_trans true ::
-          abscon_trans false @ abscon_trans true;
-    in
-      val thy = Sign.add_trrules_i trans_rules thy;
-    end;
-
-    (* prove beta reduction rule for case combinator *)
-    val case_beta = beta_of_def thy case_def;
-
-    (* prove strictness of case combinator *)
-    val case_strict =
-      let
-        val defs = case_beta :: map mk_meta_eq [rep_strict, @{thm cfcomp2}];
-        val goal = mk_trp (mk_strict case_app);
-        val rules = @{thms sscase1 ssplit1 strictify1 one_case1};
-        val tacs = [resolve_tac rules 1];
-      in prove thy defs goal (K tacs) end;
-        
-    (* prove rewrites for case combinator *)
-    local
-      fun one_case (con, args) f =
-        let
-          val (vs, nonlazy) = get_vars args;
-          val assms = map (mk_trp o mk_defined) nonlazy;
-          val lhs = case_app ` list_ccomb (con, vs);
-          val rhs = list_ccomb (f, vs);
-          val concl = mk_trp (mk_eq (lhs, rhs));
-          val goal = Logic.list_implies (assms, concl);
-          val defs = case_beta :: con_betas;
-          val rules1 = @{thms strictify2 sscase2 sscase3 ssplit2 fup2 ID1};
-          val rules2 = @{thms con_bottom_iff_rules};
-          val rules3 = @{thms cfcomp2 one_case2};
-          val rules = abs_inverse :: rules1 @ rules2 @ rules3;
-          val tacs = [asm_simp_tac (beta_ss addsimps rules) 1];
-        in prove thy defs goal (K tacs) end;
-    in
-      val case_apps = map2 one_case spec fs;
-    end
-
-  in
-    ((case_const, case_strict :: case_apps), thy)
-  end
-
-(******************************************************************************)
-(************** definitions and theorems for selector functions ***************)
-(******************************************************************************)
-
-fun add_selectors
-    (spec : (term * (bool * binding option * typ) list) list)
-    (rep_const : term)
-    (abs_inv : thm)
-    (rep_strict : thm)
-    (rep_bottom_iff : thm)
-    (con_betas : thm list)
-    (thy : theory)
-    : thm list * theory =
-  let
-
-    (* define selector functions *)
-    val ((sel_consts, sel_defs), thy) =
-      let
-        fun rangeT s = snd (dest_cfunT (fastype_of s));
-        fun mk_outl s = mk_cfcomp (from_sinl (dest_ssumT (rangeT s)), s);
-        fun mk_outr s = mk_cfcomp (from_sinr (dest_ssumT (rangeT s)), s);
-        fun mk_sfst s = mk_cfcomp (sfst_const (dest_sprodT (rangeT s)), s);
-        fun mk_ssnd s = mk_cfcomp (ssnd_const (dest_sprodT (rangeT s)), s);
-        fun mk_down s = mk_cfcomp (from_up (dest_upT (rangeT s)), s);
-
-        fun sels_of_arg s (lazy, NONE,   T) = []
-          | sels_of_arg s (lazy, SOME b, T) =
-            [(b, if lazy then mk_down s else s, NoSyn)];
-        fun sels_of_args s [] = []
-          | sels_of_args s (v :: []) = sels_of_arg s v
-          | sels_of_args s (v :: vs) =
-            sels_of_arg (mk_sfst s) v @ sels_of_args (mk_ssnd s) vs;
-        fun sels_of_cons s [] = []
-          | sels_of_cons s ((con, args) :: []) = sels_of_args s args
-          | sels_of_cons s ((con, args) :: cs) =
-            sels_of_args (mk_outl s) args @ sels_of_cons (mk_outr s) cs;
-        val sel_eqns : (binding * term * mixfix) list =
-            sels_of_cons rep_const spec;
-      in
-        define_consts sel_eqns thy
-      end
-
-    (* replace bindings with terms in constructor spec *)
-    val spec2 : (term * (bool * term option * typ) list) list =
-      let
-        fun prep_arg (lazy, NONE, T) sels = ((lazy, NONE, T), sels)
-          | prep_arg (lazy, SOME _, T) sels =
-            ((lazy, SOME (hd sels), T), tl sels);
-        fun prep_con (con, args) sels =
-            apfst (pair con) (fold_map prep_arg args sels);
-      in
-        fst (fold_map prep_con spec sel_consts)
-      end;
-
-    (* prove selector strictness rules *)
-    val sel_stricts : thm list =
-      let
-        val rules = rep_strict :: @{thms sel_strict_rules};
-        val tacs = [simp_tac (HOL_basic_ss addsimps rules) 1];
-        fun sel_strict sel =
-          let
-            val goal = mk_trp (mk_strict sel);
-          in
-            prove thy sel_defs goal (K tacs)
-          end
-      in
-        map sel_strict sel_consts
-      end
-
-    (* prove selector application rules *)
-    val sel_apps : thm list =
-      let
-        val defs = con_betas @ sel_defs;
-        val rules = abs_inv :: @{thms sel_app_rules};
-        val tacs = [asm_simp_tac (simple_ss addsimps rules) 1];
-        fun sel_apps_of (i, (con, args: (bool * term option * typ) list)) =
-          let
-            val Ts : typ list = map #3 args;
-            val ns : string list = Datatype_Prop.make_tnames Ts;
-            val vs : term list = map Free (ns ~~ Ts);
-            val con_app : term = list_ccomb (con, vs);
-            val vs' : (bool * term) list = map #1 args ~~ vs;
-            fun one_same (n, sel, T) =
-              let
-                val xs = map snd (filter_out fst (nth_drop n vs'));
-                val assms = map (mk_trp o mk_defined) xs;
-                val concl = mk_trp (mk_eq (sel ` con_app, nth vs n));
-                val goal = Logic.list_implies (assms, concl);
-              in
-                prove thy defs goal (K tacs)
-              end;
-            fun one_diff (n, sel, T) =
-              let
-                val goal = mk_trp (mk_eq (sel ` con_app, mk_bottom T));
-              in
-                prove thy defs goal (K tacs)
-              end;
-            fun one_con (j, (_, args')) : thm list =
-              let
-                fun prep (i, (lazy, NONE, T)) = NONE
-                  | prep (i, (lazy, SOME sel, T)) = SOME (i, sel, T);
-                val sels : (int * term * typ) list =
-                  map_filter prep (map_index I args');
-              in
-                if i = j
-                then map one_same sels
-                else map one_diff sels
-              end
-          in
-            flat (map_index one_con spec2)
-          end
-      in
-        flat (map_index sel_apps_of spec2)
-      end
-
-  (* prove selector definedness rules *)
-    val sel_defins : thm list =
-      let
-        val rules = rep_bottom_iff :: @{thms sel_bottom_iff_rules};
-        val tacs = [simp_tac (HOL_basic_ss addsimps rules) 1];
-        fun sel_defin sel =
-          let
-            val (T, U) = dest_cfunT (fastype_of sel);
-            val x = Free ("x", T);
-            val lhs = mk_eq (sel ` x, mk_bottom U);
-            val rhs = mk_eq (x, mk_bottom T);
-            val goal = mk_trp (mk_eq (lhs, rhs));
-          in
-            prove thy sel_defs goal (K tacs)
-          end
-        fun one_arg (false, SOME sel, T) = SOME (sel_defin sel)
-          | one_arg _                    = NONE;
-      in
-        case spec2 of
-          [(con, args)] => map_filter one_arg args
-        | _             => []
-      end;
-
-  in
-    (sel_stricts @ sel_defins @ sel_apps, thy)
-  end
-
-(******************************************************************************)
-(************ definitions and theorems for discriminator functions ************)
-(******************************************************************************)
-
-fun add_discriminators
-    (bindings : binding list)
-    (spec : (term * (bool * typ) list) list)
-    (lhsT : typ)
-    (exhaust : thm)
-    (case_const : typ -> term)
-    (case_rews : thm list)
-    (thy : theory) =
-  let
-
-    fun vars_of args =
-      let
-        val Ts = map snd args;
-        val ns = Datatype_Prop.make_tnames Ts;
-      in
-        map Free (ns ~~ Ts)
-      end;
-
-    (* define discriminator functions *)
-    local
-      fun dis_fun i (j, (con, args)) =
-        let
-          val (vs, nonlazy) = get_vars args;
-          val tr = if i = j then @{term TT} else @{term FF};
-        in
-          big_lambdas vs tr
-        end;
-      fun dis_eqn (i, bind) : binding * term * mixfix =
-        let
-          val dis_bind = Binding.prefix_name "is_" bind;
-          val rhs = list_ccomb (case_const trT, map_index (dis_fun i) spec);
-        in
-          (dis_bind, rhs, NoSyn)
-        end;
-    in
-      val ((dis_consts, dis_defs), thy) =
-          define_consts (map_index dis_eqn bindings) thy
-    end;
-
-    (* prove discriminator strictness rules *)
-    local
-      fun dis_strict dis =
-        let val goal = mk_trp (mk_strict dis);
-        in prove thy dis_defs goal (K [rtac (hd case_rews) 1]) end;
-    in
-      val dis_stricts = map dis_strict dis_consts;
-    end;
-
-    (* prove discriminator/constructor rules *)
-    local
-      fun dis_app (i, dis) (j, (con, args)) =
-        let
-          val (vs, nonlazy) = get_vars args;
-          val lhs = dis ` list_ccomb (con, vs);
-          val rhs = if i = j then @{term TT} else @{term FF};
-          val assms = map (mk_trp o mk_defined) nonlazy;
-          val concl = mk_trp (mk_eq (lhs, rhs));
-          val goal = Logic.list_implies (assms, concl);
-          val tacs = [asm_simp_tac (beta_ss addsimps case_rews) 1];
-        in prove thy dis_defs goal (K tacs) end;
-      fun one_dis (i, dis) =
-          map_index (dis_app (i, dis)) spec;
-    in
-      val dis_apps = flat (map_index one_dis dis_consts);
-    end;
-
-    (* prove discriminator definedness rules *)
-    local
-      fun dis_defin dis =
-        let
-          val x = Free ("x", lhsT);
-          val simps = dis_apps @ @{thms dist_eq_tr};
-          val tacs =
-            [rtac @{thm iffI} 1,
-             asm_simp_tac (HOL_basic_ss addsimps dis_stricts) 2,
-             rtac exhaust 1, atac 1,
-             DETERM_UNTIL_SOLVED (CHANGED
-               (asm_full_simp_tac (simple_ss addsimps simps) 1))];
-          val goal = mk_trp (mk_eq (mk_undef (dis ` x), mk_undef x));
-        in prove thy [] goal (K tacs) end;
-    in
-      val dis_defins = map dis_defin dis_consts;
-    end;
-
-  in
-    (dis_stricts @ dis_defins @ dis_apps, thy)
-  end;
-
-(******************************************************************************)
-(*************** definitions and theorems for match combinators ***************)
-(******************************************************************************)
-
-fun add_match_combinators
-    (bindings : binding list)
-    (spec : (term * (bool * typ) list) list)
-    (lhsT : typ)
-    (exhaust : thm)
-    (case_const : typ -> term)
-    (case_rews : thm list)
-    (thy : theory) =
-  let
-
-    (* get a fresh type variable for the result type *)
-    val resultT : typ =
-      let
-        val ts : string list = map fst (Term.add_tfreesT lhsT []);
-        val t : string = Name.variant ts "'t";
-      in TFree (t, @{sort pcpo}) end;
-
-    (* define match combinators *)
-    local
-      val x = Free ("x", lhsT);
-      fun k args = Free ("k", map snd args -->> mk_matchT resultT);
-      val fail = mk_fail resultT;
-      fun mat_fun i (j, (con, args)) =
-        let
-          val (vs, nonlazy) = get_vars_avoiding ["x","k"] args;
-        in
-          if i = j then k args else big_lambdas vs fail
-        end;
-      fun mat_eqn (i, (bind, (con, args))) : binding * term * mixfix =
-        let
-          val mat_bind = Binding.prefix_name "match_" bind;
-          val funs = map_index (mat_fun i) spec
-          val body = list_ccomb (case_const (mk_matchT resultT), funs);
-          val rhs = big_lambda x (big_lambda (k args) (body ` x));
-        in
-          (mat_bind, rhs, NoSyn)
-        end;
-    in
-      val ((match_consts, match_defs), thy) =
-          define_consts (map_index mat_eqn (bindings ~~ spec)) thy
-    end;
-
-    (* register match combinators with fixrec package *)
-    local
-      val con_names = map (fst o dest_Const o fst) spec;
-      val mat_names = map (fst o dest_Const) match_consts;
-    in
-      val thy = Fixrec.add_matchers (con_names ~~ mat_names) thy;
-    end;
-
-    (* prove strictness of match combinators *)
-    local
-      fun match_strict mat =
-        let
-          val (T, (U, V)) = apsnd dest_cfunT (dest_cfunT (fastype_of mat));
-          val k = Free ("k", U);
-          val goal = mk_trp (mk_eq (mat ` mk_bottom T ` k, mk_bottom V));
-          val tacs = [asm_simp_tac (beta_ss addsimps case_rews) 1];
-        in prove thy match_defs goal (K tacs) end;
-    in
-      val match_stricts = map match_strict match_consts;
-    end;
-
-    (* prove match/constructor rules *)
-    local
-      val fail = mk_fail resultT;
-      fun match_app (i, mat) (j, (con, args)) =
-        let
-          val (vs, nonlazy) = get_vars_avoiding ["k"] args;
-          val (_, (kT, _)) = apsnd dest_cfunT (dest_cfunT (fastype_of mat));
-          val k = Free ("k", kT);
-          val lhs = mat ` list_ccomb (con, vs) ` k;
-          val rhs = if i = j then list_ccomb (k, vs) else fail;
-          val assms = map (mk_trp o mk_defined) nonlazy;
-          val concl = mk_trp (mk_eq (lhs, rhs));
-          val goal = Logic.list_implies (assms, concl);
-          val tacs = [asm_simp_tac (beta_ss addsimps case_rews) 1];
-        in prove thy match_defs goal (K tacs) end;
-      fun one_match (i, mat) =
-          map_index (match_app (i, mat)) spec;
-    in
-      val match_apps = flat (map_index one_match match_consts);
-    end;
-
-  in
-    (match_stricts @ match_apps, thy)
-  end;
-
-(******************************************************************************)
-(******************************* main function ********************************)
-(******************************************************************************)
-
-fun add_domain_constructors
-    (dbind : binding)
-    (spec : (binding * (bool * binding option * typ) list * mixfix) list)
-    (iso_info : Domain_Take_Proofs.iso_info)
-    (thy : theory) =
-  let
-    val dname = Binding.name_of dbind;
-    val _ = writeln ("Proving isomorphism properties of domain "^dname^" ...");
-
-    val bindings = map #1 spec;
-
-    (* retrieve facts about rep/abs *)
-    val lhsT = #absT iso_info;
-    val {rep_const, abs_const, ...} = iso_info;
-    val abs_iso_thm = #abs_inverse iso_info;
-    val rep_iso_thm = #rep_inverse iso_info;
-    val iso_locale = @{thm iso.intro} OF [abs_iso_thm, rep_iso_thm];
-    val rep_strict = iso_locale RS @{thm iso.rep_strict};
-    val abs_strict = iso_locale RS @{thm iso.abs_strict};
-    val rep_bottom_iff = iso_locale RS @{thm iso.rep_bottom_iff};
-    val abs_bottom_iff = iso_locale RS @{thm iso.abs_bottom_iff};
-    val iso_rews = [abs_iso_thm, rep_iso_thm, abs_strict, rep_strict];
-
-    (* qualify constants and theorems with domain name *)
-    val thy = Sign.add_path dname thy;
-
-    (* define constructor functions *)
-    val (con_result, thy) =
-      let
-        fun prep_arg (lazy, sel, T) = (lazy, T);
-        fun prep_con (b, args, mx) = (b, map prep_arg args, mx);
-        val con_spec = map prep_con spec;
-      in
-        add_constructors con_spec abs_const iso_locale thy
-      end;
-    val {con_consts, con_betas, nchotomy, exhaust, compacts, con_rews,
-          inverts, injects, dist_les, dist_eqs} = con_result;
-
-    (* prepare constructor spec *)
-    val con_specs : (term * (bool * typ) list) list =
-      let
-        fun prep_arg (lazy, sel, T) = (lazy, T);
-        fun prep_con c (b, args, mx) = (c, map prep_arg args);
-      in
-        map2 prep_con con_consts spec
-      end;
-
-    (* define case combinator *)
-    val ((case_const : typ -> term, cases : thm list), thy) =
-        add_case_combinator con_specs lhsT dbind
-          con_betas exhaust iso_locale rep_const thy
-
-    (* define and prove theorems for selector functions *)
-    val (sel_thms : thm list, thy : theory) =
-      let
-        val sel_spec : (term * (bool * binding option * typ) list) list =
-          map2 (fn con => fn (b, args, mx) => (con, args)) con_consts spec;
-      in
-        add_selectors sel_spec rep_const
-          abs_iso_thm rep_strict rep_bottom_iff con_betas thy
-      end;
-
-    (* define and prove theorems for discriminator functions *)
-    val (dis_thms : thm list, thy : theory) =
-        add_discriminators bindings con_specs lhsT
-          exhaust case_const cases thy;
-
-    (* define and prove theorems for match combinators *)
-    val (match_thms : thm list, thy : theory) =
-        add_match_combinators bindings con_specs lhsT
-          exhaust case_const cases thy;
-
-    (* restore original signature path *)
-    val thy = Sign.parent_path thy;
-
-    (* bind theorem names in global theory *)
-    val (_, thy) =
-      let
-        fun qualified name = Binding.qualified true name dbind;
-        val names = "bottom" :: map (fn (b,_,_) => Binding.name_of b) spec;
-        val dname = fst (dest_Type lhsT);
-        val simp = Simplifier.simp_add;
-        val case_names = Rule_Cases.case_names names;
-        val cases_type = Induct.cases_type dname;
-      in
-        Global_Theory.add_thmss [
-          ((qualified "iso_rews"  , iso_rews    ), [simp]),
-          ((qualified "nchotomy"  , [nchotomy]  ), []),
-          ((qualified "exhaust"   , [exhaust]   ), [case_names, cases_type]),
-          ((qualified "case_rews" , cases       ), [simp]),
-          ((qualified "compacts"  , compacts    ), [simp]),
-          ((qualified "con_rews"  , con_rews    ), [simp]),
-          ((qualified "sel_rews"  , sel_thms    ), [simp]),
-          ((qualified "dis_rews"  , dis_thms    ), [simp]),
-          ((qualified "dist_les"  , dist_les    ), [simp]),
-          ((qualified "dist_eqs"  , dist_eqs    ), [simp]),
-          ((qualified "inverts"   , inverts     ), [simp]),
-          ((qualified "injects"   , injects     ), [simp]),
-          ((qualified "match_rews", match_thms  ), [simp])] thy
-      end;
-
-    val result =
-      {
-        iso_info = iso_info,
-        con_specs = con_specs,
-        con_betas = con_betas,
-        nchotomy = nchotomy,
-        exhaust = exhaust,
-        compacts = compacts,
-        con_rews = con_rews,
-        inverts = inverts,
-        injects = injects,
-        dist_les = dist_les,
-        dist_eqs = dist_eqs,
-        cases = cases,
-        sel_rews = sel_thms,
-        dis_rews = dis_thms,
-        match_rews = match_thms
-      };
-  in
-    (result, thy)
-  end;
-
-end;

--- a/src/HOLCF/Tools/Domain/domain_induction.ML	Sat Nov 27 14:34:54 2010 -0800
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,439 +0,0 @@
-(*  Title:      HOLCF/Tools/Domain/domain_induction.ML
-    Author:     David von Oheimb
-    Author:     Brian Huffman
-
-Proofs of high-level (co)induction rules for domain command.
-*)
-
-signature DOMAIN_INDUCTION =
-sig
-  val comp_theorems :
-      binding list ->
-      Domain_Take_Proofs.take_induct_info ->
-      Domain_Constructors.constr_info list ->
-      theory -> thm list * theory
-
-  val quiet_mode: bool Unsynchronized.ref;
-  val trace_domain: bool Unsynchronized.ref;
-end;
-
-structure Domain_Induction :> DOMAIN_INDUCTION =
-struct
-
-val quiet_mode = Unsynchronized.ref false;
-val trace_domain = Unsynchronized.ref false;
-
-fun message s = if !quiet_mode then () else writeln s;
-fun trace s = if !trace_domain then tracing s else ();
-
-open HOLCF_Library;
-
-(******************************************************************************)
-(***************************** proofs about take ******************************)
-(******************************************************************************)
-
-fun take_theorems
-    (dbinds : binding list)
-    (take_info : Domain_Take_Proofs.take_induct_info)
-    (constr_infos : Domain_Constructors.constr_info list)
-    (thy : theory) : thm list list * theory =
-let
-  val {take_consts, take_Suc_thms, deflation_take_thms, ...} = take_info;
-  val deflation_thms = Domain_Take_Proofs.get_deflation_thms thy;
-
-  val n = Free ("n", @{typ nat});
-  val n' = @{const Suc} $ n;
-
-  local
-    val newTs = map (#absT o #iso_info) constr_infos;
-    val subs = newTs ~~ map (fn t => t $ n) take_consts;
-    fun is_ID (Const (c, _)) = (c = @{const_name ID})
-      | is_ID _              = false;
-  in
-    fun map_of_arg thy v T =
-      let val m = Domain_Take_Proofs.map_of_typ thy subs T;
-      in if is_ID m then v else mk_capply (m, v) end;
-  end
-
-  fun prove_take_apps
-      ((dbind, take_const), constr_info) thy =
-    let
-      val {iso_info, con_specs, con_betas, ...} = constr_info;
-      val {abs_inverse, ...} = iso_info;
-      fun prove_take_app (con_const, args) =
-        let
-          val Ts = map snd args;
-          val ns = Name.variant_list ["n"] (Datatype_Prop.make_tnames Ts);
-          val vs = map Free (ns ~~ Ts);
-          val lhs = mk_capply (take_const $ n', list_ccomb (con_const, vs));
-          val rhs = list_ccomb (con_const, map2 (map_of_arg thy) vs Ts);
-          val goal = mk_trp (mk_eq (lhs, rhs));
-          val rules =
-              [abs_inverse] @ con_betas @ @{thms take_con_rules}
-              @ take_Suc_thms @ deflation_thms @ deflation_take_thms;
-          val tac = simp_tac (HOL_basic_ss addsimps rules) 1;
-        in
-          Goal.prove_global thy [] [] goal (K tac)
-        end;
-      val take_apps = map prove_take_app con_specs;
-    in
-      yield_singleton Global_Theory.add_thmss
-        ((Binding.qualified true "take_rews" dbind, take_apps),
-        [Simplifier.simp_add]) thy
-    end;
-in
-  fold_map prove_take_apps
-    (dbinds ~~ take_consts ~~ constr_infos) thy
-end;
-
-(******************************************************************************)
-(****************************** induction rules *******************************)
-(******************************************************************************)
-
-val case_UU_allI =
-    @{lemma "(!!x. x ~= UU ==> P x) ==> P UU ==> ALL x. P x" by metis};
-
-fun prove_induction
-    (comp_dbind : binding)
-    (constr_infos : Domain_Constructors.constr_info list)
-    (take_info : Domain_Take_Proofs.take_induct_info)
-    (take_rews : thm list)
-    (thy : theory) =
-let
-  val comp_dname = Binding.name_of comp_dbind;
-
-  val iso_infos = map #iso_info constr_infos;
-  val exhausts = map #exhaust constr_infos;
-  val con_rews = maps #con_rews constr_infos;
-  val {take_consts, take_induct_thms, ...} = take_info;
-
-  val newTs = map #absT iso_infos;
-  val P_names = Datatype_Prop.indexify_names (map (K "P") newTs);
-  val x_names = Datatype_Prop.indexify_names (map (K "x") newTs);
-  val P_types = map (fn T => T --> HOLogic.boolT) newTs;
-  val Ps = map Free (P_names ~~ P_types);
-  val xs = map Free (x_names ~~ newTs);
-  val n = Free ("n", HOLogic.natT);
-
-  fun con_assm defined p (con, args) =
-    let
-      val Ts = map snd args;
-      val ns = Name.variant_list P_names (Datatype_Prop.make_tnames Ts);
-      val vs = map Free (ns ~~ Ts);
-      val nonlazy = map snd (filter_out (fst o fst) (args ~~ vs));
-      fun ind_hyp (v, T) t =
-          case AList.lookup (op =) (newTs ~~ Ps) T of NONE => t
-          | SOME p' => Logic.mk_implies (mk_trp (p' $ v), t);
-      val t1 = mk_trp (p $ list_ccomb (con, vs));
-      val t2 = fold_rev ind_hyp (vs ~~ Ts) t1;
-      val t3 = Logic.list_implies (map (mk_trp o mk_defined) nonlazy, t2);
-    in fold_rev Logic.all vs (if defined then t3 else t2) end;
-  fun eq_assms ((p, T), cons) =
-      mk_trp (p $ HOLCF_Library.mk_bottom T) :: map (con_assm true p) cons;
-  val assms = maps eq_assms (Ps ~~ newTs ~~ map #con_specs constr_infos);
-
-  val take_ss = HOL_ss addsimps (@{thm Rep_cfun_strict1} :: take_rews);
-  fun quant_tac ctxt i = EVERY
-    (map (fn name => res_inst_tac ctxt [(("x", 0), name)] spec i) x_names);
-
-  (* FIXME: move this message to domain_take_proofs.ML *)
-  val is_finite = #is_finite take_info;
-  val _ = if is_finite
-          then message ("Proving finiteness rule for domain "^comp_dname^" ...")
-          else ();
-
-  val _ = trace " Proving finite_ind...";
-  val finite_ind =
-    let
-      val concls =
-          map (fn ((P, t), x) => P $ mk_capply (t $ n, x))
-              (Ps ~~ take_consts ~~ xs);
-      val goal = mk_trp (foldr1 mk_conj concls);
-
-      fun tacf {prems, context} =
-        let
-          (* Prove stronger prems, without definedness side conditions *)
-          fun con_thm p (con, args) =
-            let
-              val subgoal = con_assm false p (con, args);
-              val rules = prems @ con_rews @ simp_thms;
-              val simplify = asm_simp_tac (HOL_basic_ss addsimps rules);
-              fun arg_tac (lazy, _) =
-                  rtac (if lazy then allI else case_UU_allI) 1;
-              val tacs =
-                  rewrite_goals_tac @{thms atomize_all atomize_imp} ::
-                  map arg_tac args @
-                  [REPEAT (rtac impI 1), ALLGOALS simplify];
-            in
-              Goal.prove context [] [] subgoal (K (EVERY tacs))
-            end;
-          fun eq_thms (p, cons) = map (con_thm p) cons;
-          val conss = map #con_specs constr_infos;
-          val prems' = maps eq_thms (Ps ~~ conss);
-
-          val tacs1 = [
-            quant_tac context 1,
-            simp_tac HOL_ss 1,
-            InductTacs.induct_tac context [[SOME "n"]] 1,
-            simp_tac (take_ss addsimps prems) 1,
-            TRY (safe_tac HOL_cs)];
-          fun con_tac _ = 
-            asm_simp_tac take_ss 1 THEN
-            (resolve_tac prems' THEN_ALL_NEW etac spec) 1;
-          fun cases_tacs (cons, exhaust) =
-            res_inst_tac context [(("y", 0), "x")] exhaust 1 ::
-            asm_simp_tac (take_ss addsimps prems) 1 ::
-            map con_tac cons;
-          val tacs = tacs1 @ maps cases_tacs (conss ~~ exhausts)
-        in
-          EVERY (map DETERM tacs)
-        end;
-    in Goal.prove_global thy [] assms goal tacf end;
-
-  val _ = trace " Proving ind...";
-  val ind =
-    let
-      val concls = map (op $) (Ps ~~ xs);
-      val goal = mk_trp (foldr1 mk_conj concls);
-      val adms = if is_finite then [] else map (mk_trp o mk_adm) Ps;
-      fun tacf {prems, context} =
-        let
-          fun finite_tac (take_induct, fin_ind) =
-              rtac take_induct 1 THEN
-              (if is_finite then all_tac else resolve_tac prems 1) THEN
-              (rtac fin_ind THEN_ALL_NEW solve_tac prems) 1;
-          val fin_inds = Project_Rule.projections context finite_ind;
-        in
-          TRY (safe_tac HOL_cs) THEN
-          EVERY (map finite_tac (take_induct_thms ~~ fin_inds))
-        end;
-    in Goal.prove_global thy [] (adms @ assms) goal tacf end
-
-  (* case names for induction rules *)
-  val dnames = map (fst o dest_Type) newTs;
-  val case_ns =
-    let
-      val adms =
-          if is_finite then [] else
-          if length dnames = 1 then ["adm"] else
-          map (fn s => "adm_" ^ Long_Name.base_name s) dnames;
-      val bottoms =
-          if length dnames = 1 then ["bottom"] else
-          map (fn s => "bottom_" ^ Long_Name.base_name s) dnames;
-      fun one_eq bot constr_info =
-        let fun name_of (c, args) = Long_Name.base_name (fst (dest_Const c));
-        in bot :: map name_of (#con_specs constr_info) end;
-    in adms @ flat (map2 one_eq bottoms constr_infos) end;
-
-  val inducts = Project_Rule.projections (ProofContext.init_global thy) ind;
-  fun ind_rule (dname, rule) =
-      ((Binding.empty, rule),
-       [Rule_Cases.case_names case_ns, Induct.induct_type dname]);
-
-in
-  thy
-  |> snd o Global_Theory.add_thms [
-     ((Binding.qualified true "finite_induct" comp_dbind, finite_ind), []),
-     ((Binding.qualified true "induct"        comp_dbind, ind       ), [])]
-  |> (snd o Global_Theory.add_thms (map ind_rule (dnames ~~ inducts)))
-end; (* prove_induction *)
-
-(******************************************************************************)
-(************************ bisimulation and coinduction ************************)
-(******************************************************************************)
-
-fun prove_coinduction
-    (comp_dbind : binding, dbinds : binding list)
-    (constr_infos : Domain_Constructors.constr_info list)
-    (take_info : Domain_Take_Proofs.take_induct_info)
-    (take_rews : thm list list)
-    (thy : theory) : theory =
-let
-  val iso_infos = map #iso_info constr_infos;
-  val newTs = map #absT iso_infos;
-
-  val {take_consts, take_0_thms, take_lemma_thms, ...} = take_info;
-
-  val R_names = Datatype_Prop.indexify_names (map (K "R") newTs);
-  val R_types = map (fn T => T --> T --> boolT) newTs;
-  val Rs = map Free (R_names ~~ R_types);
-  val n = Free ("n", natT);
-  val reserved = "x" :: "y" :: R_names;
-
-  (* declare bisimulation predicate *)
-  val bisim_bind = Binding.suffix_name "_bisim" comp_dbind;
-  val bisim_type = R_types ---> boolT;
-  val (bisim_const, thy) =
-      Sign.declare_const ((bisim_bind, bisim_type), NoSyn) thy;
-
-  (* define bisimulation predicate *)
-  local
-    fun one_con T (con, args) =
-      let
-        val Ts = map snd args;
-        val ns1 = Name.variant_list reserved (Datatype_Prop.make_tnames Ts);
-        val ns2 = map (fn n => n^"'") ns1;
-        val vs1 = map Free (ns1 ~~ Ts);
-        val vs2 = map Free (ns2 ~~ Ts);
-        val eq1 = mk_eq (Free ("x", T), list_ccomb (con, vs1));
-        val eq2 = mk_eq (Free ("y", T), list_ccomb (con, vs2));
-        fun rel ((v1, v2), T) =
-            case AList.lookup (op =) (newTs ~~ Rs) T of
-              NONE => mk_eq (v1, v2) | SOME r => r $ v1 $ v2;
-        val eqs = foldr1 mk_conj (map rel (vs1 ~~ vs2 ~~ Ts) @ [eq1, eq2]);
-      in
-        Library.foldr mk_ex (vs1 @ vs2, eqs)
-      end;
-    fun one_eq ((T, R), cons) =
-      let
-        val x = Free ("x", T);
-        val y = Free ("y", T);
-        val disj1 = mk_conj (mk_eq (x, mk_bottom T), mk_eq (y, mk_bottom T));
-        val disjs = disj1 :: map (one_con T) cons;
-      in
-        mk_all (x, mk_all (y, mk_imp (R $ x $ y, foldr1 mk_disj disjs)))
-      end;
-    val conjs = map one_eq (newTs ~~ Rs ~~ map #con_specs constr_infos);
-    val bisim_rhs = lambdas Rs (Library.foldr1 mk_conj conjs);
-    val bisim_eqn = Logic.mk_equals (bisim_const, bisim_rhs);
-  in
-    val (bisim_def_thm, thy) = thy |>
-        yield_singleton (Global_Theory.add_defs false)
-         ((Binding.qualified true "bisim_def" comp_dbind, bisim_eqn), []);
-  end (* local *)
-
-  (* prove coinduction lemma *)
-  val coind_lemma =
-    let
-      val assm = mk_trp (list_comb (bisim_const, Rs));
-      fun one ((T, R), take_const) =
-        let
-          val x = Free ("x", T);
-          val y = Free ("y", T);
-          val lhs = mk_capply (take_const $ n, x);
-          val rhs = mk_capply (take_const $ n, y);
-        in
-          mk_all (x, mk_all (y, mk_imp (R $ x $ y, mk_eq (lhs, rhs))))
-        end;
-      val goal =
-          mk_trp (foldr1 mk_conj (map one (newTs ~~ Rs ~~ take_consts)));
-      val rules = @{thm Rep_cfun_strict1} :: take_0_thms;
-      fun tacf {prems, context} =
-        let
-          val prem' = rewrite_rule [bisim_def_thm] (hd prems);
-          val prems' = Project_Rule.projections context prem';
-          val dests = map (fn th => th RS spec RS spec RS mp) prems';
-          fun one_tac (dest, rews) =
-              dtac dest 1 THEN safe_tac HOL_cs THEN
-              ALLGOALS (asm_simp_tac (HOL_basic_ss addsimps rews));
-        in
-          rtac @{thm nat.induct} 1 THEN
-          simp_tac (HOL_ss addsimps rules) 1 THEN
-          safe_tac HOL_cs THEN
-          EVERY (map one_tac (dests ~~ take_rews))
-        end
-    in
-      Goal.prove_global thy [] [assm] goal tacf
-    end;
-
-  (* prove individual coinduction rules *)
-  fun prove_coind ((T, R), take_lemma) =
-    let
-      val x = Free ("x", T);
-      val y = Free ("y", T);
-      val assm1 = mk_trp (list_comb (bisim_const, Rs));
-      val assm2 = mk_trp (R $ x $ y);
-      val goal = mk_trp (mk_eq (x, y));
-      fun tacf {prems, context} =
-        let
-          val rule = hd prems RS coind_lemma;
-        in
-          rtac take_lemma 1 THEN
-          asm_simp_tac (HOL_basic_ss addsimps (rule :: prems)) 1
-        end;
-    in
-      Goal.prove_global thy [] [assm1, assm2] goal tacf
-    end;
-  val coinds = map prove_coind (newTs ~~ Rs ~~ take_lemma_thms);
-  val coind_binds = map (Binding.qualified true "coinduct") dbinds;
-
-in
-  thy |> snd o Global_Theory.add_thms
-    (map Thm.no_attributes (coind_binds ~~ coinds))
-end; (* let *)
-
-(******************************************************************************)
-(******************************* main function ********************************)
-(******************************************************************************)
-
-fun comp_theorems
-    (dbinds : binding list)
-    (take_info : Domain_Take_Proofs.take_induct_info)
-    (constr_infos : Domain_Constructors.constr_info list)
-    (thy : theory) =
-let
-
-val comp_dname = space_implode "_" (map Binding.name_of dbinds);
-val comp_dbind = Binding.name comp_dname;
-
-(* Test for emptiness *)
-(* FIXME: reimplement emptiness test
-local
-  open Domain_Library;
-  val dnames = map (fst o fst) eqs;
-  val conss = map snd eqs;
-  fun rec_to ns lazy_rec (n,cons) = forall (exists (fn arg => 
-        is_rec arg andalso not (member (op =) ns (rec_of arg)) andalso
-        ((rec_of arg =  n andalso not (lazy_rec orelse is_lazy arg)) orelse 
-          rec_of arg <> n andalso rec_to (rec_of arg::ns) 
-            (lazy_rec orelse is_lazy arg) (n, (List.nth(conss,rec_of arg))))
-        ) o snd) cons;
-  fun warn (n,cons) =
-    if rec_to [] false (n,cons)
-    then (warning ("domain "^List.nth(dnames,n)^" is empty!"); true)
-    else false;
-in
-  val n__eqs = mapn (fn n => fn (_,cons) => (n,cons)) 0 eqs;
-  val is_emptys = map warn n__eqs;
-end;
-*)
-
-(* Test for indirect recursion *)
-local
-  val newTs = map (#absT o #iso_info) constr_infos;
-  fun indirect_typ (Type (_, Ts)) =
-      exists (fn T => member (op =) newTs T orelse indirect_typ T) Ts
-    | indirect_typ _ = false;
-  fun indirect_arg (_, T) = indirect_typ T;
-  fun indirect_con (_, args) = exists indirect_arg args;
-  fun indirect_eq cons = exists indirect_con cons;
-in
-  val is_indirect = exists indirect_eq (map #con_specs constr_infos);
-  val _ =
-      if is_indirect
-      then message "Indirect recursion detected, skipping proofs of (co)induction rules"
-      else message ("Proving induction properties of domain "^comp_dname^" ...");
-end;
-
-(* theorems about take *)
-
-val (take_rewss, thy) =
-    take_theorems dbinds take_info constr_infos thy;
-
-val {take_lemma_thms, take_0_thms, take_strict_thms, ...} = take_info;
-
-val take_rews = take_0_thms @ take_strict_thms @ flat take_rewss;
-
-(* prove induction rules, unless definition is indirect recursive *)
-val thy =
-    if is_indirect then thy else
-    prove_induction comp_dbind constr_infos take_info take_rews thy;
-
-val thy =
-    if is_indirect then thy else
-    prove_coinduction (comp_dbind, dbinds) constr_infos take_info take_rewss thy;
-
-in
-  (take_rews, thy)
-end; (* let *)
-end; (* struct *)

--- a/src/HOLCF/Tools/Domain/domain_isomorphism.ML	Sat Nov 27 14:34:54 2010 -0800
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,787 +0,0 @@
-(*  Title:      HOLCF/Tools/Domain/domain_isomorphism.ML
-    Author:     Brian Huffman
-
-Defines new types satisfying the given domain equations.
-*)
-
-signature DOMAIN_ISOMORPHISM =
-sig
-  val domain_isomorphism :
-      (string list * binding * mixfix * typ
-       * (binding * binding) option) list ->
-      theory ->
-      (Domain_Take_Proofs.iso_info list
-       * Domain_Take_Proofs.take_induct_info) * theory
-
-  val define_map_functions :
-      (binding * Domain_Take_Proofs.iso_info) list ->
-      theory ->
-      {
-        map_consts : term list,
-        map_apply_thms : thm list,
-        map_unfold_thms : thm list,
-        deflation_map_thms : thm list
-      }
-      * theory
-
-  val domain_isomorphism_cmd :
-    (string list * binding * mixfix * string * (binding * binding) option) list
-      -> theory -> theory
-
-  val setup : theory -> theory
-end;
-
-structure Domain_Isomorphism : DOMAIN_ISOMORPHISM =
-struct
-
-val beta_rules =
-  @{thms beta_cfun cont_id cont_const cont2cont_APP cont2cont_LAM'} @
-  @{thms cont2cont_fst cont2cont_snd cont2cont_Pair cont2cont_prod_case'};
-
-val beta_ss = HOL_basic_ss addsimps (simp_thms @ beta_rules);
-
-val beta_tac = simp_tac beta_ss;
-
-fun is_cpo thy T = Sign.of_sort thy (T, @{sort cpo});
-
-(******************************************************************************)
-(******************************** theory data *********************************)
-(******************************************************************************)
-
-structure RepData = Named_Thms
-(
-  val name = "domain_defl_simps"
-  val description = "theorems like DEFL('a t) = t_defl$DEFL('a)"
-)
-
-structure IsodeflData = Named_Thms
-(
-  val name = "domain_isodefl"
-  val description = "theorems like isodefl d t ==> isodefl (foo_map$d) (foo_defl$t)"
-);
-
-val setup = RepData.setup #> IsodeflData.setup
-
-
-(******************************************************************************)
-(************************** building types and terms **************************)
-(******************************************************************************)
-
-open HOLCF_Library;
-
-infixr 6 ->>;
-infixr -->>;
-
-val udomT = @{typ udom};
-val deflT = @{typ "defl"};
-
-fun mk_DEFL T =
-  Const (@{const_name defl}, Term.itselfT T --> deflT) $ Logic.mk_type T;
-
-fun dest_DEFL (Const (@{const_name defl}, _) $ t) = Logic.dest_type t
-  | dest_DEFL t = raise TERM ("dest_DEFL", [t]);
-
-fun mk_LIFTDEFL T =
-  Const (@{const_name liftdefl}, Term.itselfT T --> deflT) $ Logic.mk_type T;
-
-fun dest_LIFTDEFL (Const (@{const_name liftdefl}, _) $ t) = Logic.dest_type t
-  | dest_LIFTDEFL t = raise TERM ("dest_LIFTDEFL", [t]);
-
-fun mk_u_defl t = mk_capply (@{const "u_defl"}, t);
-
-fun mk_u_map t =
-  let
-    val (T, U) = dest_cfunT (fastype_of t);
-    val u_map_type = (T ->> U) ->> (mk_upT T ->> mk_upT U);
-    val u_map_const = Const (@{const_name u_map}, u_map_type);
-  in
-    mk_capply (u_map_const, t)
-  end;
-
-fun emb_const T = Const (@{const_name emb}, T ->> udomT);
-fun prj_const T = Const (@{const_name prj}, udomT ->> T);
-fun coerce_const (T, U) = mk_cfcomp (prj_const U, emb_const T);
-
-fun isodefl_const T =
-  Const (@{const_name isodefl}, (T ->> T) --> deflT --> HOLogic.boolT);
-
-fun mk_deflation t =
-  Const (@{const_name deflation}, Term.fastype_of t --> boolT) $ t;
-
-(* splits a cterm into the right and lefthand sides of equality *)
-fun dest_eqs t = HOLogic.dest_eq (HOLogic.dest_Trueprop t);
-
-fun mk_eqs (t, u) = HOLogic.mk_Trueprop (HOLogic.mk_eq (t, u));
-
-(******************************************************************************)
-(****************************** isomorphism info ******************************)
-(******************************************************************************)
-
-fun deflation_abs_rep (info : Domain_Take_Proofs.iso_info) : thm =
-  let
-    val abs_iso = #abs_inverse info;
-    val rep_iso = #rep_inverse info;
-    val thm = @{thm deflation_abs_rep} OF [abs_iso, rep_iso];
-  in
-    Drule.zero_var_indexes thm
-  end
-
-(******************************************************************************)
-(*************** fixed-point definitions and unfolding theorems ***************)
-(******************************************************************************)
-
-fun mk_projs []      t = []
-  | mk_projs (x::[]) t = [(x, t)]
-  | mk_projs (x::xs) t = (x, mk_fst t) :: mk_projs xs (mk_snd t);
-
-fun add_fixdefs
-    (spec : (binding * term) list)
-    (thy : theory) : (thm list * thm list) * theory =
-  let
-    val binds = map fst spec;
-    val (lhss, rhss) = ListPair.unzip (map (dest_eqs o snd) spec);
-    val functional = lambda_tuple lhss (mk_tuple rhss);
-    val fixpoint = mk_fix (mk_cabs functional);
-
-    (* project components of fixpoint *)
-    val projs = mk_projs lhss fixpoint;
-
-    (* convert parameters to lambda abstractions *)
-    fun mk_eqn (lhs, rhs) =
-        case lhs of
-          Const (@{const_name Rep_cfun}, _) $ f $ (x as Free _) =>
-            mk_eqn (f, big_lambda x rhs)
-        | f $ Const (@{const_name TYPE}, T) =>
-            mk_eqn (f, Abs ("t", T, rhs))
-        | Const _ => Logic.mk_equals (lhs, rhs)
-        | _ => raise TERM ("lhs not of correct form", [lhs, rhs]);
-    val eqns = map mk_eqn projs;
-
-    (* register constant definitions *)
-    val (fixdef_thms, thy) =
-      (Global_Theory.add_defs false o map Thm.no_attributes)
-        (map (Binding.suffix_name "_def") binds ~~ eqns) thy;
-
-    (* prove applied version of definitions *)
-    fun prove_proj (lhs, rhs) =
-      let
-        val tac = rewrite_goals_tac fixdef_thms THEN beta_tac 1;
-        val goal = Logic.mk_equals (lhs, rhs);
-      in Goal.prove_global thy [] [] goal (K tac) end;
-    val proj_thms = map prove_proj projs;
-
-    (* mk_tuple lhss == fixpoint *)
-    fun pair_equalI (thm1, thm2) = @{thm Pair_equalI} OF [thm1, thm2];
-    val tuple_fixdef_thm = foldr1 pair_equalI proj_thms;
-
-    val cont_thm =
-      Goal.prove_global thy [] [] (mk_trp (mk_cont functional))
-        (K (beta_tac 1));
-    val tuple_unfold_thm =
-      (@{thm def_cont_fix_eq} OF [tuple_fixdef_thm, cont_thm])
-      |> Local_Defs.unfold (ProofContext.init_global thy) @{thms split_conv};
-
-    fun mk_unfold_thms [] thm = []
-      | mk_unfold_thms (n::[]) thm = [(n, thm)]
-      | mk_unfold_thms (n::ns) thm = let
-          val thmL = thm RS @{thm Pair_eqD1};
-          val thmR = thm RS @{thm Pair_eqD2};
-        in (n, thmL) :: mk_unfold_thms ns thmR end;
-    val unfold_binds = map (Binding.suffix_name "_unfold") binds;
-
-    (* register unfold theorems *)
-    val (unfold_thms, thy) =
-      (Global_Theory.add_thms o map (Thm.no_attributes o apsnd Drule.zero_var_indexes))
-        (mk_unfold_thms unfold_binds tuple_unfold_thm) thy;
-  in
-    ((proj_thms, unfold_thms), thy)
-  end;
-
-
-(******************************************************************************)
-(****************** deflation combinators and map functions *******************)
-(******************************************************************************)
-
-fun defl_of_typ
-    (thy : theory)
-    (tab1 : (typ * term) list)
-    (tab2 : (typ * term) list)
-    (T : typ) : term =
-  let
-    val defl_simps = RepData.get (ProofContext.init_global thy);
-    val rules = map (Thm.concl_of #> HOLogic.dest_Trueprop #> HOLogic.dest_eq) defl_simps;
-    val rules' = map (apfst mk_DEFL) tab1 @ map (apfst mk_LIFTDEFL) tab2;
-    fun proc1 t =
-      (case dest_DEFL t of
-        TFree (a, _) => SOME (Free ("d" ^ Library.unprefix "'" a, deflT))
-      | _ => NONE) handle TERM _ => NONE;
-    fun proc2 t =
-      (case dest_LIFTDEFL t of
-        TFree (a, _) => SOME (Free ("p" ^ Library.unprefix "'" a, deflT))
-      | _ => NONE) handle TERM _ => NONE;
-  in
-    Pattern.rewrite_term thy (rules @ rules') [proc1, proc2] (mk_DEFL T)
-  end;
-
-(******************************************************************************)
-(********************* declaring definitions and theorems *********************)
-(******************************************************************************)
-
-fun define_const
-    (bind : binding, rhs : term)
-    (thy : theory)
-    : (term * thm) * theory =
-  let
-    val typ = Term.fastype_of rhs;
-    val (const, thy) = Sign.declare_const ((bind, typ), NoSyn) thy;
-    val eqn = Logic.mk_equals (const, rhs);
-    val def = Thm.no_attributes (Binding.suffix_name "_def" bind, eqn);
-    val (def_thm, thy) = yield_singleton (Global_Theory.add_defs false) def thy;
-  in
-    ((const, def_thm), thy)
-  end;
-
-fun add_qualified_thm name (dbind, thm) =
-    yield_singleton Global_Theory.add_thms
-      ((Binding.qualified true name dbind, thm), []);
-
-(******************************************************************************)
-(*************************** defining map functions ***************************)
-(******************************************************************************)
-
-fun define_map_functions
-    (spec : (binding * Domain_Take_Proofs.iso_info) list)
-    (thy : theory) =
-  let
-
-    (* retrieve components of spec *)
-    val dbinds = map fst spec;
-    val iso_infos = map snd spec;
-    val dom_eqns = map (fn x => (#absT x, #repT x)) iso_infos;
-    val rep_abs_consts = map (fn x => (#rep_const x, #abs_const x)) iso_infos;
-
-    fun mapT (T as Type (_, Ts)) =
-        (map (fn T => T ->> T) (filter (is_cpo thy) Ts)) -->> (T ->> T)
-      | mapT T = T ->> T;
-
-    (* declare map functions *)
-    fun declare_map_const (tbind, (lhsT, rhsT)) thy =
-      let
-        val map_type = mapT lhsT;
-        val map_bind = Binding.suffix_name "_map" tbind;
-      in
-        Sign.declare_const ((map_bind, map_type), NoSyn) thy
-      end;
-    val (map_consts, thy) = thy |>
-      fold_map declare_map_const (dbinds ~~ dom_eqns);
-
-    (* defining equations for map functions *)
-    local
-      fun unprime a = Library.unprefix "'" a;
-      fun mapvar T = Free (unprime (fst (dest_TFree T)), T ->> T);
-      fun map_lhs (map_const, lhsT) =
-          (lhsT, list_ccomb (map_const, map mapvar (filter (is_cpo thy) (snd (dest_Type lhsT)))));
-      val tab1 = map map_lhs (map_consts ~~ map fst dom_eqns);
-      val Ts = (snd o dest_Type o fst o hd) dom_eqns;
-      val tab = (Ts ~~ map mapvar Ts) @ tab1;
-      fun mk_map_spec (((rep_const, abs_const), map_const), (lhsT, rhsT)) =
-        let
-          val lhs = Domain_Take_Proofs.map_of_typ thy tab lhsT;
-          val body = Domain_Take_Proofs.map_of_typ thy tab rhsT;
-          val rhs = mk_cfcomp (abs_const, mk_cfcomp (body, rep_const));
-        in mk_eqs (lhs, rhs) end;
-    in
-      val map_specs =
-          map mk_map_spec (rep_abs_consts ~~ map_consts ~~ dom_eqns);
-    end;
-
-    (* register recursive definition of map functions *)
-    val map_binds = map (Binding.suffix_name "_map") dbinds;
-    val ((map_apply_thms, map_unfold_thms), thy) =
-      add_fixdefs (map_binds ~~ map_specs) thy;
-
-    (* prove deflation theorems for map functions *)
-    val deflation_abs_rep_thms = map deflation_abs_rep iso_infos;
-    val deflation_map_thm =
-      let
-        fun unprime a = Library.unprefix "'" a;
-        fun mk_f T = Free (unprime (fst (dest_TFree T)), T ->> T);
-        fun mk_assm T = mk_trp (mk_deflation (mk_f T));
-        fun mk_goal (map_const, (lhsT, rhsT)) =
-          let
-            val (_, Ts) = dest_Type lhsT;
-            val map_term = list_ccomb (map_const, map mk_f (filter (is_cpo thy) Ts));
-          in mk_deflation map_term end;
-        val assms = (map mk_assm o filter (is_cpo thy) o snd o dest_Type o fst o hd) dom_eqns;
-        val goals = map mk_goal (map_consts ~~ dom_eqns);
-        val goal = mk_trp (foldr1 HOLogic.mk_conj goals);
-        val start_thms =
-          @{thm split_def} :: map_apply_thms;
-        val adm_rules =
-          @{thms adm_conj adm_subst [OF _ adm_deflation]
-                 cont2cont_fst cont2cont_snd cont_id};
-        val bottom_rules =
-          @{thms fst_strict snd_strict deflation_UU simp_thms};
-        val deflation_rules =
-          @{thms conjI deflation_ID}
-          @ deflation_abs_rep_thms
-          @ Domain_Take_Proofs.get_deflation_thms thy;
-      in
-        Goal.prove_global thy [] assms goal (fn {prems, ...} =>
-         EVERY
-          [simp_tac (HOL_basic_ss addsimps start_thms) 1,
-           rtac @{thm fix_ind} 1,
-           REPEAT (resolve_tac adm_rules 1),
-           simp_tac (HOL_basic_ss addsimps bottom_rules) 1,
-           simp_tac beta_ss 1,
-           simp_tac (HOL_basic_ss addsimps @{thms fst_conv snd_conv}) 1,
-           REPEAT (etac @{thm conjE} 1),
-           REPEAT (resolve_tac (deflation_rules @ prems) 1 ORELSE atac 1)])
-      end;
-    fun conjuncts [] thm = []
-      | conjuncts (n::[]) thm = [(n, thm)]
-      | conjuncts (n::ns) thm = let
-          val thmL = thm RS @{thm conjunct1};
-          val thmR = thm RS @{thm conjunct2};
-        in (n, thmL):: conjuncts ns thmR end;
-    val deflation_map_binds = dbinds |>
-        map (Binding.prefix_name "deflation_" o Binding.suffix_name "_map");
-    val (deflation_map_thms, thy) = thy |>
-      (Global_Theory.add_thms o map (Thm.no_attributes o apsnd Drule.zero_var_indexes))
-        (conjuncts deflation_map_binds deflation_map_thm);
-
-    (* register indirect recursion in theory data *)
-    local
-      fun register_map (dname, args) =
-        Domain_Take_Proofs.add_rec_type (dname, args);
-      val dnames = map (fst o dest_Type o fst) dom_eqns;
-      val map_names = map (fst o dest_Const) map_consts;
-      fun args (T, _) = case T of Type (_, Ts) => map (is_cpo thy) Ts | _ => [];
-      val argss = map args dom_eqns;
-    in
-      val thy =
-          fold register_map (dnames ~~ argss) thy;
-    end;
-
-    (* register deflation theorems *)
-    val thy = fold Domain_Take_Proofs.add_deflation_thm deflation_map_thms thy;
-
-    val result =
-      {
-        map_consts = map_consts,
-        map_apply_thms = map_apply_thms,
-        map_unfold_thms = map_unfold_thms,
-        deflation_map_thms = deflation_map_thms
-      }
-  in
-    (result, thy)
-  end;
-
-(******************************************************************************)
-(******************************* main function ********************************)
-(******************************************************************************)
-
-fun read_typ thy str sorts =
-  let
-    val ctxt = ProofContext.init_global thy
-      |> fold (Variable.declare_typ o TFree) sorts;
-    val T = Syntax.read_typ ctxt str;
-  in (T, Term.add_tfreesT T sorts) end;
-
-fun cert_typ sign raw_T sorts =
-  let
-    val T = Type.no_tvars (Sign.certify_typ sign raw_T)
-      handle TYPE (msg, _, _) => error msg;
-    val sorts' = Term.add_tfreesT T sorts;
-    val _ =
-      case duplicates (op =) (map fst sorts') of
-        [] => ()
-      | dups => error ("Inconsistent sort constraints for " ^ commas dups)
-  in (T, sorts') end;
-
-fun gen_domain_isomorphism
-    (prep_typ: theory -> 'a -> (string * sort) list -> typ * (string * sort) list)
-    (doms_raw: (string list * binding * mixfix * 'a * (binding * binding) option) list)
-    (thy: theory)
-    : (Domain_Take_Proofs.iso_info list
-       * Domain_Take_Proofs.take_induct_info) * theory =
-  let
-    val _ = Theory.requires thy "Domain" "domain isomorphisms";
-
-    (* this theory is used just for parsing *)
-    val tmp_thy = thy |>
-      Theory.copy |>
-      Sign.add_types (map (fn (tvs, tbind, mx, _, morphs) =>
-        (tbind, length tvs, mx)) doms_raw);
-
-    fun prep_dom thy (vs, t, mx, typ_raw, morphs) sorts =
-      let val (typ, sorts') = prep_typ thy typ_raw sorts
-      in ((vs, t, mx, typ, morphs), sorts') end;
-
-    val (doms : (string list * binding * mixfix * typ * (binding * binding) option) list,
-         sorts : (string * sort) list) =
-      fold_map (prep_dom tmp_thy) doms_raw [];
-
-    (* lookup function for sorts of type variables *)
-    fun the_sort v = the (AList.lookup (op =) sorts v);
-
-    (* declare arities in temporary theory *)
-    val tmp_thy =
-      let
-        fun arity (vs, tbind, mx, _, _) =
-          (Sign.full_name thy tbind, map the_sort vs, @{sort "domain"});
-      in
-        fold AxClass.axiomatize_arity (map arity doms) tmp_thy
-      end;
-
-    (* check bifiniteness of right-hand sides *)
-    fun check_rhs (vs, tbind, mx, rhs, morphs) =
-      if Sign.of_sort tmp_thy (rhs, @{sort "domain"}) then ()
-      else error ("Type not of sort domain: " ^
-        quote (Syntax.string_of_typ_global tmp_thy rhs));
-    val _ = map check_rhs doms;
-
-    (* domain equations *)
-    fun mk_dom_eqn (vs, tbind, mx, rhs, morphs) =
-      let fun arg v = TFree (v, the_sort v);
-      in (Type (Sign.full_name tmp_thy tbind, map arg vs), rhs) end;
-    val dom_eqns = map mk_dom_eqn doms;
-
-    (* check for valid type parameters *)
-    val (tyvars, _, _, _, _) = hd doms;
-    val new_doms = map (fn (tvs, tname, mx, _, _) =>
-      let val full_tname = Sign.full_name tmp_thy tname
-      in
-        (case duplicates (op =) tvs of
-          [] =>
-            if eq_set (op =) (tyvars, tvs) then (full_tname, tvs)
-            else error ("Mutually recursive domains must have same type parameters")
-        | dups => error ("Duplicate parameter(s) for domain " ^ quote (Binding.str_of tname) ^
-            " : " ^ commas dups))
-      end) doms;
-    val dbinds = map (fn (_, dbind, _, _, _) => dbind) doms;
-    val morphs = map (fn (_, _, _, _, morphs) => morphs) doms;
-
-    (* determine deflation combinator arguments *)
-    val lhsTs : typ list = map fst dom_eqns;
-    val defl_rec = Free ("t", mk_tupleT (map (K deflT) lhsTs));
-    val defl_recs = mk_projs lhsTs defl_rec;
-    val defl_recs' = map (apsnd mk_u_defl) defl_recs;
-    fun defl_body (_, _, _, rhsT, _) =
-      defl_of_typ tmp_thy defl_recs defl_recs' rhsT;
-    val functional = Term.lambda defl_rec (mk_tuple (map defl_body doms));
-
-    val tfrees = map fst (Term.add_tfrees functional []);
-    val frees = map fst (Term.add_frees functional []);
-    fun get_defl_flags (vs, _, _, _, _) =
-      let
-        fun argT v = TFree (v, the_sort v);
-        fun mk_d v = "d" ^ Library.unprefix "'" v;
-        fun mk_p v = "p" ^ Library.unprefix "'" v;
-        val args = maps (fn v => [(mk_d v, mk_DEFL (argT v)), (mk_p v, mk_LIFTDEFL (argT v))]) vs;
-        val typeTs = map argT (filter (member (op =) tfrees) vs);
-        val defl_args = map snd (filter (member (op =) frees o fst) args);
-      in
-        (typeTs, defl_args)
-      end;
-    val defl_flagss = map get_defl_flags doms;
-
-    (* declare deflation combinator constants *)
-    fun declare_defl_const ((typeTs, defl_args), (_, tbind, _, _, _)) thy =
-      let
-        val defl_bind = Binding.suffix_name "_defl" tbind;
-        val defl_type =
-          map Term.itselfT typeTs ---> map (K deflT) defl_args -->> deflT;
-      in
-        Sign.declare_const ((defl_bind, defl_type), NoSyn) thy
-      end;
-    val (defl_consts, thy) =
-      fold_map declare_defl_const (defl_flagss ~~ doms) thy;
-
-    (* defining equations for type combinators *)
-    fun mk_defl_term (defl_const, (typeTs, defl_args)) =
-      let
-        val type_args = map Logic.mk_type typeTs;
-      in
-        list_ccomb (list_comb (defl_const, type_args), defl_args)
-      end;
-    val defl_terms = map mk_defl_term (defl_consts ~~ defl_flagss);
-    val defl_tab = map fst dom_eqns ~~ defl_terms;
-    val defl_tab' = map fst dom_eqns ~~ map mk_u_defl defl_terms;
-    fun mk_defl_spec (lhsT, rhsT) =
-      mk_eqs (defl_of_typ tmp_thy defl_tab defl_tab' lhsT,
-              defl_of_typ tmp_thy defl_tab defl_tab' rhsT);
-    val defl_specs = map mk_defl_spec dom_eqns;
-
-    (* register recursive definition of deflation combinators *)
-    val defl_binds = map (Binding.suffix_name "_defl") dbinds;
-    val ((defl_apply_thms, defl_unfold_thms), thy) =
-      add_fixdefs (defl_binds ~~ defl_specs) thy;
-
-    (* define types using deflation combinators *)
-    fun make_repdef ((vs, tbind, mx, _, _), defl) thy =
-      let
-        val spec = (tbind, map (rpair dummyS) vs, mx);
-        val ((_, _, _, {DEFL, liftemb_def, liftprj_def, ...}), thy) =
-          Domaindef.add_domaindef false NONE spec defl NONE thy;
-        (* declare domain_defl_simps rules *)
-        val thy = Context.theory_map (RepData.add_thm DEFL) thy;
-      in
-        (DEFL, thy)
-      end;
-    val (DEFL_thms, thy) = fold_map make_repdef (doms ~~ defl_terms) thy;
-
-    (* prove DEFL equations *)
-    fun mk_DEFL_eq_thm (lhsT, rhsT) =
-      let
-        val goal = mk_eqs (mk_DEFL lhsT, mk_DEFL rhsT);
-        val DEFL_simps = RepData.get (ProofContext.init_global thy);
-        val tac =
-          rewrite_goals_tac (map mk_meta_eq DEFL_simps)
-          THEN TRY (resolve_tac defl_unfold_thms 1);
-      in
-        Goal.prove_global thy [] [] goal (K tac)
-      end;
-    val DEFL_eq_thms = map mk_DEFL_eq_thm dom_eqns;
-
-    (* register DEFL equations *)
-    val DEFL_eq_binds = map (Binding.prefix_name "DEFL_eq_") dbinds;
-    val (_, thy) = thy |>
-      (Global_Theory.add_thms o map Thm.no_attributes)
-        (DEFL_eq_binds ~~ DEFL_eq_thms);
-
-    (* define rep/abs functions *)
-    fun mk_rep_abs ((tbind, morphs), (lhsT, rhsT)) thy =
-      let
-        val rep_bind = Binding.suffix_name "_rep" tbind;
-        val abs_bind = Binding.suffix_name "_abs" tbind;
-        val ((rep_const, rep_def), thy) =
-            define_const (rep_bind, coerce_const (lhsT, rhsT)) thy;
-        val ((abs_const, abs_def), thy) =
-            define_const (abs_bind, coerce_const (rhsT, lhsT)) thy;
-      in
-        (((rep_const, abs_const), (rep_def, abs_def)), thy)
-      end;
-    val ((rep_abs_consts, rep_abs_defs), thy) = thy
-      |> fold_map mk_rep_abs (dbinds ~~ morphs ~~ dom_eqns)
-      |>> ListPair.unzip;
-
-    (* prove isomorphism and isodefl rules *)
-    fun mk_iso_thms ((tbind, DEFL_eq), (rep_def, abs_def)) thy =
-      let
-        fun make thm =
-            Drule.zero_var_indexes (thm OF [DEFL_eq, abs_def, rep_def]);
-        val rep_iso_thm = make @{thm domain_rep_iso};
-        val abs_iso_thm = make @{thm domain_abs_iso};
-        val isodefl_thm = make @{thm isodefl_abs_rep};
-        val thy = thy
-          |> snd o add_qualified_thm "rep_iso" (tbind, rep_iso_thm)
-          |> snd o add_qualified_thm "abs_iso" (tbind, abs_iso_thm)
-          |> snd o add_qualified_thm "isodefl_abs_rep" (tbind, isodefl_thm);
-      in
-        (((rep_iso_thm, abs_iso_thm), isodefl_thm), thy)
-      end;
-    val ((iso_thms, isodefl_abs_rep_thms), thy) =
-      thy
-      |> fold_map mk_iso_thms (dbinds ~~ DEFL_eq_thms ~~ rep_abs_defs)
-      |>> ListPair.unzip;
-
-    (* collect info about rep/abs *)
-    val iso_infos : Domain_Take_Proofs.iso_info list =
-      let
-        fun mk_info (((lhsT, rhsT), (repC, absC)), (rep_iso, abs_iso)) =
-          {
-            repT = rhsT,
-            absT = lhsT,
-            rep_const = repC,
-            abs_const = absC,
-            rep_inverse = rep_iso,
-            abs_inverse = abs_iso
-          };
-      in
-        map mk_info (dom_eqns ~~ rep_abs_consts ~~ iso_thms)
-      end
-
-    (* definitions and proofs related to map functions *)
-    val (map_info, thy) =
-        define_map_functions (dbinds ~~ iso_infos) thy;
-    val { map_consts, map_apply_thms, map_unfold_thms,
-          deflation_map_thms } = map_info;
-
-    (* prove isodefl rules for map functions *)
-    val isodefl_thm =
-      let
-        fun unprime a = Library.unprefix "'" a;
-        fun mk_d T = Free ("d" ^ unprime (fst (dest_TFree T)), deflT);
-        fun mk_p T = Free ("p" ^ unprime (fst (dest_TFree T)), deflT);
-        fun mk_f T = Free ("f" ^ unprime (fst (dest_TFree T)), T ->> T);
-        fun mk_assm t =
-          case try dest_LIFTDEFL t of
-            SOME T => mk_trp (isodefl_const (mk_upT T) $ mk_u_map (mk_f T) $ mk_p T)
-          | NONE =>
-            let val T = dest_DEFL t
-            in mk_trp (isodefl_const T $ mk_f T $ mk_d T) end;
-        fun mk_goal (map_const, (T, rhsT)) =
-          let
-            val (_, Ts) = dest_Type T;
-            val map_term = list_ccomb (map_const, map mk_f (filter (is_cpo thy) Ts));
-            val defl_term = defl_of_typ thy (Ts ~~ map mk_d Ts) (Ts ~~ map mk_p Ts) T;
-          in isodefl_const T $ map_term $ defl_term end;
-        val assms = (map mk_assm o snd o hd) defl_flagss;
-        val goals = map mk_goal (map_consts ~~ dom_eqns);
-        val goal = mk_trp (foldr1 HOLogic.mk_conj goals);
-        val start_thms =
-          @{thm split_def} :: defl_apply_thms @ map_apply_thms;
-        val adm_rules =
-          @{thms adm_conj adm_isodefl cont2cont_fst cont2cont_snd cont_id};
-        val bottom_rules =
-          @{thms fst_strict snd_strict isodefl_bottom simp_thms};
-        val map_ID_thms = Domain_Take_Proofs.get_map_ID_thms thy;
-        val map_ID_simps = map (fn th => th RS sym) map_ID_thms;
-        val isodefl_rules =
-          @{thms conjI isodefl_ID_DEFL isodefl_LIFTDEFL}
-          @ isodefl_abs_rep_thms
-          @ IsodeflData.get (ProofContext.init_global thy);
-      in
-        Goal.prove_global thy [] assms goal (fn {prems, ...} =>
-         EVERY
-          [simp_tac (HOL_basic_ss addsimps start_thms) 1,
-           (* FIXME: how reliable is unification here? *)
-           (* Maybe I should instantiate the rule. *)
-           rtac @{thm parallel_fix_ind} 1,
-           REPEAT (resolve_tac adm_rules 1),
-           simp_tac (HOL_basic_ss addsimps bottom_rules) 1,
-           simp_tac beta_ss 1,
-           simp_tac (HOL_basic_ss addsimps @{thms fst_conv snd_conv}) 1,
-           simp_tac (HOL_basic_ss addsimps map_ID_simps) 1,
-           REPEAT (etac @{thm conjE} 1),
-           REPEAT (resolve_tac (isodefl_rules @ prems) 1 ORELSE atac 1)])
-      end;
-    val isodefl_binds = map (Binding.prefix_name "isodefl_") dbinds;
-    fun conjuncts [] thm = []
-      | conjuncts (n::[]) thm = [(n, thm)]
-      | conjuncts (n::ns) thm = let
-          val thmL = thm RS @{thm conjunct1};
-          val thmR = thm RS @{thm conjunct2};
-        in (n, thmL):: conjuncts ns thmR end;
-    val (isodefl_thms, thy) = thy |>
-      (Global_Theory.add_thms o map (Thm.no_attributes o apsnd Drule.zero_var_indexes))
-        (conjuncts isodefl_binds isodefl_thm);
-    val thy = fold (Context.theory_map o IsodeflData.add_thm) isodefl_thms thy;
-
-    (* prove map_ID theorems *)
-    fun prove_map_ID_thm
-        (((map_const, (lhsT, _)), DEFL_thm), isodefl_thm) =
-      let
-        val Ts = snd (dest_Type lhsT);
-        fun is_cpo T = Sign.of_sort thy (T, @{sort cpo});
-        val lhs = list_ccomb (map_const, map mk_ID (filter is_cpo Ts));
-        val goal = mk_eqs (lhs, mk_ID lhsT);
-        val tac = EVERY
-          [rtac @{thm isodefl_DEFL_imp_ID} 1,
-           stac DEFL_thm 1,
-           rtac isodefl_thm 1,
-           REPEAT (resolve_tac @{thms isodefl_ID_DEFL isodefl_LIFTDEFL} 1)];
-      in
-        Goal.prove_global thy [] [] goal (K tac)
-      end;
-    val map_ID_binds = map (Binding.suffix_name "_map_ID") dbinds;
-    val map_ID_thms =
-      map prove_map_ID_thm
-        (map_consts ~~ dom_eqns ~~ DEFL_thms ~~ isodefl_thms);
-    val (_, thy) = thy |>
-      (Global_Theory.add_thms o map (rpair [Domain_Take_Proofs.map_ID_add]))
-        (map_ID_binds ~~ map_ID_thms);
-
-    (* definitions and proofs related to take functions *)
-    val (take_info, thy) =
-        Domain_Take_Proofs.define_take_functions
-          (dbinds ~~ iso_infos) thy;
-    val { take_consts, chain_take_thms, take_0_thms, take_Suc_thms, ...} =
-        take_info;
-
-    (* least-upper-bound lemma for take functions *)
-    val lub_take_lemma =
-      let
-        val lhs = mk_tuple (map mk_lub take_consts);
-        fun is_cpo T = Sign.of_sort thy (T, @{sort cpo});
-        fun mk_map_ID (map_const, (lhsT, rhsT)) =
-          list_ccomb (map_const, map mk_ID (filter is_cpo (snd (dest_Type lhsT))));
-        val rhs = mk_tuple (map mk_map_ID (map_consts ~~ dom_eqns));
-        val goal = mk_trp (mk_eq (lhs, rhs));
-        val map_ID_thms = Domain_Take_Proofs.get_map_ID_thms thy;
-        val start_rules =
-            @{thms lub_Pair [symmetric] ch2ch_Pair} @ chain_take_thms
-            @ @{thms pair_collapse split_def}
-            @ map_apply_thms @ map_ID_thms;
-        val rules0 =
-            @{thms iterate_0 Pair_strict} @ take_0_thms;
-        val rules1 =
-            @{thms iterate_Suc Pair_fst_snd_eq fst_conv snd_conv}
-            @ take_Suc_thms;
-        val tac =
-            EVERY
-            [simp_tac (HOL_basic_ss addsimps start_rules) 1,
-             simp_tac (HOL_basic_ss addsimps @{thms fix_def2}) 1,
-             rtac @{thm lub_eq} 1,
-             rtac @{thm nat.induct} 1,
-             simp_tac (HOL_basic_ss addsimps rules0) 1,
-             asm_full_simp_tac (beta_ss addsimps rules1) 1];
-      in
-        Goal.prove_global thy [] [] goal (K tac)
-      end;
-
-    (* prove lub of take equals ID *)
-    fun prove_lub_take (((dbind, take_const), map_ID_thm), (lhsT, rhsT)) thy =
-      let
-        val n = Free ("n", natT);
-        val goal = mk_eqs (mk_lub (lambda n (take_const $ n)), mk_ID lhsT);
-        val tac =
-            EVERY
-            [rtac @{thm trans} 1, rtac map_ID_thm 2,
-             cut_facts_tac [lub_take_lemma] 1,
-             REPEAT (etac @{thm Pair_inject} 1), atac 1];
-        val lub_take_thm = Goal.prove_global thy [] [] goal (K tac);
-      in
-        add_qualified_thm "lub_take" (dbind, lub_take_thm) thy
-      end;
-    val (lub_take_thms, thy) =
-        fold_map prove_lub_take
-          (dbinds ~~ take_consts ~~ map_ID_thms ~~ dom_eqns) thy;
-
-    (* prove additional take theorems *)
-    val (take_info2, thy) =
-        Domain_Take_Proofs.add_lub_take_theorems
-          (dbinds ~~ iso_infos) take_info lub_take_thms thy;
-  in
-    ((iso_infos, take_info2), thy)
-  end;
-
-val domain_isomorphism = gen_domain_isomorphism cert_typ;
-val domain_isomorphism_cmd = snd oo gen_domain_isomorphism read_typ;
-
-(******************************************************************************)
-(******************************** outer syntax ********************************)
-(******************************************************************************)
-
-local
-
-val parse_domain_iso :
-    (string list * binding * mixfix * string * (binding * binding) option)
-      parser =
-  (Parse.type_args -- Parse.binding -- Parse.opt_mixfix -- (Parse.$$$ "=" |-- Parse.typ) --
-    Scan.option (Parse.$$$ "morphisms" |-- Parse.!!! (Parse.binding -- Parse.binding)))
-    >> (fn ((((vs, t), mx), rhs), morphs) => (vs, t, mx, rhs, morphs));
-
-val parse_domain_isos = Parse.and_list1 parse_domain_iso;
-
-in
-
-val _ =
-  Outer_Syntax.command "domain_isomorphism" "define domain isomorphisms (HOLCF)"
-    Keyword.thy_decl
-    (parse_domain_isos >> (Toplevel.theory o domain_isomorphism_cmd));
-
-end;
-
-end;

--- a/src/HOLCF/Tools/Domain/domain_take_proofs.ML	Sat Nov 27 14:34:54 2010 -0800
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,609 +0,0 @@
-(*  Title:      HOLCF/Tools/Domain/domain_take_proofs.ML
-    Author:     Brian Huffman
-
-Defines take functions for the given domain equation
-and proves related theorems.
-*)
-
-signature DOMAIN_TAKE_PROOFS =
-sig
-  type iso_info =
-    {
-      absT : typ,
-      repT : typ,
-      abs_const : term,
-      rep_const : term,
-      abs_inverse : thm,
-      rep_inverse : thm
-    }
-  type take_info =
-    {
-      take_consts : term list,
-      take_defs : thm list,
-      chain_take_thms : thm list,
-      take_0_thms : thm list,
-      take_Suc_thms : thm list,
-      deflation_take_thms : thm list,
-      take_strict_thms : thm list,
-      finite_consts : term list,
-      finite_defs : thm list
-    }
-  type take_induct_info =
-    {
-      take_consts         : term list,
-      take_defs           : thm list,
-      chain_take_thms     : thm list,
-      take_0_thms         : thm list,
-      take_Suc_thms       : thm list,
-      deflation_take_thms : thm list,
-      take_strict_thms    : thm list,
-      finite_consts       : term list,
-      finite_defs         : thm list,
-      lub_take_thms       : thm list,
-      reach_thms          : thm list,
-      take_lemma_thms     : thm list,
-      is_finite           : bool,
-      take_induct_thms    : thm list
-    }
-  val define_take_functions :
-    (binding * iso_info) list -> theory -> take_info * theory
-
-  val add_lub_take_theorems :
-    (binding * iso_info) list -> take_info -> thm list ->
-    theory -> take_induct_info * theory
-
-  val map_of_typ :
-    theory -> (typ * term) list -> typ -> term
-
-  val add_rec_type : (string * bool list) -> theory -> theory
-  val get_rec_tab : theory -> (bool list) Symtab.table
-  val add_deflation_thm : thm -> theory -> theory
-  val get_deflation_thms : theory -> thm list
-  val map_ID_add : attribute
-  val get_map_ID_thms : theory -> thm list
-  val setup : theory -> theory
-end;
-
-structure Domain_Take_Proofs : DOMAIN_TAKE_PROOFS =
-struct
-
-type iso_info =
-  {
-    absT : typ,
-    repT : typ,
-    abs_const : term,
-    rep_const : term,
-    abs_inverse : thm,
-    rep_inverse : thm
-  };
-
-type take_info =
-  { take_consts : term list,
-    take_defs : thm list,
-    chain_take_thms : thm list,
-    take_0_thms : thm list,
-    take_Suc_thms : thm list,
-    deflation_take_thms : thm list,
-    take_strict_thms : thm list,
-    finite_consts : term list,
-    finite_defs : thm list
-  };
-
-type take_induct_info =
-  {
-    take_consts         : term list,
-    take_defs           : thm list,
-    chain_take_thms     : thm list,
-    take_0_thms         : thm list,
-    take_Suc_thms       : thm list,
-    deflation_take_thms : thm list,
-    take_strict_thms    : thm list,
-    finite_consts       : term list,
-    finite_defs         : thm list,
-    lub_take_thms       : thm list,
-    reach_thms          : thm list,
-    take_lemma_thms     : thm list,
-    is_finite           : bool,
-    take_induct_thms    : thm list
-  };
-
-val beta_rules =
-  @{thms beta_cfun cont_id cont_const cont2cont_APP cont2cont_LAM'} @
-  @{thms cont2cont_fst cont2cont_snd cont2cont_Pair};
-
-val beta_ss = HOL_basic_ss addsimps (simp_thms @ beta_rules);
-
-val beta_tac = simp_tac beta_ss;
-
-(******************************************************************************)
-(******************************** theory data *********************************)
-(******************************************************************************)
-
-structure Rec_Data = Theory_Data
-(
-  (* list indicates which type arguments allow indirect recursion *)
-  type T = (bool list) Symtab.table;
-  val empty = Symtab.empty;
-  val extend = I;
-  fun merge data = Symtab.merge (K true) data;
-);
-
-structure DeflMapData = Named_Thms
-(
-  val name = "domain_deflation"
-  val description = "theorems like deflation a ==> deflation (foo_map$a)"
-);
-
-structure Map_Id_Data = Named_Thms
-(
-  val name = "domain_map_ID"
-  val description = "theorems like foo_map$ID = ID"
-);
-
-fun add_rec_type (tname, bs) =
-    Rec_Data.map (Symtab.insert (K true) (tname, bs));
-
-fun add_deflation_thm thm =
-    Context.theory_map (DeflMapData.add_thm thm);
-
-val get_rec_tab = Rec_Data.get;
-fun get_deflation_thms thy = DeflMapData.get (ProofContext.init_global thy);
-
-val map_ID_add = Map_Id_Data.add;
-val get_map_ID_thms = Map_Id_Data.get o ProofContext.init_global;
-
-val setup = DeflMapData.setup #> Map_Id_Data.setup;
-
-(******************************************************************************)
-(************************** building types and terms **************************)
-(******************************************************************************)
-
-open HOLCF_Library;
-
-infixr 6 ->>;
-infix -->>;
-infix 9 `;
-
-fun mapT (T as Type (_, Ts)) =
-    (map (fn T => T ->> T) Ts) -->> (T ->> T)
-  | mapT T = T ->> T;
-
-fun mk_deflation t =
-  Const (@{const_name deflation}, Term.fastype_of t --> boolT) $ t;
-
-fun mk_eqs (t, u) = HOLogic.mk_Trueprop (HOLogic.mk_eq (t, u));
-
-(******************************************************************************)
-(****************************** isomorphism info ******************************)
-(******************************************************************************)
-
-fun deflation_abs_rep (info : iso_info) : thm =
-  let
-    val abs_iso = #abs_inverse info;
-    val rep_iso = #rep_inverse info;
-    val thm = @{thm deflation_abs_rep} OF [abs_iso, rep_iso];
-  in
-    Drule.zero_var_indexes thm
-  end
-
-(******************************************************************************)
-(********************* building map functions over types **********************)
-(******************************************************************************)
-
-fun map_of_typ (thy : theory) (sub : (typ * term) list) (T : typ) : term =
-  let
-    val thms = get_map_ID_thms thy;
-    val rules = map (Thm.concl_of #> HOLogic.dest_Trueprop #> HOLogic.dest_eq) thms;
-    val rules' = map (apfst mk_ID) sub @ map swap rules;
-  in
-    mk_ID T
-    |> Pattern.rewrite_term thy rules' []
-    |> Pattern.rewrite_term thy rules []
-  end;
-
-(******************************************************************************)
-(********************* declaring definitions and theorems *********************)
-(******************************************************************************)
-
-fun add_qualified_def name (dbind, eqn) =
-    yield_singleton (Global_Theory.add_defs false)
-     ((Binding.qualified true name dbind, eqn), []);
-
-fun add_qualified_thm name (dbind, thm) =
-    yield_singleton Global_Theory.add_thms
-      ((Binding.qualified true name dbind, thm), []);
-
-fun add_qualified_simp_thm name (dbind, thm) =
-    yield_singleton Global_Theory.add_thms
-      ((Binding.qualified true name dbind, thm), [Simplifier.simp_add]);
-
-(******************************************************************************)
-(************************** defining take functions ***************************)
-(******************************************************************************)
-
-fun define_take_functions
-    (spec : (binding * iso_info) list)
-    (thy : theory) =
-  let
-
-    (* retrieve components of spec *)
-    val dbinds = map fst spec;
-    val iso_infos = map snd spec;
-    val dom_eqns = map (fn x => (#absT x, #repT x)) iso_infos;
-    val rep_abs_consts = map (fn x => (#rep_const x, #abs_const x)) iso_infos;
-
-    fun mk_projs []      t = []
-      | mk_projs (x::[]) t = [(x, t)]
-      | mk_projs (x::xs) t = (x, mk_fst t) :: mk_projs xs (mk_snd t);
-
-    fun mk_cfcomp2 ((rep_const, abs_const), f) =
-        mk_cfcomp (abs_const, mk_cfcomp (f, rep_const));
-
-    (* define take functional *)
-    val newTs : typ list = map fst dom_eqns;
-    val copy_arg_type = mk_tupleT (map (fn T => T ->> T) newTs);
-    val copy_arg = Free ("f", copy_arg_type);
-    val copy_args = map snd (mk_projs dbinds copy_arg);
-    fun one_copy_rhs (rep_abs, (lhsT, rhsT)) =
-      let
-        val body = map_of_typ thy (newTs ~~ copy_args) rhsT;
-      in
-        mk_cfcomp2 (rep_abs, body)
-      end;
-    val take_functional =
-        big_lambda copy_arg
-          (mk_tuple (map one_copy_rhs (rep_abs_consts ~~ dom_eqns)));
-    val take_rhss =
-      let
-        val n = Free ("n", HOLogic.natT);
-        val rhs = mk_iterate (n, take_functional);
-      in
-        map (lambda n o snd) (mk_projs dbinds rhs)
-      end;
-
-    (* define take constants *)
-    fun define_take_const ((dbind, take_rhs), (lhsT, rhsT)) thy =
-      let
-        val take_type = HOLogic.natT --> lhsT ->> lhsT;
-        val take_bind = Binding.suffix_name "_take" dbind;
-        val (take_const, thy) =
-          Sign.declare_const ((take_bind, take_type), NoSyn) thy;
-        val take_eqn = Logic.mk_equals (take_const, take_rhs);
-        val (take_def_thm, thy) =
-            add_qualified_def "take_def" (dbind, take_eqn) thy;
-      in ((take_const, take_def_thm), thy) end;
-    val ((take_consts, take_defs), thy) = thy
-      |> fold_map define_take_const (dbinds ~~ take_rhss ~~ dom_eqns)
-      |>> ListPair.unzip;
-
-    (* prove chain_take lemmas *)
-    fun prove_chain_take (take_const, dbind) thy =
-      let
-        val goal = mk_trp (mk_chain take_const);
-        val rules = take_defs @ @{thms chain_iterate ch2ch_fst ch2ch_snd};
-        val tac = simp_tac (HOL_basic_ss addsimps rules) 1;
-        val thm = Goal.prove_global thy [] [] goal (K tac);
-      in
-        add_qualified_simp_thm "chain_take" (dbind, thm) thy
-      end;
-    val (chain_take_thms, thy) =
-      fold_map prove_chain_take (take_consts ~~ dbinds) thy;
-
-    (* prove take_0 lemmas *)
-    fun prove_take_0 ((take_const, dbind), (lhsT, rhsT)) thy =
-      let
-        val lhs = take_const $ @{term "0::nat"};
-        val goal = mk_eqs (lhs, mk_bottom (lhsT ->> lhsT));
-        val rules = take_defs @ @{thms iterate_0 fst_strict snd_strict};
-        val tac = simp_tac (HOL_basic_ss addsimps rules) 1;
-        val take_0_thm = Goal.prove_global thy [] [] goal (K tac);
-      in
-        add_qualified_simp_thm "take_0" (dbind, take_0_thm) thy
-      end;
-    val (take_0_thms, thy) =
-      fold_map prove_take_0 (take_consts ~~ dbinds ~~ dom_eqns) thy;
-
-    (* prove take_Suc lemmas *)
-    val n = Free ("n", natT);
-    val take_is = map (fn t => t $ n) take_consts;
-    fun prove_take_Suc
-          (((take_const, rep_abs), dbind), (lhsT, rhsT)) thy =
-      let
-        val lhs = take_const $ (@{term Suc} $ n);
-        val body = map_of_typ thy (newTs ~~ take_is) rhsT;
-        val rhs = mk_cfcomp2 (rep_abs, body);
-        val goal = mk_eqs (lhs, rhs);
-        val simps = @{thms iterate_Suc fst_conv snd_conv}
-        val rules = take_defs @ simps;
-        val tac = simp_tac (beta_ss addsimps rules) 1;
-        val take_Suc_thm = Goal.prove_global thy [] [] goal (K tac);
-      in
-        add_qualified_thm "take_Suc" (dbind, take_Suc_thm) thy
-      end;
-    val (take_Suc_thms, thy) =
-      fold_map prove_take_Suc
-        (take_consts ~~ rep_abs_consts ~~ dbinds ~~ dom_eqns) thy;
-
-    (* prove deflation theorems for take functions *)
-    val deflation_abs_rep_thms = map deflation_abs_rep iso_infos;
-    val deflation_take_thm =
-      let
-        val n = Free ("n", natT);
-        fun mk_goal take_const = mk_deflation (take_const $ n);
-        val goal = mk_trp (foldr1 mk_conj (map mk_goal take_consts));
-        val adm_rules =
-          @{thms adm_conj adm_subst [OF _ adm_deflation]
-                 cont2cont_fst cont2cont_snd cont_id};
-        val bottom_rules =
-          take_0_thms @ @{thms deflation_UU simp_thms};
-        val deflation_rules =
-          @{thms conjI deflation_ID}
-          @ deflation_abs_rep_thms
-          @ get_deflation_thms thy;
-      in
-        Goal.prove_global thy [] [] goal (fn _ =>
-         EVERY
-          [rtac @{thm nat.induct} 1,
-           simp_tac (HOL_basic_ss addsimps bottom_rules) 1,
-           asm_simp_tac (HOL_basic_ss addsimps take_Suc_thms) 1,
-           REPEAT (etac @{thm conjE} 1
-                   ORELSE resolve_tac deflation_rules 1
-                   ORELSE atac 1)])
-      end;
-    fun conjuncts [] thm = []
-      | conjuncts (n::[]) thm = [(n, thm)]
-      | conjuncts (n::ns) thm = let
-          val thmL = thm RS @{thm conjunct1};
-          val thmR = thm RS @{thm conjunct2};
-        in (n, thmL):: conjuncts ns thmR end;
-    val (deflation_take_thms, thy) =
-      fold_map (add_qualified_thm "deflation_take")
-        (map (apsnd Drule.zero_var_indexes)
-          (conjuncts dbinds deflation_take_thm)) thy;
-
-    (* prove strictness of take functions *)
-    fun prove_take_strict (deflation_take, dbind) thy =
-      let
-        val take_strict_thm =
-            Drule.zero_var_indexes
-              (@{thm deflation_strict} OF [deflation_take]);
-      in
-        add_qualified_simp_thm "take_strict" (dbind, take_strict_thm) thy
-      end;
-    val (take_strict_thms, thy) =
-      fold_map prove_take_strict
-        (deflation_take_thms ~~ dbinds) thy;
-
-    (* prove take/take rules *)
-    fun prove_take_take ((chain_take, deflation_take), dbind) thy =
-      let
-        val take_take_thm =
-            Drule.zero_var_indexes
-              (@{thm deflation_chain_min} OF [chain_take, deflation_take]);
-      in
-        add_qualified_thm "take_take" (dbind, take_take_thm) thy
-      end;
-    val (take_take_thms, thy) =
-      fold_map prove_take_take
-        (chain_take_thms ~~ deflation_take_thms ~~ dbinds) thy;
-
-    (* prove take_below rules *)
-    fun prove_take_below (deflation_take, dbind) thy =
-      let
-        val take_below_thm =
-            Drule.zero_var_indexes
-              (@{thm deflation.below} OF [deflation_take]);
-      in
-        add_qualified_thm "take_below" (dbind, take_below_thm) thy
-      end;
-    val (take_below_thms, thy) =
-      fold_map prove_take_below
-        (deflation_take_thms ~~ dbinds) thy;
-
-    (* define finiteness predicates *)
-    fun define_finite_const ((dbind, take_const), (lhsT, rhsT)) thy =
-      let
-        val finite_type = lhsT --> boolT;
-        val finite_bind = Binding.suffix_name "_finite" dbind;
-        val (finite_const, thy) =
-          Sign.declare_const ((finite_bind, finite_type), NoSyn) thy;
-        val x = Free ("x", lhsT);
-        val n = Free ("n", natT);
-        val finite_rhs =
-          lambda x (HOLogic.exists_const natT $
-            (lambda n (mk_eq (mk_capply (take_const $ n, x), x))));
-        val finite_eqn = Logic.mk_equals (finite_const, finite_rhs);
-        val (finite_def_thm, thy) =
-            add_qualified_def "finite_def" (dbind, finite_eqn) thy;
-      in ((finite_const, finite_def_thm), thy) end;
-    val ((finite_consts, finite_defs), thy) = thy
-      |> fold_map define_finite_const (dbinds ~~ take_consts ~~ dom_eqns)
-      |>> ListPair.unzip;
-
-    val result =
-      {
-        take_consts = take_consts,
-        take_defs = take_defs,
-        chain_take_thms = chain_take_thms,
-        take_0_thms = take_0_thms,
-        take_Suc_thms = take_Suc_thms,
-        deflation_take_thms = deflation_take_thms,
-        take_strict_thms = take_strict_thms,
-        finite_consts = finite_consts,
-        finite_defs = finite_defs
-      };
-
-  in
-    (result, thy)
-  end;
-
-fun prove_finite_take_induct
-    (spec : (binding * iso_info) list)
-    (take_info : take_info)
-    (lub_take_thms : thm list)
-    (thy : theory) =
-  let
-    val dbinds = map fst spec;
-    val iso_infos = map snd spec;
-    val absTs = map #absT iso_infos;
-    val {take_consts, ...} = take_info;
-    val {chain_take_thms, take_0_thms, take_Suc_thms, ...} = take_info;
-    val {finite_consts, finite_defs, ...} = take_info;
-
-    val decisive_lemma =
-      let
-        fun iso_locale (info : iso_info) =
-            @{thm iso.intro} OF [#abs_inverse info, #rep_inverse info];
-        val iso_locale_thms = map iso_locale iso_infos;
-        val decisive_abs_rep_thms =
-            map (fn x => @{thm decisive_abs_rep} OF [x]) iso_locale_thms;
-        val n = Free ("n", @{typ nat});
-        fun mk_decisive t =
-            Const (@{const_name decisive}, fastype_of t --> boolT) $ t;
-        fun f take_const = mk_decisive (take_const $ n);
-        val goal = mk_trp (foldr1 mk_conj (map f take_consts));
-        val rules0 = @{thm decisive_bottom} :: take_0_thms;
-        val rules1 =
-            take_Suc_thms @ decisive_abs_rep_thms
-            @ @{thms decisive_ID decisive_ssum_map decisive_sprod_map};
-        val tac = EVERY [
-            rtac @{thm nat.induct} 1,
-            simp_tac (HOL_ss addsimps rules0) 1,
-            asm_simp_tac (HOL_ss addsimps rules1) 1];
-      in Goal.prove_global thy [] [] goal (K tac) end;
-    fun conjuncts 1 thm = [thm]
-      | conjuncts n thm = let
-          val thmL = thm RS @{thm conjunct1};
-          val thmR = thm RS @{thm conjunct2};
-        in thmL :: conjuncts (n-1) thmR end;
-    val decisive_thms = conjuncts (length spec) decisive_lemma;
-
-    fun prove_finite_thm (absT, finite_const) =
-      let
-        val goal = mk_trp (finite_const $ Free ("x", absT));
-        val tac =
-            EVERY [
-            rewrite_goals_tac finite_defs,
-            rtac @{thm lub_ID_finite} 1,
-            resolve_tac chain_take_thms 1,
-            resolve_tac lub_take_thms 1,
-            resolve_tac decisive_thms 1];
-      in
-        Goal.prove_global thy [] [] goal (K tac)
-      end;
-    val finite_thms =
-        map prove_finite_thm (absTs ~~ finite_consts);
-
-    fun prove_take_induct ((ch_take, lub_take), decisive) =
-        Drule.export_without_context
-          (@{thm lub_ID_finite_take_induct} OF [ch_take, lub_take, decisive]);
-    val take_induct_thms =
-        map prove_take_induct
-          (chain_take_thms ~~ lub_take_thms ~~ decisive_thms);
-
-    val thy = thy
-        |> fold (snd oo add_qualified_thm "finite")
-            (dbinds ~~ finite_thms)
-        |> fold (snd oo add_qualified_thm "take_induct")
-            (dbinds ~~ take_induct_thms);
-  in
-    ((finite_thms, take_induct_thms), thy)
-  end;
-
-fun add_lub_take_theorems
-    (spec : (binding * iso_info) list)
-    (take_info : take_info)
-    (lub_take_thms : thm list)
-    (thy : theory) =
-  let
-
-    (* retrieve components of spec *)
-    val dbinds = map fst spec;
-    val iso_infos = map snd spec;
-    val absTs = map #absT iso_infos;
-    val repTs = map #repT iso_infos;
-    val {take_consts, take_0_thms, take_Suc_thms, ...} = take_info;
-    val {chain_take_thms, deflation_take_thms, ...} = take_info;
-
-    (* prove take lemmas *)
-    fun prove_take_lemma ((chain_take, lub_take), dbind) thy =
-      let
-        val take_lemma =
-            Drule.export_without_context
-              (@{thm lub_ID_take_lemma} OF [chain_take, lub_take]);
-      in
-        add_qualified_thm "take_lemma" (dbind, take_lemma) thy
-      end;
-    val (take_lemma_thms, thy) =
-      fold_map prove_take_lemma
-        (chain_take_thms ~~ lub_take_thms ~~ dbinds) thy;
-
-    (* prove reach lemmas *)
-    fun prove_reach_lemma ((chain_take, lub_take), dbind) thy =
-      let
-        val thm =
-            Drule.zero_var_indexes
-              (@{thm lub_ID_reach} OF [chain_take, lub_take]);
-      in
-        add_qualified_thm "reach" (dbind, thm) thy
-      end;
-    val (reach_thms, thy) =
-      fold_map prove_reach_lemma
-        (chain_take_thms ~~ lub_take_thms ~~ dbinds) thy;
-
-    (* test for finiteness of domain definitions *)
-    local
-      val types = [@{type_name ssum}, @{type_name sprod}];
-      fun finite d T = if member (op =) absTs T then d else finite' d T
-      and finite' d (Type (c, Ts)) =
-          let val d' = d andalso member (op =) types c;
-          in forall (finite d') Ts end
-        | finite' d _ = true;
-    in
-      val is_finite = forall (finite true) repTs;
-    end;
-
-    val ((finite_thms, take_induct_thms), thy) =
-      if is_finite
-      then
-        let
-          val ((finites, take_inducts), thy) =
-              prove_finite_take_induct spec take_info lub_take_thms thy;
-        in
-          ((SOME finites, take_inducts), thy)
-        end
-      else
-        let
-          fun prove_take_induct (chain_take, lub_take) =
-              Drule.zero_var_indexes
-                (@{thm lub_ID_take_induct} OF [chain_take, lub_take]);
-          val take_inducts =
-              map prove_take_induct (chain_take_thms ~~ lub_take_thms);
-          val thy = fold (snd oo add_qualified_thm "take_induct")
-                         (dbinds ~~ take_inducts) thy;
-        in
-          ((NONE, take_inducts), thy)
-        end;
-
-    val result =
-      {
-        take_consts         = #take_consts take_info,
-        take_defs           = #take_defs take_info,
-        chain_take_thms     = #chain_take_thms take_info,
-        take_0_thms         = #take_0_thms take_info,
-        take_Suc_thms       = #take_Suc_thms take_info,
-        deflation_take_thms = #deflation_take_thms take_info,
-        take_strict_thms    = #take_strict_thms take_info,
-        finite_consts       = #finite_consts take_info,
-        finite_defs         = #finite_defs take_info,
-        lub_take_thms       = lub_take_thms,
-        reach_thms          = reach_thms,
-        take_lemma_thms     = take_lemma_thms,
-        is_finite           = is_finite,
-        take_induct_thms    = take_induct_thms
-      };
-  in
-    (result, thy)
-  end;
-
-end;

--- a/src/HOLCF/Tools/cont_consts.ML	Sat Nov 27 14:34:54 2010 -0800
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,93 +0,0 @@
-(*  Title:      HOLCF/Tools/cont_consts.ML
-    Author:     Tobias Mayr, David von Oheimb, and Markus Wenzel
-
-HOLCF version of consts: handle continuous function types in mixfix
-syntax.
-*)
-
-signature CONT_CONSTS =
-sig
-  val add_consts: (binding * typ * mixfix) list -> theory -> theory
-  val add_consts_cmd: (binding * string * mixfix) list -> theory -> theory
-end;
-
-structure Cont_Consts: CONT_CONSTS =
-struct
-
-
-(* misc utils *)
-
-fun change_arrow 0 T = T
-  | change_arrow n (Type (_, [S, T])) = Type ("fun", [S, change_arrow (n - 1) T])
-  | change_arrow _ T = raise TYPE ("cont_consts: change_arrow", [T], []);
-
-fun trans_rules name2 name1 n mx =
-  let
-    val vnames = Name.invents Name.context "a" n;
-    val extra_parse_rule = Syntax.ParseRule (Constant name2, Constant name1);
-  in
-    [Syntax.ParsePrintRule
-      (Syntax.mk_appl (Constant name2) (map Variable vnames),
-        fold (fn a => fn t => Syntax.mk_appl (Constant @{const_syntax Rep_cfun}) [t, Variable a])
-          vnames (Constant name1))] @
-    (case mx of
-      Infix _ => [extra_parse_rule]
-    | Infixl _ => [extra_parse_rule]
-    | Infixr _ => [extra_parse_rule]
-    | _ => [])
-  end;
-
-
-(* transforming infix/mixfix declarations of constants with type ...->...
-   a declaration of such a constant is transformed to a normal declaration with
-   an internal name, the same type, and nofix. Additionally, a purely syntactic
-   declaration with the original name, type ...=>..., and the original mixfix
-   is generated and connected to the other declaration via some translation.
-*)
-fun transform thy (c, T, mx) =
-  let
-    fun syntax b = Syntax.mark_const (Sign.full_bname thy b);
-    val c1 = Binding.name_of c;
-    val c2 = c1 ^ "_cont_syntax";
-    val n = Syntax.mixfix_args mx;
-  in
-    ((c, T, NoSyn),
-      (Binding.name c2, change_arrow n T, mx),
-      trans_rules (syntax c2) (syntax c1) n mx)
-  end;
-
-fun cfun_arity (Type (n, [_, T])) = if n = @{type_name cfun} then 1 + cfun_arity T else 0
-  | cfun_arity _ = 0;
-
-fun is_contconst (_, _, NoSyn) = false
-  | is_contconst (_, _, Binder _) = false    (* FIXME ? *)
-  | is_contconst (c, T, mx) =
-      let
-        val n = Syntax.mixfix_args mx handle ERROR msg =>
-          cat_error msg ("in mixfix annotation for " ^ quote (Binding.str_of c));
-      in cfun_arity T >= n end;
-
-
-(* add_consts *)
-
-local
-
-fun gen_add_consts prep_typ raw_decls thy =
-  let
-    val decls = map (fn (c, T, mx) => (c, prep_typ thy T, mx)) raw_decls;
-    val (contconst_decls, normal_decls) = List.partition is_contconst decls;
-    val transformed_decls = map (transform thy) contconst_decls;
-  in
-    thy
-    |> Sign.add_consts_i (normal_decls @ map #1 transformed_decls @ map #2 transformed_decls)
-    |> Sign.add_trrules_i (maps #3 transformed_decls)
-  end;
-
-in
-
-val add_consts = gen_add_consts Sign.certify_typ;
-val add_consts_cmd = gen_add_consts Syntax.read_typ_global;
-
-end;
-
-end;

--- a/src/HOLCF/Tools/cont_proc.ML	Sat Nov 27 14:34:54 2010 -0800
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,136 +0,0 @@
-(*  Title:      HOLCF/Tools/cont_proc.ML
-    Author:     Brian Huffman
-*)
-
-signature CONT_PROC =
-sig
-  val is_lcf_term: term -> bool
-  val cont_thms: term -> thm list
-  val all_cont_thms: term -> thm list
-  val cont_tac: int -> tactic
-  val cont_proc: theory -> simproc
-  val setup: theory -> theory
-end;
-
-structure ContProc :> CONT_PROC =
-struct
-
-(** theory context references **)
-
-val cont_K = @{thm cont_const};
-val cont_I = @{thm cont_id};
-val cont_A = @{thm cont2cont_APP};
-val cont_L = @{thm cont2cont_LAM};
-val cont_R = @{thm cont_Rep_cfun2};
-
-(* checks whether a term contains no dangling bound variables *)
-fun is_closed_term t = not (Term.loose_bvar (t, 0));
-
-(* checks whether a term is written entirely in the LCF sublanguage *)
-fun is_lcf_term (Const (@{const_name Rep_cfun}, _) $ t $ u) =
-      is_lcf_term t andalso is_lcf_term u
-  | is_lcf_term (Const (@{const_name Abs_cfun}, _) $ Abs (_, _, t)) =
-      is_lcf_term t
-  | is_lcf_term (Const (@{const_name Abs_cfun}, _) $ t) =
-      is_lcf_term (Term.incr_boundvars 1 t $ Bound 0)
-  | is_lcf_term (Bound _) = true
-  | is_lcf_term t = is_closed_term t;
-
-(*
-  efficiently generates a cont thm for every LAM abstraction in a term,
-  using forward proof and reusing common subgoals
-*)
-local
-  fun var 0 = [SOME cont_I]
-    | var n = NONE :: var (n-1);
-
-  fun k NONE     = cont_K
-    | k (SOME x) = x;
-
-  fun ap NONE NONE = NONE
-    | ap x    y    = SOME (k y RS (k x RS cont_A));
-
-  fun zip []      []      = []
-    | zip []      (y::ys) = (ap NONE y   ) :: zip [] ys
-    | zip (x::xs) []      = (ap x    NONE) :: zip xs []
-    | zip (x::xs) (y::ys) = (ap x    y   ) :: zip xs ys
-
-  fun lam [] = ([], cont_K)
-    | lam (x::ys) =
-    let
-      (* should use "close_derivation" for thms that are used multiple times *)
-      (* it seems to allow for sharing in explicit proof objects *)
-      val x' = Thm.close_derivation (k x);
-      val Lx = x' RS cont_L;
-    in (map (fn y => SOME (k y RS Lx)) ys, x') end;
-
-  (* first list: cont thm for each dangling bound variable *)
-  (* second list: cont thm for each LAM in t *)
-  (* if b = false, only return cont thm for outermost LAMs *)
-  fun cont_thms1 b (Const (@{const_name Rep_cfun}, _) $ f $ t) =
-    let
-      val (cs1,ls1) = cont_thms1 b f;
-      val (cs2,ls2) = cont_thms1 b t;
-    in (zip cs1 cs2, if b then ls1 @ ls2 else []) end
-    | cont_thms1 b (Const (@{const_name Abs_cfun}, _) $ Abs (_, _, t)) =
-    let
-      val (cs, ls) = cont_thms1 b t;
-      val (cs', l) = lam cs;
-    in (cs', l::ls) end
-    | cont_thms1 b (Const (@{const_name Abs_cfun}, _) $ t) =
-    let
-      val t' = Term.incr_boundvars 1 t $ Bound 0;
-      val (cs, ls) = cont_thms1 b t';
-      val (cs', l) = lam cs;
-    in (cs', l::ls) end
-    | cont_thms1 _ (Bound n) = (var n, [])
-    | cont_thms1 _ _ = ([], []);
-in
-  (* precondition: is_lcf_term t = true *)
-  fun cont_thms t = snd (cont_thms1 false t);
-  fun all_cont_thms t = snd (cont_thms1 true t);
-end;
-
-(*
-  Given the term "cont f", the procedure tries to construct the
-  theorem "cont f == True". If this theorem cannot be completely
-  solved by the introduction rules, then the procedure returns a
-  conditional rewrite rule with the unsolved subgoals as premises.
-*)
-
-val cont_tac =
-  let
-    val rules = [cont_K, cont_I, cont_R, cont_A, cont_L];
-  
-    fun new_cont_tac f' i =
-      case all_cont_thms f' of
-        [] => no_tac
-      | (c::cs) => rtac c i;
-
-    fun cont_tac_of_term (Const (@{const_name cont}, _) $ f) =
-      let
-        val f' = Const (@{const_name Abs_cfun}, dummyT) $ f;
-      in
-        if is_lcf_term f'
-        then new_cont_tac f'
-        else REPEAT_ALL_NEW (resolve_tac rules)
-      end
-      | cont_tac_of_term _ = K no_tac;
-  in
-    SUBGOAL (fn (t, i) =>
-      cont_tac_of_term (HOLogic.dest_Trueprop t) i)
-  end;
-
-local
-  fun solve_cont thy _ t =
-    let
-      val tr = instantiate' [] [SOME (cterm_of thy t)] Eq_TrueI;
-    in Option.map fst (Seq.pull (cont_tac 1 tr)) end
-in
-  fun cont_proc thy =
-    Simplifier.simproc_global thy "cont_proc" ["cont f"] solve_cont;
-end;
-
-fun setup thy = Simplifier.map_simpset (fn ss => ss addsimprocs [cont_proc thy]) thy;
-
-end;

--- a/src/HOLCF/Tools/cpodef.ML	Sat Nov 27 14:34:54 2010 -0800
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,383 +0,0 @@
-(*  Title:      HOLCF/Tools/cpodef.ML
-    Author:     Brian Huffman
-
-Primitive domain definitions for HOLCF, similar to Gordon/HOL-style
-typedef (see also ~~/src/HOL/Tools/typedef.ML).
-*)
-
-signature CPODEF =
-sig
-  type cpo_info =
-    { below_def: thm, adm: thm, cont_Rep: thm, cont_Abs: thm,
-      is_lub: thm, lub: thm, compact: thm }
-  type pcpo_info =
-    { Rep_strict: thm, Abs_strict: thm, Rep_bottom_iff: thm, Abs_bottom_iff: thm,
-      Rep_defined: thm, Abs_defined: thm }
-
-  val add_podef: bool -> binding option -> binding * (string * sort) list * mixfix ->
-    term -> (binding * binding) option -> tactic -> theory ->
-    (Typedef.info * thm) * theory
-  val add_cpodef: bool -> binding option -> binding * (string * sort) list * mixfix ->
-    term -> (binding * binding) option -> tactic * tactic -> theory ->
-    (Typedef.info * cpo_info) * theory
-  val add_pcpodef: bool -> binding option -> binding * (string * sort) list * mixfix ->
-    term -> (binding * binding) option -> tactic * tactic -> theory ->
-    (Typedef.info * cpo_info * pcpo_info) * theory
-
-  val cpodef_proof: (bool * binding)
-    * (binding * (string * sort) list * mixfix) * term
-    * (binding * binding) option -> theory -> Proof.state
-  val cpodef_proof_cmd: (bool * binding)
-    * (binding * (string * string option) list * mixfix) * string
-    * (binding * binding) option -> theory -> Proof.state
-  val pcpodef_proof: (bool * binding)
-    * (binding * (string * sort) list * mixfix) * term
-    * (binding * binding) option -> theory -> Proof.state
-  val pcpodef_proof_cmd: (bool * binding)
-    * (binding * (string * string option) list * mixfix) * string
-    * (binding * binding) option -> theory -> Proof.state
-end;
-
-structure Cpodef :> CPODEF =
-struct
-
-(** type definitions **)
-
-type cpo_info =
-  { below_def: thm, adm: thm, cont_Rep: thm, cont_Abs: thm,
-    is_lub: thm, lub: thm, compact: thm }
-
-type pcpo_info =
-  { Rep_strict: thm, Abs_strict: thm, Rep_bottom_iff: thm, Abs_bottom_iff: thm,
-    Rep_defined: thm, Abs_defined: thm }
-
-(* building terms *)
-
-fun adm_const T = Const (@{const_name adm}, (T --> HOLogic.boolT) --> HOLogic.boolT);
-fun mk_adm (x, T, P) = adm_const T $ absfree (x, T, P);
-
-fun below_const T = Const (@{const_name below}, T --> T --> HOLogic.boolT);
-
-(* manipulating theorems *)
-
-fun fold_adm_mem thm NONE = thm
-  | fold_adm_mem thm (SOME set_def) =
-    let val rule = @{lemma "A == B ==> adm (%x. x : B) ==> adm (%x. x : A)" by simp}
-    in rule OF [set_def, thm] end;
-
-fun fold_UU_mem thm NONE = thm
-  | fold_UU_mem thm (SOME set_def) =
-    let val rule = @{lemma "A == B ==> UU : B ==> UU : A" by simp}
-    in rule OF [set_def, thm] end;
-
-(* proving class instances *)
-
-fun prove_cpo
-      (name: binding)
-      (newT: typ)
-      (Rep_name: binding, Abs_name: binding)
-      (type_definition: thm)  (* type_definition Rep Abs A *)
-      (set_def: thm option)   (* A == set *)
-      (below_def: thm)        (* op << == %x y. Rep x << Rep y *)
-      (admissible: thm)       (* adm (%x. x : set) *)
-      (thy: theory)
-    =
-  let
-    val admissible' = fold_adm_mem admissible set_def;
-    val cpo_thms = map (Thm.transfer thy) [type_definition, below_def, admissible'];
-    val (full_tname, Ts) = dest_Type newT;
-    val lhs_sorts = map (snd o dest_TFree) Ts;
-    val tac = Tactic.rtac (@{thm typedef_cpo} OF cpo_thms) 1;
-    val thy = AxClass.prove_arity (full_tname, lhs_sorts, @{sort cpo}) tac thy;
-    (* transfer thms so that they will know about the new cpo instance *)
-    val cpo_thms' = map (Thm.transfer thy) cpo_thms;
-    fun make thm = Drule.zero_var_indexes (thm OF cpo_thms');
-    val cont_Rep = make @{thm typedef_cont_Rep};
-    val cont_Abs = make @{thm typedef_cont_Abs};
-    val is_lub = make @{thm typedef_is_lub};
-    val lub = make @{thm typedef_lub};
-    val compact = make @{thm typedef_compact};
-    val (_, thy) =
-      thy
-      |> Sign.add_path (Binding.name_of name)
-      |> Global_Theory.add_thms
-        ([((Binding.prefix_name "adm_"      name, admissible'), []),
-          ((Binding.prefix_name "cont_" Rep_name, cont_Rep   ), []),
-          ((Binding.prefix_name "cont_" Abs_name, cont_Abs   ), []),
-          ((Binding.prefix_name "is_lub_"   name, is_lub     ), []),
-          ((Binding.prefix_name "lub_"      name, lub        ), []),
-          ((Binding.prefix_name "compact_"  name, compact    ), [])])
-      ||> Sign.parent_path;
-    val cpo_info : cpo_info =
-      { below_def = below_def, adm = admissible', cont_Rep = cont_Rep,
-        cont_Abs = cont_Abs, is_lub = is_lub, lub = lub, compact = compact };
-  in
-    (cpo_info, thy)
-  end;
-
-fun prove_pcpo
-      (name: binding)
-      (newT: typ)
-      (Rep_name: binding, Abs_name: binding)
-      (type_definition: thm)  (* type_definition Rep Abs A *)
-      (set_def: thm option)   (* A == set *)
-      (below_def: thm)        (* op << == %x y. Rep x << Rep y *)
-      (UU_mem: thm)           (* UU : set *)
-      (thy: theory)
-    =
-  let
-    val UU_mem' = fold_UU_mem UU_mem set_def;
-    val pcpo_thms = map (Thm.transfer thy) [type_definition, below_def, UU_mem'];
-    val (full_tname, Ts) = dest_Type newT;
-    val lhs_sorts = map (snd o dest_TFree) Ts;
-    val tac = Tactic.rtac (@{thm typedef_pcpo} OF pcpo_thms) 1;
-    val thy = AxClass.prove_arity (full_tname, lhs_sorts, @{sort pcpo}) tac thy;
-    val pcpo_thms' = map (Thm.transfer thy) pcpo_thms;
-    fun make thm = Drule.zero_var_indexes (thm OF pcpo_thms');
-    val Rep_strict = make @{thm typedef_Rep_strict};
-    val Abs_strict = make @{thm typedef_Abs_strict};
-    val Rep_bottom_iff = make @{thm typedef_Rep_bottom_iff};
-    val Abs_bottom_iff = make @{thm typedef_Abs_bottom_iff};
-    val Rep_defined = make @{thm typedef_Rep_defined};
-    val Abs_defined = make @{thm typedef_Abs_defined};
-    val (_, thy) =
-      thy
-      |> Sign.add_path (Binding.name_of name)
-      |> Global_Theory.add_thms
-        ([((Binding.suffix_name "_strict"     Rep_name, Rep_strict), []),
-          ((Binding.suffix_name "_strict"     Abs_name, Abs_strict), []),
-          ((Binding.suffix_name "_bottom_iff" Rep_name, Rep_bottom_iff), []),
-          ((Binding.suffix_name "_bottom_iff" Abs_name, Abs_bottom_iff), []),
-          ((Binding.suffix_name "_defined"    Rep_name, Rep_defined), []),
-          ((Binding.suffix_name "_defined"    Abs_name, Abs_defined), [])])
-      ||> Sign.parent_path;
-    val pcpo_info =
-      { Rep_strict = Rep_strict, Abs_strict = Abs_strict,
-        Rep_bottom_iff = Rep_bottom_iff, Abs_bottom_iff = Abs_bottom_iff,
-        Rep_defined = Rep_defined, Abs_defined = Abs_defined };
-  in
-    (pcpo_info, thy)
-  end;
-
-(* prepare_cpodef *)
-
-fun declare_type_name a =
-  Variable.declare_constraints (Logic.mk_type (TFree (a, dummyS)));
-
-fun prepare prep_term name (tname, raw_args, mx) raw_set opt_morphs thy =
-  let
-    val _ = Theory.requires thy "Cpodef" "cpodefs";
-
-    (*rhs*)
-    val tmp_ctxt =
-      ProofContext.init_global thy
-      |> fold (Variable.declare_typ o TFree) raw_args;
-    val set = prep_term tmp_ctxt raw_set;
-    val tmp_ctxt' = tmp_ctxt |> Variable.declare_term set;
-
-    val setT = Term.fastype_of set;
-    val oldT = HOLogic.dest_setT setT handle TYPE _ =>
-      error ("Not a set type: " ^ quote (Syntax.string_of_typ tmp_ctxt setT));
-
-    (*lhs*)
-    val lhs_tfrees = map (ProofContext.check_tfree tmp_ctxt') raw_args;
-    val full_tname = Sign.full_name thy tname;
-    val newT = Type (full_tname, map TFree lhs_tfrees);
-
-    val morphs = opt_morphs
-      |> the_default (Binding.prefix_name "Rep_" name, Binding.prefix_name "Abs_" name);
-  in
-    (newT, oldT, set, morphs)
-  end
-
-fun add_podef def opt_name typ set opt_morphs tac thy =
-  let
-    val name = the_default (#1 typ) opt_name;
-    val ((full_tname, info as ({Rep_name, ...}, {type_definition, set_def, ...})), thy2) = thy
-      |> Typedef.add_typedef_global def opt_name typ set opt_morphs tac;
-    val oldT = #rep_type (#1 info);
-    val newT = #abs_type (#1 info);
-    val lhs_tfrees = map dest_TFree (snd (dest_Type newT));
-
-    val RepC = Const (Rep_name, newT --> oldT);
-    val below_eqn = Logic.mk_equals (below_const newT,
-      Abs ("x", newT, Abs ("y", newT, below_const oldT $ (RepC $ Bound 1) $ (RepC $ Bound 0))));
-    val lthy3 = thy2
-      |> Class.instantiation ([full_tname], lhs_tfrees, @{sort po});
-    val ((_, (_, below_ldef)), lthy4) = lthy3
-      |> Specification.definition (NONE,
-          ((Binding.prefix_name "below_" (Binding.suffix_name "_def" name), []), below_eqn));
-    val ctxt_thy = ProofContext.init_global (ProofContext.theory_of lthy4);
-    val below_def = singleton (ProofContext.export lthy4 ctxt_thy) below_ldef;
-    val thy5 = lthy4
-      |> Class.prove_instantiation_instance
-          (K (Tactic.rtac (@{thm typedef_po} OF [type_definition, below_def]) 1))
-      |> Local_Theory.exit_global;
-  in ((info, below_def), thy5) end;
-
-fun prepare_cpodef
-      (prep_term: Proof.context -> 'a -> term)
-      (def: bool)
-      (name: binding)
-      (typ: binding * (string * sort) list * mixfix)
-      (raw_set: 'a)
-      (opt_morphs: (binding * binding) option)
-      (thy: theory)
-    : term * term * (thm -> thm -> theory -> (Typedef.info * cpo_info) * theory) =
-  let
-    val (newT, oldT, set, morphs as (Rep_name, Abs_name)) =
-      prepare prep_term name typ raw_set opt_morphs thy;
-
-    val goal_nonempty =
-      HOLogic.mk_Trueprop (HOLogic.mk_exists ("x", oldT, HOLogic.mk_mem (Free ("x", oldT), set)));
-    val goal_admissible =
-      HOLogic.mk_Trueprop (mk_adm ("x", oldT, HOLogic.mk_mem (Free ("x", oldT), set)));
-
-    fun cpodef_result nonempty admissible thy =
-      let
-        val ((info as (_, {type_definition, set_def, ...}), below_def), thy2) = thy
-          |> add_podef def (SOME name) typ set opt_morphs (Tactic.rtac nonempty 1);
-        val (cpo_info, thy3) = thy2
-          |> prove_cpo name newT morphs type_definition set_def below_def admissible;
-      in
-        ((info, cpo_info), thy3)
-      end;
-  in
-    (goal_nonempty, goal_admissible, cpodef_result)
-  end
-  handle ERROR msg =>
-    cat_error msg ("The error(s) above occurred in cpodef " ^ quote (Binding.str_of name));
-
-fun prepare_pcpodef
-      (prep_term: Proof.context -> 'a -> term)
-      (def: bool)
-      (name: binding)
-      (typ: binding * (string * sort) list * mixfix)
-      (raw_set: 'a)
-      (opt_morphs: (binding * binding) option)
-      (thy: theory)
-    : term * term * (thm -> thm -> theory -> (Typedef.info * cpo_info * pcpo_info) * theory) =
-  let
-    val (newT, oldT, set, morphs as (Rep_name, Abs_name)) =
-      prepare prep_term name typ raw_set opt_morphs thy;
-
-    val goal_UU_mem =
-      HOLogic.mk_Trueprop (HOLogic.mk_mem (Const (@{const_name UU}, oldT), set));
-
-    val goal_admissible =
-      HOLogic.mk_Trueprop (mk_adm ("x", oldT, HOLogic.mk_mem (Free ("x", oldT), set)));
-
-    fun pcpodef_result UU_mem admissible thy =
-      let
-        val tac = Tactic.rtac exI 1 THEN Tactic.rtac UU_mem 1;
-        val ((info as (_, {type_definition, set_def, ...}), below_def), thy2) = thy
-          |> add_podef def (SOME name) typ set opt_morphs tac;
-        val (cpo_info, thy3) = thy2
-          |> prove_cpo name newT morphs type_definition set_def below_def admissible;
-        val (pcpo_info, thy4) = thy3
-          |> prove_pcpo name newT morphs type_definition set_def below_def UU_mem;
-      in
-        ((info, cpo_info, pcpo_info), thy4)
-      end;
-  in
-    (goal_UU_mem, goal_admissible, pcpodef_result)
-  end
-  handle ERROR msg =>
-    cat_error msg ("The error(s) above occurred in pcpodef " ^ quote (Binding.str_of name));
-
-
-(* tactic interface *)
-
-fun add_cpodef def opt_name typ set opt_morphs (tac1, tac2) thy =
-  let
-    val name = the_default (#1 typ) opt_name;
-    val (goal1, goal2, cpodef_result) =
-      prepare_cpodef Syntax.check_term def name typ set opt_morphs thy;
-    val thm1 = Goal.prove_global thy [] [] goal1 (K tac1)
-      handle ERROR msg => cat_error msg
-        ("Failed to prove non-emptiness of " ^ quote (Syntax.string_of_term_global thy set));
-    val thm2 = Goal.prove_global thy [] [] goal2 (K tac2)
-      handle ERROR msg => cat_error msg
-        ("Failed to prove admissibility of " ^ quote (Syntax.string_of_term_global thy set));
-  in cpodef_result thm1 thm2 thy end;
-
-fun add_pcpodef def opt_name typ set opt_morphs (tac1, tac2) thy =
-  let
-    val name = the_default (#1 typ) opt_name;
-    val (goal1, goal2, pcpodef_result) =
-      prepare_pcpodef Syntax.check_term def name typ set opt_morphs thy;
-    val thm1 = Goal.prove_global thy [] [] goal1 (K tac1)
-      handle ERROR msg => cat_error msg
-        ("Failed to prove non-emptiness of " ^ quote (Syntax.string_of_term_global thy set));
-    val thm2 = Goal.prove_global thy [] [] goal2 (K tac2)
-      handle ERROR msg => cat_error msg
-        ("Failed to prove admissibility of " ^ quote (Syntax.string_of_term_global thy set));
-  in pcpodef_result thm1 thm2 thy end;
-
-
-(* proof interface *)
-
-local
-
-fun gen_cpodef_proof prep_term prep_constraint
-    ((def, name), (b, raw_args, mx), set, opt_morphs) thy =
-  let
-    val ctxt = ProofContext.init_global thy;
-    val args = map (apsnd (prep_constraint ctxt)) raw_args;
-    val (goal1, goal2, make_result) =
-      prepare_cpodef prep_term def name (b, args, mx) set opt_morphs thy;
-    fun after_qed [[th1, th2]] = ProofContext.background_theory (snd o make_result th1 th2)
-      | after_qed _ = raise Fail "cpodef_proof";
-  in Proof.theorem NONE after_qed [[(goal1, []), (goal2, [])]] ctxt end;
-
-fun gen_pcpodef_proof prep_term prep_constraint
-    ((def, name), (b, raw_args, mx), set, opt_morphs) thy =
-  let
-    val ctxt = ProofContext.init_global thy;
-    val args = map (apsnd (prep_constraint ctxt)) raw_args;
-    val (goal1, goal2, make_result) =
-      prepare_pcpodef prep_term def name (b, args, mx) set opt_morphs thy;
-    fun after_qed [[th1, th2]] = ProofContext.background_theory (snd o make_result th1 th2)
-      | after_qed _ = raise Fail "pcpodef_proof";
-  in Proof.theorem NONE after_qed [[(goal1, []), (goal2, [])]] ctxt end;
-
-in
-
-fun cpodef_proof x = gen_cpodef_proof Syntax.check_term (K I) x;
-fun cpodef_proof_cmd x = gen_cpodef_proof Syntax.read_term Typedecl.read_constraint x;
-
-fun pcpodef_proof x = gen_pcpodef_proof Syntax.check_term (K I) x;
-fun pcpodef_proof_cmd x = gen_pcpodef_proof Syntax.read_term Typedecl.read_constraint x;
-
-end;
-
-
-
-(** outer syntax **)
-
-val typedef_proof_decl =
-  Scan.optional (Parse.$$$ "(" |--
-      ((Parse.$$$ "open" >> K false) -- Scan.option Parse.binding ||
-        Parse.binding >> (fn s => (true, SOME s)))
-        --| Parse.$$$ ")") (true, NONE) --
-    (Parse.type_args_constrained -- Parse.binding) -- Parse.opt_mixfix --
-    (Parse.$$$ "=" |-- Parse.term) --
-    Scan.option (Parse.$$$ "morphisms" |-- Parse.!!! (Parse.binding -- Parse.binding));
-
-fun mk_pcpodef_proof pcpo ((((((def, opt_name), (args, t)), mx), A), morphs)) =
-  (if pcpo then pcpodef_proof_cmd else cpodef_proof_cmd)
-    ((def, the_default t opt_name), (t, args, mx), A, morphs);
-
-val _ =
-  Outer_Syntax.command "pcpodef" "HOLCF type definition (requires admissibility proof)"
-  Keyword.thy_goal
-    (typedef_proof_decl >>
-      (Toplevel.print oo (Toplevel.theory_to_proof o mk_pcpodef_proof true)));
-
-val _ =
-  Outer_Syntax.command "cpodef" "HOLCF type definition (requires admissibility proof)"
-  Keyword.thy_goal
-    (typedef_proof_decl >>
-      (Toplevel.print oo (Toplevel.theory_to_proof o mk_pcpodef_proof false)));
-
-end;

--- a/src/HOLCF/Tools/domaindef.ML	Sat Nov 27 14:34:54 2010 -0800
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,236 +0,0 @@
-(*  Title:      HOLCF/Tools/repdef.ML
-    Author:     Brian Huffman
-
-Defining representable domains using algebraic deflations.
-*)
-
-signature DOMAINDEF =
-sig
-  type rep_info =
-    {
-      emb_def : thm,
-      prj_def : thm,
-      defl_def : thm,
-      liftemb_def : thm,
-      liftprj_def : thm,
-      liftdefl_def : thm,
-      DEFL : thm
-    }
-
-  val add_domaindef: bool -> binding option -> binding * (string * sort) list * mixfix ->
-    term -> (binding * binding) option -> theory ->
-    (Typedef.info * Cpodef.cpo_info * Cpodef.pcpo_info * rep_info) * theory
-
-  val domaindef_cmd: (bool * binding) * (binding * (string * string option) list * mixfix) * string
-    * (binding * binding) option -> theory -> theory
-end;
-
-structure Domaindef :> DOMAINDEF =
-struct
-
-open HOLCF_Library;
-
-infixr 6 ->>;
-infix -->>;
-
-(** type definitions **)
-
-type rep_info =
-  {
-    emb_def : thm,
-    prj_def : thm,
-    defl_def : thm,
-    liftemb_def : thm,
-    liftprj_def : thm,
-    liftdefl_def : thm,
-    DEFL : thm
-  };
-
-(* building types and terms *)
-
-val udomT = @{typ udom};
-val deflT = @{typ defl};
-fun emb_const T = Const (@{const_name emb}, T ->> udomT);
-fun prj_const T = Const (@{const_name prj}, udomT ->> T);
-fun defl_const T = Const (@{const_name defl}, Term.itselfT T --> deflT);
-fun liftemb_const T = Const (@{const_name liftemb}, mk_upT T ->> udomT);
-fun liftprj_const T = Const (@{const_name liftprj}, udomT ->> mk_upT T);
-fun liftdefl_const T = Const (@{const_name liftdefl}, Term.itselfT T --> deflT);
-
-fun mk_u_map t =
-  let
-    val (T, U) = dest_cfunT (fastype_of t);
-    val u_map_type = (T ->> U) ->> (mk_upT T ->> mk_upT U);
-    val u_map_const = Const (@{const_name u_map}, u_map_type);
-  in
-    mk_capply (u_map_const, t)
-  end;
-
-fun mk_cast (t, x) =
-  capply_const (udomT, udomT)
-  $ (capply_const (deflT, udomT ->> udomT) $ @{const cast} $ t)
-  $ x;
-
-(* manipulating theorems *)
-
-(* proving class instances *)
-
-fun declare_type_name a =
-  Variable.declare_constraints (Logic.mk_type (TFree (a, dummyS)));
-
-fun gen_add_domaindef
-      (prep_term: Proof.context -> 'a -> term)
-      (def: bool)
-      (name: binding)
-      (typ as (tname, raw_args, mx) : binding * (string * sort) list * mixfix)
-      (raw_defl: 'a)
-      (opt_morphs: (binding * binding) option)
-      (thy: theory)
-    : (Typedef.info * Cpodef.cpo_info * Cpodef.pcpo_info * rep_info) * theory =
-  let
-    val _ = Theory.requires thy "Domain" "domaindefs";
-
-    (*rhs*)
-    val tmp_ctxt =
-      ProofContext.init_global thy
-      |> fold (Variable.declare_typ o TFree) raw_args;
-    val defl = prep_term tmp_ctxt raw_defl;
-    val tmp_ctxt = tmp_ctxt |> Variable.declare_constraints defl;
-
-    val deflT = Term.fastype_of defl;
-    val _ = if deflT = @{typ "defl"} then ()
-            else error ("Not type defl: " ^ quote (Syntax.string_of_typ tmp_ctxt deflT));
-
-    (*lhs*)
-    val lhs_tfrees = map (ProofContext.check_tfree tmp_ctxt) raw_args;
-    val lhs_sorts = map snd lhs_tfrees;
-    val full_tname = Sign.full_name thy tname;
-    val newT = Type (full_tname, map TFree lhs_tfrees);
-
-    (*morphisms*)
-    val morphs = opt_morphs
-      |> the_default (Binding.prefix_name "Rep_" name, Binding.prefix_name "Abs_" name);
-
-    (*set*)
-    val set = @{const defl_set} $ defl;
-
-    (*pcpodef*)
-    val tac1 = rtac @{thm defl_set_bottom} 1;
-    val tac2 = rtac @{thm adm_defl_set} 1;
-    val ((info, cpo_info, pcpo_info), thy) = thy
-      |> Cpodef.add_pcpodef def (SOME name) typ set (SOME morphs) (tac1, tac2);
-
-    (*definitions*)
-    val Rep_const = Const (#Rep_name (#1 info), newT --> udomT);
-    val Abs_const = Const (#Abs_name (#1 info), udomT --> newT);
-    val emb_eqn = Logic.mk_equals (emb_const newT, cabs_const (newT, udomT) $ Rep_const);
-    val prj_eqn = Logic.mk_equals (prj_const newT, cabs_const (udomT, newT) $
-      Abs ("x", udomT, Abs_const $ mk_cast (defl, Bound 0)));
-    val defl_eqn = Logic.mk_equals (defl_const newT,
-      Abs ("x", Term.itselfT newT, defl));
-    val liftemb_eqn =
-      Logic.mk_equals (liftemb_const newT,
-      mk_cfcomp (@{term "udom_emb u_approx"}, mk_u_map (emb_const newT)));
-    val liftprj_eqn =
-      Logic.mk_equals (liftprj_const newT,
-      mk_cfcomp (mk_u_map (prj_const newT), @{term "udom_prj u_approx"}));
-    val liftdefl_eqn =
-      Logic.mk_equals (liftdefl_const newT,
-        Abs ("t", Term.itselfT newT,
-          mk_capply (@{const u_defl}, defl_const newT $ Logic.mk_type newT)));
-
-    val name_def = Binding.suffix_name "_def" name;
-    val emb_bind = (Binding.prefix_name "emb_" name_def, []);
-    val prj_bind = (Binding.prefix_name "prj_" name_def, []);
-    val defl_bind = (Binding.prefix_name "defl_" name_def, []);
-    val liftemb_bind = (Binding.prefix_name "liftemb_" name_def, []);
-    val liftprj_bind = (Binding.prefix_name "liftprj_" name_def, []);
-    val liftdefl_bind = (Binding.prefix_name "liftdefl_" name_def, []);
-
-    (*instantiate class rep*)
-    val lthy = thy
-      |> Class.instantiation ([full_tname], lhs_tfrees, @{sort liftdomain});
-    val ((_, (_, emb_ldef)), lthy) =
-        Specification.definition (NONE, (emb_bind, emb_eqn)) lthy;
-    val ((_, (_, prj_ldef)), lthy) =
-        Specification.definition (NONE, (prj_bind, prj_eqn)) lthy;
-    val ((_, (_, defl_ldef)), lthy) =
-        Specification.definition (NONE, (defl_bind, defl_eqn)) lthy;
-    val ((_, (_, liftemb_ldef)), lthy) =
-        Specification.definition (NONE, (liftemb_bind, liftemb_eqn)) lthy;
-    val ((_, (_, liftprj_ldef)), lthy) =
-        Specification.definition (NONE, (liftprj_bind, liftprj_eqn)) lthy;
-    val ((_, (_, liftdefl_ldef)), lthy) =
-        Specification.definition (NONE, (liftdefl_bind, liftdefl_eqn)) lthy;
-    val ctxt_thy = ProofContext.init_global (ProofContext.theory_of lthy);
-    val emb_def = singleton (ProofContext.export lthy ctxt_thy) emb_ldef;
-    val prj_def = singleton (ProofContext.export lthy ctxt_thy) prj_ldef;
-    val defl_def = singleton (ProofContext.export lthy ctxt_thy) defl_ldef;
-    val liftemb_def = singleton (ProofContext.export lthy ctxt_thy) liftemb_ldef;
-    val liftprj_def = singleton (ProofContext.export lthy ctxt_thy) liftprj_ldef;
-    val liftdefl_def = singleton (ProofContext.export lthy ctxt_thy) liftdefl_ldef;
-    val type_definition_thm =
-      MetaSimplifier.rewrite_rule
-        (the_list (#set_def (#2 info)))
-        (#type_definition (#2 info));
-    val typedef_thms =
-      [type_definition_thm, #below_def cpo_info, emb_def, prj_def, defl_def,
-      liftemb_def, liftprj_def, liftdefl_def];
-    val thy = lthy
-      |> Class.prove_instantiation_instance
-          (K (Tactic.rtac (@{thm typedef_liftdomain_class} OF typedef_thms) 1))
-      |> Local_Theory.exit_global;
-
-    (*other theorems*)
-    val defl_thm' = Thm.transfer thy defl_def;
-    val (DEFL_thm, thy) = thy
-      |> Sign.add_path (Binding.name_of name)
-      |> Global_Theory.add_thm
-         ((Binding.prefix_name "DEFL_" name,
-          Drule.zero_var_indexes (@{thm typedef_DEFL} OF [defl_thm'])), [])
-      ||> Sign.restore_naming thy;
-
-    val rep_info =
-      { emb_def = emb_def, prj_def = prj_def, defl_def = defl_def,
-        liftemb_def = liftemb_def, liftprj_def = liftprj_def,
-        liftdefl_def = liftdefl_def, DEFL = DEFL_thm };
-  in
-    ((info, cpo_info, pcpo_info, rep_info), thy)
-  end
-  handle ERROR msg =>
-    cat_error msg ("The error(s) above occurred in domaindef " ^ quote (Binding.str_of name));
-
-fun add_domaindef def opt_name typ defl opt_morphs thy =
-  let
-    val name = the_default (#1 typ) opt_name;
-  in
-    gen_add_domaindef Syntax.check_term def name typ defl opt_morphs thy
-  end;
-
-fun domaindef_cmd ((def, name), (b, raw_args, mx), A, morphs) thy =
-  let
-    val ctxt = ProofContext.init_global thy;
-    val args = map (apsnd (Typedecl.read_constraint ctxt)) raw_args;
-  in snd (gen_add_domaindef Syntax.read_term def name (b, args, mx) A morphs thy) end;
-
-
-(** outer syntax **)
-
-val domaindef_decl =
-  Scan.optional (Parse.$$$ "(" |--
-      ((Parse.$$$ "open" >> K false) -- Scan.option Parse.binding ||
-        Parse.binding >> (fn s => (true, SOME s)))
-        --| Parse.$$$ ")") (true, NONE) --
-    (Parse.type_args_constrained -- Parse.binding) --
-    Parse.opt_mixfix -- (Parse.$$$ "=" |-- Parse.term) --
-    Scan.option (Parse.$$$ "morphisms" |-- Parse.!!! (Parse.binding -- Parse.binding));
-
-fun mk_domaindef ((((((def, opt_name), (args, t)), mx), A), morphs)) =
-  domaindef_cmd ((def, the_default t opt_name), (t, args, mx), A, morphs);
-
-val _ =
-  Outer_Syntax.command "domaindef" "HOLCF definition of domains from deflations" Keyword.thy_decl
-    (domaindef_decl >>
-      (Toplevel.print oo (Toplevel.theory o mk_domaindef)));
-
-end;

--- a/src/HOLCF/Tools/fixrec.ML	Sat Nov 27 14:34:54 2010 -0800
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,417 +0,0 @@
-(*  Title:      HOLCF/Tools/fixrec.ML
-    Author:     Amber Telfer and Brian Huffman
-
-Recursive function definition package for HOLCF.
-*)
-
-signature FIXREC =
-sig
-  val add_fixrec: (binding * typ option * mixfix) list
-    -> (bool * (Attrib.binding * term)) list -> local_theory -> local_theory
-  val add_fixrec_cmd: (binding * string option * mixfix) list
-    -> (bool * (Attrib.binding * string)) list -> local_theory -> local_theory
-  val add_matchers: (string * string) list -> theory -> theory
-  val fixrec_simp_tac: Proof.context -> int -> tactic
-  val setup: theory -> theory
-end;
-
-structure Fixrec :> FIXREC =
-struct
-
-open HOLCF_Library;
-
-infixr 6 ->>;
-infix -->>;
-infix 9 `;
-
-val def_cont_fix_eq = @{thm def_cont_fix_eq};
-val def_cont_fix_ind = @{thm def_cont_fix_ind};
-
-fun fixrec_err s = error ("fixrec definition error:\n" ^ s);
-fun fixrec_eq_err thy s eq =
-  fixrec_err (s ^ "\nin\n" ^ quote (Syntax.string_of_term_global thy eq));
-
-(*************************************************************************)
-(***************************** building types ****************************)
-(*************************************************************************)
-
-local
-
-fun binder_cfun (Type(@{type_name cfun},[T, U])) = T :: binder_cfun U
-  | binder_cfun (Type(@{type_name "fun"},[T, U])) = T :: binder_cfun U
-  | binder_cfun _   =  [];
-
-fun body_cfun (Type(@{type_name cfun},[T, U])) = body_cfun U
-  | body_cfun (Type(@{type_name "fun"},[T, U])) = body_cfun U
-  | body_cfun T   =  T;
-
-fun strip_cfun T : typ list * typ =
-  (binder_cfun T, body_cfun T);
-
-in
-
-fun matcherT (T, U) =
-  body_cfun T ->> (binder_cfun T -->> U) ->> U;
-
-end
-
-(*************************************************************************)
-(***************************** building terms ****************************)
-(*************************************************************************)
-
-val mk_trp = HOLogic.mk_Trueprop;
-
-(* splits a cterm into the right and lefthand sides of equality *)
-fun dest_eqs t = HOLogic.dest_eq (HOLogic.dest_Trueprop t);
-
-(* similar to Thm.head_of, but for continuous application *)
-fun chead_of (Const(@{const_name Rep_cfun},_)$f$t) = chead_of f
-  | chead_of u = u;
-
-infix 0 ==;  val (op ==) = Logic.mk_equals;
-infix 1 ===; val (op ===) = HOLogic.mk_eq;
-
-fun mk_mplus (t, u) =
-  let val mT = Term.fastype_of t
-  in Const(@{const_name Fixrec.mplus}, mT ->> mT ->> mT) ` t ` u end;
-
-fun mk_run t =
-  let
-    val mT = Term.fastype_of t
-    val T = dest_matchT mT
-    val run = Const(@{const_name Fixrec.run}, mT ->> T)
-  in
-    case t of
-      Const(@{const_name Rep_cfun}, _) $
-        Const(@{const_name Fixrec.succeed}, _) $ u => u
-    | _ => run ` t
-  end;
-
-
-(*************************************************************************)
-(************* fixed-point definitions and unfolding theorems ************)
-(*************************************************************************)
-
-structure FixrecUnfoldData = Generic_Data
-(
-  type T = thm Symtab.table;
-  val empty = Symtab.empty;
-  val extend = I;
-  fun merge data : T = Symtab.merge (K true) data;
-);
-
-local
-
-fun name_of (Const (n, T)) = n
-  | name_of (Free (n, T)) = n
-  | name_of t = raise TERM ("Fixrec.add_unfold: lhs not a constant", [t]);
-
-val lhs_name =
-  name_of o head_of o fst o HOLogic.dest_eq o HOLogic.dest_Trueprop o prop_of;
-
-in
-
-val add_unfold : attribute =
-  Thm.declaration_attribute
-    (fn th => FixrecUnfoldData.map (Symtab.insert (K true) (lhs_name th, th)));
-
-end
-
-fun add_fixdefs
-  (fixes : ((binding * typ) * mixfix) list)
-  (spec : (Attrib.binding * term) list)
-  (lthy : local_theory) =
-  let
-    val thy = ProofContext.theory_of lthy;
-    val names = map (Binding.name_of o fst o fst) fixes;
-    val all_names = space_implode "_" names;
-    val (lhss, rhss) = ListPair.unzip (map (dest_eqs o snd) spec);
-    val functional = lambda_tuple lhss (mk_tuple rhss);
-    val fixpoint = mk_fix (mk_cabs functional);
-
-    val cont_thm =
-      let
-        val prop = mk_trp (mk_cont functional);
-        fun err _ = error (
-          "Continuity proof failed; please check that cont2cont rules\n" ^
-          "or simp rules are configured for all non-HOLCF constants.\n" ^
-          "The error occurred for the goal statement:\n" ^
-          Syntax.string_of_term lthy prop);
-        val rules = Cont2ContData.get lthy;
-        val fast_tac = SOLVED' (REPEAT_ALL_NEW (match_tac rules));
-        val slow_tac = SOLVED' (simp_tac (simpset_of lthy));
-        val tac = fast_tac 1 ORELSE slow_tac 1 ORELSE err;
-      in
-        Goal.prove lthy [] [] prop (K tac)
-      end;
-
-    fun one_def (l as Free(n,_)) r =
-          let val b = Long_Name.base_name n
-          in ((Binding.name (b^"_def"), []), r) end
-      | one_def _ _ = fixrec_err "fixdefs: lhs not of correct form";
-    fun defs [] _ = []
-      | defs (l::[]) r = [one_def l r]
-      | defs (l::ls) r = one_def l (mk_fst r) :: defs ls (mk_snd r);
-    val fixdefs = defs lhss fixpoint;
-    val (fixdef_thms : (term * (string * thm)) list, lthy) = lthy
-      |> fold_map Local_Theory.define (map (apfst fst) fixes ~~ fixdefs);
-    fun pair_equalI (thm1, thm2) = @{thm Pair_equalI} OF [thm1, thm2];
-    val tuple_fixdef_thm = foldr1 pair_equalI (map (snd o snd) fixdef_thms);
-    val P = Var (("P", 0), map Term.fastype_of lhss ---> HOLogic.boolT);
-    val predicate = lambda_tuple lhss (list_comb (P, lhss));
-    val tuple_induct_thm = (def_cont_fix_ind OF [tuple_fixdef_thm, cont_thm])
-      |> Drule.instantiate' [] [SOME (Thm.cterm_of thy predicate)]
-      |> Local_Defs.unfold lthy @{thms split_paired_all split_conv split_strict};
-    val tuple_unfold_thm = (def_cont_fix_eq OF [tuple_fixdef_thm, cont_thm])
-      |> Local_Defs.unfold lthy @{thms split_conv};
-    fun unfolds [] thm = []
-      | unfolds (n::[]) thm = [(n, thm)]
-      | unfolds (n::ns) thm = let
-          val thmL = thm RS @{thm Pair_eqD1};
-          val thmR = thm RS @{thm Pair_eqD2};
-        in (n, thmL) :: unfolds ns thmR end;
-    val unfold_thms = unfolds names tuple_unfold_thm;
-    val induct_note : Attrib.binding * Thm.thm list =
-      let
-        val thm_name = Binding.qualify true all_names (Binding.name "induct");
-      in
-        ((thm_name, []), [tuple_induct_thm])
-      end;
-    fun unfold_note (name, thm) : Attrib.binding * Thm.thm list =
-      let
-        val thm_name = Binding.qualify true name (Binding.name "unfold");
-        val src = Attrib.internal (K add_unfold);
-      in
-        ((thm_name, [src]), [thm])
-      end;
-    val (thmss, lthy) = lthy
-      |> fold_map Local_Theory.note (induct_note :: map unfold_note unfold_thms);
-  in
-    (lthy, names, fixdef_thms, map snd unfold_thms)
-  end;
-
-(*************************************************************************)
-(*********** monadic notation and pattern matching compilation ***********)
-(*************************************************************************)
-
-structure FixrecMatchData = Theory_Data
-(
-  type T = string Symtab.table;
-  val empty = Symtab.empty;
-  val extend = I;
-  fun merge data = Symtab.merge (K true) data;
-);
-
-(* associate match functions with pattern constants *)
-fun add_matchers ms = FixrecMatchData.map (fold Symtab.update ms);
-
-fun taken_names (t : term) : bstring list =
-  let
-    fun taken (Const(a,_), bs) = insert (op =) (Long_Name.base_name a) bs
-      | taken (Free(a,_) , bs) = insert (op =) a bs
-      | taken (f $ u     , bs) = taken (f, taken (u, bs))
-      | taken (Abs(a,_,t), bs) = taken (t, insert (op =) a bs)
-      | taken (_         , bs) = bs;
-  in
-    taken (t, [])
-  end;
-
-(* builds a monadic term for matching a pattern *)
-(* returns (rhs, free variable, used varnames) *)
-fun compile_pat match_name pat rhs taken =
-  let
-    fun comp_pat p rhs taken =
-      if is_Free p then (rhs, p, taken)
-      else comp_con (fastype_of p) p rhs [] taken
-    (* compiles a monadic term for a constructor pattern *)
-    and comp_con T p rhs vs taken =
-      case p of
-        Const(@{const_name Rep_cfun},_) $ f $ x =>
-          let val (rhs', v, taken') = comp_pat x rhs taken
-          in comp_con T f rhs' (v::vs) taken' end
-      | f $ x =>
-          let val (rhs', v, taken') = comp_pat x rhs taken
-          in comp_con T f rhs' (v::vs) taken' end
-      | Const (c, cT) =>
-          let
-            val n = Name.variant taken "v"
-            val v = Free(n, T)
-            val m = Const(match_name c, matcherT (cT, fastype_of rhs))
-            val k = big_lambdas vs rhs
-          in
-            (m`v`k, v, n::taken)
-          end
-      | _ => raise TERM ("fixrec: invalid pattern ", [p])
-  in
-    comp_pat pat rhs taken
-  end;
-
-(* builds a monadic term for matching a function definition pattern *)
-(* returns (constant, (vars, matcher)) *)
-fun compile_lhs match_name pat rhs vs taken =
-  case pat of
-    Const(@{const_name Rep_cfun}, _) $ f $ x =>
-      let val (rhs', v, taken') = compile_pat match_name x rhs taken;
-      in compile_lhs match_name f rhs' (v::vs) taken' end
-  | Free(_,_) => (pat, (vs, rhs))
-  | Const(_,_) => (pat, (vs, rhs))
-  | _ => fixrec_err ("invalid function pattern: "
-                    ^ ML_Syntax.print_term pat);
-
-fun strip_alls t =
-  if Logic.is_all t then strip_alls (snd (Logic.dest_all t)) else t;
-
-fun compile_eq match_name eq =
-  let
-    val (lhs,rhs) = dest_eqs (Logic.strip_imp_concl (strip_alls eq));
-  in
-    compile_lhs match_name lhs (mk_succeed rhs) [] (taken_names eq)
-  end;
-
-(* this is the pattern-matching compiler function *)
-fun compile_eqs match_name eqs =
-  let
-    val (consts, matchers) =
-      ListPair.unzip (map (compile_eq match_name) eqs);
-    val const =
-        case distinct (op =) consts of
-          [n] => n
-        | _ => fixrec_err "all equations in block must define the same function";
-    val vars =
-        case distinct (op = o pairself length) (map fst matchers) of
-          [vars] => vars
-        | _ => fixrec_err "all equations in block must have the same arity";
-    (* rename so all matchers use same free variables *)
-    fun rename (vs, t) = Term.subst_free (filter_out (op =) (vs ~~ vars)) t;
-    val rhs = big_lambdas vars (mk_run (foldr1 mk_mplus (map rename matchers)));
-  in
-    mk_trp (const === rhs)
-  end;
-
-(*************************************************************************)
-(********************** Proving associated theorems **********************)
-(*************************************************************************)
-
-fun eta_tac i = CONVERSION Thm.eta_conversion i;
-
-fun fixrec_simp_tac ctxt =
-  let
-    val tab = FixrecUnfoldData.get (Context.Proof ctxt);
-    val ss = Simplifier.simpset_of ctxt;
-    fun concl t =
-      if Logic.is_all t then concl (snd (Logic.dest_all t))
-      else HOLogic.dest_Trueprop (Logic.strip_imp_concl t);
-    fun tac (t, i) =
-      let
-        val (c, T) =
-            (dest_Const o head_of o chead_of o fst o HOLogic.dest_eq o concl) t;
-        val unfold_thm = the (Symtab.lookup tab c);
-        val rule = unfold_thm RS @{thm ssubst_lhs};
-      in
-        CHANGED (rtac rule i THEN eta_tac i THEN asm_simp_tac ss i)
-      end
-  in
-    SUBGOAL (fn ti => the_default no_tac (try tac ti))
-  end;
-
-(* proves a block of pattern matching equations as theorems, using unfold *)
-fun make_simps ctxt (unfold_thm, eqns : (Attrib.binding * term) list) =
-  let
-    val ss = Simplifier.simpset_of ctxt;
-    val rule = unfold_thm RS @{thm ssubst_lhs};
-    val tac = rtac rule 1 THEN eta_tac 1 THEN asm_simp_tac ss 1;
-    fun prove_term t = Goal.prove ctxt [] [] t (K tac);
-    fun prove_eqn (bind, eqn_t) = (bind, prove_term eqn_t);
-  in
-    map prove_eqn eqns
-  end;
-
-(*************************************************************************)
-(************************* Main fixrec function **************************)
-(*************************************************************************)
-
-local
-(* code adapted from HOL/Tools/primrec.ML *)
-
-fun gen_fixrec
-  prep_spec
-  (raw_fixes : (binding * 'a option * mixfix) list)
-  (raw_spec' : (bool * (Attrib.binding * 'b)) list)
-  (lthy : local_theory) =
-  let
-    val (skips, raw_spec) = ListPair.unzip raw_spec';
-    val (fixes : ((binding * typ) * mixfix) list,
-         spec : (Attrib.binding * term) list) =
-          fst (prep_spec raw_fixes raw_spec lthy);
-    val chead_of_spec =
-      chead_of o fst o dest_eqs o Logic.strip_imp_concl o strip_alls o snd;
-    fun name_of (Free (n, _)) = n
-      | name_of t = fixrec_err ("unknown term");
-    val all_names = map (name_of o chead_of_spec) spec;
-    val names = distinct (op =) all_names;
-    fun block_of_name n =
-      map_filter
-        (fn (m,eq) => if m = n then SOME eq else NONE)
-        (all_names ~~ (spec ~~ skips));
-    val blocks = map block_of_name names;
-
-    val matcher_tab = FixrecMatchData.get (ProofContext.theory_of lthy);
-    fun match_name c =
-      case Symtab.lookup matcher_tab c of SOME m => m
-        | NONE => fixrec_err ("unknown pattern constructor: " ^ c);
-
-    val matches = map (compile_eqs match_name) (map (map (snd o fst)) blocks);
-    val spec' = map (pair Attrib.empty_binding) matches;
-    val (lthy, cnames, fixdef_thms, unfold_thms) =
-      add_fixdefs fixes spec' lthy;
-
-    val blocks' = map (map fst o filter_out snd) blocks;
-    val simps : (Attrib.binding * thm) list list =
-      map (make_simps lthy) (unfold_thms ~~ blocks');
-    fun mk_bind n : Attrib.binding =
-     (Binding.qualify true n (Binding.name "simps"),
-       [Attrib.internal (K Simplifier.simp_add)]);
-    val simps1 : (Attrib.binding * thm list) list =
-      map (fn (n,xs) => (mk_bind n, map snd xs)) (names ~~ simps);
-    val simps2 : (Attrib.binding * thm list) list =
-      map (apsnd (fn thm => [thm])) (flat simps);
-    val (_, lthy) = lthy
-      |> fold_map Local_Theory.note (simps1 @ simps2);
-  in
-    lthy
-  end;
-
-in
-
-val add_fixrec = gen_fixrec Specification.check_spec;
-val add_fixrec_cmd = gen_fixrec Specification.read_spec;
-
-end; (* local *)
-
-
-(*************************************************************************)
-(******************************** Parsers ********************************)
-(*************************************************************************)
-
-val opt_thm_name' : (bool * Attrib.binding) parser =
-  Parse.$$$ "(" -- Parse.$$$ "unchecked" -- Parse.$$$ ")" >> K (true, Attrib.empty_binding)
-    || Parse_Spec.opt_thm_name ":" >> pair false;
-
-val spec' : (bool * (Attrib.binding * string)) parser =
-  opt_thm_name' -- Parse.prop >> (fn ((a, b), c) => (a, (b, c)));
-
-val alt_specs' : (bool * (Attrib.binding * string)) list parser =
-  let val unexpected = Scan.ahead (Parse.name || Parse.$$$ "[" || Parse.$$$ "(");
-  in Parse.enum1 "|" (spec' --| Scan.option (unexpected -- Parse.!!! (Parse.$$$ "|"))) end;
-
-val _ =
-  Outer_Syntax.local_theory "fixrec" "define recursive functions (HOLCF)" Keyword.thy_decl
-    (Parse.fixes -- (Parse.where_ |-- Parse.!!! alt_specs')
-      >> (fn (fixes, specs) => add_fixrec_cmd fixes specs));
-
-val setup =
-  Method.setup @{binding fixrec_simp}
-    (Scan.succeed (SIMPLE_METHOD' o fixrec_simp_tac))
-    "pattern prover for fixrec constants";
-
-end;

--- a/src/HOLCF/Tools/holcf_library.ML	Sat Nov 27 14:34:54 2010 -0800
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,289 +0,0 @@
-(*  Title:      HOLCF/Tools/holcf_library.ML
-    Author:     Brian Huffman
-
-Functions for constructing HOLCF types and terms.
-*)
-
-structure HOLCF_Library =
-struct
-
-infixr 6 ->>;
-infixr -->>;
-infix 9 `;
-
-(*** Operations from Isabelle/HOL ***)
-
-val boolT = HOLogic.boolT;
-val natT = HOLogic.natT;
-
-val mk_equals = Logic.mk_equals;
-val mk_eq = HOLogic.mk_eq;
-val mk_trp = HOLogic.mk_Trueprop;
-val mk_fst = HOLogic.mk_fst;
-val mk_snd = HOLogic.mk_snd;
-val mk_not = HOLogic.mk_not;
-val mk_conj = HOLogic.mk_conj;
-val mk_disj = HOLogic.mk_disj;
-val mk_imp = HOLogic.mk_imp;
-
-fun mk_ex (x, t) = HOLogic.exists_const (fastype_of x) $ Term.lambda x t;
-fun mk_all (x, t) = HOLogic.all_const (fastype_of x) $ Term.lambda x t;
-
-
-(*** Basic HOLCF concepts ***)
-
-fun mk_bottom T = Const (@{const_name UU}, T);
-
-fun below_const T = Const (@{const_name below}, [T, T] ---> boolT);
-fun mk_below (t, u) = below_const (fastype_of t) $ t $ u;
-
-fun mk_undef t = mk_eq (t, mk_bottom (fastype_of t));
-
-fun mk_defined t = mk_not (mk_undef t);
-
-fun mk_adm t =
-  Const (@{const_name adm}, fastype_of t --> boolT) $ t;
-
-fun mk_compact t =
-  Const (@{const_name compact}, fastype_of t --> boolT) $ t;
-
-fun mk_cont t =
-  Const (@{const_name cont}, fastype_of t --> boolT) $ t;
-
-fun mk_chain t =
-  Const (@{const_name chain}, Term.fastype_of t --> boolT) $ t;
-
-fun mk_lub t =
-  let
-    val T = Term.range_type (Term.fastype_of t);
-    val lub_const = Const (@{const_name lub}, (T --> boolT) --> T);
-    val UNIV_const = @{term "UNIV :: nat set"};
-    val image_type = (natT --> T) --> (natT --> boolT) --> T --> boolT;
-    val image_const = Const (@{const_name image}, image_type);
-  in
-    lub_const $ (image_const $ t $ UNIV_const)
-  end;
-
-
-(*** Continuous function space ***)
-
-fun mk_cfunT (T, U) = Type(@{type_name cfun}, [T, U]);
-
-val (op ->>) = mk_cfunT;
-val (op -->>) = Library.foldr mk_cfunT;
-
-fun dest_cfunT (Type(@{type_name cfun}, [T, U])) = (T, U)
-  | dest_cfunT T = raise TYPE ("dest_cfunT", [T], []);
-
-fun capply_const (S, T) =
-  Const(@{const_name Rep_cfun}, (S ->> T) --> (S --> T));
-
-fun cabs_const (S, T) =
-  Const(@{const_name Abs_cfun}, (S --> T) --> (S ->> T));
-
-fun mk_cabs t =
-  let val T = fastype_of t
-  in cabs_const (Term.domain_type T, Term.range_type T) $ t end
-
-(* builds the expression (% v1 v2 .. vn. rhs) *)
-fun lambdas [] rhs = rhs
-  | lambdas (v::vs) rhs = Term.lambda v (lambdas vs rhs);
-
-(* builds the expression (LAM v. rhs) *)
-fun big_lambda v rhs =
-  cabs_const (fastype_of v, fastype_of rhs) $ Term.lambda v rhs;
-
-(* builds the expression (LAM v1 v2 .. vn. rhs) *)
-fun big_lambdas [] rhs = rhs
-  | big_lambdas (v::vs) rhs = big_lambda v (big_lambdas vs rhs);
-
-fun mk_capply (t, u) =
-  let val (S, T) =
-    case fastype_of t of
-        Type(@{type_name cfun}, [S, T]) => (S, T)
-      | _ => raise TERM ("mk_capply " ^ ML_Syntax.print_list ML_Syntax.print_term [t, u], [t, u]);
-  in capply_const (S, T) $ t $ u end;
-
-val (op `) = mk_capply;
-
-val list_ccomb : term * term list -> term = Library.foldl mk_capply;
-
-fun mk_ID T = Const (@{const_name ID}, T ->> T);
-
-fun cfcomp_const (T, U, V) =
-  Const (@{const_name cfcomp}, (U ->> V) ->> (T ->> U) ->> (T ->> V));
-
-fun mk_cfcomp (f, g) =
-  let
-    val (U, V) = dest_cfunT (fastype_of f);
-    val (T, U') = dest_cfunT (fastype_of g);
-  in
-    if U = U'
-    then mk_capply (mk_capply (cfcomp_const (T, U, V), f), g)
-    else raise TYPE ("mk_cfcomp", [U, U'], [f, g])
-  end;
-
-fun strictify_const T = Const (@{const_name strictify}, T ->> T);
-fun mk_strictify t = strictify_const (fastype_of t) ` t;
-
-fun mk_strict t =
-  let val (T, U) = dest_cfunT (fastype_of t);
-  in mk_eq (t ` mk_bottom T, mk_bottom U) end;
-
-
-(*** Product type ***)
-
-val mk_prodT = HOLogic.mk_prodT
-
-fun mk_tupleT [] = HOLogic.unitT
-  | mk_tupleT [T] = T
-  | mk_tupleT (T :: Ts) = mk_prodT (T, mk_tupleT Ts);
-
-(* builds the expression (v1,v2,..,vn) *)
-fun mk_tuple [] = HOLogic.unit
-  | mk_tuple (t::[]) = t
-  | mk_tuple (t::ts) = HOLogic.mk_prod (t, mk_tuple ts);
-
-(* builds the expression (%(v1,v2,..,vn). rhs) *)
-fun lambda_tuple [] rhs = Term.lambda (Free("unit", HOLogic.unitT)) rhs
-  | lambda_tuple (v::[]) rhs = Term.lambda v rhs
-  | lambda_tuple (v::vs) rhs =
-      HOLogic.mk_split (Term.lambda v (lambda_tuple vs rhs));
-
-
-(*** Lifted cpo type ***)
-
-fun mk_upT T = Type(@{type_name "u"}, [T]);
-
-fun dest_upT (Type(@{type_name "u"}, [T])) = T
-  | dest_upT T = raise TYPE ("dest_upT", [T], []);
-
-fun up_const T = Const(@{const_name up}, T ->> mk_upT T);
-
-fun mk_up t = up_const (fastype_of t) ` t;
-
-fun fup_const (T, U) =
-  Const(@{const_name fup}, (T ->> U) ->> mk_upT T ->> U);
-
-fun mk_fup t = fup_const (dest_cfunT (fastype_of t)) ` t;
-
-fun from_up T = fup_const (T, T) ` mk_ID T;
-
-
-(*** Lifted unit type ***)
-
-val oneT = @{typ "one"};
-
-fun one_case_const T = Const (@{const_name one_case}, T ->> oneT ->> T);
-fun mk_one_case t = one_case_const (fastype_of t) ` t;
-
-
-(*** Strict product type ***)
-
-fun mk_sprodT (T, U) = Type(@{type_name sprod}, [T, U]);
-
-fun dest_sprodT (Type(@{type_name sprod}, [T, U])) = (T, U)
-  | dest_sprodT T = raise TYPE ("dest_sprodT", [T], []);
-
-fun spair_const (T, U) =
-  Const(@{const_name spair}, T ->> U ->> mk_sprodT (T, U));
-
-(* builds the expression (:t, u:) *)
-fun mk_spair (t, u) =
-  spair_const (fastype_of t, fastype_of u) ` t ` u;
-
-(* builds the expression (:t1,t2,..,tn:) *)
-fun mk_stuple [] = @{term "ONE"}
-  | mk_stuple (t::[]) = t
-  | mk_stuple (t::ts) = mk_spair (t, mk_stuple ts);
-
-fun sfst_const (T, U) =
-  Const(@{const_name sfst}, mk_sprodT (T, U) ->> T);
-
-fun ssnd_const (T, U) =
-  Const(@{const_name ssnd}, mk_sprodT (T, U) ->> U);
-
-fun ssplit_const (T, U, V) =
-  Const (@{const_name ssplit}, (T ->> U ->> V) ->> mk_sprodT (T, U) ->> V);
-
-fun mk_ssplit t =
-  let val (T, (U, V)) = apsnd dest_cfunT (dest_cfunT (fastype_of t));
-  in ssplit_const (T, U, V) ` t end;
-
-
-(*** Strict sum type ***)
-
-fun mk_ssumT (T, U) = Type(@{type_name ssum}, [T, U]);
-
-fun dest_ssumT (Type(@{type_name ssum}, [T, U])) = (T, U)
-  | dest_ssumT T = raise TYPE ("dest_ssumT", [T], []);
-
-fun sinl_const (T, U) = Const(@{const_name sinl}, T ->> mk_ssumT (T, U));
-fun sinr_const (T, U) = Const(@{const_name sinr}, U ->> mk_ssumT (T, U));
-
-(* builds the list [sinl(t1), sinl(sinr(t2)), ... sinr(...sinr(tn))] *)
-fun mk_sinjects ts =
-  let
-    val Ts = map fastype_of ts;
-    fun combine (t, T) (us, U) =
-      let
-        val v = sinl_const (T, U) ` t;
-        val vs = map (fn u => sinr_const (T, U) ` u) us;
-      in
-        (v::vs, mk_ssumT (T, U))
-      end
-    fun inj [] = raise Fail "mk_sinjects: empty list"
-      | inj ((t, T)::[]) = ([t], T)
-      | inj ((t, T)::ts) = combine (t, T) (inj ts);
-  in
-    fst (inj (ts ~~ Ts))
-  end;
-
-fun sscase_const (T, U, V) =
-  Const(@{const_name sscase},
-    (T ->> V) ->> (U ->> V) ->> mk_ssumT (T, U) ->> V);
-
-fun mk_sscase (t, u) =
-  let val (T, V) = dest_cfunT (fastype_of t);
-      val (U, V) = dest_cfunT (fastype_of u);
-  in sscase_const (T, U, V) ` t ` u end;
-
-fun from_sinl (T, U) =
-  sscase_const (T, U, T) ` mk_ID T ` mk_bottom (U ->> T);
-
-fun from_sinr (T, U) =
-  sscase_const (T, U, U) ` mk_bottom (T ->> U) ` mk_ID U;
-
-
-(*** pattern match monad type ***)
-
-fun mk_matchT T = Type (@{type_name "match"}, [T]);
-
-fun dest_matchT (Type(@{type_name "match"}, [T])) = T
-  | dest_matchT T = raise TYPE ("dest_matchT", [T], []);
-
-fun mk_fail T = Const (@{const_name "Fixrec.fail"}, mk_matchT T);
-
-fun succeed_const T = Const (@{const_name "Fixrec.succeed"}, T ->> mk_matchT T);
-fun mk_succeed t = succeed_const (fastype_of t) ` t;
-
-
-(*** lifted boolean type ***)
-
-val trT = @{typ "tr"};
-
-
-(*** theory of fixed points ***)
-
-fun mk_fix t =
-  let val (T, _) = dest_cfunT (fastype_of t)
-  in mk_capply (Const(@{const_name fix}, (T ->> T) ->> T), t) end;
-
-fun iterate_const T =
-  Const (@{const_name iterate}, natT --> (T ->> T) ->> (T ->> T));
-
-fun mk_iterate (n, f) =
-  let val (T, _) = dest_cfunT (Term.fastype_of f);
-  in (iterate_const T $ n) ` f ` mk_bottom T end;
-
-end;

--- a/src/HOLCF/Tr.thy	Sat Nov 27 14:34:54 2010 -0800
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,199 +0,0 @@
-(*  Title:      HOLCF/Tr.thy
-    Author:     Franz Regensburger
-*)
-
-header {* The type of lifted booleans *}
-
-theory Tr
-imports Lift
-begin
-
-subsection {* Type definition and constructors *}
-
-types
-  tr = "bool lift"
-
-translations
-  (type) "tr" <= (type) "bool lift"
-
-definition
-  TT :: "tr" where
-  "TT = Def True"
-
-definition
-  FF :: "tr" where
-  "FF = Def False"
-
-text {* Exhaustion and Elimination for type @{typ tr} *}
-
-lemma Exh_tr: "t = \<bottom> \<or> t = TT \<or> t = FF"
-unfolding FF_def TT_def by (induct t) auto
-
-lemma trE [case_names bottom TT FF]:
-  "\<lbrakk>p = \<bottom> \<Longrightarrow> Q; p = TT \<Longrightarrow> Q; p = FF \<Longrightarrow> Q\<rbrakk> \<Longrightarrow> Q"
-unfolding FF_def TT_def by (induct p) auto
-
-lemma tr_induct [case_names bottom TT FF]:
-  "\<lbrakk>P \<bottom>; P TT; P FF\<rbrakk> \<Longrightarrow> P x"
-by (cases x rule: trE) simp_all
-
-text {* distinctness for type @{typ tr} *}
-
-lemma dist_below_tr [simp]:
-  "\<not> TT \<sqsubseteq> \<bottom>" "\<not> FF \<sqsubseteq> \<bottom>" "\<not> TT \<sqsubseteq> FF" "\<not> FF \<sqsubseteq> TT"
-unfolding TT_def FF_def by simp_all
-
-lemma dist_eq_tr [simp]:
-  "TT \<noteq> \<bottom>" "FF \<noteq> \<bottom>" "TT \<noteq> FF" "\<bottom> \<noteq> TT" "\<bottom> \<noteq> FF" "FF \<noteq> TT"
-unfolding TT_def FF_def by simp_all
-
-lemma TT_below_iff [simp]: "TT \<sqsubseteq> x \<longleftrightarrow> x = TT"
-by (induct x rule: tr_induct) simp_all
-
-lemma FF_below_iff [simp]: "FF \<sqsubseteq> x \<longleftrightarrow> x = FF"
-by (induct x rule: tr_induct) simp_all
-
-lemma not_below_TT_iff [simp]: "\<not> (x \<sqsubseteq> TT) \<longleftrightarrow> x = FF"
-by (induct x rule: tr_induct) simp_all
-
-lemma not_below_FF_iff [simp]: "\<not> (x \<sqsubseteq> FF) \<longleftrightarrow> x = TT"
-by (induct x rule: tr_induct) simp_all
-
-
-subsection {* Case analysis *}
-
-default_sort pcpo
-
-definition tr_case :: "'a \<rightarrow> 'a \<rightarrow> tr \<rightarrow> 'a" where
-  "tr_case = (\<Lambda> t e (Def b). if b then t else e)"
-
-abbreviation
-  cifte_syn :: "[tr, 'c, 'c] \<Rightarrow> 'c"  ("(If (_)/ then (_)/ else (_))" [0, 0, 60] 60)
-where
-  "If b then e1 else e2 == tr_case\<cdot>e1\<cdot>e2\<cdot>b"
-
-translations
-  "\<Lambda> (XCONST TT). t" == "CONST tr_case\<cdot>t\<cdot>\<bottom>"
-  "\<Lambda> (XCONST FF). t" == "CONST tr_case\<cdot>\<bottom>\<cdot>t"
-
-lemma ifte_thms [simp]:
-  "If \<bottom> then e1 else e2 = \<bottom>"
-  "If FF then e1 else e2 = e2"
-  "If TT then e1 else e2 = e1"
-by (simp_all add: tr_case_def TT_def FF_def)
-
-
-subsection {* Boolean connectives *}
-
-definition
-  trand :: "tr \<rightarrow> tr \<rightarrow> tr" where
-  andalso_def: "trand = (\<Lambda> x y. If x then y else FF)"
-abbreviation
-  andalso_syn :: "tr \<Rightarrow> tr \<Rightarrow> tr"  ("_ andalso _" [36,35] 35)  where
-  "x andalso y == trand\<cdot>x\<cdot>y"
-
-definition
-  tror :: "tr \<rightarrow> tr \<rightarrow> tr" where
-  orelse_def: "tror = (\<Lambda> x y. If x then TT else y)"
-abbreviation
-  orelse_syn :: "tr \<Rightarrow> tr \<Rightarrow> tr"  ("_ orelse _"  [31,30] 30)  where
-  "x orelse y == tror\<cdot>x\<cdot>y"
-
-definition
-  neg :: "tr \<rightarrow> tr" where
-  "neg = flift2 Not"
-
-definition
-  If2 :: "[tr, 'c, 'c] \<Rightarrow> 'c" where
-  "If2 Q x y = (If Q then x else y)"
-
-text {* tactic for tr-thms with case split *}
-
-lemmas tr_defs = andalso_def orelse_def neg_def tr_case_def TT_def FF_def
-
-text {* lemmas about andalso, orelse, neg and if *}
-
-lemma andalso_thms [simp]:
-  "(TT andalso y) = y"
-  "(FF andalso y) = FF"
-  "(\<bottom> andalso y) = \<bottom>"
-  "(y andalso TT) = y"
-  "(y andalso y) = y"
-apply (unfold andalso_def, simp_all)
-apply (cases y rule: trE, simp_all)
-apply (cases y rule: trE, simp_all)
-done
-
-lemma orelse_thms [simp]:
-  "(TT orelse y) = TT"
-  "(FF orelse y) = y"
-  "(\<bottom> orelse y) = \<bottom>"
-  "(y orelse FF) = y"
-  "(y orelse y) = y"
-apply (unfold orelse_def, simp_all)
-apply (cases y rule: trE, simp_all)
-apply (cases y rule: trE, simp_all)
-done
-
-lemma neg_thms [simp]:
-  "neg\<cdot>TT = FF"
-  "neg\<cdot>FF = TT"
-  "neg\<cdot>\<bottom> = \<bottom>"
-by (simp_all add: neg_def TT_def FF_def)
-
-text {* split-tac for If via If2 because the constant has to be a constant *}
-
-lemma split_If2:
-  "P (If2 Q x y) = ((Q = \<bottom> \<longrightarrow> P \<bottom>) \<and> (Q = TT \<longrightarrow> P x) \<and> (Q = FF \<longrightarrow> P y))"
-apply (unfold If2_def)
-apply (rule_tac p = "Q" in trE)
-apply (simp_all)
-done
-
-ML {*
-val split_If_tac =
-  simp_tac (HOL_basic_ss addsimps [@{thm If2_def} RS sym])
-    THEN' (split_tac [@{thm split_If2}])
-*}
-
-subsection "Rewriting of HOLCF operations to HOL functions"
-
-lemma andalso_or:
-  "t \<noteq> \<bottom> \<Longrightarrow> ((t andalso s) = FF) = (t = FF \<or> s = FF)"
-apply (rule_tac p = "t" in trE)
-apply simp_all
-done
-
-lemma andalso_and:
-  "t \<noteq> \<bottom> \<Longrightarrow> ((t andalso s) \<noteq> FF) = (t \<noteq> FF \<and> s \<noteq> FF)"
-apply (rule_tac p = "t" in trE)
-apply simp_all
-done
-
-lemma Def_bool1 [simp]: "(Def x \<noteq> FF) = x"
-by (simp add: FF_def)
-
-lemma Def_bool2 [simp]: "(Def x = FF) = (\<not> x)"
-by (simp add: FF_def)
-
-lemma Def_bool3 [simp]: "(Def x = TT) = x"
-by (simp add: TT_def)
-
-lemma Def_bool4 [simp]: "(Def x \<noteq> TT) = (\<not> x)"
-by (simp add: TT_def)
-
-lemma If_and_if:
-  "(If Def P then A else B) = (if P then A else B)"
-apply (rule_tac p = "Def P" in trE)
-apply (auto simp add: TT_def[symmetric] FF_def[symmetric])
-done
-
-subsection {* Compactness *}
-
-lemma compact_TT: "compact TT"
-by (rule compact_chfin)
-
-lemma compact_FF: "compact FF"
-by (rule compact_chfin)
-
-end

--- a/src/HOLCF/Tutorial/Domain_ex.thy	Sat Nov 27 14:34:54 2010 -0800
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,201 +0,0 @@
-(*  Title:      HOLCF/ex/Domain_ex.thy
-    Author:     Brian Huffman
-*)
-
-header {* Domain package examples *}
-
-theory Domain_ex
-imports HOLCF
-begin
-
-text {* Domain constructors are strict by default. *}
-
-domain d1 = d1a | d1b "d1" "d1"
-
-lemma "d1b\<cdot>\<bottom>\<cdot>y = \<bottom>" by simp
-
-text {* Constructors can be made lazy using the @{text "lazy"} keyword. *}
-
-domain d2 = d2a | d2b (lazy "d2")
-
-lemma "d2b\<cdot>x \<noteq> \<bottom>" by simp
-
-text {* Strict and lazy arguments may be mixed arbitrarily. *}
-
-domain d3 = d3a | d3b (lazy "d2") "d2"
-
-lemma "P (d3b\<cdot>x\<cdot>y = \<bottom>) \<longleftrightarrow> P (y = \<bottom>)" by simp
-
-text {* Selectors can be used with strict or lazy constructor arguments. *}
-
-domain d4 = d4a | d4b (lazy d4b_left :: "d2") (d4b_right :: "d2")
-
-lemma "y \<noteq> \<bottom> \<Longrightarrow> d4b_left\<cdot>(d4b\<cdot>x\<cdot>y) = x" by simp
-
-text {* Mixfix declarations can be given for data constructors. *}
-
-domain d5 = d5a | d5b (lazy "d5") "d5" (infixl ":#:" 70)
-
-lemma "d5a \<noteq> x :#: y :#: z" by simp
-
-text {* Mixfix declarations can also be given for type constructors. *}
-
-domain ('a, 'b) lazypair (infixl ":*:" 25) =
-  lpair (lazy lfst :: 'a) (lazy lsnd :: 'b) (infixl ":*:" 75)
-
-lemma "\<forall>p::('a :*: 'b). p \<sqsubseteq> lfst\<cdot>p :*: lsnd\<cdot>p"
-by (rule allI, case_tac p, simp_all)
-
-text {* Non-recursive constructor arguments can have arbitrary types. *}
-
-domain ('a, 'b) d6 = d6 "int lift" "'a \<oplus> 'b u" (lazy "('a :*: 'b) \<times> ('b \<rightarrow> 'a)")
-
-text {*
-  Indirect recusion is allowed for sums, products, lifting, and the
-  continuous function space.  However, the domain package does not
-  generate an induction rule in terms of the constructors.
-*}
-
-domain 'a d7 = d7a "'a d7 \<oplus> int lift" | d7b "'a \<otimes> 'a d7" | d7c (lazy "'a d7 \<rightarrow> 'a")
-  -- "Indirect recursion detected, skipping proofs of (co)induction rules"
-
-text {* Note that @{text d7.induct} is absent. *}
-
-text {*
-  Indirect recursion is also allowed using previously-defined datatypes.
-*}
-
-domain 'a slist = SNil | SCons 'a "'a slist"
-
-domain 'a stree = STip | SBranch "'a stree slist"
-
-text {* Mutually-recursive datatypes can be defined using the @{text "and"} keyword. *}
-
-domain d8 = d8a | d8b "d9" and d9 = d9a | d9b (lazy "d8")
-
-text {* Non-regular recursion is not allowed. *}
-(*
-domain ('a, 'b) altlist = ANil | ACons 'a "('b, 'a) altlist"
-  -- "illegal direct recursion with different arguments"
-domain 'a nest = Nest1 'a | Nest2 "'a nest nest"
-  -- "illegal direct recursion with different arguments"
-*)
-
-text {*
-  Mutually-recursive datatypes must have all the same type arguments,
-  not necessarily in the same order.
-*}
-
-domain ('a, 'b) list1 = Nil1 | Cons1 'a "('b, 'a) list2"
-   and ('b, 'a) list2 = Nil2 | Cons2 'b "('a, 'b) list1"
-
-text {* Induction rules for flat datatypes have no admissibility side-condition. *}
-
-domain 'a flattree = Tip | Branch "'a flattree" "'a flattree"
-
-lemma "\<lbrakk>P \<bottom>; P Tip; \<And>x y. \<lbrakk>x \<noteq> \<bottom>; y \<noteq> \<bottom>; P x; P y\<rbrakk> \<Longrightarrow> P (Branch\<cdot>x\<cdot>y)\<rbrakk> \<Longrightarrow> P x"
-by (rule flattree.induct) -- "no admissibility requirement"
-
-text {* Trivial datatypes will produce a warning message. *}
-
-domain triv = Triv triv triv
-  -- "domain @{text Domain_ex.triv} is empty!"
-
-lemma "(x::triv) = \<bottom>" by (induct x, simp_all)
-
-text {* Lazy constructor arguments may have unpointed types. *}
-
-domain natlist = nnil | ncons (lazy "nat discr") natlist
-
-text {* Class constraints may be given for type parameters on the LHS. *}
-
-domain ('a::predomain) box = Box (lazy 'a)
-
-domain ('a::countable) stream = snil | scons (lazy "'a discr") "'a stream"
-
-
-subsection {* Generated constants and theorems *}
-
-domain 'a tree = Leaf (lazy 'a) | Node (left :: "'a tree") (right :: "'a tree")
-
-lemmas tree_abs_bottom_iff =
-  iso.abs_bottom_iff [OF iso.intro [OF tree.abs_iso tree.rep_iso]]
-
-text {* Rules about ismorphism *}
-term tree_rep
-term tree_abs
-thm tree.rep_iso
-thm tree.abs_iso
-thm tree.iso_rews
-
-text {* Rules about constructors *}
-term Leaf
-term Node
-thm Leaf_def Node_def
-thm tree.nchotomy
-thm tree.exhaust
-thm tree.compacts
-thm tree.con_rews
-thm tree.dist_les
-thm tree.dist_eqs
-thm tree.inverts
-thm tree.injects
-
-text {* Rules about case combinator *}
-term tree_case
-thm tree.tree_case_def
-thm tree.case_rews
-
-text {* Rules about selectors *}
-term left
-term right
-thm tree.sel_rews
-
-text {* Rules about discriminators *}
-term is_Leaf
-term is_Node
-thm tree.dis_rews
-
-text {* Rules about monadic pattern match combinators *}
-term match_Leaf
-term match_Node
-thm tree.match_rews
-
-text {* Rules about take function *}
-term tree_take
-thm tree.take_def
-thm tree.take_0
-thm tree.take_Suc
-thm tree.take_rews
-thm tree.chain_take
-thm tree.take_take
-thm tree.deflation_take
-thm tree.take_below
-thm tree.take_lemma
-thm tree.lub_take
-thm tree.reach
-thm tree.finite_induct
-
-text {* Rules about finiteness predicate *}
-term tree_finite
-thm tree.finite_def
-thm tree.finite (* only generated for flat datatypes *)
-
-text {* Rules about bisimulation predicate *}
-term tree_bisim
-thm tree.bisim_def
-thm tree.coinduct
-
-text {* Induction rule *}
-thm tree.induct
-
-
-subsection {* Known bugs *}
-
-text {* Declaring a mixfix with spaces causes some strange parse errors. *}
-(*
-domain xx = xx ("x y")
-  -- "Inner syntax error: unexpected end of input"
-*)
-
-end

--- a/src/HOLCF/Tutorial/Fixrec_ex.thy	Sat Nov 27 14:34:54 2010 -0800
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,245 +0,0 @@
-(*  Title:      HOLCF/ex/Fixrec_ex.thy
-    Author:     Brian Huffman
-*)
-
-header {* Fixrec package examples *}
-
-theory Fixrec_ex
-imports HOLCF
-begin
-
-subsection {* Basic @{text fixrec} examples *}
-
-text {*
-  Fixrec patterns can mention any constructor defined by the domain
-  package, as well as any of the following built-in constructors:
-  Pair, spair, sinl, sinr, up, ONE, TT, FF.
-*}
-
-text {* Typical usage is with lazy constructors. *}
-
-fixrec down :: "'a u \<rightarrow> 'a"
-where "down\<cdot>(up\<cdot>x) = x"
-
-text {* With strict constructors, rewrite rules may require side conditions. *}
-
-fixrec from_sinl :: "'a \<oplus> 'b \<rightarrow> 'a"
-where "x \<noteq> \<bottom> \<Longrightarrow> from_sinl\<cdot>(sinl\<cdot>x) = x"
-
-text {* Lifting can turn a strict constructor into a lazy one. *}
-
-fixrec from_sinl_up :: "'a u \<oplus> 'b \<rightarrow> 'a"
-where "from_sinl_up\<cdot>(sinl\<cdot>(up\<cdot>x)) = x"
-
-text {* Fixrec also works with the HOL pair constructor. *}
-
-fixrec down2 :: "'a u \<times> 'b u \<rightarrow> 'a \<times> 'b"
-where "down2\<cdot>(up\<cdot>x, up\<cdot>y) = (x, y)"
-
-
-subsection {* Examples using @{text fixrec_simp} *}
-
-text {* A type of lazy lists. *}
-
-domain 'a llist = lNil | lCons (lazy 'a) (lazy "'a llist")
-
-text {* A zip function for lazy lists. *}
-
-text {* Notice that the patterns are not exhaustive. *}
-
-fixrec
-  lzip :: "'a llist \<rightarrow> 'b llist \<rightarrow> ('a \<times> 'b) llist"
-where
-  "lzip\<cdot>(lCons\<cdot>x\<cdot>xs)\<cdot>(lCons\<cdot>y\<cdot>ys) = lCons\<cdot>(x, y)\<cdot>(lzip\<cdot>xs\<cdot>ys)"
-| "lzip\<cdot>lNil\<cdot>lNil = lNil"
-
-text {* @{text fixrec_simp} is useful for producing strictness theorems. *}
-text {* Note that pattern matching is done in left-to-right order. *}
-
-lemma lzip_stricts [simp]:
-  "lzip\<cdot>\<bottom>\<cdot>ys = \<bottom>"
-  "lzip\<cdot>lNil\<cdot>\<bottom> = \<bottom>"
-  "lzip\<cdot>(lCons\<cdot>x\<cdot>xs)\<cdot>\<bottom> = \<bottom>"
-by fixrec_simp+
-
-text {* @{text fixrec_simp} can also produce rules for missing cases. *}
-
-lemma lzip_undefs [simp]:
-  "lzip\<cdot>lNil\<cdot>(lCons\<cdot>y\<cdot>ys) = \<bottom>"
-  "lzip\<cdot>(lCons\<cdot>x\<cdot>xs)\<cdot>lNil = \<bottom>"
-by fixrec_simp+
-
-
-subsection {* Pattern matching with bottoms *}
-
-text {*
-  As an alternative to using @{text fixrec_simp}, it is also possible
-  to use bottom as a constructor pattern.  When using a bottom
-  pattern, the right-hand-side must also be bottom; otherwise, @{text
-  fixrec} will not be able to prove the equation.
-*}
-
-fixrec
-  from_sinr_up :: "'a \<oplus> 'b\<^sub>\<bottom> \<rightarrow> 'b"
-where
-  "from_sinr_up\<cdot>\<bottom> = \<bottom>"
-| "from_sinr_up\<cdot>(sinr\<cdot>(up\<cdot>x)) = x"
-
-text {*
-  If the function is already strict in that argument, then the bottom
-  pattern does not change the meaning of the function.  For example,
-  in the definition of @{term from_sinr_up}, the first equation is
-  actually redundant, and could have been proven separately by
-  @{text fixrec_simp}.
-*}
-
-text {*
-  A bottom pattern can also be used to make a function strict in a
-  certain argument, similar to a bang-pattern in Haskell.
-*}
-
-fixrec
-  seq :: "'a \<rightarrow> 'b \<rightarrow> 'b"
-where
-  "seq\<cdot>\<bottom>\<cdot>y = \<bottom>"
-| "x \<noteq> \<bottom> \<Longrightarrow> seq\<cdot>x\<cdot>y = y"
-
-
-subsection {* Skipping proofs of rewrite rules *}
-
-text {* Another zip function for lazy lists. *}
-
-text {*
-  Notice that this version has overlapping patterns.
-  The second equation cannot be proved as a theorem
-  because it only applies when the first pattern fails.
-*}
-
-fixrec
-  lzip2 :: "'a llist \<rightarrow> 'b llist \<rightarrow> ('a \<times> 'b) llist"
-where
-  "lzip2\<cdot>(lCons\<cdot>x\<cdot>xs)\<cdot>(lCons\<cdot>y\<cdot>ys) = lCons\<cdot>(x, y)\<cdot>(lzip2\<cdot>xs\<cdot>ys)"
-| (unchecked) "lzip2\<cdot>xs\<cdot>ys = lNil"
-
-text {*
-  Usually fixrec tries to prove all equations as theorems.
-  The "unchecked" option overrides this behavior, so fixrec
-  does not attempt to prove that particular equation.
-*}
-
-text {* Simp rules can be generated later using @{text fixrec_simp}. *}
-
-lemma lzip2_simps [simp]:
-  "lzip2\<cdot>(lCons\<cdot>x\<cdot>xs)\<cdot>lNil = lNil"
-  "lzip2\<cdot>lNil\<cdot>(lCons\<cdot>y\<cdot>ys) = lNil"
-  "lzip2\<cdot>lNil\<cdot>lNil = lNil"
-by fixrec_simp+
-
-lemma lzip2_stricts [simp]:
-  "lzip2\<cdot>\<bottom>\<cdot>ys = \<bottom>"
-  "lzip2\<cdot>(lCons\<cdot>x\<cdot>xs)\<cdot>\<bottom> = \<bottom>"
-by fixrec_simp+
-
-
-subsection {* Mutual recursion with @{text fixrec} *}
-
-text {* Tree and forest types. *}
-
-domain 'a tree = Leaf (lazy 'a) | Branch (lazy "'a forest")
-and    'a forest = Empty | Trees (lazy "'a tree") "'a forest"
-
-text {*
-  To define mutually recursive functions, give multiple type signatures
-  separated by the keyword @{text "and"}.
-*}
-
-fixrec
-  map_tree :: "('a \<rightarrow> 'b) \<rightarrow> ('a tree \<rightarrow> 'b tree)"
-and
-  map_forest :: "('a \<rightarrow> 'b) \<rightarrow> ('a forest \<rightarrow> 'b forest)"
-where
-  "map_tree\<cdot>f\<cdot>(Leaf\<cdot>x) = Leaf\<cdot>(f\<cdot>x)"
-| "map_tree\<cdot>f\<cdot>(Branch\<cdot>ts) = Branch\<cdot>(map_forest\<cdot>f\<cdot>ts)"
-| "map_forest\<cdot>f\<cdot>Empty = Empty"
-| "ts \<noteq> \<bottom> \<Longrightarrow>
-    map_forest\<cdot>f\<cdot>(Trees\<cdot>t\<cdot>ts) = Trees\<cdot>(map_tree\<cdot>f\<cdot>t)\<cdot>(map_forest\<cdot>f\<cdot>ts)"
-
-lemma map_tree_strict [simp]: "map_tree\<cdot>f\<cdot>\<bottom> = \<bottom>"
-by fixrec_simp
-
-lemma map_forest_strict [simp]: "map_forest\<cdot>f\<cdot>\<bottom> = \<bottom>"
-by fixrec_simp
-
-(*
-  Theorems generated:
-  @{text map_tree_def}  @{thm map_tree_def}
-  @{text map_forest_def}  @{thm map_forest_def}
-  @{text map_tree.unfold}  @{thm map_tree.unfold}
-  @{text map_forest.unfold}  @{thm map_forest.unfold}
-  @{text map_tree.simps}  @{thm map_tree.simps}
-  @{text map_forest.simps}  @{thm map_forest.simps}
-  @{text map_tree_map_forest.induct}  @{thm map_tree_map_forest.induct}
-*)
-
-
-subsection {* Looping simp rules *}
-
-text {*
-  The defining equations of a fixrec definition are declared as simp
-  rules by default.  In some cases, especially for constants with no
-  arguments or functions with variable patterns, the defining
-  equations may cause the simplifier to loop.  In these cases it will
-  be necessary to use a @{text "[simp del]"} declaration.
-*}
-
-fixrec
-  repeat :: "'a \<rightarrow> 'a llist"
-where
-  [simp del]: "repeat\<cdot>x = lCons\<cdot>x\<cdot>(repeat\<cdot>x)"
-
-text {*
-  We can derive other non-looping simp rules for @{const repeat} by
-  using the @{text subst} method with the @{text repeat.simps} rule.
-*}
-
-lemma repeat_simps [simp]:
-  "repeat\<cdot>x \<noteq> \<bottom>"
-  "repeat\<cdot>x \<noteq> lNil"
-  "repeat\<cdot>x = lCons\<cdot>y\<cdot>ys \<longleftrightarrow> x = y \<and> repeat\<cdot>x = ys"
-by (subst repeat.simps, simp)+
-
-lemma llist_case_repeat [simp]:
-  "llist_case\<cdot>z\<cdot>f\<cdot>(repeat\<cdot>x) = f\<cdot>x\<cdot>(repeat\<cdot>x)"
-by (subst repeat.simps, simp)
-
-text {*
-  For mutually-recursive constants, looping might only occur if all
-  equations are in the simpset at the same time.  In such cases it may
-  only be necessary to declare @{text "[simp del]"} on one equation.
-*}
-
-fixrec
-  inf_tree :: "'a tree" and inf_forest :: "'a forest"
-where
-  [simp del]: "inf_tree = Branch\<cdot>inf_forest"
-| "inf_forest = Trees\<cdot>inf_tree\<cdot>(Trees\<cdot>inf_tree\<cdot>Empty)"
-
-
-subsection {* Using @{text fixrec} inside locales *}
-
-locale test =
-  fixes foo :: "'a \<rightarrow> 'a"
-  assumes foo_strict: "foo\<cdot>\<bottom> = \<bottom>"
-begin
-
-fixrec
-  bar :: "'a u \<rightarrow> 'a"
-where
-  "bar\<cdot>(up\<cdot>x) = foo\<cdot>x"
-
-lemma bar_strict: "bar\<cdot>\<bottom> = \<bottom>"
-by fixrec_simp
-
-end
-
-end

--- a/src/HOLCF/Tutorial/New_Domain.thy	Sat Nov 27 14:34:54 2010 -0800
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,90 +0,0 @@
-(*  Title:      HOLCF/ex/New_Domain.thy
-    Author:     Brian Huffman
-*)
-
-header {* Definitional domain package *}
-
-theory New_Domain
-imports HOLCF
-begin
-
-text {*
-  UPDATE: The definitional back-end is now the default mode of the domain
-  package. This file should be merged with @{text Domain_ex.thy}.
-*}
-
-text {*
-  Provided that @{text domain} is the default sort, the @{text new_domain}
-  package should work with any type definition supported by the old
-  domain package.
-*}
-
-domain 'a llist = LNil | LCons (lazy 'a) (lazy "'a llist")
-
-text {*
-  The difference is that the new domain package is completely
-  definitional, and does not generate any axioms.  The following type
-  and constant definitions are not produced by the old domain package.
-*}
-
-thm type_definition_llist
-thm llist_abs_def llist_rep_def
-
-text {*
-  The new domain package also adds support for indirect recursion with
-  user-defined datatypes.  This definition of a tree datatype uses
-  indirect recursion through the lazy list type constructor.
-*}
-
-domain 'a ltree = Leaf (lazy 'a) | Branch (lazy "'a ltree llist")
-
-text {*
-  For indirect-recursive definitions, the domain package is not able to
-  generate a high-level induction rule.  (It produces a warning
-  message instead.)  The low-level reach lemma (now proved as a
-  theorem, no longer generated as an axiom) can be used to derive
-  other induction rules.
-*}
-
-thm ltree.reach
-
-text {*
-  The definition of the take function uses map functions associated with
-  each type constructor involved in the definition.  A map function
-  for the lazy list type has been generated by the new domain package.
-*}
-
-thm ltree.take_rews
-thm llist_map_def
-
-lemma ltree_induct:
-  fixes P :: "'a ltree \<Rightarrow> bool"
-  assumes adm: "adm P"
-  assumes bot: "P \<bottom>"
-  assumes Leaf: "\<And>x. P (Leaf\<cdot>x)"
-  assumes Branch: "\<And>f l. \<forall>x. P (f\<cdot>x) \<Longrightarrow> P (Branch\<cdot>(llist_map\<cdot>f\<cdot>l))"
-  shows "P x"
-proof -
-  have "P (\<Squnion>i. ltree_take i\<cdot>x)"
-  using adm
-  proof (rule admD)
-    fix i
-    show "P (ltree_take i\<cdot>x)"
-    proof (induct i arbitrary: x)
-      case (0 x)
-      show "P (ltree_take 0\<cdot>x)" by (simp add: bot)
-    next
-      case (Suc n x)
-      show "P (ltree_take (Suc n)\<cdot>x)"
-        apply (cases x)
-        apply (simp add: bot)
-        apply (simp add: Leaf)
-        apply (simp add: Branch Suc)
-        done
-    qed
-  qed (simp add: ltree.chain_take)
-  thus ?thesis
-    by (simp add: ltree.reach)
-qed
-
-end

--- a/src/HOLCF/Tutorial/ROOT.ML	Sat Nov 27 14:34:54 2010 -0800
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,1 +0,0 @@
-use_thys ["Domain_ex", "Fixrec_ex", "New_Domain"];

--- a/src/HOLCF/Tutorial/document/root.tex	Sat Nov 27 14:34:54 2010 -0800
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,29 +0,0 @@
-
-% HOLCF/document/root.tex
-
-\documentclass[11pt,a4paper]{article}
-\usepackage{graphicx,isabelle,isabellesym,latexsym}
-\usepackage[only,bigsqcap]{stmaryrd}
-\usepackage[latin1]{inputenc}
-\usepackage{pdfsetup}
-
-\urlstyle{rm}
-%\isabellestyle{it}
-\pagestyle{myheadings}
-
-\begin{document}
-
-\title{Isabelle/HOLCF Tutorial}
-\maketitle
-
-\tableofcontents
-
-%\newpage
-
-%\renewcommand{\isamarkupheader}[1]%
-%{\section{\isabellecontext: #1}\markright{THEORY~``\isabellecontext''}}
-
-\parindent 0pt\parskip 0.5ex
-\input{session}
-
-\end{document}

--- a/src/HOLCF/Universal.thy	Sat Nov 27 14:34:54 2010 -0800
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,1014 +0,0 @@
-(*  Title:      HOLCF/Universal.thy
-    Author:     Brian Huffman
-*)
-
-header {* A universal bifinite domain *}
-
-theory Universal
-imports Completion Deflation Nat_Bijection
-begin
-
-subsection {* Basis for universal domain *}
-
-subsubsection {* Basis datatype *}
-
-types ubasis = nat
-
-definition
-  node :: "nat \<Rightarrow> ubasis \<Rightarrow> ubasis set \<Rightarrow> ubasis"
-where
-  "node i a S = Suc (prod_encode (i, prod_encode (a, set_encode S)))"
-
-lemma node_not_0 [simp]: "node i a S \<noteq> 0"
-unfolding node_def by simp
-
-lemma node_gt_0 [simp]: "0 < node i a S"
-unfolding node_def by simp
-
-lemma node_inject [simp]:
-  "\<lbrakk>finite S; finite T\<rbrakk>
-    \<Longrightarrow> node i a S = node j b T \<longleftrightarrow> i = j \<and> a = b \<and> S = T"
-unfolding node_def by (simp add: prod_encode_eq set_encode_eq)
-
-lemma node_gt0: "i < node i a S"
-unfolding node_def less_Suc_eq_le
-by (rule le_prod_encode_1)
-
-lemma node_gt1: "a < node i a S"
-unfolding node_def less_Suc_eq_le
-by (rule order_trans [OF le_prod_encode_1 le_prod_encode_2])
-
-lemma nat_less_power2: "n < 2^n"
-by (induct n) simp_all
-
-lemma node_gt2: "\<lbrakk>finite S; b \<in> S\<rbrakk> \<Longrightarrow> b < node i a S"
-unfolding node_def less_Suc_eq_le set_encode_def
-apply (rule order_trans [OF _ le_prod_encode_2])
-apply (rule order_trans [OF _ le_prod_encode_2])
-apply (rule order_trans [where y="setsum (op ^ 2) {b}"])
-apply (simp add: nat_less_power2 [THEN order_less_imp_le])
-apply (erule setsum_mono2, simp, simp)
-done
-
-lemma eq_prod_encode_pairI:
-  "\<lbrakk>fst (prod_decode x) = a; snd (prod_decode x) = b\<rbrakk> \<Longrightarrow> x = prod_encode (a, b)"
-by (erule subst, erule subst, simp)
-
-lemma node_cases:
-  assumes 1: "x = 0 \<Longrightarrow> P"
-  assumes 2: "\<And>i a S. \<lbrakk>finite S; x = node i a S\<rbrakk> \<Longrightarrow> P"
-  shows "P"
- apply (cases x)
-  apply (erule 1)
- apply (rule 2)
-  apply (rule finite_set_decode)
- apply (simp add: node_def)
- apply (rule eq_prod_encode_pairI [OF refl])
- apply (rule eq_prod_encode_pairI [OF refl refl])
-done
-
-lemma node_induct:
-  assumes 1: "P 0"
-  assumes 2: "\<And>i a S. \<lbrakk>P a; finite S; \<forall>b\<in>S. P b\<rbrakk> \<Longrightarrow> P (node i a S)"
-  shows "P x"
- apply (induct x rule: nat_less_induct)
- apply (case_tac n rule: node_cases)
-  apply (simp add: 1)
- apply (simp add: 2 node_gt1 node_gt2)
-done
-
-subsubsection {* Basis ordering *}
-
-inductive
-  ubasis_le :: "nat \<Rightarrow> nat \<Rightarrow> bool"
-where
-  ubasis_le_refl: "ubasis_le a a"
-| ubasis_le_trans:
-    "\<lbrakk>ubasis_le a b; ubasis_le b c\<rbrakk> \<Longrightarrow> ubasis_le a c"
-| ubasis_le_lower:
-    "finite S \<Longrightarrow> ubasis_le a (node i a S)"
-| ubasis_le_upper:
-    "\<lbrakk>finite S; b \<in> S; ubasis_le a b\<rbrakk> \<Longrightarrow> ubasis_le (node i a S) b"
-
-lemma ubasis_le_minimal: "ubasis_le 0 x"
-apply (induct x rule: node_induct)
-apply (rule ubasis_le_refl)
-apply (erule ubasis_le_trans)
-apply (erule ubasis_le_lower)
-done
-
-interpretation udom: preorder ubasis_le
-apply default
-apply (rule ubasis_le_refl)
-apply (erule (1) ubasis_le_trans)
-done
-
-subsubsection {* Generic take function *}
-
-function
-  ubasis_until :: "(ubasis \<Rightarrow> bool) \<Rightarrow> ubasis \<Rightarrow> ubasis"
-where
-  "ubasis_until P 0 = 0"
-| "finite S \<Longrightarrow> ubasis_until P (node i a S) =
-    (if P (node i a S) then node i a S else ubasis_until P a)"
-    apply clarify
-    apply (rule_tac x=b in node_cases)
-     apply simp
-    apply simp
-    apply fast
-   apply simp
-  apply simp
- apply simp
-done
-
-termination ubasis_until
-apply (relation "measure snd")
-apply (rule wf_measure)
-apply (simp add: node_gt1)
-done
-
-lemma ubasis_until: "P 0 \<Longrightarrow> P (ubasis_until P x)"
-by (induct x rule: node_induct) simp_all
-
-lemma ubasis_until': "0 < ubasis_until P x \<Longrightarrow> P (ubasis_until P x)"
-by (induct x rule: node_induct) auto
-
-lemma ubasis_until_same: "P x \<Longrightarrow> ubasis_until P x = x"
-by (induct x rule: node_induct) simp_all
-
-lemma ubasis_until_idem:
-  "P 0 \<Longrightarrow> ubasis_until P (ubasis_until P x) = ubasis_until P x"
-by (rule ubasis_until_same [OF ubasis_until])
-
-lemma ubasis_until_0:
-  "\<forall>x. x \<noteq> 0 \<longrightarrow> \<not> P x \<Longrightarrow> ubasis_until P x = 0"
-by (induct x rule: node_induct) simp_all
-
-lemma ubasis_until_less: "ubasis_le (ubasis_until P x) x"
-apply (induct x rule: node_induct)
-apply (simp add: ubasis_le_refl)
-apply (simp add: ubasis_le_refl)
-apply (rule impI)
-apply (erule ubasis_le_trans)
-apply (erule ubasis_le_lower)
-done
-
-lemma ubasis_until_chain:
-  assumes PQ: "\<And>x. P x \<Longrightarrow> Q x"
-  shows "ubasis_le (ubasis_until P x) (ubasis_until Q x)"
-apply (induct x rule: node_induct)
-apply (simp add: ubasis_le_refl)
-apply (simp add: ubasis_le_refl)
-apply (simp add: PQ)
-apply clarify
-apply (rule ubasis_le_trans)
-apply (rule ubasis_until_less)
-apply (erule ubasis_le_lower)
-done
-
-lemma ubasis_until_mono:
-  assumes "\<And>i a S b. \<lbrakk>finite S; P (node i a S); b \<in> S; ubasis_le a b\<rbrakk> \<Longrightarrow> P b"
-  shows "ubasis_le a b \<Longrightarrow> ubasis_le (ubasis_until P a) (ubasis_until P b)"
-proof (induct set: ubasis_le)
-  case (ubasis_le_refl a) show ?case by (rule ubasis_le.ubasis_le_refl)
-next
-  case (ubasis_le_trans a b c) thus ?case by - (rule ubasis_le.ubasis_le_trans)
-next
-  case (ubasis_le_lower S a i) thus ?case
-    apply (clarsimp simp add: ubasis_le_refl)
-    apply (rule ubasis_le_trans [OF ubasis_until_less])
-    apply (erule ubasis_le.ubasis_le_lower)
-    done
-next
-  case (ubasis_le_upper S b a i) thus ?case
-    apply clarsimp
-    apply (subst ubasis_until_same)
-     apply (erule (3) prems)
-    apply (erule (2) ubasis_le.ubasis_le_upper)
-    done
-qed
-
-lemma finite_range_ubasis_until:
-  "finite {x. P x} \<Longrightarrow> finite (range (ubasis_until P))"
-apply (rule finite_subset [where B="insert 0 {x. P x}"])
-apply (clarsimp simp add: ubasis_until')
-apply simp
-done
-
-
-subsection {* Defining the universal domain by ideal completion *}
-
-typedef (open) udom = "{S. udom.ideal S}"
-by (fast intro: udom.ideal_principal)
-
-instantiation udom :: below
-begin
-
-definition
-  "x \<sqsubseteq> y \<longleftrightarrow> Rep_udom x \<subseteq> Rep_udom y"
-
-instance ..
-end
-
-instance udom :: po
-using type_definition_udom below_udom_def
-by (rule udom.typedef_ideal_po)
-
-instance udom :: cpo
-using type_definition_udom below_udom_def
-by (rule udom.typedef_ideal_cpo)
-
-definition
-  udom_principal :: "nat \<Rightarrow> udom" where
-  "udom_principal t = Abs_udom {u. ubasis_le u t}"
-
-lemma ubasis_countable: "\<exists>f::ubasis \<Rightarrow> nat. inj f"
-by (rule exI, rule inj_on_id)
-
-interpretation udom:
-  ideal_completion ubasis_le udom_principal Rep_udom
-using type_definition_udom below_udom_def
-using udom_principal_def ubasis_countable
-by (rule udom.typedef_ideal_completion)
-
-text {* Universal domain is pointed *}
-
-lemma udom_minimal: "udom_principal 0 \<sqsubseteq> x"
-apply (induct x rule: udom.principal_induct)
-apply (simp, simp add: ubasis_le_minimal)
-done
-
-instance udom :: pcpo
-by intro_classes (fast intro: udom_minimal)
-
-lemma inst_udom_pcpo: "\<bottom> = udom_principal 0"
-by (rule udom_minimal [THEN UU_I, symmetric])
-
-
-subsection {* Compact bases of domains *}
-
-typedef (open) 'a compact_basis = "{x::'a::pcpo. compact x}"
-by auto
-
-lemma compact_Rep_compact_basis: "compact (Rep_compact_basis a)"
-by (rule Rep_compact_basis [unfolded mem_Collect_eq])
-
-instantiation compact_basis :: (pcpo) below
-begin
-
-definition
-  compact_le_def:
-    "(op \<sqsubseteq>) \<equiv> (\<lambda>x y. Rep_compact_basis x \<sqsubseteq> Rep_compact_basis y)"
-
-instance ..
-end
-
-instance compact_basis :: (pcpo) po
-using type_definition_compact_basis compact_le_def
-by (rule typedef_po)
-
-definition
-  approximants :: "'a \<Rightarrow> 'a compact_basis set" where
-  "approximants = (\<lambda>x. {a. Rep_compact_basis a \<sqsubseteq> x})"
-
-definition
-  compact_bot :: "'a::pcpo compact_basis" where
-  "compact_bot = Abs_compact_basis \<bottom>"
-
-lemma Rep_compact_bot [simp]: "Rep_compact_basis compact_bot = \<bottom>"
-unfolding compact_bot_def by (simp add: Abs_compact_basis_inverse)
-
-lemma compact_bot_minimal [simp]: "compact_bot \<sqsubseteq> a"
-unfolding compact_le_def Rep_compact_bot by simp
-
-
-subsection {* Universality of \emph{udom} *}
-
-text {* We use a locale to parameterize the construction over a chain
-of approx functions on the type to be embedded. *}
-
-locale approx_chain =
-  fixes approx :: "nat \<Rightarrow> 'a::pcpo \<rightarrow> 'a"
-  assumes chain_approx [simp]: "chain (\<lambda>i. approx i)"
-  assumes lub_approx [simp]: "(\<Squnion>i. approx i) = ID"
-  assumes finite_deflation_approx: "\<And>i. finite_deflation (approx i)"
-begin
-
-subsubsection {* Choosing a maximal element from a finite set *}
-
-lemma finite_has_maximal:
-  fixes A :: "'a compact_basis set"
-  shows "\<lbrakk>finite A; A \<noteq> {}\<rbrakk> \<Longrightarrow> \<exists>x\<in>A. \<forall>y\<in>A. x \<sqsubseteq> y \<longrightarrow> x = y"
-proof (induct rule: finite_ne_induct)
-  case (singleton x)
-    show ?case by simp
-next
-  case (insert a A)
-  from `\<exists>x\<in>A. \<forall>y\<in>A. x \<sqsubseteq> y \<longrightarrow> x = y`
-  obtain x where x: "x \<in> A"
-           and x_eq: "\<And>y. \<lbrakk>y \<in> A; x \<sqsubseteq> y\<rbrakk> \<Longrightarrow> x = y" by fast
-  show ?case
-  proof (intro bexI ballI impI)
-    fix y
-    assume "y \<in> insert a A" and "(if x \<sqsubseteq> a then a else x) \<sqsubseteq> y"
-    thus "(if x \<sqsubseteq> a then a else x) = y"
-      apply auto
-      apply (frule (1) below_trans)
-      apply (frule (1) x_eq)
-      apply (rule below_antisym, assumption)
-      apply simp
-      apply (erule (1) x_eq)
-      done
-  next
-    show "(if x \<sqsubseteq> a then a else x) \<in> insert a A"
-      by (simp add: x)
-  qed
-qed
-
-definition
-  choose :: "'a compact_basis set \<Rightarrow> 'a compact_basis"
-where
-  "choose A = (SOME x. x \<in> {x\<in>A. \<forall>y\<in>A. x \<sqsubseteq> y \<longrightarrow> x = y})"
-
-lemma choose_lemma:
-  "\<lbrakk>finite A; A \<noteq> {}\<rbrakk> \<Longrightarrow> choose A \<in> {x\<in>A. \<forall>y\<in>A. x \<sqsubseteq> y \<longrightarrow> x = y}"
-unfolding choose_def
-apply (rule someI_ex)
-apply (frule (1) finite_has_maximal, fast)
-done
-
-lemma maximal_choose:
-  "\<lbrakk>finite A; y \<in> A; choose A \<sqsubseteq> y\<rbrakk> \<Longrightarrow> choose A = y"
-apply (cases "A = {}", simp)
-apply (frule (1) choose_lemma, simp)
-done
-
-lemma choose_in: "\<lbrakk>finite A; A \<noteq> {}\<rbrakk> \<Longrightarrow> choose A \<in> A"
-by (frule (1) choose_lemma, simp)
-
-function
-  choose_pos :: "'a compact_basis set \<Rightarrow> 'a compact_basis \<Rightarrow> nat"
-where
-  "choose_pos A x =
-    (if finite A \<and> x \<in> A \<and> x \<noteq> choose A
-      then Suc (choose_pos (A - {choose A}) x) else 0)"
-by auto
-
-termination choose_pos
-apply (relation "measure (card \<circ> fst)", simp)
-apply clarsimp
-apply (rule card_Diff1_less)
-apply assumption
-apply (erule choose_in)
-apply clarsimp
-done
-
-declare choose_pos.simps [simp del]
-
-lemma choose_pos_choose: "finite A \<Longrightarrow> choose_pos A (choose A) = 0"
-by (simp add: choose_pos.simps)
-
-lemma inj_on_choose_pos [OF refl]:
-  "\<lbrakk>card A = n; finite A\<rbrakk> \<Longrightarrow> inj_on (choose_pos A) A"
- apply (induct n arbitrary: A)
-  apply simp
- apply (case_tac "A = {}", simp)
- apply (frule (1) choose_in)
- apply (rule inj_onI)
- apply (drule_tac x="A - {choose A}" in meta_spec, simp)
- apply (simp add: choose_pos.simps)
- apply (simp split: split_if_asm)
- apply (erule (1) inj_onD, simp, simp)
-done
-
-lemma choose_pos_bounded [OF refl]:
-  "\<lbrakk>card A = n; finite A; x \<in> A\<rbrakk> \<Longrightarrow> choose_pos A x < n"
-apply (induct n arbitrary: A)
-apply simp
- apply (case_tac "A = {}", simp)
- apply (frule (1) choose_in)
-apply (subst choose_pos.simps)
-apply simp
-done
-
-lemma choose_pos_lessD:
-  "\<lbrakk>choose_pos A x < choose_pos A y; finite A; x \<in> A; y \<in> A\<rbrakk> \<Longrightarrow> \<not> x \<sqsubseteq> y"
- apply (induct A x arbitrary: y rule: choose_pos.induct)
- apply simp
- apply (case_tac "x = choose A")
-  apply simp
-  apply (rule notI)
-  apply (frule (2) maximal_choose)
-  apply simp
- apply (case_tac "y = choose A")
-  apply (simp add: choose_pos_choose)
- apply (drule_tac x=y in meta_spec)
- apply simp
- apply (erule meta_mp)
- apply (simp add: choose_pos.simps)
-done
-
-subsubsection {* Properties of approx function *}
-
-lemma deflation_approx: "deflation (approx i)"
-using finite_deflation_approx by (rule finite_deflation_imp_deflation)
-
-lemma approx_idem: "approx i\<cdot>(approx i\<cdot>x) = approx i\<cdot>x"
-using deflation_approx by (rule deflation.idem)
-
-lemma approx_below: "approx i\<cdot>x \<sqsubseteq> x"
-using deflation_approx by (rule deflation.below)
-
-lemma finite_range_approx: "finite (range (\<lambda>x. approx i\<cdot>x))"
-apply (rule finite_deflation.finite_range)
-apply (rule finite_deflation_approx)
-done
-
-lemma compact_approx: "compact (approx n\<cdot>x)"
-apply (rule finite_deflation.compact)
-apply (rule finite_deflation_approx)
-done
-
-lemma compact_eq_approx: "compact x \<Longrightarrow> \<exists>i. approx i\<cdot>x = x"
-by (rule admD2, simp_all)
-
-subsubsection {* Compact basis take function *}
-
-primrec
-  cb_take :: "nat \<Rightarrow> 'a compact_basis \<Rightarrow> 'a compact_basis" where
-  "cb_take 0 = (\<lambda>x. compact_bot)"
-| "cb_take (Suc n) = (\<lambda>a. Abs_compact_basis (approx n\<cdot>(Rep_compact_basis a)))"
-
-declare cb_take.simps [simp del]
-
-lemma cb_take_zero [simp]: "cb_take 0 a = compact_bot"
-by (simp only: cb_take.simps)
-
-lemma Rep_cb_take:
-  "Rep_compact_basis (cb_take (Suc n) a) = approx n\<cdot>(Rep_compact_basis a)"
-by (simp add: Abs_compact_basis_inverse cb_take.simps(2) compact_approx)
-
-lemmas approx_Rep_compact_basis = Rep_cb_take [symmetric]
-
-lemma cb_take_covers: "\<exists>n. cb_take n x = x"
-apply (subgoal_tac "\<exists>n. cb_take (Suc n) x = x", fast)
-apply (simp add: Rep_compact_basis_inject [symmetric])
-apply (simp add: Rep_cb_take)
-apply (rule compact_eq_approx)
-apply (rule compact_Rep_compact_basis)
-done
-
-lemma cb_take_less: "cb_take n x \<sqsubseteq> x"
-unfolding compact_le_def
-by (cases n, simp, simp add: Rep_cb_take approx_below)
-
-lemma cb_take_idem: "cb_take n (cb_take n x) = cb_take n x"
-unfolding Rep_compact_basis_inject [symmetric]
-by (cases n, simp, simp add: Rep_cb_take approx_idem)
-
-lemma cb_take_mono: "x \<sqsubseteq> y \<Longrightarrow> cb_take n x \<sqsubseteq> cb_take n y"
-unfolding compact_le_def
-by (cases n, simp, simp add: Rep_cb_take monofun_cfun_arg)
-
-lemma cb_take_chain_le: "m \<le> n \<Longrightarrow> cb_take m x \<sqsubseteq> cb_take n x"
-unfolding compact_le_def
-apply (cases m, simp, cases n, simp)
-apply (simp add: Rep_cb_take, rule chain_mono, simp, simp)
-done
-
-lemma finite_range_cb_take: "finite (range (cb_take n))"
-apply (cases n)
-apply (subgoal_tac "range (cb_take 0) = {compact_bot}", simp, force)
-apply (rule finite_imageD [where f="Rep_compact_basis"])
-apply (rule finite_subset [where B="range (\<lambda>x. approx (n - 1)\<cdot>x)"])
-apply (clarsimp simp add: Rep_cb_take)
-apply (rule finite_range_approx)
-apply (rule inj_onI, simp add: Rep_compact_basis_inject)
-done
-
-subsubsection {* Rank of basis elements *}
-
-definition
-  rank :: "'a compact_basis \<Rightarrow> nat"
-where
-  "rank x = (LEAST n. cb_take n x = x)"
-
-lemma compact_approx_rank: "cb_take (rank x) x = x"
-unfolding rank_def
-apply (rule LeastI_ex)
-apply (rule cb_take_covers)
-done
-
-lemma rank_leD: "rank x \<le> n \<Longrightarrow> cb_take n x = x"
-apply (rule below_antisym [OF cb_take_less])
-apply (subst compact_approx_rank [symmetric])
-apply (erule cb_take_chain_le)
-done
-
-lemma rank_leI: "cb_take n x = x \<Longrightarrow> rank x \<le> n"
-unfolding rank_def by (rule Least_le)
-
-lemma rank_le_iff: "rank x \<le> n \<longleftrightarrow> cb_take n x = x"
-by (rule iffI [OF rank_leD rank_leI])
-
-lemma rank_compact_bot [simp]: "rank compact_bot = 0"
-using rank_leI [of 0 compact_bot] by simp
-
-lemma rank_eq_0_iff [simp]: "rank x = 0 \<longleftrightarrow> x = compact_bot"
-using rank_le_iff [of x 0] by auto
-
-definition
-  rank_le :: "'a compact_basis \<Rightarrow> 'a compact_basis set"
-where
-  "rank_le x = {y. rank y \<le> rank x}"
-
-definition
-  rank_lt :: "'a compact_basis \<Rightarrow> 'a compact_basis set"
-where
-  "rank_lt x = {y. rank y < rank x}"
-
-definition
-  rank_eq :: "'a compact_basis \<Rightarrow> 'a compact_basis set"
-where
-  "rank_eq x = {y. rank y = rank x}"
-
-lemma rank_eq_cong: "rank x = rank y \<Longrightarrow> rank_eq x = rank_eq y"
-unfolding rank_eq_def by simp
-
-lemma rank_lt_cong: "rank x = rank y \<Longrightarrow> rank_lt x = rank_lt y"
-unfolding rank_lt_def by simp
-
-lemma rank_eq_subset: "rank_eq x \<subseteq> rank_le x"
-unfolding rank_eq_def rank_le_def by auto
-
-lemma rank_lt_subset: "rank_lt x \<subseteq> rank_le x"
-unfolding rank_lt_def rank_le_def by auto
-
-lemma finite_rank_le: "finite (rank_le x)"
-unfolding rank_le_def
-apply (rule finite_subset [where B="range (cb_take (rank x))"])
-apply clarify
-apply (rule range_eqI)
-apply (erule rank_leD [symmetric])
-apply (rule finite_range_cb_take)
-done
-
-lemma finite_rank_eq: "finite (rank_eq x)"
-by (rule finite_subset [OF rank_eq_subset finite_rank_le])
-
-lemma finite_rank_lt: "finite (rank_lt x)"
-by (rule finite_subset [OF rank_lt_subset finite_rank_le])
-
-lemma rank_lt_Int_rank_eq: "rank_lt x \<inter> rank_eq x = {}"
-unfolding rank_lt_def rank_eq_def rank_le_def by auto
-
-lemma rank_lt_Un_rank_eq: "rank_lt x \<union> rank_eq x = rank_le x"
-unfolding rank_lt_def rank_eq_def rank_le_def by auto
-
-subsubsection {* Sequencing basis elements *}
-
-definition
-  place :: "'a compact_basis \<Rightarrow> nat"
-where
-  "place x = card (rank_lt x) + choose_pos (rank_eq x) x"
-
-lemma place_bounded: "place x < card (rank_le x)"
-unfolding place_def
- apply (rule ord_less_eq_trans)
-  apply (rule add_strict_left_mono)
-  apply (rule choose_pos_bounded)
-   apply (rule finite_rank_eq)
-  apply (simp add: rank_eq_def)
- apply (subst card_Un_disjoint [symmetric])
-    apply (rule finite_rank_lt)
-   apply (rule finite_rank_eq)
-  apply (rule rank_lt_Int_rank_eq)
- apply (simp add: rank_lt_Un_rank_eq)
-done
-
-lemma place_ge: "card (rank_lt x) \<le> place x"
-unfolding place_def by simp
-
-lemma place_rank_mono:
-  fixes x y :: "'a compact_basis"
-  shows "rank x < rank y \<Longrightarrow> place x < place y"
-apply (rule less_le_trans [OF place_bounded])
-apply (rule order_trans [OF _ place_ge])
-apply (rule card_mono)
-apply (rule finite_rank_lt)
-apply (simp add: rank_le_def rank_lt_def subset_eq)
-done
-
-lemma place_eqD: "place x = place y \<Longrightarrow> x = y"
- apply (rule linorder_cases [where x="rank x" and y="rank y"])
-   apply (drule place_rank_mono, simp)
-  apply (simp add: place_def)
-  apply (rule inj_on_choose_pos [where A="rank_eq x", THEN inj_onD])
-     apply (rule finite_rank_eq)
-    apply (simp cong: rank_lt_cong rank_eq_cong)
-   apply (simp add: rank_eq_def)
-  apply (simp add: rank_eq_def)
- apply (drule place_rank_mono, simp)
-done
-
-lemma inj_place: "inj place"
-by (rule inj_onI, erule place_eqD)
-
-subsubsection {* Embedding and projection on basis elements *}
-
-definition
-  sub :: "'a compact_basis \<Rightarrow> 'a compact_basis"
-where
-  "sub x = (case rank x of 0 \<Rightarrow> compact_bot | Suc k \<Rightarrow> cb_take k x)"
-
-lemma rank_sub_less: "x \<noteq> compact_bot \<Longrightarrow> rank (sub x) < rank x"
-unfolding sub_def
-apply (cases "rank x", simp)
-apply (simp add: less_Suc_eq_le)
-apply (rule rank_leI)
-apply (rule cb_take_idem)
-done
-
-lemma place_sub_less: "x \<noteq> compact_bot \<Longrightarrow> place (sub x) < place x"
-apply (rule place_rank_mono)
-apply (erule rank_sub_less)
-done
-
-lemma sub_below: "sub x \<sqsubseteq> x"
-unfolding sub_def by (cases "rank x", simp_all add: cb_take_less)
-
-lemma rank_less_imp_below_sub: "\<lbrakk>x \<sqsubseteq> y; rank x < rank y\<rbrakk> \<Longrightarrow> x \<sqsubseteq> sub y"
-unfolding sub_def
-apply (cases "rank y", simp)
-apply (simp add: less_Suc_eq_le)
-apply (subgoal_tac "cb_take nat x \<sqsubseteq> cb_take nat y")
-apply (simp add: rank_leD)
-apply (erule cb_take_mono)
-done
-
-function
-  basis_emb :: "'a compact_basis \<Rightarrow> ubasis"
-where
-  "basis_emb x = (if x = compact_bot then 0 else
-    node (place x) (basis_emb (sub x))
-      (basis_emb ` {y. place y < place x \<and> x \<sqsubseteq> y}))"
-by auto
-
-termination basis_emb
-apply (relation "measure place", simp)
-apply (simp add: place_sub_less)
-apply simp
-done
-
-declare basis_emb.simps [simp del]
-
-lemma basis_emb_compact_bot [simp]: "basis_emb compact_bot = 0"
-by (simp add: basis_emb.simps)
-
-lemma fin1: "finite {y. place y < place x \<and> x \<sqsubseteq> y}"
-apply (subst Collect_conj_eq)
-apply (rule finite_Int)
-apply (rule disjI1)
-apply (subgoal_tac "finite (place -` {n. n < place x})", simp)
-apply (rule finite_vimageI [OF _ inj_place])
-apply (simp add: lessThan_def [symmetric])
-done
-
-lemma fin2: "finite (basis_emb ` {y. place y < place x \<and> x \<sqsubseteq> y})"
-by (rule finite_imageI [OF fin1])
-
-lemma rank_place_mono:
-  "\<lbrakk>place x < place y; x \<sqsubseteq> y\<rbrakk> \<Longrightarrow> rank x < rank y"
-apply (rule linorder_cases, assumption)
-apply (simp add: place_def cong: rank_lt_cong rank_eq_cong)
-apply (drule choose_pos_lessD)
-apply (rule finite_rank_eq)
-apply (simp add: rank_eq_def)
-apply (simp add: rank_eq_def)
-apply simp
-apply (drule place_rank_mono, simp)
-done
-
-lemma basis_emb_mono:
-  "x \<sqsubseteq> y \<Longrightarrow> ubasis_le (basis_emb x) (basis_emb y)"
-proof (induct "max (place x) (place y)" arbitrary: x y rule: less_induct)
-  case less
-  show ?case proof (rule linorder_cases)
-    assume "place x < place y"
-    then have "rank x < rank y"
-      using `x \<sqsubseteq> y` by (rule rank_place_mono)
-    with `place x < place y` show ?case
-      apply (case_tac "y = compact_bot", simp)
-      apply (simp add: basis_emb.simps [of y])
-      apply (rule ubasis_le_trans [OF _ ubasis_le_lower [OF fin2]])
-      apply (rule less)
-       apply (simp add: less_max_iff_disj)
-       apply (erule place_sub_less)
-      apply (erule rank_less_imp_below_sub [OF `x \<sqsubseteq> y`])
-      done
-  next
-    assume "place x = place y"
-    hence "x = y" by (rule place_eqD)
-    thus ?case by (simp add: ubasis_le_refl)
-  next
-    assume "place x > place y"
-    with `x \<sqsubseteq> y` show ?case
-      apply (case_tac "x = compact_bot", simp add: ubasis_le_minimal)
-      apply (simp add: basis_emb.simps [of x])
-      apply (rule ubasis_le_upper [OF fin2], simp)
-      apply (rule less)
-       apply (simp add: less_max_iff_disj)
-       apply (erule place_sub_less)
-      apply (erule rev_below_trans)
-      apply (rule sub_below)
-      done
-  qed
-qed
-
-lemma inj_basis_emb: "inj basis_emb"
- apply (rule inj_onI)
- apply (case_tac "x = compact_bot")
-  apply (case_tac [!] "y = compact_bot")
-    apply simp
-   apply (simp add: basis_emb.simps)
-  apply (simp add: basis_emb.simps)
- apply (simp add: basis_emb.simps)
- apply (simp add: fin2 inj_eq [OF inj_place])
-done
-
-definition
-  basis_prj :: "ubasis \<Rightarrow> 'a compact_basis"
-where
-  "basis_prj x = inv basis_emb
-    (ubasis_until (\<lambda>x. x \<in> range (basis_emb :: 'a compact_basis \<Rightarrow> ubasis)) x)"
-
-lemma basis_prj_basis_emb: "\<And>x. basis_prj (basis_emb x) = x"
-unfolding basis_prj_def
- apply (subst ubasis_until_same)
-  apply (rule rangeI)
- apply (rule inv_f_f)
- apply (rule inj_basis_emb)
-done
-
-lemma basis_prj_node:
-  "\<lbrakk>finite S; node i a S \<notin> range (basis_emb :: 'a compact_basis \<Rightarrow> nat)\<rbrakk>
-    \<Longrightarrow> basis_prj (node i a S) = (basis_prj a :: 'a compact_basis)"
-unfolding basis_prj_def by simp
-
-lemma basis_prj_0: "basis_prj 0 = compact_bot"
-apply (subst basis_emb_compact_bot [symmetric])
-apply (rule basis_prj_basis_emb)
-done
-
-lemma node_eq_basis_emb_iff:
-  "finite S \<Longrightarrow> node i a S = basis_emb x \<longleftrightarrow>
-    x \<noteq> compact_bot \<and> i = place x \<and> a = basis_emb (sub x) \<and>
-        S = basis_emb ` {y. place y < place x \<and> x \<sqsubseteq> y}"
-apply (cases "x = compact_bot", simp)
-apply (simp add: basis_emb.simps [of x])
-apply (simp add: fin2)
-done
-
-lemma basis_prj_mono: "ubasis_le a b \<Longrightarrow> basis_prj a \<sqsubseteq> basis_prj b"
-proof (induct a b rule: ubasis_le.induct)
-  case (ubasis_le_refl a) show ?case by (rule below_refl)
-next
-  case (ubasis_le_trans a b c) thus ?case by - (rule below_trans)
-next
-  case (ubasis_le_lower S a i) thus ?case
-    apply (cases "node i a S \<in> range (basis_emb :: 'a compact_basis \<Rightarrow> nat)")
-     apply (erule rangeE, rename_tac x)
-     apply (simp add: basis_prj_basis_emb)
-     apply (simp add: node_eq_basis_emb_iff)
-     apply (simp add: basis_prj_basis_emb)
-     apply (rule sub_below)
-    apply (simp add: basis_prj_node)
-    done
-next
-  case (ubasis_le_upper S b a i) thus ?case
-    apply (cases "node i a S \<in> range (basis_emb :: 'a compact_basis \<Rightarrow> nat)")
-     apply (erule rangeE, rename_tac x)
-     apply (simp add: basis_prj_basis_emb)
-     apply (clarsimp simp add: node_eq_basis_emb_iff)
-     apply (simp add: basis_prj_basis_emb)
-    apply (simp add: basis_prj_node)
-    done
-qed
-
-lemma basis_emb_prj_less: "ubasis_le (basis_emb (basis_prj x)) x"
-unfolding basis_prj_def
- apply (subst f_inv_into_f [where f=basis_emb])
-  apply (rule ubasis_until)
-  apply (rule range_eqI [where x=compact_bot])
-  apply simp
- apply (rule ubasis_until_less)
-done
-
-end
-
-sublocale approx_chain \<subseteq> compact_basis!:
-  ideal_completion below Rep_compact_basis
-    "approximants :: 'a \<Rightarrow> 'a compact_basis set"
-proof
-  fix w :: "'a"
-  show "below.ideal (approximants w)"
-  proof (rule below.idealI)
-    show "\<exists>x. x \<in> approximants w"
-      unfolding approximants_def
-      apply (rule_tac x="Abs_compact_basis (approx 0\<cdot>w)" in exI)
-      apply (simp add: Abs_compact_basis_inverse approx_below compact_approx)
-      done
-  next
-    fix x y :: "'a compact_basis"
-    assume "x \<in> approximants w" "y \<in> approximants w"
-    thus "\<exists>z \<in> approximants w. x \<sqsubseteq> z \<and> y \<sqsubseteq> z"
-      unfolding approximants_def
-      apply simp
-      apply (cut_tac a=x in compact_Rep_compact_basis)
-      apply (cut_tac a=y in compact_Rep_compact_basis)
-      apply (drule compact_eq_approx)
-      apply (drule compact_eq_approx)
-      apply (clarify, rename_tac i j)
-      apply (rule_tac x="Abs_compact_basis (approx (max i j)\<cdot>w)" in exI)
-      apply (simp add: compact_le_def)
-      apply (simp add: Abs_compact_basis_inverse approx_below compact_approx)
-      apply (erule subst, erule subst)
-      apply (simp add: monofun_cfun chain_mono [OF chain_approx])
-      done
-  next
-    fix x y :: "'a compact_basis"
-    assume "x \<sqsubseteq> y" "y \<in> approximants w" thus "x \<in> approximants w"
-      unfolding approximants_def
-      apply simp
-      apply (simp add: compact_le_def)
-      apply (erule (1) below_trans)
-      done
-  qed
-next
-  fix Y :: "nat \<Rightarrow> 'a"
-  assume Y: "chain Y"
-  show "approximants (\<Squnion>i. Y i) = (\<Union>i. approximants (Y i))"
-    unfolding approximants_def
-    apply safe
-    apply (simp add: compactD2 [OF compact_Rep_compact_basis Y])
-    apply (erule below_lub [OF Y])
-    done
-next
-  fix a :: "'a compact_basis"
-  show "approximants (Rep_compact_basis a) = {b. b \<sqsubseteq> a}"
-    unfolding approximants_def compact_le_def ..
-next
-  fix x y :: "'a"
-  assume "approximants x \<subseteq> approximants y" thus "x \<sqsubseteq> y"
-    apply (subgoal_tac "(\<Squnion>i. approx i\<cdot>x) \<sqsubseteq> y")
-    apply (simp add: lub_distribs)
-    apply (rule admD, simp, simp)
-    apply (drule_tac c="Abs_compact_basis (approx i\<cdot>x)" in subsetD)
-    apply (simp add: approximants_def Abs_compact_basis_inverse
-                     approx_below compact_approx)
-    apply (simp add: approximants_def Abs_compact_basis_inverse compact_approx)
-    done
-next
-  show "\<exists>f::'a compact_basis \<Rightarrow> nat. inj f"
-    by (rule exI, rule inj_place)
-qed
-
-subsubsection {* EP-pair from any bifinite domain into \emph{udom} *}
-
-context approx_chain begin
-
-definition
-  udom_emb :: "'a \<rightarrow> udom"
-where
-  "udom_emb = compact_basis.basis_fun (\<lambda>x. udom_principal (basis_emb x))"
-
-definition
-  udom_prj :: "udom \<rightarrow> 'a"
-where
-  "udom_prj = udom.basis_fun (\<lambda>x. Rep_compact_basis (basis_prj x))"
-
-lemma udom_emb_principal:
-  "udom_emb\<cdot>(Rep_compact_basis x) = udom_principal (basis_emb x)"
-unfolding udom_emb_def
-apply (rule compact_basis.basis_fun_principal)
-apply (rule udom.principal_mono)
-apply (erule basis_emb_mono)
-done
-
-lemma udom_prj_principal:
-  "udom_prj\<cdot>(udom_principal x) = Rep_compact_basis (basis_prj x)"
-unfolding udom_prj_def
-apply (rule udom.basis_fun_principal)
-apply (rule compact_basis.principal_mono)
-apply (erule basis_prj_mono)
-done
-
-lemma ep_pair_udom: "ep_pair udom_emb udom_prj"
- apply default
-  apply (rule compact_basis.principal_induct, simp)
-  apply (simp add: udom_emb_principal udom_prj_principal)
-  apply (simp add: basis_prj_basis_emb)
- apply (rule udom.principal_induct, simp)
- apply (simp add: udom_emb_principal udom_prj_principal)
- apply (rule basis_emb_prj_less)
-done
-
-end
-
-abbreviation "udom_emb \<equiv> approx_chain.udom_emb"
-abbreviation "udom_prj \<equiv> approx_chain.udom_prj"
-
-lemmas ep_pair_udom = approx_chain.ep_pair_udom
-
-subsection {* Chain of approx functions for type \emph{udom} *}
-
-definition
-  udom_approx :: "nat \<Rightarrow> udom \<rightarrow> udom"
-where
-  "udom_approx i =
-    udom.basis_fun (\<lambda>x. udom_principal (ubasis_until (\<lambda>y. y \<le> i) x))"
-
-lemma udom_approx_mono:
-  "ubasis_le a b \<Longrightarrow>
-    udom_principal (ubasis_until (\<lambda>y. y \<le> i) a) \<sqsubseteq>
-    udom_principal (ubasis_until (\<lambda>y. y \<le> i) b)"
-apply (rule udom.principal_mono)
-apply (rule ubasis_until_mono)
-apply (frule (2) order_less_le_trans [OF node_gt2])
-apply (erule order_less_imp_le)
-apply assumption
-done
-
-lemma adm_mem_finite: "\<lbrakk>cont f; finite S\<rbrakk> \<Longrightarrow> adm (\<lambda>x. f x \<in> S)"
-by (erule adm_subst, induct set: finite, simp_all)
-
-lemma udom_approx_principal:
-  "udom_approx i\<cdot>(udom_principal x) =
-    udom_principal (ubasis_until (\<lambda>y. y \<le> i) x)"
-unfolding udom_approx_def
-apply (rule udom.basis_fun_principal)
-apply (erule udom_approx_mono)
-done
-
-lemma finite_deflation_udom_approx: "finite_deflation (udom_approx i)"
-proof
-  fix x show "udom_approx i\<cdot>(udom_approx i\<cdot>x) = udom_approx i\<cdot>x"
-    by (induct x rule: udom.principal_induct, simp)
-       (simp add: udom_approx_principal ubasis_until_idem)
-next
-  fix x show "udom_approx i\<cdot>x \<sqsubseteq> x"
-    by (induct x rule: udom.principal_induct, simp)
-       (simp add: udom_approx_principal ubasis_until_less)
-next
-  have *: "finite (range (\<lambda>x. udom_principal (ubasis_until (\<lambda>y. y \<le> i) x)))"
-    apply (subst range_composition [where f=udom_principal])
-    apply (simp add: finite_range_ubasis_until)
-    done
-  show "finite {x. udom_approx i\<cdot>x = x}"
-    apply (rule finite_range_imp_finite_fixes)
-    apply (rule rev_finite_subset [OF *])
-    apply (clarsimp, rename_tac x)
-    apply (induct_tac x rule: udom.principal_induct)
-    apply (simp add: adm_mem_finite *)
-    apply (simp add: udom_approx_principal)
-    done
-qed
-
-interpretation udom_approx: finite_deflation "udom_approx i"
-by (rule finite_deflation_udom_approx)
-
-lemma chain_udom_approx [simp]: "chain (\<lambda>i. udom_approx i)"
-unfolding udom_approx_def
-apply (rule chainI)
-apply (rule udom.basis_fun_mono)
-apply (erule udom_approx_mono)
-apply (erule udom_approx_mono)
-apply (rule udom.principal_mono)
-apply (rule ubasis_until_chain, simp)
-done
-
-lemma lub_udom_approx [simp]: "(\<Squnion>i. udom_approx i) = ID"
-apply (rule cfun_eqI, simp add: contlub_cfun_fun)
-apply (rule below_antisym)
-apply (rule lub_below)
-apply (simp)
-apply (rule udom_approx.below)
-apply (rule_tac x=x in udom.principal_induct)
-apply (simp add: lub_distribs)
-apply (rule_tac i=a in below_lub)
-apply simp
-apply (simp add: udom_approx_principal)
-apply (simp add: ubasis_until_same ubasis_le_refl)
-done
- 
-lemma udom_approx: "approx_chain udom_approx"
-proof
-  show "chain (\<lambda>i. udom_approx i)"
-    by (rule chain_udom_approx)
-  show "(\<Squnion>i. udom_approx i) = ID"
-    by (rule lub_udom_approx)
-qed
-
-hide_const (open) node
-
-end

--- a/src/HOLCF/Up.thy	Sat Nov 27 14:34:54 2010 -0800
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,263 +0,0 @@
-(*  Title:      HOLCF/Up.thy
-    Author:     Franz Regensburger
-    Author:     Brian Huffman
-*)
-
-header {* The type of lifted values *}
-
-theory Up
-imports Cfun
-begin
-
-default_sort cpo
-
-subsection {* Definition of new type for lifting *}
-
-datatype 'a u = Ibottom | Iup 'a
-
-type_notation (xsymbols)
-  u  ("(_\<^sub>\<bottom>)" [1000] 999)
-
-primrec Ifup :: "('a \<rightarrow> 'b::pcpo) \<Rightarrow> 'a u \<Rightarrow> 'b" where
-    "Ifup f Ibottom = \<bottom>"
- |  "Ifup f (Iup x) = f\<cdot>x"
-
-subsection {* Ordering on lifted cpo *}
-
-instantiation u :: (cpo) below
-begin
-
-definition
-  below_up_def:
-    "(op \<sqsubseteq>) \<equiv> (\<lambda>x y. case x of Ibottom \<Rightarrow> True | Iup a \<Rightarrow>
-      (case y of Ibottom \<Rightarrow> False | Iup b \<Rightarrow> a \<sqsubseteq> b))"
-
-instance ..
-end
-
-lemma minimal_up [iff]: "Ibottom \<sqsubseteq> z"
-by (simp add: below_up_def)
-
-lemma not_Iup_below [iff]: "\<not> Iup x \<sqsubseteq> Ibottom"
-by (simp add: below_up_def)
-
-lemma Iup_below [iff]: "(Iup x \<sqsubseteq> Iup y) = (x \<sqsubseteq> y)"
-by (simp add: below_up_def)
-
-subsection {* Lifted cpo is a partial order *}
-
-instance u :: (cpo) po
-proof
-  fix x :: "'a u"
-  show "x \<sqsubseteq> x"
-    unfolding below_up_def by (simp split: u.split)
-next
-  fix x y :: "'a u"
-  assume "x \<sqsubseteq> y" "y \<sqsubseteq> x" thus "x = y"
-    unfolding below_up_def
-    by (auto split: u.split_asm intro: below_antisym)
-next
-  fix x y z :: "'a u"
-  assume "x \<sqsubseteq> y" "y \<sqsubseteq> z" thus "x \<sqsubseteq> z"
-    unfolding below_up_def
-    by (auto split: u.split_asm intro: below_trans)
-qed
-
-subsection {* Lifted cpo is a cpo *}
-
-lemma is_lub_Iup:
-  "range S <<| x \<Longrightarrow> range (\<lambda>i. Iup (S i)) <<| Iup x"
-unfolding is_lub_def is_ub_def ball_simps
-by (auto simp add: below_up_def split: u.split)
-
-lemma up_chain_lemma:
-  assumes Y: "chain Y" obtains "\<forall>i. Y i = Ibottom"
-  | A k where "\<forall>i. Iup (A i) = Y (i + k)" and "chain A" and "range Y <<| Iup (\<Squnion>i. A i)"
-proof (cases "\<exists>k. Y k \<noteq> Ibottom")
-  case True
-  then obtain k where k: "Y k \<noteq> Ibottom" ..
-  def A \<equiv> "\<lambda>i. THE a. Iup a = Y (i + k)"
-  have Iup_A: "\<forall>i. Iup (A i) = Y (i + k)"
-  proof
-    fix i :: nat
-    from Y le_add2 have "Y k \<sqsubseteq> Y (i + k)" by (rule chain_mono)
-    with k have "Y (i + k) \<noteq> Ibottom" by (cases "Y k", auto)
-    thus "Iup (A i) = Y (i + k)"
-      by (cases "Y (i + k)", simp_all add: A_def)
-  qed
-  from Y have chain_A: "chain A"
-    unfolding chain_def Iup_below [symmetric]
-    by (simp add: Iup_A)
-  hence "range A <<| (\<Squnion>i. A i)"
-    by (rule cpo_lubI)
-  hence "range (\<lambda>i. Iup (A i)) <<| Iup (\<Squnion>i. A i)"
-    by (rule is_lub_Iup)
-  hence "range (\<lambda>i. Y (i + k)) <<| Iup (\<Squnion>i. A i)"
-    by (simp only: Iup_A)
-  hence "range (\<lambda>i. Y i) <<| Iup (\<Squnion>i. A i)"
-    by (simp only: is_lub_range_shift [OF Y])
-  with Iup_A chain_A show ?thesis ..
-next
-  case False
-  then have "\<forall>i. Y i = Ibottom" by simp
-  then show ?thesis ..
-qed
-
-instance u :: (cpo) cpo
-proof
-  fix S :: "nat \<Rightarrow> 'a u"
-  assume S: "chain S"
-  thus "\<exists>x. range (\<lambda>i. S i) <<| x"
-  proof (rule up_chain_lemma)
-    assume "\<forall>i. S i = Ibottom"
-    hence "range (\<lambda>i. S i) <<| Ibottom"
-      by (simp add: is_lub_const)
-    thus ?thesis ..
-  next
-    fix A :: "nat \<Rightarrow> 'a"
-    assume "range S <<| Iup (\<Squnion>i. A i)"
-    thus ?thesis ..
-  qed
-qed
-
-subsection {* Lifted cpo is pointed *}
-
-instance u :: (cpo) pcpo
-by intro_classes fast
-
-text {* for compatibility with old HOLCF-Version *}
-lemma inst_up_pcpo: "\<bottom> = Ibottom"
-by (rule minimal_up [THEN UU_I, symmetric])
-
-subsection {* Continuity of \emph{Iup} and \emph{Ifup} *}
-
-text {* continuity for @{term Iup} *}
-
-lemma cont_Iup: "cont Iup"
-apply (rule contI)
-apply (rule is_lub_Iup)
-apply (erule cpo_lubI)
-done
-
-text {* continuity for @{term Ifup} *}
-
-lemma cont_Ifup1: "cont (\<lambda>f. Ifup f x)"
-by (induct x, simp_all)
-
-lemma monofun_Ifup2: "monofun (\<lambda>x. Ifup f x)"
-apply (rule monofunI)
-apply (case_tac x, simp)
-apply (case_tac y, simp)
-apply (simp add: monofun_cfun_arg)
-done
-
-lemma cont_Ifup2: "cont (\<lambda>x. Ifup f x)"
-proof (rule contI2)
-  fix Y assume Y: "chain Y" and Y': "chain (\<lambda>i. Ifup f (Y i))"
-  from Y show "Ifup f (\<Squnion>i. Y i) \<sqsubseteq> (\<Squnion>i. Ifup f (Y i))"
-  proof (rule up_chain_lemma)
-    fix A and k
-    assume A: "\<forall>i. Iup (A i) = Y (i + k)"
-    assume "chain A" and "range Y <<| Iup (\<Squnion>i. A i)"
-    hence "Ifup f (\<Squnion>i. Y i) = (\<Squnion>i. Ifup f (Iup (A i)))"
-      by (simp add: lub_eqI contlub_cfun_arg)
-    also have "\<dots> = (\<Squnion>i. Ifup f (Y (i + k)))"
-      by (simp add: A)
-    also have "\<dots> = (\<Squnion>i. Ifup f (Y i))"
-      using Y' by (rule lub_range_shift)
-    finally show ?thesis by simp
-  qed simp
-qed (rule monofun_Ifup2)
-
-subsection {* Continuous versions of constants *}
-
-definition
-  up  :: "'a \<rightarrow> 'a u" where
-  "up = (\<Lambda> x. Iup x)"
-
-definition
-  fup :: "('a \<rightarrow> 'b::pcpo) \<rightarrow> 'a u \<rightarrow> 'b" where
-  "fup = (\<Lambda> f p. Ifup f p)"
-
-translations
-  "case l of XCONST up\<cdot>x \<Rightarrow> t" == "CONST fup\<cdot>(\<Lambda> x. t)\<cdot>l"
-  "\<Lambda>(XCONST up\<cdot>x). t" == "CONST fup\<cdot>(\<Lambda> x. t)"
-
-text {* continuous versions of lemmas for @{typ "('a)u"} *}
-
-lemma Exh_Up: "z = \<bottom> \<or> (\<exists>x. z = up\<cdot>x)"
-apply (induct z)
-apply (simp add: inst_up_pcpo)
-apply (simp add: up_def cont_Iup)
-done
-
-lemma up_eq [simp]: "(up\<cdot>x = up\<cdot>y) = (x = y)"
-by (simp add: up_def cont_Iup)
-
-lemma up_inject: "up\<cdot>x = up\<cdot>y \<Longrightarrow> x = y"
-by simp
-
-lemma up_defined [simp]: "up\<cdot>x \<noteq> \<bottom>"
-by (simp add: up_def cont_Iup inst_up_pcpo)
-
-lemma not_up_less_UU: "\<not> up\<cdot>x \<sqsubseteq> \<bottom>"
-by simp (* FIXME: remove? *)
-
-lemma up_below [simp]: "up\<cdot>x \<sqsubseteq> up\<cdot>y \<longleftrightarrow> x \<sqsubseteq> y"
-by (simp add: up_def cont_Iup)
-
-lemma upE [case_names bottom up, cases type: u]:
-  "\<lbrakk>p = \<bottom> \<Longrightarrow> Q; \<And>x. p = up\<cdot>x \<Longrightarrow> Q\<rbrakk> \<Longrightarrow> Q"
-apply (cases p)
-apply (simp add: inst_up_pcpo)
-apply (simp add: up_def cont_Iup)
-done
-
-lemma up_induct [case_names bottom up, induct type: u]:
-  "\<lbrakk>P \<bottom>; \<And>x. P (up\<cdot>x)\<rbrakk> \<Longrightarrow> P x"
-by (cases x, simp_all)
-
-text {* lifting preserves chain-finiteness *}
-
-lemma up_chain_cases:
-  assumes Y: "chain Y" obtains "\<forall>i. Y i = \<bottom>"
-  | A k where "\<forall>i. up\<cdot>(A i) = Y (i + k)" and "chain A" and "(\<Squnion>i. Y i) = up\<cdot>(\<Squnion>i. A i)"
-apply (rule up_chain_lemma [OF Y])
-apply (simp_all add: inst_up_pcpo up_def cont_Iup lub_eqI)
-done
-
-lemma compact_up: "compact x \<Longrightarrow> compact (up\<cdot>x)"
-apply (rule compactI2)
-apply (erule up_chain_cases)
-apply simp
-apply (drule (1) compactD2, simp)
-apply (erule exE)
-apply (drule_tac f="up" and x="x" in monofun_cfun_arg)
-apply (simp, erule exI)
-done
-
-lemma compact_upD: "compact (up\<cdot>x) \<Longrightarrow> compact x"
-unfolding compact_def
-by (drule adm_subst [OF cont_Rep_cfun2 [where f=up]], simp)
-
-lemma compact_up_iff [simp]: "compact (up\<cdot>x) = compact x"
-by (safe elim!: compact_up compact_upD)
-
-instance u :: (chfin) chfin
-apply intro_classes
-apply (erule compact_imp_max_in_chain)
-apply (rule_tac p="\<Squnion>i. Y i" in upE, simp_all)
-done
-
-text {* properties of fup *}
-
-lemma fup1 [simp]: "fup\<cdot>f\<cdot>\<bottom> = \<bottom>"
-by (simp add: fup_def cont_Ifup1 cont_Ifup2 inst_up_pcpo cont2cont_LAM)
-
-lemma fup2 [simp]: "fup\<cdot>f\<cdot>(up\<cdot>x) = f\<cdot>x"
-by (simp add: up_def fup_def cont_Iup cont_Ifup1 cont_Ifup2 cont2cont_LAM)
-
-lemma fup3 [simp]: "fup\<cdot>up\<cdot>x = x"
-by (cases x, simp_all)
-
-end

--- a/src/HOLCF/UpperPD.thy	Sat Nov 27 14:34:54 2010 -0800
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,529 +0,0 @@
-(*  Title:      HOLCF/UpperPD.thy
-    Author:     Brian Huffman
-*)
-
-header {* Upper powerdomain *}
-
-theory UpperPD
-imports CompactBasis
-begin
-
-subsection {* Basis preorder *}
-
-definition
-  upper_le :: "'a pd_basis \<Rightarrow> 'a pd_basis \<Rightarrow> bool" (infix "\<le>\<sharp>" 50) where
-  "upper_le = (\<lambda>u v. \<forall>y\<in>Rep_pd_basis v. \<exists>x\<in>Rep_pd_basis u. x \<sqsubseteq> y)"
-
-lemma upper_le_refl [simp]: "t \<le>\<sharp> t"
-unfolding upper_le_def by fast
-
-lemma upper_le_trans: "\<lbrakk>t \<le>\<sharp> u; u \<le>\<sharp> v\<rbrakk> \<Longrightarrow> t \<le>\<sharp> v"
-unfolding upper_le_def
-apply (rule ballI)
-apply (drule (1) bspec, erule bexE)
-apply (drule (1) bspec, erule bexE)
-apply (erule rev_bexI)
-apply (erule (1) below_trans)
-done
-
-interpretation upper_le: preorder upper_le
-by (rule preorder.intro, rule upper_le_refl, rule upper_le_trans)
-
-lemma upper_le_minimal [simp]: "PDUnit compact_bot \<le>\<sharp> t"
-unfolding upper_le_def Rep_PDUnit by simp
-
-lemma PDUnit_upper_mono: "x \<sqsubseteq> y \<Longrightarrow> PDUnit x \<le>\<sharp> PDUnit y"
-unfolding upper_le_def Rep_PDUnit by simp
-
-lemma PDPlus_upper_mono: "\<lbrakk>s \<le>\<sharp> t; u \<le>\<sharp> v\<rbrakk> \<Longrightarrow> PDPlus s u \<le>\<sharp> PDPlus t v"
-unfolding upper_le_def Rep_PDPlus by fast
-
-lemma PDPlus_upper_le: "PDPlus t u \<le>\<sharp> t"
-unfolding upper_le_def Rep_PDPlus by fast
-
-lemma upper_le_PDUnit_PDUnit_iff [simp]:
-  "(PDUnit a \<le>\<sharp> PDUnit b) = (a \<sqsubseteq> b)"
-unfolding upper_le_def Rep_PDUnit by fast
-
-lemma upper_le_PDPlus_PDUnit_iff:
-  "(PDPlus t u \<le>\<sharp> PDUnit a) = (t \<le>\<sharp> PDUnit a \<or> u \<le>\<sharp> PDUnit a)"
-unfolding upper_le_def Rep_PDPlus Rep_PDUnit by fast
-
-lemma upper_le_PDPlus_iff: "(t \<le>\<sharp> PDPlus u v) = (t \<le>\<sharp> u \<and> t \<le>\<sharp> v)"
-unfolding upper_le_def Rep_PDPlus by fast
-
-lemma upper_le_induct [induct set: upper_le]:
-  assumes le: "t \<le>\<sharp> u"
-  assumes 1: "\<And>a b. a \<sqsubseteq> b \<Longrightarrow> P (PDUnit a) (PDUnit b)"
-  assumes 2: "\<And>t u a. P t (PDUnit a) \<Longrightarrow> P (PDPlus t u) (PDUnit a)"
-  assumes 3: "\<And>t u v. \<lbrakk>P t u; P t v\<rbrakk> \<Longrightarrow> P t (PDPlus u v)"
-  shows "P t u"
-using le apply (induct u arbitrary: t rule: pd_basis_induct)
-apply (erule rev_mp)
-apply (induct_tac t rule: pd_basis_induct)
-apply (simp add: 1)
-apply (simp add: upper_le_PDPlus_PDUnit_iff)
-apply (simp add: 2)
-apply (subst PDPlus_commute)
-apply (simp add: 2)
-apply (simp add: upper_le_PDPlus_iff 3)
-done
-
-
-subsection {* Type definition *}
-
-typedef (open) 'a upper_pd =
-  "{S::'a pd_basis set. upper_le.ideal S}"
-by (fast intro: upper_le.ideal_principal)
-
-instantiation upper_pd :: ("domain") below
-begin
-
-definition
-  "x \<sqsubseteq> y \<longleftrightarrow> Rep_upper_pd x \<subseteq> Rep_upper_pd y"
-
-instance ..
-end
-
-instance upper_pd :: ("domain") po
-using type_definition_upper_pd below_upper_pd_def
-by (rule upper_le.typedef_ideal_po)
-
-instance upper_pd :: ("domain") cpo
-using type_definition_upper_pd below_upper_pd_def
-by (rule upper_le.typedef_ideal_cpo)
-
-definition
-  upper_principal :: "'a pd_basis \<Rightarrow> 'a upper_pd" where
-  "upper_principal t = Abs_upper_pd {u. u \<le>\<sharp> t}"
-
-interpretation upper_pd:
-  ideal_completion upper_le upper_principal Rep_upper_pd
-using type_definition_upper_pd below_upper_pd_def
-using upper_principal_def pd_basis_countable
-by (rule upper_le.typedef_ideal_completion)
-
-text {* Upper powerdomain is pointed *}
-
-lemma upper_pd_minimal: "upper_principal (PDUnit compact_bot) \<sqsubseteq> ys"
-by (induct ys rule: upper_pd.principal_induct, simp, simp)
-
-instance upper_pd :: ("domain") pcpo
-by intro_classes (fast intro: upper_pd_minimal)
-
-lemma inst_upper_pd_pcpo: "\<bottom> = upper_principal (PDUnit compact_bot)"
-by (rule upper_pd_minimal [THEN UU_I, symmetric])
-
-
-subsection {* Monadic unit and plus *}
-
-definition
-  upper_unit :: "'a \<rightarrow> 'a upper_pd" where
-  "upper_unit = compact_basis.basis_fun (\<lambda>a. upper_principal (PDUnit a))"
-
-definition
-  upper_plus :: "'a upper_pd \<rightarrow> 'a upper_pd \<rightarrow> 'a upper_pd" where
-  "upper_plus = upper_pd.basis_fun (\<lambda>t. upper_pd.basis_fun (\<lambda>u.
-      upper_principal (PDPlus t u)))"
-
-abbreviation
-  upper_add :: "'a upper_pd \<Rightarrow> 'a upper_pd \<Rightarrow> 'a upper_pd"
-    (infixl "+\<sharp>" 65) where
-  "xs +\<sharp> ys == upper_plus\<cdot>xs\<cdot>ys"
-
-syntax
-  "_upper_pd" :: "args \<Rightarrow> 'a upper_pd" ("{_}\<sharp>")
-
-translations
-  "{x,xs}\<sharp>" == "{x}\<sharp> +\<sharp> {xs}\<sharp>"
-  "{x}\<sharp>" == "CONST upper_unit\<cdot>x"
-
-lemma upper_unit_Rep_compact_basis [simp]:
-  "{Rep_compact_basis a}\<sharp> = upper_principal (PDUnit a)"
-unfolding upper_unit_def
-by (simp add: compact_basis.basis_fun_principal PDUnit_upper_mono)
-
-lemma upper_plus_principal [simp]:
-  "upper_principal t +\<sharp> upper_principal u = upper_principal (PDPlus t u)"
-unfolding upper_plus_def
-by (simp add: upper_pd.basis_fun_principal
-    upper_pd.basis_fun_mono PDPlus_upper_mono)
-
-interpretation upper_add: semilattice upper_add proof
-  fix xs ys zs :: "'a upper_pd"
-  show "(xs +\<sharp> ys) +\<sharp> zs = xs +\<sharp> (ys +\<sharp> zs)"
-    apply (induct xs ys arbitrary: zs rule: upper_pd.principal_induct2, simp, simp)
-    apply (rule_tac x=zs in upper_pd.principal_induct, simp)
-    apply (simp add: PDPlus_assoc)
-    done
-  show "xs +\<sharp> ys = ys +\<sharp> xs"
-    apply (induct xs ys rule: upper_pd.principal_induct2, simp, simp)
-    apply (simp add: PDPlus_commute)
-    done
-  show "xs +\<sharp> xs = xs"
-    apply (induct xs rule: upper_pd.principal_induct, simp)
-    apply (simp add: PDPlus_absorb)
-    done
-qed
-
-lemmas upper_plus_assoc = upper_add.assoc
-lemmas upper_plus_commute = upper_add.commute
-lemmas upper_plus_absorb = upper_add.idem
-lemmas upper_plus_left_commute = upper_add.left_commute
-lemmas upper_plus_left_absorb = upper_add.left_idem
-
-text {* Useful for @{text "simp add: upper_plus_ac"} *}
-lemmas upper_plus_ac =
-  upper_plus_assoc upper_plus_commute upper_plus_left_commute
-
-text {* Useful for @{text "simp only: upper_plus_aci"} *}
-lemmas upper_plus_aci =
-  upper_plus_ac upper_plus_absorb upper_plus_left_absorb
-
-lemma upper_plus_below1: "xs +\<sharp> ys \<sqsubseteq> xs"
-apply (induct xs ys rule: upper_pd.principal_induct2, simp, simp)
-apply (simp add: PDPlus_upper_le)
-done
-
-lemma upper_plus_below2: "xs +\<sharp> ys \<sqsubseteq> ys"
-by (subst upper_plus_commute, rule upper_plus_below1)
-
-lemma upper_plus_greatest: "\<lbrakk>xs \<sqsubseteq> ys; xs \<sqsubseteq> zs\<rbrakk> \<Longrightarrow> xs \<sqsubseteq> ys +\<sharp> zs"
-apply (subst upper_plus_absorb [of xs, symmetric])
-apply (erule (1) monofun_cfun [OF monofun_cfun_arg])
-done
-
-lemma upper_below_plus_iff [simp]:
-  "xs \<sqsubseteq> ys +\<sharp> zs \<longleftrightarrow> xs \<sqsubseteq> ys \<and> xs \<sqsubseteq> zs"
-apply safe
-apply (erule below_trans [OF _ upper_plus_below1])
-apply (erule below_trans [OF _ upper_plus_below2])
-apply (erule (1) upper_plus_greatest)
-done
-
-lemma upper_plus_below_unit_iff [simp]:
-  "xs +\<sharp> ys \<sqsubseteq> {z}\<sharp> \<longleftrightarrow> xs \<sqsubseteq> {z}\<sharp> \<or> ys \<sqsubseteq> {z}\<sharp>"
-apply (induct xs rule: upper_pd.principal_induct, simp)
-apply (induct ys rule: upper_pd.principal_induct, simp)
-apply (induct z rule: compact_basis.principal_induct, simp)
-apply (simp add: upper_le_PDPlus_PDUnit_iff)
-done
-
-lemma upper_unit_below_iff [simp]: "{x}\<sharp> \<sqsubseteq> {y}\<sharp> \<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
-
-lemmas upper_pd_below_simps =
-  upper_unit_below_iff
-  upper_below_plus_iff
-  upper_plus_below_unit_iff
-
-lemma upper_unit_eq_iff [simp]: "{x}\<sharp> = {y}\<sharp> \<longleftrightarrow> x = y"
-unfolding po_eq_conv by simp
-
-lemma upper_unit_strict [simp]: "{\<bottom>}\<sharp> = \<bottom>"
-using upper_unit_Rep_compact_basis [of compact_bot]
-by (simp add: inst_upper_pd_pcpo)
-
-lemma upper_plus_strict1 [simp]: "\<bottom> +\<sharp> ys = \<bottom>"
-by (rule UU_I, rule upper_plus_below1)
-
-lemma upper_plus_strict2 [simp]: "xs +\<sharp> \<bottom> = \<bottom>"
-by (rule UU_I, rule upper_plus_below2)
-
-lemma upper_unit_bottom_iff [simp]: "{x}\<sharp> = \<bottom> \<longleftrightarrow> x = \<bottom>"
-unfolding upper_unit_strict [symmetric] by (rule upper_unit_eq_iff)
-
-lemma upper_plus_bottom_iff [simp]:
-  "xs +\<sharp> ys = \<bottom> \<longleftrightarrow> xs = \<bottom> \<or> ys = \<bottom>"
-apply (rule iffI)
-apply (erule rev_mp)
-apply (rule upper_pd.principal_induct2 [where x=xs and y=ys], simp, simp)
-apply (simp add: inst_upper_pd_pcpo upper_pd.principal_eq_iff
-                 upper_le_PDPlus_PDUnit_iff)
-apply auto
-done
-
-lemma compact_upper_unit: "compact x \<Longrightarrow> compact {x}\<sharp>"
-by (auto dest!: compact_basis.compact_imp_principal)
-
-lemma compact_upper_unit_iff [simp]: "compact {x}\<sharp> \<longleftrightarrow> compact x"
-apply (safe elim!: compact_upper_unit)
-apply (simp only: compact_def upper_unit_below_iff [symmetric])
-apply (erule adm_subst [OF cont_Rep_cfun2])
-done
-
-lemma compact_upper_plus [simp]:
-  "\<lbrakk>compact xs; compact ys\<rbrakk> \<Longrightarrow> compact (xs +\<sharp> ys)"
-by (auto dest!: upper_pd.compact_imp_principal)
-
-
-subsection {* Induction rules *}
-
-lemma upper_pd_induct1:
-  assumes P: "adm P"
-  assumes unit: "\<And>x. P {x}\<sharp>"
-  assumes insert: "\<And>x ys. \<lbrakk>P {x}\<sharp>; P ys\<rbrakk> \<Longrightarrow> P ({x}\<sharp> +\<sharp> ys)"
-  shows "P (xs::'a upper_pd)"
-apply (induct xs rule: upper_pd.principal_induct, rule P)
-apply (induct_tac a rule: pd_basis_induct1)
-apply (simp only: upper_unit_Rep_compact_basis [symmetric])
-apply (rule unit)
-apply (simp only: upper_unit_Rep_compact_basis [symmetric]
-                  upper_plus_principal [symmetric])
-apply (erule insert [OF unit])
-done
-
-lemma upper_pd_induct
-  [case_names adm upper_unit upper_plus, induct type: upper_pd]:
-  assumes P: "adm P"
-  assumes unit: "\<And>x. P {x}\<sharp>"
-  assumes plus: "\<And>xs ys. \<lbrakk>P xs; P ys\<rbrakk> \<Longrightarrow> P (xs +\<sharp> ys)"
-  shows "P (xs::'a upper_pd)"
-apply (induct xs rule: upper_pd.principal_induct, rule P)
-apply (induct_tac a rule: pd_basis_induct)
-apply (simp only: upper_unit_Rep_compact_basis [symmetric] unit)
-apply (simp only: upper_plus_principal [symmetric] plus)
-done
-
-
-subsection {* Monadic bind *}
-
-definition
-  upper_bind_basis ::
-  "'a pd_basis \<Rightarrow> ('a \<rightarrow> 'b upper_pd) \<rightarrow> 'b upper_pd" where
-  "upper_bind_basis = fold_pd
-    (\<lambda>a. \<Lambda> f. f\<cdot>(Rep_compact_basis a))
-    (\<lambda>x y. \<Lambda> f. x\<cdot>f +\<sharp> y\<cdot>f)"
-
-lemma ACI_upper_bind:
-  "class.ab_semigroup_idem_mult (\<lambda>x y. \<Lambda> f. x\<cdot>f +\<sharp> y\<cdot>f)"
-apply unfold_locales
-apply (simp add: upper_plus_assoc)
-apply (simp add: upper_plus_commute)
-apply (simp add: eta_cfun)
-done
-
-lemma upper_bind_basis_simps [simp]:
-  "upper_bind_basis (PDUnit a) =
-    (\<Lambda> f. f\<cdot>(Rep_compact_basis a))"
-  "upper_bind_basis (PDPlus t u) =
-    (\<Lambda> f. upper_bind_basis t\<cdot>f +\<sharp> upper_bind_basis u\<cdot>f)"
-unfolding upper_bind_basis_def
-apply -
-apply (rule fold_pd_PDUnit [OF ACI_upper_bind])
-apply (rule fold_pd_PDPlus [OF ACI_upper_bind])
-done
-
-lemma upper_bind_basis_mono:
-  "t \<le>\<sharp> u \<Longrightarrow> upper_bind_basis t \<sqsubseteq> upper_bind_basis u"
-unfolding cfun_below_iff
-apply (erule upper_le_induct, safe)
-apply (simp add: monofun_cfun)
-apply (simp add: below_trans [OF upper_plus_below1])
-apply simp
-done
-
-definition
-  upper_bind :: "'a upper_pd \<rightarrow> ('a \<rightarrow> 'b upper_pd) \<rightarrow> 'b upper_pd" where
-  "upper_bind = upper_pd.basis_fun upper_bind_basis"
-
-lemma upper_bind_principal [simp]:
-  "upper_bind\<cdot>(upper_principal t) = upper_bind_basis t"
-unfolding upper_bind_def
-apply (rule upper_pd.basis_fun_principal)
-apply (erule upper_bind_basis_mono)
-done
-
-lemma upper_bind_unit [simp]:
-  "upper_bind\<cdot>{x}\<sharp>\<cdot>f = f\<cdot>x"
-by (induct x rule: compact_basis.principal_induct, simp, simp)
-
-lemma upper_bind_plus [simp]:
-  "upper_bind\<cdot>(xs +\<sharp> ys)\<cdot>f = upper_bind\<cdot>xs\<cdot>f +\<sharp> upper_bind\<cdot>ys\<cdot>f"
-by (induct xs ys rule: upper_pd.principal_induct2, simp, simp, simp)
-
-lemma upper_bind_strict [simp]: "upper_bind\<cdot>\<bottom>\<cdot>f = f\<cdot>\<bottom>"
-unfolding upper_unit_strict [symmetric] by (rule upper_bind_unit)
-
-lemma upper_bind_bind:
-  "upper_bind\<cdot>(upper_bind\<cdot>xs\<cdot>f)\<cdot>g = upper_bind\<cdot>xs\<cdot>(\<Lambda> x. upper_bind\<cdot>(f\<cdot>x)\<cdot>g)"
-by (induct xs, simp_all)
-
-
-subsection {* Map *}
-
-definition
-  upper_map :: "('a \<rightarrow> 'b) \<rightarrow> 'a upper_pd \<rightarrow> 'b upper_pd" where
-  "upper_map = (\<Lambda> f xs. upper_bind\<cdot>xs\<cdot>(\<Lambda> x. {f\<cdot>x}\<sharp>))"
-
-lemma upper_map_unit [simp]:
-  "upper_map\<cdot>f\<cdot>{x}\<sharp> = {f\<cdot>x}\<sharp>"
-unfolding upper_map_def by simp
-
-lemma upper_map_plus [simp]:
-  "upper_map\<cdot>f\<cdot>(xs +\<sharp> ys) = upper_map\<cdot>f\<cdot>xs +\<sharp> upper_map\<cdot>f\<cdot>ys"
-unfolding upper_map_def by simp
-
-lemma upper_map_bottom [simp]: "upper_map\<cdot>f\<cdot>\<bottom> = {f\<cdot>\<bottom>}\<sharp>"
-unfolding upper_map_def by simp
-
-lemma upper_map_ident: "upper_map\<cdot>(\<Lambda> x. x)\<cdot>xs = xs"
-by (induct xs rule: upper_pd_induct, simp_all)
-
-lemma upper_map_ID: "upper_map\<cdot>ID = ID"
-by (simp add: cfun_eq_iff ID_def upper_map_ident)
-
-lemma upper_map_map:
-  "upper_map\<cdot>f\<cdot>(upper_map\<cdot>g\<cdot>xs) = upper_map\<cdot>(\<Lambda> x. f\<cdot>(g\<cdot>x))\<cdot>xs"
-by (induct xs rule: upper_pd_induct, simp_all)
-
-lemma ep_pair_upper_map: "ep_pair e p \<Longrightarrow> ep_pair (upper_map\<cdot>e) (upper_map\<cdot>p)"
-apply default
-apply (induct_tac x rule: upper_pd_induct, simp_all add: ep_pair.e_inverse)
-apply (induct_tac y rule: upper_pd_induct)
-apply (simp_all add: ep_pair.e_p_below monofun_cfun del: upper_below_plus_iff)
-done
-
-lemma deflation_upper_map: "deflation d \<Longrightarrow> deflation (upper_map\<cdot>d)"
-apply default
-apply (induct_tac x rule: upper_pd_induct, simp_all add: deflation.idem)
-apply (induct_tac x rule: upper_pd_induct)
-apply (simp_all add: deflation.below monofun_cfun del: upper_below_plus_iff)
-done
-
-(* FIXME: long proof! *)
-lemma finite_deflation_upper_map:
-  assumes "finite_deflation d" shows "finite_deflation (upper_map\<cdot>d)"
-proof (rule finite_deflation_intro)
-  interpret d: finite_deflation d by fact
-  have "deflation d" by fact
-  thus "deflation (upper_map\<cdot>d)" by (rule deflation_upper_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 (upper_principal ` Rep_pd_basis -` (Pow (Rep_compact_basis -` range (\<lambda>x. d\<cdot>x))))" by simp
-  hence "finite (range (\<lambda>xs. upper_map\<cdot>d\<cdot>xs))"
-    apply (rule rev_finite_subset)
-    apply clarsimp
-    apply (induct_tac xs rule: upper_pd.principal_induct)
-    apply (simp add: adm_mem_finite *)
-    apply (rename_tac t, induct_tac t rule: pd_basis_induct)
-    apply (simp only: upper_unit_Rep_compact_basis [symmetric] upper_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: upper_plus_principal [symmetric] upper_map_plus)
-    apply clarsimp
-    apply (rule imageI)
-    apply (rule vimageI2)
-    apply (simp add: Rep_PDPlus)
-    done
-  thus "finite {xs. upper_map\<cdot>d\<cdot>xs = xs}"
-    by (rule finite_range_imp_finite_fixes)
-qed
-
-subsection {* Upper powerdomain is a domain *}
-
-definition
-  upper_approx :: "nat \<Rightarrow> udom upper_pd \<rightarrow> udom upper_pd"
-where
-  "upper_approx = (\<lambda>i. upper_map\<cdot>(udom_approx i))"
-
-lemma upper_approx: "approx_chain upper_approx"
-using upper_map_ID finite_deflation_upper_map
-unfolding upper_approx_def by (rule approx_chain_lemma1)
-
-definition upper_defl :: "defl \<rightarrow> defl"
-where "upper_defl = defl_fun1 upper_approx upper_map"
-
-lemma cast_upper_defl:
-  "cast\<cdot>(upper_defl\<cdot>A) =
-    udom_emb upper_approx oo upper_map\<cdot>(cast\<cdot>A) oo udom_prj upper_approx"
-using upper_approx finite_deflation_upper_map
-unfolding upper_defl_def by (rule cast_defl_fun1)
-
-instantiation upper_pd :: ("domain") liftdomain
-begin
-
-definition
-  "emb = udom_emb upper_approx oo upper_map\<cdot>emb"
-
-definition
-  "prj = upper_map\<cdot>prj oo udom_prj upper_approx"
-
-definition
-  "defl (t::'a upper_pd itself) = upper_defl\<cdot>DEFL('a)"
-
-definition
-  "(liftemb :: 'a upper_pd u \<rightarrow> udom) = udom_emb u_approx oo u_map\<cdot>emb"
-
-definition
-  "(liftprj :: udom \<rightarrow> 'a upper_pd u) = u_map\<cdot>prj oo udom_prj u_approx"
-
-definition
-  "liftdefl (t::'a upper_pd itself) = u_defl\<cdot>DEFL('a upper_pd)"
-
-instance
-using liftemb_upper_pd_def liftprj_upper_pd_def liftdefl_upper_pd_def
-proof (rule liftdomain_class_intro)
-  show "ep_pair emb (prj :: udom \<rightarrow> 'a upper_pd)"
-    unfolding emb_upper_pd_def prj_upper_pd_def
-    using ep_pair_udom [OF upper_approx]
-    by (intro ep_pair_comp ep_pair_upper_map ep_pair_emb_prj)
-next
-  show "cast\<cdot>DEFL('a upper_pd) = emb oo (prj :: udom \<rightarrow> 'a upper_pd)"
-    unfolding emb_upper_pd_def prj_upper_pd_def defl_upper_pd_def cast_upper_defl
-    by (simp add: cast_DEFL oo_def cfun_eq_iff upper_map_map)
-qed
-
-end
-
-lemma DEFL_upper: "DEFL('a upper_pd) = upper_defl\<cdot>DEFL('a)"
-by (rule defl_upper_pd_def)
-
-
-subsection {* Join *}
-
-definition
-  upper_join :: "'a upper_pd upper_pd \<rightarrow> 'a upper_pd" where
-  "upper_join = (\<Lambda> xss. upper_bind\<cdot>xss\<cdot>(\<Lambda> xs. xs))"
-
-lemma upper_join_unit [simp]:
-  "upper_join\<cdot>{xs}\<sharp> = xs"
-unfolding upper_join_def by simp
-
-lemma upper_join_plus [simp]:
-  "upper_join\<cdot>(xss +\<sharp> yss) = upper_join\<cdot>xss +\<sharp> upper_join\<cdot>yss"
-unfolding upper_join_def by simp
-
-lemma upper_join_bottom [simp]: "upper_join\<cdot>\<bottom> = \<bottom>"
-unfolding upper_join_def by simp
-
-lemma upper_join_map_unit:
-  "upper_join\<cdot>(upper_map\<cdot>upper_unit\<cdot>xs) = xs"
-by (induct xs rule: upper_pd_induct, simp_all)
-
-lemma upper_join_map_join:
-  "upper_join\<cdot>(upper_map\<cdot>upper_join\<cdot>xsss) = upper_join\<cdot>(upper_join\<cdot>xsss)"
-by (induct xsss rule: upper_pd_induct, simp_all)
-
-lemma upper_join_map_map:
-  "upper_join\<cdot>(upper_map\<cdot>(upper_map\<cdot>f)\<cdot>xss) =
-   upper_map\<cdot>f\<cdot>(upper_join\<cdot>xss)"
-by (induct xss rule: upper_pd_induct, simp_all)
-
-end

--- a/src/HOLCF/document/root.tex	Sat Nov 27 14:34:54 2010 -0800
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,35 +0,0 @@
-
-% HOLCF/document/root.tex
-
-\documentclass[11pt,a4paper]{article}
-\usepackage{graphicx,isabelle,isabellesym,latexsym}
-\usepackage[only,bigsqcap]{stmaryrd}
-\usepackage[latin1]{inputenc}
-\usepackage{pdfsetup}
-
-\urlstyle{rm}
-\isabellestyle{it}
-\pagestyle{myheadings}
-\newcommand{\isasymas}{\textsf{as}}
-\newcommand{\isasymlazy}{\isamath{\sim}}
-
-\begin{document}
-
-\title{Isabelle/HOLCF --- Higher-Order Logic of Computable Functions}
-\maketitle
-
-\tableofcontents
-
-\begin{center}
-  \includegraphics[scale=0.45]{session_graph}
-\end{center}
-
-\newpage
-
-\renewcommand{\isamarkupheader}[1]%
-{\section{\isabellecontext: #1}\markright{THEORY~``\isabellecontext''}}
-
-\parindent 0pt\parskip 0.5ex
-\input{session}
-
-\end{document}

--- a/src/HOLCF/ex/Dagstuhl.thy	Sat Nov 27 14:34:54 2010 -0800
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,92 +0,0 @@
-theory Dagstuhl
-imports Stream
-begin
-
-axiomatization
-  y  :: "'a"
-
-definition
-  YS :: "'a stream" where
-  "YS = fix$(LAM x. y && x)"
-
-definition
-  YYS :: "'a stream" where
-  "YYS = fix$(LAM z. y && y && z)"
-
-lemma YS_def2: "YS = y && YS"
-  apply (rule trans)
-  apply (rule fix_eq2)
-  apply (rule YS_def [THEN eq_reflection])
-  apply (rule beta_cfun)
-  apply simp
-  done
-
-lemma YYS_def2: "YYS = y && y && YYS"
-  apply (rule trans)
-  apply (rule fix_eq2)
-  apply (rule YYS_def [THEN eq_reflection])
-  apply (rule beta_cfun)
-  apply simp
-  done
-
-
-lemma lemma3: "YYS << y && YYS"
-  apply (rule YYS_def [THEN eq_reflection, THEN def_fix_ind])
-  apply simp_all
-  apply (rule monofun_cfun_arg)
-  apply (rule monofun_cfun_arg)
-  apply assumption
-  done
-
-lemma lemma4: "y && YYS << YYS"
-  apply (subst YYS_def2)
-  back
-  apply (rule monofun_cfun_arg)
-  apply (rule lemma3)
-  done
-
-lemma lemma5: "y && YYS = YYS"
-  apply (rule below_antisym)
-  apply (rule lemma4)
-  apply (rule lemma3)
-  done
-
-lemma wir_moel: "YS = YYS"
-  apply (rule stream.take_lemma)
-  apply (induct_tac n)
-  apply (simp (no_asm))
-  apply (subst YS_def2)
-  apply (subst YYS_def2)
-  apply simp
-  apply (rule lemma5 [symmetric, THEN subst])
-  apply (rule refl)
-  done
-
-(* ------------------------------------------------------------------------ *)
-(* Zweite L"osung: Bernhard Möller                                          *)
-(* statt Beweis von  wir_moel "uber take_lemma beidseitige Inclusion        *)
-(* verwendet lemma5                                                         *)
-(* ------------------------------------------------------------------------ *)
-
-lemma lemma6: "YYS << YS"
-  apply (unfold YYS_def)
-  apply (rule fix_least)
-  apply (subst beta_cfun)
-  apply simp
-  apply (simp add: YS_def2 [symmetric])
-  done
-
-lemma lemma7: "YS << YYS"
-  apply (rule YS_def [THEN eq_reflection, THEN def_fix_ind])
-  apply simp_all
-  apply (subst lemma5 [symmetric])
-  apply (erule monofun_cfun_arg)
-  done
-
-lemma wir_moel': "YS = YYS"
-  apply (rule below_antisym)
-  apply (rule lemma7)
-  apply (rule lemma6)
-  done
-
-end

--- a/src/HOLCF/ex/Dnat.thy	Sat Nov 27 14:34:54 2010 -0800
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,72 +0,0 @@
-(*  Title:      HOLCF/Dnat.thy
-    Author:     Franz Regensburger
-
-Theory for the domain of natural numbers  dnat = one ++ dnat
-*)
-
-theory Dnat
-imports HOLCF
-begin
-
-domain dnat = dzero | dsucc (dpred :: dnat)
-
-definition
-  iterator :: "dnat -> ('a -> 'a) -> 'a -> 'a" where
-  "iterator = fix $ (LAM h n f x.
-    case n of dzero => x
-      | dsucc $ m => f $ (h $ m $ f $ x))"
-
-text {*
-  \medskip Expand fixed point properties.
-*}
-
-lemma iterator_def2:
-  "iterator = (LAM n f x. case n of dzero => x | dsucc$m => f$(iterator$m$f$x))"
-  apply (rule trans)
-  apply (rule fix_eq2)
-  apply (rule iterator_def [THEN eq_reflection])
-  apply (rule beta_cfun)
-  apply simp
-  done
-
-text {* \medskip Recursive properties. *}
-
-lemma iterator1: "iterator $ UU $ f $ x = UU"
-  apply (subst iterator_def2)
-  apply simp
-  done
-
-lemma iterator2: "iterator $ dzero $ f $ x = x"
-  apply (subst iterator_def2)
-  apply simp
-  done
-
-lemma iterator3: "n ~= UU ==> iterator $ (dsucc $ n) $ f $ x = f $ (iterator $ n $ f $ x)"
-  apply (rule trans)
-   apply (subst iterator_def2)
-   apply simp
-  apply (rule refl)
-  done
-
-lemmas iterator_rews = iterator1 iterator2 iterator3
-
-lemma dnat_flat: "ALL x y::dnat. x<<y --> x=UU | x=y"
-  apply (rule allI)
-  apply (induct_tac x)
-    apply fast
-   apply (rule allI)
-   apply (case_tac y)
-     apply simp
-    apply simp
-   apply simp
-  apply (rule allI)
-  apply (case_tac y)
-    apply (fast intro!: UU_I)
-   apply (thin_tac "ALL y. dnat << y --> dnat = UU | dnat = y")
-   apply simp
-  apply (simp (no_asm_simp))
-  apply (drule_tac x="dnata" in spec)
-  apply simp
-  done
-
-end

--- a/src/HOLCF/ex/Domain_Proofs.thy	Sat Nov 27 14:34:54 2010 -0800
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,501 +0,0 @@
-(*  Title:      HOLCF/ex/Domain_Proofs.thy
-    Author:     Brian Huffman
-*)
-
-header {* Internal domain package proofs done manually *}
-
-theory Domain_Proofs
-imports HOLCF
-begin
-
-(*
-
-The definitions and proofs below are for the following recursive
-datatypes:
-
-domain 'a foo = Foo1 | Foo2 (lazy 'a) (lazy "'a bar")
-   and 'a bar = Bar (lazy "'a baz \<rightarrow> tr")
-   and 'a baz = Baz (lazy "'a foo convex_pd \<rightarrow> tr")
-
-TODO: add another type parameter that is strict,
-to show the different handling of LIFTDEFL vs. DEFL.
-
-*)
-
-(********************************************************************)
-
-subsection {* Step 1: Define the new type combinators *}
-
-text {* Start with the one-step non-recursive version *}
-
-definition
-  foo_bar_baz_deflF ::
-    "defl \<rightarrow> defl \<times> defl \<times> defl \<rightarrow> defl \<times> defl \<times> defl"
-where
-  "foo_bar_baz_deflF = (\<Lambda> a. Abs_cfun (\<lambda>(t1, t2, t3). 
-    ( ssum_defl\<cdot>DEFL(one)\<cdot>(sprod_defl\<cdot>a\<cdot>(u_defl\<cdot>t2))
-    , u_defl\<cdot>(sfun_defl\<cdot>(u_defl\<cdot>t3)\<cdot>DEFL(tr))
-    , u_defl\<cdot>(sfun_defl\<cdot>(u_defl\<cdot>(convex_defl\<cdot>t1))\<cdot>DEFL(tr)))))"
-
-lemma foo_bar_baz_deflF_beta:
-  "foo_bar_baz_deflF\<cdot>a\<cdot>t =
-    ( ssum_defl\<cdot>DEFL(one)\<cdot>(sprod_defl\<cdot>a\<cdot>(u_defl\<cdot>(fst (snd t))))
-    , u_defl\<cdot>(sfun_defl\<cdot>(u_defl\<cdot>(snd (snd t)))\<cdot>DEFL(tr))
-    , u_defl\<cdot>(sfun_defl\<cdot>(u_defl\<cdot>(convex_defl\<cdot>(fst t)))\<cdot>DEFL(tr)))"
-unfolding foo_bar_baz_deflF_def
-by (simp add: split_def)
-
-text {* Individual type combinators are projected from the fixed point. *}
-
-definition foo_defl :: "defl \<rightarrow> defl"
-where "foo_defl = (\<Lambda> a. fst (fix\<cdot>(foo_bar_baz_deflF\<cdot>a)))"
-
-definition bar_defl :: "defl \<rightarrow> defl"
-where "bar_defl = (\<Lambda> a. fst (snd (fix\<cdot>(foo_bar_baz_deflF\<cdot>a))))"
-
-definition baz_defl :: "defl \<rightarrow> defl"
-where "baz_defl = (\<Lambda> a. snd (snd (fix\<cdot>(foo_bar_baz_deflF\<cdot>a))))"
-
-lemma defl_apply_thms:
-  "foo_defl\<cdot>a = fst (fix\<cdot>(foo_bar_baz_deflF\<cdot>a))"
-  "bar_defl\<cdot>a = fst (snd (fix\<cdot>(foo_bar_baz_deflF\<cdot>a)))"
-  "baz_defl\<cdot>a = snd (snd (fix\<cdot>(foo_bar_baz_deflF\<cdot>a)))"
-unfolding foo_defl_def bar_defl_def baz_defl_def by simp_all
-
-text {* Unfold rules for each combinator. *}
-
-lemma foo_defl_unfold:
-  "foo_defl\<cdot>a = ssum_defl\<cdot>DEFL(one)\<cdot>(sprod_defl\<cdot>a\<cdot>(u_defl\<cdot>(bar_defl\<cdot>a)))"
-unfolding defl_apply_thms by (subst fix_eq, simp add: foo_bar_baz_deflF_beta)
-
-lemma bar_defl_unfold: "bar_defl\<cdot>a = u_defl\<cdot>(sfun_defl\<cdot>(u_defl\<cdot>(baz_defl\<cdot>a))\<cdot>DEFL(tr))"
-unfolding defl_apply_thms by (subst fix_eq, simp add: foo_bar_baz_deflF_beta)
-
-lemma baz_defl_unfold: "baz_defl\<cdot>a = u_defl\<cdot>(sfun_defl\<cdot>(u_defl\<cdot>(convex_defl\<cdot>(foo_defl\<cdot>a)))\<cdot>DEFL(tr))"
-unfolding defl_apply_thms by (subst fix_eq, simp add: foo_bar_baz_deflF_beta)
-
-text "The automation for the previous steps will be quite similar to
-how the fixrec package works."
-
-(********************************************************************)
-
-subsection {* Step 2: Define types, prove class instances *}
-
-text {* Use @{text pcpodef} with the appropriate type combinator. *}
-
-pcpodef (open) 'a foo = "defl_set (foo_defl\<cdot>LIFTDEFL('a))"
-by (rule defl_set_bottom, rule adm_defl_set)
-
-pcpodef (open) 'a bar = "defl_set (bar_defl\<cdot>LIFTDEFL('a))"
-by (rule defl_set_bottom, rule adm_defl_set)
-
-pcpodef (open) 'a baz = "defl_set (baz_defl\<cdot>LIFTDEFL('a))"
-by (rule defl_set_bottom, rule adm_defl_set)
-
-text {* Prove rep instance using lemma @{text typedef_rep_class}. *}
-
-instantiation foo :: ("domain") liftdomain
-begin
-
-definition emb_foo :: "'a foo \<rightarrow> udom"
-where "emb_foo \<equiv> (\<Lambda> x. Rep_foo x)"
-
-definition prj_foo :: "udom \<rightarrow> 'a foo"
-where "prj_foo \<equiv> (\<Lambda> y. Abs_foo (cast\<cdot>(foo_defl\<cdot>LIFTDEFL('a))\<cdot>y))"
-
-definition defl_foo :: "'a foo itself \<Rightarrow> defl"
-where "defl_foo \<equiv> \<lambda>a. foo_defl\<cdot>LIFTDEFL('a)"
-
-definition
-  "(liftemb :: 'a foo u \<rightarrow> udom) \<equiv> udom_emb u_approx oo u_map\<cdot>emb"
-
-definition
-  "(liftprj :: udom \<rightarrow> 'a foo u) \<equiv> u_map\<cdot>prj oo udom_prj u_approx"
-
-definition
-  "liftdefl \<equiv> \<lambda>(t::'a foo itself). u_defl\<cdot>DEFL('a foo)"
-
-instance
-apply (rule typedef_liftdomain_class)
-apply (rule type_definition_foo)
-apply (rule below_foo_def)
-apply (rule emb_foo_def)
-apply (rule prj_foo_def)
-apply (rule defl_foo_def)
-apply (rule liftemb_foo_def)
-apply (rule liftprj_foo_def)
-apply (rule liftdefl_foo_def)
-done
-
-end
-
-instantiation bar :: ("domain") liftdomain
-begin
-
-definition emb_bar :: "'a bar \<rightarrow> udom"
-where "emb_bar \<equiv> (\<Lambda> x. Rep_bar x)"
-
-definition prj_bar :: "udom \<rightarrow> 'a bar"
-where "prj_bar \<equiv> (\<Lambda> y. Abs_bar (cast\<cdot>(bar_defl\<cdot>LIFTDEFL('a))\<cdot>y))"
-
-definition defl_bar :: "'a bar itself \<Rightarrow> defl"
-where "defl_bar \<equiv> \<lambda>a. bar_defl\<cdot>LIFTDEFL('a)"
-
-definition
-  "(liftemb :: 'a bar u \<rightarrow> udom) \<equiv> udom_emb u_approx oo u_map\<cdot>emb"
-
-definition
-  "(liftprj :: udom \<rightarrow> 'a bar u) \<equiv> u_map\<cdot>prj oo udom_prj u_approx"
-
-definition
-  "liftdefl \<equiv> \<lambda>(t::'a bar itself). u_defl\<cdot>DEFL('a bar)"
-
-instance
-apply (rule typedef_liftdomain_class)
-apply (rule type_definition_bar)
-apply (rule below_bar_def)
-apply (rule emb_bar_def)
-apply (rule prj_bar_def)
-apply (rule defl_bar_def)
-apply (rule liftemb_bar_def)
-apply (rule liftprj_bar_def)
-apply (rule liftdefl_bar_def)
-done
-
-end
-
-instantiation baz :: ("domain") liftdomain
-begin
-
-definition emb_baz :: "'a baz \<rightarrow> udom"
-where "emb_baz \<equiv> (\<Lambda> x. Rep_baz x)"
-
-definition prj_baz :: "udom \<rightarrow> 'a baz"
-where "prj_baz \<equiv> (\<Lambda> y. Abs_baz (cast\<cdot>(baz_defl\<cdot>LIFTDEFL('a))\<cdot>y))"
-
-definition defl_baz :: "'a baz itself \<Rightarrow> defl"
-where "defl_baz \<equiv> \<lambda>a. baz_defl\<cdot>LIFTDEFL('a)"
-
-definition
-  "(liftemb :: 'a baz u \<rightarrow> udom) \<equiv> udom_emb u_approx oo u_map\<cdot>emb"
-
-definition
-  "(liftprj :: udom \<rightarrow> 'a baz u) \<equiv> u_map\<cdot>prj oo udom_prj u_approx"
-
-definition
-  "liftdefl \<equiv> \<lambda>(t::'a baz itself). u_defl\<cdot>DEFL('a baz)"
-
-instance
-apply (rule typedef_liftdomain_class)
-apply (rule type_definition_baz)
-apply (rule below_baz_def)
-apply (rule emb_baz_def)
-apply (rule prj_baz_def)
-apply (rule defl_baz_def)
-apply (rule liftemb_baz_def)
-apply (rule liftprj_baz_def)
-apply (rule liftdefl_baz_def)
-done
-
-end
-
-text {* Prove DEFL rules using lemma @{text typedef_DEFL}. *}
-
-lemma DEFL_foo: "DEFL('a foo) = foo_defl\<cdot>LIFTDEFL('a)"
-apply (rule typedef_DEFL)
-apply (rule defl_foo_def)
-done
-
-lemma DEFL_bar: "DEFL('a bar) = bar_defl\<cdot>LIFTDEFL('a)"
-apply (rule typedef_DEFL)
-apply (rule defl_bar_def)
-done
-
-lemma DEFL_baz: "DEFL('a baz) = baz_defl\<cdot>LIFTDEFL('a)"
-apply (rule typedef_DEFL)
-apply (rule defl_baz_def)
-done
-
-text {* Prove DEFL equations using type combinator unfold lemmas. *}
-
-lemma DEFL_foo': "DEFL('a foo) = DEFL(one \<oplus> 'a\<^sub>\<bottom> \<otimes> ('a bar)\<^sub>\<bottom>)"
-unfolding DEFL_foo DEFL_bar DEFL_baz domain_defl_simps
-by (rule foo_defl_unfold)
-
-lemma DEFL_bar': "DEFL('a bar) = DEFL(('a baz \<rightarrow> tr)\<^sub>\<bottom>)"
-unfolding DEFL_foo DEFL_bar DEFL_baz domain_defl_simps
-by (rule bar_defl_unfold)
-
-lemma DEFL_baz': "DEFL('a baz) = DEFL(('a foo convex_pd \<rightarrow> tr)\<^sub>\<bottom>)"
-unfolding DEFL_foo DEFL_bar DEFL_baz domain_defl_simps
-by (rule baz_defl_unfold)
-
-(********************************************************************)
-
-subsection {* Step 3: Define rep and abs functions *}
-
-text {* Define them all using @{text prj} and @{text emb}! *}
-
-definition foo_rep :: "'a foo \<rightarrow> one \<oplus> ('a\<^sub>\<bottom> \<otimes> ('a bar)\<^sub>\<bottom>)"
-where "foo_rep \<equiv> prj oo emb"
-
-definition foo_abs :: "one \<oplus> ('a\<^sub>\<bottom> \<otimes> ('a bar)\<^sub>\<bottom>) \<rightarrow> 'a foo"
-where "foo_abs \<equiv> prj oo emb"
-
-definition bar_rep :: "'a bar \<rightarrow> ('a baz \<rightarrow> tr)\<^sub>\<bottom>"
-where "bar_rep \<equiv> prj oo emb"
-
-definition bar_abs :: "('a baz \<rightarrow> tr)\<^sub>\<bottom> \<rightarrow> 'a bar"
-where "bar_abs \<equiv> prj oo emb"
-
-definition baz_rep :: "'a baz \<rightarrow> ('a foo convex_pd \<rightarrow> tr)\<^sub>\<bottom>"
-where "baz_rep \<equiv> prj oo emb"
-
-definition baz_abs :: "('a foo convex_pd \<rightarrow> tr)\<^sub>\<bottom> \<rightarrow> 'a baz"
-where "baz_abs \<equiv> prj oo emb"
-
-text {* Prove isomorphism rules. *}
-
-lemma foo_abs_iso: "foo_rep\<cdot>(foo_abs\<cdot>x) = x"
-by (rule domain_abs_iso [OF DEFL_foo' foo_abs_def foo_rep_def])
-
-lemma foo_rep_iso: "foo_abs\<cdot>(foo_rep\<cdot>x) = x"
-by (rule domain_rep_iso [OF DEFL_foo' foo_abs_def foo_rep_def])
-
-lemma bar_abs_iso: "bar_rep\<cdot>(bar_abs\<cdot>x) = x"
-by (rule domain_abs_iso [OF DEFL_bar' bar_abs_def bar_rep_def])
-
-lemma bar_rep_iso: "bar_abs\<cdot>(bar_rep\<cdot>x) = x"
-by (rule domain_rep_iso [OF DEFL_bar' bar_abs_def bar_rep_def])
-
-lemma baz_abs_iso: "baz_rep\<cdot>(baz_abs\<cdot>x) = x"
-by (rule domain_abs_iso [OF DEFL_baz' baz_abs_def baz_rep_def])
-
-lemma baz_rep_iso: "baz_abs\<cdot>(baz_rep\<cdot>x) = x"
-by (rule domain_rep_iso [OF DEFL_baz' baz_abs_def baz_rep_def])
-
-text {* Prove isodefl rules using @{text isodefl_coerce}. *}
-
-lemma isodefl_foo_abs:
-  "isodefl d t \<Longrightarrow> isodefl (foo_abs oo d oo foo_rep) t"
-by (rule isodefl_abs_rep [OF DEFL_foo' foo_abs_def foo_rep_def])
-
-lemma isodefl_bar_abs:
-  "isodefl d t \<Longrightarrow> isodefl (bar_abs oo d oo bar_rep) t"
-by (rule isodefl_abs_rep [OF DEFL_bar' bar_abs_def bar_rep_def])
-
-lemma isodefl_baz_abs:
-  "isodefl d t \<Longrightarrow> isodefl (baz_abs oo d oo baz_rep) t"
-by (rule isodefl_abs_rep [OF DEFL_baz' baz_abs_def baz_rep_def])
-
-(********************************************************************)
-
-subsection {* Step 4: Define map functions, prove isodefl property *}
-
-text {* Start with the one-step non-recursive version. *}
-
-text {* Note that the type of the map function depends on which
-variables are used in positive and negative positions. *}
-
-definition
-  foo_bar_baz_mapF ::
-    "('a \<rightarrow> 'b) \<rightarrow>
-     ('a foo \<rightarrow> 'b foo) \<times> ('a bar \<rightarrow> 'b bar) \<times> ('b baz \<rightarrow> 'a baz) \<rightarrow>
-     ('a foo \<rightarrow> 'b foo) \<times> ('a bar \<rightarrow> 'b bar) \<times> ('b baz \<rightarrow> 'a baz)"
-where
-  "foo_bar_baz_mapF = (\<Lambda> f. Abs_cfun (\<lambda>(d1, d2, d3).
-    (
-      foo_abs oo
-        ssum_map\<cdot>ID\<cdot>(sprod_map\<cdot>(u_map\<cdot>f)\<cdot>(u_map\<cdot>d2))
-          oo foo_rep
-    ,
-      bar_abs oo u_map\<cdot>(cfun_map\<cdot>d3\<cdot>ID) oo bar_rep
-    ,
-      baz_abs oo u_map\<cdot>(cfun_map\<cdot>(convex_map\<cdot>d1)\<cdot>ID) oo baz_rep
-    )))"
-
-lemma foo_bar_baz_mapF_beta:
-  "foo_bar_baz_mapF\<cdot>f\<cdot>d =
-    (
-      foo_abs oo
-        ssum_map\<cdot>ID\<cdot>(sprod_map\<cdot>(u_map\<cdot>f)\<cdot>(u_map\<cdot>(fst (snd d))))
-          oo foo_rep
-    ,
-      bar_abs oo u_map\<cdot>(cfun_map\<cdot>(snd (snd d))\<cdot>ID) oo bar_rep
-    ,
-      baz_abs oo u_map\<cdot>(cfun_map\<cdot>(convex_map\<cdot>(fst d))\<cdot>ID) oo baz_rep
-    )"
-unfolding foo_bar_baz_mapF_def
-by (simp add: split_def)
-
-text {* Individual map functions are projected from the fixed point. *}
-
-definition foo_map :: "('a \<rightarrow> 'b) \<rightarrow> ('a foo \<rightarrow> 'b foo)"
-where "foo_map = (\<Lambda> f. fst (fix\<cdot>(foo_bar_baz_mapF\<cdot>f)))"
-
-definition bar_map :: "('a \<rightarrow> 'b) \<rightarrow> ('a bar \<rightarrow> 'b bar)"
-where "bar_map = (\<Lambda> f. fst (snd (fix\<cdot>(foo_bar_baz_mapF\<cdot>f))))"
-
-definition baz_map :: "('a \<rightarrow> 'b) \<rightarrow> ('b baz \<rightarrow> 'a baz)"
-where "baz_map = (\<Lambda> f. snd (snd (fix\<cdot>(foo_bar_baz_mapF\<cdot>f))))"
-
-lemma map_apply_thms:
-  "foo_map\<cdot>f = fst (fix\<cdot>(foo_bar_baz_mapF\<cdot>f))"
-  "bar_map\<cdot>f = fst (snd (fix\<cdot>(foo_bar_baz_mapF\<cdot>f)))"
-  "baz_map\<cdot>f = snd (snd (fix\<cdot>(foo_bar_baz_mapF\<cdot>f)))"
-unfolding foo_map_def bar_map_def baz_map_def by simp_all
-
-text {* Prove isodefl rules for all map functions simultaneously. *}
-
-lemma isodefl_foo_bar_baz:
-  assumes isodefl_d: "isodefl (u_map\<cdot>d) t"
-  shows
-  "isodefl (foo_map\<cdot>d) (foo_defl\<cdot>t) \<and>
-  isodefl (bar_map\<cdot>d) (bar_defl\<cdot>t) \<and>
-  isodefl (baz_map\<cdot>d) (baz_defl\<cdot>t)"
-unfolding map_apply_thms defl_apply_thms
- apply (rule parallel_fix_ind)
-   apply (intro adm_conj adm_isodefl cont2cont_fst cont2cont_snd cont_id)
-  apply (simp only: fst_strict snd_strict isodefl_bottom simp_thms)
- apply (simp only: foo_bar_baz_mapF_beta
-                   foo_bar_baz_deflF_beta
-                   fst_conv snd_conv)
- apply (elim conjE)
- apply (intro
-  conjI
-  isodefl_foo_abs
-  isodefl_bar_abs
-  isodefl_baz_abs
-  domain_isodefl
-  isodefl_ID_DEFL isodefl_LIFTDEFL
-  isodefl_d
- )
- apply assumption+
-done
-
-lemmas isodefl_foo = isodefl_foo_bar_baz [THEN conjunct1]
-lemmas isodefl_bar = isodefl_foo_bar_baz [THEN conjunct2, THEN conjunct1]
-lemmas isodefl_baz = isodefl_foo_bar_baz [THEN conjunct2, THEN conjunct2]
-
-text {* Prove map ID lemmas, using isodefl_DEFL_imp_ID *}
-
-lemma foo_map_ID: "foo_map\<cdot>ID = ID"
-apply (rule isodefl_DEFL_imp_ID)
-apply (subst DEFL_foo)
-apply (rule isodefl_foo)
-apply (rule isodefl_LIFTDEFL)
-done
-
-lemma bar_map_ID: "bar_map\<cdot>ID = ID"
-apply (rule isodefl_DEFL_imp_ID)
-apply (subst DEFL_bar)
-apply (rule isodefl_bar)
-apply (rule isodefl_LIFTDEFL)
-done
-
-lemma baz_map_ID: "baz_map\<cdot>ID = ID"
-apply (rule isodefl_DEFL_imp_ID)
-apply (subst DEFL_baz)
-apply (rule isodefl_baz)
-apply (rule isodefl_LIFTDEFL)
-done
-
-(********************************************************************)
-
-subsection {* Step 5: Define take functions, prove lub-take lemmas *}
-
-definition
-  foo_bar_baz_takeF ::
-    "('a foo \<rightarrow> 'a foo) \<times> ('a bar \<rightarrow> 'a bar) \<times> ('a baz \<rightarrow> 'a baz) \<rightarrow>
-     ('a foo \<rightarrow> 'a foo) \<times> ('a bar \<rightarrow> 'a bar) \<times> ('a baz \<rightarrow> 'a baz)"
-where
-  "foo_bar_baz_takeF = (\<Lambda> p.
-    ( foo_abs oo
-        ssum_map\<cdot>ID\<cdot>(sprod_map\<cdot>(u_map\<cdot>ID)\<cdot>(u_map\<cdot>(fst (snd p))))
-          oo foo_rep
-    , bar_abs oo
-        u_map\<cdot>(cfun_map\<cdot>(snd (snd p))\<cdot>ID) oo bar_rep
-    , baz_abs oo
-        u_map\<cdot>(cfun_map\<cdot>(convex_map\<cdot>(fst p))\<cdot>ID) oo baz_rep
-    ))"
-
-lemma foo_bar_baz_takeF_beta:
-  "foo_bar_baz_takeF\<cdot>p =
-    ( foo_abs oo
-        ssum_map\<cdot>ID\<cdot>(sprod_map\<cdot>(u_map\<cdot>ID)\<cdot>(u_map\<cdot>(fst (snd p))))
-          oo foo_rep
-    , bar_abs oo
-        u_map\<cdot>(cfun_map\<cdot>(snd (snd p))\<cdot>ID) oo bar_rep
-    , baz_abs oo
-        u_map\<cdot>(cfun_map\<cdot>(convex_map\<cdot>(fst p))\<cdot>ID) oo baz_rep
-    )"
-unfolding foo_bar_baz_takeF_def by (rule beta_cfun, simp)
-
-definition
-  foo_take :: "nat \<Rightarrow> 'a foo \<rightarrow> 'a foo"
-where
-  "foo_take = (\<lambda>n. fst (iterate n\<cdot>foo_bar_baz_takeF\<cdot>\<bottom>))"
-
-definition
-  bar_take :: "nat \<Rightarrow> 'a bar \<rightarrow> 'a bar"
-where
-  "bar_take = (\<lambda>n. fst (snd (iterate n\<cdot>foo_bar_baz_takeF\<cdot>\<bottom>)))"
-
-definition
-  baz_take :: "nat \<Rightarrow> 'a baz \<rightarrow> 'a baz"
-where
-  "baz_take = (\<lambda>n. snd (snd (iterate n\<cdot>foo_bar_baz_takeF\<cdot>\<bottom>)))"
-
-lemma chain_take_thms: "chain foo_take" "chain bar_take" "chain baz_take"
-unfolding foo_take_def bar_take_def baz_take_def
-by (intro ch2ch_fst ch2ch_snd chain_iterate)+
-
-lemma take_0_thms: "foo_take 0 = \<bottom>" "bar_take 0 = \<bottom>" "baz_take 0 = \<bottom>"
-unfolding foo_take_def bar_take_def baz_take_def
-by (simp only: iterate_0 fst_strict snd_strict)+
-
-lemma take_Suc_thms:
-  "foo_take (Suc n) =
-    foo_abs oo ssum_map\<cdot>ID\<cdot>(sprod_map\<cdot>(u_map\<cdot>ID)\<cdot>(u_map\<cdot>(bar_take n))) oo foo_rep"
-  "bar_take (Suc n) =
-    bar_abs oo u_map\<cdot>(cfun_map\<cdot>(baz_take n)\<cdot>ID) oo bar_rep"
-  "baz_take (Suc n) =
-    baz_abs oo u_map\<cdot>(cfun_map\<cdot>(convex_map\<cdot>(foo_take n))\<cdot>ID) oo baz_rep"
-unfolding foo_take_def bar_take_def baz_take_def
-by (simp only: iterate_Suc foo_bar_baz_takeF_beta fst_conv snd_conv)+
-
-lemma lub_take_lemma:
-  "(\<Squnion>n. foo_take n, \<Squnion>n. bar_take n, \<Squnion>n. baz_take n)
-    = (foo_map\<cdot>(ID::'a \<rightarrow> 'a), bar_map\<cdot>(ID::'a \<rightarrow> 'a), baz_map\<cdot>(ID::'a \<rightarrow> 'a))"
-apply (simp only: lub_Pair [symmetric] ch2ch_Pair chain_take_thms)
-apply (simp only: map_apply_thms pair_collapse)
-apply (simp only: fix_def2)
-apply (rule lub_eq)
-apply (rule nat.induct)
-apply (simp only: iterate_0 Pair_strict take_0_thms)
-apply (simp only: iterate_Suc Pair_fst_snd_eq fst_conv snd_conv
-                  foo_bar_baz_mapF_beta take_Suc_thms simp_thms)
-done
-
-lemma lub_foo_take: "(\<Squnion>n. foo_take n) = ID"
-apply (rule trans [OF _ foo_map_ID])
-using lub_take_lemma
-apply (elim Pair_inject)
-apply assumption
-done
-
-lemma lub_bar_take: "(\<Squnion>n. bar_take n) = ID"
-apply (rule trans [OF _ bar_map_ID])
-using lub_take_lemma
-apply (elim Pair_inject)
-apply assumption
-done
-
-lemma lub_baz_take: "(\<Squnion>n. baz_take n) = ID"
-apply (rule trans [OF _ baz_map_ID])
-using lub_take_lemma
-apply (elim Pair_inject)
-apply assumption
-done
-
-end

--- a/src/HOLCF/ex/Fix2.thy	Sat Nov 27 14:34:54 2010 -0800
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,32 +0,0 @@
-(*  Title:      HOLCF/ex/Fix2.thy
-    Author:     Franz Regensburger
-
-Show that fix is the unique least fixed-point operator.
-From axioms gix1_def,gix2_def it follows that fix = gix
-*)
-
-theory Fix2
-imports HOLCF
-begin
-
-axiomatization
-  gix :: "('a->'a)->'a" where
-  gix1_def: "F$(gix$F) = gix$F" and
-  gix2_def: "F$y=y ==> gix$F << y"
-
-
-lemma lemma1: "fix = gix"
-apply (rule cfun_eqI)
-apply (rule below_antisym)
-apply (rule fix_least)
-apply (rule gix1_def)
-apply (rule gix2_def)
-apply (rule fix_eq [symmetric])
-done
-
-lemma lemma2: "gix$F=lub(range(%i. iterate i$F$UU))"
-apply (rule lemma1 [THEN subst])
-apply (rule fix_def2)
-done
-
-end

--- a/src/HOLCF/ex/Focus_ex.thy	Sat Nov 27 14:34:54 2010 -0800
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,258 +0,0 @@
-(* Specification of the following loop back device
-
-
-          g
-           --------------------
-          |      -------       |
-       x  |     |       |      |  y
-    ------|---->|       |------| ----->
-          |  z  |   f   | z    |
-          |  -->|       |---   |
-          | |   |       |   |  |
-          | |    -------    |  |
-          | |               |  |
-          |  <--------------   |
-          |                    |
-           --------------------
-
-
-First step: Notation in Agent Network Description Language (ANDL)
------------------------------------------------------------------
-
-agent f
-        input  channel i1:'b i2: ('b,'c) tc
-        output channel o1:'c o2: ('b,'c) tc
-is
-        Rf(i1,i2,o1,o2)  (left open in the example)
-end f
-
-agent g
-        input  channel x:'b
-        output channel y:'c
-is network
-        (y,z) = f$(x,z)
-end network
-end g
-
-
-Remark: the type of the feedback depends at most on the types of the input and
-        output of g. (No type miracles inside g)
-
-Second step: Translation of ANDL specification to HOLCF Specification
----------------------------------------------------------------------
-
-Specification of agent f ist translated to predicate is_f
-
-is_f :: ('b stream * ('b,'c) tc stream ->
-                'c stream * ('b,'c) tc stream) => bool
-
-is_f f  = !i1 i2 o1 o2.
-        f$(i1,i2) = (o1,o2) --> Rf(i1,i2,o1,o2)
-
-Specification of agent g is translated to predicate is_g which uses
-predicate is_net_g
-
-is_net_g :: ('b stream * ('b,'c) tc stream -> 'c stream * ('b,'c) tc stream) =>
-            'b stream => 'c stream => bool
-
-is_net_g f x y =
-        ? z. (y,z) = f$(x,z) &
-        !oy hz. (oy,hz) = f$(x,hz) --> z << hz
-
-
-is_g :: ('b stream -> 'c stream) => bool
-
-is_g g  = ? f. is_f f  & (!x y. g$x = y --> is_net_g f x y
-
-Third step: (show conservativity)
------------
-
-Suppose we have a model for the theory TH1 which contains the axiom
-
-        ? f. is_f f
-
-In this case there is also a model for the theory TH2 that enriches TH1 by
-axiom
-
-        ? g. is_g g
-
-The result is proved by showing that there is a definitional extension
-that extends TH1 by a definition of g.
-
-
-We define:
-
-def_g g  =
-         (? f. is_f f  &
-              g = (LAM x. fst (f$(x,fix$(LAM k. snd (f$(x,k)))))) )
-
-Now we prove:
-
-        (? f. is_f f ) --> (? g. is_g g)
-
-using the theorems
-
-loopback_eq)    def_g = is_g                    (real work)
-
-L1)             (? f. is_f f ) --> (? g. def_g g)  (trivial)
-
-*)
-
-theory Focus_ex
-imports Stream
-begin
-
-typedecl ('a, 'b) tc
-arities tc:: (pcpo, pcpo) pcpo
-
-axiomatization
-  Rf :: "('b stream * ('b,'c) tc stream * 'c stream * ('b,'c) tc stream) => bool"
-
-definition
-  is_f :: "('b stream * ('b,'c) tc stream -> 'c stream * ('b,'c) tc stream) => bool" where
-  "is_f f = (!i1 i2 o1 o2. f$(i1,i2) = (o1,o2) --> Rf(i1,i2,o1,o2))"
-
-definition
-  is_net_g :: "('b stream *('b,'c) tc stream -> 'c stream * ('b,'c) tc stream) =>
-    'b stream => 'c stream => bool" where
-  "is_net_g f x y == (? z.
-                        (y,z) = f$(x,z) &
-                        (!oy hz. (oy,hz) = f$(x,hz) --> z << hz))"
-
-definition
-  is_g :: "('b stream -> 'c stream) => bool" where
-  "is_g g  == (? f. is_f f  & (!x y. g$x = y --> is_net_g f x y))"
-
-definition
-  def_g :: "('b stream -> 'c stream) => bool" where
-  "def_g g == (? f. is_f f  & g = (LAM x. fst (f$(x,fix$(LAM  k. snd (f$(x,k)))))))"
-
-
-(* first some logical trading *)
-
-lemma lemma1:
-"is_g(g) =
-  (? f. is_f(f) &  (!x.(? z. (g$x,z) = f$(x,z) &
-                   (! w y. (y,w) = f$(x,w)  --> z << w))))"
-apply (simp add: is_g_def is_net_g_def)
-apply fast
-done
-
-lemma lemma2:
-"(? f. is_f(f) &  (!x. (? z. (g$x,z) = f$(x,z) &
-                  (!w y. (y,w) = f$(x,w)  --> z << w))))
-  =
-  (? f. is_f(f) &  (!x. ? z.
-        g$x = fst (f$(x,z)) &
-          z = snd (f$(x,z)) &
-        (! w y.  (y,w) = f$(x,w) --> z << w)))"
-apply (rule iffI)
-apply (erule exE)
-apply (rule_tac x = "f" in exI)
-apply (erule conjE)+
-apply (erule conjI)
-apply (intro strip)
-apply (erule allE)
-apply (erule exE)
-apply (rule_tac x = "z" in exI)
-apply (erule conjE)+
-apply (rule conjI)
-apply (rule_tac [2] conjI)
-prefer 3 apply (assumption)
-apply (drule sym)
-apply (simp)
-apply (drule sym)
-apply (simp)
-apply (erule exE)
-apply (rule_tac x = "f" in exI)
-apply (erule conjE)+
-apply (erule conjI)
-apply (intro strip)
-apply (erule allE)
-apply (erule exE)
-apply (rule_tac x = "z" in exI)
-apply (erule conjE)+
-apply (rule conjI)
-prefer 2 apply (assumption)
-apply (rule prod_eqI)
-apply simp
-apply simp
-done
-
-lemma lemma3: "def_g(g) --> is_g(g)"
-apply (tactic {* simp_tac (HOL_ss addsimps [@{thm def_g_def}, @{thm lemma1}, @{thm lemma2}]) 1 *})
-apply (rule impI)
-apply (erule exE)
-apply (rule_tac x = "f" in exI)
-apply (erule conjE)+
-apply (erule conjI)
-apply (intro strip)
-apply (rule_tac x = "fix$ (LAM k. snd (f$(x,k)))" in exI)
-apply (rule conjI)
- apply (simp)
- apply (rule prod_eqI, simp, simp)
- apply (rule trans)
-  apply (rule fix_eq)
- apply (simp (no_asm))
-apply (intro strip)
-apply (rule fix_least)
-apply (simp (no_asm))
-apply (erule exE)
-apply (drule sym)
-back
-apply simp
-done
-
-lemma lemma4: "is_g(g) --> def_g(g)"
-apply (tactic {* simp_tac (HOL_ss delsimps (@{thms HOL.ex_simps} @ @{thms HOL.all_simps})
-  addsimps [@{thm lemma1}, @{thm lemma2}, @{thm def_g_def}]) 1 *})
-apply (rule impI)
-apply (erule exE)
-apply (rule_tac x = "f" in exI)
-apply (erule conjE)+
-apply (erule conjI)
-apply (rule cfun_eqI)
-apply (erule_tac x = "x" in allE)
-apply (erule exE)
-apply (erule conjE)+
-apply (subgoal_tac "fix$ (LAM k. snd (f$(x, k))) = z")
- apply simp
-apply (subgoal_tac "! w y. f$(x, w) = (y, w) --> z << w")
-apply (rule fix_eqI)
-apply simp
-apply (subgoal_tac "f$(x, za) = (fst (f$(x,za)) ,za)")
-apply fast
-apply (rule prod_eqI, simp, simp)
-apply (intro strip)
-apply (erule allE)+
-apply (erule mp)
-apply (erule sym)
-done
-
-(* now we assemble the result *)
-
-lemma loopback_eq: "def_g = is_g"
-apply (rule ext)
-apply (rule iffI)
-apply (erule lemma3 [THEN mp])
-apply (erule lemma4 [THEN mp])
-done
-
-lemma L2:
-"(? f.
-  is_f(f::'b stream * ('b,'c) tc stream -> 'c stream * ('b,'c) tc stream))
-  -->
-  (? g. def_g(g::'b stream -> 'c stream ))"
-apply (simp add: def_g_def)
-done
-
-theorem conservative_loopback:
-"(? f.
-  is_f(f::'b stream * ('b,'c) tc stream -> 'c stream * ('b,'c) tc stream))
-  -->
-  (? g. is_g(g::'b stream -> 'c stream ))"
-apply (rule loopback_eq [THEN subst])
-apply (rule L2)
-done
-
-end

--- a/src/HOLCF/ex/Hoare.thy	Sat Nov 27 14:34:54 2010 -0800
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,425 +0,0 @@
-(*  Title:      HOLCF/ex/hoare.thy
-    Author:     Franz Regensburger
-
-Theory for an example by C.A.R. Hoare
-
-p x = if b1 x
-         then p (g x)
-         else x fi
-
-q x = if b1 x orelse b2 x
-         then q (g x)
-         else x fi
-
-Prove: for all b1 b2 g .
-            q o p  = q
-
-In order to get a nice notation we fix the functions b1,b2 and g in the
-signature of this example
-
-*)
-
-theory Hoare
-imports HOLCF
-begin
-
-axiomatization
-  b1 :: "'a -> tr" and
-  b2 :: "'a -> tr" and
-  g :: "'a -> 'a"
-
-definition
-  p :: "'a -> 'a" where
-  "p = fix$(LAM f. LAM x. If b1$x then f$(g$x) else x)"
-
-definition
-  q :: "'a -> 'a" where
-  "q = fix$(LAM f. LAM x. If b1$x orelse b2$x then f$(g$x) else x)"
-
-
-(* --------- pure HOLCF logic, some little lemmas ------ *)
-
-lemma hoare_lemma2: "b~=TT ==> b=FF | b=UU"
-apply (rule Exh_tr [THEN disjE])
-apply blast+
-done
-
-lemma hoare_lemma3: " (ALL k. b1$(iterate k$g$x) = TT) | (EX k. b1$(iterate k$g$x)~=TT)"
-apply blast
-done
-
-lemma hoare_lemma4: "(EX k. b1$(iterate k$g$x) ~= TT) ==>  
-  EX k. b1$(iterate k$g$x) = FF | b1$(iterate k$g$x) = UU"
-apply (erule exE)
-apply (rule exI)
-apply (rule hoare_lemma2)
-apply assumption
-done
-
-lemma hoare_lemma5: "[|(EX k. b1$(iterate k$g$x) ~= TT); 
-    k=Least(%n. b1$(iterate n$g$x) ~= TT)|] ==>  
-  b1$(iterate k$g$x)=FF | b1$(iterate k$g$x)=UU"
-apply hypsubst
-apply (rule hoare_lemma2)
-apply (erule exE)
-apply (erule LeastI)
-done
-
-lemma hoare_lemma6: "b=UU ==> b~=TT"
-apply hypsubst
-apply (rule dist_eq_tr)
-done
-
-lemma hoare_lemma7: "b=FF ==> b~=TT"
-apply hypsubst
-apply (rule dist_eq_tr)
-done
-
-lemma hoare_lemma8: "[|(EX k. b1$(iterate k$g$x) ~= TT); 
-    k=Least(%n. b1$(iterate n$g$x) ~= TT)|] ==>  
-  ALL m. m < k --> b1$(iterate m$g$x)=TT"
-apply hypsubst
-apply (erule exE)
-apply (intro strip)
-apply (rule_tac p = "b1$ (iterate m$g$x) " in trE)
-prefer 2 apply (assumption)
-apply (rule le_less_trans [THEN less_irrefl [THEN notE]])
-prefer 2 apply (assumption)
-apply (rule Least_le)
-apply (erule hoare_lemma6)
-apply (rule le_less_trans [THEN less_irrefl [THEN notE]])
-prefer 2 apply (assumption)
-apply (rule Least_le)
-apply (erule hoare_lemma7)
-done
-
-
-lemma hoare_lemma28: "f$(y::'a)=(UU::tr) ==> f$UU = UU"
-by (rule strictI)
-
-
-(* ----- access to definitions ----- *)
-
-lemma p_def3: "p$x = If b1$x then p$(g$x) else x"
-apply (rule trans)
-apply (rule p_def [THEN eq_reflection, THEN fix_eq3])
-apply simp
-done
-
-lemma q_def3: "q$x = If b1$x orelse b2$x then q$(g$x) else x"
-apply (rule trans)
-apply (rule q_def [THEN eq_reflection, THEN fix_eq3])
-apply simp
-done
-
-(** --------- proofs about iterations of p and q ---------- **)
-
-lemma hoare_lemma9: "(ALL m. m< Suc k --> b1$(iterate m$g$x)=TT) --> 
-   p$(iterate k$g$x)=p$x"
-apply (induct_tac k)
-apply (simp (no_asm))
-apply (simp (no_asm))
-apply (intro strip)
-apply (rule_tac s = "p$ (iterate n$g$x) " in trans)
-apply (rule trans)
-apply (rule_tac [2] p_def3 [symmetric])
-apply (rule_tac s = "TT" and t = "b1$ (iterate n$g$x) " in ssubst)
-apply (rule mp)
-apply (erule spec)
-apply (simp (no_asm) add: less_Suc_eq)
-apply simp
-apply (erule mp)
-apply (intro strip)
-apply (rule mp)
-apply (erule spec)
-apply (erule less_trans)
-apply simp
-done
-
-lemma hoare_lemma24: "(ALL m. m< Suc k --> b1$(iterate m$g$x)=TT) -->  
-  q$(iterate k$g$x)=q$x"
-apply (induct_tac k)
-apply (simp (no_asm))
-apply (simp (no_asm) add: less_Suc_eq)
-apply (intro strip)
-apply (rule_tac s = "q$ (iterate n$g$x) " in trans)
-apply (rule trans)
-apply (rule_tac [2] q_def3 [symmetric])
-apply (rule_tac s = "TT" and t = "b1$ (iterate n$g$x) " in ssubst)
-apply blast
-apply simp
-apply (erule mp)
-apply (intro strip)
-apply (fast dest!: less_Suc_eq [THEN iffD1])
-done
-
-(* -------- results about p for case (EX k. b1$(iterate k$g$x)~=TT) ------- *)
-
-thm hoare_lemma8 [THEN hoare_lemma9 [THEN mp], standard]
-
-lemma hoare_lemma10:
-  "EX k. b1$(iterate k$g$x) ~= TT
-    ==> Suc k = (LEAST n. b1$(iterate n$g$x) ~= TT) ==> p$(iterate k$g$x) = p$x"
-  by (rule hoare_lemma8 [THEN hoare_lemma9 [THEN mp]])
-
-lemma hoare_lemma11: "(EX n. b1$(iterate n$g$x) ~= TT) ==> 
-  k=(LEAST n. b1$(iterate n$g$x) ~= TT) & b1$(iterate k$g$x)=FF  
-  --> p$x = iterate k$g$x"
-apply (case_tac "k")
-apply hypsubst
-apply (simp (no_asm))
-apply (intro strip)
-apply (erule conjE)
-apply (rule trans)
-apply (rule p_def3)
-apply simp
-apply hypsubst
-apply (intro strip)
-apply (erule conjE)
-apply (rule trans)
-apply (erule hoare_lemma10 [symmetric])
-apply assumption
-apply (rule trans)
-apply (rule p_def3)
-apply (rule_tac s = "TT" and t = "b1$ (iterate nat$g$x) " in ssubst)
-apply (rule hoare_lemma8 [THEN spec, THEN mp])
-apply assumption
-apply assumption
-apply (simp (no_asm))
-apply (simp (no_asm))
-apply (rule trans)
-apply (rule p_def3)
-apply (simp (no_asm) del: iterate_Suc add: iterate_Suc [symmetric])
-apply (erule_tac s = "FF" in ssubst)
-apply simp
-done
-
-lemma hoare_lemma12: "(EX n. b1$(iterate n$g$x) ~= TT) ==> 
-  k=Least(%n. b1$(iterate n$g$x)~=TT) & b1$(iterate k$g$x)=UU  
-  --> p$x = UU"
-apply (case_tac "k")
-apply hypsubst
-apply (simp (no_asm))
-apply (intro strip)
-apply (erule conjE)
-apply (rule trans)
-apply (rule p_def3)
-apply simp
-apply hypsubst
-apply (simp (no_asm))
-apply (intro strip)
-apply (erule conjE)
-apply (rule trans)
-apply (rule hoare_lemma10 [symmetric])
-apply assumption
-apply assumption
-apply (rule trans)
-apply (rule p_def3)
-apply (rule_tac s = "TT" and t = "b1$ (iterate nat$g$x) " in ssubst)
-apply (rule hoare_lemma8 [THEN spec, THEN mp])
-apply assumption
-apply assumption
-apply (simp (no_asm))
-apply (simp)
-apply (rule trans)
-apply (rule p_def3)
-apply simp
-done
-
-(* -------- results about p for case  (ALL k. b1$(iterate k$g$x)=TT) ------- *)
-
-lemma fernpass_lemma: "(ALL k. b1$(iterate k$g$x)=TT) ==> ALL k. p$(iterate k$g$x) = UU"
-apply (rule p_def [THEN eq_reflection, THEN def_fix_ind])
-apply simp
-apply simp
-apply (simp (no_asm))
-apply (rule allI)
-apply (rule_tac s = "TT" and t = "b1$ (iterate k$g$x) " in ssubst)
-apply (erule spec)
-apply (simp)
-apply (rule iterate_Suc [THEN subst])
-apply (erule spec)
-done
-
-lemma hoare_lemma16: "(ALL k. b1$(iterate k$g$x)=TT) ==> p$x = UU"
-apply (rule_tac F1 = "g" and t = "x" in iterate_0 [THEN subst])
-apply (erule fernpass_lemma [THEN spec])
-done
-
-(* -------- results about q for case  (ALL k. b1$(iterate k$g$x)=TT) ------- *)
-
-lemma hoare_lemma17: "(ALL k. b1$(iterate k$g$x)=TT) ==> ALL k. q$(iterate k$g$x) = UU"
-apply (rule q_def [THEN eq_reflection, THEN def_fix_ind])
-apply simp
-apply simp
-apply (rule allI)
-apply (simp (no_asm))
-apply (rule_tac s = "TT" and t = "b1$ (iterate k$g$x) " in ssubst)
-apply (erule spec)
-apply (simp)
-apply (rule iterate_Suc [THEN subst])
-apply (erule spec)
-done
-
-lemma hoare_lemma18: "(ALL k. b1$(iterate k$g$x)=TT) ==> q$x = UU"
-apply (rule_tac F1 = "g" and t = "x" in iterate_0 [THEN subst])
-apply (erule hoare_lemma17 [THEN spec])
-done
-
-lemma hoare_lemma19:
-  "(ALL k. (b1::'a->tr)$(iterate k$g$x)=TT) ==> b1$(UU::'a) = UU | (ALL y. b1$(y::'a)=TT)"
-apply (rule flat_codom)
-apply (rule_tac t = "x1" in iterate_0 [THEN subst])
-apply (erule spec)
-done
-
-lemma hoare_lemma20: "(ALL y. b1$(y::'a)=TT) ==> ALL k. q$(iterate k$g$(x::'a)) = UU"
-apply (rule q_def [THEN eq_reflection, THEN def_fix_ind])
-apply simp
-apply simp
-apply (rule allI)
-apply (simp (no_asm))
-apply (rule_tac s = "TT" and t = "b1$ (iterate k$g$ (x::'a))" in ssubst)
-apply (erule spec)
-apply (simp)
-apply (rule iterate_Suc [THEN subst])
-apply (erule spec)
-done
-
-lemma hoare_lemma21: "(ALL y. b1$(y::'a)=TT) ==> q$(x::'a) = UU"
-apply (rule_tac F1 = "g" and t = "x" in iterate_0 [THEN subst])
-apply (erule hoare_lemma20 [THEN spec])
-done
-
-lemma hoare_lemma22: "b1$(UU::'a)=UU ==> q$(UU::'a) = UU"
-apply (subst q_def3)
-apply simp
-done
-
-(* -------- results about q for case (EX k. b1$(iterate k$g$x) ~= TT) ------- *)
-
-lemma hoare_lemma25: "EX k. b1$(iterate k$g$x) ~= TT
-  ==> Suc k = (LEAST n. b1$(iterate n$g$x) ~= TT) ==> q$(iterate k$g$x) = q$x"
-  by (rule hoare_lemma8 [THEN hoare_lemma24 [THEN mp]])
-
-lemma hoare_lemma26: "(EX n. b1$(iterate n$g$x)~=TT) ==> 
-  k=Least(%n. b1$(iterate n$g$x) ~= TT) & b1$(iterate k$g$x) =FF  
-  --> q$x = q$(iterate k$g$x)"
-apply (case_tac "k")
-apply hypsubst
-apply (intro strip)
-apply (simp (no_asm))
-apply hypsubst
-apply (intro strip)
-apply (erule conjE)
-apply (rule trans)
-apply (rule hoare_lemma25 [symmetric])
-apply assumption
-apply assumption
-apply (rule trans)
-apply (rule q_def3)
-apply (rule_tac s = "TT" and t = "b1$ (iterate nat$g$x) " in ssubst)
-apply (rule hoare_lemma8 [THEN spec, THEN mp])
-apply assumption
-apply assumption
-apply (simp (no_asm))
-apply (simp (no_asm))
-done
-
-
-lemma hoare_lemma27: "(EX n. b1$(iterate n$g$x) ~= TT) ==> 
-  k=Least(%n. b1$(iterate n$g$x)~=TT) & b1$(iterate k$g$x)=UU  
-  --> q$x = UU"
-apply (case_tac "k")
-apply hypsubst
-apply (simp (no_asm))
-apply (intro strip)
-apply (erule conjE)
-apply (subst q_def3)
-apply (simp)
-apply hypsubst
-apply (simp (no_asm))
-apply (intro strip)
-apply (erule conjE)
-apply (rule trans)
-apply (rule hoare_lemma25 [symmetric])
-apply assumption
-apply assumption
-apply (rule trans)
-apply (rule q_def3)
-apply (rule_tac s = "TT" and t = "b1$ (iterate nat$g$x) " in ssubst)
-apply (rule hoare_lemma8 [THEN spec, THEN mp])
-apply assumption
-apply assumption
-apply (simp (no_asm))
-apply (simp)
-apply (rule trans)
-apply (rule q_def3)
-apply (simp)
-done
-
-(* ------- (ALL k. b1$(iterate k$g$x)=TT) ==> q o p = q   ----- *)
-
-lemma hoare_lemma23: "(ALL k. b1$(iterate k$g$x)=TT) ==> q$(p$x) = q$x"
-apply (subst hoare_lemma16)
-apply assumption
-apply (rule hoare_lemma19 [THEN disjE])
-apply assumption
-apply (simplesubst hoare_lemma18)
-apply assumption
-apply (simplesubst hoare_lemma22)
-apply assumption
-apply (rule refl)
-apply (simplesubst hoare_lemma21)
-apply assumption
-apply (simplesubst hoare_lemma21)
-apply assumption
-apply (rule refl)
-done
-
-(* ------------  EX k. b1~(iterate k$g$x) ~= TT ==> q o p = q   ----- *)
-
-lemma hoare_lemma29: "EX k. b1$(iterate k$g$x) ~= TT ==> q$(p$x) = q$x"
-apply (rule hoare_lemma5 [THEN disjE])
-apply assumption
-apply (rule refl)
-apply (subst hoare_lemma11 [THEN mp])
-apply assumption
-apply (rule conjI)
-apply (rule refl)
-apply assumption
-apply (rule hoare_lemma26 [THEN mp, THEN subst])
-apply assumption
-apply (rule conjI)
-apply (rule refl)
-apply assumption
-apply (rule refl)
-apply (subst hoare_lemma12 [THEN mp])
-apply assumption
-apply (rule conjI)
-apply (rule refl)
-apply assumption
-apply (subst hoare_lemma22)
-apply (subst hoare_lemma28)
-apply assumption
-apply (rule refl)
-apply (rule sym)
-apply (subst hoare_lemma27 [THEN mp])
-apply assumption
-apply (rule conjI)
-apply (rule refl)
-apply assumption
-apply (rule refl)
-done
-
-(* ------ the main proof q o p = q ------ *)
-
-theorem hoare_main: "q oo p = q"
-apply (rule cfun_eqI)
-apply (subst cfcomp2)
-apply (rule hoare_lemma3 [THEN disjE])
-apply (erule hoare_lemma23)
-apply (erule hoare_lemma29)
-done
-
-end

--- a/src/HOLCF/ex/Letrec.thy	Sat Nov 27 14:34:54 2010 -0800
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,37 +0,0 @@
-(*  Title:      HOLCF/ex/Letrec.thy
-    Author:     Brian Huffman
-*)
-
-header {* Recursive let bindings *}
-
-theory Letrec
-imports HOLCF
-begin
-
-default_sort pcpo
-
-definition
-  CLetrec :: "('a \<rightarrow> 'a \<times> 'b) \<rightarrow> 'b" where
-  "CLetrec = (\<Lambda> F. snd (F\<cdot>(\<mu> x. fst (F\<cdot>x))))"
-
-nonterminals
-  recbinds recbindt recbind
-
-syntax
-  "_recbind"  :: "['a, 'a] \<Rightarrow> recbind"               ("(2_ =/ _)" 10)
-  ""          :: "recbind \<Rightarrow> recbindt"               ("_")
-  "_recbindt" :: "[recbind, recbindt] \<Rightarrow> recbindt"   ("_,/ _")
-  ""          :: "recbindt \<Rightarrow> recbinds"              ("_")
-  "_recbinds" :: "[recbindt, recbinds] \<Rightarrow> recbinds"  ("_;/ _")
-  "_Letrec"   :: "[recbinds, 'a] \<Rightarrow> 'a"      ("(Letrec (_)/ in (_))" 10)
-
-translations
-  (recbindt) "x = a, (y,ys) = (b,bs)" == (recbindt) "(x,y,ys) = (a,b,bs)"
-  (recbindt) "x = a, y = b"          == (recbindt) "(x,y) = (a,b)"
-
-translations
-  "_Letrec (_recbinds b bs) e" == "_Letrec b (_Letrec bs e)"
-  "Letrec xs = a in (e,es)"    == "CONST CLetrec\<cdot>(\<Lambda> xs. (a,e,es))"
-  "Letrec xs = a in e"         == "CONST CLetrec\<cdot>(\<Lambda> xs. (a,e))"
-
-end

--- a/src/HOLCF/ex/Loop.thy	Sat Nov 27 14:34:54 2010 -0800
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,200 +0,0 @@
-(*  Title:      HOLCF/ex/Loop.thy
-    Author:     Franz Regensburger
-*)
-
-header {* Theory for a loop primitive like while *}
-
-theory Loop
-imports HOLCF
-begin
-
-definition
-  step  :: "('a -> tr)->('a -> 'a)->'a->'a" where
-  "step = (LAM b g x. If b$x then g$x else x)"
-
-definition
-  while :: "('a -> tr)->('a -> 'a)->'a->'a" where
-  "while = (LAM b g. fix$(LAM f x. If b$x then f$(g$x) else x))"
-
-(* ------------------------------------------------------------------------- *)
-(* access to definitions                                                     *)
-(* ------------------------------------------------------------------------- *)
-
-
-lemma step_def2: "step$b$g$x = If b$x then g$x else x"
-apply (unfold step_def)
-apply simp
-done
-
-lemma while_def2: "while$b$g = fix$(LAM f x. If b$x then f$(g$x) else x)"
-apply (unfold while_def)
-apply simp
-done
-
-
-(* ------------------------------------------------------------------------- *)
-(* rekursive properties of while                                             *)
-(* ------------------------------------------------------------------------- *)
-
-lemma while_unfold: "while$b$g$x = If b$x then while$b$g$(g$x) else x"
-apply (rule trans)
-apply (rule while_def2 [THEN fix_eq5])
-apply simp
-done
-
-lemma while_unfold2: "ALL x. while$b$g$x = while$b$g$(iterate k$(step$b$g)$x)"
-apply (induct_tac k)
-apply simp
-apply (rule allI)
-apply (rule trans)
-apply (rule while_unfold)
-apply (subst iterate_Suc2)
-apply (rule trans)
-apply (erule_tac [2] spec)
-apply (subst step_def2)
-apply (rule_tac p = "b$x" in trE)
-apply simp
-apply (subst while_unfold)
-apply (rule_tac s = "UU" and t = "b$UU" in ssubst)
-apply (erule strictI)
-apply simp
-apply simp
-apply simp
-apply (subst while_unfold)
-apply simp
-done
-
-lemma while_unfold3: "while$b$g$x = while$b$g$(step$b$g$x)"
-apply (rule_tac s = "while$b$g$ (iterate (Suc 0) $ (step$b$g) $x) " in trans)
-apply (rule while_unfold2 [THEN spec])
-apply simp
-done
-
-
-(* ------------------------------------------------------------------------- *)
-(* properties of while and iterations                                        *)
-(* ------------------------------------------------------------------------- *)
-
-lemma loop_lemma1: "[| EX y. b$y=FF; iterate k$(step$b$g)$x = UU |]
-     ==>iterate(Suc k)$(step$b$g)$x=UU"
-apply (simp (no_asm))
-apply (rule trans)
-apply (rule step_def2)
-apply simp
-apply (erule exE)
-apply (erule flat_codom [THEN disjE])
-apply simp_all
-done
-
-lemma loop_lemma2: "[|EX y. b$y=FF;iterate (Suc k)$(step$b$g)$x ~=UU |]==>
-      iterate k$(step$b$g)$x ~=UU"
-apply (blast intro: loop_lemma1)
-done
-
-lemma loop_lemma3 [rule_format (no_asm)]:
-  "[| ALL x. INV x & b$x=TT & g$x~=UU --> INV (g$x);
-         EX y. b$y=FF; INV x |]
-      ==> iterate k$(step$b$g)$x ~=UU --> INV (iterate k$(step$b$g)$x)"
-apply (induct_tac "k")
-apply (simp (no_asm_simp))
-apply (intro strip)
-apply (simp (no_asm) add: step_def2)
-apply (rule_tac p = "b$ (iterate n$ (step$b$g) $x) " in trE)
-apply (erule notE)
-apply (simp add: step_def2)
-apply (simp (no_asm_simp))
-apply (rule mp)
-apply (erule spec)
-apply (simp (no_asm_simp) del: iterate_Suc add: loop_lemma2)
-apply (rule_tac s = "iterate (Suc n) $ (step$b$g) $x"
-  and t = "g$ (iterate n$ (step$b$g) $x) " in ssubst)
-prefer 2 apply (assumption)
-apply (simp add: step_def2)
-apply (drule (1) loop_lemma2, simp)
-done
-
-lemma loop_lemma4 [rule_format]:
-  "ALL x. b$(iterate k$(step$b$g)$x)=FF --> while$b$g$x= iterate k$(step$b$g)$x"
-apply (induct_tac k)
-apply (simp (no_asm))
-apply (intro strip)
-apply (simplesubst while_unfold)
-apply simp
-apply (rule allI)
-apply (simplesubst iterate_Suc2)
-apply (intro strip)
-apply (rule trans)
-apply (rule while_unfold3)
-apply simp
-done
-
-lemma loop_lemma5 [rule_format (no_asm)]:
-  "ALL k. b$(iterate k$(step$b$g)$x) ~= FF ==>
-    ALL m. while$b$g$(iterate m$(step$b$g)$x)=UU"
-apply (simplesubst while_def2)
-apply (rule fix_ind)
-apply simp
-apply simp
-apply (rule allI)
-apply (simp (no_asm))
-apply (rule_tac p = "b$ (iterate m$ (step$b$g) $x) " in trE)
-apply (simp (no_asm_simp))
-apply (simp (no_asm_simp))
-apply (rule_tac s = "xa$ (iterate (Suc m) $ (step$b$g) $x) " in trans)
-apply (erule_tac [2] spec)
-apply (rule cfun_arg_cong)
-apply (rule trans)
-apply (rule_tac [2] iterate_Suc [symmetric])
-apply (simp add: step_def2)
-apply blast
-done
-
-lemma loop_lemma6: "ALL k. b$(iterate k$(step$b$g)$x) ~= FF ==> while$b$g$x=UU"
-apply (rule_tac t = "x" in iterate_0 [THEN subst])
-apply (erule loop_lemma5)
-done
-
-lemma loop_lemma7: "while$b$g$x ~= UU ==> EX k. b$(iterate k$(step$b$g)$x) = FF"
-apply (blast intro: loop_lemma6)
-done
-
-
-(* ------------------------------------------------------------------------- *)
-(* an invariant rule for loops                                               *)
-(* ------------------------------------------------------------------------- *)
-
-lemma loop_inv2:
-"[| (ALL y. INV y & b$y=TT & g$y ~= UU --> INV (g$y));
-    (ALL y. INV y & b$y=FF --> Q y);
-    INV x; while$b$g$x~=UU |] ==> Q (while$b$g$x)"
-apply (rule_tac P = "%k. b$ (iterate k$ (step$b$g) $x) =FF" in exE)
-apply (erule loop_lemma7)
-apply (simplesubst loop_lemma4)
-apply assumption
-apply (drule spec, erule mp)
-apply (rule conjI)
-prefer 2 apply (assumption)
-apply (rule loop_lemma3)
-apply assumption
-apply (blast intro: loop_lemma6)
-apply assumption
-apply (rotate_tac -1)
-apply (simp add: loop_lemma4)
-done
-
-lemma loop_inv:
-  assumes premP: "P(x)"
-    and premI: "!!y. P y ==> INV y"
-    and premTT: "!!y. [| INV y; b$y=TT; g$y~=UU|] ==> INV (g$y)"
-    and premFF: "!!y. [| INV y; b$y=FF|] ==> Q y"
-    and premW: "while$b$g$x ~= UU"
-  shows "Q (while$b$g$x)"
-apply (rule loop_inv2)
-apply (rule_tac [3] premP [THEN premI])
-apply (rule_tac [3] premW)
-apply (blast intro: premTT)
-apply (blast intro: premFF)
-done
-
-end
-

--- a/src/HOLCF/ex/Pattern_Match.thy	Sat Nov 27 14:34:54 2010 -0800
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,609 +0,0 @@
-(*  Title:      HOLCF/ex/Pattern_Match.thy
-    Author:     Brian Huffman
-*)
-
-header {* An experimental pattern-matching notation *}
-
-theory Pattern_Match
-imports HOLCF
-begin
-
-default_sort pcpo
-
-text {* FIXME: Find a proper way to un-hide constants. *}
-
-abbreviation fail :: "'a match"
-where "fail \<equiv> Fixrec.fail"
-
-abbreviation succeed :: "'a \<rightarrow> 'a match"
-where "succeed \<equiv> Fixrec.succeed"
-
-abbreviation run :: "'a match \<rightarrow> 'a"
-where "run \<equiv> Fixrec.run"
-
-subsection {* Fatbar combinator *}
-
-definition
-  fatbar :: "('a \<rightarrow> 'b match) \<rightarrow> ('a \<rightarrow> 'b match) \<rightarrow> ('a \<rightarrow> 'b match)" where
-  "fatbar = (\<Lambda> a b x. a\<cdot>x +++ b\<cdot>x)"
-
-abbreviation
-  fatbar_syn :: "['a \<rightarrow> 'b match, 'a \<rightarrow> 'b match] \<Rightarrow> 'a \<rightarrow> 'b match" (infixr "\<parallel>" 60)  where
-  "m1 \<parallel> m2 == fatbar\<cdot>m1\<cdot>m2"
-
-lemma fatbar1: "m\<cdot>x = \<bottom> \<Longrightarrow> (m \<parallel> ms)\<cdot>x = \<bottom>"
-by (simp add: fatbar_def)
-
-lemma fatbar2: "m\<cdot>x = fail \<Longrightarrow> (m \<parallel> ms)\<cdot>x = ms\<cdot>x"
-by (simp add: fatbar_def)
-
-lemma fatbar3: "m\<cdot>x = succeed\<cdot>y \<Longrightarrow> (m \<parallel> ms)\<cdot>x = succeed\<cdot>y"
-by (simp add: fatbar_def)
-
-lemmas fatbar_simps = fatbar1 fatbar2 fatbar3
-
-lemma run_fatbar1: "m\<cdot>x = \<bottom> \<Longrightarrow> run\<cdot>((m \<parallel> ms)\<cdot>x) = \<bottom>"
-by (simp add: fatbar_def)
-
-lemma run_fatbar2: "m\<cdot>x = fail \<Longrightarrow> run\<cdot>((m \<parallel> ms)\<cdot>x) = run\<cdot>(ms\<cdot>x)"
-by (simp add: fatbar_def)
-
-lemma run_fatbar3: "m\<cdot>x = succeed\<cdot>y \<Longrightarrow> run\<cdot>((m \<parallel> ms)\<cdot>x) = y"
-by (simp add: fatbar_def)
-
-lemmas run_fatbar_simps [simp] = run_fatbar1 run_fatbar2 run_fatbar3
-
-subsection {* Bind operator for match monad *}
-
-definition match_bind :: "'a match \<rightarrow> ('a \<rightarrow> 'b match) \<rightarrow> 'b match" where
-  "match_bind = (\<Lambda> m k. sscase\<cdot>(\<Lambda> _. fail)\<cdot>(fup\<cdot>k)\<cdot>(Rep_match m))"
-
-lemma match_bind_simps [simp]:
-  "match_bind\<cdot>\<bottom>\<cdot>k = \<bottom>"
-  "match_bind\<cdot>fail\<cdot>k = fail"
-  "match_bind\<cdot>(succeed\<cdot>x)\<cdot>k = k\<cdot>x"
-unfolding match_bind_def fail_def succeed_def
-by (simp_all add: cont2cont_Rep_match cont_Abs_match
-  Rep_match_strict Abs_match_inverse)
-
-subsection {* Case branch combinator *}
-
-definition
-  branch :: "('a \<rightarrow> 'b match) \<Rightarrow> ('b \<rightarrow> 'c) \<rightarrow> ('a \<rightarrow> 'c match)" where
-  "branch p \<equiv> \<Lambda> r x. match_bind\<cdot>(p\<cdot>x)\<cdot>(\<Lambda> y. succeed\<cdot>(r\<cdot>y))"
-
-lemma branch_simps:
-  "p\<cdot>x = \<bottom> \<Longrightarrow> branch p\<cdot>r\<cdot>x = \<bottom>"
-  "p\<cdot>x = fail \<Longrightarrow> branch p\<cdot>r\<cdot>x = fail"
-  "p\<cdot>x = succeed\<cdot>y \<Longrightarrow> branch p\<cdot>r\<cdot>x = succeed\<cdot>(r\<cdot>y)"
-by (simp_all add: branch_def)
-
-lemma branch_succeed [simp]: "branch succeed\<cdot>r\<cdot>x = succeed\<cdot>(r\<cdot>x)"
-by (simp add: branch_def)
-
-subsection {* Cases operator *}
-
-definition
-  cases :: "'a match \<rightarrow> 'a::pcpo" where
-  "cases = Fixrec.run"
-
-text {* rewrite rules for cases *}
-
-lemma cases_strict [simp]: "cases\<cdot>\<bottom> = \<bottom>"
-by (simp add: cases_def)
-
-lemma cases_fail [simp]: "cases\<cdot>fail = \<bottom>"
-by (simp add: cases_def)
-
-lemma cases_succeed [simp]: "cases\<cdot>(succeed\<cdot>x) = x"
-by (simp add: cases_def)
-
-subsection {* Case syntax *}
-
-nonterminals
-  Case_syn  Cases_syn
-
-syntax
-  "_Case_syntax":: "['a, Cases_syn] => 'b"               ("(Case _ of/ _)" 10)
-  "_Case1"      :: "['a, 'b] => Case_syn"                ("(2_ =>/ _)" 10)
-  ""            :: "Case_syn => Cases_syn"               ("_")
-  "_Case2"      :: "[Case_syn, Cases_syn] => Cases_syn"  ("_/ | _")
-
-syntax (xsymbols)
-  "_Case1"      :: "['a, 'b] => Case_syn"                ("(2_ \<Rightarrow>/ _)" 10)
-
-translations
-  "_Case_syntax x ms" == "CONST cases\<cdot>(ms\<cdot>x)"
-  "_Case2 m ms" == "m \<parallel> ms"
-
-text {* Parsing Case expressions *}
-
-syntax
-  "_pat" :: "'a"
-  "_variable" :: "'a"
-  "_noargs" :: "'a"
-
-translations
-  "_Case1 p r" => "CONST branch (_pat p)\<cdot>(_variable p r)"
-  "_variable (_args x y) r" => "CONST csplit\<cdot>(_variable x (_variable y r))"
-  "_variable _noargs r" => "CONST unit_when\<cdot>r"
-
-parse_translation {*
-(* rewrite (_pat x) => (succeed) *)
-(* rewrite (_variable x t) => (Abs_cfun (%x. t)) *)
- [(@{syntax_const "_pat"}, fn _ => Syntax.const @{const_syntax Fixrec.succeed}),
-  mk_binder_tr (@{syntax_const "_variable"}, @{const_syntax Abs_cfun})];
-*}
-
-text {* Printing Case expressions *}
-
-syntax
-  "_match" :: "'a"
-
-print_translation {*
-  let
-    fun dest_LAM (Const (@{const_syntax Rep_cfun},_) $ Const (@{const_syntax unit_when},_) $ t) =
-          (Syntax.const @{syntax_const "_noargs"}, t)
-    |   dest_LAM (Const (@{const_syntax Rep_cfun},_) $ Const (@{const_syntax csplit},_) $ t) =
-          let
-            val (v1, t1) = dest_LAM t;
-            val (v2, t2) = dest_LAM t1;
-          in (Syntax.const @{syntax_const "_args"} $ v1 $ v2, t2) end
-    |   dest_LAM (Const (@{const_syntax Abs_cfun},_) $ t) =
-          let
-            val abs =
-              case t of Abs abs => abs
-                | _ => ("x", dummyT, incr_boundvars 1 t $ Bound 0);
-            val (x, t') = atomic_abs_tr' abs;
-          in (Syntax.const @{syntax_const "_variable"} $ x, t') end
-    |   dest_LAM _ = raise Match; (* too few vars: abort translation *)
-
-    fun Case1_tr' [Const(@{const_syntax branch},_) $ p, r] =
-          let val (v, t) = dest_LAM r in
-            Syntax.const @{syntax_const "_Case1"} $
-              (Syntax.const @{syntax_const "_match"} $ p $ v) $ t
-          end;
-
-  in [(@{const_syntax Rep_cfun}, Case1_tr')] end;
-*}
-
-translations
-  "x" <= "_match (CONST succeed) (_variable x)"
-
-
-subsection {* Pattern combinators for data constructors *}
-
-types ('a, 'b) pat = "'a \<rightarrow> 'b match"
-
-definition
-  cpair_pat :: "('a, 'c) pat \<Rightarrow> ('b, 'd) pat \<Rightarrow> ('a \<times> 'b, 'c \<times> 'd) pat" where
-  "cpair_pat p1 p2 = (\<Lambda>(x, y).
-    match_bind\<cdot>(p1\<cdot>x)\<cdot>(\<Lambda> a. match_bind\<cdot>(p2\<cdot>y)\<cdot>(\<Lambda> b. succeed\<cdot>(a, b))))"
-
-definition
-  spair_pat ::
-  "('a, 'c) pat \<Rightarrow> ('b, 'd) pat \<Rightarrow> ('a::pcpo \<otimes> 'b::pcpo, 'c \<times> 'd) pat" where
-  "spair_pat p1 p2 = (\<Lambda>(:x, y:). cpair_pat p1 p2\<cdot>(x, y))"
-
-definition
-  sinl_pat :: "('a, 'c) pat \<Rightarrow> ('a::pcpo \<oplus> 'b::pcpo, 'c) pat" where
-  "sinl_pat p = sscase\<cdot>p\<cdot>(\<Lambda> x. fail)"
-
-definition
-  sinr_pat :: "('b, 'c) pat \<Rightarrow> ('a::pcpo \<oplus> 'b::pcpo, 'c) pat" where
-  "sinr_pat p = sscase\<cdot>(\<Lambda> x. fail)\<cdot>p"
-
-definition
-  up_pat :: "('a, 'b) pat \<Rightarrow> ('a u, 'b) pat" where
-  "up_pat p = fup\<cdot>p"
-
-definition
-  TT_pat :: "(tr, unit) pat" where
-  "TT_pat = (\<Lambda> b. If b then succeed\<cdot>() else fail)"
-
-definition
-  FF_pat :: "(tr, unit) pat" where
-  "FF_pat = (\<Lambda> b. If b then fail else succeed\<cdot>())"
-
-definition
-  ONE_pat :: "(one, unit) pat" where
-  "ONE_pat = (\<Lambda> ONE. succeed\<cdot>())"
-
-text {* Parse translations (patterns) *}
-translations
-  "_pat (XCONST Pair x y)" => "CONST cpair_pat (_pat x) (_pat y)"
-  "_pat (XCONST spair\<cdot>x\<cdot>y)" => "CONST spair_pat (_pat x) (_pat y)"
-  "_pat (XCONST sinl\<cdot>x)" => "CONST sinl_pat (_pat x)"
-  "_pat (XCONST sinr\<cdot>x)" => "CONST sinr_pat (_pat x)"
-  "_pat (XCONST up\<cdot>x)" => "CONST up_pat (_pat x)"
-  "_pat (XCONST TT)" => "CONST TT_pat"
-  "_pat (XCONST FF)" => "CONST FF_pat"
-  "_pat (XCONST ONE)" => "CONST ONE_pat"
-
-text {* CONST version is also needed for constructors with special syntax *}
-translations
-  "_pat (CONST Pair x y)" => "CONST cpair_pat (_pat x) (_pat y)"
-  "_pat (CONST spair\<cdot>x\<cdot>y)" => "CONST spair_pat (_pat x) (_pat y)"
-
-text {* Parse translations (variables) *}
-translations
-  "_variable (XCONST Pair x y) r" => "_variable (_args x y) r"
-  "_variable (XCONST spair\<cdot>x\<cdot>y) r" => "_variable (_args x y) r"
-  "_variable (XCONST sinl\<cdot>x) r" => "_variable x r"
-  "_variable (XCONST sinr\<cdot>x) r" => "_variable x r"
-  "_variable (XCONST up\<cdot>x) r" => "_variable x r"
-  "_variable (XCONST TT) r" => "_variable _noargs r"
-  "_variable (XCONST FF) r" => "_variable _noargs r"
-  "_variable (XCONST ONE) r" => "_variable _noargs r"
-
-translations
-  "_variable (CONST Pair x y) r" => "_variable (_args x y) r"
-  "_variable (CONST spair\<cdot>x\<cdot>y) r" => "_variable (_args x y) r"
-
-text {* Print translations *}
-translations
-  "CONST Pair (_match p1 v1) (_match p2 v2)"
-      <= "_match (CONST cpair_pat p1 p2) (_args v1 v2)"
-  "CONST spair\<cdot>(_match p1 v1)\<cdot>(_match p2 v2)"
-      <= "_match (CONST spair_pat p1 p2) (_args v1 v2)"
-  "CONST sinl\<cdot>(_match p1 v1)" <= "_match (CONST sinl_pat p1) v1"
-  "CONST sinr\<cdot>(_match p1 v1)" <= "_match (CONST sinr_pat p1) v1"
-  "CONST up\<cdot>(_match p1 v1)" <= "_match (CONST up_pat p1) v1"
-  "CONST TT" <= "_match (CONST TT_pat) _noargs"
-  "CONST FF" <= "_match (CONST FF_pat) _noargs"
-  "CONST ONE" <= "_match (CONST ONE_pat) _noargs"
-
-lemma cpair_pat1:
-  "branch p\<cdot>r\<cdot>x = \<bottom> \<Longrightarrow> branch (cpair_pat p q)\<cdot>(csplit\<cdot>r)\<cdot>(x, y) = \<bottom>"
-apply (simp add: branch_def cpair_pat_def)
-apply (cases "p\<cdot>x", simp_all)
-done
-
-lemma cpair_pat2:
-  "branch p\<cdot>r\<cdot>x = fail \<Longrightarrow> branch (cpair_pat p q)\<cdot>(csplit\<cdot>r)\<cdot>(x, y) = fail"
-apply (simp add: branch_def cpair_pat_def)
-apply (cases "p\<cdot>x", simp_all)
-done
-
-lemma cpair_pat3:
-  "branch p\<cdot>r\<cdot>x = succeed\<cdot>s \<Longrightarrow>
-   branch (cpair_pat p q)\<cdot>(csplit\<cdot>r)\<cdot>(x, y) = branch q\<cdot>s\<cdot>y"
-apply (simp add: branch_def cpair_pat_def)
-apply (cases "p\<cdot>x", simp_all)
-apply (cases "q\<cdot>y", simp_all)
-done
-
-lemmas cpair_pat [simp] =
-  cpair_pat1 cpair_pat2 cpair_pat3
-
-lemma spair_pat [simp]:
-  "branch (spair_pat p1 p2)\<cdot>r\<cdot>\<bottom> = \<bottom>"
-  "\<lbrakk>x \<noteq> \<bottom>; y \<noteq> \<bottom>\<rbrakk>
-     \<Longrightarrow> branch (spair_pat p1 p2)\<cdot>r\<cdot>(:x, y:) =
-         branch (cpair_pat p1 p2)\<cdot>r\<cdot>(x, y)"
-by (simp_all add: branch_def spair_pat_def)
-
-lemma sinl_pat [simp]:
-  "branch (sinl_pat p)\<cdot>r\<cdot>\<bottom> = \<bottom>"
-  "x \<noteq> \<bottom> \<Longrightarrow> branch (sinl_pat p)\<cdot>r\<cdot>(sinl\<cdot>x) = branch p\<cdot>r\<cdot>x"
-  "y \<noteq> \<bottom> \<Longrightarrow> branch (sinl_pat p)\<cdot>r\<cdot>(sinr\<cdot>y) = fail"
-by (simp_all add: branch_def sinl_pat_def)
-
-lemma sinr_pat [simp]:
-  "branch (sinr_pat p)\<cdot>r\<cdot>\<bottom> = \<bottom>"
-  "x \<noteq> \<bottom> \<Longrightarrow> branch (sinr_pat p)\<cdot>r\<cdot>(sinl\<cdot>x) = fail"
-  "y \<noteq> \<bottom> \<Longrightarrow> branch (sinr_pat p)\<cdot>r\<cdot>(sinr\<cdot>y) = branch p\<cdot>r\<cdot>y"
-by (simp_all add: branch_def sinr_pat_def)
-
-lemma up_pat [simp]:
-  "branch (up_pat p)\<cdot>r\<cdot>\<bottom> = \<bottom>"
-  "branch (up_pat p)\<cdot>r\<cdot>(up\<cdot>x) = branch p\<cdot>r\<cdot>x"
-by (simp_all add: branch_def up_pat_def)
-
-lemma TT_pat [simp]:
-  "branch TT_pat\<cdot>(unit_when\<cdot>r)\<cdot>\<bottom> = \<bottom>"
-  "branch TT_pat\<cdot>(unit_when\<cdot>r)\<cdot>TT = succeed\<cdot>r"
-  "branch TT_pat\<cdot>(unit_when\<cdot>r)\<cdot>FF = fail"
-by (simp_all add: branch_def TT_pat_def)
-
-lemma FF_pat [simp]:
-  "branch FF_pat\<cdot>(unit_when\<cdot>r)\<cdot>\<bottom> = \<bottom>"
-  "branch FF_pat\<cdot>(unit_when\<cdot>r)\<cdot>TT = fail"
-  "branch FF_pat\<cdot>(unit_when\<cdot>r)\<cdot>FF = succeed\<cdot>r"
-by (simp_all add: branch_def FF_pat_def)
-
-lemma ONE_pat [simp]:
-  "branch ONE_pat\<cdot>(unit_when\<cdot>r)\<cdot>\<bottom> = \<bottom>"
-  "branch ONE_pat\<cdot>(unit_when\<cdot>r)\<cdot>ONE = succeed\<cdot>r"
-by (simp_all add: branch_def ONE_pat_def)
-
-
-subsection {* Wildcards, as-patterns, and lazy patterns *}
-
-definition
-  wild_pat :: "'a \<rightarrow> unit match" where
-  "wild_pat = (\<Lambda> x. succeed\<cdot>())"
-
-definition
-  as_pat :: "('a \<rightarrow> 'b match) \<Rightarrow> 'a \<rightarrow> ('a \<times> 'b) match" where
-  "as_pat p = (\<Lambda> x. match_bind\<cdot>(p\<cdot>x)\<cdot>(\<Lambda> a. succeed\<cdot>(x, a)))"
-
-definition
-  lazy_pat :: "('a \<rightarrow> 'b::pcpo match) \<Rightarrow> ('a \<rightarrow> 'b match)" where
-  "lazy_pat p = (\<Lambda> x. succeed\<cdot>(cases\<cdot>(p\<cdot>x)))"
-
-text {* Parse translations (patterns) *}
-translations
-  "_pat _" => "CONST wild_pat"
-
-text {* Parse translations (variables) *}
-translations
-  "_variable _ r" => "_variable _noargs r"
-
-text {* Print translations *}
-translations
-  "_" <= "_match (CONST wild_pat) _noargs"
-
-lemma wild_pat [simp]: "branch wild_pat\<cdot>(unit_when\<cdot>r)\<cdot>x = succeed\<cdot>r"
-by (simp add: branch_def wild_pat_def)
-
-lemma as_pat [simp]:
-  "branch (as_pat p)\<cdot>(csplit\<cdot>r)\<cdot>x = branch p\<cdot>(r\<cdot>x)\<cdot>x"
-apply (simp add: branch_def as_pat_def)
-apply (cases "p\<cdot>x", simp_all)
-done
-
-lemma lazy_pat [simp]:
-  "branch p\<cdot>r\<cdot>x = \<bottom> \<Longrightarrow> branch (lazy_pat p)\<cdot>r\<cdot>x = succeed\<cdot>(r\<cdot>\<bottom>)"
-  "branch p\<cdot>r\<cdot>x = fail \<Longrightarrow> branch (lazy_pat p)\<cdot>r\<cdot>x = succeed\<cdot>(r\<cdot>\<bottom>)"
-  "branch p\<cdot>r\<cdot>x = succeed\<cdot>s \<Longrightarrow> branch (lazy_pat p)\<cdot>r\<cdot>x = succeed\<cdot>s"
-apply (simp_all add: branch_def lazy_pat_def)
-apply (cases "p\<cdot>x", simp_all)+
-done
-
-subsection {* Examples *}
-
-term "Case t of (:up\<cdot>(sinl\<cdot>x), sinr\<cdot>y:) \<Rightarrow> (x, y)"
-
-term "\<Lambda> t. Case t of up\<cdot>(sinl\<cdot>a) \<Rightarrow> a | up\<cdot>(sinr\<cdot>b) \<Rightarrow> b"
-
-term "\<Lambda> t. Case t of (:up\<cdot>(sinl\<cdot>_), sinr\<cdot>x:) \<Rightarrow> x"
-
-subsection {* ML code for generating definitions *}
-
-ML {*
-local open HOLCF_Library in
-
-infixr 6 ->>;
-infix 9 ` ;
-
-val beta_rules =
-  @{thms beta_cfun cont_id cont_const cont2cont_APP cont2cont_LAM'} @
-  @{thms cont2cont_fst cont2cont_snd cont2cont_Pair};
-
-val beta_ss = HOL_basic_ss addsimps (simp_thms @ beta_rules);
-
-fun define_consts
-    (specs : (binding * term * mixfix) list)
-    (thy : theory)
-    : (term list * thm list) * theory =
-  let
-    fun mk_decl (b, t, mx) = (b, fastype_of t, mx);
-    val decls = map mk_decl specs;
-    val thy = Cont_Consts.add_consts decls thy;
-    fun mk_const (b, T, mx) = Const (Sign.full_name thy b, T);
-    val consts = map mk_const decls;
-    fun mk_def c (b, t, mx) =
-      (Binding.suffix_name "_def" b, Logic.mk_equals (c, t));
-    val defs = map2 mk_def consts specs;
-    val (def_thms, thy) =
-      Global_Theory.add_defs false (map Thm.no_attributes defs) thy;
-  in
-    ((consts, def_thms), thy)
-  end;
-
-fun prove
-    (thy : theory)
-    (defs : thm list)
-    (goal : term)
-    (tacs : {prems: thm list, context: Proof.context} -> tactic list)
-    : thm =
-  let
-    fun tac {prems, context} =
-      rewrite_goals_tac defs THEN
-      EVERY (tacs {prems = map (rewrite_rule defs) prems, context = context})
-  in
-    Goal.prove_global thy [] [] goal tac
-  end;
-
-fun get_vars_avoiding
-    (taken : string list)
-    (args : (bool * typ) list)
-    : (term list * term list) =
-  let
-    val Ts = map snd args;
-    val ns = Name.variant_list taken (Datatype_Prop.make_tnames Ts);
-    val vs = map Free (ns ~~ Ts);
-    val nonlazy = map snd (filter_out (fst o fst) (args ~~ vs));
-  in
-    (vs, nonlazy)
-  end;
-
-(******************************************************************************)
-(************** definitions and theorems for pattern combinators **************)
-(******************************************************************************)
-
-fun add_pattern_combinators
-    (bindings : binding list)
-    (spec : (term * (bool * typ) list) list)
-    (lhsT : typ)
-    (exhaust : thm)
-    (case_const : typ -> term)
-    (case_rews : thm list)
-    (thy : theory) =
-  let
-
-    (* utility functions *)
-    fun mk_pair_pat (p1, p2) =
-      let
-        val T1 = fastype_of p1;
-        val T2 = fastype_of p2;
-        val (U1, V1) = apsnd dest_matchT (dest_cfunT T1);
-        val (U2, V2) = apsnd dest_matchT (dest_cfunT T2);
-        val pat_typ = [T1, T2] --->
-            (mk_prodT (U1, U2) ->> mk_matchT (mk_prodT (V1, V2)));
-        val pat_const = Const (@{const_name cpair_pat}, pat_typ);
-      in
-        pat_const $ p1 $ p2
-      end;
-    fun mk_tuple_pat [] = succeed_const HOLogic.unitT
-      | mk_tuple_pat ps = foldr1 mk_pair_pat ps;
-    fun branch_const (T,U,V) = 
-      Const (@{const_name branch},
-        (T ->> mk_matchT U) --> (U ->> V) ->> T ->> mk_matchT V);
-
-    (* define pattern combinators *)
-    local
-      val tns = map (fst o dest_TFree) (snd (dest_Type lhsT));
-
-      fun pat_eqn (i, (bind, (con, args))) : binding * term * mixfix =
-        let
-          val pat_bind = Binding.suffix_name "_pat" bind;
-          val Ts = map snd args;
-          val Vs =
-              (map (K "'t") args)
-              |> Datatype_Prop.indexify_names
-              |> Name.variant_list tns
-              |> map (fn t => TFree (t, @{sort pcpo}));
-          val patNs = Datatype_Prop.indexify_names (map (K "pat") args);
-          val patTs = map2 (fn T => fn V => T ->> mk_matchT V) Ts Vs;
-          val pats = map Free (patNs ~~ patTs);
-          val fail = mk_fail (mk_tupleT Vs);
-          val (vs, nonlazy) = get_vars_avoiding patNs args;
-          val rhs = big_lambdas vs (mk_tuple_pat pats ` mk_tuple vs);
-          fun one_fun (j, (_, args')) =
-            let
-              val (vs', nonlazy) = get_vars_avoiding patNs args';
-            in if i = j then rhs else big_lambdas vs' fail end;
-          val funs = map_index one_fun spec;
-          val body = list_ccomb (case_const (mk_matchT (mk_tupleT Vs)), funs);
-        in
-          (pat_bind, lambdas pats body, NoSyn)
-        end;
-    in
-      val ((pat_consts, pat_defs), thy) =
-          define_consts (map_index pat_eqn (bindings ~~ spec)) thy
-    end;
-
-    (* syntax translations for pattern combinators *)
-    local
-      open Syntax
-      fun syntax c = Syntax.mark_const (fst (dest_Const c));
-      fun app s (l, r) = Syntax.mk_appl (Constant s) [l, r];
-      val capp = app @{const_syntax Rep_cfun};
-      val capps = Library.foldl capp
-
-      fun app_var x = Syntax.mk_appl (Constant "_variable") [x, Variable "rhs"];
-      fun app_pat x = Syntax.mk_appl (Constant "_pat") [x];
-      fun args_list [] = Constant "_noargs"
-        | args_list xs = foldr1 (app "_args") xs;
-      fun one_case_trans (pat, (con, args)) =
-        let
-          val cname = Constant (syntax con);
-          val pname = Constant (syntax pat);
-          val ns = 1 upto length args;
-          val xs = map (fn n => Variable ("x"^(string_of_int n))) ns;
-          val ps = map (fn n => Variable ("p"^(string_of_int n))) ns;
-          val vs = map (fn n => Variable ("v"^(string_of_int n))) ns;
-        in
-          [ParseRule (app_pat (capps (cname, xs)),
-                      mk_appl pname (map app_pat xs)),
-           ParseRule (app_var (capps (cname, xs)),
-                      app_var (args_list xs)),
-           PrintRule (capps (cname, ListPair.map (app "_match") (ps,vs)),
-                      app "_match" (mk_appl pname ps, args_list vs))]
-        end;
-      val trans_rules : Syntax.ast Syntax.trrule list =
-          maps one_case_trans (pat_consts ~~ spec);
-    in
-      val thy = Sign.add_trrules_i trans_rules thy;
-    end;
-
-    (* prove strictness and reduction rules of pattern combinators *)
-    local
-      val tns = map (fst o dest_TFree) (snd (dest_Type lhsT));
-      val rn = Name.variant tns "'r";
-      val R = TFree (rn, @{sort pcpo});
-      fun pat_lhs (pat, args) =
-        let
-          val Ts = map snd args;
-          val Vs =
-              (map (K "'t") args)
-              |> Datatype_Prop.indexify_names
-              |> Name.variant_list (rn::tns)
-              |> map (fn t => TFree (t, @{sort pcpo}));
-          val patNs = Datatype_Prop.indexify_names (map (K "pat") args);
-          val patTs = map2 (fn T => fn V => T ->> mk_matchT V) Ts Vs;
-          val pats = map Free (patNs ~~ patTs);
-          val k = Free ("rhs", mk_tupleT Vs ->> R);
-          val branch1 = branch_const (lhsT, mk_tupleT Vs, R);
-          val fun1 = (branch1 $ list_comb (pat, pats)) ` k;
-          val branch2 = branch_const (mk_tupleT Ts, mk_tupleT Vs, R);
-          val fun2 = (branch2 $ mk_tuple_pat pats) ` k;
-          val taken = "rhs" :: patNs;
-        in (fun1, fun2, taken) end;
-      fun pat_strict (pat, (con, args)) =
-        let
-          val (fun1, fun2, taken) = pat_lhs (pat, args);
-          val defs = @{thm branch_def} :: pat_defs;
-          val goal = mk_trp (mk_strict fun1);
-          val rules = @{thms match_bind_simps} @ case_rews;
-          val tacs = [simp_tac (beta_ss addsimps rules) 1];
-        in prove thy defs goal (K tacs) end;
-      fun pat_apps (i, (pat, (con, args))) =
-        let
-          val (fun1, fun2, taken) = pat_lhs (pat, args);
-          fun pat_app (j, (con', args')) =
-            let
-              val (vs, nonlazy) = get_vars_avoiding taken args';
-              val con_app = list_ccomb (con', vs);
-              val assms = map (mk_trp o mk_defined) nonlazy;
-              val rhs = if i = j then fun2 ` mk_tuple vs else mk_fail R;
-              val concl = mk_trp (mk_eq (fun1 ` con_app, rhs));
-              val goal = Logic.list_implies (assms, concl);
-              val defs = @{thm branch_def} :: pat_defs;
-              val rules = @{thms match_bind_simps} @ case_rews;
-              val tacs = [asm_simp_tac (beta_ss addsimps rules) 1];
-            in prove thy defs goal (K tacs) end;
-        in map_index pat_app spec end;
-    in
-      val pat_stricts = map pat_strict (pat_consts ~~ spec);
-      val pat_apps = flat (map_index pat_apps (pat_consts ~~ spec));
-    end;
-
-  in
-    (pat_stricts @ pat_apps, thy)
-  end
-
-end
-*}
-
-(*
-Cut from HOLCF/Tools/domain_constructors.ML
-in function add_domain_constructors:
-
-    ( * define and prove theorems for pattern combinators * )
-    val (pat_thms : thm list, thy : theory) =
-      let
-        val bindings = map #1 spec;
-        fun prep_arg (lazy, sel, T) = (lazy, T);
-        fun prep_con c (b, args, mx) = (c, map prep_arg args);
-        val pat_spec = map2 prep_con con_consts spec;
-      in
-        add_pattern_combinators bindings pat_spec lhsT
-          exhaust case_const cases thy
-      end
-
-*)
-
-end

--- a/src/HOLCF/ex/Powerdomain_ex.thy	Sat Nov 27 14:34:54 2010 -0800
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,113 +0,0 @@
-(*  Title:      HOLCF/ex/Powerdomain_ex.thy
-    Author:     Brian Huffman
-*)
-
-header {* Powerdomain examples *}
-
-theory Powerdomain_ex
-imports HOLCF
-begin
-
-subsection {* Monadic sorting example *}
-
-domain ordering = LT | EQ | GT
-
-definition
-  compare :: "int lift \<rightarrow> int lift \<rightarrow> ordering" where
-  "compare = (FLIFT x y. if x < y then LT else if x = y then EQ else GT)"
-
-definition
-  is_le :: "int lift \<rightarrow> int lift \<rightarrow> tr" where
-  "is_le = (\<Lambda> x y. case compare\<cdot>x\<cdot>y of LT \<Rightarrow> TT | EQ \<Rightarrow> TT | GT \<Rightarrow> FF)"
-
-definition
-  is_less :: "int lift \<rightarrow> int lift \<rightarrow> tr" where
-  "is_less = (\<Lambda> x y. case compare\<cdot>x\<cdot>y of LT \<Rightarrow> TT | EQ \<Rightarrow> FF | GT \<Rightarrow> FF)"
-
-definition
-  r1 :: "(int lift \<times> 'a) \<rightarrow> (int lift \<times> 'a) \<rightarrow> tr convex_pd" where
-  "r1 = (\<Lambda> (x,_) (y,_). case compare\<cdot>x\<cdot>y of
-          LT \<Rightarrow> {TT}\<natural> |
-          EQ \<Rightarrow> {TT, FF}\<natural> |
-          GT \<Rightarrow> {FF}\<natural>)"
-
-definition
-  r2 :: "(int lift \<times> 'a) \<rightarrow> (int lift \<times> 'a) \<rightarrow> tr convex_pd" where
-  "r2 = (\<Lambda> (x,_) (y,_). {is_le\<cdot>x\<cdot>y, is_less\<cdot>x\<cdot>y}\<natural>)"
-
-lemma r1_r2: "r1\<cdot>(x,a)\<cdot>(y,b) = (r2\<cdot>(x,a)\<cdot>(y,b) :: tr convex_pd)"
-apply (simp add: r1_def r2_def)
-apply (simp add: is_le_def is_less_def)
-apply (cases "compare\<cdot>x\<cdot>y")
-apply simp_all
-done
-
-
-subsection {* Picking a leaf from a tree *}
-
-domain 'a tree =
-  Node (lazy "'a tree") (lazy "'a tree") |
-  Leaf (lazy "'a")
-
-fixrec
-  mirror :: "'a tree \<rightarrow> 'a tree"
-where
-  mirror_Leaf: "mirror\<cdot>(Leaf\<cdot>a) = Leaf\<cdot>a"
-| mirror_Node: "mirror\<cdot>(Node\<cdot>l\<cdot>r) = Node\<cdot>(mirror\<cdot>r)\<cdot>(mirror\<cdot>l)"
-
-lemma mirror_strict [simp]: "mirror\<cdot>\<bottom> = \<bottom>"
-by fixrec_simp
-
-fixrec
-  pick :: "'a tree \<rightarrow> 'a convex_pd"
-where
-  pick_Leaf: "pick\<cdot>(Leaf\<cdot>a) = {a}\<natural>"
-| pick_Node: "pick\<cdot>(Node\<cdot>l\<cdot>r) = pick\<cdot>l +\<natural> pick\<cdot>r"
-
-lemma pick_strict [simp]: "pick\<cdot>\<bottom> = \<bottom>"
-by fixrec_simp
-
-lemma pick_mirror: "pick\<cdot>(mirror\<cdot>t) = pick\<cdot>t"
-by (induct t) (simp_all add: convex_plus_ac)
-
-fixrec tree1 :: "int lift tree"
-where "tree1 = Node\<cdot>(Node\<cdot>(Leaf\<cdot>(Def 1))\<cdot>(Leaf\<cdot>(Def 2)))
-                   \<cdot>(Node\<cdot>(Leaf\<cdot>(Def 3))\<cdot>(Leaf\<cdot>(Def 4)))"
-
-fixrec tree2 :: "int lift tree"
-where "tree2 = Node\<cdot>(Node\<cdot>(Leaf\<cdot>(Def 1))\<cdot>(Leaf\<cdot>(Def 2)))
-                   \<cdot>(Node\<cdot>\<bottom>\<cdot>(Leaf\<cdot>(Def 4)))"
-
-fixrec tree3 :: "int lift tree"
-where "tree3 = Node\<cdot>(Node\<cdot>(Leaf\<cdot>(Def 1))\<cdot>tree3)
-                   \<cdot>(Node\<cdot>(Leaf\<cdot>(Def 3))\<cdot>(Leaf\<cdot>(Def 4)))"
-
-declare tree1.simps tree2.simps tree3.simps [simp del]
-
-lemma pick_tree1:
-  "pick\<cdot>tree1 = {Def 1, Def 2, Def 3, Def 4}\<natural>"
-apply (subst tree1.simps)
-apply simp
-apply (simp add: convex_plus_ac)
-done
-
-lemma pick_tree2:
-  "pick\<cdot>tree2 = {Def 1, Def 2, \<bottom>, Def 4}\<natural>"
-apply (subst tree2.simps)
-apply simp
-apply (simp add: convex_plus_ac)
-done
-
-lemma pick_tree3:
-  "pick\<cdot>tree3 = {Def 1, \<bottom>, Def 3, Def 4}\<natural>"
-apply (subst tree3.simps)
-apply simp
-apply (induct rule: tree3.induct)
-apply simp
-apply simp
-apply (simp add: convex_plus_ac)
-apply simp
-apply (simp add: convex_plus_ac)
-done
-
-end

--- a/src/HOLCF/ex/ROOT.ML	Sat Nov 27 14:34:54 2010 -0800
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,9 +0,0 @@
-(*  Title:      HOLCF/ex/ROOT.ML
-
-Misc HOLCF examples.
-*)
-
-use_thys ["Dnat", "Dagstuhl", "Focus_ex", "Fix2", "Hoare",
-  "Loop", "Powerdomain_ex", "Domain_Proofs",
-  "Letrec",
-  "Pattern_Match"];

--- a/src/HOLCF/ex/hoare.txt	Sat Nov 27 14:34:54 2010 -0800
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,97 +0,0 @@
-Proves about loops and tail-recursive functions
-===============================================
-
-Problem A
-
-P = while B1       do S od
-Q = while B1 or B2 do S od
-
-Prove P;Q = Q    (provided B1, B2 have no side effects)
-
-------
-
-Looking at the denotational semantics of while, we get
-
-Problem B
-
-[|B1|]:State->Bool
-[|B2|]:State->Bool
-[|S |]:State->State
-f     :State->State
-
-p = fix LAM f.LAM x. if [| B1 |] x                  then f([| S |] x) else x fi
-q = fix LAM f.LAM x. if [| B1 |] x orelse [|b2 |] x then f([| S |] x) else x fi
-
-Prove q o p = q          rsp.       ALL x.q(p(x))=q(x)
-
-Remark: 1. Bool is the three-valued domain {UU,FF,TT} since tests B1 and B2 may
-           not terminate.
-        2. orelse is the sequential or like in ML
-
-----------
-
-If we abstract over the structure of stores we get
-
-Problem C
-
-b1:'a -> Bool
-b2:'a -> Bool
-g :'a ->'a
-h :'a ->'a
-
-p = fix LAM h.LAM x. if b1(x)              then h(g(x)) else x fi
-q = fix LAM h.LAM x. if b1(x) orelse b2(x) then h(g(x)) else x fi
-
-where g is an abstraction of [| S |]
-
-Prove q o p = q 
-
-Remark: there are no restrictions wrt. definedness or strictness for any of 
-        the involved functions.
-
-----------
-
-In a functional programming language the problem reads as follows:
-
-p(x) = if b1(x) 
-         then p(g(x))
-         else x fi
-
-q(x) = if b1(x) orelse b2(x) 
-         then q(g(x))
-         else x fi
-
-
-Prove:  q o p = q
-
-
--------------
-
-In you like to test the problem in ML (bad guy) you have to introduce 
-formal parameters for b1,b2 and g.
-
-fun p b1 g x = if b1(x) 
-         then p b1 g (g(x))
-         else x;
-
-
-fun q b1 b2 g x = if b1(x) orelse b2(x) 
-         then q b1 b2 g (g(x))
-         else x;
-
-Prove: for all b1 b2 g . 
-            (q b1 b2 g) o (p b1 g) = (q b1 b2 g)
-
-===========
-
-It took 4 person-days to formulate and prove the problem C in the
-Isabelle logic HOLCF. The formalisation was done by conservative extension and
-all proof principles where derived from pure HOLCF.
-
-
-    
-
-
-
-
-