moved directory src/HOLCF to src/HOL/HOLCF;
authorhuffman
Sat Nov 27 16:08:10 2010 -0800 (2010-11-27)
changeset 407740437dbc127b3
parent 40773 6c12f5e24e34
child 40775 ed7a4eadb2f6
moved directory src/HOLCF to src/HOL/HOLCF;
added HOLCF theories to src/HOL/IsaMakefile;
src/HOL/HOLCF/Adm.thy
src/HOL/HOLCF/Algebraic.thy
src/HOL/HOLCF/Bifinite.thy
src/HOL/HOLCF/Cfun.thy
src/HOL/HOLCF/CompactBasis.thy
src/HOL/HOLCF/Completion.thy
src/HOL/HOLCF/Cont.thy
src/HOL/HOLCF/ConvexPD.thy
src/HOL/HOLCF/Cpodef.thy
src/HOL/HOLCF/Cprod.thy
src/HOL/HOLCF/Deflation.thy
src/HOL/HOLCF/Discrete.thy
src/HOL/HOLCF/Domain.thy
src/HOL/HOLCF/Domain_Aux.thy
src/HOL/HOLCF/FOCUS/Buffer.thy
src/HOL/HOLCF/FOCUS/Buffer_adm.thy
src/HOL/HOLCF/FOCUS/FOCUS.thy
src/HOL/HOLCF/FOCUS/Fstream.thy
src/HOL/HOLCF/FOCUS/Fstreams.thy
src/HOL/HOLCF/FOCUS/README.html
src/HOL/HOLCF/FOCUS/ROOT.ML
src/HOL/HOLCF/FOCUS/Stream_adm.thy
src/HOL/HOLCF/Fix.thy
src/HOL/HOLCF/Fixrec.thy
src/HOL/HOLCF/Fun_Cpo.thy
src/HOL/HOLCF/HOLCF.thy
src/HOL/HOLCF/IMP/Denotational.thy
src/HOL/HOLCF/IMP/HoareEx.thy
src/HOL/HOLCF/IMP/README.html
src/HOL/HOLCF/IMP/ROOT.ML
src/HOL/HOLCF/IMP/document/root.bib
src/HOL/HOLCF/IMP/document/root.tex
src/HOL/HOLCF/IOA/ABP/Abschannel.thy
src/HOL/HOLCF/IOA/ABP/Abschannel_finite.thy
src/HOL/HOLCF/IOA/ABP/Action.thy
src/HOL/HOLCF/IOA/ABP/Check.ML
src/HOL/HOLCF/IOA/ABP/Correctness.thy
src/HOL/HOLCF/IOA/ABP/Env.thy
src/HOL/HOLCF/IOA/ABP/Impl.thy
src/HOL/HOLCF/IOA/ABP/Impl_finite.thy
src/HOL/HOLCF/IOA/ABP/Lemmas.thy
src/HOL/HOLCF/IOA/ABP/Packet.thy
src/HOL/HOLCF/IOA/ABP/ROOT.ML
src/HOL/HOLCF/IOA/ABP/Read_me
src/HOL/HOLCF/IOA/ABP/Receiver.thy
src/HOL/HOLCF/IOA/ABP/Sender.thy
src/HOL/HOLCF/IOA/ABP/Spec.thy
src/HOL/HOLCF/IOA/NTP/Abschannel.thy
src/HOL/HOLCF/IOA/NTP/Action.thy
src/HOL/HOLCF/IOA/NTP/Correctness.thy
src/HOL/HOLCF/IOA/NTP/Impl.thy
src/HOL/HOLCF/IOA/NTP/Lemmas.thy
src/HOL/HOLCF/IOA/NTP/Multiset.thy
src/HOL/HOLCF/IOA/NTP/Packet.thy
src/HOL/HOLCF/IOA/NTP/ROOT.ML
src/HOL/HOLCF/IOA/NTP/Read_me
src/HOL/HOLCF/IOA/NTP/Receiver.thy
src/HOL/HOLCF/IOA/NTP/Sender.thy
src/HOL/HOLCF/IOA/NTP/Spec.thy
src/HOL/HOLCF/IOA/README.html
src/HOL/HOLCF/IOA/ROOT.ML
src/HOL/HOLCF/IOA/Storage/Action.thy
src/HOL/HOLCF/IOA/Storage/Correctness.thy
src/HOL/HOLCF/IOA/Storage/Impl.thy
src/HOL/HOLCF/IOA/Storage/ROOT.ML
src/HOL/HOLCF/IOA/Storage/Spec.thy
src/HOL/HOLCF/IOA/ex/ROOT.ML
src/HOL/HOLCF/IOA/ex/TrivEx.thy
src/HOL/HOLCF/IOA/ex/TrivEx2.thy
src/HOL/HOLCF/IOA/meta_theory/Abstraction.thy
src/HOL/HOLCF/IOA/meta_theory/Asig.thy
src/HOL/HOLCF/IOA/meta_theory/Automata.thy
src/HOL/HOLCF/IOA/meta_theory/CompoExecs.thy
src/HOL/HOLCF/IOA/meta_theory/CompoScheds.thy
src/HOL/HOLCF/IOA/meta_theory/CompoTraces.thy
src/HOL/HOLCF/IOA/meta_theory/Compositionality.thy
src/HOL/HOLCF/IOA/meta_theory/Deadlock.thy
src/HOL/HOLCF/IOA/meta_theory/IOA.thy
src/HOL/HOLCF/IOA/meta_theory/LiveIOA.thy
src/HOL/HOLCF/IOA/meta_theory/Pred.thy
src/HOL/HOLCF/IOA/meta_theory/RefCorrectness.thy
src/HOL/HOLCF/IOA/meta_theory/RefMappings.thy
src/HOL/HOLCF/IOA/meta_theory/Seq.thy
src/HOL/HOLCF/IOA/meta_theory/Sequence.thy
src/HOL/HOLCF/IOA/meta_theory/ShortExecutions.thy
src/HOL/HOLCF/IOA/meta_theory/SimCorrectness.thy
src/HOL/HOLCF/IOA/meta_theory/Simulations.thy
src/HOL/HOLCF/IOA/meta_theory/TL.thy
src/HOL/HOLCF/IOA/meta_theory/TLS.thy
src/HOL/HOLCF/IOA/meta_theory/Traces.thy
src/HOL/HOLCF/IsaMakefile
src/HOL/HOLCF/Library/Defl_Bifinite.thy
src/HOL/HOLCF/Library/HOLCF_Library.thy
src/HOL/HOLCF/Library/List_Cpo.thy
src/HOL/HOLCF/Library/ROOT.ML
src/HOL/HOLCF/Library/Stream.thy
src/HOL/HOLCF/Library/Sum_Cpo.thy
src/HOL/HOLCF/Lift.thy
src/HOL/HOLCF/LowerPD.thy
src/HOL/HOLCF/Map_Functions.thy
src/HOL/HOLCF/One.thy
src/HOL/HOLCF/Pcpo.thy
src/HOL/HOLCF/Plain_HOLCF.thy
src/HOL/HOLCF/Porder.thy
src/HOL/HOLCF/Powerdomains.thy
src/HOL/HOLCF/Product_Cpo.thy
src/HOL/HOLCF/README.html
src/HOL/HOLCF/ROOT.ML
src/HOL/HOLCF/Sfun.thy
src/HOL/HOLCF/Sprod.thy
src/HOL/HOLCF/Ssum.thy
src/HOL/HOLCF/Tools/Domain/domain.ML
src/HOL/HOLCF/Tools/Domain/domain_axioms.ML
src/HOL/HOLCF/Tools/Domain/domain_constructors.ML
src/HOL/HOLCF/Tools/Domain/domain_induction.ML
src/HOL/HOLCF/Tools/Domain/domain_isomorphism.ML
src/HOL/HOLCF/Tools/Domain/domain_take_proofs.ML
src/HOL/HOLCF/Tools/cont_consts.ML
src/HOL/HOLCF/Tools/cont_proc.ML
src/HOL/HOLCF/Tools/cpodef.ML
src/HOL/HOLCF/Tools/domaindef.ML
src/HOL/HOLCF/Tools/fixrec.ML
src/HOL/HOLCF/Tools/holcf_library.ML
src/HOL/HOLCF/Tr.thy
src/HOL/HOLCF/Tutorial/Domain_ex.thy
src/HOL/HOLCF/Tutorial/Fixrec_ex.thy
src/HOL/HOLCF/Tutorial/New_Domain.thy
src/HOL/HOLCF/Tutorial/ROOT.ML
src/HOL/HOLCF/Tutorial/document/root.tex
src/HOL/HOLCF/Universal.thy
src/HOL/HOLCF/Up.thy
src/HOL/HOLCF/UpperPD.thy
src/HOL/HOLCF/document/root.tex
src/HOL/HOLCF/ex/Dagstuhl.thy
src/HOL/HOLCF/ex/Dnat.thy
src/HOL/HOLCF/ex/Domain_Proofs.thy
src/HOL/HOLCF/ex/Fix2.thy
src/HOL/HOLCF/ex/Focus_ex.thy
src/HOL/HOLCF/ex/Hoare.thy
src/HOL/HOLCF/ex/Letrec.thy
src/HOL/HOLCF/ex/Loop.thy
src/HOL/HOLCF/ex/Pattern_Match.thy
src/HOL/HOLCF/ex/Powerdomain_ex.thy
src/HOL/HOLCF/ex/ROOT.ML
src/HOL/HOLCF/ex/hoare.txt
src/HOL/IsaMakefile
src/HOLCF/Adm.thy
src/HOLCF/Algebraic.thy
src/HOLCF/Bifinite.thy
src/HOLCF/Cfun.thy
src/HOLCF/CompactBasis.thy
src/HOLCF/Completion.thy
src/HOLCF/Cont.thy
src/HOLCF/ConvexPD.thy
src/HOLCF/Cpodef.thy
src/HOLCF/Cprod.thy
src/HOLCF/Deflation.thy
src/HOLCF/Discrete.thy
src/HOLCF/Domain.thy
src/HOLCF/Domain_Aux.thy
src/HOLCF/FOCUS/Buffer.thy
src/HOLCF/FOCUS/Buffer_adm.thy
src/HOLCF/FOCUS/FOCUS.thy
src/HOLCF/FOCUS/Fstream.thy
src/HOLCF/FOCUS/Fstreams.thy
src/HOLCF/FOCUS/README.html
src/HOLCF/FOCUS/ROOT.ML
src/HOLCF/FOCUS/Stream_adm.thy
src/HOLCF/Fix.thy
src/HOLCF/Fixrec.thy
src/HOLCF/Fun_Cpo.thy
src/HOLCF/HOLCF.thy
src/HOLCF/IMP/Denotational.thy
src/HOLCF/IMP/HoareEx.thy
src/HOLCF/IMP/README.html
src/HOLCF/IMP/ROOT.ML
src/HOLCF/IMP/document/root.bib
src/HOLCF/IMP/document/root.tex
src/HOLCF/IOA/ABP/Abschannel.thy
src/HOLCF/IOA/ABP/Abschannel_finite.thy
src/HOLCF/IOA/ABP/Action.thy
src/HOLCF/IOA/ABP/Check.ML
src/HOLCF/IOA/ABP/Correctness.thy
src/HOLCF/IOA/ABP/Env.thy
src/HOLCF/IOA/ABP/Impl.thy
src/HOLCF/IOA/ABP/Impl_finite.thy
src/HOLCF/IOA/ABP/Lemmas.thy
src/HOLCF/IOA/ABP/Packet.thy
src/HOLCF/IOA/ABP/ROOT.ML
src/HOLCF/IOA/ABP/Read_me
src/HOLCF/IOA/ABP/Receiver.thy
src/HOLCF/IOA/ABP/Sender.thy
src/HOLCF/IOA/ABP/Spec.thy
src/HOLCF/IOA/NTP/Abschannel.thy
src/HOLCF/IOA/NTP/Action.thy
src/HOLCF/IOA/NTP/Correctness.thy
src/HOLCF/IOA/NTP/Impl.thy
src/HOLCF/IOA/NTP/Lemmas.thy
src/HOLCF/IOA/NTP/Multiset.thy
src/HOLCF/IOA/NTP/Packet.thy
src/HOLCF/IOA/NTP/ROOT.ML
src/HOLCF/IOA/NTP/Read_me
src/HOLCF/IOA/NTP/Receiver.thy
src/HOLCF/IOA/NTP/Sender.thy
src/HOLCF/IOA/NTP/Spec.thy
src/HOLCF/IOA/README.html
src/HOLCF/IOA/ROOT.ML
src/HOLCF/IOA/Storage/Action.thy
src/HOLCF/IOA/Storage/Correctness.thy
src/HOLCF/IOA/Storage/Impl.thy
src/HOLCF/IOA/Storage/ROOT.ML
src/HOLCF/IOA/Storage/Spec.thy
src/HOLCF/IOA/ex/ROOT.ML
src/HOLCF/IOA/ex/TrivEx.thy
src/HOLCF/IOA/ex/TrivEx2.thy
src/HOLCF/IOA/meta_theory/Abstraction.thy
src/HOLCF/IOA/meta_theory/Asig.thy
src/HOLCF/IOA/meta_theory/Automata.thy
src/HOLCF/IOA/meta_theory/CompoExecs.thy
src/HOLCF/IOA/meta_theory/CompoScheds.thy
src/HOLCF/IOA/meta_theory/CompoTraces.thy
src/HOLCF/IOA/meta_theory/Compositionality.thy
src/HOLCF/IOA/meta_theory/Deadlock.thy
src/HOLCF/IOA/meta_theory/IOA.thy
src/HOLCF/IOA/meta_theory/LiveIOA.thy
src/HOLCF/IOA/meta_theory/Pred.thy
src/HOLCF/IOA/meta_theory/RefCorrectness.thy
src/HOLCF/IOA/meta_theory/RefMappings.thy
src/HOLCF/IOA/meta_theory/Seq.thy
src/HOLCF/IOA/meta_theory/Sequence.thy
src/HOLCF/IOA/meta_theory/ShortExecutions.thy
src/HOLCF/IOA/meta_theory/SimCorrectness.thy
src/HOLCF/IOA/meta_theory/Simulations.thy
src/HOLCF/IOA/meta_theory/TL.thy
src/HOLCF/IOA/meta_theory/TLS.thy
src/HOLCF/IOA/meta_theory/Traces.thy
src/HOLCF/IsaMakefile
src/HOLCF/Library/Defl_Bifinite.thy
src/HOLCF/Library/HOLCF_Library.thy
src/HOLCF/Library/List_Cpo.thy
src/HOLCF/Library/ROOT.ML
src/HOLCF/Library/Stream.thy
src/HOLCF/Library/Sum_Cpo.thy
src/HOLCF/Lift.thy
src/HOLCF/LowerPD.thy
src/HOLCF/Map_Functions.thy
src/HOLCF/One.thy
src/HOLCF/Pcpo.thy
src/HOLCF/Plain_HOLCF.thy
src/HOLCF/Porder.thy
src/HOLCF/Powerdomains.thy
src/HOLCF/Product_Cpo.thy
src/HOLCF/README.html
src/HOLCF/ROOT.ML
src/HOLCF/Sfun.thy
src/HOLCF/Sprod.thy
src/HOLCF/Ssum.thy
src/HOLCF/Tools/Domain/domain.ML
src/HOLCF/Tools/Domain/domain_axioms.ML
src/HOLCF/Tools/Domain/domain_constructors.ML
src/HOLCF/Tools/Domain/domain_induction.ML
src/HOLCF/Tools/Domain/domain_isomorphism.ML
src/HOLCF/Tools/Domain/domain_take_proofs.ML
src/HOLCF/Tools/cont_consts.ML
src/HOLCF/Tools/cont_proc.ML
src/HOLCF/Tools/cpodef.ML
src/HOLCF/Tools/domaindef.ML
src/HOLCF/Tools/fixrec.ML
src/HOLCF/Tools/holcf_library.ML
src/HOLCF/Tr.thy
src/HOLCF/Tutorial/Domain_ex.thy
src/HOLCF/Tutorial/Fixrec_ex.thy
src/HOLCF/Tutorial/New_Domain.thy
src/HOLCF/Tutorial/ROOT.ML
src/HOLCF/Tutorial/document/root.tex
src/HOLCF/Universal.thy
src/HOLCF/Up.thy
src/HOLCF/UpperPD.thy
src/HOLCF/document/root.tex
src/HOLCF/ex/Dagstuhl.thy
src/HOLCF/ex/Dnat.thy
src/HOLCF/ex/Domain_Proofs.thy
src/HOLCF/ex/Fix2.thy
src/HOLCF/ex/Focus_ex.thy
src/HOLCF/ex/Hoare.thy
src/HOLCF/ex/Letrec.thy
src/HOLCF/ex/Loop.thy
src/HOLCF/ex/Pattern_Match.thy
src/HOLCF/ex/Powerdomain_ex.thy
src/HOLCF/ex/ROOT.ML
src/HOLCF/ex/hoare.txt
     1.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     1.2 +++ b/src/HOL/HOLCF/Adm.thy	Sat Nov 27 16:08:10 2010 -0800
     1.3 @@ -0,0 +1,193 @@
     1.4 +(*  Title:      HOLCF/Adm.thy
     1.5 +    Author:     Franz Regensburger and Brian Huffman
     1.6 +*)
     1.7 +
     1.8 +header {* Admissibility and compactness *}
     1.9 +
    1.10 +theory Adm
    1.11 +imports Cont
    1.12 +begin
    1.13 +
    1.14 +default_sort cpo
    1.15 +
    1.16 +subsection {* Definitions *}
    1.17 +
    1.18 +definition
    1.19 +  adm :: "('a::cpo \<Rightarrow> bool) \<Rightarrow> bool" where
    1.20 +  "adm P = (\<forall>Y. chain Y \<longrightarrow> (\<forall>i. P (Y i)) \<longrightarrow> P (\<Squnion>i. Y i))"
    1.21 +
    1.22 +lemma admI:
    1.23 +   "(\<And>Y. \<lbrakk>chain Y; \<forall>i. P (Y i)\<rbrakk> \<Longrightarrow> P (\<Squnion>i. Y i)) \<Longrightarrow> adm P"
    1.24 +unfolding adm_def by fast
    1.25 +
    1.26 +lemma admD: "\<lbrakk>adm P; chain Y; \<And>i. P (Y i)\<rbrakk> \<Longrightarrow> P (\<Squnion>i. Y i)"
    1.27 +unfolding adm_def by fast
    1.28 +
    1.29 +lemma admD2: "\<lbrakk>adm (\<lambda>x. \<not> P x); chain Y; P (\<Squnion>i. Y i)\<rbrakk> \<Longrightarrow> \<exists>i. P (Y i)"
    1.30 +unfolding adm_def by fast
    1.31 +
    1.32 +lemma triv_admI: "\<forall>x. P x \<Longrightarrow> adm P"
    1.33 +by (rule admI, erule spec)
    1.34 +
    1.35 +subsection {* Admissibility on chain-finite types *}
    1.36 +
    1.37 +text {* For chain-finite (easy) types every formula is admissible. *}
    1.38 +
    1.39 +lemma adm_chfin [simp]: "adm (P::'a::chfin \<Rightarrow> bool)"
    1.40 +by (rule admI, frule chfin, auto simp add: maxinch_is_thelub)
    1.41 +
    1.42 +subsection {* Admissibility of special formulae and propagation *}
    1.43 +
    1.44 +lemma adm_const [simp]: "adm (\<lambda>x. t)"
    1.45 +by (rule admI, simp)
    1.46 +
    1.47 +lemma adm_conj [simp]:
    1.48 +  "\<lbrakk>adm (\<lambda>x. P x); adm (\<lambda>x. Q x)\<rbrakk> \<Longrightarrow> adm (\<lambda>x. P x \<and> Q x)"
    1.49 +by (fast intro: admI elim: admD)
    1.50 +
    1.51 +lemma adm_all [simp]:
    1.52 +  "(\<And>y. adm (\<lambda>x. P x y)) \<Longrightarrow> adm (\<lambda>x. \<forall>y. P x y)"
    1.53 +by (fast intro: admI elim: admD)
    1.54 +
    1.55 +lemma adm_ball [simp]:
    1.56 +  "(\<And>y. y \<in> A \<Longrightarrow> adm (\<lambda>x. P x y)) \<Longrightarrow> adm (\<lambda>x. \<forall>y\<in>A. P x y)"
    1.57 +by (fast intro: admI elim: admD)
    1.58 +
    1.59 +text {* Admissibility for disjunction is hard to prove. It requires 2 lemmas. *}
    1.60 +
    1.61 +lemma adm_disj_lemma1:
    1.62 +  assumes adm: "adm P"
    1.63 +  assumes chain: "chain Y"
    1.64 +  assumes P: "\<forall>i. \<exists>j\<ge>i. P (Y j)"
    1.65 +  shows "P (\<Squnion>i. Y i)"
    1.66 +proof -
    1.67 +  def f \<equiv> "\<lambda>i. LEAST j. i \<le> j \<and> P (Y j)"
    1.68 +  have chain': "chain (\<lambda>i. Y (f i))"
    1.69 +    unfolding f_def
    1.70 +    apply (rule chainI)
    1.71 +    apply (rule chain_mono [OF chain])
    1.72 +    apply (rule Least_le)
    1.73 +    apply (rule LeastI2_ex)
    1.74 +    apply (simp_all add: P)
    1.75 +    done
    1.76 +  have f1: "\<And>i. i \<le> f i" and f2: "\<And>i. P (Y (f i))"
    1.77 +    using LeastI_ex [OF P [rule_format]] by (simp_all add: f_def)
    1.78 +  have lub_eq: "(\<Squnion>i. Y i) = (\<Squnion>i. Y (f i))"
    1.79 +    apply (rule below_antisym)
    1.80 +    apply (rule lub_mono [OF chain chain'])
    1.81 +    apply (rule chain_mono [OF chain f1])
    1.82 +    apply (rule lub_range_mono [OF _ chain chain'])
    1.83 +    apply clarsimp
    1.84 +    done
    1.85 +  show "P (\<Squnion>i. Y i)"
    1.86 +    unfolding lub_eq using adm chain' f2 by (rule admD)
    1.87 +qed
    1.88 +
    1.89 +lemma adm_disj_lemma2:
    1.90 +  "\<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)"
    1.91 +apply (erule contrapos_pp)
    1.92 +apply (clarsimp, rename_tac a b)
    1.93 +apply (rule_tac x="max a b" in exI)
    1.94 +apply simp
    1.95 +done
    1.96 +
    1.97 +lemma adm_disj [simp]:
    1.98 +  "\<lbrakk>adm (\<lambda>x. P x); adm (\<lambda>x. Q x)\<rbrakk> \<Longrightarrow> adm (\<lambda>x. P x \<or> Q x)"
    1.99 +apply (rule admI)
   1.100 +apply (erule adm_disj_lemma2 [THEN disjE])
   1.101 +apply (erule (2) adm_disj_lemma1 [THEN disjI1])
   1.102 +apply (erule (2) adm_disj_lemma1 [THEN disjI2])
   1.103 +done
   1.104 +
   1.105 +lemma adm_imp [simp]:
   1.106 +  "\<lbrakk>adm (\<lambda>x. \<not> P x); adm (\<lambda>x. Q x)\<rbrakk> \<Longrightarrow> adm (\<lambda>x. P x \<longrightarrow> Q x)"
   1.107 +by (subst imp_conv_disj, rule adm_disj)
   1.108 +
   1.109 +lemma adm_iff [simp]:
   1.110 +  "\<lbrakk>adm (\<lambda>x. P x \<longrightarrow> Q x); adm (\<lambda>x. Q x \<longrightarrow> P x)\<rbrakk>  
   1.111 +    \<Longrightarrow> adm (\<lambda>x. P x = Q x)"
   1.112 +by (subst iff_conv_conj_imp, rule adm_conj)
   1.113 +
   1.114 +text {* admissibility and continuity *}
   1.115 +
   1.116 +lemma adm_below [simp]:
   1.117 +  "\<lbrakk>cont (\<lambda>x. u x); cont (\<lambda>x. v x)\<rbrakk> \<Longrightarrow> adm (\<lambda>x. u x \<sqsubseteq> v x)"
   1.118 +by (simp add: adm_def cont2contlubE lub_mono ch2ch_cont)
   1.119 +
   1.120 +lemma adm_eq [simp]:
   1.121 +  "\<lbrakk>cont (\<lambda>x. u x); cont (\<lambda>x. v x)\<rbrakk> \<Longrightarrow> adm (\<lambda>x. u x = v x)"
   1.122 +by (simp add: po_eq_conv)
   1.123 +
   1.124 +lemma adm_subst: "\<lbrakk>cont (\<lambda>x. t x); adm P\<rbrakk> \<Longrightarrow> adm (\<lambda>x. P (t x))"
   1.125 +by (simp add: adm_def cont2contlubE ch2ch_cont)
   1.126 +
   1.127 +lemma adm_not_below [simp]: "cont (\<lambda>x. t x) \<Longrightarrow> adm (\<lambda>x. \<not> t x \<sqsubseteq> u)"
   1.128 +by (rule admI, simp add: cont2contlubE ch2ch_cont lub_below_iff)
   1.129 +
   1.130 +subsection {* Compactness *}
   1.131 +
   1.132 +definition
   1.133 +  compact :: "'a::cpo \<Rightarrow> bool" where
   1.134 +  "compact k = adm (\<lambda>x. \<not> k \<sqsubseteq> x)"
   1.135 +
   1.136 +lemma compactI: "adm (\<lambda>x. \<not> k \<sqsubseteq> x) \<Longrightarrow> compact k"
   1.137 +unfolding compact_def .
   1.138 +
   1.139 +lemma compactD: "compact k \<Longrightarrow> adm (\<lambda>x. \<not> k \<sqsubseteq> x)"
   1.140 +unfolding compact_def .
   1.141 +
   1.142 +lemma compactI2:
   1.143 +  "(\<And>Y. \<lbrakk>chain Y; x \<sqsubseteq> (\<Squnion>i. Y i)\<rbrakk> \<Longrightarrow> \<exists>i. x \<sqsubseteq> Y i) \<Longrightarrow> compact x"
   1.144 +unfolding compact_def adm_def by fast
   1.145 +
   1.146 +lemma compactD2:
   1.147 +  "\<lbrakk>compact x; chain Y; x \<sqsubseteq> (\<Squnion>i. Y i)\<rbrakk> \<Longrightarrow> \<exists>i. x \<sqsubseteq> Y i"
   1.148 +unfolding compact_def adm_def by fast
   1.149 +
   1.150 +lemma compact_below_lub_iff:
   1.151 +  "\<lbrakk>compact x; chain Y\<rbrakk> \<Longrightarrow> x \<sqsubseteq> (\<Squnion>i. Y i) \<longleftrightarrow> (\<exists>i. x \<sqsubseteq> Y i)"
   1.152 +by (fast intro: compactD2 elim: below_lub)
   1.153 +
   1.154 +lemma compact_chfin [simp]: "compact (x::'a::chfin)"
   1.155 +by (rule compactI [OF adm_chfin])
   1.156 +
   1.157 +lemma compact_imp_max_in_chain:
   1.158 +  "\<lbrakk>chain Y; compact (\<Squnion>i. Y i)\<rbrakk> \<Longrightarrow> \<exists>i. max_in_chain i Y"
   1.159 +apply (drule (1) compactD2, simp)
   1.160 +apply (erule exE, rule_tac x=i in exI)
   1.161 +apply (rule max_in_chainI)
   1.162 +apply (rule below_antisym)
   1.163 +apply (erule (1) chain_mono)
   1.164 +apply (erule (1) below_trans [OF is_ub_thelub])
   1.165 +done
   1.166 +
   1.167 +text {* admissibility and compactness *}
   1.168 +
   1.169 +lemma adm_compact_not_below [simp]:
   1.170 +  "\<lbrakk>compact k; cont (\<lambda>x. t x)\<rbrakk> \<Longrightarrow> adm (\<lambda>x. \<not> k \<sqsubseteq> t x)"
   1.171 +unfolding compact_def by (rule adm_subst)
   1.172 +
   1.173 +lemma adm_neq_compact [simp]:
   1.174 +  "\<lbrakk>compact k; cont (\<lambda>x. t x)\<rbrakk> \<Longrightarrow> adm (\<lambda>x. t x \<noteq> k)"
   1.175 +by (simp add: po_eq_conv)
   1.176 +
   1.177 +lemma adm_compact_neq [simp]:
   1.178 +  "\<lbrakk>compact k; cont (\<lambda>x. t x)\<rbrakk> \<Longrightarrow> adm (\<lambda>x. k \<noteq> t x)"
   1.179 +by (simp add: po_eq_conv)
   1.180 +
   1.181 +lemma compact_UU [simp, intro]: "compact \<bottom>"
   1.182 +by (rule compactI, simp)
   1.183 +
   1.184 +text {* Any upward-closed predicate is admissible. *}
   1.185 +
   1.186 +lemma adm_upward:
   1.187 +  assumes P: "\<And>x y. \<lbrakk>P x; x \<sqsubseteq> y\<rbrakk> \<Longrightarrow> P y"
   1.188 +  shows "adm P"
   1.189 +by (rule admI, drule spec, erule P, erule is_ub_thelub)
   1.190 +
   1.191 +lemmas adm_lemmas =
   1.192 +  adm_const adm_conj adm_all adm_ball adm_disj adm_imp adm_iff
   1.193 +  adm_below adm_eq adm_not_below
   1.194 +  adm_compact_not_below adm_compact_neq adm_neq_compact
   1.195 +
   1.196 +end
     2.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     2.2 +++ b/src/HOL/HOLCF/Algebraic.thy	Sat Nov 27 16:08:10 2010 -0800
     2.3 @@ -0,0 +1,214 @@
     2.4 +(*  Title:      HOLCF/Algebraic.thy
     2.5 +    Author:     Brian Huffman
     2.6 +*)
     2.7 +
     2.8 +header {* Algebraic deflations *}
     2.9 +
    2.10 +theory Algebraic
    2.11 +imports Universal Map_Functions
    2.12 +begin
    2.13 +
    2.14 +subsection {* Type constructor for finite deflations *}
    2.15 +
    2.16 +typedef (open) fin_defl = "{d::udom \<rightarrow> udom. finite_deflation d}"
    2.17 +by (fast intro: finite_deflation_UU)
    2.18 +
    2.19 +instantiation fin_defl :: below
    2.20 +begin
    2.21 +
    2.22 +definition below_fin_defl_def:
    2.23 +    "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep_fin_defl x \<sqsubseteq> Rep_fin_defl y"
    2.24 +
    2.25 +instance ..
    2.26 +end
    2.27 +
    2.28 +instance fin_defl :: po
    2.29 +using type_definition_fin_defl below_fin_defl_def
    2.30 +by (rule typedef_po)
    2.31 +
    2.32 +lemma finite_deflation_Rep_fin_defl: "finite_deflation (Rep_fin_defl d)"
    2.33 +using Rep_fin_defl by simp
    2.34 +
    2.35 +lemma deflation_Rep_fin_defl: "deflation (Rep_fin_defl d)"
    2.36 +using finite_deflation_Rep_fin_defl
    2.37 +by (rule finite_deflation_imp_deflation)
    2.38 +
    2.39 +interpretation Rep_fin_defl: finite_deflation "Rep_fin_defl d"
    2.40 +by (rule finite_deflation_Rep_fin_defl)
    2.41 +
    2.42 +lemma fin_defl_belowI:
    2.43 +  "(\<And>x. Rep_fin_defl a\<cdot>x = x \<Longrightarrow> Rep_fin_defl b\<cdot>x = x) \<Longrightarrow> a \<sqsubseteq> b"
    2.44 +unfolding below_fin_defl_def
    2.45 +by (rule Rep_fin_defl.belowI)
    2.46 +
    2.47 +lemma fin_defl_belowD:
    2.48 +  "\<lbrakk>a \<sqsubseteq> b; Rep_fin_defl a\<cdot>x = x\<rbrakk> \<Longrightarrow> Rep_fin_defl b\<cdot>x = x"
    2.49 +unfolding below_fin_defl_def
    2.50 +by (rule Rep_fin_defl.belowD)
    2.51 +
    2.52 +lemma fin_defl_eqI:
    2.53 +  "(\<And>x. Rep_fin_defl a\<cdot>x = x \<longleftrightarrow> Rep_fin_defl b\<cdot>x = x) \<Longrightarrow> a = b"
    2.54 +apply (rule below_antisym)
    2.55 +apply (rule fin_defl_belowI, simp)
    2.56 +apply (rule fin_defl_belowI, simp)
    2.57 +done
    2.58 +
    2.59 +lemma Rep_fin_defl_mono: "a \<sqsubseteq> b \<Longrightarrow> Rep_fin_defl a \<sqsubseteq> Rep_fin_defl b"
    2.60 +unfolding below_fin_defl_def .
    2.61 +
    2.62 +lemma Abs_fin_defl_mono:
    2.63 +  "\<lbrakk>finite_deflation a; finite_deflation b; a \<sqsubseteq> b\<rbrakk>
    2.64 +    \<Longrightarrow> Abs_fin_defl a \<sqsubseteq> Abs_fin_defl b"
    2.65 +unfolding below_fin_defl_def
    2.66 +by (simp add: Abs_fin_defl_inverse)
    2.67 +
    2.68 +lemma (in finite_deflation) compact_belowI:
    2.69 +  assumes "\<And>x. compact x \<Longrightarrow> d\<cdot>x = x \<Longrightarrow> f\<cdot>x = x" shows "d \<sqsubseteq> f"
    2.70 +by (rule belowI, rule assms, erule subst, rule compact)
    2.71 +
    2.72 +lemma compact_Rep_fin_defl [simp]: "compact (Rep_fin_defl a)"
    2.73 +using finite_deflation_Rep_fin_defl
    2.74 +by (rule finite_deflation_imp_compact)
    2.75 +
    2.76 +subsection {* Defining algebraic deflations by ideal completion *}
    2.77 +
    2.78 +typedef (open) defl = "{S::fin_defl set. below.ideal S}"
    2.79 +by (fast intro: below.ideal_principal)
    2.80 +
    2.81 +instantiation defl :: below
    2.82 +begin
    2.83 +
    2.84 +definition
    2.85 +  "x \<sqsubseteq> y \<longleftrightarrow> Rep_defl x \<subseteq> Rep_defl y"
    2.86 +
    2.87 +instance ..
    2.88 +end
    2.89 +
    2.90 +instance defl :: po
    2.91 +using type_definition_defl below_defl_def
    2.92 +by (rule below.typedef_ideal_po)
    2.93 +
    2.94 +instance defl :: cpo
    2.95 +using type_definition_defl below_defl_def
    2.96 +by (rule below.typedef_ideal_cpo)
    2.97 +
    2.98 +definition
    2.99 +  defl_principal :: "fin_defl \<Rightarrow> defl" where
   2.100 +  "defl_principal t = Abs_defl {u. u \<sqsubseteq> t}"
   2.101 +
   2.102 +lemma fin_defl_countable: "\<exists>f::fin_defl \<Rightarrow> nat. inj f"
   2.103 +proof
   2.104 +  have *: "\<And>d. finite (approx_chain.place udom_approx `
   2.105 +               Rep_compact_basis -` {x. Rep_fin_defl d\<cdot>x = x})"
   2.106 +    apply (rule finite_imageI)
   2.107 +    apply (rule finite_vimageI)
   2.108 +    apply (rule Rep_fin_defl.finite_fixes)
   2.109 +    apply (simp add: inj_on_def Rep_compact_basis_inject)
   2.110 +    done
   2.111 +  have range_eq: "range Rep_compact_basis = {x. compact x}"
   2.112 +    using type_definition_compact_basis by (rule type_definition.Rep_range)
   2.113 +  show "inj (\<lambda>d. set_encode
   2.114 +    (approx_chain.place udom_approx ` Rep_compact_basis -` {x. Rep_fin_defl d\<cdot>x = x}))"
   2.115 +    apply (rule inj_onI)
   2.116 +    apply (simp only: set_encode_eq *)
   2.117 +    apply (simp only: inj_image_eq_iff approx_chain.inj_place [OF udom_approx])
   2.118 +    apply (drule_tac f="image Rep_compact_basis" in arg_cong)
   2.119 +    apply (simp del: vimage_Collect_eq add: range_eq set_eq_iff)
   2.120 +    apply (rule Rep_fin_defl_inject [THEN iffD1])
   2.121 +    apply (rule below_antisym)
   2.122 +    apply (rule Rep_fin_defl.compact_belowI, rename_tac z)
   2.123 +    apply (drule_tac x=z in spec, simp)
   2.124 +    apply (rule Rep_fin_defl.compact_belowI, rename_tac z)
   2.125 +    apply (drule_tac x=z in spec, simp)
   2.126 +    done
   2.127 +qed
   2.128 +
   2.129 +interpretation defl: ideal_completion below defl_principal Rep_defl
   2.130 +using type_definition_defl below_defl_def
   2.131 +using defl_principal_def fin_defl_countable
   2.132 +by (rule below.typedef_ideal_completion)
   2.133 +
   2.134 +text {* Algebraic deflations are pointed *}
   2.135 +
   2.136 +lemma defl_minimal: "defl_principal (Abs_fin_defl \<bottom>) \<sqsubseteq> x"
   2.137 +apply (induct x rule: defl.principal_induct, simp)
   2.138 +apply (rule defl.principal_mono)
   2.139 +apply (simp add: below_fin_defl_def)
   2.140 +apply (simp add: Abs_fin_defl_inverse finite_deflation_UU)
   2.141 +done
   2.142 +
   2.143 +instance defl :: pcpo
   2.144 +by intro_classes (fast intro: defl_minimal)
   2.145 +
   2.146 +lemma inst_defl_pcpo: "\<bottom> = defl_principal (Abs_fin_defl \<bottom>)"
   2.147 +by (rule defl_minimal [THEN UU_I, symmetric])
   2.148 +
   2.149 +subsection {* Applying algebraic deflations *}
   2.150 +
   2.151 +definition
   2.152 +  cast :: "defl \<rightarrow> udom \<rightarrow> udom"
   2.153 +where
   2.154 +  "cast = defl.basis_fun Rep_fin_defl"
   2.155 +
   2.156 +lemma cast_defl_principal:
   2.157 +  "cast\<cdot>(defl_principal a) = Rep_fin_defl a"
   2.158 +unfolding cast_def
   2.159 +apply (rule defl.basis_fun_principal)
   2.160 +apply (simp only: below_fin_defl_def)
   2.161 +done
   2.162 +
   2.163 +lemma deflation_cast: "deflation (cast\<cdot>d)"
   2.164 +apply (induct d rule: defl.principal_induct)
   2.165 +apply (rule adm_subst [OF _ adm_deflation], simp)
   2.166 +apply (simp add: cast_defl_principal)
   2.167 +apply (rule finite_deflation_imp_deflation)
   2.168 +apply (rule finite_deflation_Rep_fin_defl)
   2.169 +done
   2.170 +
   2.171 +lemma finite_deflation_cast:
   2.172 +  "compact d \<Longrightarrow> finite_deflation (cast\<cdot>d)"
   2.173 +apply (drule defl.compact_imp_principal, clarify)
   2.174 +apply (simp add: cast_defl_principal)
   2.175 +apply (rule finite_deflation_Rep_fin_defl)
   2.176 +done
   2.177 +
   2.178 +interpretation cast: deflation "cast\<cdot>d"
   2.179 +by (rule deflation_cast)
   2.180 +
   2.181 +declare cast.idem [simp]
   2.182 +
   2.183 +lemma compact_cast [simp]: "compact d \<Longrightarrow> compact (cast\<cdot>d)"
   2.184 +apply (rule finite_deflation_imp_compact)
   2.185 +apply (erule finite_deflation_cast)
   2.186 +done
   2.187 +
   2.188 +lemma cast_below_cast: "cast\<cdot>A \<sqsubseteq> cast\<cdot>B \<longleftrightarrow> A \<sqsubseteq> B"
   2.189 +apply (induct A rule: defl.principal_induct, simp)
   2.190 +apply (induct B rule: defl.principal_induct, simp)
   2.191 +apply (simp add: cast_defl_principal below_fin_defl_def)
   2.192 +done
   2.193 +
   2.194 +lemma compact_cast_iff: "compact (cast\<cdot>d) \<longleftrightarrow> compact d"
   2.195 +apply (rule iffI)
   2.196 +apply (simp only: compact_def cast_below_cast [symmetric])
   2.197 +apply (erule adm_subst [OF cont_Rep_cfun2])
   2.198 +apply (erule compact_cast)
   2.199 +done
   2.200 +
   2.201 +lemma cast_below_imp_below: "cast\<cdot>A \<sqsubseteq> cast\<cdot>B \<Longrightarrow> A \<sqsubseteq> B"
   2.202 +by (simp only: cast_below_cast)
   2.203 +
   2.204 +lemma cast_eq_imp_eq: "cast\<cdot>A = cast\<cdot>B \<Longrightarrow> A = B"
   2.205 +by (simp add: below_antisym cast_below_imp_below)
   2.206 +
   2.207 +lemma cast_strict1 [simp]: "cast\<cdot>\<bottom> = \<bottom>"
   2.208 +apply (subst inst_defl_pcpo)
   2.209 +apply (subst cast_defl_principal)
   2.210 +apply (rule Abs_fin_defl_inverse)
   2.211 +apply (simp add: finite_deflation_UU)
   2.212 +done
   2.213 +
   2.214 +lemma cast_strict2 [simp]: "cast\<cdot>A\<cdot>\<bottom> = \<bottom>"
   2.215 +by (rule cast.below [THEN UU_I])
   2.216 +
   2.217 +end
     3.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     3.2 +++ b/src/HOL/HOLCF/Bifinite.thy	Sat Nov 27 16:08:10 2010 -0800
     3.3 @@ -0,0 +1,800 @@
     3.4 +(*  Title:      HOLCF/Bifinite.thy
     3.5 +    Author:     Brian Huffman
     3.6 +*)
     3.7 +
     3.8 +header {* Bifinite domains *}
     3.9 +
    3.10 +theory Bifinite
    3.11 +imports Algebraic Map_Functions Countable
    3.12 +begin
    3.13 +
    3.14 +subsection {* Class of bifinite domains *}
    3.15 +
    3.16 +text {*
    3.17 +  We define a ``domain'' as a pcpo that is isomorphic to some
    3.18 +  algebraic deflation over the universal domain; this is equivalent
    3.19 +  to being omega-bifinite.
    3.20 +
    3.21 +  A predomain is a cpo that, when lifted, becomes a domain.
    3.22 +*}
    3.23 +
    3.24 +class predomain = cpo +
    3.25 +  fixes liftdefl :: "('a::cpo) itself \<Rightarrow> defl"
    3.26 +  fixes liftemb :: "'a\<^sub>\<bottom> \<rightarrow> udom"
    3.27 +  fixes liftprj :: "udom \<rightarrow> 'a\<^sub>\<bottom>"
    3.28 +  assumes predomain_ep: "ep_pair liftemb liftprj"
    3.29 +  assumes cast_liftdefl: "cast\<cdot>(liftdefl TYPE('a::cpo)) = liftemb oo liftprj"
    3.30 +
    3.31 +syntax "_LIFTDEFL" :: "type \<Rightarrow> logic"  ("(1LIFTDEFL/(1'(_')))")
    3.32 +translations "LIFTDEFL('t)" \<rightleftharpoons> "CONST liftdefl TYPE('t)"
    3.33 +
    3.34 +class "domain" = predomain + pcpo +
    3.35 +  fixes emb :: "'a::cpo \<rightarrow> udom"
    3.36 +  fixes prj :: "udom \<rightarrow> 'a::cpo"
    3.37 +  fixes defl :: "'a itself \<Rightarrow> defl"
    3.38 +  assumes ep_pair_emb_prj: "ep_pair emb prj"
    3.39 +  assumes cast_DEFL: "cast\<cdot>(defl TYPE('a)) = emb oo prj"
    3.40 +
    3.41 +syntax "_DEFL" :: "type \<Rightarrow> defl"  ("(1DEFL/(1'(_')))")
    3.42 +translations "DEFL('t)" \<rightleftharpoons> "CONST defl TYPE('t)"
    3.43 +
    3.44 +interpretation "domain": pcpo_ep_pair emb prj
    3.45 +  unfolding pcpo_ep_pair_def
    3.46 +  by (rule ep_pair_emb_prj)
    3.47 +
    3.48 +lemmas emb_inverse = domain.e_inverse
    3.49 +lemmas emb_prj_below = domain.e_p_below
    3.50 +lemmas emb_eq_iff = domain.e_eq_iff
    3.51 +lemmas emb_strict = domain.e_strict
    3.52 +lemmas prj_strict = domain.p_strict
    3.53 +
    3.54 +subsection {* Domains have a countable compact basis *}
    3.55 +
    3.56 +text {*
    3.57 +  Eventually it should be possible to generalize this to an unpointed
    3.58 +  variant of the domain class.
    3.59 +*}
    3.60 +
    3.61 +interpretation compact_basis:
    3.62 +  ideal_completion below Rep_compact_basis "approximants::'a::domain \<Rightarrow> _"
    3.63 +proof -
    3.64 +  obtain Y where Y: "\<forall>i. Y i \<sqsubseteq> Y (Suc i)"
    3.65 +  and DEFL: "DEFL('a) = (\<Squnion>i. defl_principal (Y i))"
    3.66 +    by (rule defl.obtain_principal_chain)
    3.67 +  def approx \<equiv> "\<lambda>i. (prj oo cast\<cdot>(defl_principal (Y i)) oo emb) :: 'a \<rightarrow> 'a"
    3.68 +  interpret defl_approx: approx_chain approx
    3.69 +  proof (rule approx_chain.intro)
    3.70 +    show "chain (\<lambda>i. approx i)"
    3.71 +      unfolding approx_def by (simp add: Y)
    3.72 +    show "(\<Squnion>i. approx i) = ID"
    3.73 +      unfolding approx_def
    3.74 +      by (simp add: lub_distribs Y DEFL [symmetric] cast_DEFL cfun_eq_iff)
    3.75 +    show "\<And>i. finite_deflation (approx i)"
    3.76 +      unfolding approx_def
    3.77 +      apply (rule domain.finite_deflation_p_d_e)
    3.78 +      apply (rule finite_deflation_cast)
    3.79 +      apply (rule defl.compact_principal)
    3.80 +      apply (rule below_trans [OF monofun_cfun_fun])
    3.81 +      apply (rule is_ub_thelub, simp add: Y)
    3.82 +      apply (simp add: lub_distribs Y DEFL [symmetric] cast_DEFL)
    3.83 +      done
    3.84 +  qed
    3.85 +  (* FIXME: why does show ?thesis fail here? *)
    3.86 +  show "ideal_completion below Rep_compact_basis (approximants::'a \<Rightarrow> _)" ..
    3.87 +qed
    3.88 +
    3.89 +subsection {* Chains of approx functions *}
    3.90 +
    3.91 +definition u_approx :: "nat \<Rightarrow> udom\<^sub>\<bottom> \<rightarrow> udom\<^sub>\<bottom>"
    3.92 +  where "u_approx = (\<lambda>i. u_map\<cdot>(udom_approx i))"
    3.93 +
    3.94 +definition sfun_approx :: "nat \<Rightarrow> (udom \<rightarrow>! udom) \<rightarrow> (udom \<rightarrow>! udom)"
    3.95 +  where "sfun_approx = (\<lambda>i. sfun_map\<cdot>(udom_approx i)\<cdot>(udom_approx i))"
    3.96 +
    3.97 +definition prod_approx :: "nat \<Rightarrow> udom \<times> udom \<rightarrow> udom \<times> udom"
    3.98 +  where "prod_approx = (\<lambda>i. cprod_map\<cdot>(udom_approx i)\<cdot>(udom_approx i))"
    3.99 +
   3.100 +definition sprod_approx :: "nat \<Rightarrow> udom \<otimes> udom \<rightarrow> udom \<otimes> udom"
   3.101 +  where "sprod_approx = (\<lambda>i. sprod_map\<cdot>(udom_approx i)\<cdot>(udom_approx i))"
   3.102 +
   3.103 +definition ssum_approx :: "nat \<Rightarrow> udom \<oplus> udom \<rightarrow> udom \<oplus> udom"
   3.104 +  where "ssum_approx = (\<lambda>i. ssum_map\<cdot>(udom_approx i)\<cdot>(udom_approx i))"
   3.105 +
   3.106 +lemma approx_chain_lemma1:
   3.107 +  assumes "m\<cdot>ID = ID"
   3.108 +  assumes "\<And>d. finite_deflation d \<Longrightarrow> finite_deflation (m\<cdot>d)"
   3.109 +  shows "approx_chain (\<lambda>i. m\<cdot>(udom_approx i))"
   3.110 +by (rule approx_chain.intro)
   3.111 +   (simp_all add: lub_distribs finite_deflation_udom_approx assms)
   3.112 +
   3.113 +lemma approx_chain_lemma2:
   3.114 +  assumes "m\<cdot>ID\<cdot>ID = ID"
   3.115 +  assumes "\<And>a b. \<lbrakk>finite_deflation a; finite_deflation b\<rbrakk>
   3.116 +    \<Longrightarrow> finite_deflation (m\<cdot>a\<cdot>b)"
   3.117 +  shows "approx_chain (\<lambda>i. m\<cdot>(udom_approx i)\<cdot>(udom_approx i))"
   3.118 +by (rule approx_chain.intro)
   3.119 +   (simp_all add: lub_distribs finite_deflation_udom_approx assms)
   3.120 +
   3.121 +lemma u_approx: "approx_chain u_approx"
   3.122 +using u_map_ID finite_deflation_u_map
   3.123 +unfolding u_approx_def by (rule approx_chain_lemma1)
   3.124 +
   3.125 +lemma sfun_approx: "approx_chain sfun_approx"
   3.126 +using sfun_map_ID finite_deflation_sfun_map
   3.127 +unfolding sfun_approx_def by (rule approx_chain_lemma2)
   3.128 +
   3.129 +lemma prod_approx: "approx_chain prod_approx"
   3.130 +using cprod_map_ID finite_deflation_cprod_map
   3.131 +unfolding prod_approx_def by (rule approx_chain_lemma2)
   3.132 +
   3.133 +lemma sprod_approx: "approx_chain sprod_approx"
   3.134 +using sprod_map_ID finite_deflation_sprod_map
   3.135 +unfolding sprod_approx_def by (rule approx_chain_lemma2)
   3.136 +
   3.137 +lemma ssum_approx: "approx_chain ssum_approx"
   3.138 +using ssum_map_ID finite_deflation_ssum_map
   3.139 +unfolding ssum_approx_def by (rule approx_chain_lemma2)
   3.140 +
   3.141 +subsection {* Type combinators *}
   3.142 +
   3.143 +definition
   3.144 +  defl_fun1 ::
   3.145 +    "(nat \<Rightarrow> 'a \<rightarrow> 'a) \<Rightarrow> ((udom \<rightarrow> udom) \<rightarrow> ('a \<rightarrow> 'a)) \<Rightarrow> (defl \<rightarrow> defl)"
   3.146 +where
   3.147 +  "defl_fun1 approx f =
   3.148 +    defl.basis_fun (\<lambda>a.
   3.149 +      defl_principal (Abs_fin_defl
   3.150 +        (udom_emb approx oo f\<cdot>(Rep_fin_defl a) oo udom_prj approx)))"
   3.151 +
   3.152 +definition
   3.153 +  defl_fun2 ::
   3.154 +    "(nat \<Rightarrow> 'a \<rightarrow> 'a) \<Rightarrow> ((udom \<rightarrow> udom) \<rightarrow> (udom \<rightarrow> udom) \<rightarrow> ('a \<rightarrow> 'a))
   3.155 +      \<Rightarrow> (defl \<rightarrow> defl \<rightarrow> defl)"
   3.156 +where
   3.157 +  "defl_fun2 approx f =
   3.158 +    defl.basis_fun (\<lambda>a.
   3.159 +      defl.basis_fun (\<lambda>b.
   3.160 +        defl_principal (Abs_fin_defl
   3.161 +          (udom_emb approx oo
   3.162 +            f\<cdot>(Rep_fin_defl a)\<cdot>(Rep_fin_defl b) oo udom_prj approx))))"
   3.163 +
   3.164 +lemma cast_defl_fun1:
   3.165 +  assumes approx: "approx_chain approx"
   3.166 +  assumes f: "\<And>a. finite_deflation a \<Longrightarrow> finite_deflation (f\<cdot>a)"
   3.167 +  shows "cast\<cdot>(defl_fun1 approx f\<cdot>A) = udom_emb approx oo f\<cdot>(cast\<cdot>A) oo udom_prj approx"
   3.168 +proof -
   3.169 +  have 1: "\<And>a. finite_deflation
   3.170 +        (udom_emb approx oo f\<cdot>(Rep_fin_defl a) oo udom_prj approx)"
   3.171 +    apply (rule ep_pair.finite_deflation_e_d_p)
   3.172 +    apply (rule approx_chain.ep_pair_udom [OF approx])
   3.173 +    apply (rule f, rule finite_deflation_Rep_fin_defl)
   3.174 +    done
   3.175 +  show ?thesis
   3.176 +    by (induct A rule: defl.principal_induct, simp)
   3.177 +       (simp only: defl_fun1_def
   3.178 +                   defl.basis_fun_principal
   3.179 +                   defl.basis_fun_mono
   3.180 +                   defl.principal_mono
   3.181 +                   Abs_fin_defl_mono [OF 1 1]
   3.182 +                   monofun_cfun below_refl
   3.183 +                   Rep_fin_defl_mono
   3.184 +                   cast_defl_principal
   3.185 +                   Abs_fin_defl_inverse [unfolded mem_Collect_eq, OF 1])
   3.186 +qed
   3.187 +
   3.188 +lemma cast_defl_fun2:
   3.189 +  assumes approx: "approx_chain approx"
   3.190 +  assumes f: "\<And>a b. finite_deflation a \<Longrightarrow> finite_deflation b \<Longrightarrow>
   3.191 +                finite_deflation (f\<cdot>a\<cdot>b)"
   3.192 +  shows "cast\<cdot>(defl_fun2 approx f\<cdot>A\<cdot>B) =
   3.193 +    udom_emb approx oo f\<cdot>(cast\<cdot>A)\<cdot>(cast\<cdot>B) oo udom_prj approx"
   3.194 +proof -
   3.195 +  have 1: "\<And>a b. finite_deflation (udom_emb approx oo
   3.196 +      f\<cdot>(Rep_fin_defl a)\<cdot>(Rep_fin_defl b) oo udom_prj approx)"
   3.197 +    apply (rule ep_pair.finite_deflation_e_d_p)
   3.198 +    apply (rule ep_pair_udom [OF approx])
   3.199 +    apply (rule f, (rule finite_deflation_Rep_fin_defl)+)
   3.200 +    done
   3.201 +  show ?thesis
   3.202 +    by (induct A B rule: defl.principal_induct2, simp, simp)
   3.203 +       (simp only: defl_fun2_def
   3.204 +                   defl.basis_fun_principal
   3.205 +                   defl.basis_fun_mono
   3.206 +                   defl.principal_mono
   3.207 +                   Abs_fin_defl_mono [OF 1 1]
   3.208 +                   monofun_cfun below_refl
   3.209 +                   Rep_fin_defl_mono
   3.210 +                   cast_defl_principal
   3.211 +                   Abs_fin_defl_inverse [unfolded mem_Collect_eq, OF 1])
   3.212 +qed
   3.213 +
   3.214 +definition u_defl :: "defl \<rightarrow> defl"
   3.215 +  where "u_defl = defl_fun1 u_approx u_map"
   3.216 +
   3.217 +definition sfun_defl :: "defl \<rightarrow> defl \<rightarrow> defl"
   3.218 +  where "sfun_defl = defl_fun2 sfun_approx sfun_map"
   3.219 +
   3.220 +definition prod_defl :: "defl \<rightarrow> defl \<rightarrow> defl"
   3.221 +  where "prod_defl = defl_fun2 prod_approx cprod_map"
   3.222 +
   3.223 +definition sprod_defl :: "defl \<rightarrow> defl \<rightarrow> defl"
   3.224 +  where "sprod_defl = defl_fun2 sprod_approx sprod_map"
   3.225 +
   3.226 +definition ssum_defl :: "defl \<rightarrow> defl \<rightarrow> defl"
   3.227 +where "ssum_defl = defl_fun2 ssum_approx ssum_map"
   3.228 +
   3.229 +lemma cast_u_defl:
   3.230 +  "cast\<cdot>(u_defl\<cdot>A) =
   3.231 +    udom_emb u_approx oo u_map\<cdot>(cast\<cdot>A) oo udom_prj u_approx"
   3.232 +using u_approx finite_deflation_u_map
   3.233 +unfolding u_defl_def by (rule cast_defl_fun1)
   3.234 +
   3.235 +lemma cast_sfun_defl:
   3.236 +  "cast\<cdot>(sfun_defl\<cdot>A\<cdot>B) =
   3.237 +    udom_emb sfun_approx oo sfun_map\<cdot>(cast\<cdot>A)\<cdot>(cast\<cdot>B) oo udom_prj sfun_approx"
   3.238 +using sfun_approx finite_deflation_sfun_map
   3.239 +unfolding sfun_defl_def by (rule cast_defl_fun2)
   3.240 +
   3.241 +lemma cast_prod_defl:
   3.242 +  "cast\<cdot>(prod_defl\<cdot>A\<cdot>B) = udom_emb prod_approx oo
   3.243 +    cprod_map\<cdot>(cast\<cdot>A)\<cdot>(cast\<cdot>B) oo udom_prj prod_approx"
   3.244 +using prod_approx finite_deflation_cprod_map
   3.245 +unfolding prod_defl_def by (rule cast_defl_fun2)
   3.246 +
   3.247 +lemma cast_sprod_defl:
   3.248 +  "cast\<cdot>(sprod_defl\<cdot>A\<cdot>B) =
   3.249 +    udom_emb sprod_approx oo
   3.250 +      sprod_map\<cdot>(cast\<cdot>A)\<cdot>(cast\<cdot>B) oo
   3.251 +        udom_prj sprod_approx"
   3.252 +using sprod_approx finite_deflation_sprod_map
   3.253 +unfolding sprod_defl_def by (rule cast_defl_fun2)
   3.254 +
   3.255 +lemma cast_ssum_defl:
   3.256 +  "cast\<cdot>(ssum_defl\<cdot>A\<cdot>B) =
   3.257 +    udom_emb ssum_approx oo ssum_map\<cdot>(cast\<cdot>A)\<cdot>(cast\<cdot>B) oo udom_prj ssum_approx"
   3.258 +using ssum_approx finite_deflation_ssum_map
   3.259 +unfolding ssum_defl_def by (rule cast_defl_fun2)
   3.260 +
   3.261 +subsection {* Lemma for proving domain instances *}
   3.262 +
   3.263 +text {*
   3.264 +  A class of domains where @{const liftemb}, @{const liftprj},
   3.265 +  and @{const liftdefl} are all defined in the standard way.
   3.266 +*}
   3.267 +
   3.268 +class liftdomain = "domain" +
   3.269 +  assumes liftemb_eq: "liftemb = udom_emb u_approx oo u_map\<cdot>emb"
   3.270 +  assumes liftprj_eq: "liftprj = u_map\<cdot>prj oo udom_prj u_approx"
   3.271 +  assumes liftdefl_eq: "liftdefl TYPE('a::cpo) = u_defl\<cdot>DEFL('a)"
   3.272 +
   3.273 +text {* Temporarily relax type constraints. *}
   3.274 +
   3.275 +setup {*
   3.276 +  fold Sign.add_const_constraint
   3.277 +  [ (@{const_name defl}, SOME @{typ "'a::pcpo itself \<Rightarrow> defl"})
   3.278 +  , (@{const_name emb}, SOME @{typ "'a::pcpo \<rightarrow> udom"})
   3.279 +  , (@{const_name prj}, SOME @{typ "udom \<rightarrow> 'a::pcpo"})
   3.280 +  , (@{const_name liftdefl}, SOME @{typ "'a::pcpo itself \<Rightarrow> defl"})
   3.281 +  , (@{const_name liftemb}, SOME @{typ "'a::pcpo u \<rightarrow> udom"})
   3.282 +  , (@{const_name liftprj}, SOME @{typ "udom \<rightarrow> 'a::pcpo u"}) ]
   3.283 +*}
   3.284 +
   3.285 +lemma liftdomain_class_intro:
   3.286 +  assumes liftemb: "(liftemb :: 'a u \<rightarrow> udom) = udom_emb u_approx oo u_map\<cdot>emb"
   3.287 +  assumes liftprj: "(liftprj :: udom \<rightarrow> 'a u) = u_map\<cdot>prj oo udom_prj u_approx"
   3.288 +  assumes liftdefl: "liftdefl TYPE('a) = u_defl\<cdot>DEFL('a)"
   3.289 +  assumes ep_pair: "ep_pair emb (prj :: udom \<rightarrow> 'a)"
   3.290 +  assumes cast_defl: "cast\<cdot>DEFL('a) = emb oo (prj :: udom \<rightarrow> 'a)"
   3.291 +  shows "OFCLASS('a, liftdomain_class)"
   3.292 +proof
   3.293 +  show "ep_pair liftemb (liftprj :: udom \<rightarrow> 'a u)"
   3.294 +    unfolding liftemb liftprj
   3.295 +    by (intro ep_pair_comp ep_pair_u_map ep_pair ep_pair_udom u_approx)
   3.296 +  show "cast\<cdot>LIFTDEFL('a) = liftemb oo (liftprj :: udom \<rightarrow> 'a u)"
   3.297 +    unfolding liftemb liftprj liftdefl
   3.298 +    by (simp add: cfcomp1 cast_u_defl cast_defl u_map_map)
   3.299 +next
   3.300 +qed fact+
   3.301 +
   3.302 +text {* Restore original type constraints. *}
   3.303 +
   3.304 +setup {*
   3.305 +  fold Sign.add_const_constraint
   3.306 +  [ (@{const_name defl}, SOME @{typ "'a::domain itself \<Rightarrow> defl"})
   3.307 +  , (@{const_name emb}, SOME @{typ "'a::domain \<rightarrow> udom"})
   3.308 +  , (@{const_name prj}, SOME @{typ "udom \<rightarrow> 'a::domain"})
   3.309 +  , (@{const_name liftdefl}, SOME @{typ "'a::predomain itself \<Rightarrow> defl"})
   3.310 +  , (@{const_name liftemb}, SOME @{typ "'a::predomain u \<rightarrow> udom"})
   3.311 +  , (@{const_name liftprj}, SOME @{typ "udom \<rightarrow> 'a::predomain u"}) ]
   3.312 +*}
   3.313 +
   3.314 +subsection {* Class instance proofs *}
   3.315 +
   3.316 +subsubsection {* Universal domain *}
   3.317 +
   3.318 +instantiation udom :: liftdomain
   3.319 +begin
   3.320 +
   3.321 +definition [simp]:
   3.322 +  "emb = (ID :: udom \<rightarrow> udom)"
   3.323 +
   3.324 +definition [simp]:
   3.325 +  "prj = (ID :: udom \<rightarrow> udom)"
   3.326 +
   3.327 +definition
   3.328 +  "defl (t::udom itself) = (\<Squnion>i. defl_principal (Abs_fin_defl (udom_approx i)))"
   3.329 +
   3.330 +definition
   3.331 +  "(liftemb :: udom u \<rightarrow> udom) = udom_emb u_approx oo u_map\<cdot>emb"
   3.332 +
   3.333 +definition
   3.334 +  "(liftprj :: udom \<rightarrow> udom u) = u_map\<cdot>prj oo udom_prj u_approx"
   3.335 +
   3.336 +definition
   3.337 +  "liftdefl (t::udom itself) = u_defl\<cdot>DEFL(udom)"
   3.338 +
   3.339 +instance
   3.340 +using liftemb_udom_def liftprj_udom_def liftdefl_udom_def
   3.341 +proof (rule liftdomain_class_intro)
   3.342 +  show "ep_pair emb (prj :: udom \<rightarrow> udom)"
   3.343 +    by (simp add: ep_pair.intro)
   3.344 +  show "cast\<cdot>DEFL(udom) = emb oo (prj :: udom \<rightarrow> udom)"
   3.345 +    unfolding defl_udom_def
   3.346 +    apply (subst contlub_cfun_arg)
   3.347 +    apply (rule chainI)
   3.348 +    apply (rule defl.principal_mono)
   3.349 +    apply (simp add: below_fin_defl_def)
   3.350 +    apply (simp add: Abs_fin_defl_inverse finite_deflation_udom_approx)
   3.351 +    apply (rule chainE)
   3.352 +    apply (rule chain_udom_approx)
   3.353 +    apply (subst cast_defl_principal)
   3.354 +    apply (simp add: Abs_fin_defl_inverse finite_deflation_udom_approx)
   3.355 +    done
   3.356 +qed
   3.357 +
   3.358 +end
   3.359 +
   3.360 +subsubsection {* Lifted cpo *}
   3.361 +
   3.362 +instantiation u :: (predomain) liftdomain
   3.363 +begin
   3.364 +
   3.365 +definition
   3.366 +  "emb = liftemb"
   3.367 +
   3.368 +definition
   3.369 +  "prj = liftprj"
   3.370 +
   3.371 +definition
   3.372 +  "defl (t::'a u itself) = LIFTDEFL('a)"
   3.373 +
   3.374 +definition
   3.375 +  "(liftemb :: 'a u u \<rightarrow> udom) = udom_emb u_approx oo u_map\<cdot>emb"
   3.376 +
   3.377 +definition
   3.378 +  "(liftprj :: udom \<rightarrow> 'a u u) = u_map\<cdot>prj oo udom_prj u_approx"
   3.379 +
   3.380 +definition
   3.381 +  "liftdefl (t::'a u itself) = u_defl\<cdot>DEFL('a u)"
   3.382 +
   3.383 +instance
   3.384 +using liftemb_u_def liftprj_u_def liftdefl_u_def
   3.385 +proof (rule liftdomain_class_intro)
   3.386 +  show "ep_pair emb (prj :: udom \<rightarrow> 'a u)"
   3.387 +    unfolding emb_u_def prj_u_def
   3.388 +    by (rule predomain_ep)
   3.389 +  show "cast\<cdot>DEFL('a u) = emb oo (prj :: udom \<rightarrow> 'a u)"
   3.390 +    unfolding emb_u_def prj_u_def defl_u_def
   3.391 +    by (rule cast_liftdefl)
   3.392 +qed
   3.393 +
   3.394 +end
   3.395 +
   3.396 +lemma DEFL_u: "DEFL('a::predomain u) = LIFTDEFL('a)"
   3.397 +by (rule defl_u_def)
   3.398 +
   3.399 +subsubsection {* Strict function space *}
   3.400 +
   3.401 +instantiation sfun :: ("domain", "domain") liftdomain
   3.402 +begin
   3.403 +
   3.404 +definition
   3.405 +  "emb = udom_emb sfun_approx oo sfun_map\<cdot>prj\<cdot>emb"
   3.406 +
   3.407 +definition
   3.408 +  "prj = sfun_map\<cdot>emb\<cdot>prj oo udom_prj sfun_approx"
   3.409 +
   3.410 +definition
   3.411 +  "defl (t::('a \<rightarrow>! 'b) itself) = sfun_defl\<cdot>DEFL('a)\<cdot>DEFL('b)"
   3.412 +
   3.413 +definition
   3.414 +  "(liftemb :: ('a \<rightarrow>! 'b) u \<rightarrow> udom) = udom_emb u_approx oo u_map\<cdot>emb"
   3.415 +
   3.416 +definition
   3.417 +  "(liftprj :: udom \<rightarrow> ('a \<rightarrow>! 'b) u) = u_map\<cdot>prj oo udom_prj u_approx"
   3.418 +
   3.419 +definition
   3.420 +  "liftdefl (t::('a \<rightarrow>! 'b) itself) = u_defl\<cdot>DEFL('a \<rightarrow>! 'b)"
   3.421 +
   3.422 +instance
   3.423 +using liftemb_sfun_def liftprj_sfun_def liftdefl_sfun_def
   3.424 +proof (rule liftdomain_class_intro)
   3.425 +  show "ep_pair emb (prj :: udom \<rightarrow> 'a \<rightarrow>! 'b)"
   3.426 +    unfolding emb_sfun_def prj_sfun_def
   3.427 +    using ep_pair_udom [OF sfun_approx]
   3.428 +    by (intro ep_pair_comp ep_pair_sfun_map ep_pair_emb_prj)
   3.429 +  show "cast\<cdot>DEFL('a \<rightarrow>! 'b) = emb oo (prj :: udom \<rightarrow> 'a \<rightarrow>! 'b)"
   3.430 +    unfolding emb_sfun_def prj_sfun_def defl_sfun_def cast_sfun_defl
   3.431 +    by (simp add: cast_DEFL oo_def sfun_eq_iff sfun_map_map)
   3.432 +qed
   3.433 +
   3.434 +end
   3.435 +
   3.436 +lemma DEFL_sfun:
   3.437 +  "DEFL('a::domain \<rightarrow>! 'b::domain) = sfun_defl\<cdot>DEFL('a)\<cdot>DEFL('b)"
   3.438 +by (rule defl_sfun_def)
   3.439 +
   3.440 +subsubsection {* Continuous function space *}
   3.441 +
   3.442 +text {*
   3.443 +  Types @{typ "'a \<rightarrow> 'b"} and @{typ "'a u \<rightarrow>! 'b"} are isomorphic.
   3.444 +*}
   3.445 +
   3.446 +definition
   3.447 +  "encode_cfun = (\<Lambda> f. sfun_abs\<cdot>(fup\<cdot>f))"
   3.448 +
   3.449 +definition
   3.450 +  "decode_cfun = (\<Lambda> g x. sfun_rep\<cdot>g\<cdot>(up\<cdot>x))"
   3.451 +
   3.452 +lemma decode_encode_cfun [simp]: "decode_cfun\<cdot>(encode_cfun\<cdot>x) = x"
   3.453 +unfolding encode_cfun_def decode_cfun_def
   3.454 +by (simp add: eta_cfun)
   3.455 +
   3.456 +lemma encode_decode_cfun [simp]: "encode_cfun\<cdot>(decode_cfun\<cdot>y) = y"
   3.457 +unfolding encode_cfun_def decode_cfun_def
   3.458 +apply (simp add: sfun_eq_iff strictify_cancel)
   3.459 +apply (rule cfun_eqI, case_tac x, simp_all)
   3.460 +done
   3.461 +
   3.462 +instantiation cfun :: (predomain, "domain") liftdomain
   3.463 +begin
   3.464 +
   3.465 +definition
   3.466 +  "emb = (udom_emb sfun_approx oo sfun_map\<cdot>prj\<cdot>emb) oo encode_cfun"
   3.467 +
   3.468 +definition
   3.469 +  "prj = decode_cfun oo (sfun_map\<cdot>emb\<cdot>prj oo udom_prj sfun_approx)"
   3.470 +
   3.471 +definition
   3.472 +  "defl (t::('a \<rightarrow> 'b) itself) = sfun_defl\<cdot>DEFL('a u)\<cdot>DEFL('b)"
   3.473 +
   3.474 +definition
   3.475 +  "(liftemb :: ('a \<rightarrow> 'b) u \<rightarrow> udom) = udom_emb u_approx oo u_map\<cdot>emb"
   3.476 +
   3.477 +definition
   3.478 +  "(liftprj :: udom \<rightarrow> ('a \<rightarrow> 'b) u) = u_map\<cdot>prj oo udom_prj u_approx"
   3.479 +
   3.480 +definition
   3.481 +  "liftdefl (t::('a \<rightarrow> 'b) itself) = u_defl\<cdot>DEFL('a \<rightarrow> 'b)"
   3.482 +
   3.483 +instance
   3.484 +using liftemb_cfun_def liftprj_cfun_def liftdefl_cfun_def
   3.485 +proof (rule liftdomain_class_intro)
   3.486 +  have "ep_pair encode_cfun decode_cfun"
   3.487 +    by (rule ep_pair.intro, simp_all)
   3.488 +  thus "ep_pair emb (prj :: udom \<rightarrow> 'a \<rightarrow> 'b)"
   3.489 +    unfolding emb_cfun_def prj_cfun_def
   3.490 +    apply (rule ep_pair_comp)
   3.491 +    apply (rule ep_pair_comp)
   3.492 +    apply (intro ep_pair_sfun_map ep_pair_emb_prj)
   3.493 +    apply (rule ep_pair_udom [OF sfun_approx])
   3.494 +    done
   3.495 +  show "cast\<cdot>DEFL('a \<rightarrow> 'b) = emb oo (prj :: udom \<rightarrow> 'a \<rightarrow> 'b)"
   3.496 +    unfolding emb_cfun_def prj_cfun_def defl_cfun_def cast_sfun_defl
   3.497 +    by (simp add: cast_DEFL oo_def cfun_eq_iff sfun_map_map)
   3.498 +qed
   3.499 +
   3.500 +end
   3.501 +
   3.502 +lemma DEFL_cfun:
   3.503 +  "DEFL('a::predomain \<rightarrow> 'b::domain) = sfun_defl\<cdot>DEFL('a u)\<cdot>DEFL('b)"
   3.504 +by (rule defl_cfun_def)
   3.505 +
   3.506 +subsubsection {* Cartesian product *}
   3.507 +
   3.508 +text {*
   3.509 +  Types @{typ "('a * 'b) u"} and @{typ "'a u \<otimes> 'b u"} are isomorphic.
   3.510 +*}
   3.511 +
   3.512 +definition
   3.513 +  "encode_prod_u = (\<Lambda>(up\<cdot>(x, y)). (:up\<cdot>x, up\<cdot>y:))"
   3.514 +
   3.515 +definition
   3.516 +  "decode_prod_u = (\<Lambda>(:up\<cdot>x, up\<cdot>y:). up\<cdot>(x, y))"
   3.517 +
   3.518 +lemma decode_encode_prod_u [simp]: "decode_prod_u\<cdot>(encode_prod_u\<cdot>x) = x"
   3.519 +unfolding encode_prod_u_def decode_prod_u_def
   3.520 +by (case_tac x, simp, rename_tac y, case_tac y, simp)
   3.521 +
   3.522 +lemma encode_decode_prod_u [simp]: "encode_prod_u\<cdot>(decode_prod_u\<cdot>y) = y"
   3.523 +unfolding encode_prod_u_def decode_prod_u_def
   3.524 +apply (case_tac y, simp, rename_tac a b)
   3.525 +apply (case_tac a, simp, case_tac b, simp, simp)
   3.526 +done
   3.527 +
   3.528 +instantiation prod :: (predomain, predomain) predomain
   3.529 +begin
   3.530 +
   3.531 +definition
   3.532 +  "liftemb =
   3.533 +    (udom_emb sprod_approx oo sprod_map\<cdot>emb\<cdot>emb) oo encode_prod_u"
   3.534 +
   3.535 +definition
   3.536 +  "liftprj =
   3.537 +    decode_prod_u oo (sprod_map\<cdot>prj\<cdot>prj oo udom_prj sprod_approx)"
   3.538 +
   3.539 +definition
   3.540 +  "liftdefl (t::('a \<times> 'b) itself) = sprod_defl\<cdot>DEFL('a u)\<cdot>DEFL('b u)"
   3.541 +
   3.542 +instance proof
   3.543 +  have "ep_pair encode_prod_u decode_prod_u"
   3.544 +    by (rule ep_pair.intro, simp_all)
   3.545 +  thus "ep_pair liftemb (liftprj :: udom \<rightarrow> ('a \<times> 'b) u)"
   3.546 +    unfolding liftemb_prod_def liftprj_prod_def
   3.547 +    apply (rule ep_pair_comp)
   3.548 +    apply (rule ep_pair_comp)
   3.549 +    apply (intro ep_pair_sprod_map ep_pair_emb_prj)
   3.550 +    apply (rule ep_pair_udom [OF sprod_approx])
   3.551 +    done
   3.552 +  show "cast\<cdot>LIFTDEFL('a \<times> 'b) = liftemb oo (liftprj :: udom \<rightarrow> ('a \<times> 'b) u)"
   3.553 +    unfolding liftemb_prod_def liftprj_prod_def liftdefl_prod_def
   3.554 +    by (simp add: cast_sprod_defl cast_DEFL cfcomp1 sprod_map_map)
   3.555 +qed
   3.556 +
   3.557 +end
   3.558 +
   3.559 +instantiation prod :: ("domain", "domain") "domain"
   3.560 +begin
   3.561 +
   3.562 +definition
   3.563 +  "emb = udom_emb prod_approx oo cprod_map\<cdot>emb\<cdot>emb"
   3.564 +
   3.565 +definition
   3.566 +  "prj = cprod_map\<cdot>prj\<cdot>prj oo udom_prj prod_approx"
   3.567 +
   3.568 +definition
   3.569 +  "defl (t::('a \<times> 'b) itself) = prod_defl\<cdot>DEFL('a)\<cdot>DEFL('b)"
   3.570 +
   3.571 +instance proof
   3.572 +  show "ep_pair emb (prj :: udom \<rightarrow> 'a \<times> 'b)"
   3.573 +    unfolding emb_prod_def prj_prod_def
   3.574 +    using ep_pair_udom [OF prod_approx]
   3.575 +    by (intro ep_pair_comp ep_pair_cprod_map ep_pair_emb_prj)
   3.576 +next
   3.577 +  show "cast\<cdot>DEFL('a \<times> 'b) = emb oo (prj :: udom \<rightarrow> 'a \<times> 'b)"
   3.578 +    unfolding emb_prod_def prj_prod_def defl_prod_def cast_prod_defl
   3.579 +    by (simp add: cast_DEFL oo_def cfun_eq_iff cprod_map_map)
   3.580 +qed
   3.581 +
   3.582 +end
   3.583 +
   3.584 +lemma DEFL_prod:
   3.585 +  "DEFL('a::domain \<times> 'b::domain) = prod_defl\<cdot>DEFL('a)\<cdot>DEFL('b)"
   3.586 +by (rule defl_prod_def)
   3.587 +
   3.588 +lemma LIFTDEFL_prod:
   3.589 +  "LIFTDEFL('a::predomain \<times> 'b::predomain) = sprod_defl\<cdot>DEFL('a u)\<cdot>DEFL('b u)"
   3.590 +by (rule liftdefl_prod_def)
   3.591 +
   3.592 +subsubsection {* Strict product *}
   3.593 +
   3.594 +instantiation sprod :: ("domain", "domain") liftdomain
   3.595 +begin
   3.596 +
   3.597 +definition
   3.598 +  "emb = udom_emb sprod_approx oo sprod_map\<cdot>emb\<cdot>emb"
   3.599 +
   3.600 +definition
   3.601 +  "prj = sprod_map\<cdot>prj\<cdot>prj oo udom_prj sprod_approx"
   3.602 +
   3.603 +definition
   3.604 +  "defl (t::('a \<otimes> 'b) itself) = sprod_defl\<cdot>DEFL('a)\<cdot>DEFL('b)"
   3.605 +
   3.606 +definition
   3.607 +  "(liftemb :: ('a \<otimes> 'b) u \<rightarrow> udom) = udom_emb u_approx oo u_map\<cdot>emb"
   3.608 +
   3.609 +definition
   3.610 +  "(liftprj :: udom \<rightarrow> ('a \<otimes> 'b) u) = u_map\<cdot>prj oo udom_prj u_approx"
   3.611 +
   3.612 +definition
   3.613 +  "liftdefl (t::('a \<otimes> 'b) itself) = u_defl\<cdot>DEFL('a \<otimes> 'b)"
   3.614 +
   3.615 +instance
   3.616 +using liftemb_sprod_def liftprj_sprod_def liftdefl_sprod_def
   3.617 +proof (rule liftdomain_class_intro)
   3.618 +  show "ep_pair emb (prj :: udom \<rightarrow> 'a \<otimes> 'b)"
   3.619 +    unfolding emb_sprod_def prj_sprod_def
   3.620 +    using ep_pair_udom [OF sprod_approx]
   3.621 +    by (intro ep_pair_comp ep_pair_sprod_map ep_pair_emb_prj)
   3.622 +next
   3.623 +  show "cast\<cdot>DEFL('a \<otimes> 'b) = emb oo (prj :: udom \<rightarrow> 'a \<otimes> 'b)"
   3.624 +    unfolding emb_sprod_def prj_sprod_def defl_sprod_def cast_sprod_defl
   3.625 +    by (simp add: cast_DEFL oo_def cfun_eq_iff sprod_map_map)
   3.626 +qed
   3.627 +
   3.628 +end
   3.629 +
   3.630 +lemma DEFL_sprod:
   3.631 +  "DEFL('a::domain \<otimes> 'b::domain) = sprod_defl\<cdot>DEFL('a)\<cdot>DEFL('b)"
   3.632 +by (rule defl_sprod_def)
   3.633 +
   3.634 +subsubsection {* Discrete cpo *}
   3.635 +
   3.636 +definition discr_approx :: "nat \<Rightarrow> 'a::countable discr u \<rightarrow> 'a discr u"
   3.637 +  where "discr_approx = (\<lambda>i. \<Lambda>(up\<cdot>x). if to_nat (undiscr x) < i then up\<cdot>x else \<bottom>)"
   3.638 +
   3.639 +lemma chain_discr_approx [simp]: "chain discr_approx"
   3.640 +unfolding discr_approx_def
   3.641 +by (rule chainI, simp add: monofun_cfun monofun_LAM)
   3.642 +
   3.643 +lemma lub_discr_approx [simp]: "(\<Squnion>i. discr_approx i) = ID"
   3.644 +apply (rule cfun_eqI)
   3.645 +apply (simp add: contlub_cfun_fun)
   3.646 +apply (simp add: discr_approx_def)
   3.647 +apply (case_tac x, simp)
   3.648 +apply (rule lub_eqI)
   3.649 +apply (rule is_lubI)
   3.650 +apply (rule ub_rangeI, simp)
   3.651 +apply (drule ub_rangeD)
   3.652 +apply (erule rev_below_trans)
   3.653 +apply simp
   3.654 +apply (rule lessI)
   3.655 +done
   3.656 +
   3.657 +lemma inj_on_undiscr [simp]: "inj_on undiscr A"
   3.658 +using Discr_undiscr by (rule inj_on_inverseI)
   3.659 +
   3.660 +lemma finite_deflation_discr_approx: "finite_deflation (discr_approx i)"
   3.661 +proof
   3.662 +  fix x :: "'a discr u"
   3.663 +  show "discr_approx i\<cdot>x \<sqsubseteq> x"
   3.664 +    unfolding discr_approx_def
   3.665 +    by (cases x, simp, simp)
   3.666 +  show "discr_approx i\<cdot>(discr_approx i\<cdot>x) = discr_approx i\<cdot>x"
   3.667 +    unfolding discr_approx_def
   3.668 +    by (cases x, simp, simp)
   3.669 +  show "finite {x::'a discr u. discr_approx i\<cdot>x = x}"
   3.670 +  proof (rule finite_subset)
   3.671 +    let ?S = "insert (\<bottom>::'a discr u) ((\<lambda>x. up\<cdot>x) ` undiscr -` to_nat -` {..<i})"
   3.672 +    show "{x::'a discr u. discr_approx i\<cdot>x = x} \<subseteq> ?S"
   3.673 +      unfolding discr_approx_def
   3.674 +      by (rule subsetI, case_tac x, simp, simp split: split_if_asm)
   3.675 +    show "finite ?S"
   3.676 +      by (simp add: finite_vimageI)
   3.677 +  qed
   3.678 +qed
   3.679 +
   3.680 +lemma discr_approx: "approx_chain discr_approx"
   3.681 +using chain_discr_approx lub_discr_approx finite_deflation_discr_approx
   3.682 +by (rule approx_chain.intro)
   3.683 +
   3.684 +instantiation discr :: (countable) predomain
   3.685 +begin
   3.686 +
   3.687 +definition
   3.688 +  "liftemb = udom_emb discr_approx"
   3.689 +
   3.690 +definition
   3.691 +  "liftprj = udom_prj discr_approx"
   3.692 +
   3.693 +definition
   3.694 +  "liftdefl (t::'a discr itself) =
   3.695 +    (\<Squnion>i. defl_principal (Abs_fin_defl (liftemb oo discr_approx i oo liftprj)))"
   3.696 +
   3.697 +instance proof
   3.698 +  show "ep_pair liftemb (liftprj :: udom \<rightarrow> 'a discr u)"
   3.699 +    unfolding liftemb_discr_def liftprj_discr_def
   3.700 +    by (rule ep_pair_udom [OF discr_approx])
   3.701 +  show "cast\<cdot>LIFTDEFL('a discr) = liftemb oo (liftprj :: udom \<rightarrow> 'a discr u)"
   3.702 +    unfolding liftemb_discr_def liftprj_discr_def liftdefl_discr_def
   3.703 +    apply (subst contlub_cfun_arg)
   3.704 +    apply (rule chainI)
   3.705 +    apply (rule defl.principal_mono)
   3.706 +    apply (simp add: below_fin_defl_def)
   3.707 +    apply (simp add: Abs_fin_defl_inverse
   3.708 +        ep_pair.finite_deflation_e_d_p [OF ep_pair_udom [OF discr_approx]]
   3.709 +        approx_chain.finite_deflation_approx [OF discr_approx])
   3.710 +    apply (intro monofun_cfun below_refl)
   3.711 +    apply (rule chainE)
   3.712 +    apply (rule chain_discr_approx)
   3.713 +    apply (subst cast_defl_principal)
   3.714 +    apply (simp add: Abs_fin_defl_inverse
   3.715 +        ep_pair.finite_deflation_e_d_p [OF ep_pair_udom [OF discr_approx]]
   3.716 +        approx_chain.finite_deflation_approx [OF discr_approx])
   3.717 +    apply (simp add: lub_distribs)
   3.718 +    done
   3.719 +qed
   3.720 +
   3.721 +end
   3.722 +
   3.723 +subsubsection {* Strict sum *}
   3.724 +
   3.725 +instantiation ssum :: ("domain", "domain") liftdomain
   3.726 +begin
   3.727 +
   3.728 +definition
   3.729 +  "emb = udom_emb ssum_approx oo ssum_map\<cdot>emb\<cdot>emb"
   3.730 +
   3.731 +definition
   3.732 +  "prj = ssum_map\<cdot>prj\<cdot>prj oo udom_prj ssum_approx"
   3.733 +
   3.734 +definition
   3.735 +  "defl (t::('a \<oplus> 'b) itself) = ssum_defl\<cdot>DEFL('a)\<cdot>DEFL('b)"
   3.736 +
   3.737 +definition
   3.738 +  "(liftemb :: ('a \<oplus> 'b) u \<rightarrow> udom) = udom_emb u_approx oo u_map\<cdot>emb"
   3.739 +
   3.740 +definition
   3.741 +  "(liftprj :: udom \<rightarrow> ('a \<oplus> 'b) u) = u_map\<cdot>prj oo udom_prj u_approx"
   3.742 +
   3.743 +definition
   3.744 +  "liftdefl (t::('a \<oplus> 'b) itself) = u_defl\<cdot>DEFL('a \<oplus> 'b)"
   3.745 +
   3.746 +instance
   3.747 +using liftemb_ssum_def liftprj_ssum_def liftdefl_ssum_def
   3.748 +proof (rule liftdomain_class_intro)
   3.749 +  show "ep_pair emb (prj :: udom \<rightarrow> 'a \<oplus> 'b)"
   3.750 +    unfolding emb_ssum_def prj_ssum_def
   3.751 +    using ep_pair_udom [OF ssum_approx]
   3.752 +    by (intro ep_pair_comp ep_pair_ssum_map ep_pair_emb_prj)
   3.753 +  show "cast\<cdot>DEFL('a \<oplus> 'b) = emb oo (prj :: udom \<rightarrow> 'a \<oplus> 'b)"
   3.754 +    unfolding emb_ssum_def prj_ssum_def defl_ssum_def cast_ssum_defl
   3.755 +    by (simp add: cast_DEFL oo_def cfun_eq_iff ssum_map_map)
   3.756 +qed
   3.757 +
   3.758 +end
   3.759 +
   3.760 +lemma DEFL_ssum:
   3.761 +  "DEFL('a::domain \<oplus> 'b::domain) = ssum_defl\<cdot>DEFL('a)\<cdot>DEFL('b)"
   3.762 +by (rule defl_ssum_def)
   3.763 +
   3.764 +subsubsection {* Lifted HOL type *}
   3.765 +
   3.766 +instantiation lift :: (countable) liftdomain
   3.767 +begin
   3.768 +
   3.769 +definition
   3.770 +  "emb = emb oo (\<Lambda> x. Rep_lift x)"
   3.771 +
   3.772 +definition
   3.773 +  "prj = (\<Lambda> y. Abs_lift y) oo prj"
   3.774 +
   3.775 +definition
   3.776 +  "defl (t::'a lift itself) = DEFL('a discr u)"
   3.777 +
   3.778 +definition
   3.779 +  "(liftemb :: 'a lift u \<rightarrow> udom) = udom_emb u_approx oo u_map\<cdot>emb"
   3.780 +
   3.781 +definition
   3.782 +  "(liftprj :: udom \<rightarrow> 'a lift u) = u_map\<cdot>prj oo udom_prj u_approx"
   3.783 +
   3.784 +definition
   3.785 +  "liftdefl (t::'a lift itself) = u_defl\<cdot>DEFL('a lift)"
   3.786 +
   3.787 +instance
   3.788 +using liftemb_lift_def liftprj_lift_def liftdefl_lift_def
   3.789 +proof (rule liftdomain_class_intro)
   3.790 +  note [simp] = cont_Rep_lift cont_Abs_lift Rep_lift_inverse Abs_lift_inverse
   3.791 +  have "ep_pair (\<Lambda>(x::'a lift). Rep_lift x) (\<Lambda> y. Abs_lift y)"
   3.792 +    by (simp add: ep_pair_def)
   3.793 +  thus "ep_pair emb (prj :: udom \<rightarrow> 'a lift)"
   3.794 +    unfolding emb_lift_def prj_lift_def
   3.795 +    using ep_pair_emb_prj by (rule ep_pair_comp)
   3.796 +  show "cast\<cdot>DEFL('a lift) = emb oo (prj :: udom \<rightarrow> 'a lift)"
   3.797 +    unfolding emb_lift_def prj_lift_def defl_lift_def cast_DEFL
   3.798 +    by (simp add: cfcomp1)
   3.799 +qed
   3.800 +
   3.801 +end
   3.802 +
   3.803 +end
     4.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     4.2 +++ b/src/HOL/HOLCF/Cfun.thy	Sat Nov 27 16:08:10 2010 -0800
     4.3 @@ -0,0 +1,543 @@
     4.4 +(*  Title:      HOLCF/Cfun.thy
     4.5 +    Author:     Franz Regensburger
     4.6 +    Author:     Brian Huffman
     4.7 +*)
     4.8 +
     4.9 +header {* The type of continuous functions *}
    4.10 +
    4.11 +theory Cfun
    4.12 +imports Cpodef Fun_Cpo Product_Cpo
    4.13 +begin
    4.14 +
    4.15 +default_sort cpo
    4.16 +
    4.17 +subsection {* Definition of continuous function type *}
    4.18 +
    4.19 +cpodef ('a, 'b) cfun (infixr "->" 0) = "{f::'a => 'b. cont f}"
    4.20 +by (auto intro: cont_const adm_cont)
    4.21 +
    4.22 +type_notation (xsymbols)
    4.23 +  cfun  ("(_ \<rightarrow>/ _)" [1, 0] 0)
    4.24 +
    4.25 +notation
    4.26 +  Rep_cfun  ("(_$/_)" [999,1000] 999)
    4.27 +
    4.28 +notation (xsymbols)
    4.29 +  Rep_cfun  ("(_\<cdot>/_)" [999,1000] 999)
    4.30 +
    4.31 +notation (HTML output)
    4.32 +  Rep_cfun  ("(_\<cdot>/_)" [999,1000] 999)
    4.33 +
    4.34 +subsection {* Syntax for continuous lambda abstraction *}
    4.35 +
    4.36 +syntax "_cabs" :: "'a"
    4.37 +
    4.38 +parse_translation {*
    4.39 +(* rewrite (_cabs x t) => (Abs_cfun (%x. t)) *)
    4.40 +  [mk_binder_tr (@{syntax_const "_cabs"}, @{const_syntax Abs_cfun})];
    4.41 +*}
    4.42 +
    4.43 +text {* To avoid eta-contraction of body: *}
    4.44 +typed_print_translation {*
    4.45 +  let
    4.46 +    fun cabs_tr' _ _ [Abs abs] = let
    4.47 +          val (x,t) = atomic_abs_tr' abs
    4.48 +        in Syntax.const @{syntax_const "_cabs"} $ x $ t end
    4.49 +
    4.50 +      | cabs_tr' _ T [t] = let
    4.51 +          val xT = domain_type (domain_type T);
    4.52 +          val abs' = ("x",xT,(incr_boundvars 1 t)$Bound 0);
    4.53 +          val (x,t') = atomic_abs_tr' abs';
    4.54 +        in Syntax.const @{syntax_const "_cabs"} $ x $ t' end;
    4.55 +
    4.56 +  in [(@{const_syntax Abs_cfun}, cabs_tr')] end;
    4.57 +*}
    4.58 +
    4.59 +text {* Syntax for nested abstractions *}
    4.60 +
    4.61 +syntax
    4.62 +  "_Lambda" :: "[cargs, 'a] \<Rightarrow> logic"  ("(3LAM _./ _)" [1000, 10] 10)
    4.63 +
    4.64 +syntax (xsymbols)
    4.65 +  "_Lambda" :: "[cargs, 'a] \<Rightarrow> logic" ("(3\<Lambda> _./ _)" [1000, 10] 10)
    4.66 +
    4.67 +parse_ast_translation {*
    4.68 +(* rewrite (LAM x y z. t) => (_cabs x (_cabs y (_cabs z t))) *)
    4.69 +(* cf. Syntax.lambda_ast_tr from src/Pure/Syntax/syn_trans.ML *)
    4.70 +  let
    4.71 +    fun Lambda_ast_tr [pats, body] =
    4.72 +          Syntax.fold_ast_p @{syntax_const "_cabs"}
    4.73 +            (Syntax.unfold_ast @{syntax_const "_cargs"} pats, body)
    4.74 +      | Lambda_ast_tr asts = raise Syntax.AST ("Lambda_ast_tr", asts);
    4.75 +  in [(@{syntax_const "_Lambda"}, Lambda_ast_tr)] end;
    4.76 +*}
    4.77 +
    4.78 +print_ast_translation {*
    4.79 +(* rewrite (_cabs x (_cabs y (_cabs z t))) => (LAM x y z. t) *)
    4.80 +(* cf. Syntax.abs_ast_tr' from src/Pure/Syntax/syn_trans.ML *)
    4.81 +  let
    4.82 +    fun cabs_ast_tr' asts =
    4.83 +      (case Syntax.unfold_ast_p @{syntax_const "_cabs"}
    4.84 +          (Syntax.Appl (Syntax.Constant @{syntax_const "_cabs"} :: asts)) of
    4.85 +        ([], _) => raise Syntax.AST ("cabs_ast_tr'", asts)
    4.86 +      | (xs, body) => Syntax.Appl
    4.87 +          [Syntax.Constant @{syntax_const "_Lambda"},
    4.88 +           Syntax.fold_ast @{syntax_const "_cargs"} xs, body]);
    4.89 +  in [(@{syntax_const "_cabs"}, cabs_ast_tr')] end
    4.90 +*}
    4.91 +
    4.92 +text {* Dummy patterns for continuous abstraction *}
    4.93 +translations
    4.94 +  "\<Lambda> _. t" => "CONST Abs_cfun (\<lambda> _. t)"
    4.95 +
    4.96 +subsection {* Continuous function space is pointed *}
    4.97 +
    4.98 +lemma UU_cfun: "\<bottom> \<in> cfun"
    4.99 +by (simp add: cfun_def inst_fun_pcpo)
   4.100 +
   4.101 +instance cfun :: (cpo, discrete_cpo) discrete_cpo
   4.102 +by intro_classes (simp add: below_cfun_def Rep_cfun_inject)
   4.103 +
   4.104 +instance cfun :: (cpo, pcpo) pcpo
   4.105 +by (rule typedef_pcpo [OF type_definition_cfun below_cfun_def UU_cfun])
   4.106 +
   4.107 +lemmas Rep_cfun_strict =
   4.108 +  typedef_Rep_strict [OF type_definition_cfun below_cfun_def UU_cfun]
   4.109 +
   4.110 +lemmas Abs_cfun_strict =
   4.111 +  typedef_Abs_strict [OF type_definition_cfun below_cfun_def UU_cfun]
   4.112 +
   4.113 +text {* function application is strict in its first argument *}
   4.114 +
   4.115 +lemma Rep_cfun_strict1 [simp]: "\<bottom>\<cdot>x = \<bottom>"
   4.116 +by (simp add: Rep_cfun_strict)
   4.117 +
   4.118 +lemma LAM_strict [simp]: "(\<Lambda> x. \<bottom>) = \<bottom>"
   4.119 +by (simp add: inst_fun_pcpo [symmetric] Abs_cfun_strict)
   4.120 +
   4.121 +text {* for compatibility with old HOLCF-Version *}
   4.122 +lemma inst_cfun_pcpo: "\<bottom> = (\<Lambda> x. \<bottom>)"
   4.123 +by simp
   4.124 +
   4.125 +subsection {* Basic properties of continuous functions *}
   4.126 +
   4.127 +text {* Beta-equality for continuous functions *}
   4.128 +
   4.129 +lemma Abs_cfun_inverse2: "cont f \<Longrightarrow> Rep_cfun (Abs_cfun f) = f"
   4.130 +by (simp add: Abs_cfun_inverse cfun_def)
   4.131 +
   4.132 +lemma beta_cfun: "cont f \<Longrightarrow> (\<Lambda> x. f x)\<cdot>u = f u"
   4.133 +by (simp add: Abs_cfun_inverse2)
   4.134 +
   4.135 +text {* Beta-reduction simproc *}
   4.136 +
   4.137 +text {*
   4.138 +  Given the term @{term "(\<Lambda> x. f x)\<cdot>y"}, the procedure tries to
   4.139 +  construct the theorem @{term "(\<Lambda> x. f x)\<cdot>y == f y"}.  If this
   4.140 +  theorem cannot be completely solved by the cont2cont rules, then
   4.141 +  the procedure returns the ordinary conditional @{text beta_cfun}
   4.142 +  rule.
   4.143 +
   4.144 +  The simproc does not solve any more goals that would be solved by
   4.145 +  using @{text beta_cfun} as a simp rule.  The advantage of the
   4.146 +  simproc is that it can avoid deeply-nested calls to the simplifier
   4.147 +  that would otherwise be caused by large continuity side conditions.
   4.148 +*}
   4.149 +
   4.150 +simproc_setup beta_cfun_proc ("Abs_cfun f\<cdot>x") = {*
   4.151 +  fn phi => fn ss => fn ct =>
   4.152 +    let
   4.153 +      val dest = Thm.dest_comb;
   4.154 +      val (f, x) = (apfst (snd o dest o snd o dest) o dest) ct;
   4.155 +      val [T, U] = Thm.dest_ctyp (ctyp_of_term f);
   4.156 +      val tr = instantiate' [SOME T, SOME U] [SOME f, SOME x]
   4.157 +          (mk_meta_eq @{thm beta_cfun});
   4.158 +      val rules = Cont2ContData.get (Simplifier.the_context ss);
   4.159 +      val tac = SOLVED' (REPEAT_ALL_NEW (match_tac rules));
   4.160 +    in SOME (perhaps (SINGLE (tac 1)) tr) end
   4.161 +*}
   4.162 +
   4.163 +text {* Eta-equality for continuous functions *}
   4.164 +
   4.165 +lemma eta_cfun: "(\<Lambda> x. f\<cdot>x) = f"
   4.166 +by (rule Rep_cfun_inverse)
   4.167 +
   4.168 +text {* Extensionality for continuous functions *}
   4.169 +
   4.170 +lemma cfun_eq_iff: "f = g \<longleftrightarrow> (\<forall>x. f\<cdot>x = g\<cdot>x)"
   4.171 +by (simp add: Rep_cfun_inject [symmetric] fun_eq_iff)
   4.172 +
   4.173 +lemma cfun_eqI: "(\<And>x. f\<cdot>x = g\<cdot>x) \<Longrightarrow> f = g"
   4.174 +by (simp add: cfun_eq_iff)
   4.175 +
   4.176 +text {* Extensionality wrt. ordering for continuous functions *}
   4.177 +
   4.178 +lemma cfun_below_iff: "f \<sqsubseteq> g \<longleftrightarrow> (\<forall>x. f\<cdot>x \<sqsubseteq> g\<cdot>x)" 
   4.179 +by (simp add: below_cfun_def fun_below_iff)
   4.180 +
   4.181 +lemma cfun_belowI: "(\<And>x. f\<cdot>x \<sqsubseteq> g\<cdot>x) \<Longrightarrow> f \<sqsubseteq> g"
   4.182 +by (simp add: cfun_below_iff)
   4.183 +
   4.184 +text {* Congruence for continuous function application *}
   4.185 +
   4.186 +lemma cfun_cong: "\<lbrakk>f = g; x = y\<rbrakk> \<Longrightarrow> f\<cdot>x = g\<cdot>y"
   4.187 +by simp
   4.188 +
   4.189 +lemma cfun_fun_cong: "f = g \<Longrightarrow> f\<cdot>x = g\<cdot>x"
   4.190 +by simp
   4.191 +
   4.192 +lemma cfun_arg_cong: "x = y \<Longrightarrow> f\<cdot>x = f\<cdot>y"
   4.193 +by simp
   4.194 +
   4.195 +subsection {* Continuity of application *}
   4.196 +
   4.197 +lemma cont_Rep_cfun1: "cont (\<lambda>f. f\<cdot>x)"
   4.198 +by (rule cont_Rep_cfun [THEN cont2cont_fun])
   4.199 +
   4.200 +lemma cont_Rep_cfun2: "cont (\<lambda>x. f\<cdot>x)"
   4.201 +apply (cut_tac x=f in Rep_cfun)
   4.202 +apply (simp add: cfun_def)
   4.203 +done
   4.204 +
   4.205 +lemmas monofun_Rep_cfun = cont_Rep_cfun [THEN cont2mono]
   4.206 +
   4.207 +lemmas monofun_Rep_cfun1 = cont_Rep_cfun1 [THEN cont2mono, standard]
   4.208 +lemmas monofun_Rep_cfun2 = cont_Rep_cfun2 [THEN cont2mono, standard]
   4.209 +
   4.210 +text {* contlub, cont properties of @{term Rep_cfun} in each argument *}
   4.211 +
   4.212 +lemma contlub_cfun_arg: "chain Y \<Longrightarrow> f\<cdot>(\<Squnion>i. Y i) = (\<Squnion>i. f\<cdot>(Y i))"
   4.213 +by (rule cont_Rep_cfun2 [THEN cont2contlubE])
   4.214 +
   4.215 +lemma contlub_cfun_fun: "chain F \<Longrightarrow> (\<Squnion>i. F i)\<cdot>x = (\<Squnion>i. F i\<cdot>x)"
   4.216 +by (rule cont_Rep_cfun1 [THEN cont2contlubE])
   4.217 +
   4.218 +text {* monotonicity of application *}
   4.219 +
   4.220 +lemma monofun_cfun_fun: "f \<sqsubseteq> g \<Longrightarrow> f\<cdot>x \<sqsubseteq> g\<cdot>x"
   4.221 +by (simp add: cfun_below_iff)
   4.222 +
   4.223 +lemma monofun_cfun_arg: "x \<sqsubseteq> y \<Longrightarrow> f\<cdot>x \<sqsubseteq> f\<cdot>y"
   4.224 +by (rule monofun_Rep_cfun2 [THEN monofunE])
   4.225 +
   4.226 +lemma monofun_cfun: "\<lbrakk>f \<sqsubseteq> g; x \<sqsubseteq> y\<rbrakk> \<Longrightarrow> f\<cdot>x \<sqsubseteq> g\<cdot>y"
   4.227 +by (rule below_trans [OF monofun_cfun_fun monofun_cfun_arg])
   4.228 +
   4.229 +text {* ch2ch - rules for the type @{typ "'a -> 'b"} *}
   4.230 +
   4.231 +lemma chain_monofun: "chain Y \<Longrightarrow> chain (\<lambda>i. f\<cdot>(Y i))"
   4.232 +by (erule monofun_Rep_cfun2 [THEN ch2ch_monofun])
   4.233 +
   4.234 +lemma ch2ch_Rep_cfunR: "chain Y \<Longrightarrow> chain (\<lambda>i. f\<cdot>(Y i))"
   4.235 +by (rule monofun_Rep_cfun2 [THEN ch2ch_monofun])
   4.236 +
   4.237 +lemma ch2ch_Rep_cfunL: "chain F \<Longrightarrow> chain (\<lambda>i. (F i)\<cdot>x)"
   4.238 +by (rule monofun_Rep_cfun1 [THEN ch2ch_monofun])
   4.239 +
   4.240 +lemma ch2ch_Rep_cfun [simp]:
   4.241 +  "\<lbrakk>chain F; chain Y\<rbrakk> \<Longrightarrow> chain (\<lambda>i. (F i)\<cdot>(Y i))"
   4.242 +by (simp add: chain_def monofun_cfun)
   4.243 +
   4.244 +lemma ch2ch_LAM [simp]:
   4.245 +  "\<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)"
   4.246 +by (simp add: chain_def cfun_below_iff)
   4.247 +
   4.248 +text {* contlub, cont properties of @{term Rep_cfun} in both arguments *}
   4.249 +
   4.250 +lemma contlub_cfun: 
   4.251 +  "\<lbrakk>chain F; chain Y\<rbrakk> \<Longrightarrow> (\<Squnion>i. F i)\<cdot>(\<Squnion>i. Y i) = (\<Squnion>i. F i\<cdot>(Y i))"
   4.252 +by (simp add: contlub_cfun_fun contlub_cfun_arg diag_lub)
   4.253 +
   4.254 +lemma cont_cfun: 
   4.255 +  "\<lbrakk>chain F; chain Y\<rbrakk> \<Longrightarrow> range (\<lambda>i. F i\<cdot>(Y i)) <<| (\<Squnion>i. F i)\<cdot>(\<Squnion>i. Y i)"
   4.256 +apply (rule thelubE)
   4.257 +apply (simp only: ch2ch_Rep_cfun)
   4.258 +apply (simp only: contlub_cfun)
   4.259 +done
   4.260 +
   4.261 +lemma contlub_LAM:
   4.262 +  "\<lbrakk>\<And>x. chain (\<lambda>i. F i x); \<And>i. cont (\<lambda>x. F i x)\<rbrakk>
   4.263 +    \<Longrightarrow> (\<Lambda> x. \<Squnion>i. F i x) = (\<Squnion>i. \<Lambda> x. F i x)"
   4.264 +apply (simp add: lub_cfun)
   4.265 +apply (simp add: Abs_cfun_inverse2)
   4.266 +apply (simp add: thelub_fun ch2ch_lambda)
   4.267 +done
   4.268 +
   4.269 +lemmas lub_distribs = 
   4.270 +  contlub_cfun [symmetric]
   4.271 +  contlub_LAM [symmetric]
   4.272 +
   4.273 +text {* strictness *}
   4.274 +
   4.275 +lemma strictI: "f\<cdot>x = \<bottom> \<Longrightarrow> f\<cdot>\<bottom> = \<bottom>"
   4.276 +apply (rule UU_I)
   4.277 +apply (erule subst)
   4.278 +apply (rule minimal [THEN monofun_cfun_arg])
   4.279 +done
   4.280 +
   4.281 +text {* type @{typ "'a -> 'b"} is chain complete *}
   4.282 +
   4.283 +lemma lub_cfun: "chain F \<Longrightarrow> range F <<| (\<Lambda> x. \<Squnion>i. F i\<cdot>x)"
   4.284 +by (simp only: contlub_cfun_fun [symmetric] eta_cfun thelubE)
   4.285 +
   4.286 +lemma thelub_cfun: "chain F \<Longrightarrow> (\<Squnion>i. F i) = (\<Lambda> x. \<Squnion>i. F i\<cdot>x)"
   4.287 +by (rule lub_cfun [THEN lub_eqI])
   4.288 +
   4.289 +subsection {* Continuity simplification procedure *}
   4.290 +
   4.291 +text {* cont2cont lemma for @{term Rep_cfun} *}
   4.292 +
   4.293 +lemma cont2cont_APP [simp, cont2cont]:
   4.294 +  assumes f: "cont (\<lambda>x. f x)"
   4.295 +  assumes t: "cont (\<lambda>x. t x)"
   4.296 +  shows "cont (\<lambda>x. (f x)\<cdot>(t x))"
   4.297 +proof -
   4.298 +  have 1: "\<And>y. cont (\<lambda>x. (f x)\<cdot>y)"
   4.299 +    using cont_Rep_cfun1 f by (rule cont_compose)
   4.300 +  show "cont (\<lambda>x. (f x)\<cdot>(t x))"
   4.301 +    using t cont_Rep_cfun2 1 by (rule cont_apply)
   4.302 +qed
   4.303 +
   4.304 +text {*
   4.305 +  Two specific lemmas for the combination of LCF and HOL terms.
   4.306 +  These lemmas are needed in theories that use types like @{typ "'a \<rightarrow> 'b \<Rightarrow> 'c"}.
   4.307 +*}
   4.308 +
   4.309 +lemma cont_APP_app [simp]: "\<lbrakk>cont f; cont g\<rbrakk> \<Longrightarrow> cont (\<lambda>x. ((f x)\<cdot>(g x)) s)"
   4.310 +by (rule cont2cont_APP [THEN cont2cont_fun])
   4.311 +
   4.312 +lemma cont_APP_app_app [simp]: "\<lbrakk>cont f; cont g\<rbrakk> \<Longrightarrow> cont (\<lambda>x. ((f x)\<cdot>(g x)) s t)"
   4.313 +by (rule cont_APP_app [THEN cont2cont_fun])
   4.314 +
   4.315 +
   4.316 +text {* cont2mono Lemma for @{term "%x. LAM y. c1(x)(y)"} *}
   4.317 +
   4.318 +lemma cont2mono_LAM:
   4.319 +  "\<lbrakk>\<And>x. cont (\<lambda>y. f x y); \<And>y. monofun (\<lambda>x. f x y)\<rbrakk>
   4.320 +    \<Longrightarrow> monofun (\<lambda>x. \<Lambda> y. f x y)"
   4.321 +  unfolding monofun_def cfun_below_iff by simp
   4.322 +
   4.323 +text {* cont2cont Lemma for @{term "%x. LAM y. f x y"} *}
   4.324 +
   4.325 +text {*
   4.326 +  Not suitable as a cont2cont rule, because on nested lambdas
   4.327 +  it causes exponential blow-up in the number of subgoals.
   4.328 +*}
   4.329 +
   4.330 +lemma cont2cont_LAM:
   4.331 +  assumes f1: "\<And>x. cont (\<lambda>y. f x y)"
   4.332 +  assumes f2: "\<And>y. cont (\<lambda>x. f x y)"
   4.333 +  shows "cont (\<lambda>x. \<Lambda> y. f x y)"
   4.334 +proof (rule cont_Abs_cfun)
   4.335 +  fix x
   4.336 +  from f1 show "f x \<in> cfun" by (simp add: cfun_def)
   4.337 +  from f2 show "cont f" by (rule cont2cont_lambda)
   4.338 +qed
   4.339 +
   4.340 +text {*
   4.341 +  This version does work as a cont2cont rule, since it
   4.342 +  has only a single subgoal.
   4.343 +*}
   4.344 +
   4.345 +lemma cont2cont_LAM' [simp, cont2cont]:
   4.346 +  fixes f :: "'a::cpo \<Rightarrow> 'b::cpo \<Rightarrow> 'c::cpo"
   4.347 +  assumes f: "cont (\<lambda>p. f (fst p) (snd p))"
   4.348 +  shows "cont (\<lambda>x. \<Lambda> y. f x y)"
   4.349 +using assms by (simp add: cont2cont_LAM prod_cont_iff)
   4.350 +
   4.351 +lemma cont2cont_LAM_discrete [simp, cont2cont]:
   4.352 +  "(\<And>y::'a::discrete_cpo. cont (\<lambda>x. f x y)) \<Longrightarrow> cont (\<lambda>x. \<Lambda> y. f x y)"
   4.353 +by (simp add: cont2cont_LAM)
   4.354 +
   4.355 +subsection {* Miscellaneous *}
   4.356 +
   4.357 +text {* Monotonicity of @{term Abs_cfun} *}
   4.358 +
   4.359 +lemma monofun_LAM:
   4.360 +  "\<lbrakk>cont f; cont g; \<And>x. f x \<sqsubseteq> g x\<rbrakk> \<Longrightarrow> (\<Lambda> x. f x) \<sqsubseteq> (\<Lambda> x. g x)"
   4.361 +by (simp add: cfun_below_iff)
   4.362 +
   4.363 +text {* some lemmata for functions with flat/chfin domain/range types *}
   4.364 +
   4.365 +lemma chfin_Rep_cfunR: "chain (Y::nat => 'a::cpo->'b::chfin)  
   4.366 +      ==> !s. ? n. (LUB i. Y i)$s = Y n$s"
   4.367 +apply (rule allI)
   4.368 +apply (subst contlub_cfun_fun)
   4.369 +apply assumption
   4.370 +apply (fast intro!: lub_eqI chfin lub_finch2 chfin2finch ch2ch_Rep_cfunL)
   4.371 +done
   4.372 +
   4.373 +lemma adm_chfindom: "adm (\<lambda>(u::'a::cpo \<rightarrow> 'b::chfin). P(u\<cdot>s))"
   4.374 +by (rule adm_subst, simp, rule adm_chfin)
   4.375 +
   4.376 +subsection {* Continuous injection-retraction pairs *}
   4.377 +
   4.378 +text {* Continuous retractions are strict. *}
   4.379 +
   4.380 +lemma retraction_strict:
   4.381 +  "\<forall>x. f\<cdot>(g\<cdot>x) = x \<Longrightarrow> f\<cdot>\<bottom> = \<bottom>"
   4.382 +apply (rule UU_I)
   4.383 +apply (drule_tac x="\<bottom>" in spec)
   4.384 +apply (erule subst)
   4.385 +apply (rule monofun_cfun_arg)
   4.386 +apply (rule minimal)
   4.387 +done
   4.388 +
   4.389 +lemma injection_eq:
   4.390 +  "\<forall>x. f\<cdot>(g\<cdot>x) = x \<Longrightarrow> (g\<cdot>x = g\<cdot>y) = (x = y)"
   4.391 +apply (rule iffI)
   4.392 +apply (drule_tac f=f in cfun_arg_cong)
   4.393 +apply simp
   4.394 +apply simp
   4.395 +done
   4.396 +
   4.397 +lemma injection_below:
   4.398 +  "\<forall>x. f\<cdot>(g\<cdot>x) = x \<Longrightarrow> (g\<cdot>x \<sqsubseteq> g\<cdot>y) = (x \<sqsubseteq> y)"
   4.399 +apply (rule iffI)
   4.400 +apply (drule_tac f=f in monofun_cfun_arg)
   4.401 +apply simp
   4.402 +apply (erule monofun_cfun_arg)
   4.403 +done
   4.404 +
   4.405 +lemma injection_defined_rev:
   4.406 +  "\<lbrakk>\<forall>x. f\<cdot>(g\<cdot>x) = x; g\<cdot>z = \<bottom>\<rbrakk> \<Longrightarrow> z = \<bottom>"
   4.407 +apply (drule_tac f=f in cfun_arg_cong)
   4.408 +apply (simp add: retraction_strict)
   4.409 +done
   4.410 +
   4.411 +lemma injection_defined:
   4.412 +  "\<lbrakk>\<forall>x. f\<cdot>(g\<cdot>x) = x; z \<noteq> \<bottom>\<rbrakk> \<Longrightarrow> g\<cdot>z \<noteq> \<bottom>"
   4.413 +by (erule contrapos_nn, rule injection_defined_rev)
   4.414 +
   4.415 +text {* a result about functions with flat codomain *}
   4.416 +
   4.417 +lemma flat_eqI: "\<lbrakk>(x::'a::flat) \<sqsubseteq> y; x \<noteq> \<bottom>\<rbrakk> \<Longrightarrow> x = y"
   4.418 +by (drule ax_flat, simp)
   4.419 +
   4.420 +lemma flat_codom:
   4.421 +  "f\<cdot>x = (c::'b::flat) \<Longrightarrow> f\<cdot>\<bottom> = \<bottom> \<or> (\<forall>z. f\<cdot>z = c)"
   4.422 +apply (case_tac "f\<cdot>x = \<bottom>")
   4.423 +apply (rule disjI1)
   4.424 +apply (rule UU_I)
   4.425 +apply (erule_tac t="\<bottom>" in subst)
   4.426 +apply (rule minimal [THEN monofun_cfun_arg])
   4.427 +apply clarify
   4.428 +apply (rule_tac a = "f\<cdot>\<bottom>" in refl [THEN box_equals])
   4.429 +apply (erule minimal [THEN monofun_cfun_arg, THEN flat_eqI])
   4.430 +apply (erule minimal [THEN monofun_cfun_arg, THEN flat_eqI])
   4.431 +done
   4.432 +
   4.433 +subsection {* Identity and composition *}
   4.434 +
   4.435 +definition
   4.436 +  ID :: "'a \<rightarrow> 'a" where
   4.437 +  "ID = (\<Lambda> x. x)"
   4.438 +
   4.439 +definition
   4.440 +  cfcomp  :: "('b \<rightarrow> 'c) \<rightarrow> ('a \<rightarrow> 'b) \<rightarrow> 'a \<rightarrow> 'c" where
   4.441 +  oo_def: "cfcomp = (\<Lambda> f g x. f\<cdot>(g\<cdot>x))"
   4.442 +
   4.443 +abbreviation
   4.444 +  cfcomp_syn :: "['b \<rightarrow> 'c, 'a \<rightarrow> 'b] \<Rightarrow> 'a \<rightarrow> 'c"  (infixr "oo" 100)  where
   4.445 +  "f oo g == cfcomp\<cdot>f\<cdot>g"
   4.446 +
   4.447 +lemma ID1 [simp]: "ID\<cdot>x = x"
   4.448 +by (simp add: ID_def)
   4.449 +
   4.450 +lemma cfcomp1: "(f oo g) = (\<Lambda> x. f\<cdot>(g\<cdot>x))"
   4.451 +by (simp add: oo_def)
   4.452 +
   4.453 +lemma cfcomp2 [simp]: "(f oo g)\<cdot>x = f\<cdot>(g\<cdot>x)"
   4.454 +by (simp add: cfcomp1)
   4.455 +
   4.456 +lemma cfcomp_LAM: "cont g \<Longrightarrow> f oo (\<Lambda> x. g x) = (\<Lambda> x. f\<cdot>(g x))"
   4.457 +by (simp add: cfcomp1)
   4.458 +
   4.459 +lemma cfcomp_strict [simp]: "\<bottom> oo f = \<bottom>"
   4.460 +by (simp add: cfun_eq_iff)
   4.461 +
   4.462 +text {*
   4.463 +  Show that interpretation of (pcpo,@{text "_->_"}) is a category.
   4.464 +  The class of objects is interpretation of syntactical class pcpo.
   4.465 +  The class of arrows  between objects @{typ 'a} and @{typ 'b} is interpret. of @{typ "'a -> 'b"}.
   4.466 +  The identity arrow is interpretation of @{term ID}.
   4.467 +  The composition of f and g is interpretation of @{text "oo"}.
   4.468 +*}
   4.469 +
   4.470 +lemma ID2 [simp]: "f oo ID = f"
   4.471 +by (rule cfun_eqI, simp)
   4.472 +
   4.473 +lemma ID3 [simp]: "ID oo f = f"
   4.474 +by (rule cfun_eqI, simp)
   4.475 +
   4.476 +lemma assoc_oo: "f oo (g oo h) = (f oo g) oo h"
   4.477 +by (rule cfun_eqI, simp)
   4.478 +
   4.479 +subsection {* Strictified functions *}
   4.480 +
   4.481 +default_sort pcpo
   4.482 +
   4.483 +definition
   4.484 +  seq :: "'a \<rightarrow> 'b \<rightarrow> 'b" where
   4.485 +  "seq = (\<Lambda> x. if x = \<bottom> then \<bottom> else ID)"
   4.486 +
   4.487 +lemma cont_seq: "cont (\<lambda>x. if x = \<bottom> then \<bottom> else y)"
   4.488 +unfolding cont_def is_lub_def is_ub_def ball_simps
   4.489 +by (simp add: lub_eq_bottom_iff)
   4.490 +
   4.491 +lemma seq_conv_if: "seq\<cdot>x = (if x = \<bottom> then \<bottom> else ID)"
   4.492 +unfolding seq_def by (simp add: cont_seq)
   4.493 +
   4.494 +lemma seq1 [simp]: "seq\<cdot>\<bottom> = \<bottom>"
   4.495 +by (simp add: seq_conv_if)
   4.496 +
   4.497 +lemma seq2 [simp]: "x \<noteq> \<bottom> \<Longrightarrow> seq\<cdot>x = ID"
   4.498 +by (simp add: seq_conv_if)
   4.499 +
   4.500 +lemma seq3 [simp]: "seq\<cdot>x\<cdot>\<bottom> = \<bottom>"
   4.501 +by (simp add: seq_conv_if)
   4.502 +
   4.503 +definition
   4.504 +  strictify  :: "('a \<rightarrow> 'b) \<rightarrow> 'a \<rightarrow> 'b" where
   4.505 +  "strictify = (\<Lambda> f x. seq\<cdot>x\<cdot>(f\<cdot>x))"
   4.506 +
   4.507 +lemma strictify_conv_if: "strictify\<cdot>f\<cdot>x = (if x = \<bottom> then \<bottom> else f\<cdot>x)"
   4.508 +unfolding strictify_def by simp
   4.509 +
   4.510 +lemma strictify1 [simp]: "strictify\<cdot>f\<cdot>\<bottom> = \<bottom>"
   4.511 +by (simp add: strictify_conv_if)
   4.512 +
   4.513 +lemma strictify2 [simp]: "x \<noteq> \<bottom> \<Longrightarrow> strictify\<cdot>f\<cdot>x = f\<cdot>x"
   4.514 +by (simp add: strictify_conv_if)
   4.515 +
   4.516 +subsection {* Continuity of let-bindings *}
   4.517 +
   4.518 +lemma cont2cont_Let:
   4.519 +  assumes f: "cont (\<lambda>x. f x)"
   4.520 +  assumes g1: "\<And>y. cont (\<lambda>x. g x y)"
   4.521 +  assumes g2: "\<And>x. cont (\<lambda>y. g x y)"
   4.522 +  shows "cont (\<lambda>x. let y = f x in g x y)"
   4.523 +unfolding Let_def using f g2 g1 by (rule cont_apply)
   4.524 +
   4.525 +lemma cont2cont_Let' [simp, cont2cont]:
   4.526 +  assumes f: "cont (\<lambda>x. f x)"
   4.527 +  assumes g: "cont (\<lambda>p. g (fst p) (snd p))"
   4.528 +  shows "cont (\<lambda>x. let y = f x in g x y)"
   4.529 +using f
   4.530 +proof (rule cont2cont_Let)
   4.531 +  fix x show "cont (\<lambda>y. g x y)"
   4.532 +    using g by (simp add: prod_cont_iff)
   4.533 +next
   4.534 +  fix y show "cont (\<lambda>x. g x y)"
   4.535 +    using g by (simp add: prod_cont_iff)
   4.536 +qed
   4.537 +
   4.538 +text {* The simple version (suggested by Joachim Breitner) is needed if
   4.539 +  the type of the defined term is not a cpo. *}
   4.540 +
   4.541 +lemma cont2cont_Let_simple [simp, cont2cont]:
   4.542 +  assumes "\<And>y. cont (\<lambda>x. g x y)"
   4.543 +  shows "cont (\<lambda>x. let y = t in g x y)"
   4.544 +unfolding Let_def using assms .
   4.545 +
   4.546 +end
     5.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     5.2 +++ b/src/HOL/HOLCF/CompactBasis.thy	Sat Nov 27 16:08:10 2010 -0800
     5.3 @@ -0,0 +1,111 @@
     5.4 +(*  Title:      HOLCF/CompactBasis.thy
     5.5 +    Author:     Brian Huffman
     5.6 +*)
     5.7 +
     5.8 +header {* A compact basis for powerdomains *}
     5.9 +
    5.10 +theory CompactBasis
    5.11 +imports Bifinite
    5.12 +begin
    5.13 +
    5.14 +default_sort "domain"
    5.15 +
    5.16 +subsection {* A compact basis for powerdomains *}
    5.17 +
    5.18 +typedef 'a pd_basis =
    5.19 +  "{S::'a compact_basis set. finite S \<and> S \<noteq> {}}"
    5.20 +by (rule_tac x="{arbitrary}" in exI, simp)
    5.21 +
    5.22 +lemma finite_Rep_pd_basis [simp]: "finite (Rep_pd_basis u)"
    5.23 +by (insert Rep_pd_basis [of u, unfolded pd_basis_def]) simp
    5.24 +
    5.25 +lemma Rep_pd_basis_nonempty [simp]: "Rep_pd_basis u \<noteq> {}"
    5.26 +by (insert Rep_pd_basis [of u, unfolded pd_basis_def]) simp
    5.27 +
    5.28 +text {* The powerdomain basis type is countable. *}
    5.29 +
    5.30 +lemma pd_basis_countable: "\<exists>f::'a pd_basis \<Rightarrow> nat. inj f"
    5.31 +proof -
    5.32 +  obtain g :: "'a compact_basis \<Rightarrow> nat" where "inj g"
    5.33 +    using compact_basis.countable ..
    5.34 +  hence image_g_eq: "\<And>A B. g ` A = g ` B \<longleftrightarrow> A = B"
    5.35 +    by (rule inj_image_eq_iff)
    5.36 +  have "inj (\<lambda>t. set_encode (g ` Rep_pd_basis t))"
    5.37 +    by (simp add: inj_on_def set_encode_eq image_g_eq Rep_pd_basis_inject)
    5.38 +  thus ?thesis by - (rule exI)
    5.39 +  (* FIXME: why doesn't ".." or "by (rule exI)" work? *)
    5.40 +qed
    5.41 +
    5.42 +subsection {* Unit and plus constructors *}
    5.43 +
    5.44 +definition
    5.45 +  PDUnit :: "'a compact_basis \<Rightarrow> 'a pd_basis" where
    5.46 +  "PDUnit = (\<lambda>x. Abs_pd_basis {x})"
    5.47 +
    5.48 +definition
    5.49 +  PDPlus :: "'a pd_basis \<Rightarrow> 'a pd_basis \<Rightarrow> 'a pd_basis" where
    5.50 +  "PDPlus t u = Abs_pd_basis (Rep_pd_basis t \<union> Rep_pd_basis u)"
    5.51 +
    5.52 +lemma Rep_PDUnit:
    5.53 +  "Rep_pd_basis (PDUnit x) = {x}"
    5.54 +unfolding PDUnit_def by (rule Abs_pd_basis_inverse) (simp add: pd_basis_def)
    5.55 +
    5.56 +lemma Rep_PDPlus:
    5.57 +  "Rep_pd_basis (PDPlus u v) = Rep_pd_basis u \<union> Rep_pd_basis v"
    5.58 +unfolding PDPlus_def by (rule Abs_pd_basis_inverse) (simp add: pd_basis_def)
    5.59 +
    5.60 +lemma PDUnit_inject [simp]: "(PDUnit a = PDUnit b) = (a = b)"
    5.61 +unfolding Rep_pd_basis_inject [symmetric] Rep_PDUnit by simp
    5.62 +
    5.63 +lemma PDPlus_assoc: "PDPlus (PDPlus t u) v = PDPlus t (PDPlus u v)"
    5.64 +unfolding Rep_pd_basis_inject [symmetric] Rep_PDPlus by (rule Un_assoc)
    5.65 +
    5.66 +lemma PDPlus_commute: "PDPlus t u = PDPlus u t"
    5.67 +unfolding Rep_pd_basis_inject [symmetric] Rep_PDPlus by (rule Un_commute)
    5.68 +
    5.69 +lemma PDPlus_absorb: "PDPlus t t = t"
    5.70 +unfolding Rep_pd_basis_inject [symmetric] Rep_PDPlus by (rule Un_absorb)
    5.71 +
    5.72 +lemma pd_basis_induct1:
    5.73 +  assumes PDUnit: "\<And>a. P (PDUnit a)"
    5.74 +  assumes PDPlus: "\<And>a t. P t \<Longrightarrow> P (PDPlus (PDUnit a) t)"
    5.75 +  shows "P x"
    5.76 +apply (induct x, unfold pd_basis_def, clarify)
    5.77 +apply (erule (1) finite_ne_induct)
    5.78 +apply (cut_tac a=x in PDUnit)
    5.79 +apply (simp add: PDUnit_def)
    5.80 +apply (drule_tac a=x in PDPlus)
    5.81 +apply (simp add: PDUnit_def PDPlus_def
    5.82 +  Abs_pd_basis_inverse [unfolded pd_basis_def])
    5.83 +done
    5.84 +
    5.85 +lemma pd_basis_induct:
    5.86 +  assumes PDUnit: "\<And>a. P (PDUnit a)"
    5.87 +  assumes PDPlus: "\<And>t u. \<lbrakk>P t; P u\<rbrakk> \<Longrightarrow> P (PDPlus t u)"
    5.88 +  shows "P x"
    5.89 +apply (induct x rule: pd_basis_induct1)
    5.90 +apply (rule PDUnit, erule PDPlus [OF PDUnit])
    5.91 +done
    5.92 +
    5.93 +subsection {* Fold operator *}
    5.94 +
    5.95 +definition
    5.96 +  fold_pd ::
    5.97 +    "('a compact_basis \<Rightarrow> 'b::type) \<Rightarrow> ('b \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> 'a pd_basis \<Rightarrow> 'b"
    5.98 +  where "fold_pd g f t = fold1 f (g ` Rep_pd_basis t)"
    5.99 +
   5.100 +lemma fold_pd_PDUnit:
   5.101 +  assumes "class.ab_semigroup_idem_mult f"
   5.102 +  shows "fold_pd g f (PDUnit x) = g x"
   5.103 +unfolding fold_pd_def Rep_PDUnit by simp
   5.104 +
   5.105 +lemma fold_pd_PDPlus:
   5.106 +  assumes "class.ab_semigroup_idem_mult f"
   5.107 +  shows "fold_pd g f (PDPlus t u) = f (fold_pd g f t) (fold_pd g f u)"
   5.108 +proof -
   5.109 +  interpret ab_semigroup_idem_mult f by fact
   5.110 +  show ?thesis unfolding fold_pd_def Rep_PDPlus
   5.111 +    by (simp add: image_Un fold1_Un2)
   5.112 +qed
   5.113 +
   5.114 +end
     6.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     6.2 +++ b/src/HOL/HOLCF/Completion.thy	Sat Nov 27 16:08:10 2010 -0800
     6.3 @@ -0,0 +1,433 @@
     6.4 +(*  Title:      HOLCF/Completion.thy
     6.5 +    Author:     Brian Huffman
     6.6 +*)
     6.7 +
     6.8 +header {* Defining algebraic domains by ideal completion *}
     6.9 +
    6.10 +theory Completion
    6.11 +imports Plain_HOLCF
    6.12 +begin
    6.13 +
    6.14 +subsection {* Ideals over a preorder *}
    6.15 +
    6.16 +locale preorder =
    6.17 +  fixes r :: "'a::type \<Rightarrow> 'a \<Rightarrow> bool" (infix "\<preceq>" 50)
    6.18 +  assumes r_refl: "x \<preceq> x"
    6.19 +  assumes r_trans: "\<lbrakk>x \<preceq> y; y \<preceq> z\<rbrakk> \<Longrightarrow> x \<preceq> z"
    6.20 +begin
    6.21 +
    6.22 +definition
    6.23 +  ideal :: "'a set \<Rightarrow> bool" where
    6.24 +  "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>
    6.25 +    (\<forall>x y. x \<preceq> y \<longrightarrow> y \<in> A \<longrightarrow> x \<in> A))"
    6.26 +
    6.27 +lemma idealI:
    6.28 +  assumes "\<exists>x. x \<in> A"
    6.29 +  assumes "\<And>x y. \<lbrakk>x \<in> A; y \<in> A\<rbrakk> \<Longrightarrow> \<exists>z\<in>A. x \<preceq> z \<and> y \<preceq> z"
    6.30 +  assumes "\<And>x y. \<lbrakk>x \<preceq> y; y \<in> A\<rbrakk> \<Longrightarrow> x \<in> A"
    6.31 +  shows "ideal A"
    6.32 +unfolding ideal_def using prems by fast
    6.33 +
    6.34 +lemma idealD1:
    6.35 +  "ideal A \<Longrightarrow> \<exists>x. x \<in> A"
    6.36 +unfolding ideal_def by fast
    6.37 +
    6.38 +lemma idealD2:
    6.39 +  "\<lbrakk>ideal A; x \<in> A; y \<in> A\<rbrakk> \<Longrightarrow> \<exists>z\<in>A. x \<preceq> z \<and> y \<preceq> z"
    6.40 +unfolding ideal_def by fast
    6.41 +
    6.42 +lemma idealD3:
    6.43 +  "\<lbrakk>ideal A; x \<preceq> y; y \<in> A\<rbrakk> \<Longrightarrow> x \<in> A"
    6.44 +unfolding ideal_def by fast
    6.45 +
    6.46 +lemma ideal_principal: "ideal {x. x \<preceq> z}"
    6.47 +apply (rule idealI)
    6.48 +apply (rule_tac x=z in exI)
    6.49 +apply (fast intro: r_refl)
    6.50 +apply (rule_tac x=z in bexI, fast)
    6.51 +apply (fast intro: r_refl)
    6.52 +apply (fast intro: r_trans)
    6.53 +done
    6.54 +
    6.55 +lemma ex_ideal: "\<exists>A. ideal A"
    6.56 +by (rule exI, rule ideal_principal)
    6.57 +
    6.58 +lemma lub_image_principal:
    6.59 +  assumes f: "\<And>x y. x \<preceq> y \<Longrightarrow> f x \<sqsubseteq> f y"
    6.60 +  shows "(\<Squnion>x\<in>{x. x \<preceq> y}. f x) = f y"
    6.61 +apply (rule lub_eqI)
    6.62 +apply (rule is_lub_maximal)
    6.63 +apply (rule ub_imageI)
    6.64 +apply (simp add: f)
    6.65 +apply (rule imageI)
    6.66 +apply (simp add: r_refl)
    6.67 +done
    6.68 +
    6.69 +text {* The set of ideals is a cpo *}
    6.70 +
    6.71 +lemma ideal_UN:
    6.72 +  fixes A :: "nat \<Rightarrow> 'a set"
    6.73 +  assumes ideal_A: "\<And>i. ideal (A i)"
    6.74 +  assumes chain_A: "\<And>i j. i \<le> j \<Longrightarrow> A i \<subseteq> A j"
    6.75 +  shows "ideal (\<Union>i. A i)"
    6.76 + apply (rule idealI)
    6.77 +   apply (cut_tac idealD1 [OF ideal_A], fast)
    6.78 +  apply (clarify, rename_tac i j)
    6.79 +  apply (drule subsetD [OF chain_A [OF le_maxI1]])
    6.80 +  apply (drule subsetD [OF chain_A [OF le_maxI2]])
    6.81 +  apply (drule (1) idealD2 [OF ideal_A])
    6.82 +  apply blast
    6.83 + apply clarify
    6.84 + apply (drule (1) idealD3 [OF ideal_A])
    6.85 + apply fast
    6.86 +done
    6.87 +
    6.88 +lemma typedef_ideal_po:
    6.89 +  fixes Abs :: "'a set \<Rightarrow> 'b::below"
    6.90 +  assumes type: "type_definition Rep Abs {S. ideal S}"
    6.91 +  assumes below: "\<And>x y. x \<sqsubseteq> y \<longleftrightarrow> Rep x \<subseteq> Rep y"
    6.92 +  shows "OFCLASS('b, po_class)"
    6.93 + apply (intro_classes, unfold below)
    6.94 +   apply (rule subset_refl)
    6.95 +  apply (erule (1) subset_trans)
    6.96 + apply (rule type_definition.Rep_inject [OF type, THEN iffD1])
    6.97 + apply (erule (1) subset_antisym)
    6.98 +done
    6.99 +
   6.100 +lemma
   6.101 +  fixes Abs :: "'a set \<Rightarrow> 'b::po"
   6.102 +  assumes type: "type_definition Rep Abs {S. ideal S}"
   6.103 +  assumes below: "\<And>x y. x \<sqsubseteq> y \<longleftrightarrow> Rep x \<subseteq> Rep y"
   6.104 +  assumes S: "chain S"
   6.105 +  shows typedef_ideal_lub: "range S <<| Abs (\<Union>i. Rep (S i))"
   6.106 +    and typedef_ideal_rep_lub: "Rep (\<Squnion>i. S i) = (\<Union>i. Rep (S i))"
   6.107 +proof -
   6.108 +  have 1: "ideal (\<Union>i. Rep (S i))"
   6.109 +    apply (rule ideal_UN)
   6.110 +     apply (rule type_definition.Rep [OF type, unfolded mem_Collect_eq])
   6.111 +    apply (subst below [symmetric])
   6.112 +    apply (erule chain_mono [OF S])
   6.113 +    done
   6.114 +  hence 2: "Rep (Abs (\<Union>i. Rep (S i))) = (\<Union>i. Rep (S i))"
   6.115 +    by (simp add: type_definition.Abs_inverse [OF type])
   6.116 +  show 3: "range S <<| Abs (\<Union>i. Rep (S i))"
   6.117 +    apply (rule is_lubI)
   6.118 +     apply (rule is_ubI)
   6.119 +     apply (simp add: below 2, fast)
   6.120 +    apply (simp add: below 2 is_ub_def, fast)
   6.121 +    done
   6.122 +  hence 4: "(\<Squnion>i. S i) = Abs (\<Union>i. Rep (S i))"
   6.123 +    by (rule lub_eqI)
   6.124 +  show 5: "Rep (\<Squnion>i. S i) = (\<Union>i. Rep (S i))"
   6.125 +    by (simp add: 4 2)
   6.126 +qed
   6.127 +
   6.128 +lemma typedef_ideal_cpo:
   6.129 +  fixes Abs :: "'a set \<Rightarrow> 'b::po"
   6.130 +  assumes type: "type_definition Rep Abs {S. ideal S}"
   6.131 +  assumes below: "\<And>x y. x \<sqsubseteq> y \<longleftrightarrow> Rep x \<subseteq> Rep y"
   6.132 +  shows "OFCLASS('b, cpo_class)"
   6.133 +by (default, rule exI, erule typedef_ideal_lub [OF type below])
   6.134 +
   6.135 +end
   6.136 +
   6.137 +interpretation below: preorder "below :: 'a::po \<Rightarrow> 'a \<Rightarrow> bool"
   6.138 +apply unfold_locales
   6.139 +apply (rule below_refl)
   6.140 +apply (erule (1) below_trans)
   6.141 +done
   6.142 +
   6.143 +subsection {* Lemmas about least upper bounds *}
   6.144 +
   6.145 +lemma is_ub_thelub_ex: "\<lbrakk>\<exists>u. S <<| u; x \<in> S\<rbrakk> \<Longrightarrow> x \<sqsubseteq> lub S"
   6.146 +apply (erule exE, drule is_lub_lub)
   6.147 +apply (drule is_lubD1)
   6.148 +apply (erule (1) is_ubD)
   6.149 +done
   6.150 +
   6.151 +lemma is_lub_thelub_ex: "\<lbrakk>\<exists>u. S <<| u; S <| x\<rbrakk> \<Longrightarrow> lub S \<sqsubseteq> x"
   6.152 +by (erule exE, drule is_lub_lub, erule is_lubD2)
   6.153 +
   6.154 +subsection {* Locale for ideal completion *}
   6.155 +
   6.156 +locale ideal_completion = preorder +
   6.157 +  fixes principal :: "'a::type \<Rightarrow> 'b::cpo"
   6.158 +  fixes rep :: "'b::cpo \<Rightarrow> 'a::type set"
   6.159 +  assumes ideal_rep: "\<And>x. ideal (rep x)"
   6.160 +  assumes rep_lub: "\<And>Y. chain Y \<Longrightarrow> rep (\<Squnion>i. Y i) = (\<Union>i. rep (Y i))"
   6.161 +  assumes rep_principal: "\<And>a. rep (principal a) = {b. b \<preceq> a}"
   6.162 +  assumes subset_repD: "\<And>x y. rep x \<subseteq> rep y \<Longrightarrow> x \<sqsubseteq> y"
   6.163 +  assumes countable: "\<exists>f::'a \<Rightarrow> nat. inj f"
   6.164 +begin
   6.165 +
   6.166 +lemma rep_mono: "x \<sqsubseteq> y \<Longrightarrow> rep x \<subseteq> rep y"
   6.167 +apply (frule bin_chain)
   6.168 +apply (drule rep_lub)
   6.169 +apply (simp only: lub_eqI [OF is_lub_bin_chain])
   6.170 +apply (rule subsetI, rule UN_I [where a=0], simp_all)
   6.171 +done
   6.172 +
   6.173 +lemma below_def: "x \<sqsubseteq> y \<longleftrightarrow> rep x \<subseteq> rep y"
   6.174 +by (rule iffI [OF rep_mono subset_repD])
   6.175 +
   6.176 +lemma rep_eq: "rep x = {a. principal a \<sqsubseteq> x}"
   6.177 +unfolding below_def rep_principal
   6.178 +apply safe
   6.179 +apply (erule (1) idealD3 [OF ideal_rep])
   6.180 +apply (erule subsetD, simp add: r_refl)
   6.181 +done
   6.182 +
   6.183 +lemma mem_rep_iff_principal_below: "a \<in> rep x \<longleftrightarrow> principal a \<sqsubseteq> x"
   6.184 +by (simp add: rep_eq)
   6.185 +
   6.186 +lemma principal_below_iff_mem_rep: "principal a \<sqsubseteq> x \<longleftrightarrow> a \<in> rep x"
   6.187 +by (simp add: rep_eq)
   6.188 +
   6.189 +lemma principal_below_iff [simp]: "principal a \<sqsubseteq> principal b \<longleftrightarrow> a \<preceq> b"
   6.190 +by (simp add: principal_below_iff_mem_rep rep_principal)
   6.191 +
   6.192 +lemma principal_eq_iff: "principal a = principal b \<longleftrightarrow> a \<preceq> b \<and> b \<preceq> a"
   6.193 +unfolding po_eq_conv [where 'a='b] principal_below_iff ..
   6.194 +
   6.195 +lemma eq_iff: "x = y \<longleftrightarrow> rep x = rep y"
   6.196 +unfolding po_eq_conv below_def by auto
   6.197 +
   6.198 +lemma repD: "a \<in> rep x \<Longrightarrow> principal a \<sqsubseteq> x"
   6.199 +by (simp add: rep_eq)
   6.200 +
   6.201 +lemma principal_mono: "a \<preceq> b \<Longrightarrow> principal a \<sqsubseteq> principal b"
   6.202 +by (simp only: principal_below_iff)
   6.203 +
   6.204 +lemma ch2ch_principal [simp]:
   6.205 +  "\<forall>i. Y i \<preceq> Y (Suc i) \<Longrightarrow> chain (\<lambda>i. principal (Y i))"
   6.206 +by (simp add: chainI principal_mono)
   6.207 +
   6.208 +lemma lub_principal_rep: "principal ` rep x <<| x"
   6.209 +apply (rule is_lubI)
   6.210 +apply (rule ub_imageI)
   6.211 +apply (erule repD)
   6.212 +apply (subst below_def)
   6.213 +apply (rule subsetI)
   6.214 +apply (drule (1) ub_imageD)
   6.215 +apply (simp add: rep_eq)
   6.216 +done
   6.217 +
   6.218 +subsubsection {* Principal ideals approximate all elements *}
   6.219 +
   6.220 +lemma compact_principal [simp]: "compact (principal a)"
   6.221 +by (rule compactI2, simp add: principal_below_iff_mem_rep rep_lub)
   6.222 +
   6.223 +text {* Construct a chain whose lub is the same as a given ideal *}
   6.224 +
   6.225 +lemma obtain_principal_chain:
   6.226 +  obtains Y where "\<forall>i. Y i \<preceq> Y (Suc i)" and "x = (\<Squnion>i. principal (Y i))"
   6.227 +proof -
   6.228 +  obtain count :: "'a \<Rightarrow> nat" where inj: "inj count"
   6.229 +    using countable ..
   6.230 +  def enum \<equiv> "\<lambda>i. THE a. count a = i"
   6.231 +  have enum_count [simp]: "\<And>x. enum (count x) = x"
   6.232 +    unfolding enum_def by (simp add: inj_eq [OF inj])
   6.233 +  def a \<equiv> "LEAST i. enum i \<in> rep x"
   6.234 +  def b \<equiv> "\<lambda>i. LEAST j. enum j \<in> rep x \<and> \<not> enum j \<preceq> enum i"
   6.235 +  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"
   6.236 +  def P \<equiv> "\<lambda>i. \<exists>j. enum j \<in> rep x \<and> \<not> enum j \<preceq> enum i"
   6.237 +  def X \<equiv> "nat_rec a (\<lambda>n i. if P i then c i (b i) else i)"
   6.238 +  have X_0: "X 0 = a" unfolding X_def by simp
   6.239 +  have X_Suc: "\<And>n. X (Suc n) = (if P (X n) then c (X n) (b (X n)) else X n)"
   6.240 +    unfolding X_def by simp
   6.241 +  have a_mem: "enum a \<in> rep x"
   6.242 +    unfolding a_def
   6.243 +    apply (rule LeastI_ex)
   6.244 +    apply (cut_tac ideal_rep [of x])
   6.245 +    apply (drule idealD1)
   6.246 +    apply (clarify, rename_tac a)
   6.247 +    apply (rule_tac x="count a" in exI, simp)
   6.248 +    done
   6.249 +  have b: "\<And>i. P i \<Longrightarrow> enum i \<in> rep x
   6.250 +    \<Longrightarrow> enum (b i) \<in> rep x \<and> \<not> enum (b i) \<preceq> enum i"
   6.251 +    unfolding P_def b_def by (erule LeastI2_ex, simp)
   6.252 +  have c: "\<And>i j. enum i \<in> rep x \<Longrightarrow> enum j \<in> rep x
   6.253 +    \<Longrightarrow> enum (c i j) \<in> rep x \<and> enum i \<preceq> enum (c i j) \<and> enum j \<preceq> enum (c i j)"
   6.254 +    unfolding c_def
   6.255 +    apply (drule (1) idealD2 [OF ideal_rep], clarify)
   6.256 +    apply (rule_tac a="count z" in LeastI2, simp, simp)
   6.257 +    done
   6.258 +  have X_mem: "\<And>n. enum (X n) \<in> rep x"
   6.259 +    apply (induct_tac n)
   6.260 +    apply (simp add: X_0 a_mem)
   6.261 +    apply (clarsimp simp add: X_Suc, rename_tac n)
   6.262 +    apply (simp add: b c)
   6.263 +    done
   6.264 +  have X_chain: "\<And>n. enum (X n) \<preceq> enum (X (Suc n))"
   6.265 +    apply (clarsimp simp add: X_Suc r_refl)
   6.266 +    apply (simp add: b c X_mem)
   6.267 +    done
   6.268 +  have less_b: "\<And>n i. n < b i \<Longrightarrow> enum n \<in> rep x \<Longrightarrow> enum n \<preceq> enum i"
   6.269 +    unfolding b_def by (drule not_less_Least, simp)
   6.270 +  have X_covers: "\<And>n. \<forall>k\<le>n. enum k \<in> rep x \<longrightarrow> enum k \<preceq> enum (X n)"
   6.271 +    apply (induct_tac n)
   6.272 +    apply (clarsimp simp add: X_0 a_def)
   6.273 +    apply (drule_tac k=0 in Least_le, simp add: r_refl)
   6.274 +    apply (clarsimp, rename_tac n k)
   6.275 +    apply (erule le_SucE)
   6.276 +    apply (rule r_trans [OF _ X_chain], simp)
   6.277 +    apply (case_tac "P (X n)", simp add: X_Suc)
   6.278 +    apply (rule_tac x="b (X n)" and y="Suc n" in linorder_cases)
   6.279 +    apply (simp only: less_Suc_eq_le)
   6.280 +    apply (drule spec, drule (1) mp, simp add: b X_mem)
   6.281 +    apply (simp add: c X_mem)
   6.282 +    apply (drule (1) less_b)
   6.283 +    apply (erule r_trans)
   6.284 +    apply (simp add: b c X_mem)
   6.285 +    apply (simp add: X_Suc)
   6.286 +    apply (simp add: P_def)
   6.287 +    done
   6.288 +  have 1: "\<forall>i. enum (X i) \<preceq> enum (X (Suc i))"
   6.289 +    by (simp add: X_chain)
   6.290 +  have 2: "x = (\<Squnion>n. principal (enum (X n)))"
   6.291 +    apply (simp add: eq_iff rep_lub 1 rep_principal)
   6.292 +    apply (auto, rename_tac a)
   6.293 +    apply (subgoal_tac "\<exists>i. a = enum i", erule exE)
   6.294 +    apply (rule_tac x=i in exI, simp add: X_covers)
   6.295 +    apply (rule_tac x="count a" in exI, simp)
   6.296 +    apply (erule idealD3 [OF ideal_rep])
   6.297 +    apply (rule X_mem)
   6.298 +    done
   6.299 +  from 1 2 show ?thesis ..
   6.300 +qed
   6.301 +
   6.302 +lemma principal_induct:
   6.303 +  assumes adm: "adm P"
   6.304 +  assumes P: "\<And>a. P (principal a)"
   6.305 +  shows "P x"
   6.306 +apply (rule obtain_principal_chain [of x])
   6.307 +apply (simp add: admD [OF adm] P)
   6.308 +done
   6.309 +
   6.310 +lemma principal_induct2:
   6.311 +  "\<lbrakk>\<And>y. adm (\<lambda>x. P x y); \<And>x. adm (\<lambda>y. P x y);
   6.312 +    \<And>a b. P (principal a) (principal b)\<rbrakk> \<Longrightarrow> P x y"
   6.313 +apply (rule_tac x=y in spec)
   6.314 +apply (rule_tac x=x in principal_induct, simp)
   6.315 +apply (rule allI, rename_tac y)
   6.316 +apply (rule_tac x=y in principal_induct, simp)
   6.317 +apply simp
   6.318 +done
   6.319 +
   6.320 +lemma compact_imp_principal: "compact x \<Longrightarrow> \<exists>a. x = principal a"
   6.321 +apply (rule obtain_principal_chain [of x])
   6.322 +apply (drule adm_compact_neq [OF _ cont_id])
   6.323 +apply (subgoal_tac "chain (\<lambda>i. principal (Y i))")
   6.324 +apply (drule (2) admD2, fast, simp)
   6.325 +done
   6.326 +
   6.327 +lemma obtain_compact_chain:
   6.328 +  obtains Y :: "nat \<Rightarrow> 'b"
   6.329 +  where "chain Y" and "\<forall>i. compact (Y i)" and "x = (\<Squnion>i. Y i)"
   6.330 +apply (rule obtain_principal_chain [of x])
   6.331 +apply (rule_tac Y="\<lambda>i. principal (Y i)" in that, simp_all)
   6.332 +done
   6.333 +
   6.334 +subsection {* Defining functions in terms of basis elements *}
   6.335 +
   6.336 +definition
   6.337 +  basis_fun :: "('a::type \<Rightarrow> 'c::cpo) \<Rightarrow> 'b \<rightarrow> 'c" where
   6.338 +  "basis_fun = (\<lambda>f. (\<Lambda> x. lub (f ` rep x)))"
   6.339 +
   6.340 +lemma basis_fun_lemma:
   6.341 +  fixes f :: "'a::type \<Rightarrow> 'c::cpo"
   6.342 +  assumes f_mono: "\<And>a b. a \<preceq> b \<Longrightarrow> f a \<sqsubseteq> f b"
   6.343 +  shows "\<exists>u. f ` rep x <<| u"
   6.344 +proof -
   6.345 +  obtain Y where Y: "\<forall>i. Y i \<preceq> Y (Suc i)"
   6.346 +  and x: "x = (\<Squnion>i. principal (Y i))"
   6.347 +    by (rule obtain_principal_chain [of x])
   6.348 +  have chain: "chain (\<lambda>i. f (Y i))"
   6.349 +    by (rule chainI, simp add: f_mono Y)
   6.350 +  have rep_x: "rep x = (\<Union>n. {a. a \<preceq> Y n})"
   6.351 +    by (simp add: x rep_lub Y rep_principal)
   6.352 +  have "f ` rep x <<| (\<Squnion>n. f (Y n))"
   6.353 +    apply (rule is_lubI)
   6.354 +    apply (rule ub_imageI, rename_tac a)
   6.355 +    apply (clarsimp simp add: rep_x)
   6.356 +    apply (drule f_mono)
   6.357 +    apply (erule below_lub [OF chain])
   6.358 +    apply (rule lub_below [OF chain])
   6.359 +    apply (drule_tac x="Y n" in ub_imageD)
   6.360 +    apply (simp add: rep_x, fast intro: r_refl)
   6.361 +    apply assumption
   6.362 +    done
   6.363 +  thus ?thesis ..
   6.364 +qed
   6.365 +
   6.366 +lemma basis_fun_beta:
   6.367 +  fixes f :: "'a::type \<Rightarrow> 'c::cpo"
   6.368 +  assumes f_mono: "\<And>a b. a \<preceq> b \<Longrightarrow> f a \<sqsubseteq> f b"
   6.369 +  shows "basis_fun f\<cdot>x = lub (f ` rep x)"
   6.370 +unfolding basis_fun_def
   6.371 +proof (rule beta_cfun)
   6.372 +  have lub: "\<And>x. \<exists>u. f ` rep x <<| u"
   6.373 +    using f_mono by (rule basis_fun_lemma)
   6.374 +  show cont: "cont (\<lambda>x. lub (f ` rep x))"
   6.375 +    apply (rule contI2)
   6.376 +     apply (rule monofunI)
   6.377 +     apply (rule is_lub_thelub_ex [OF lub ub_imageI])
   6.378 +     apply (rule is_ub_thelub_ex [OF lub imageI])
   6.379 +     apply (erule (1) subsetD [OF rep_mono])
   6.380 +    apply (rule is_lub_thelub_ex [OF lub ub_imageI])
   6.381 +    apply (simp add: rep_lub, clarify)
   6.382 +    apply (erule rev_below_trans [OF is_ub_thelub])
   6.383 +    apply (erule is_ub_thelub_ex [OF lub imageI])
   6.384 +    done
   6.385 +qed
   6.386 +
   6.387 +lemma basis_fun_principal:
   6.388 +  fixes f :: "'a::type \<Rightarrow> 'c::cpo"
   6.389 +  assumes f_mono: "\<And>a b. a \<preceq> b \<Longrightarrow> f a \<sqsubseteq> f b"
   6.390 +  shows "basis_fun f\<cdot>(principal a) = f a"
   6.391 +apply (subst basis_fun_beta, erule f_mono)
   6.392 +apply (subst rep_principal)
   6.393 +apply (rule lub_image_principal, erule f_mono)
   6.394 +done
   6.395 +
   6.396 +lemma basis_fun_mono:
   6.397 +  assumes f_mono: "\<And>a b. a \<preceq> b \<Longrightarrow> f a \<sqsubseteq> f b"
   6.398 +  assumes g_mono: "\<And>a b. a \<preceq> b \<Longrightarrow> g a \<sqsubseteq> g b"
   6.399 +  assumes below: "\<And>a. f a \<sqsubseteq> g a"
   6.400 +  shows "basis_fun f \<sqsubseteq> basis_fun g"
   6.401 + apply (rule cfun_belowI)
   6.402 + apply (simp only: basis_fun_beta f_mono g_mono)
   6.403 + apply (rule is_lub_thelub_ex)
   6.404 +  apply (rule basis_fun_lemma, erule f_mono)
   6.405 + apply (rule ub_imageI, rename_tac a)
   6.406 + apply (rule below_trans [OF below])
   6.407 + apply (rule is_ub_thelub_ex)
   6.408 +  apply (rule basis_fun_lemma, erule g_mono)
   6.409 + apply (erule imageI)
   6.410 +done
   6.411 +
   6.412 +end
   6.413 +
   6.414 +lemma (in preorder) typedef_ideal_completion:
   6.415 +  fixes Abs :: "'a set \<Rightarrow> 'b::cpo"
   6.416 +  assumes type: "type_definition Rep Abs {S. ideal S}"
   6.417 +  assumes below: "\<And>x y. x \<sqsubseteq> y \<longleftrightarrow> Rep x \<subseteq> Rep y"
   6.418 +  assumes principal: "\<And>a. principal a = Abs {b. b \<preceq> a}"
   6.419 +  assumes countable: "\<exists>f::'a \<Rightarrow> nat. inj f"
   6.420 +  shows "ideal_completion r principal Rep"
   6.421 +proof
   6.422 +  interpret type_definition Rep Abs "{S. ideal S}" by fact
   6.423 +  fix a b :: 'a and x y :: 'b and Y :: "nat \<Rightarrow> 'b"
   6.424 +  show "ideal (Rep x)"
   6.425 +    using Rep [of x] by simp
   6.426 +  show "chain Y \<Longrightarrow> Rep (\<Squnion>i. Y i) = (\<Union>i. Rep (Y i))"
   6.427 +    using type below by (rule typedef_ideal_rep_lub)
   6.428 +  show "Rep (principal a) = {b. b \<preceq> a}"
   6.429 +    by (simp add: principal Abs_inverse ideal_principal)
   6.430 +  show "Rep x \<subseteq> Rep y \<Longrightarrow> x \<sqsubseteq> y"
   6.431 +    by (simp only: below)
   6.432 +  show "\<exists>f::'a \<Rightarrow> nat. inj f"
   6.433 +    by (rule countable)
   6.434 +qed
   6.435 +
   6.436 +end
     7.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     7.2 +++ b/src/HOL/HOLCF/Cont.thy	Sat Nov 27 16:08:10 2010 -0800
     7.3 @@ -0,0 +1,239 @@
     7.4 +(*  Title:      HOLCF/Cont.thy
     7.5 +    Author:     Franz Regensburger
     7.6 +    Author:     Brian Huffman
     7.7 +*)
     7.8 +
     7.9 +header {* Continuity and monotonicity *}
    7.10 +
    7.11 +theory Cont
    7.12 +imports Pcpo
    7.13 +begin
    7.14 +
    7.15 +text {*
    7.16 +   Now we change the default class! Form now on all untyped type variables are
    7.17 +   of default class po
    7.18 +*}
    7.19 +
    7.20 +default_sort po
    7.21 +
    7.22 +subsection {* Definitions *}
    7.23 +
    7.24 +definition
    7.25 +  monofun :: "('a \<Rightarrow> 'b) \<Rightarrow> bool"  -- "monotonicity"  where
    7.26 +  "monofun f = (\<forall>x y. x \<sqsubseteq> y \<longrightarrow> f x \<sqsubseteq> f y)"
    7.27 +
    7.28 +definition
    7.29 +  cont :: "('a::cpo \<Rightarrow> 'b::cpo) \<Rightarrow> bool"
    7.30 +where
    7.31 +  "cont f = (\<forall>Y. chain Y \<longrightarrow> range (\<lambda>i. f (Y i)) <<| f (\<Squnion>i. Y i))"
    7.32 +
    7.33 +lemma contI:
    7.34 +  "\<lbrakk>\<And>Y. chain Y \<Longrightarrow> range (\<lambda>i. f (Y i)) <<| f (\<Squnion>i. Y i)\<rbrakk> \<Longrightarrow> cont f"
    7.35 +by (simp add: cont_def)
    7.36 +
    7.37 +lemma contE:
    7.38 +  "\<lbrakk>cont f; chain Y\<rbrakk> \<Longrightarrow> range (\<lambda>i. f (Y i)) <<| f (\<Squnion>i. Y i)"
    7.39 +by (simp add: cont_def)
    7.40 +
    7.41 +lemma monofunI: 
    7.42 +  "\<lbrakk>\<And>x y. x \<sqsubseteq> y \<Longrightarrow> f x \<sqsubseteq> f y\<rbrakk> \<Longrightarrow> monofun f"
    7.43 +by (simp add: monofun_def)
    7.44 +
    7.45 +lemma monofunE: 
    7.46 +  "\<lbrakk>monofun f; x \<sqsubseteq> y\<rbrakk> \<Longrightarrow> f x \<sqsubseteq> f y"
    7.47 +by (simp add: monofun_def)
    7.48 +
    7.49 +
    7.50 +subsection {* Equivalence of alternate definition *}
    7.51 +
    7.52 +text {* monotone functions map chains to chains *}
    7.53 +
    7.54 +lemma ch2ch_monofun: "\<lbrakk>monofun f; chain Y\<rbrakk> \<Longrightarrow> chain (\<lambda>i. f (Y i))"
    7.55 +apply (rule chainI)
    7.56 +apply (erule monofunE)
    7.57 +apply (erule chainE)
    7.58 +done
    7.59 +
    7.60 +text {* monotone functions map upper bound to upper bounds *}
    7.61 +
    7.62 +lemma ub2ub_monofun: 
    7.63 +  "\<lbrakk>monofun f; range Y <| u\<rbrakk> \<Longrightarrow> range (\<lambda>i. f (Y i)) <| f u"
    7.64 +apply (rule ub_rangeI)
    7.65 +apply (erule monofunE)
    7.66 +apply (erule ub_rangeD)
    7.67 +done
    7.68 +
    7.69 +text {* a lemma about binary chains *}
    7.70 +
    7.71 +lemma binchain_cont:
    7.72 +  "\<lbrakk>cont f; x \<sqsubseteq> y\<rbrakk> \<Longrightarrow> range (\<lambda>i::nat. f (if i = 0 then x else y)) <<| f y"
    7.73 +apply (subgoal_tac "f (\<Squnion>i::nat. if i = 0 then x else y) = f y")
    7.74 +apply (erule subst)
    7.75 +apply (erule contE)
    7.76 +apply (erule bin_chain)
    7.77 +apply (rule_tac f=f in arg_cong)
    7.78 +apply (erule is_lub_bin_chain [THEN lub_eqI])
    7.79 +done
    7.80 +
    7.81 +text {* continuity implies monotonicity *}
    7.82 +
    7.83 +lemma cont2mono: "cont f \<Longrightarrow> monofun f"
    7.84 +apply (rule monofunI)
    7.85 +apply (drule (1) binchain_cont)
    7.86 +apply (drule_tac i=0 in is_lub_rangeD1)
    7.87 +apply simp
    7.88 +done
    7.89 +
    7.90 +lemmas cont2monofunE = cont2mono [THEN monofunE]
    7.91 +
    7.92 +lemmas ch2ch_cont = cont2mono [THEN ch2ch_monofun]
    7.93 +
    7.94 +text {* continuity implies preservation of lubs *}
    7.95 +
    7.96 +lemma cont2contlubE:
    7.97 +  "\<lbrakk>cont f; chain Y\<rbrakk> \<Longrightarrow> f (\<Squnion> i. Y i) = (\<Squnion> i. f (Y i))"
    7.98 +apply (rule lub_eqI [symmetric])
    7.99 +apply (erule (1) contE)
   7.100 +done
   7.101 +
   7.102 +lemma contI2:
   7.103 +  fixes f :: "'a::cpo \<Rightarrow> 'b::cpo"
   7.104 +  assumes mono: "monofun f"
   7.105 +  assumes below: "\<And>Y. \<lbrakk>chain Y; chain (\<lambda>i. f (Y i))\<rbrakk>
   7.106 +     \<Longrightarrow> f (\<Squnion>i. Y i) \<sqsubseteq> (\<Squnion>i. f (Y i))"
   7.107 +  shows "cont f"
   7.108 +proof (rule contI)
   7.109 +  fix Y :: "nat \<Rightarrow> 'a"
   7.110 +  assume Y: "chain Y"
   7.111 +  with mono have fY: "chain (\<lambda>i. f (Y i))"
   7.112 +    by (rule ch2ch_monofun)
   7.113 +  have "(\<Squnion>i. f (Y i)) = f (\<Squnion>i. Y i)"
   7.114 +    apply (rule below_antisym)
   7.115 +    apply (rule lub_below [OF fY])
   7.116 +    apply (rule monofunE [OF mono])
   7.117 +    apply (rule is_ub_thelub [OF Y])
   7.118 +    apply (rule below [OF Y fY])
   7.119 +    done
   7.120 +  with fY show "range (\<lambda>i. f (Y i)) <<| f (\<Squnion>i. Y i)"
   7.121 +    by (rule thelubE)
   7.122 +qed
   7.123 +
   7.124 +subsection {* Collection of continuity rules *}
   7.125 +
   7.126 +ML {*
   7.127 +structure Cont2ContData = Named_Thms
   7.128 +(
   7.129 +  val name = "cont2cont"
   7.130 +  val description = "continuity intro rule"
   7.131 +)
   7.132 +*}
   7.133 +
   7.134 +setup Cont2ContData.setup
   7.135 +
   7.136 +subsection {* Continuity of basic functions *}
   7.137 +
   7.138 +text {* The identity function is continuous *}
   7.139 +
   7.140 +lemma cont_id [simp, cont2cont]: "cont (\<lambda>x. x)"
   7.141 +apply (rule contI)
   7.142 +apply (erule cpo_lubI)
   7.143 +done
   7.144 +
   7.145 +text {* constant functions are continuous *}
   7.146 +
   7.147 +lemma cont_const [simp, cont2cont]: "cont (\<lambda>x. c)"
   7.148 +  using is_lub_const by (rule contI)
   7.149 +
   7.150 +text {* application of functions is continuous *}
   7.151 +
   7.152 +lemma cont_apply:
   7.153 +  fixes f :: "'a::cpo \<Rightarrow> 'b::cpo \<Rightarrow> 'c::cpo" and t :: "'a \<Rightarrow> 'b"
   7.154 +  assumes 1: "cont (\<lambda>x. t x)"
   7.155 +  assumes 2: "\<And>x. cont (\<lambda>y. f x y)"
   7.156 +  assumes 3: "\<And>y. cont (\<lambda>x. f x y)"
   7.157 +  shows "cont (\<lambda>x. (f x) (t x))"
   7.158 +proof (rule contI2 [OF monofunI])
   7.159 +  fix x y :: "'a" assume "x \<sqsubseteq> y"
   7.160 +  then show "f x (t x) \<sqsubseteq> f y (t y)"
   7.161 +    by (auto intro: cont2monofunE [OF 1]
   7.162 +                    cont2monofunE [OF 2]
   7.163 +                    cont2monofunE [OF 3]
   7.164 +                    below_trans)
   7.165 +next
   7.166 +  fix Y :: "nat \<Rightarrow> 'a" assume "chain Y"
   7.167 +  then show "f (\<Squnion>i. Y i) (t (\<Squnion>i. Y i)) \<sqsubseteq> (\<Squnion>i. f (Y i) (t (Y i)))"
   7.168 +    by (simp only: cont2contlubE [OF 1] ch2ch_cont [OF 1]
   7.169 +                   cont2contlubE [OF 2] ch2ch_cont [OF 2]
   7.170 +                   cont2contlubE [OF 3] ch2ch_cont [OF 3]
   7.171 +                   diag_lub below_refl)
   7.172 +qed
   7.173 +
   7.174 +lemma cont_compose:
   7.175 +  "\<lbrakk>cont c; cont (\<lambda>x. f x)\<rbrakk> \<Longrightarrow> cont (\<lambda>x. c (f x))"
   7.176 +by (rule cont_apply [OF _ _ cont_const])
   7.177 +
   7.178 +text {* Least upper bounds preserve continuity *}
   7.179 +
   7.180 +lemma cont2cont_lub [simp]:
   7.181 +  assumes chain: "\<And>x. chain (\<lambda>i. F i x)" and cont: "\<And>i. cont (\<lambda>x. F i x)"
   7.182 +  shows "cont (\<lambda>x. \<Squnion>i. F i x)"
   7.183 +apply (rule contI2)
   7.184 +apply (simp add: monofunI cont2monofunE [OF cont] lub_mono chain)
   7.185 +apply (simp add: cont2contlubE [OF cont])
   7.186 +apply (simp add: diag_lub ch2ch_cont [OF cont] chain)
   7.187 +done
   7.188 +
   7.189 +text {* if-then-else is continuous *}
   7.190 +
   7.191 +lemma cont_if [simp, cont2cont]:
   7.192 +  "\<lbrakk>cont f; cont g\<rbrakk> \<Longrightarrow> cont (\<lambda>x. if b then f x else g x)"
   7.193 +by (induct b) simp_all
   7.194 +
   7.195 +subsection {* Finite chains and flat pcpos *}
   7.196 +
   7.197 +text {* Monotone functions map finite chains to finite chains. *}
   7.198 +
   7.199 +lemma monofun_finch2finch:
   7.200 +  "\<lbrakk>monofun f; finite_chain Y\<rbrakk> \<Longrightarrow> finite_chain (\<lambda>n. f (Y n))"
   7.201 +apply (unfold finite_chain_def)
   7.202 +apply (simp add: ch2ch_monofun)
   7.203 +apply (force simp add: max_in_chain_def)
   7.204 +done
   7.205 +
   7.206 +text {* The same holds for continuous functions. *}
   7.207 +
   7.208 +lemma cont_finch2finch:
   7.209 +  "\<lbrakk>cont f; finite_chain Y\<rbrakk> \<Longrightarrow> finite_chain (\<lambda>n. f (Y n))"
   7.210 +by (rule cont2mono [THEN monofun_finch2finch])
   7.211 +
   7.212 +text {* All monotone functions with chain-finite domain are continuous. *}
   7.213 +
   7.214 +lemma chfindom_monofun2cont: "monofun f \<Longrightarrow> cont (f::'a::chfin \<Rightarrow> 'b::cpo)"
   7.215 +apply (erule contI2)
   7.216 +apply (frule chfin2finch)
   7.217 +apply (clarsimp simp add: finite_chain_def)
   7.218 +apply (subgoal_tac "max_in_chain i (\<lambda>i. f (Y i))")
   7.219 +apply (simp add: maxinch_is_thelub ch2ch_monofun)
   7.220 +apply (force simp add: max_in_chain_def)
   7.221 +done
   7.222 +
   7.223 +text {* All strict functions with flat domain are continuous. *}
   7.224 +
   7.225 +lemma flatdom_strict2mono: "f \<bottom> = \<bottom> \<Longrightarrow> monofun (f::'a::flat \<Rightarrow> 'b::pcpo)"
   7.226 +apply (rule monofunI)
   7.227 +apply (drule ax_flat)
   7.228 +apply auto
   7.229 +done
   7.230 +
   7.231 +lemma flatdom_strict2cont: "f \<bottom> = \<bottom> \<Longrightarrow> cont (f::'a::flat \<Rightarrow> 'b::pcpo)"
   7.232 +by (rule flatdom_strict2mono [THEN chfindom_monofun2cont])
   7.233 +
   7.234 +text {* All functions with discrete domain are continuous. *}
   7.235 +
   7.236 +lemma cont_discrete_cpo [simp, cont2cont]: "cont (f::'a::discrete_cpo \<Rightarrow> 'b::cpo)"
   7.237 +apply (rule contI)
   7.238 +apply (drule discrete_chain_const, clarify)
   7.239 +apply (simp add: is_lub_const)
   7.240 +done
   7.241 +
   7.242 +end
     8.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     8.2 +++ b/src/HOL/HOLCF/ConvexPD.thy	Sat Nov 27 16:08:10 2010 -0800
     8.3 @@ -0,0 +1,651 @@
     8.4 +(*  Title:      HOLCF/ConvexPD.thy
     8.5 +    Author:     Brian Huffman
     8.6 +*)
     8.7 +
     8.8 +header {* Convex powerdomain *}
     8.9 +
    8.10 +theory ConvexPD
    8.11 +imports UpperPD LowerPD
    8.12 +begin
    8.13 +
    8.14 +subsection {* Basis preorder *}
    8.15 +
    8.16 +definition
    8.17 +  convex_le :: "'a pd_basis \<Rightarrow> 'a pd_basis \<Rightarrow> bool" (infix "\<le>\<natural>" 50) where
    8.18 +  "convex_le = (\<lambda>u v. u \<le>\<sharp> v \<and> u \<le>\<flat> v)"
    8.19 +
    8.20 +lemma convex_le_refl [simp]: "t \<le>\<natural> t"
    8.21 +unfolding convex_le_def by (fast intro: upper_le_refl lower_le_refl)
    8.22 +
    8.23 +lemma convex_le_trans: "\<lbrakk>t \<le>\<natural> u; u \<le>\<natural> v\<rbrakk> \<Longrightarrow> t \<le>\<natural> v"
    8.24 +unfolding convex_le_def by (fast intro: upper_le_trans lower_le_trans)
    8.25 +
    8.26 +interpretation convex_le: preorder convex_le
    8.27 +by (rule preorder.intro, rule convex_le_refl, rule convex_le_trans)
    8.28 +
    8.29 +lemma upper_le_minimal [simp]: "PDUnit compact_bot \<le>\<natural> t"
    8.30 +unfolding convex_le_def Rep_PDUnit by simp
    8.31 +
    8.32 +lemma PDUnit_convex_mono: "x \<sqsubseteq> y \<Longrightarrow> PDUnit x \<le>\<natural> PDUnit y"
    8.33 +unfolding convex_le_def by (fast intro: PDUnit_upper_mono PDUnit_lower_mono)
    8.34 +
    8.35 +lemma PDPlus_convex_mono: "\<lbrakk>s \<le>\<natural> t; u \<le>\<natural> v\<rbrakk> \<Longrightarrow> PDPlus s u \<le>\<natural> PDPlus t v"
    8.36 +unfolding convex_le_def by (fast intro: PDPlus_upper_mono PDPlus_lower_mono)
    8.37 +
    8.38 +lemma convex_le_PDUnit_PDUnit_iff [simp]:
    8.39 +  "(PDUnit a \<le>\<natural> PDUnit b) = (a \<sqsubseteq> b)"
    8.40 +unfolding convex_le_def upper_le_def lower_le_def Rep_PDUnit by fast
    8.41 +
    8.42 +lemma convex_le_PDUnit_lemma1:
    8.43 +  "(PDUnit a \<le>\<natural> t) = (\<forall>b\<in>Rep_pd_basis t. a \<sqsubseteq> b)"
    8.44 +unfolding convex_le_def upper_le_def lower_le_def Rep_PDUnit
    8.45 +using Rep_pd_basis_nonempty [of t, folded ex_in_conv] by fast
    8.46 +
    8.47 +lemma convex_le_PDUnit_PDPlus_iff [simp]:
    8.48 +  "(PDUnit a \<le>\<natural> PDPlus t u) = (PDUnit a \<le>\<natural> t \<and> PDUnit a \<le>\<natural> u)"
    8.49 +unfolding convex_le_PDUnit_lemma1 Rep_PDPlus by fast
    8.50 +
    8.51 +lemma convex_le_PDUnit_lemma2:
    8.52 +  "(t \<le>\<natural> PDUnit b) = (\<forall>a\<in>Rep_pd_basis t. a \<sqsubseteq> b)"
    8.53 +unfolding convex_le_def upper_le_def lower_le_def Rep_PDUnit
    8.54 +using Rep_pd_basis_nonempty [of t, folded ex_in_conv] by fast
    8.55 +
    8.56 +lemma convex_le_PDPlus_PDUnit_iff [simp]:
    8.57 +  "(PDPlus t u \<le>\<natural> PDUnit a) = (t \<le>\<natural> PDUnit a \<and> u \<le>\<natural> PDUnit a)"
    8.58 +unfolding convex_le_PDUnit_lemma2 Rep_PDPlus by fast
    8.59 +
    8.60 +lemma convex_le_PDPlus_lemma:
    8.61 +  assumes z: "PDPlus t u \<le>\<natural> z"
    8.62 +  shows "\<exists>v w. z = PDPlus v w \<and> t \<le>\<natural> v \<and> u \<le>\<natural> w"
    8.63 +proof (intro exI conjI)
    8.64 +  let ?A = "{b\<in>Rep_pd_basis z. \<exists>a\<in>Rep_pd_basis t. a \<sqsubseteq> b}"
    8.65 +  let ?B = "{b\<in>Rep_pd_basis z. \<exists>a\<in>Rep_pd_basis u. a \<sqsubseteq> b}"
    8.66 +  let ?v = "Abs_pd_basis ?A"
    8.67 +  let ?w = "Abs_pd_basis ?B"
    8.68 +  have Rep_v: "Rep_pd_basis ?v = ?A"
    8.69 +    apply (rule Abs_pd_basis_inverse)
    8.70 +    apply (rule Rep_pd_basis_nonempty [of t, folded ex_in_conv, THEN exE])
    8.71 +    apply (cut_tac z, simp only: convex_le_def lower_le_def, clarify)
    8.72 +    apply (drule_tac x=x in bspec, simp add: Rep_PDPlus, erule bexE)
    8.73 +    apply (simp add: pd_basis_def)
    8.74 +    apply fast
    8.75 +    done
    8.76 +  have Rep_w: "Rep_pd_basis ?w = ?B"
    8.77 +    apply (rule Abs_pd_basis_inverse)
    8.78 +    apply (rule Rep_pd_basis_nonempty [of u, folded ex_in_conv, THEN exE])
    8.79 +    apply (cut_tac z, simp only: convex_le_def lower_le_def, clarify)
    8.80 +    apply (drule_tac x=x in bspec, simp add: Rep_PDPlus, erule bexE)
    8.81 +    apply (simp add: pd_basis_def)
    8.82 +    apply fast
    8.83 +    done
    8.84 +  show "z = PDPlus ?v ?w"
    8.85 +    apply (insert z)
    8.86 +    apply (simp add: convex_le_def, erule conjE)
    8.87 +    apply (simp add: Rep_pd_basis_inject [symmetric] Rep_PDPlus)
    8.88 +    apply (simp add: Rep_v Rep_w)
    8.89 +    apply (rule equalityI)
    8.90 +     apply (rule subsetI)
    8.91 +     apply (simp only: upper_le_def)
    8.92 +     apply (drule (1) bspec, erule bexE)
    8.93 +     apply (simp add: Rep_PDPlus)
    8.94 +     apply fast
    8.95 +    apply fast
    8.96 +    done
    8.97 +  show "t \<le>\<natural> ?v" "u \<le>\<natural> ?w"
    8.98 +   apply (insert z)
    8.99 +   apply (simp_all add: convex_le_def upper_le_def lower_le_def Rep_PDPlus Rep_v Rep_w)
   8.100 +   apply fast+
   8.101 +   done
   8.102 +qed
   8.103 +
   8.104 +lemma convex_le_induct [induct set: convex_le]:
   8.105 +  assumes le: "t \<le>\<natural> u"
   8.106 +  assumes 2: "\<And>t u v. \<lbrakk>P t u; P u v\<rbrakk> \<Longrightarrow> P t v"
   8.107 +  assumes 3: "\<And>a b. a \<sqsubseteq> b \<Longrightarrow> P (PDUnit a) (PDUnit b)"
   8.108 +  assumes 4: "\<And>t u v w. \<lbrakk>P t v; P u w\<rbrakk> \<Longrightarrow> P (PDPlus t u) (PDPlus v w)"
   8.109 +  shows "P t u"
   8.110 +using le apply (induct t arbitrary: u rule: pd_basis_induct)
   8.111 +apply (erule rev_mp)
   8.112 +apply (induct_tac u rule: pd_basis_induct1)
   8.113 +apply (simp add: 3)
   8.114 +apply (simp, clarify, rename_tac a b t)
   8.115 +apply (subgoal_tac "P (PDPlus (PDUnit a) (PDUnit a)) (PDPlus (PDUnit b) t)")
   8.116 +apply (simp add: PDPlus_absorb)
   8.117 +apply (erule (1) 4 [OF 3])
   8.118 +apply (drule convex_le_PDPlus_lemma, clarify)
   8.119 +apply (simp add: 4)
   8.120 +done
   8.121 +
   8.122 +
   8.123 +subsection {* Type definition *}
   8.124 +
   8.125 +typedef (open) 'a convex_pd =
   8.126 +  "{S::'a pd_basis set. convex_le.ideal S}"
   8.127 +by (fast intro: convex_le.ideal_principal)
   8.128 +
   8.129 +instantiation convex_pd :: ("domain") below
   8.130 +begin
   8.131 +
   8.132 +definition
   8.133 +  "x \<sqsubseteq> y \<longleftrightarrow> Rep_convex_pd x \<subseteq> Rep_convex_pd y"
   8.134 +
   8.135 +instance ..
   8.136 +end
   8.137 +
   8.138 +instance convex_pd :: ("domain") po
   8.139 +using type_definition_convex_pd below_convex_pd_def
   8.140 +by (rule convex_le.typedef_ideal_po)
   8.141 +
   8.142 +instance convex_pd :: ("domain") cpo
   8.143 +using type_definition_convex_pd below_convex_pd_def
   8.144 +by (rule convex_le.typedef_ideal_cpo)
   8.145 +
   8.146 +definition
   8.147 +  convex_principal :: "'a pd_basis \<Rightarrow> 'a convex_pd" where
   8.148 +  "convex_principal t = Abs_convex_pd {u. u \<le>\<natural> t}"
   8.149 +
   8.150 +interpretation convex_pd:
   8.151 +  ideal_completion convex_le convex_principal Rep_convex_pd
   8.152 +using type_definition_convex_pd below_convex_pd_def
   8.153 +using convex_principal_def pd_basis_countable
   8.154 +by (rule convex_le.typedef_ideal_completion)
   8.155 +
   8.156 +text {* Convex powerdomain is pointed *}
   8.157 +
   8.158 +lemma convex_pd_minimal: "convex_principal (PDUnit compact_bot) \<sqsubseteq> ys"
   8.159 +by (induct ys rule: convex_pd.principal_induct, simp, simp)
   8.160 +
   8.161 +instance convex_pd :: ("domain") pcpo
   8.162 +by intro_classes (fast intro: convex_pd_minimal)
   8.163 +
   8.164 +lemma inst_convex_pd_pcpo: "\<bottom> = convex_principal (PDUnit compact_bot)"
   8.165 +by (rule convex_pd_minimal [THEN UU_I, symmetric])
   8.166 +
   8.167 +
   8.168 +subsection {* Monadic unit and plus *}
   8.169 +
   8.170 +definition
   8.171 +  convex_unit :: "'a \<rightarrow> 'a convex_pd" where
   8.172 +  "convex_unit = compact_basis.basis_fun (\<lambda>a. convex_principal (PDUnit a))"
   8.173 +
   8.174 +definition
   8.175 +  convex_plus :: "'a convex_pd \<rightarrow> 'a convex_pd \<rightarrow> 'a convex_pd" where
   8.176 +  "convex_plus = convex_pd.basis_fun (\<lambda>t. convex_pd.basis_fun (\<lambda>u.
   8.177 +      convex_principal (PDPlus t u)))"
   8.178 +
   8.179 +abbreviation
   8.180 +  convex_add :: "'a convex_pd \<Rightarrow> 'a convex_pd \<Rightarrow> 'a convex_pd"
   8.181 +    (infixl "+\<natural>" 65) where
   8.182 +  "xs +\<natural> ys == convex_plus\<cdot>xs\<cdot>ys"
   8.183 +
   8.184 +syntax
   8.185 +  "_convex_pd" :: "args \<Rightarrow> 'a convex_pd" ("{_}\<natural>")
   8.186 +
   8.187 +translations
   8.188 +  "{x,xs}\<natural>" == "{x}\<natural> +\<natural> {xs}\<natural>"
   8.189 +  "{x}\<natural>" == "CONST convex_unit\<cdot>x"
   8.190 +
   8.191 +lemma convex_unit_Rep_compact_basis [simp]:
   8.192 +  "{Rep_compact_basis a}\<natural> = convex_principal (PDUnit a)"
   8.193 +unfolding convex_unit_def
   8.194 +by (simp add: compact_basis.basis_fun_principal PDUnit_convex_mono)
   8.195 +
   8.196 +lemma convex_plus_principal [simp]:
   8.197 +  "convex_principal t +\<natural> convex_principal u = convex_principal (PDPlus t u)"
   8.198 +unfolding convex_plus_def
   8.199 +by (simp add: convex_pd.basis_fun_principal
   8.200 +    convex_pd.basis_fun_mono PDPlus_convex_mono)
   8.201 +
   8.202 +interpretation convex_add: semilattice convex_add proof
   8.203 +  fix xs ys zs :: "'a convex_pd"
   8.204 +  show "(xs +\<natural> ys) +\<natural> zs = xs +\<natural> (ys +\<natural> zs)"
   8.205 +    apply (induct xs ys arbitrary: zs rule: convex_pd.principal_induct2, simp, simp)
   8.206 +    apply (rule_tac x=zs in convex_pd.principal_induct, simp)
   8.207 +    apply (simp add: PDPlus_assoc)
   8.208 +    done
   8.209 +  show "xs +\<natural> ys = ys +\<natural> xs"
   8.210 +    apply (induct xs ys rule: convex_pd.principal_induct2, simp, simp)
   8.211 +    apply (simp add: PDPlus_commute)
   8.212 +    done
   8.213 +  show "xs +\<natural> xs = xs"
   8.214 +    apply (induct xs rule: convex_pd.principal_induct, simp)
   8.215 +    apply (simp add: PDPlus_absorb)
   8.216 +    done
   8.217 +qed
   8.218 +
   8.219 +lemmas convex_plus_assoc = convex_add.assoc
   8.220 +lemmas convex_plus_commute = convex_add.commute
   8.221 +lemmas convex_plus_absorb = convex_add.idem
   8.222 +lemmas convex_plus_left_commute = convex_add.left_commute
   8.223 +lemmas convex_plus_left_absorb = convex_add.left_idem
   8.224 +
   8.225 +text {* Useful for @{text "simp add: convex_plus_ac"} *}
   8.226 +lemmas convex_plus_ac =
   8.227 +  convex_plus_assoc convex_plus_commute convex_plus_left_commute
   8.228 +
   8.229 +text {* Useful for @{text "simp only: convex_plus_aci"} *}
   8.230 +lemmas convex_plus_aci =
   8.231 +  convex_plus_ac convex_plus_absorb convex_plus_left_absorb
   8.232 +
   8.233 +lemma convex_unit_below_plus_iff [simp]:
   8.234 +  "{x}\<natural> \<sqsubseteq> ys +\<natural> zs \<longleftrightarrow> {x}\<natural> \<sqsubseteq> ys \<and> {x}\<natural> \<sqsubseteq> zs"
   8.235 +apply (induct x rule: compact_basis.principal_induct, simp)
   8.236 +apply (induct ys rule: convex_pd.principal_induct, simp)
   8.237 +apply (induct zs rule: convex_pd.principal_induct, simp)
   8.238 +apply simp
   8.239 +done
   8.240 +
   8.241 +lemma convex_plus_below_unit_iff [simp]:
   8.242 +  "xs +\<natural> ys \<sqsubseteq> {z}\<natural> \<longleftrightarrow> xs \<sqsubseteq> {z}\<natural> \<and> ys \<sqsubseteq> {z}\<natural>"
   8.243 +apply (induct xs rule: convex_pd.principal_induct, simp)
   8.244 +apply (induct ys rule: convex_pd.principal_induct, simp)
   8.245 +apply (induct z rule: compact_basis.principal_induct, simp)
   8.246 +apply simp
   8.247 +done
   8.248 +
   8.249 +lemma convex_unit_below_iff [simp]: "{x}\<natural> \<sqsubseteq> {y}\<natural> \<longleftrightarrow> x \<sqsubseteq> y"
   8.250 +apply (induct x rule: compact_basis.principal_induct, simp)
   8.251 +apply (induct y rule: compact_basis.principal_induct, simp)
   8.252 +apply simp
   8.253 +done
   8.254 +
   8.255 +lemma convex_unit_eq_iff [simp]: "{x}\<natural> = {y}\<natural> \<longleftrightarrow> x = y"
   8.256 +unfolding po_eq_conv by simp
   8.257 +
   8.258 +lemma convex_unit_strict [simp]: "{\<bottom>}\<natural> = \<bottom>"
   8.259 +using convex_unit_Rep_compact_basis [of compact_bot]
   8.260 +by (simp add: inst_convex_pd_pcpo)
   8.261 +
   8.262 +lemma convex_unit_bottom_iff [simp]: "{x}\<natural> = \<bottom> \<longleftrightarrow> x = \<bottom>"
   8.263 +unfolding convex_unit_strict [symmetric] by (rule convex_unit_eq_iff)
   8.264 +
   8.265 +lemma compact_convex_unit: "compact x \<Longrightarrow> compact {x}\<natural>"
   8.266 +by (auto dest!: compact_basis.compact_imp_principal)
   8.267 +
   8.268 +lemma compact_convex_unit_iff [simp]: "compact {x}\<natural> \<longleftrightarrow> compact x"
   8.269 +apply (safe elim!: compact_convex_unit)
   8.270 +apply (simp only: compact_def convex_unit_below_iff [symmetric])
   8.271 +apply (erule adm_subst [OF cont_Rep_cfun2])
   8.272 +done
   8.273 +
   8.274 +lemma compact_convex_plus [simp]:
   8.275 +  "\<lbrakk>compact xs; compact ys\<rbrakk> \<Longrightarrow> compact (xs +\<natural> ys)"
   8.276 +by (auto dest!: convex_pd.compact_imp_principal)
   8.277 +
   8.278 +
   8.279 +subsection {* Induction rules *}
   8.280 +
   8.281 +lemma convex_pd_induct1:
   8.282 +  assumes P: "adm P"
   8.283 +  assumes unit: "\<And>x. P {x}\<natural>"
   8.284 +  assumes insert: "\<And>x ys. \<lbrakk>P {x}\<natural>; P ys\<rbrakk> \<Longrightarrow> P ({x}\<natural> +\<natural> ys)"
   8.285 +  shows "P (xs::'a convex_pd)"
   8.286 +apply (induct xs rule: convex_pd.principal_induct, rule P)
   8.287 +apply (induct_tac a rule: pd_basis_induct1)
   8.288 +apply (simp only: convex_unit_Rep_compact_basis [symmetric])
   8.289 +apply (rule unit)
   8.290 +apply (simp only: convex_unit_Rep_compact_basis [symmetric]
   8.291 +                  convex_plus_principal [symmetric])
   8.292 +apply (erule insert [OF unit])
   8.293 +done
   8.294 +
   8.295 +lemma convex_pd_induct
   8.296 +  [case_names adm convex_unit convex_plus, induct type: convex_pd]:
   8.297 +  assumes P: "adm P"
   8.298 +  assumes unit: "\<And>x. P {x}\<natural>"
   8.299 +  assumes plus: "\<And>xs ys. \<lbrakk>P xs; P ys\<rbrakk> \<Longrightarrow> P (xs +\<natural> ys)"
   8.300 +  shows "P (xs::'a convex_pd)"
   8.301 +apply (induct xs rule: convex_pd.principal_induct, rule P)
   8.302 +apply (induct_tac a rule: pd_basis_induct)
   8.303 +apply (simp only: convex_unit_Rep_compact_basis [symmetric] unit)
   8.304 +apply (simp only: convex_plus_principal [symmetric] plus)
   8.305 +done
   8.306 +
   8.307 +
   8.308 +subsection {* Monadic bind *}
   8.309 +
   8.310 +definition
   8.311 +  convex_bind_basis ::
   8.312 +  "'a pd_basis \<Rightarrow> ('a \<rightarrow> 'b convex_pd) \<rightarrow> 'b convex_pd" where
   8.313 +  "convex_bind_basis = fold_pd
   8.314 +    (\<lambda>a. \<Lambda> f. f\<cdot>(Rep_compact_basis a))
   8.315 +    (\<lambda>x y. \<Lambda> f. x\<cdot>f +\<natural> y\<cdot>f)"
   8.316 +
   8.317 +lemma ACI_convex_bind:
   8.318 +  "class.ab_semigroup_idem_mult (\<lambda>x y. \<Lambda> f. x\<cdot>f +\<natural> y\<cdot>f)"
   8.319 +apply unfold_locales
   8.320 +apply (simp add: convex_plus_assoc)
   8.321 +apply (simp add: convex_plus_commute)
   8.322 +apply (simp add: eta_cfun)
   8.323 +done
   8.324 +
   8.325 +lemma convex_bind_basis_simps [simp]:
   8.326 +  "convex_bind_basis (PDUnit a) =
   8.327 +    (\<Lambda> f. f\<cdot>(Rep_compact_basis a))"
   8.328 +  "convex_bind_basis (PDPlus t u) =
   8.329 +    (\<Lambda> f. convex_bind_basis t\<cdot>f +\<natural> convex_bind_basis u\<cdot>f)"
   8.330 +unfolding convex_bind_basis_def
   8.331 +apply -
   8.332 +apply (rule fold_pd_PDUnit [OF ACI_convex_bind])
   8.333 +apply (rule fold_pd_PDPlus [OF ACI_convex_bind])
   8.334 +done
   8.335 +
   8.336 +lemma convex_bind_basis_mono:
   8.337 +  "t \<le>\<natural> u \<Longrightarrow> convex_bind_basis t \<sqsubseteq> convex_bind_basis u"
   8.338 +apply (erule convex_le_induct)
   8.339 +apply (erule (1) below_trans)
   8.340 +apply (simp add: monofun_LAM monofun_cfun)
   8.341 +apply (simp add: monofun_LAM monofun_cfun)
   8.342 +done
   8.343 +
   8.344 +definition
   8.345 +  convex_bind :: "'a convex_pd \<rightarrow> ('a \<rightarrow> 'b convex_pd) \<rightarrow> 'b convex_pd" where
   8.346 +  "convex_bind = convex_pd.basis_fun convex_bind_basis"
   8.347 +
   8.348 +lemma convex_bind_principal [simp]:
   8.349 +  "convex_bind\<cdot>(convex_principal t) = convex_bind_basis t"
   8.350 +unfolding convex_bind_def
   8.351 +apply (rule convex_pd.basis_fun_principal)
   8.352 +apply (erule convex_bind_basis_mono)
   8.353 +done
   8.354 +
   8.355 +lemma convex_bind_unit [simp]:
   8.356 +  "convex_bind\<cdot>{x}\<natural>\<cdot>f = f\<cdot>x"
   8.357 +by (induct x rule: compact_basis.principal_induct, simp, simp)
   8.358 +
   8.359 +lemma convex_bind_plus [simp]:
   8.360 +  "convex_bind\<cdot>(xs +\<natural> ys)\<cdot>f = convex_bind\<cdot>xs\<cdot>f +\<natural> convex_bind\<cdot>ys\<cdot>f"
   8.361 +by (induct xs ys rule: convex_pd.principal_induct2, simp, simp, simp)
   8.362 +
   8.363 +lemma convex_bind_strict [simp]: "convex_bind\<cdot>\<bottom>\<cdot>f = f\<cdot>\<bottom>"
   8.364 +unfolding convex_unit_strict [symmetric] by (rule convex_bind_unit)
   8.365 +
   8.366 +lemma convex_bind_bind:
   8.367 +  "convex_bind\<cdot>(convex_bind\<cdot>xs\<cdot>f)\<cdot>g =
   8.368 +    convex_bind\<cdot>xs\<cdot>(\<Lambda> x. convex_bind\<cdot>(f\<cdot>x)\<cdot>g)"
   8.369 +by (induct xs, simp_all)
   8.370 +
   8.371 +
   8.372 +subsection {* Map *}
   8.373 +
   8.374 +definition
   8.375 +  convex_map :: "('a \<rightarrow> 'b) \<rightarrow> 'a convex_pd \<rightarrow> 'b convex_pd" where
   8.376 +  "convex_map = (\<Lambda> f xs. convex_bind\<cdot>xs\<cdot>(\<Lambda> x. {f\<cdot>x}\<natural>))"
   8.377 +
   8.378 +lemma convex_map_unit [simp]:
   8.379 +  "convex_map\<cdot>f\<cdot>{x}\<natural> = {f\<cdot>x}\<natural>"
   8.380 +unfolding convex_map_def by simp
   8.381 +
   8.382 +lemma convex_map_plus [simp]:
   8.383 +  "convex_map\<cdot>f\<cdot>(xs +\<natural> ys) = convex_map\<cdot>f\<cdot>xs +\<natural> convex_map\<cdot>f\<cdot>ys"
   8.384 +unfolding convex_map_def by simp
   8.385 +
   8.386 +lemma convex_map_bottom [simp]: "convex_map\<cdot>f\<cdot>\<bottom> = {f\<cdot>\<bottom>}\<natural>"
   8.387 +unfolding convex_map_def by simp
   8.388 +
   8.389 +lemma convex_map_ident: "convex_map\<cdot>(\<Lambda> x. x)\<cdot>xs = xs"
   8.390 +by (induct xs rule: convex_pd_induct, simp_all)
   8.391 +
   8.392 +lemma convex_map_ID: "convex_map\<cdot>ID = ID"
   8.393 +by (simp add: cfun_eq_iff ID_def convex_map_ident)
   8.394 +
   8.395 +lemma convex_map_map:
   8.396 +  "convex_map\<cdot>f\<cdot>(convex_map\<cdot>g\<cdot>xs) = convex_map\<cdot>(\<Lambda> x. f\<cdot>(g\<cdot>x))\<cdot>xs"
   8.397 +by (induct xs rule: convex_pd_induct, simp_all)
   8.398 +
   8.399 +lemma ep_pair_convex_map: "ep_pair e p \<Longrightarrow> ep_pair (convex_map\<cdot>e) (convex_map\<cdot>p)"
   8.400 +apply default
   8.401 +apply (induct_tac x rule: convex_pd_induct, simp_all add: ep_pair.e_inverse)
   8.402 +apply (induct_tac y rule: convex_pd_induct)
   8.403 +apply (simp_all add: ep_pair.e_p_below monofun_cfun)
   8.404 +done
   8.405 +
   8.406 +lemma deflation_convex_map: "deflation d \<Longrightarrow> deflation (convex_map\<cdot>d)"
   8.407 +apply default
   8.408 +apply (induct_tac x rule: convex_pd_induct, simp_all add: deflation.idem)
   8.409 +apply (induct_tac x rule: convex_pd_induct)
   8.410 +apply (simp_all add: deflation.below monofun_cfun)
   8.411 +done
   8.412 +
   8.413 +(* FIXME: long proof! *)
   8.414 +lemma finite_deflation_convex_map:
   8.415 +  assumes "finite_deflation d" shows "finite_deflation (convex_map\<cdot>d)"
   8.416 +proof (rule finite_deflation_intro)
   8.417 +  interpret d: finite_deflation d by fact
   8.418 +  have "deflation d" by fact
   8.419 +  thus "deflation (convex_map\<cdot>d)" by (rule deflation_convex_map)
   8.420 +  have "finite (range (\<lambda>x. d\<cdot>x))" by (rule d.finite_range)
   8.421 +  hence "finite (Rep_compact_basis -` range (\<lambda>x. d\<cdot>x))"
   8.422 +    by (rule finite_vimageI, simp add: inj_on_def Rep_compact_basis_inject)
   8.423 +  hence "finite (Pow (Rep_compact_basis -` range (\<lambda>x. d\<cdot>x)))" by simp
   8.424 +  hence "finite (Rep_pd_basis -` (Pow (Rep_compact_basis -` range (\<lambda>x. d\<cdot>x))))"
   8.425 +    by (rule finite_vimageI, simp add: inj_on_def Rep_pd_basis_inject)
   8.426 +  hence *: "finite (convex_principal ` Rep_pd_basis -` (Pow (Rep_compact_basis -` range (\<lambda>x. d\<cdot>x))))" by simp
   8.427 +  hence "finite (range (\<lambda>xs. convex_map\<cdot>d\<cdot>xs))"
   8.428 +    apply (rule rev_finite_subset)
   8.429 +    apply clarsimp
   8.430 +    apply (induct_tac xs rule: convex_pd.principal_induct)
   8.431 +    apply (simp add: adm_mem_finite *)
   8.432 +    apply (rename_tac t, induct_tac t rule: pd_basis_induct)
   8.433 +    apply (simp only: convex_unit_Rep_compact_basis [symmetric] convex_map_unit)
   8.434 +    apply simp
   8.435 +    apply (subgoal_tac "\<exists>b. d\<cdot>(Rep_compact_basis a) = Rep_compact_basis b")
   8.436 +    apply clarsimp
   8.437 +    apply (rule imageI)
   8.438 +    apply (rule vimageI2)
   8.439 +    apply (simp add: Rep_PDUnit)
   8.440 +    apply (rule range_eqI)
   8.441 +    apply (erule sym)
   8.442 +    apply (rule exI)
   8.443 +    apply (rule Abs_compact_basis_inverse [symmetric])
   8.444 +    apply (simp add: d.compact)
   8.445 +    apply (simp only: convex_plus_principal [symmetric] convex_map_plus)
   8.446 +    apply clarsimp
   8.447 +    apply (rule imageI)
   8.448 +    apply (rule vimageI2)
   8.449 +    apply (simp add: Rep_PDPlus)
   8.450 +    done
   8.451 +  thus "finite {xs. convex_map\<cdot>d\<cdot>xs = xs}"
   8.452 +    by (rule finite_range_imp_finite_fixes)
   8.453 +qed
   8.454 +
   8.455 +subsection {* Convex powerdomain is a domain *}
   8.456 +
   8.457 +definition
   8.458 +  convex_approx :: "nat \<Rightarrow> udom convex_pd \<rightarrow> udom convex_pd"
   8.459 +where
   8.460 +  "convex_approx = (\<lambda>i. convex_map\<cdot>(udom_approx i))"
   8.461 +
   8.462 +lemma convex_approx: "approx_chain convex_approx"
   8.463 +using convex_map_ID finite_deflation_convex_map
   8.464 +unfolding convex_approx_def by (rule approx_chain_lemma1)
   8.465 +
   8.466 +definition convex_defl :: "defl \<rightarrow> defl"
   8.467 +where "convex_defl = defl_fun1 convex_approx convex_map"
   8.468 +
   8.469 +lemma cast_convex_defl:
   8.470 +  "cast\<cdot>(convex_defl\<cdot>A) =
   8.471 +    udom_emb convex_approx oo convex_map\<cdot>(cast\<cdot>A) oo udom_prj convex_approx"
   8.472 +using convex_approx finite_deflation_convex_map
   8.473 +unfolding convex_defl_def by (rule cast_defl_fun1)
   8.474 +
   8.475 +instantiation convex_pd :: ("domain") liftdomain
   8.476 +begin
   8.477 +
   8.478 +definition
   8.479 +  "emb = udom_emb convex_approx oo convex_map\<cdot>emb"
   8.480 +
   8.481 +definition
   8.482 +  "prj = convex_map\<cdot>prj oo udom_prj convex_approx"
   8.483 +
   8.484 +definition
   8.485 +  "defl (t::'a convex_pd itself) = convex_defl\<cdot>DEFL('a)"
   8.486 +
   8.487 +definition
   8.488 +  "(liftemb :: 'a convex_pd u \<rightarrow> udom) = udom_emb u_approx oo u_map\<cdot>emb"
   8.489 +
   8.490 +definition
   8.491 +  "(liftprj :: udom \<rightarrow> 'a convex_pd u) = u_map\<cdot>prj oo udom_prj u_approx"
   8.492 +
   8.493 +definition
   8.494 +  "liftdefl (t::'a convex_pd itself) = u_defl\<cdot>DEFL('a convex_pd)"
   8.495 +
   8.496 +instance
   8.497 +using liftemb_convex_pd_def liftprj_convex_pd_def liftdefl_convex_pd_def
   8.498 +proof (rule liftdomain_class_intro)
   8.499 +  show "ep_pair emb (prj :: udom \<rightarrow> 'a convex_pd)"
   8.500 +    unfolding emb_convex_pd_def prj_convex_pd_def
   8.501 +    using ep_pair_udom [OF convex_approx]
   8.502 +    by (intro ep_pair_comp ep_pair_convex_map ep_pair_emb_prj)
   8.503 +next
   8.504 +  show "cast\<cdot>DEFL('a convex_pd) = emb oo (prj :: udom \<rightarrow> 'a convex_pd)"
   8.505 +    unfolding emb_convex_pd_def prj_convex_pd_def defl_convex_pd_def cast_convex_defl
   8.506 +    by (simp add: cast_DEFL oo_def cfun_eq_iff convex_map_map)
   8.507 +qed
   8.508 +
   8.509 +end
   8.510 +
   8.511 +text {* DEFL of type constructor = type combinator *}
   8.512 +
   8.513 +lemma DEFL_convex: "DEFL('a convex_pd) = convex_defl\<cdot>DEFL('a)"
   8.514 +by (rule defl_convex_pd_def)
   8.515 +
   8.516 +
   8.517 +subsection {* Join *}
   8.518 +
   8.519 +definition
   8.520 +  convex_join :: "'a convex_pd convex_pd \<rightarrow> 'a convex_pd" where
   8.521 +  "convex_join = (\<Lambda> xss. convex_bind\<cdot>xss\<cdot>(\<Lambda> xs. xs))"
   8.522 +
   8.523 +lemma convex_join_unit [simp]:
   8.524 +  "convex_join\<cdot>{xs}\<natural> = xs"
   8.525 +unfolding convex_join_def by simp
   8.526 +
   8.527 +lemma convex_join_plus [simp]:
   8.528 +  "convex_join\<cdot>(xss +\<natural> yss) = convex_join\<cdot>xss +\<natural> convex_join\<cdot>yss"
   8.529 +unfolding convex_join_def by simp
   8.530 +
   8.531 +lemma convex_join_bottom [simp]: "convex_join\<cdot>\<bottom> = \<bottom>"
   8.532 +unfolding convex_join_def by simp
   8.533 +
   8.534 +lemma convex_join_map_unit:
   8.535 +  "convex_join\<cdot>(convex_map\<cdot>convex_unit\<cdot>xs) = xs"
   8.536 +by (induct xs rule: convex_pd_induct, simp_all)
   8.537 +
   8.538 +lemma convex_join_map_join:
   8.539 +  "convex_join\<cdot>(convex_map\<cdot>convex_join\<cdot>xsss) = convex_join\<cdot>(convex_join\<cdot>xsss)"
   8.540 +by (induct xsss rule: convex_pd_induct, simp_all)
   8.541 +
   8.542 +lemma convex_join_map_map:
   8.543 +  "convex_join\<cdot>(convex_map\<cdot>(convex_map\<cdot>f)\<cdot>xss) =
   8.544 +   convex_map\<cdot>f\<cdot>(convex_join\<cdot>xss)"
   8.545 +by (induct xss rule: convex_pd_induct, simp_all)
   8.546 +
   8.547 +
   8.548 +subsection {* Conversions to other powerdomains *}
   8.549 +
   8.550 +text {* Convex to upper *}
   8.551 +
   8.552 +lemma convex_le_imp_upper_le: "t \<le>\<natural> u \<Longrightarrow> t \<le>\<sharp> u"
   8.553 +unfolding convex_le_def by simp
   8.554 +
   8.555 +definition
   8.556 +  convex_to_upper :: "'a convex_pd \<rightarrow> 'a upper_pd" where
   8.557 +  "convex_to_upper = convex_pd.basis_fun upper_principal"
   8.558 +
   8.559 +lemma convex_to_upper_principal [simp]:
   8.560 +  "convex_to_upper\<cdot>(convex_principal t) = upper_principal t"
   8.561 +unfolding convex_to_upper_def
   8.562 +apply (rule convex_pd.basis_fun_principal)
   8.563 +apply (rule upper_pd.principal_mono)
   8.564 +apply (erule convex_le_imp_upper_le)
   8.565 +done
   8.566 +
   8.567 +lemma convex_to_upper_unit [simp]:
   8.568 +  "convex_to_upper\<cdot>{x}\<natural> = {x}\<sharp>"
   8.569 +by (induct x rule: compact_basis.principal_induct, simp, simp)
   8.570 +
   8.571 +lemma convex_to_upper_plus [simp]:
   8.572 +  "convex_to_upper\<cdot>(xs +\<natural> ys) = convex_to_upper\<cdot>xs +\<sharp> convex_to_upper\<cdot>ys"
   8.573 +by (induct xs ys rule: convex_pd.principal_induct2, simp, simp, simp)
   8.574 +
   8.575 +lemma convex_to_upper_bind [simp]:
   8.576 +  "convex_to_upper\<cdot>(convex_bind\<cdot>xs\<cdot>f) =
   8.577 +    upper_bind\<cdot>(convex_to_upper\<cdot>xs)\<cdot>(convex_to_upper oo f)"
   8.578 +by (induct xs rule: convex_pd_induct, simp, simp, simp)
   8.579 +
   8.580 +lemma convex_to_upper_map [simp]:
   8.581 +  "convex_to_upper\<cdot>(convex_map\<cdot>f\<cdot>xs) = upper_map\<cdot>f\<cdot>(convex_to_upper\<cdot>xs)"
   8.582 +by (simp add: convex_map_def upper_map_def cfcomp_LAM)
   8.583 +
   8.584 +lemma convex_to_upper_join [simp]:
   8.585 +  "convex_to_upper\<cdot>(convex_join\<cdot>xss) =
   8.586 +    upper_bind\<cdot>(convex_to_upper\<cdot>xss)\<cdot>convex_to_upper"
   8.587 +by (simp add: convex_join_def upper_join_def cfcomp_LAM eta_cfun)
   8.588 +
   8.589 +text {* Convex to lower *}
   8.590 +
   8.591 +lemma convex_le_imp_lower_le: "t \<le>\<natural> u \<Longrightarrow> t \<le>\<flat> u"
   8.592 +unfolding convex_le_def by simp
   8.593 +
   8.594 +definition
   8.595 +  convex_to_lower :: "'a convex_pd \<rightarrow> 'a lower_pd" where
   8.596 +  "convex_to_lower = convex_pd.basis_fun lower_principal"
   8.597 +
   8.598 +lemma convex_to_lower_principal [simp]:
   8.599 +  "convex_to_lower\<cdot>(convex_principal t) = lower_principal t"
   8.600 +unfolding convex_to_lower_def
   8.601 +apply (rule convex_pd.basis_fun_principal)
   8.602 +apply (rule lower_pd.principal_mono)
   8.603 +apply (erule convex_le_imp_lower_le)
   8.604 +done
   8.605 +
   8.606 +lemma convex_to_lower_unit [simp]:
   8.607 +  "convex_to_lower\<cdot>{x}\<natural> = {x}\<flat>"
   8.608 +by (induct x rule: compact_basis.principal_induct, simp, simp)
   8.609 +
   8.610 +lemma convex_to_lower_plus [simp]:
   8.611 +  "convex_to_lower\<cdot>(xs +\<natural> ys) = convex_to_lower\<cdot>xs +\<flat> convex_to_lower\<cdot>ys"
   8.612 +by (induct xs ys rule: convex_pd.principal_induct2, simp, simp, simp)
   8.613 +
   8.614 +lemma convex_to_lower_bind [simp]:
   8.615 +  "convex_to_lower\<cdot>(convex_bind\<cdot>xs\<cdot>f) =
   8.616 +    lower_bind\<cdot>(convex_to_lower\<cdot>xs)\<cdot>(convex_to_lower oo f)"
   8.617 +by (induct xs rule: convex_pd_induct, simp, simp, simp)
   8.618 +
   8.619 +lemma convex_to_lower_map [simp]:
   8.620 +  "convex_to_lower\<cdot>(convex_map\<cdot>f\<cdot>xs) = lower_map\<cdot>f\<cdot>(convex_to_lower\<cdot>xs)"
   8.621 +by (simp add: convex_map_def lower_map_def cfcomp_LAM)
   8.622 +
   8.623 +lemma convex_to_lower_join [simp]:
   8.624 +  "convex_to_lower\<cdot>(convex_join\<cdot>xss) =
   8.625 +    lower_bind\<cdot>(convex_to_lower\<cdot>xss)\<cdot>convex_to_lower"
   8.626 +by (simp add: convex_join_def lower_join_def cfcomp_LAM eta_cfun)
   8.627 +
   8.628 +text {* Ordering property *}
   8.629 +
   8.630 +lemma convex_pd_below_iff:
   8.631 +  "(xs \<sqsubseteq> ys) =
   8.632 +    (convex_to_upper\<cdot>xs \<sqsubseteq> convex_to_upper\<cdot>ys \<and>
   8.633 +     convex_to_lower\<cdot>xs \<sqsubseteq> convex_to_lower\<cdot>ys)"
   8.634 +apply (induct xs rule: convex_pd.principal_induct, simp)
   8.635 +apply (induct ys rule: convex_pd.principal_induct, simp)
   8.636 +apply (simp add: convex_le_def)
   8.637 +done
   8.638 +
   8.639 +lemmas convex_plus_below_plus_iff =
   8.640 +  convex_pd_below_iff [where xs="xs +\<natural> ys" and ys="zs +\<natural> ws", standard]
   8.641 +
   8.642 +lemmas convex_pd_below_simps =
   8.643 +  convex_unit_below_plus_iff
   8.644 +  convex_plus_below_unit_iff
   8.645 +  convex_plus_below_plus_iff
   8.646 +  convex_unit_below_iff
   8.647 +  convex_to_upper_unit
   8.648 +  convex_to_upper_plus
   8.649 +  convex_to_lower_unit
   8.650 +  convex_to_lower_plus
   8.651 +  upper_pd_below_simps
   8.652 +  lower_pd_below_simps
   8.653 +
   8.654 +end
     9.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     9.2 +++ b/src/HOL/HOLCF/Cpodef.thy	Sat Nov 27 16:08:10 2010 -0800
     9.3 @@ -0,0 +1,285 @@
     9.4 +(*  Title:      HOLCF/Pcpodef.thy
     9.5 +    Author:     Brian Huffman
     9.6 +*)
     9.7 +
     9.8 +header {* Subtypes of pcpos *}
     9.9 +
    9.10 +theory Cpodef
    9.11 +imports Adm
    9.12 +uses ("Tools/cpodef.ML")
    9.13 +begin
    9.14 +
    9.15 +subsection {* Proving a subtype is a partial order *}
    9.16 +
    9.17 +text {*
    9.18 +  A subtype of a partial order is itself a partial order,
    9.19 +  if the ordering is defined in the standard way.
    9.20 +*}
    9.21 +
    9.22 +setup {* Sign.add_const_constraint (@{const_name Porder.below}, NONE) *}
    9.23 +
    9.24 +theorem typedef_po:
    9.25 +  fixes Abs :: "'a::po \<Rightarrow> 'b::type"
    9.26 +  assumes type: "type_definition Rep Abs A"
    9.27 +    and below: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
    9.28 +  shows "OFCLASS('b, po_class)"
    9.29 + apply (intro_classes, unfold below)
    9.30 +   apply (rule below_refl)
    9.31 +  apply (erule (1) below_trans)
    9.32 + apply (rule type_definition.Rep_inject [OF type, THEN iffD1])
    9.33 + apply (erule (1) below_antisym)
    9.34 +done
    9.35 +
    9.36 +setup {* Sign.add_const_constraint (@{const_name Porder.below},
    9.37 +  SOME @{typ "'a::below \<Rightarrow> 'a::below \<Rightarrow> bool"}) *}
    9.38 +
    9.39 +subsection {* Proving a subtype is finite *}
    9.40 +
    9.41 +lemma typedef_finite_UNIV:
    9.42 +  fixes Abs :: "'a::type \<Rightarrow> 'b::type"
    9.43 +  assumes type: "type_definition Rep Abs A"
    9.44 +  shows "finite A \<Longrightarrow> finite (UNIV :: 'b set)"
    9.45 +proof -
    9.46 +  assume "finite A"
    9.47 +  hence "finite (Abs ` A)" by (rule finite_imageI)
    9.48 +  thus "finite (UNIV :: 'b set)"
    9.49 +    by (simp only: type_definition.Abs_image [OF type])
    9.50 +qed
    9.51 +
    9.52 +subsection {* Proving a subtype is chain-finite *}
    9.53 +
    9.54 +lemma ch2ch_Rep:
    9.55 +  assumes below: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
    9.56 +  shows "chain S \<Longrightarrow> chain (\<lambda>i. Rep (S i))"
    9.57 +unfolding chain_def below .
    9.58 +
    9.59 +theorem typedef_chfin:
    9.60 +  fixes Abs :: "'a::chfin \<Rightarrow> 'b::po"
    9.61 +  assumes type: "type_definition Rep Abs A"
    9.62 +    and below: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
    9.63 +  shows "OFCLASS('b, chfin_class)"
    9.64 + apply intro_classes
    9.65 + apply (drule ch2ch_Rep [OF below])
    9.66 + apply (drule chfin)
    9.67 + apply (unfold max_in_chain_def)
    9.68 + apply (simp add: type_definition.Rep_inject [OF type])
    9.69 +done
    9.70 +
    9.71 +subsection {* Proving a subtype is complete *}
    9.72 +
    9.73 +text {*
    9.74 +  A subtype of a cpo is itself a cpo if the ordering is
    9.75 +  defined in the standard way, and the defining subset
    9.76 +  is closed with respect to limits of chains.  A set is
    9.77 +  closed if and only if membership in the set is an
    9.78 +  admissible predicate.
    9.79 +*}
    9.80 +
    9.81 +lemma typedef_is_lubI:
    9.82 +  assumes below: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
    9.83 +  shows "range (\<lambda>i. Rep (S i)) <<| Rep x \<Longrightarrow> range S <<| x"
    9.84 +unfolding is_lub_def is_ub_def below by simp
    9.85 +
    9.86 +lemma Abs_inverse_lub_Rep:
    9.87 +  fixes Abs :: "'a::cpo \<Rightarrow> 'b::po"
    9.88 +  assumes type: "type_definition Rep Abs A"
    9.89 +    and below: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
    9.90 +    and adm:  "adm (\<lambda>x. x \<in> A)"
    9.91 +  shows "chain S \<Longrightarrow> Rep (Abs (\<Squnion>i. Rep (S i))) = (\<Squnion>i. Rep (S i))"
    9.92 + apply (rule type_definition.Abs_inverse [OF type])
    9.93 + apply (erule admD [OF adm ch2ch_Rep [OF below]])
    9.94 + apply (rule type_definition.Rep [OF type])
    9.95 +done
    9.96 +
    9.97 +theorem typedef_is_lub:
    9.98 +  fixes Abs :: "'a::cpo \<Rightarrow> 'b::po"
    9.99 +  assumes type: "type_definition Rep Abs A"
   9.100 +    and below: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
   9.101 +    and adm: "adm (\<lambda>x. x \<in> A)"
   9.102 +  shows "chain S \<Longrightarrow> range S <<| Abs (\<Squnion>i. Rep (S i))"
   9.103 +proof -
   9.104 +  assume S: "chain S"
   9.105 +  hence "chain (\<lambda>i. Rep (S i))" by (rule ch2ch_Rep [OF below])
   9.106 +  hence "range (\<lambda>i. Rep (S i)) <<| (\<Squnion>i. Rep (S i))" by (rule cpo_lubI)
   9.107 +  hence "range (\<lambda>i. Rep (S i)) <<| Rep (Abs (\<Squnion>i. Rep (S i)))"
   9.108 +    by (simp only: Abs_inverse_lub_Rep [OF type below adm S])
   9.109 +  thus "range S <<| Abs (\<Squnion>i. Rep (S i))"
   9.110 +    by (rule typedef_is_lubI [OF below])
   9.111 +qed
   9.112 +
   9.113 +lemmas typedef_lub = typedef_is_lub [THEN lub_eqI, standard]
   9.114 +
   9.115 +theorem typedef_cpo:
   9.116 +  fixes Abs :: "'a::cpo \<Rightarrow> 'b::po"
   9.117 +  assumes type: "type_definition Rep Abs A"
   9.118 +    and below: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
   9.119 +    and adm: "adm (\<lambda>x. x \<in> A)"
   9.120 +  shows "OFCLASS('b, cpo_class)"
   9.121 +proof
   9.122 +  fix S::"nat \<Rightarrow> 'b" assume "chain S"
   9.123 +  hence "range S <<| Abs (\<Squnion>i. Rep (S i))"
   9.124 +    by (rule typedef_is_lub [OF type below adm])
   9.125 +  thus "\<exists>x. range S <<| x" ..
   9.126 +qed
   9.127 +
   9.128 +subsubsection {* Continuity of \emph{Rep} and \emph{Abs} *}
   9.129 +
   9.130 +text {* For any sub-cpo, the @{term Rep} function is continuous. *}
   9.131 +
   9.132 +theorem typedef_cont_Rep:
   9.133 +  fixes Abs :: "'a::cpo \<Rightarrow> 'b::cpo"
   9.134 +  assumes type: "type_definition Rep Abs A"
   9.135 +    and below: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
   9.136 +    and adm: "adm (\<lambda>x. x \<in> A)"
   9.137 +  shows "cont Rep"
   9.138 + apply (rule contI)
   9.139 + apply (simp only: typedef_lub [OF type below adm])
   9.140 + apply (simp only: Abs_inverse_lub_Rep [OF type below adm])
   9.141 + apply (rule cpo_lubI)
   9.142 + apply (erule ch2ch_Rep [OF below])
   9.143 +done
   9.144 +
   9.145 +text {*
   9.146 +  For a sub-cpo, we can make the @{term Abs} function continuous
   9.147 +  only if we restrict its domain to the defining subset by
   9.148 +  composing it with another continuous function.
   9.149 +*}
   9.150 +
   9.151 +theorem typedef_cont_Abs:
   9.152 +  fixes Abs :: "'a::cpo \<Rightarrow> 'b::cpo"
   9.153 +  fixes f :: "'c::cpo \<Rightarrow> 'a::cpo"
   9.154 +  assumes type: "type_definition Rep Abs A"
   9.155 +    and below: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
   9.156 +    and adm: "adm (\<lambda>x. x \<in> A)" (* not used *)
   9.157 +    and f_in_A: "\<And>x. f x \<in> A"
   9.158 +  shows "cont f \<Longrightarrow> cont (\<lambda>x. Abs (f x))"
   9.159 +unfolding cont_def is_lub_def is_ub_def ball_simps below
   9.160 +by (simp add: type_definition.Abs_inverse [OF type f_in_A])
   9.161 +
   9.162 +subsection {* Proving subtype elements are compact *}
   9.163 +
   9.164 +theorem typedef_compact:
   9.165 +  fixes Abs :: "'a::cpo \<Rightarrow> 'b::cpo"
   9.166 +  assumes type: "type_definition Rep Abs A"
   9.167 +    and below: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
   9.168 +    and adm: "adm (\<lambda>x. x \<in> A)"
   9.169 +  shows "compact (Rep k) \<Longrightarrow> compact k"
   9.170 +proof (unfold compact_def)
   9.171 +  have cont_Rep: "cont Rep"
   9.172 +    by (rule typedef_cont_Rep [OF type below adm])
   9.173 +  assume "adm (\<lambda>x. \<not> Rep k \<sqsubseteq> x)"
   9.174 +  with cont_Rep have "adm (\<lambda>x. \<not> Rep k \<sqsubseteq> Rep x)" by (rule adm_subst)
   9.175 +  thus "adm (\<lambda>x. \<not> k \<sqsubseteq> x)" by (unfold below)
   9.176 +qed
   9.177 +
   9.178 +subsection {* Proving a subtype is pointed *}
   9.179 +
   9.180 +text {*
   9.181 +  A subtype of a cpo has a least element if and only if
   9.182 +  the defining subset has a least element.
   9.183 +*}
   9.184 +
   9.185 +theorem typedef_pcpo_generic:
   9.186 +  fixes Abs :: "'a::cpo \<Rightarrow> 'b::cpo"
   9.187 +  assumes type: "type_definition Rep Abs A"
   9.188 +    and below: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
   9.189 +    and z_in_A: "z \<in> A"
   9.190 +    and z_least: "\<And>x. x \<in> A \<Longrightarrow> z \<sqsubseteq> x"
   9.191 +  shows "OFCLASS('b, pcpo_class)"
   9.192 + apply (intro_classes)
   9.193 + apply (rule_tac x="Abs z" in exI, rule allI)
   9.194 + apply (unfold below)
   9.195 + apply (subst type_definition.Abs_inverse [OF type z_in_A])
   9.196 + apply (rule z_least [OF type_definition.Rep [OF type]])
   9.197 +done
   9.198 +
   9.199 +text {*
   9.200 +  As a special case, a subtype of a pcpo has a least element
   9.201 +  if the defining subset contains @{term \<bottom>}.
   9.202 +*}
   9.203 +
   9.204 +theorem typedef_pcpo:
   9.205 +  fixes Abs :: "'a::pcpo \<Rightarrow> 'b::cpo"
   9.206 +  assumes type: "type_definition Rep Abs A"
   9.207 +    and below: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
   9.208 +    and UU_in_A: "\<bottom> \<in> A"
   9.209 +  shows "OFCLASS('b, pcpo_class)"
   9.210 +by (rule typedef_pcpo_generic [OF type below UU_in_A], rule minimal)
   9.211 +
   9.212 +subsubsection {* Strictness of \emph{Rep} and \emph{Abs} *}
   9.213 +
   9.214 +text {*
   9.215 +  For a sub-pcpo where @{term \<bottom>} is a member of the defining
   9.216 +  subset, @{term Rep} and @{term Abs} are both strict.
   9.217 +*}
   9.218 +
   9.219 +theorem typedef_Abs_strict:
   9.220 +  assumes type: "type_definition Rep Abs A"
   9.221 +    and below: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
   9.222 +    and UU_in_A: "\<bottom> \<in> A"
   9.223 +  shows "Abs \<bottom> = \<bottom>"
   9.224 + apply (rule UU_I, unfold below)
   9.225 + apply (simp add: type_definition.Abs_inverse [OF type UU_in_A])
   9.226 +done
   9.227 +
   9.228 +theorem typedef_Rep_strict:
   9.229 +  assumes type: "type_definition Rep Abs A"
   9.230 +    and below: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
   9.231 +    and UU_in_A: "\<bottom> \<in> A"
   9.232 +  shows "Rep \<bottom> = \<bottom>"
   9.233 + apply (rule typedef_Abs_strict [OF type below UU_in_A, THEN subst])
   9.234 + apply (rule type_definition.Abs_inverse [OF type UU_in_A])
   9.235 +done
   9.236 +
   9.237 +theorem typedef_Abs_bottom_iff:
   9.238 +  assumes type: "type_definition Rep Abs A"
   9.239 +    and below: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
   9.240 +    and UU_in_A: "\<bottom> \<in> A"
   9.241 +  shows "x \<in> A \<Longrightarrow> (Abs x = \<bottom>) = (x = \<bottom>)"
   9.242 + apply (rule typedef_Abs_strict [OF type below UU_in_A, THEN subst])
   9.243 + apply (simp add: type_definition.Abs_inject [OF type] UU_in_A)
   9.244 +done
   9.245 +
   9.246 +theorem typedef_Rep_bottom_iff:
   9.247 +  assumes type: "type_definition Rep Abs A"
   9.248 +    and below: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
   9.249 +    and UU_in_A: "\<bottom> \<in> A"
   9.250 +  shows "(Rep x = \<bottom>) = (x = \<bottom>)"
   9.251 + apply (rule typedef_Rep_strict [OF type below UU_in_A, THEN subst])
   9.252 + apply (simp add: type_definition.Rep_inject [OF type])
   9.253 +done
   9.254 +
   9.255 +theorem typedef_Abs_defined:
   9.256 +  assumes type: "type_definition Rep Abs A"
   9.257 +    and below: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
   9.258 +    and UU_in_A: "\<bottom> \<in> A"
   9.259 +  shows "\<lbrakk>x \<noteq> \<bottom>; x \<in> A\<rbrakk> \<Longrightarrow> Abs x \<noteq> \<bottom>"
   9.260 +by (simp add: typedef_Abs_bottom_iff [OF type below UU_in_A])
   9.261 +
   9.262 +theorem typedef_Rep_defined:
   9.263 +  assumes type: "type_definition Rep Abs A"
   9.264 +    and below: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
   9.265 +    and UU_in_A: "\<bottom> \<in> A"
   9.266 +  shows "x \<noteq> \<bottom> \<Longrightarrow> Rep x \<noteq> \<bottom>"
   9.267 +by (simp add: typedef_Rep_bottom_iff [OF type below UU_in_A])
   9.268 +
   9.269 +subsection {* Proving a subtype is flat *}
   9.270 +
   9.271 +theorem typedef_flat:
   9.272 +  fixes Abs :: "'a::flat \<Rightarrow> 'b::pcpo"
   9.273 +  assumes type: "type_definition Rep Abs A"
   9.274 +    and below: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
   9.275 +    and UU_in_A: "\<bottom> \<in> A"
   9.276 +  shows "OFCLASS('b, flat_class)"
   9.277 + apply (intro_classes)
   9.278 + apply (unfold below)
   9.279 + apply (simp add: type_definition.Rep_inject [OF type, symmetric])
   9.280 + apply (simp add: typedef_Rep_strict [OF type below UU_in_A])
   9.281 + apply (simp add: ax_flat)
   9.282 +done
   9.283 +
   9.284 +subsection {* HOLCF type definition package *}
   9.285 +
   9.286 +use "Tools/cpodef.ML"
   9.287 +
   9.288 +end
    10.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    10.2 +++ b/src/HOL/HOLCF/Cprod.thy	Sat Nov 27 16:08:10 2010 -0800
    10.3 @@ -0,0 +1,43 @@
    10.4 +(*  Title:      HOLCF/Cprod.thy
    10.5 +    Author:     Franz Regensburger
    10.6 +*)
    10.7 +
    10.8 +header {* The cpo of cartesian products *}
    10.9 +
   10.10 +theory Cprod
   10.11 +imports Cfun
   10.12 +begin
   10.13 +
   10.14 +default_sort cpo
   10.15 +
   10.16 +subsection {* Continuous case function for unit type *}
   10.17 +
   10.18 +definition
   10.19 +  unit_when :: "'a \<rightarrow> unit \<rightarrow> 'a" where
   10.20 +  "unit_when = (\<Lambda> a _. a)"
   10.21 +
   10.22 +translations
   10.23 +  "\<Lambda>(). t" == "CONST unit_when\<cdot>t"
   10.24 +
   10.25 +lemma unit_when [simp]: "unit_when\<cdot>a\<cdot>u = a"
   10.26 +by (simp add: unit_when_def)
   10.27 +
   10.28 +subsection {* Continuous version of split function *}
   10.29 +
   10.30 +definition
   10.31 +  csplit :: "('a \<rightarrow> 'b \<rightarrow> 'c) \<rightarrow> ('a * 'b) \<rightarrow> 'c" where
   10.32 +  "csplit = (\<Lambda> f p. f\<cdot>(fst p)\<cdot>(snd p))"
   10.33 +
   10.34 +translations
   10.35 +  "\<Lambda>(CONST Pair x y). t" == "CONST csplit\<cdot>(\<Lambda> x y. t)"
   10.36 +
   10.37 +
   10.38 +subsection {* Convert all lemmas to the continuous versions *}
   10.39 +
   10.40 +lemma csplit1 [simp]: "csplit\<cdot>f\<cdot>\<bottom> = f\<cdot>\<bottom>\<cdot>\<bottom>"
   10.41 +by (simp add: csplit_def)
   10.42 +
   10.43 +lemma csplit_Pair [simp]: "csplit\<cdot>f\<cdot>(x, y) = f\<cdot>x\<cdot>y"
   10.44 +by (simp add: csplit_def)
   10.45 +
   10.46 +end
    11.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    11.2 +++ b/src/HOL/HOLCF/Deflation.thy	Sat Nov 27 16:08:10 2010 -0800
    11.3 @@ -0,0 +1,408 @@
    11.4 +(*  Title:      HOLCF/Deflation.thy
    11.5 +    Author:     Brian Huffman
    11.6 +*)
    11.7 +
    11.8 +header {* Continuous deflations and ep-pairs *}
    11.9 +
   11.10 +theory Deflation
   11.11 +imports Plain_HOLCF
   11.12 +begin
   11.13 +
   11.14 +default_sort cpo
   11.15 +
   11.16 +subsection {* Continuous deflations *}
   11.17 +
   11.18 +locale deflation =
   11.19 +  fixes d :: "'a \<rightarrow> 'a"
   11.20 +  assumes idem: "\<And>x. d\<cdot>(d\<cdot>x) = d\<cdot>x"
   11.21 +  assumes below: "\<And>x. d\<cdot>x \<sqsubseteq> x"
   11.22 +begin
   11.23 +
   11.24 +lemma below_ID: "d \<sqsubseteq> ID"
   11.25 +by (rule cfun_belowI, simp add: below)
   11.26 +
   11.27 +text {* The set of fixed points is the same as the range. *}
   11.28 +
   11.29 +lemma fixes_eq_range: "{x. d\<cdot>x = x} = range (\<lambda>x. d\<cdot>x)"
   11.30 +by (auto simp add: eq_sym_conv idem)
   11.31 +
   11.32 +lemma range_eq_fixes: "range (\<lambda>x. d\<cdot>x) = {x. d\<cdot>x = x}"
   11.33 +by (auto simp add: eq_sym_conv idem)
   11.34 +
   11.35 +text {*
   11.36 +  The pointwise ordering on deflation functions coincides with
   11.37 +  the subset ordering of their sets of fixed-points.
   11.38 +*}
   11.39 +
   11.40 +lemma belowI:
   11.41 +  assumes f: "\<And>x. d\<cdot>x = x \<Longrightarrow> f\<cdot>x = x" shows "d \<sqsubseteq> f"
   11.42 +proof (rule cfun_belowI)
   11.43 +  fix x
   11.44 +  from below have "f\<cdot>(d\<cdot>x) \<sqsubseteq> f\<cdot>x" by (rule monofun_cfun_arg)
   11.45 +  also from idem have "f\<cdot>(d\<cdot>x) = d\<cdot>x" by (rule f)
   11.46 +  finally show "d\<cdot>x \<sqsubseteq> f\<cdot>x" .
   11.47 +qed
   11.48 +
   11.49 +lemma belowD: "\<lbrakk>f \<sqsubseteq> d; f\<cdot>x = x\<rbrakk> \<Longrightarrow> d\<cdot>x = x"
   11.50 +proof (rule below_antisym)
   11.51 +  from below show "d\<cdot>x \<sqsubseteq> x" .
   11.52 +next
   11.53 +  assume "f \<sqsubseteq> d"
   11.54 +  hence "f\<cdot>x \<sqsubseteq> d\<cdot>x" by (rule monofun_cfun_fun)
   11.55 +  also assume "f\<cdot>x = x"
   11.56 +  finally show "x \<sqsubseteq> d\<cdot>x" .
   11.57 +qed
   11.58 +
   11.59 +end
   11.60 +
   11.61 +lemma deflation_strict: "deflation d \<Longrightarrow> d\<cdot>\<bottom> = \<bottom>"
   11.62 +by (rule deflation.below [THEN UU_I])
   11.63 +
   11.64 +lemma adm_deflation: "adm (\<lambda>d. deflation d)"
   11.65 +by (simp add: deflation_def)
   11.66 +
   11.67 +lemma deflation_ID: "deflation ID"
   11.68 +by (simp add: deflation.intro)
   11.69 +
   11.70 +lemma deflation_UU: "deflation \<bottom>"
   11.71 +by (simp add: deflation.intro)
   11.72 +
   11.73 +lemma deflation_below_iff:
   11.74 +  "\<lbrakk>deflation p; deflation q\<rbrakk> \<Longrightarrow> p \<sqsubseteq> q \<longleftrightarrow> (\<forall>x. p\<cdot>x = x \<longrightarrow> q\<cdot>x = x)"
   11.75 + apply safe
   11.76 +  apply (simp add: deflation.belowD)
   11.77 + apply (simp add: deflation.belowI)
   11.78 +done
   11.79 +
   11.80 +text {*
   11.81 +  The composition of two deflations is equal to
   11.82 +  the lesser of the two (if they are comparable).
   11.83 +*}
   11.84 +
   11.85 +lemma deflation_below_comp1:
   11.86 +  assumes "deflation f"
   11.87 +  assumes "deflation g"
   11.88 +  shows "f \<sqsubseteq> g \<Longrightarrow> f\<cdot>(g\<cdot>x) = f\<cdot>x"
   11.89 +proof (rule below_antisym)
   11.90 +  interpret g: deflation g by fact
   11.91 +  from g.below show "f\<cdot>(g\<cdot>x) \<sqsubseteq> f\<cdot>x" by (rule monofun_cfun_arg)
   11.92 +next
   11.93 +  interpret f: deflation f by fact
   11.94 +  assume "f \<sqsubseteq> g" hence "f\<cdot>x \<sqsubseteq> g\<cdot>x" by (rule monofun_cfun_fun)
   11.95 +  hence "f\<cdot>(f\<cdot>x) \<sqsubseteq> f\<cdot>(g\<cdot>x)" by (rule monofun_cfun_arg)
   11.96 +  also have "f\<cdot>(f\<cdot>x) = f\<cdot>x" by (rule f.idem)
   11.97 +  finally show "f\<cdot>x \<sqsubseteq> f\<cdot>(g\<cdot>x)" .
   11.98 +qed
   11.99 +
  11.100 +lemma deflation_below_comp2:
  11.101 +  "\<lbrakk>deflation f; deflation g; f \<sqsubseteq> g\<rbrakk> \<Longrightarrow> g\<cdot>(f\<cdot>x) = f\<cdot>x"
  11.102 +by (simp only: deflation.belowD deflation.idem)
  11.103 +
  11.104 +
  11.105 +subsection {* Deflations with finite range *}
  11.106 +
  11.107 +lemma finite_range_imp_finite_fixes:
  11.108 +  "finite (range f) \<Longrightarrow> finite {x. f x = x}"
  11.109 +proof -
  11.110 +  have "{x. f x = x} \<subseteq> range f"
  11.111 +    by (clarify, erule subst, rule rangeI)
  11.112 +  moreover assume "finite (range f)"
  11.113 +  ultimately show "finite {x. f x = x}"
  11.114 +    by (rule finite_subset)
  11.115 +qed
  11.116 +
  11.117 +locale finite_deflation = deflation +
  11.118 +  assumes finite_fixes: "finite {x. d\<cdot>x = x}"
  11.119 +begin
  11.120 +
  11.121 +lemma finite_range: "finite (range (\<lambda>x. d\<cdot>x))"
  11.122 +by (simp add: range_eq_fixes finite_fixes)
  11.123 +
  11.124 +lemma finite_image: "finite ((\<lambda>x. d\<cdot>x) ` A)"
  11.125 +by (rule finite_subset [OF image_mono [OF subset_UNIV] finite_range])
  11.126 +
  11.127 +lemma compact: "compact (d\<cdot>x)"
  11.128 +proof (rule compactI2)
  11.129 +  fix Y :: "nat \<Rightarrow> 'a"
  11.130 +  assume Y: "chain Y"
  11.131 +  have "finite_chain (\<lambda>i. d\<cdot>(Y i))"
  11.132 +  proof (rule finite_range_imp_finch)
  11.133 +    show "chain (\<lambda>i. d\<cdot>(Y i))"
  11.134 +      using Y by simp
  11.135 +    have "range (\<lambda>i. d\<cdot>(Y i)) \<subseteq> range (\<lambda>x. d\<cdot>x)"
  11.136 +      by clarsimp
  11.137 +    thus "finite (range (\<lambda>i. d\<cdot>(Y i)))"
  11.138 +      using finite_range by (rule finite_subset)
  11.139 +  qed
  11.140 +  hence "\<exists>j. (\<Squnion>i. d\<cdot>(Y i)) = d\<cdot>(Y j)"
  11.141 +    by (simp add: finite_chain_def maxinch_is_thelub Y)
  11.142 +  then obtain j where j: "(\<Squnion>i. d\<cdot>(Y i)) = d\<cdot>(Y j)" ..
  11.143 +
  11.144 +  assume "d\<cdot>x \<sqsubseteq> (\<Squnion>i. Y i)"
  11.145 +  hence "d\<cdot>(d\<cdot>x) \<sqsubseteq> d\<cdot>(\<Squnion>i. Y i)"
  11.146 +    by (rule monofun_cfun_arg)
  11.147 +  hence "d\<cdot>x \<sqsubseteq> (\<Squnion>i. d\<cdot>(Y i))"
  11.148 +    by (simp add: contlub_cfun_arg Y idem)
  11.149 +  hence "d\<cdot>x \<sqsubseteq> d\<cdot>(Y j)"
  11.150 +    using j by simp
  11.151 +  hence "d\<cdot>x \<sqsubseteq> Y j"
  11.152 +    using below by (rule below_trans)
  11.153 +  thus "\<exists>j. d\<cdot>x \<sqsubseteq> Y j" ..
  11.154 +qed
  11.155 +
  11.156 +end
  11.157 +
  11.158 +lemma finite_deflation_intro:
  11.159 +  "deflation d \<Longrightarrow> finite {x. d\<cdot>x = x} \<Longrightarrow> finite_deflation d"
  11.160 +by (intro finite_deflation.intro finite_deflation_axioms.intro)
  11.161 +
  11.162 +lemma finite_deflation_imp_deflation:
  11.163 +  "finite_deflation d \<Longrightarrow> deflation d"
  11.164 +unfolding finite_deflation_def by simp
  11.165 +
  11.166 +lemma finite_deflation_UU: "finite_deflation \<bottom>"
  11.167 +by default simp_all
  11.168 +
  11.169 +
  11.170 +subsection {* Continuous embedding-projection pairs *}
  11.171 +
  11.172 +locale ep_pair =
  11.173 +  fixes e :: "'a \<rightarrow> 'b" and p :: "'b \<rightarrow> 'a"
  11.174 +  assumes e_inverse [simp]: "\<And>x. p\<cdot>(e\<cdot>x) = x"
  11.175 +  and e_p_below: "\<And>y. e\<cdot>(p\<cdot>y) \<sqsubseteq> y"
  11.176 +begin
  11.177 +
  11.178 +lemma e_below_iff [simp]: "e\<cdot>x \<sqsubseteq> e\<cdot>y \<longleftrightarrow> x \<sqsubseteq> y"
  11.179 +proof
  11.180 +  assume "e\<cdot>x \<sqsubseteq> e\<cdot>y"
  11.181 +  hence "p\<cdot>(e\<cdot>x) \<sqsubseteq> p\<cdot>(e\<cdot>y)" by (rule monofun_cfun_arg)
  11.182 +  thus "x \<sqsubseteq> y" by simp
  11.183 +next
  11.184 +  assume "x \<sqsubseteq> y"
  11.185 +  thus "e\<cdot>x \<sqsubseteq> e\<cdot>y" by (rule monofun_cfun_arg)
  11.186 +qed
  11.187 +
  11.188 +lemma e_eq_iff [simp]: "e\<cdot>x = e\<cdot>y \<longleftrightarrow> x = y"
  11.189 +unfolding po_eq_conv e_below_iff ..
  11.190 +
  11.191 +lemma p_eq_iff:
  11.192 +  "\<lbrakk>e\<cdot>(p\<cdot>x) = x; e\<cdot>(p\<cdot>y) = y\<rbrakk> \<Longrightarrow> p\<cdot>x = p\<cdot>y \<longleftrightarrow> x = y"
  11.193 +by (safe, erule subst, erule subst, simp)
  11.194 +
  11.195 +lemma p_inverse: "(\<exists>x. y = e\<cdot>x) = (e\<cdot>(p\<cdot>y) = y)"
  11.196 +by (auto, rule exI, erule sym)
  11.197 +
  11.198 +lemma e_below_iff_below_p: "e\<cdot>x \<sqsubseteq> y \<longleftrightarrow> x \<sqsubseteq> p\<cdot>y"
  11.199 +proof
  11.200 +  assume "e\<cdot>x \<sqsubseteq> y"
  11.201 +  then have "p\<cdot>(e\<cdot>x) \<sqsubseteq> p\<cdot>y" by (rule monofun_cfun_arg)
  11.202 +  then show "x \<sqsubseteq> p\<cdot>y" by simp
  11.203 +next
  11.204 +  assume "x \<sqsubseteq> p\<cdot>y"
  11.205 +  then have "e\<cdot>x \<sqsubseteq> e\<cdot>(p\<cdot>y)" by (rule monofun_cfun_arg)
  11.206 +  then show "e\<cdot>x \<sqsubseteq> y" using e_p_below by (rule below_trans)
  11.207 +qed
  11.208 +
  11.209 +lemma compact_e_rev: "compact (e\<cdot>x) \<Longrightarrow> compact x"
  11.210 +proof -
  11.211 +  assume "compact (e\<cdot>x)"
  11.212 +  hence "adm (\<lambda>y. \<not> e\<cdot>x \<sqsubseteq> y)" by (rule compactD)
  11.213 +  hence "adm (\<lambda>y. \<not> e\<cdot>x \<sqsubseteq> e\<cdot>y)" by (rule adm_subst [OF cont_Rep_cfun2])
  11.214 +  hence "adm (\<lambda>y. \<not> x \<sqsubseteq> y)" by simp
  11.215 +  thus "compact x" by (rule compactI)
  11.216 +qed
  11.217 +
  11.218 +lemma compact_e: "compact x \<Longrightarrow> compact (e\<cdot>x)"
  11.219 +proof -
  11.220 +  assume "compact x"
  11.221 +  hence "adm (\<lambda>y. \<not> x \<sqsubseteq> y)" by (rule compactD)
  11.222 +  hence "adm (\<lambda>y. \<not> x \<sqsubseteq> p\<cdot>y)" by (rule adm_subst [OF cont_Rep_cfun2])
  11.223 +  hence "adm (\<lambda>y. \<not> e\<cdot>x \<sqsubseteq> y)" by (simp add: e_below_iff_below_p)
  11.224 +  thus "compact (e\<cdot>x)" by (rule compactI)
  11.225 +qed
  11.226 +
  11.227 +lemma compact_e_iff: "compact (e\<cdot>x) \<longleftrightarrow> compact x"
  11.228 +by (rule iffI [OF compact_e_rev compact_e])
  11.229 +
  11.230 +text {* Deflations from ep-pairs *}
  11.231 +
  11.232 +lemma deflation_e_p: "deflation (e oo p)"
  11.233 +by (simp add: deflation.intro e_p_below)
  11.234 +
  11.235 +lemma deflation_e_d_p:
  11.236 +  assumes "deflation d"
  11.237 +  shows "deflation (e oo d oo p)"
  11.238 +proof
  11.239 +  interpret deflation d by fact
  11.240 +  fix x :: 'b
  11.241 +  show "(e oo d oo p)\<cdot>((e oo d oo p)\<cdot>x) = (e oo d oo p)\<cdot>x"
  11.242 +    by (simp add: idem)
  11.243 +  show "(e oo d oo p)\<cdot>x \<sqsubseteq> x"
  11.244 +    by (simp add: e_below_iff_below_p below)
  11.245 +qed
  11.246 +
  11.247 +lemma finite_deflation_e_d_p:
  11.248 +  assumes "finite_deflation d"
  11.249 +  shows "finite_deflation (e oo d oo p)"
  11.250 +proof
  11.251 +  interpret finite_deflation d by fact
  11.252 +  fix x :: 'b
  11.253 +  show "(e oo d oo p)\<cdot>((e oo d oo p)\<cdot>x) = (e oo d oo p)\<cdot>x"
  11.254 +    by (simp add: idem)
  11.255 +  show "(e oo d oo p)\<cdot>x \<sqsubseteq> x"
  11.256 +    by (simp add: e_below_iff_below_p below)
  11.257 +  have "finite ((\<lambda>x. e\<cdot>x) ` (\<lambda>x. d\<cdot>x) ` range (\<lambda>x. p\<cdot>x))"
  11.258 +    by (simp add: finite_image)
  11.259 +  hence "finite (range (\<lambda>x. (e oo d oo p)\<cdot>x))"
  11.260 +    by (simp add: image_image)
  11.261 +  thus "finite {x. (e oo d oo p)\<cdot>x = x}"
  11.262 +    by (rule finite_range_imp_finite_fixes)
  11.263 +qed
  11.264 +
  11.265 +lemma deflation_p_d_e:
  11.266 +  assumes "deflation d"
  11.267 +  assumes d: "\<And>x. d\<cdot>x \<sqsubseteq> e\<cdot>(p\<cdot>x)"
  11.268 +  shows "deflation (p oo d oo e)"
  11.269 +proof -
  11.270 +  interpret d: deflation d by fact
  11.271 +  {
  11.272 +    fix x
  11.273 +    have "d\<cdot>(e\<cdot>x) \<sqsubseteq> e\<cdot>x"
  11.274 +      by (rule d.below)
  11.275 +    hence "p\<cdot>(d\<cdot>(e\<cdot>x)) \<sqsubseteq> p\<cdot>(e\<cdot>x)"
  11.276 +      by (rule monofun_cfun_arg)
  11.277 +    hence "(p oo d oo e)\<cdot>x \<sqsubseteq> x"
  11.278 +      by simp
  11.279 +  }
  11.280 +  note p_d_e_below = this
  11.281 +  show ?thesis
  11.282 +  proof
  11.283 +    fix x
  11.284 +    show "(p oo d oo e)\<cdot>x \<sqsubseteq> x"
  11.285 +      by (rule p_d_e_below)
  11.286 +  next
  11.287 +    fix x
  11.288 +    show "(p oo d oo e)\<cdot>((p oo d oo e)\<cdot>x) = (p oo d oo e)\<cdot>x"
  11.289 +    proof (rule below_antisym)
  11.290 +      show "(p oo d oo e)\<cdot>((p oo d oo e)\<cdot>x) \<sqsubseteq> (p oo d oo e)\<cdot>x"
  11.291 +        by (rule p_d_e_below)
  11.292 +      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)))))"
  11.293 +        by (intro monofun_cfun_arg d)
  11.294 +      hence "p\<cdot>(d\<cdot>(e\<cdot>x)) \<sqsubseteq> p\<cdot>(d\<cdot>(e\<cdot>(p\<cdot>(d\<cdot>(e\<cdot>x)))))"
  11.295 +        by (simp only: d.idem)
  11.296 +      thus "(p oo d oo e)\<cdot>x \<sqsubseteq> (p oo d oo e)\<cdot>((p oo d oo e)\<cdot>x)"
  11.297 +        by simp
  11.298 +    qed
  11.299 +  qed
  11.300 +qed
  11.301 +
  11.302 +lemma finite_deflation_p_d_e:
  11.303 +  assumes "finite_deflation d"
  11.304 +  assumes d: "\<And>x. d\<cdot>x \<sqsubseteq> e\<cdot>(p\<cdot>x)"
  11.305 +  shows "finite_deflation (p oo d oo e)"
  11.306 +proof -
  11.307 +  interpret d: finite_deflation d by fact
  11.308 +  show ?thesis
  11.309 +  proof (rule finite_deflation_intro)
  11.310 +    have "deflation d" ..
  11.311 +    thus "deflation (p oo d oo e)"
  11.312 +      using d by (rule deflation_p_d_e)
  11.313 +  next
  11.314 +    have "finite ((\<lambda>x. d\<cdot>x) ` range (\<lambda>x. e\<cdot>x))"
  11.315 +      by (rule d.finite_image)
  11.316 +    hence "finite ((\<lambda>x. p\<cdot>x) ` (\<lambda>x. d\<cdot>x) ` range (\<lambda>x. e\<cdot>x))"
  11.317 +      by (rule finite_imageI)
  11.318 +    hence "finite (range (\<lambda>x. (p oo d oo e)\<cdot>x))"
  11.319 +      by (simp add: image_image)
  11.320 +    thus "finite {x. (p oo d oo e)\<cdot>x = x}"
  11.321 +      by (rule finite_range_imp_finite_fixes)
  11.322 +  qed
  11.323 +qed
  11.324 +
  11.325 +end
  11.326 +
  11.327 +subsection {* Uniqueness of ep-pairs *}
  11.328 +
  11.329 +lemma ep_pair_unique_e_lemma:
  11.330 +  assumes 1: "ep_pair e1 p" and 2: "ep_pair e2 p"
  11.331 +  shows "e1 \<sqsubseteq> e2"
  11.332 +proof (rule cfun_belowI)
  11.333 +  fix x
  11.334 +  have "e1\<cdot>(p\<cdot>(e2\<cdot>x)) \<sqsubseteq> e2\<cdot>x"
  11.335 +    by (rule ep_pair.e_p_below [OF 1])
  11.336 +  thus "e1\<cdot>x \<sqsubseteq> e2\<cdot>x"
  11.337 +    by (simp only: ep_pair.e_inverse [OF 2])
  11.338 +qed
  11.339 +
  11.340 +lemma ep_pair_unique_e:
  11.341 +  "\<lbrakk>ep_pair e1 p; ep_pair e2 p\<rbrakk> \<Longrightarrow> e1 = e2"
  11.342 +by (fast intro: below_antisym elim: ep_pair_unique_e_lemma)
  11.343 +
  11.344 +lemma ep_pair_unique_p_lemma:
  11.345 +  assumes 1: "ep_pair e p1" and 2: "ep_pair e p2"
  11.346 +  shows "p1 \<sqsubseteq> p2"
  11.347 +proof (rule cfun_belowI)
  11.348 +  fix x
  11.349 +  have "e\<cdot>(p1\<cdot>x) \<sqsubseteq> x"
  11.350 +    by (rule ep_pair.e_p_below [OF 1])
  11.351 +  hence "p2\<cdot>(e\<cdot>(p1\<cdot>x)) \<sqsubseteq> p2\<cdot>x"
  11.352 +    by (rule monofun_cfun_arg)
  11.353 +  thus "p1\<cdot>x \<sqsubseteq> p2\<cdot>x"
  11.354 +    by (simp only: ep_pair.e_inverse [OF 2])
  11.355 +qed
  11.356 +
  11.357 +lemma ep_pair_unique_p:
  11.358 +  "\<lbrakk>ep_pair e p1; ep_pair e p2\<rbrakk> \<Longrightarrow> p1 = p2"
  11.359 +by (fast intro: below_antisym elim: ep_pair_unique_p_lemma)
  11.360 +
  11.361 +subsection {* Composing ep-pairs *}
  11.362 +
  11.363 +lemma ep_pair_ID_ID: "ep_pair ID ID"
  11.364 +by default simp_all
  11.365 +
  11.366 +lemma ep_pair_comp:
  11.367 +  assumes "ep_pair e1 p1" and "ep_pair e2 p2"
  11.368 +  shows "ep_pair (e2 oo e1) (p1 oo p2)"
  11.369 +proof
  11.370 +  interpret ep1: ep_pair e1 p1 by fact
  11.371 +  interpret ep2: ep_pair e2 p2 by fact
  11.372 +  fix x y
  11.373 +  show "(p1 oo p2)\<cdot>((e2 oo e1)\<cdot>x) = x"
  11.374 +    by simp
  11.375 +  have "e1\<cdot>(p1\<cdot>(p2\<cdot>y)) \<sqsubseteq> p2\<cdot>y"
  11.376 +    by (rule ep1.e_p_below)
  11.377 +  hence "e2\<cdot>(e1\<cdot>(p1\<cdot>(p2\<cdot>y))) \<sqsubseteq> e2\<cdot>(p2\<cdot>y)"
  11.378 +    by (rule monofun_cfun_arg)
  11.379 +  also have "e2\<cdot>(p2\<cdot>y) \<sqsubseteq> y"
  11.380 +    by (rule ep2.e_p_below)
  11.381 +  finally show "(e2 oo e1)\<cdot>((p1 oo p2)\<cdot>y) \<sqsubseteq> y"
  11.382 +    by simp
  11.383 +qed
  11.384 +
  11.385 +locale pcpo_ep_pair = ep_pair +
  11.386 +  constrains e :: "'a::pcpo \<rightarrow> 'b::pcpo"
  11.387 +  constrains p :: "'b::pcpo \<rightarrow> 'a::pcpo"
  11.388 +begin
  11.389 +
  11.390 +lemma e_strict [simp]: "e\<cdot>\<bottom> = \<bottom>"
  11.391 +proof -
  11.392 +  have "\<bottom> \<sqsubseteq> p\<cdot>\<bottom>" by (rule minimal)
  11.393 +  hence "e\<cdot>\<bottom> \<sqsubseteq> e\<cdot>(p\<cdot>\<bottom>)" by (rule monofun_cfun_arg)
  11.394 +  also have "e\<cdot>(p\<cdot>\<bottom>) \<sqsubseteq> \<bottom>" by (rule e_p_below)
  11.395 +  finally show "e\<cdot>\<bottom> = \<bottom>" by simp
  11.396 +qed
  11.397 +
  11.398 +lemma e_bottom_iff [simp]: "e\<cdot>x = \<bottom> \<longleftrightarrow> x = \<bottom>"
  11.399 +by (rule e_eq_iff [where y="\<bottom>", unfolded e_strict])
  11.400 +
  11.401 +lemma e_defined: "x \<noteq> \<bottom> \<Longrightarrow> e\<cdot>x \<noteq> \<bottom>"
  11.402 +by simp
  11.403 +
  11.404 +lemma p_strict [simp]: "p\<cdot>\<bottom> = \<bottom>"
  11.405 +by (rule e_inverse [where x="\<bottom>", unfolded e_strict])
  11.406 +
  11.407 +lemmas stricts = e_strict p_strict
  11.408 +
  11.409 +end
  11.410 +
  11.411 +end
    12.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    12.2 +++ b/src/HOL/HOLCF/Discrete.thy	Sat Nov 27 16:08:10 2010 -0800
    12.3 @@ -0,0 +1,38 @@
    12.4 +(*  Title:      HOLCF/Discrete.thy
    12.5 +    Author:     Tobias Nipkow
    12.6 +*)
    12.7 +
    12.8 +header {* Discrete cpo types *}
    12.9 +
   12.10 +theory Discrete
   12.11 +imports Cont
   12.12 +begin
   12.13 +
   12.14 +datatype 'a discr = Discr "'a :: type"
   12.15 +
   12.16 +subsection {* Discrete cpo class instance *}
   12.17 +
   12.18 +instantiation discr :: (type) discrete_cpo
   12.19 +begin
   12.20 +
   12.21 +definition
   12.22 +  "(op \<sqsubseteq> :: 'a discr \<Rightarrow> 'a discr \<Rightarrow> bool) = (op =)"
   12.23 +
   12.24 +instance
   12.25 +by default (simp add: below_discr_def)
   12.26 +
   12.27 +end
   12.28 +
   12.29 +subsection {* \emph{undiscr} *}
   12.30 +
   12.31 +definition
   12.32 +  undiscr :: "('a::type)discr => 'a" where
   12.33 +  "undiscr x = (case x of Discr y => y)"
   12.34 +
   12.35 +lemma undiscr_Discr [simp]: "undiscr (Discr x) = x"
   12.36 +by (simp add: undiscr_def)
   12.37 +
   12.38 +lemma Discr_undiscr [simp]: "Discr (undiscr y) = y"
   12.39 +by (induct y) simp
   12.40 +
   12.41 +end
    13.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    13.2 +++ b/src/HOL/HOLCF/Domain.thy	Sat Nov 27 16:08:10 2010 -0800
    13.3 @@ -0,0 +1,352 @@
    13.4 +(*  Title:      HOLCF/Domain.thy
    13.5 +    Author:     Brian Huffman
    13.6 +*)
    13.7 +
    13.8 +header {* Domain package *}
    13.9 +
   13.10 +theory Domain
   13.11 +imports Bifinite Domain_Aux
   13.12 +uses
   13.13 +  ("Tools/domaindef.ML")
   13.14 +  ("Tools/Domain/domain_isomorphism.ML")
   13.15 +  ("Tools/Domain/domain_axioms.ML")
   13.16 +  ("Tools/Domain/domain.ML")
   13.17 +begin
   13.18 +
   13.19 +default_sort "domain"
   13.20 +
   13.21 +subsection {* Representations of types *}
   13.22 +
   13.23 +lemma emb_prj: "emb\<cdot>((prj\<cdot>x)::'a) = cast\<cdot>DEFL('a)\<cdot>x"
   13.24 +by (simp add: cast_DEFL)
   13.25 +
   13.26 +lemma emb_prj_emb:
   13.27 +  fixes x :: "'a"
   13.28 +  assumes "DEFL('a) \<sqsubseteq> DEFL('b)"
   13.29 +  shows "emb\<cdot>(prj\<cdot>(emb\<cdot>x) :: 'b) = emb\<cdot>x"
   13.30 +unfolding emb_prj
   13.31 +apply (rule cast.belowD)
   13.32 +apply (rule monofun_cfun_arg [OF assms])
   13.33 +apply (simp add: cast_DEFL)
   13.34 +done
   13.35 +
   13.36 +lemma prj_emb_prj:
   13.37 +  assumes "DEFL('a) \<sqsubseteq> DEFL('b)"
   13.38 +  shows "prj\<cdot>(emb\<cdot>(prj\<cdot>x :: 'b)) = (prj\<cdot>x :: 'a)"
   13.39 + apply (rule emb_eq_iff [THEN iffD1])
   13.40 + apply (simp only: emb_prj)
   13.41 + apply (rule deflation_below_comp1)
   13.42 +   apply (rule deflation_cast)
   13.43 +  apply (rule deflation_cast)
   13.44 + apply (rule monofun_cfun_arg [OF assms])
   13.45 +done
   13.46 +
   13.47 +text {* Isomorphism lemmas used internally by the domain package: *}
   13.48 +
   13.49 +lemma domain_abs_iso:
   13.50 +  fixes abs and rep
   13.51 +  assumes DEFL: "DEFL('b) = DEFL('a)"
   13.52 +  assumes abs_def: "(abs :: 'a \<rightarrow> 'b) \<equiv> prj oo emb"
   13.53 +  assumes rep_def: "(rep :: 'b \<rightarrow> 'a) \<equiv> prj oo emb"
   13.54 +  shows "rep\<cdot>(abs\<cdot>x) = x"
   13.55 +unfolding abs_def rep_def
   13.56 +by (simp add: emb_prj_emb DEFL)
   13.57 +
   13.58 +lemma domain_rep_iso:
   13.59 +  fixes abs and rep
   13.60 +  assumes DEFL: "DEFL('b) = DEFL('a)"
   13.61 +  assumes abs_def: "(abs :: 'a \<rightarrow> 'b) \<equiv> prj oo emb"
   13.62 +  assumes rep_def: "(rep :: 'b \<rightarrow> 'a) \<equiv> prj oo emb"
   13.63 +  shows "abs\<cdot>(rep\<cdot>x) = x"
   13.64 +unfolding abs_def rep_def
   13.65 +by (simp add: emb_prj_emb DEFL)
   13.66 +
   13.67 +subsection {* Deflations as sets *}
   13.68 +
   13.69 +definition defl_set :: "defl \<Rightarrow> udom set"
   13.70 +where "defl_set A = {x. cast\<cdot>A\<cdot>x = x}"
   13.71 +
   13.72 +lemma adm_defl_set: "adm (\<lambda>x. x \<in> defl_set A)"
   13.73 +unfolding defl_set_def by simp
   13.74 +
   13.75 +lemma defl_set_bottom: "\<bottom> \<in> defl_set A"
   13.76 +unfolding defl_set_def by simp
   13.77 +
   13.78 +lemma defl_set_cast [simp]: "cast\<cdot>A\<cdot>x \<in> defl_set A"
   13.79 +unfolding defl_set_def by simp
   13.80 +
   13.81 +lemma defl_set_subset_iff: "defl_set A \<subseteq> defl_set B \<longleftrightarrow> A \<sqsubseteq> B"
   13.82 +apply (simp add: defl_set_def subset_eq cast_below_cast [symmetric])
   13.83 +apply (auto simp add: cast.belowI cast.belowD)
   13.84 +done
   13.85 +
   13.86 +subsection {* Proving a subtype is representable *}
   13.87 +
   13.88 +text {* Temporarily relax type constraints. *}
   13.89 +
   13.90 +setup {*
   13.91 +  fold Sign.add_const_constraint
   13.92 +  [ (@{const_name defl}, SOME @{typ "'a::pcpo itself \<Rightarrow> defl"})
   13.93 +  , (@{const_name emb}, SOME @{typ "'a::pcpo \<rightarrow> udom"})
   13.94 +  , (@{const_name prj}, SOME @{typ "udom \<rightarrow> 'a::pcpo"})
   13.95 +  , (@{const_name liftdefl}, SOME @{typ "'a::pcpo itself \<Rightarrow> defl"})
   13.96 +  , (@{const_name liftemb}, SOME @{typ "'a::pcpo u \<rightarrow> udom"})
   13.97 +  , (@{const_name liftprj}, SOME @{typ "udom \<rightarrow> 'a::pcpo u"}) ]
   13.98 +*}
   13.99 +
  13.100 +lemma typedef_liftdomain_class:
  13.101 +  fixes Rep :: "'a::pcpo \<Rightarrow> udom"
  13.102 +  fixes Abs :: "udom \<Rightarrow> 'a::pcpo"
  13.103 +  fixes t :: defl
  13.104 +  assumes type: "type_definition Rep Abs (defl_set t)"
  13.105 +  assumes below: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
  13.106 +  assumes emb: "emb \<equiv> (\<Lambda> x. Rep x)"
  13.107 +  assumes prj: "prj \<equiv> (\<Lambda> x. Abs (cast\<cdot>t\<cdot>x))"
  13.108 +  assumes defl: "defl \<equiv> (\<lambda> a::'a itself. t)"
  13.109 +  assumes liftemb: "(liftemb :: 'a u \<rightarrow> udom) \<equiv> udom_emb u_approx oo u_map\<cdot>emb"
  13.110 +  assumes liftprj: "(liftprj :: udom \<rightarrow> 'a u) \<equiv> u_map\<cdot>prj oo udom_prj u_approx"
  13.111 +  assumes liftdefl: "(liftdefl :: 'a itself \<Rightarrow> defl) \<equiv> (\<lambda>t. u_defl\<cdot>DEFL('a))"
  13.112 +  shows "OFCLASS('a, liftdomain_class)"
  13.113 +using liftemb [THEN meta_eq_to_obj_eq]
  13.114 +using liftprj [THEN meta_eq_to_obj_eq]
  13.115 +proof (rule liftdomain_class_intro)
  13.116 +  have emb_beta: "\<And>x. emb\<cdot>x = Rep x"
  13.117 +    unfolding emb
  13.118 +    apply (rule beta_cfun)
  13.119 +    apply (rule typedef_cont_Rep [OF type below adm_defl_set])
  13.120 +    done
  13.121 +  have prj_beta: "\<And>y. prj\<cdot>y = Abs (cast\<cdot>t\<cdot>y)"
  13.122 +    unfolding prj
  13.123 +    apply (rule beta_cfun)
  13.124 +    apply (rule typedef_cont_Abs [OF type below adm_defl_set])
  13.125 +    apply simp_all
  13.126 +    done
  13.127 +  have prj_emb: "\<And>x::'a. prj\<cdot>(emb\<cdot>x) = x"
  13.128 +    using type_definition.Rep [OF type]
  13.129 +    unfolding prj_beta emb_beta defl_set_def
  13.130 +    by (simp add: type_definition.Rep_inverse [OF type])
  13.131 +  have emb_prj: "\<And>y. emb\<cdot>(prj\<cdot>y :: 'a) = cast\<cdot>t\<cdot>y"
  13.132 +    unfolding prj_beta emb_beta
  13.133 +    by (simp add: type_definition.Abs_inverse [OF type])
  13.134 +  show "ep_pair (emb :: 'a \<rightarrow> udom) prj"
  13.135 +    apply default
  13.136 +    apply (simp add: prj_emb)
  13.137 +    apply (simp add: emb_prj cast.below)
  13.138 +    done
  13.139 +  show "cast\<cdot>DEFL('a) = emb oo (prj :: udom \<rightarrow> 'a)"
  13.140 +    by (rule cfun_eqI, simp add: defl emb_prj)
  13.141 +  show "LIFTDEFL('a) = u_defl\<cdot>DEFL('a)"
  13.142 +    unfolding liftdefl ..
  13.143 +qed
  13.144 +
  13.145 +lemma typedef_DEFL:
  13.146 +  assumes "defl \<equiv> (\<lambda>a::'a::pcpo itself. t)"
  13.147 +  shows "DEFL('a::pcpo) = t"
  13.148 +unfolding assms ..
  13.149 +
  13.150 +text {* Restore original typing constraints. *}
  13.151 +
  13.152 +setup {*
  13.153 +  fold Sign.add_const_constraint
  13.154 +  [ (@{const_name defl}, SOME @{typ "'a::domain itself \<Rightarrow> defl"})
  13.155 +  , (@{const_name emb}, SOME @{typ "'a::domain \<rightarrow> udom"})
  13.156 +  , (@{const_name prj}, SOME @{typ "udom \<rightarrow> 'a::domain"})
  13.157 +  , (@{const_name liftdefl}, SOME @{typ "'a::predomain itself \<Rightarrow> defl"})
  13.158 +  , (@{const_name liftemb}, SOME @{typ "'a::predomain u \<rightarrow> udom"})
  13.159 +  , (@{const_name liftprj}, SOME @{typ "udom \<rightarrow> 'a::predomain u"}) ]
  13.160 +*}
  13.161 +
  13.162 +use "Tools/domaindef.ML"
  13.163 +
  13.164 +subsection {* Isomorphic deflations *}
  13.165 +
  13.166 +definition
  13.167 +  isodefl :: "('a \<rightarrow> 'a) \<Rightarrow> defl \<Rightarrow> bool"
  13.168 +where
  13.169 +  "isodefl d t \<longleftrightarrow> cast\<cdot>t = emb oo d oo prj"
  13.170 +
  13.171 +lemma isodeflI: "(\<And>x. cast\<cdot>t\<cdot>x = emb\<cdot>(d\<cdot>(prj\<cdot>x))) \<Longrightarrow> isodefl d t"
  13.172 +unfolding isodefl_def by (simp add: cfun_eqI)
  13.173 +
  13.174 +lemma cast_isodefl: "isodefl d t \<Longrightarrow> cast\<cdot>t = (\<Lambda> x. emb\<cdot>(d\<cdot>(prj\<cdot>x)))"
  13.175 +unfolding isodefl_def by (simp add: cfun_eqI)
  13.176 +
  13.177 +lemma isodefl_strict: "isodefl d t \<Longrightarrow> d\<cdot>\<bottom> = \<bottom>"
  13.178 +unfolding isodefl_def
  13.179 +by (drule cfun_fun_cong [where x="\<bottom>"], simp)
  13.180 +
  13.181 +lemma isodefl_imp_deflation:
  13.182 +  fixes d :: "'a \<rightarrow> 'a"
  13.183 +  assumes "isodefl d t" shows "deflation d"
  13.184 +proof
  13.185 +  note assms [unfolded isodefl_def, simp]
  13.186 +  fix x :: 'a
  13.187 +  show "d\<cdot>(d\<cdot>x) = d\<cdot>x"
  13.188 +    using cast.idem [of t "emb\<cdot>x"] by simp
  13.189 +  show "d\<cdot>x \<sqsubseteq> x"
  13.190 +    using cast.below [of t "emb\<cdot>x"] by simp
  13.191 +qed
  13.192 +
  13.193 +lemma isodefl_ID_DEFL: "isodefl (ID :: 'a \<rightarrow> 'a) DEFL('a)"
  13.194 +unfolding isodefl_def by (simp add: cast_DEFL)
  13.195 +
  13.196 +lemma isodefl_LIFTDEFL:
  13.197 +  "isodefl (u_map\<cdot>(ID :: 'a \<rightarrow> 'a)) LIFTDEFL('a::predomain)"
  13.198 +unfolding u_map_ID DEFL_u [symmetric]
  13.199 +by (rule isodefl_ID_DEFL)
  13.200 +
  13.201 +lemma isodefl_DEFL_imp_ID: "isodefl (d :: 'a \<rightarrow> 'a) DEFL('a) \<Longrightarrow> d = ID"
  13.202 +unfolding isodefl_def
  13.203 +apply (simp add: cast_DEFL)
  13.204 +apply (simp add: cfun_eq_iff)
  13.205 +apply (rule allI)
  13.206 +apply (drule_tac x="emb\<cdot>x" in spec)
  13.207 +apply simp
  13.208 +done
  13.209 +
  13.210 +lemma isodefl_bottom: "isodefl \<bottom> \<bottom>"
  13.211 +unfolding isodefl_def by (simp add: cfun_eq_iff)
  13.212 +
  13.213 +lemma adm_isodefl:
  13.214 +  "cont f \<Longrightarrow> cont g \<Longrightarrow> adm (\<lambda>x. isodefl (f x) (g x))"
  13.215 +unfolding isodefl_def by simp
  13.216 +
  13.217 +lemma isodefl_lub:
  13.218 +  assumes "chain d" and "chain t"
  13.219 +  assumes "\<And>i. isodefl (d i) (t i)"
  13.220 +  shows "isodefl (\<Squnion>i. d i) (\<Squnion>i. t i)"
  13.221 +using prems unfolding isodefl_def
  13.222 +by (simp add: contlub_cfun_arg contlub_cfun_fun)
  13.223 +
  13.224 +lemma isodefl_fix:
  13.225 +  assumes "\<And>d t. isodefl d t \<Longrightarrow> isodefl (f\<cdot>d) (g\<cdot>t)"
  13.226 +  shows "isodefl (fix\<cdot>f) (fix\<cdot>g)"
  13.227 +unfolding fix_def2
  13.228 +apply (rule isodefl_lub, simp, simp)
  13.229 +apply (induct_tac i)
  13.230 +apply (simp add: isodefl_bottom)
  13.231 +apply (simp add: assms)
  13.232 +done
  13.233 +
  13.234 +lemma isodefl_abs_rep:
  13.235 +  fixes abs and rep and d
  13.236 +  assumes DEFL: "DEFL('b) = DEFL('a)"
  13.237 +  assumes abs_def: "(abs :: 'a \<rightarrow> 'b) \<equiv> prj oo emb"
  13.238 +  assumes rep_def: "(rep :: 'b \<rightarrow> 'a) \<equiv> prj oo emb"
  13.239 +  shows "isodefl d t \<Longrightarrow> isodefl (abs oo d oo rep) t"
  13.240 +unfolding isodefl_def
  13.241 +by (simp add: cfun_eq_iff assms prj_emb_prj emb_prj_emb)
  13.242 +
  13.243 +lemma isodefl_sfun:
  13.244 +  "isodefl d1 t1 \<Longrightarrow> isodefl d2 t2 \<Longrightarrow>
  13.245 +    isodefl (sfun_map\<cdot>d1\<cdot>d2) (sfun_defl\<cdot>t1\<cdot>t2)"
  13.246 +apply (rule isodeflI)
  13.247 +apply (simp add: cast_sfun_defl cast_isodefl)
  13.248 +apply (simp add: emb_sfun_def prj_sfun_def)
  13.249 +apply (simp add: sfun_map_map isodefl_strict)
  13.250 +done
  13.251 +
  13.252 +lemma isodefl_ssum:
  13.253 +  "isodefl d1 t1 \<Longrightarrow> isodefl d2 t2 \<Longrightarrow>
  13.254 +    isodefl (ssum_map\<cdot>d1\<cdot>d2) (ssum_defl\<cdot>t1\<cdot>t2)"
  13.255 +apply (rule isodeflI)
  13.256 +apply (simp add: cast_ssum_defl cast_isodefl)
  13.257 +apply (simp add: emb_ssum_def prj_ssum_def)
  13.258 +apply (simp add: ssum_map_map isodefl_strict)
  13.259 +done
  13.260 +
  13.261 +lemma isodefl_sprod:
  13.262 +  "isodefl d1 t1 \<Longrightarrow> isodefl d2 t2 \<Longrightarrow>
  13.263 +    isodefl (sprod_map\<cdot>d1\<cdot>d2) (sprod_defl\<cdot>t1\<cdot>t2)"
  13.264 +apply (rule isodeflI)
  13.265 +apply (simp add: cast_sprod_defl cast_isodefl)
  13.266 +apply (simp add: emb_sprod_def prj_sprod_def)
  13.267 +apply (simp add: sprod_map_map isodefl_strict)
  13.268 +done
  13.269 +
  13.270 +lemma isodefl_cprod:
  13.271 +  "isodefl d1 t1 \<Longrightarrow> isodefl d2 t2 \<Longrightarrow>
  13.272 +    isodefl (cprod_map\<cdot>d1\<cdot>d2) (prod_defl\<cdot>t1\<cdot>t2)"
  13.273 +apply (rule isodeflI)
  13.274 +apply (simp add: cast_prod_defl cast_isodefl)
  13.275 +apply (simp add: emb_prod_def prj_prod_def)
  13.276 +apply (simp add: cprod_map_map cfcomp1)
  13.277 +done
  13.278 +
  13.279 +lemma isodefl_u:
  13.280 +  fixes d :: "'a::liftdomain \<rightarrow> 'a"
  13.281 +  shows "isodefl (d :: 'a \<rightarrow> 'a) t \<Longrightarrow> isodefl (u_map\<cdot>d) (u_defl\<cdot>t)"
  13.282 +apply (rule isodeflI)
  13.283 +apply (simp add: cast_u_defl cast_isodefl)
  13.284 +apply (simp add: emb_u_def prj_u_def liftemb_eq liftprj_eq)
  13.285 +apply (simp add: u_map_map)
  13.286 +done
  13.287 +
  13.288 +lemma encode_prod_u_map:
  13.289 +  "encode_prod_u\<cdot>(u_map\<cdot>(cprod_map\<cdot>f\<cdot>g)\<cdot>(decode_prod_u\<cdot>x))
  13.290 +    = sprod_map\<cdot>(u_map\<cdot>f)\<cdot>(u_map\<cdot>g)\<cdot>x"
  13.291 +unfolding encode_prod_u_def decode_prod_u_def
  13.292 +apply (case_tac x, simp, rename_tac a b)
  13.293 +apply (case_tac a, simp, case_tac b, simp, simp)
  13.294 +done
  13.295 +
  13.296 +lemma isodefl_cprod_u:
  13.297 +  assumes "isodefl (u_map\<cdot>d1) t1" and "isodefl (u_map\<cdot>d2) t2"
  13.298 +  shows "isodefl (u_map\<cdot>(cprod_map\<cdot>d1\<cdot>d2)) (sprod_defl\<cdot>t1\<cdot>t2)"
  13.299 +using assms unfolding isodefl_def
  13.300 +apply (simp add: emb_u_def prj_u_def liftemb_prod_def liftprj_prod_def)
  13.301 +apply (simp add: emb_u_def [symmetric] prj_u_def [symmetric])
  13.302 +apply (simp add: cfcomp1 encode_prod_u_map cast_sprod_defl sprod_map_map)
  13.303 +done
  13.304 +
  13.305 +lemma encode_cfun_map:
  13.306 +  "encode_cfun\<cdot>(cfun_map\<cdot>f\<cdot>g\<cdot>(decode_cfun\<cdot>x))
  13.307 +    = sfun_map\<cdot>(u_map\<cdot>f)\<cdot>g\<cdot>x"
  13.308 +unfolding encode_cfun_def decode_cfun_def
  13.309 +apply (simp add: sfun_eq_iff cfun_map_def sfun_map_def)
  13.310 +apply (rule cfun_eqI, rename_tac y, case_tac y, simp_all)
  13.311 +done
  13.312 +
  13.313 +lemma isodefl_cfun:
  13.314 +  "isodefl (u_map\<cdot>d1) t1 \<Longrightarrow> isodefl d2 t2 \<Longrightarrow>
  13.315 +    isodefl (cfun_map\<cdot>d1\<cdot>d2) (sfun_defl\<cdot>t1\<cdot>t2)"
  13.316 +apply (rule isodeflI)
  13.317 +apply (simp add: cast_sfun_defl cast_isodefl)
  13.318 +apply (simp add: emb_cfun_def prj_cfun_def encode_cfun_map)
  13.319 +apply (simp add: sfun_map_map isodefl_strict)
  13.320 +done
  13.321 +
  13.322 +subsection {* Setting up the domain package *}
  13.323 +
  13.324 +use "Tools/Domain/domain_isomorphism.ML"
  13.325 +use "Tools/Domain/domain_axioms.ML"
  13.326 +use "Tools/Domain/domain.ML"
  13.327 +
  13.328 +setup Domain_Isomorphism.setup
  13.329 +
  13.330 +lemmas [domain_defl_simps] =
  13.331 +  DEFL_cfun DEFL_sfun DEFL_ssum DEFL_sprod DEFL_prod DEFL_u
  13.332 +  liftdefl_eq LIFTDEFL_prod
  13.333 +
  13.334 +lemmas [domain_map_ID] =
  13.335 +  cfun_map_ID sfun_map_ID ssum_map_ID sprod_map_ID cprod_map_ID u_map_ID
  13.336 +
  13.337 +lemmas [domain_isodefl] =
  13.338 +  isodefl_u isodefl_sfun isodefl_ssum isodefl_sprod
  13.339 +  isodefl_cfun isodefl_cprod isodefl_cprod_u
  13.340 +
  13.341 +lemmas [domain_deflation] =
  13.342 +  deflation_cfun_map deflation_sfun_map deflation_ssum_map
  13.343 +  deflation_sprod_map deflation_cprod_map deflation_u_map
  13.344 +
  13.345 +setup {*
  13.346 +  fold Domain_Take_Proofs.add_rec_type
  13.347 +    [(@{type_name cfun}, [true, true]),
  13.348 +     (@{type_name "sfun"}, [true, true]),
  13.349 +     (@{type_name ssum}, [true, true]),
  13.350 +     (@{type_name sprod}, [true, true]),
  13.351 +     (@{type_name prod}, [true, true]),
  13.352 +     (@{type_name "u"}, [true])]
  13.353 +*}
  13.354 +
  13.355 +end
    14.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    14.2 +++ b/src/HOL/HOLCF/Domain_Aux.thy	Sat Nov 27 16:08:10 2010 -0800
    14.3 @@ -0,0 +1,361 @@
    14.4 +(*  Title:      HOLCF/Domain_Aux.thy
    14.5 +    Author:     Brian Huffman
    14.6 +*)
    14.7 +
    14.8 +header {* Domain package support *}
    14.9 +
   14.10 +theory Domain_Aux
   14.11 +imports Map_Functions Fixrec
   14.12 +uses
   14.13 +  ("Tools/Domain/domain_take_proofs.ML")
   14.14 +  ("Tools/cont_consts.ML")
   14.15 +  ("Tools/cont_proc.ML")
   14.16 +  ("Tools/Domain/domain_constructors.ML")
   14.17 +  ("Tools/Domain/domain_induction.ML")
   14.18 +begin
   14.19 +
   14.20 +subsection {* Continuous isomorphisms *}
   14.21 +
   14.22 +text {* A locale for continuous isomorphisms *}
   14.23 +
   14.24 +locale iso =
   14.25 +  fixes abs :: "'a \<rightarrow> 'b"
   14.26 +  fixes rep :: "'b \<rightarrow> 'a"
   14.27 +  assumes abs_iso [simp]: "rep\<cdot>(abs\<cdot>x) = x"
   14.28 +  assumes rep_iso [simp]: "abs\<cdot>(rep\<cdot>y) = y"
   14.29 +begin
   14.30 +
   14.31 +lemma swap: "iso rep abs"
   14.32 +  by (rule iso.intro [OF rep_iso abs_iso])
   14.33 +
   14.34 +lemma abs_below: "(abs\<cdot>x \<sqsubseteq> abs\<cdot>y) = (x \<sqsubseteq> y)"
   14.35 +proof
   14.36 +  assume "abs\<cdot>x \<sqsubseteq> abs\<cdot>y"
   14.37 +  then have "rep\<cdot>(abs\<cdot>x) \<sqsubseteq> rep\<cdot>(abs\<cdot>y)" by (rule monofun_cfun_arg)
   14.38 +  then show "x \<sqsubseteq> y" by simp
   14.39 +next
   14.40 +  assume "x \<sqsubseteq> y"
   14.41 +  then show "abs\<cdot>x \<sqsubseteq> abs\<cdot>y" by (rule monofun_cfun_arg)
   14.42 +qed
   14.43 +
   14.44 +lemma rep_below: "(rep\<cdot>x \<sqsubseteq> rep\<cdot>y) = (x \<sqsubseteq> y)"
   14.45 +  by (rule iso.abs_below [OF swap])
   14.46 +
   14.47 +lemma abs_eq: "(abs\<cdot>x = abs\<cdot>y) = (x = y)"
   14.48 +  by (simp add: po_eq_conv abs_below)
   14.49 +
   14.50 +lemma rep_eq: "(rep\<cdot>x = rep\<cdot>y) = (x = y)"
   14.51 +  by (rule iso.abs_eq [OF swap])
   14.52 +
   14.53 +lemma abs_strict: "abs\<cdot>\<bottom> = \<bottom>"
   14.54 +proof -
   14.55 +  have "\<bottom> \<sqsubseteq> rep\<cdot>\<bottom>" ..
   14.56 +  then have "abs\<cdot>\<bottom> \<sqsubseteq> abs\<cdot>(rep\<cdot>\<bottom>)" by (rule monofun_cfun_arg)
   14.57 +  then have "abs\<cdot>\<bottom> \<sqsubseteq> \<bottom>" by simp
   14.58 +  then show ?thesis by (rule UU_I)
   14.59 +qed
   14.60 +
   14.61 +lemma rep_strict: "rep\<cdot>\<bottom> = \<bottom>"
   14.62 +  by (rule iso.abs_strict [OF swap])
   14.63 +
   14.64 +lemma abs_defin': "abs\<cdot>x = \<bottom> \<Longrightarrow> x = \<bottom>"
   14.65 +proof -
   14.66 +  have "x = rep\<cdot>(abs\<cdot>x)" by simp
   14.67 +  also assume "abs\<cdot>x = \<bottom>"
   14.68 +  also note rep_strict
   14.69 +  finally show "x = \<bottom>" .
   14.70 +qed
   14.71 +
   14.72 +lemma rep_defin': "rep\<cdot>z = \<bottom> \<Longrightarrow> z = \<bottom>"
   14.73 +  by (rule iso.abs_defin' [OF swap])
   14.74 +
   14.75 +lemma abs_defined: "z \<noteq> \<bottom> \<Longrightarrow> abs\<cdot>z \<noteq> \<bottom>"
   14.76 +  by (erule contrapos_nn, erule abs_defin')
   14.77 +
   14.78 +lemma rep_defined: "z \<noteq> \<bottom> \<Longrightarrow> rep\<cdot>z \<noteq> \<bottom>"
   14.79 +  by (rule iso.abs_defined [OF iso.swap]) (rule iso_axioms)
   14.80 +
   14.81 +lemma abs_bottom_iff: "(abs\<cdot>x = \<bottom>) = (x = \<bottom>)"
   14.82 +  by (auto elim: abs_defin' intro: abs_strict)
   14.83 +
   14.84 +lemma rep_bottom_iff: "(rep\<cdot>x = \<bottom>) = (x = \<bottom>)"
   14.85 +  by (rule iso.abs_bottom_iff [OF iso.swap]) (rule iso_axioms)
   14.86 +
   14.87 +lemma casedist_rule: "rep\<cdot>x = \<bottom> \<or> P \<Longrightarrow> x = \<bottom> \<or> P"
   14.88 +  by (simp add: rep_bottom_iff)
   14.89 +
   14.90 +lemma compact_abs_rev: "compact (abs\<cdot>x) \<Longrightarrow> compact x"
   14.91 +proof (unfold compact_def)
   14.92 +  assume "adm (\<lambda>y. \<not> abs\<cdot>x \<sqsubseteq> y)"
   14.93 +  with cont_Rep_cfun2
   14.94 +  have "adm (\<lambda>y. \<not> abs\<cdot>x \<sqsubseteq> abs\<cdot>y)" by (rule adm_subst)
   14.95 +  then show "adm (\<lambda>y. \<not> x \<sqsubseteq> y)" using abs_below by simp
   14.96 +qed
   14.97 +
   14.98 +lemma compact_rep_rev: "compact (rep\<cdot>x) \<Longrightarrow> compact x"
   14.99 +  by (rule iso.compact_abs_rev [OF iso.swap]) (rule iso_axioms)
  14.100 +
  14.101 +lemma compact_abs: "compact x \<Longrightarrow> compact (abs\<cdot>x)"
  14.102 +  by (rule compact_rep_rev) simp
  14.103 +
  14.104 +lemma compact_rep: "compact x \<Longrightarrow> compact (rep\<cdot>x)"
  14.105 +  by (rule iso.compact_abs [OF iso.swap]) (rule iso_axioms)
  14.106 +
  14.107 +lemma iso_swap: "(x = abs\<cdot>y) = (rep\<cdot>x = y)"
  14.108 +proof
  14.109 +  assume "x = abs\<cdot>y"
  14.110 +  then have "rep\<cdot>x = rep\<cdot>(abs\<cdot>y)" by simp
  14.111 +  then show "rep\<cdot>x = y" by simp
  14.112 +next
  14.113 +  assume "rep\<cdot>x = y"
  14.114 +  then have "abs\<cdot>(rep\<cdot>x) = abs\<cdot>y" by simp
  14.115 +  then show "x = abs\<cdot>y" by simp
  14.116 +qed
  14.117 +
  14.118 +end
  14.119 +
  14.120 +subsection {* Proofs about take functions *}
  14.121 +
  14.122 +text {*
  14.123 +  This section contains lemmas that are used in a module that supports
  14.124 +  the domain isomorphism package; the module contains proofs related
  14.125 +  to take functions and the finiteness predicate.
  14.126 +*}
  14.127 +
  14.128 +lemma deflation_abs_rep:
  14.129 +  fixes abs and rep and d
  14.130 +  assumes abs_iso: "\<And>x. rep\<cdot>(abs\<cdot>x) = x"
  14.131 +  assumes rep_iso: "\<And>y. abs\<cdot>(rep\<cdot>y) = y"
  14.132 +  shows "deflation d \<Longrightarrow> deflation (abs oo d oo rep)"
  14.133 +by (rule ep_pair.deflation_e_d_p) (simp add: ep_pair.intro assms)
  14.134 +
  14.135 +lemma deflation_chain_min:
  14.136 +  assumes chain: "chain d"
  14.137 +  assumes defl: "\<And>n. deflation (d n)"
  14.138 +  shows "d m\<cdot>(d n\<cdot>x) = d (min m n)\<cdot>x"
  14.139 +proof (rule linorder_le_cases)
  14.140 +  assume "m \<le> n"
  14.141 +  with chain have "d m \<sqsubseteq> d n" by (rule chain_mono)
  14.142 +  then have "d m\<cdot>(d n\<cdot>x) = d m\<cdot>x"
  14.143 +    by (rule deflation_below_comp1 [OF defl defl])
  14.144 +  moreover from `m \<le> n` have "min m n = m" by simp
  14.145 +  ultimately show ?thesis by simp
  14.146 +next
  14.147 +  assume "n \<le> m"
  14.148 +  with chain have "d n \<sqsubseteq> d m" by (rule chain_mono)
  14.149 +  then have "d m\<cdot>(d n\<cdot>x) = d n\<cdot>x"
  14.150 +    by (rule deflation_below_comp2 [OF defl defl])
  14.151 +  moreover from `n \<le> m` have "min m n = n" by simp
  14.152 +  ultimately show ?thesis by simp
  14.153 +qed
  14.154 +
  14.155 +lemma lub_ID_take_lemma:
  14.156 +  assumes "chain t" and "(\<Squnion>n. t n) = ID"
  14.157 +  assumes "\<And>n. t n\<cdot>x = t n\<cdot>y" shows "x = y"
  14.158 +proof -
  14.159 +  have "(\<Squnion>n. t n\<cdot>x) = (\<Squnion>n. t n\<cdot>y)"
  14.160 +    using assms(3) by simp
  14.161 +  then have "(\<Squnion>n. t n)\<cdot>x = (\<Squnion>n. t n)\<cdot>y"
  14.162 +    using assms(1) by (simp add: lub_distribs)
  14.163 +  then show "x = y"
  14.164 +    using assms(2) by simp
  14.165 +qed
  14.166 +
  14.167 +lemma lub_ID_reach:
  14.168 +  assumes "chain t" and "(\<Squnion>n. t n) = ID"
  14.169 +  shows "(\<Squnion>n. t n\<cdot>x) = x"
  14.170 +using assms by (simp add: lub_distribs)
  14.171 +
  14.172 +lemma lub_ID_take_induct:
  14.173 +  assumes "chain t" and "(\<Squnion>n. t n) = ID"
  14.174 +  assumes "adm P" and "\<And>n. P (t n\<cdot>x)" shows "P x"
  14.175 +proof -
  14.176 +  from `chain t` have "chain (\<lambda>n. t n\<cdot>x)" by simp
  14.177 +  from `adm P` this `\<And>n. P (t n\<cdot>x)` have "P (\<Squnion>n. t n\<cdot>x)" by (rule admD)
  14.178 +  with `chain t` `(\<Squnion>n. t n) = ID` show "P x" by (simp add: lub_distribs)
  14.179 +qed
  14.180 +
  14.181 +subsection {* Finiteness *}
  14.182 +
  14.183 +text {*
  14.184 +  Let a ``decisive'' function be a deflation that maps every input to
  14.185 +  either itself or bottom.  Then if a domain's take functions are all
  14.186 +  decisive, then all values in the domain are finite.
  14.187 +*}
  14.188 +
  14.189 +definition
  14.190 +  decisive :: "('a::pcpo \<rightarrow> 'a) \<Rightarrow> bool"
  14.191 +where
  14.192 +  "decisive d \<longleftrightarrow> (\<forall>x. d\<cdot>x = x \<or> d\<cdot>x = \<bottom>)"
  14.193 +
  14.194 +lemma decisiveI: "(\<And>x. d\<cdot>x = x \<or> d\<cdot>x = \<bottom>) \<Longrightarrow> decisive d"
  14.195 +  unfolding decisive_def by simp
  14.196 +
  14.197 +lemma decisive_cases:
  14.198 +  assumes "decisive d" obtains "d\<cdot>x = x" | "d\<cdot>x = \<bottom>"
  14.199 +using assms unfolding decisive_def by auto
  14.200 +
  14.201 +lemma decisive_bottom: "decisive \<bottom>"
  14.202 +  unfolding decisive_def by simp
  14.203 +
  14.204 +lemma decisive_ID: "decisive ID"
  14.205 +  unfolding decisive_def by simp
  14.206 +
  14.207 +lemma decisive_ssum_map:
  14.208 +  assumes f: "decisive f"
  14.209 +  assumes g: "decisive g"
  14.210 +  shows "decisive (ssum_map\<cdot>f\<cdot>g)"
  14.211 +apply (rule decisiveI, rename_tac s)
  14.212 +apply (case_tac s, simp_all)
  14.213 +apply (rule_tac x=x in decisive_cases [OF f], simp_all)
  14.214 +apply (rule_tac x=y in decisive_cases [OF g], simp_all)
  14.215 +done
  14.216 +
  14.217 +lemma decisive_sprod_map:
  14.218 +  assumes f: "decisive f"
  14.219 +  assumes g: "decisive g"
  14.220 +  shows "decisive (sprod_map\<cdot>f\<cdot>g)"
  14.221 +apply (rule decisiveI, rename_tac s)
  14.222 +apply (case_tac s, simp_all)
  14.223 +apply (rule_tac x=x in decisive_cases [OF f], simp_all)
  14.224 +apply (rule_tac x=y in decisive_cases [OF g], simp_all)
  14.225 +done
  14.226 +
  14.227 +lemma decisive_abs_rep:
  14.228 +  fixes abs rep
  14.229 +  assumes iso: "iso abs rep"
  14.230 +  assumes d: "decisive d"
  14.231 +  shows "decisive (abs oo d oo rep)"
  14.232 +apply (rule decisiveI)
  14.233 +apply (rule_tac x="rep\<cdot>x" in decisive_cases [OF d])
  14.234 +apply (simp add: iso.rep_iso [OF iso])
  14.235 +apply (simp add: iso.abs_strict [OF iso])
  14.236 +done
  14.237 +
  14.238 +lemma lub_ID_finite:
  14.239 +  assumes chain: "chain d"
  14.240 +  assumes lub: "(\<Squnion>n. d n) = ID"
  14.241 +  assumes decisive: "\<And>n. decisive (d n)"
  14.242 +  shows "\<exists>n. d n\<cdot>x = x"
  14.243 +proof -
  14.244 +  have 1: "chain (\<lambda>n. d n\<cdot>x)" using chain by simp
  14.245 +  have 2: "(\<Squnion>n. d n\<cdot>x) = x" using chain lub by (rule lub_ID_reach)
  14.246 +  have "\<forall>n. d n\<cdot>x = x \<or> d n\<cdot>x = \<bottom>"
  14.247 +    using decisive unfolding decisive_def by simp
  14.248 +  hence "range (\<lambda>n. d n\<cdot>x) \<subseteq> {x, \<bottom>}"
  14.249 +    by auto
  14.250 +  hence "finite (range (\<lambda>n. d n\<cdot>x))"
  14.251 +    by (rule finite_subset, simp)
  14.252 +  with 1 have "finite_chain (\<lambda>n. d n\<cdot>x)"
  14.253 +    by (rule finite_range_imp_finch)
  14.254 +  then have "\<exists>n. (\<Squnion>n. d n\<cdot>x) = d n\<cdot>x"
  14.255 +    unfolding finite_chain_def by (auto simp add: maxinch_is_thelub)
  14.256 +  with 2 show "\<exists>n. d n\<cdot>x = x" by (auto elim: sym)
  14.257 +qed
  14.258 +
  14.259 +lemma lub_ID_finite_take_induct:
  14.260 +  assumes "chain d" and "(\<Squnion>n. d n) = ID" and "\<And>n. decisive (d n)"
  14.261 +  shows "(\<And>n. P (d n\<cdot>x)) \<Longrightarrow> P x"
  14.262 +using lub_ID_finite [OF assms] by metis
  14.263 +
  14.264 +subsection {* Proofs about constructor functions *}
  14.265 +
  14.266 +text {* Lemmas for proving nchotomy rule: *}
  14.267 +
  14.268 +lemma ex_one_bottom_iff:
  14.269 +  "(\<exists>x. P x \<and> x \<noteq> \<bottom>) = P ONE"
  14.270 +by simp
  14.271 +
  14.272 +lemma ex_up_bottom_iff:
  14.273 +  "(\<exists>x. P x \<and> x \<noteq> \<bottom>) = (\<exists>x. P (up\<cdot>x))"
  14.274 +by (safe, case_tac x, auto)
  14.275 +
  14.276 +lemma ex_sprod_bottom_iff:
  14.277 + "(\<exists>y. P y \<and> y \<noteq> \<bottom>) =
  14.278 +  (\<exists>x y. (P (:x, y:) \<and> x \<noteq> \<bottom>) \<and> y \<noteq> \<bottom>)"
  14.279 +by (safe, case_tac y, auto)
  14.280 +
  14.281 +lemma ex_sprod_up_bottom_iff:
  14.282 + "(\<exists>y. P y \<and> y \<noteq> \<bottom>) =
  14.283 +  (\<exists>x y. P (:up\<cdot>x, y:) \<and> y \<noteq> \<bottom>)"
  14.284 +by (safe, case_tac y, simp, case_tac x, auto)
  14.285 +
  14.286 +lemma ex_ssum_bottom_iff:
  14.287 + "(\<exists>x. P x \<and> x \<noteq> \<bottom>) =
  14.288 + ((\<exists>x. P (sinl\<cdot>x) \<and> x \<noteq> \<bottom>) \<or>
  14.289 +  (\<exists>x. P (sinr\<cdot>x) \<and> x \<noteq> \<bottom>))"
  14.290 +by (safe, case_tac x, auto)
  14.291 +
  14.292 +lemma exh_start: "p = \<bottom> \<or> (\<exists>x. p = x \<and> x \<noteq> \<bottom>)"
  14.293 +  by auto
  14.294 +
  14.295 +lemmas ex_bottom_iffs =
  14.296 +   ex_ssum_bottom_iff
  14.297 +   ex_sprod_up_bottom_iff
  14.298 +   ex_sprod_bottom_iff
  14.299 +   ex_up_bottom_iff
  14.300 +   ex_one_bottom_iff
  14.301 +
  14.302 +text {* Rules for turning nchotomy into exhaust: *}
  14.303 +
  14.304 +lemma exh_casedist0: "\<lbrakk>R; R \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P" (* like make_elim *)
  14.305 +  by auto
  14.306 +
  14.307 +lemma exh_casedist1: "((P \<or> Q \<Longrightarrow> R) \<Longrightarrow> S) \<equiv> (\<lbrakk>P \<Longrightarrow> R; Q \<Longrightarrow> R\<rbrakk> \<Longrightarrow> S)"
  14.308 +  by rule auto
  14.309 +
  14.310 +lemma exh_casedist2: "(\<exists>x. P x \<Longrightarrow> Q) \<equiv> (\<And>x. P x \<Longrightarrow> Q)"
  14.311 +  by rule auto
  14.312 +
  14.313 +lemma exh_casedist3: "(P \<and> Q \<Longrightarrow> R) \<equiv> (P \<Longrightarrow> Q \<Longrightarrow> R)"
  14.314 +  by rule auto
  14.315 +
  14.316 +lemmas exh_casedists = exh_casedist1 exh_casedist2 exh_casedist3
  14.317 +
  14.318 +text {* Rules for proving constructor properties *}
  14.319 +
  14.320 +lemmas con_strict_rules =
  14.321 +  sinl_strict sinr_strict spair_strict1 spair_strict2
  14.322 +
  14.323 +lemmas con_bottom_iff_rules =
  14.324 +  sinl_bottom_iff sinr_bottom_iff spair_bottom_iff up_defined ONE_defined
  14.325 +
  14.326 +lemmas con_below_iff_rules =
  14.327 +  sinl_below sinr_below sinl_below_sinr sinr_below_sinl con_bottom_iff_rules
  14.328 +
  14.329 +lemmas con_eq_iff_rules =
  14.330 +  sinl_eq sinr_eq sinl_eq_sinr sinr_eq_sinl con_bottom_iff_rules
  14.331 +
  14.332 +lemmas sel_strict_rules =
  14.333 +  cfcomp2 sscase1 sfst_strict ssnd_strict fup1
  14.334 +
  14.335 +lemma sel_app_extra_rules:
  14.336 +  "sscase\<cdot>ID\<cdot>\<bottom>\<cdot>(sinr\<cdot>x) = \<bottom>"
  14.337 +  "sscase\<cdot>ID\<cdot>\<bottom>\<cdot>(sinl\<cdot>x) = x"
  14.338 +  "sscase\<cdot>\<bottom>\<cdot>ID\<cdot>(sinl\<cdot>x) = \<bottom>"
  14.339 +  "sscase\<cdot>\<bottom>\<cdot>ID\<cdot>(sinr\<cdot>x) = x"
  14.340 +  "fup\<cdot>ID\<cdot>(up\<cdot>x) = x"
  14.341 +by (cases "x = \<bottom>", simp, simp)+
  14.342 +
  14.343 +lemmas sel_app_rules =
  14.344 +  sel_strict_rules sel_app_extra_rules
  14.345 +  ssnd_spair sfst_spair up_defined spair_defined
  14.346 +
  14.347 +lemmas sel_bottom_iff_rules =
  14.348 +  cfcomp2 sfst_bottom_iff ssnd_bottom_iff
  14.349 +
  14.350 +lemmas take_con_rules =
  14.351 +  ssum_map_sinl' ssum_map_sinr' sprod_map_spair' u_map_up
  14.352 +  deflation_strict deflation_ID ID1 cfcomp2
  14.353 +
  14.354 +subsection {* ML setup *}
  14.355 +
  14.356 +use "Tools/Domain/domain_take_proofs.ML"
  14.357 +use "Tools/cont_consts.ML"
  14.358 +use "Tools/cont_proc.ML"
  14.359 +use "Tools/Domain/domain_constructors.ML"
  14.360 +use "Tools/Domain/domain_induction.ML"
  14.361 +
  14.362 +setup Domain_Take_Proofs.setup
  14.363 +
  14.364 +end
    15.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    15.2 +++ b/src/HOL/HOLCF/FOCUS/Buffer.thy	Sat Nov 27 16:08:10 2010 -0800
    15.3 @@ -0,0 +1,381 @@
    15.4 +(*  Title:      HOLCF/FOCUS/Buffer.thy
    15.5 +    Author:     David von Oheimb, TU Muenchen
    15.6 +
    15.7 +Formalization of section 4 of
    15.8 +
    15.9 +@inproceedings {broy_mod94,
   15.10 +    author = {Manfred Broy},
   15.11 +    title = {{Specification and Refinement of a Buffer of Length One}},
   15.12 +    booktitle = {Deductive Program Design},
   15.13 +    year = {1994},
   15.14 +    editor = {Manfred Broy},
   15.15 +    volume = {152},
   15.16 +    series = {ASI Series, Series F: Computer and System Sciences},
   15.17 +    pages = {273 -- 304},
   15.18 +    publisher = {Springer}
   15.19 +}
   15.20 +
   15.21 +Slides available from http://ddvo.net/talks/1-Buffer.ps.gz
   15.22 +
   15.23 +*)
   15.24 +
   15.25 +theory Buffer
   15.26 +imports FOCUS
   15.27 +begin
   15.28 +
   15.29 +typedecl D
   15.30 +
   15.31 +datatype
   15.32 +
   15.33 +  M     = Md D | Mreq ("\<bullet>")
   15.34 +
   15.35 +datatype
   15.36 +
   15.37 +  State = Sd D | Snil ("\<currency>")
   15.38 +
   15.39 +types
   15.40 +
   15.41 +  SPF11         = "M fstream \<rightarrow> D fstream"
   15.42 +  SPEC11        = "SPF11 set"
   15.43 +  SPSF11        = "State \<Rightarrow> SPF11"
   15.44 +  SPECS11       = "SPSF11 set"
   15.45 +
   15.46 +definition
   15.47 +  BufEq_F       :: "SPEC11 \<Rightarrow> SPEC11" where
   15.48 +  "BufEq_F B = {f. \<forall>d. f\<cdot>(Md d\<leadsto><>) = <> \<and>
   15.49 +                (\<forall>x. \<exists>ff\<in>B. f\<cdot>(Md d\<leadsto>\<bullet>\<leadsto>x) = d\<leadsto>ff\<cdot>x)}"
   15.50 +
   15.51 +definition
   15.52 +  BufEq         :: "SPEC11" where
   15.53 +  "BufEq = gfp BufEq_F"
   15.54 +
   15.55 +definition
   15.56 +  BufEq_alt     :: "SPEC11" where
   15.57 +  "BufEq_alt = gfp (\<lambda>B. {f. \<forall>d. f\<cdot>(Md d\<leadsto><> ) = <> \<and>
   15.58 +                         (\<exists>ff\<in>B. (\<forall>x. f\<cdot>(Md d\<leadsto>\<bullet>\<leadsto>x) = d\<leadsto>ff\<cdot>x))})"
   15.59 +
   15.60 +definition
   15.61 +  BufAC_Asm_F   :: " (M fstream set) \<Rightarrow> (M fstream set)" where
   15.62 +  "BufAC_Asm_F A = {s. s = <> \<or>
   15.63 +                  (\<exists>d x. s = Md d\<leadsto>x \<and> (x = <> \<or> (ft\<cdot>x = Def \<bullet> \<and> (rt\<cdot>x)\<in>A)))}"
   15.64 +
   15.65 +definition
   15.66 +  BufAC_Asm     :: " (M fstream set)" where
   15.67 +  "BufAC_Asm = gfp BufAC_Asm_F"
   15.68 +
   15.69 +definition
   15.70 +  BufAC_Cmt_F   :: "((M fstream * D fstream) set) \<Rightarrow>
   15.71 +                    ((M fstream * D fstream) set)" where
   15.72 +  "BufAC_Cmt_F C = {(s,t). \<forall>d x.
   15.73 +                           (s = <>         \<longrightarrow>     t = <>                 ) \<and>
   15.74 +                           (s = Md d\<leadsto><>   \<longrightarrow>     t = <>                 ) \<and>
   15.75 +                           (s = Md d\<leadsto>\<bullet>\<leadsto>x \<longrightarrow> (ft\<cdot>t = Def d \<and> (x,rt\<cdot>t)\<in>C))}"
   15.76 +
   15.77 +definition
   15.78 +  BufAC_Cmt     :: "((M fstream * D fstream) set)" where
   15.79 +  "BufAC_Cmt = gfp BufAC_Cmt_F"
   15.80 +
   15.81 +definition
   15.82 +  BufAC         :: "SPEC11" where
   15.83 +  "BufAC = {f. \<forall>x. x\<in>BufAC_Asm \<longrightarrow> (x,f\<cdot>x)\<in>BufAC_Cmt}"
   15.84 +
   15.85 +definition
   15.86 +  BufSt_F       :: "SPECS11 \<Rightarrow> SPECS11" where
   15.87 +  "BufSt_F H = {h. \<forall>s  . h s      \<cdot><>        = <>         \<and>
   15.88 +                                 (\<forall>d x. h \<currency>     \<cdot>(Md d\<leadsto>x) = h (Sd d)\<cdot>x \<and>
   15.89 +                                (\<exists>hh\<in>H. h (Sd d)\<cdot>(\<bullet>   \<leadsto>x) = d\<leadsto>(hh \<currency>\<cdot>x)))}"
   15.90 +
   15.91 +definition
   15.92 +  BufSt_P       :: "SPECS11" where
   15.93 +  "BufSt_P = gfp BufSt_F"
   15.94 +
   15.95 +definition
   15.96 +  BufSt         :: "SPEC11" where
   15.97 +  "BufSt = {f. \<exists>h\<in>BufSt_P. f = h \<currency>}"
   15.98 +
   15.99 +
  15.100 +lemma set_cong: "!!X. A = B ==> (x:A) = (x:B)"
  15.101 +by (erule subst, rule refl)
  15.102 +
  15.103 +
  15.104 +(**** BufEq *******************************************************************)
  15.105 +
  15.106 +lemma mono_BufEq_F: "mono BufEq_F"
  15.107 +by (unfold mono_def BufEq_F_def, fast)
  15.108 +
  15.109 +lemmas BufEq_fix = mono_BufEq_F [THEN BufEq_def [THEN eq_reflection, THEN def_gfp_unfold]]
  15.110 +
  15.111 +lemma BufEq_unfold: "(f:BufEq) = (!d. f\<cdot>(Md d\<leadsto><>) = <> &
  15.112 +                 (!x. ? ff:BufEq. f\<cdot>(Md d\<leadsto>\<bullet>\<leadsto>x) = d\<leadsto>(ff\<cdot>x)))"
  15.113 +apply (subst BufEq_fix [THEN set_cong])
  15.114 +apply (unfold BufEq_F_def)
  15.115 +apply (simp)
  15.116 +done
  15.117 +
  15.118 +lemma Buf_f_empty: "f:BufEq \<Longrightarrow> f\<cdot><> = <>"
  15.119 +by (drule BufEq_unfold [THEN iffD1], auto)
  15.120 +
  15.121 +lemma Buf_f_d: "f:BufEq \<Longrightarrow> f\<cdot>(Md d\<leadsto><>) = <>"
  15.122 +by (drule BufEq_unfold [THEN iffD1], auto)
  15.123 +
  15.124 +lemma Buf_f_d_req:
  15.125 +        "f:BufEq \<Longrightarrow> \<exists>ff. ff:BufEq \<and> f\<cdot>(Md d\<leadsto>\<bullet>\<leadsto>x) = d\<leadsto>ff\<cdot>x"
  15.126 +by (drule BufEq_unfold [THEN iffD1], auto)
  15.127 +
  15.128 +
  15.129 +(**** BufAC_Asm ***************************************************************)
  15.130 +
  15.131 +lemma mono_BufAC_Asm_F: "mono BufAC_Asm_F"
  15.132 +by (unfold mono_def BufAC_Asm_F_def, fast)
  15.133 +
  15.134 +lemmas BufAC_Asm_fix =
  15.135 +  mono_BufAC_Asm_F [THEN BufAC_Asm_def [THEN eq_reflection, THEN def_gfp_unfold]]
  15.136 +
  15.137 +lemma BufAC_Asm_unfold: "(s:BufAC_Asm) = (s = <> | (? d x. 
  15.138 +        s = Md d\<leadsto>x & (x = <> | (ft\<cdot>x = Def \<bullet> & (rt\<cdot>x):BufAC_Asm))))"
  15.139 +apply (subst BufAC_Asm_fix [THEN set_cong])
  15.140 +apply (unfold BufAC_Asm_F_def)
  15.141 +apply (simp)
  15.142 +done
  15.143 +
  15.144 +lemma BufAC_Asm_empty: "<>     :BufAC_Asm"
  15.145 +by (rule BufAC_Asm_unfold [THEN iffD2], auto)
  15.146 +
  15.147 +lemma BufAC_Asm_d: "Md d\<leadsto><>:BufAC_Asm"
  15.148 +by (rule BufAC_Asm_unfold [THEN iffD2], auto)
  15.149 +lemma BufAC_Asm_d_req: "x:BufAC_Asm ==> Md d\<leadsto>\<bullet>\<leadsto>x:BufAC_Asm"
  15.150 +by (rule BufAC_Asm_unfold [THEN iffD2], auto)
  15.151 +lemma BufAC_Asm_prefix2: "a\<leadsto>b\<leadsto>s:BufAC_Asm ==> s:BufAC_Asm"
  15.152 +by (drule BufAC_Asm_unfold [THEN iffD1], auto)
  15.153 +
  15.154 +
  15.155 +(**** BBufAC_Cmt **************************************************************)
  15.156 +
  15.157 +lemma mono_BufAC_Cmt_F: "mono BufAC_Cmt_F"
  15.158 +by (unfold mono_def BufAC_Cmt_F_def, fast)
  15.159 +
  15.160 +lemmas BufAC_Cmt_fix =
  15.161 +  mono_BufAC_Cmt_F [THEN BufAC_Cmt_def [THEN eq_reflection, THEN def_gfp_unfold]]
  15.162 +
  15.163 +lemma BufAC_Cmt_unfold: "((s,t):BufAC_Cmt) = (!d x. 
  15.164 +     (s = <>       -->      t = <>) & 
  15.165 +     (s = Md d\<leadsto><>  -->      t = <>) & 
  15.166 +     (s = Md d\<leadsto>\<bullet>\<leadsto>x --> ft\<cdot>t = Def d & (x, rt\<cdot>t):BufAC_Cmt))"
  15.167 +apply (subst BufAC_Cmt_fix [THEN set_cong])
  15.168 +apply (unfold BufAC_Cmt_F_def)
  15.169 +apply (simp)
  15.170 +done
  15.171 +
  15.172 +lemma BufAC_Cmt_empty: "f:BufEq ==> (<>, f\<cdot><>):BufAC_Cmt"
  15.173 +by (rule BufAC_Cmt_unfold [THEN iffD2], auto simp add: Buf_f_empty)
  15.174 +
  15.175 +lemma BufAC_Cmt_d: "f:BufEq ==> (a\<leadsto>\<bottom>, f\<cdot>(a\<leadsto>\<bottom>)):BufAC_Cmt"
  15.176 +by (rule BufAC_Cmt_unfold [THEN iffD2], auto simp add: Buf_f_d)
  15.177 +
  15.178 +lemma BufAC_Cmt_d2:
  15.179 + "(Md d\<leadsto>\<bottom>, f\<cdot>(Md d\<leadsto>\<bottom>)):BufAC_Cmt ==> f\<cdot>(Md d\<leadsto>\<bottom>) = \<bottom>"
  15.180 +by (drule BufAC_Cmt_unfold [THEN iffD1], auto)
  15.181 +
  15.182 +lemma BufAC_Cmt_d3:
  15.183 +"(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"
  15.184 +by (drule BufAC_Cmt_unfold [THEN iffD1], auto)
  15.185 +
  15.186 +lemma BufAC_Cmt_d32:
  15.187 +"(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"
  15.188 +by (drule BufAC_Cmt_unfold [THEN iffD1], auto)
  15.189 +
  15.190 +(**** BufAC *******************************************************************)
  15.191 +
  15.192 +lemma BufAC_f_d: "f \<in> BufAC \<Longrightarrow> f\<cdot>(Md d\<leadsto>\<bottom>) = \<bottom>"
  15.193 +apply (unfold BufAC_def)
  15.194 +apply (fast intro: BufAC_Cmt_d2 BufAC_Asm_d)
  15.195 +done
  15.196 +
  15.197 +lemma ex_elim_lemma: "(? ff:B. (!x. f\<cdot>(a\<leadsto>b\<leadsto>x) = d\<leadsto>ff\<cdot>x)) = 
  15.198 +    ((!x. ft\<cdot>(f\<cdot>(a\<leadsto>b\<leadsto>x)) = Def d) & (LAM x. rt\<cdot>(f\<cdot>(a\<leadsto>b\<leadsto>x))):B)"
  15.199 +(*  this is an instance (though unification cannot handle this) of
  15.200 +lemma "(? ff:B. (!x. f\<cdot>x = d\<leadsto>ff\<cdot>x)) = \
  15.201 +   \((!x. ft\<cdot>(f\<cdot>x) = Def d) & (LAM x. rt\<cdot>(f\<cdot>x)):B)"*)
  15.202 +apply safe
  15.203 +apply (  rule_tac [2] P="(%x. x:B)" in ssubst)
  15.204 +prefer 3
  15.205 +apply (   assumption)
  15.206 +apply (  rule_tac [2] cfun_eqI)
  15.207 +apply (  drule_tac [2] spec)
  15.208 +apply (  drule_tac [2] f="rt" in cfun_arg_cong)
  15.209 +prefer 2
  15.210 +apply (  simp)
  15.211 +prefer 2
  15.212 +apply ( simp)
  15.213 +apply (rule_tac bexI)
  15.214 +apply auto
  15.215 +apply (drule spec)
  15.216 +apply (erule exE)
  15.217 +apply (erule ssubst)
  15.218 +apply (simp)
  15.219 +done
  15.220 +
  15.221 +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"
  15.222 +apply (unfold BufAC_def)
  15.223 +apply (rule ex_elim_lemma [THEN iffD2])
  15.224 +apply safe
  15.225 +apply  (fast intro: BufAC_Cmt_d32 [THEN Def_maximal]
  15.226 +             monofun_cfun_arg BufAC_Asm_empty [THEN BufAC_Asm_d_req])
  15.227 +apply (auto intro: BufAC_Cmt_d3 BufAC_Asm_d_req)
  15.228 +done
  15.229 +
  15.230 +
  15.231 +(**** BufSt *******************************************************************)
  15.232 +
  15.233 +lemma mono_BufSt_F: "mono BufSt_F"
  15.234 +by (unfold mono_def BufSt_F_def, fast)
  15.235 +
  15.236 +lemmas BufSt_P_fix =
  15.237 +  mono_BufSt_F [THEN BufSt_P_def [THEN eq_reflection, THEN def_gfp_unfold]]
  15.238 +
  15.239 +lemma BufSt_P_unfold: "(h:BufSt_P) = (!s. h s\<cdot><> = <> & 
  15.240 +           (!d x. h \<currency>     \<cdot>(Md d\<leadsto>x)   =    h (Sd d)\<cdot>x & 
  15.241 +      (? hh:BufSt_P. h (Sd d)\<cdot>(\<bullet>\<leadsto>x)   = d\<leadsto>(hh \<currency>    \<cdot>x))))"
  15.242 +apply (subst BufSt_P_fix [THEN set_cong])
  15.243 +apply (unfold BufSt_F_def)
  15.244 +apply (simp)
  15.245 +done
  15.246 +
  15.247 +lemma BufSt_P_empty: "h:BufSt_P ==> h s     \<cdot> <>       = <>"
  15.248 +by (drule BufSt_P_unfold [THEN iffD1], auto)
  15.249 +lemma BufSt_P_d: "h:BufSt_P ==> h  \<currency>    \<cdot>(Md d\<leadsto>x) = h (Sd d)\<cdot>x"
  15.250 +by (drule BufSt_P_unfold [THEN iffD1], auto)
  15.251 +lemma BufSt_P_d_req: "h:BufSt_P ==> \<exists>hh\<in>BufSt_P.
  15.252 +                                          h (Sd d)\<cdot>(\<bullet>   \<leadsto>x) = d\<leadsto>(hh \<currency>    \<cdot>x)"
  15.253 +by (drule BufSt_P_unfold [THEN iffD1], auto)
  15.254 +
  15.255 +
  15.256 +(**** Buf_AC_imp_Eq ***********************************************************)
  15.257 +
  15.258 +lemma Buf_AC_imp_Eq: "BufAC \<subseteq> BufEq"
  15.259 +apply (unfold BufEq_def)
  15.260 +apply (rule gfp_upperbound)
  15.261 +apply (unfold BufEq_F_def)
  15.262 +apply safe
  15.263 +apply  (erule BufAC_f_d)
  15.264 +apply (drule BufAC_f_d_req)
  15.265 +apply (fast)
  15.266 +done
  15.267 +
  15.268 +
  15.269 +(**** Buf_Eq_imp_AC by coinduction ********************************************)
  15.270 +
  15.271 +lemma BufAC_Asm_cong_lemma [rule_format]: "\<forall>s f ff. f\<in>BufEq \<longrightarrow> ff\<in>BufEq \<longrightarrow> 
  15.272 +  s\<in>BufAC_Asm \<longrightarrow> stream_take n\<cdot>(f\<cdot>s) = stream_take n\<cdot>(ff\<cdot>s)"
  15.273 +apply (induct_tac "n")
  15.274 +apply  (simp)
  15.275 +apply (intro strip)
  15.276 +apply (drule BufAC_Asm_unfold [THEN iffD1])
  15.277 +apply safe
  15.278 +apply   (simp add: Buf_f_empty)
  15.279 +apply  (simp add: Buf_f_d)
  15.280 +apply (drule ft_eq [THEN iffD1])
  15.281 +apply (clarsimp)
  15.282 +apply (drule Buf_f_d_req)+
  15.283 +apply safe
  15.284 +apply (erule ssubst)+
  15.285 +apply (simp (no_asm))
  15.286 +apply (fast)
  15.287 +done
  15.288 +
  15.289 +lemma BufAC_Asm_cong: "\<lbrakk>f \<in> BufEq; ff \<in> BufEq; s \<in> BufAC_Asm\<rbrakk> \<Longrightarrow> f\<cdot>s = ff\<cdot>s"
  15.290 +apply (rule stream.take_lemma)
  15.291 +apply (erule (2) BufAC_Asm_cong_lemma)
  15.292 +done
  15.293 +
  15.294 +lemma Buf_Eq_imp_AC_lemma: "\<lbrakk>f \<in> BufEq; x \<in> BufAC_Asm\<rbrakk> \<Longrightarrow> (x, f\<cdot>x) \<in> BufAC_Cmt"
  15.295 +apply (unfold BufAC_Cmt_def)
  15.296 +apply (rotate_tac)
  15.297 +apply (erule weak_coinduct_image)
  15.298 +apply (unfold BufAC_Cmt_F_def)
  15.299 +apply safe
  15.300 +apply    (erule Buf_f_empty)
  15.301 +apply   (erule Buf_f_d)
  15.302 +apply  (drule Buf_f_d_req)
  15.303 +apply  (clarsimp)
  15.304 +apply  (erule exI)
  15.305 +apply (drule BufAC_Asm_prefix2)
  15.306 +apply (frule Buf_f_d_req)
  15.307 +apply (clarsimp)
  15.308 +apply (erule ssubst)
  15.309 +apply (simp)
  15.310 +apply (drule (2) BufAC_Asm_cong)
  15.311 +apply (erule subst)
  15.312 +apply (erule imageI)
  15.313 +done
  15.314 +lemma Buf_Eq_imp_AC: "BufEq \<subseteq> BufAC"
  15.315 +apply (unfold BufAC_def)
  15.316 +apply (clarify)
  15.317 +apply (erule (1) Buf_Eq_imp_AC_lemma)
  15.318 +done
  15.319 +
  15.320 +(**** Buf_Eq_eq_AC ************************************************************)
  15.321 +
  15.322 +lemmas Buf_Eq_eq_AC = Buf_AC_imp_Eq [THEN Buf_Eq_imp_AC [THEN subset_antisym]]
  15.323 +
  15.324 +
  15.325 +(**** alternative (not strictly) stronger version of Buf_Eq *******************)
  15.326 +
  15.327 +lemma Buf_Eq_alt_imp_Eq: "BufEq_alt \<subseteq> BufEq"
  15.328 +apply (unfold BufEq_def BufEq_alt_def)
  15.329 +apply (rule gfp_mono)
  15.330 +apply (unfold BufEq_F_def)
  15.331 +apply (fast)
  15.332 +done
  15.333 +
  15.334 +(* direct proof of "BufEq \<subseteq> BufEq_alt" seems impossible *)
  15.335 +
  15.336 +
  15.337 +lemma Buf_AC_imp_Eq_alt: "BufAC <= BufEq_alt"
  15.338 +apply (unfold BufEq_alt_def)
  15.339 +apply (rule gfp_upperbound)
  15.340 +apply (fast elim: BufAC_f_d BufAC_f_d_req)
  15.341 +done
  15.342 +
  15.343 +lemmas Buf_Eq_imp_Eq_alt = subset_trans [OF Buf_Eq_imp_AC Buf_AC_imp_Eq_alt]
  15.344 +
  15.345 +lemmas Buf_Eq_alt_eq = subset_antisym [OF Buf_Eq_alt_imp_Eq Buf_Eq_imp_Eq_alt]
  15.346 +
  15.347 +
  15.348 +(**** Buf_Eq_eq_St ************************************************************)
  15.349 +
  15.350 +lemma Buf_St_imp_Eq: "BufSt <= BufEq"
  15.351 +apply (unfold BufSt_def BufEq_def)
  15.352 +apply (rule gfp_upperbound)
  15.353 +apply (unfold BufEq_F_def)
  15.354 +apply safe
  15.355 +apply ( simp add: BufSt_P_d BufSt_P_empty)
  15.356 +apply (simp add: BufSt_P_d)
  15.357 +apply (drule BufSt_P_d_req)
  15.358 +apply (force)
  15.359 +done
  15.360 +
  15.361 +lemma Buf_Eq_imp_St: "BufEq <= BufSt"
  15.362 +apply (unfold BufSt_def BufSt_P_def)
  15.363 +apply safe
  15.364 +apply (rename_tac f)
  15.365 +apply (rule_tac x="\<lambda>s. case s of Sd d => \<Lambda> x. f\<cdot>(Md d\<leadsto>x)| \<currency> => f" in bexI)
  15.366 +apply ( simp)
  15.367 +apply (erule weak_coinduct_image)
  15.368 +apply (unfold BufSt_F_def)
  15.369 +apply (simp)
  15.370 +apply safe
  15.371 +apply (  rename_tac "s")
  15.372 +apply (  induct_tac "s")
  15.373 +apply (   simp add: Buf_f_d)
  15.374 +apply (  simp add: Buf_f_empty)
  15.375 +apply ( simp)
  15.376 +apply (simp)
  15.377 +apply (rename_tac f d x)
  15.378 +apply (drule_tac d="d" and x="x" in Buf_f_d_req)
  15.379 +apply auto
  15.380 +done
  15.381 +
  15.382 +lemmas Buf_Eq_eq_St = Buf_St_imp_Eq [THEN Buf_Eq_imp_St [THEN subset_antisym]]
  15.383 +
  15.384 +end
    16.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    16.2 +++ b/src/HOL/HOLCF/FOCUS/Buffer_adm.thy	Sat Nov 27 16:08:10 2010 -0800
    16.3 @@ -0,0 +1,300 @@
    16.4 +(*  Title:      HOLCF/FOCUS/Buffer_adm.thy
    16.5 +    Author:     David von Oheimb, TU Muenchen
    16.6 +*)
    16.7 +
    16.8 +header {* One-element buffer, proof of Buf_Eq_imp_AC by induction + admissibility *}
    16.9 +
   16.10 +theory Buffer_adm
   16.11 +imports Buffer Stream_adm
   16.12 +begin
   16.13 +
   16.14 +declare Fin_0 [simp]
   16.15 +
   16.16 +lemma BufAC_Asm_d2: "a\<leadsto>s:BufAC_Asm ==> ? d. a=Md d"
   16.17 +by (drule BufAC_Asm_unfold [THEN iffD1], auto)
   16.18 +
   16.19 +lemma BufAC_Asm_d3:
   16.20 +    "a\<leadsto>b\<leadsto>s:BufAC_Asm ==> ? d. a=Md d & b=\<bullet> & s:BufAC_Asm"
   16.21 +by (drule BufAC_Asm_unfold [THEN iffD1], auto)
   16.22 +
   16.23 +lemma BufAC_Asm_F_def3:
   16.24 + "(s:BufAC_Asm_F A) = (s=<> | 
   16.25 +  (? d. ft\<cdot>s=Def(Md d)) & (rt\<cdot>s=<> | ft\<cdot>(rt\<cdot>s)=Def \<bullet> & rt\<cdot>(rt\<cdot>s):A))"
   16.26 +by (unfold BufAC_Asm_F_def, auto)
   16.27 +
   16.28 +lemma cont_BufAC_Asm_F: "down_cont BufAC_Asm_F"
   16.29 +by (auto simp add: down_cont_def BufAC_Asm_F_def3)
   16.30 +
   16.31 +lemma BufAC_Cmt_F_def3:
   16.32 + "((s,t):BufAC_Cmt_F C) = (!d x.
   16.33 +    (s = <>       --> t = <>                   ) & 
   16.34 +    (s = Md d\<leadsto><>  --> t = <>                   ) & 
   16.35 +    (s = Md d\<leadsto>\<bullet>\<leadsto>x --> ft\<cdot>t = Def d & (x,rt\<cdot>t):C))"
   16.36 +apply (unfold BufAC_Cmt_F_def)
   16.37 +apply (subgoal_tac "!d x. (s = Md d\<leadsto>\<bullet>\<leadsto>x --> (? y. t = d\<leadsto>y & (x,y):C)) = 
   16.38 +                     (s = Md d\<leadsto>\<bullet>\<leadsto>x --> ft\<cdot>t = Def d & (x,rt\<cdot>t):C)")
   16.39 +apply (simp)
   16.40 +apply (auto intro: surjectiv_scons [symmetric])
   16.41 +done
   16.42 +
   16.43 +lemma cont_BufAC_Cmt_F: "down_cont BufAC_Cmt_F"
   16.44 +by (auto simp add: down_cont_def BufAC_Cmt_F_def3)
   16.45 +
   16.46 +
   16.47 +(**** adm_BufAC_Asm ***********************************************************)
   16.48 +
   16.49 +lemma BufAC_Asm_F_stream_monoP: "stream_monoP BufAC_Asm_F"
   16.50 +apply (unfold BufAC_Asm_F_def stream_monoP_def)
   16.51 +apply (rule_tac x="{x. (? d. x = Md d\<leadsto>\<bullet>\<leadsto><>)}" in exI)
   16.52 +apply (rule_tac x="Suc (Suc 0)" in exI)
   16.53 +apply (clarsimp)
   16.54 +done
   16.55 +
   16.56 +lemma adm_BufAC_Asm: "adm (%x. x:BufAC_Asm)"
   16.57 +apply (unfold BufAC_Asm_def)
   16.58 +apply (rule cont_BufAC_Asm_F [THEN BufAC_Asm_F_stream_monoP [THEN fstream_gfp_admI]])
   16.59 +done
   16.60 +
   16.61 +
   16.62 +(**** adm_non_BufAC_Asm *******************************************************)
   16.63 +
   16.64 +lemma BufAC_Asm_F_stream_antiP: "stream_antiP BufAC_Asm_F"
   16.65 +apply (unfold stream_antiP_def BufAC_Asm_F_def)
   16.66 +apply (intro strip)
   16.67 +apply (rule_tac x="{x. (? d. x = Md d\<leadsto>\<bullet>\<leadsto><>)}" in exI)
   16.68 +apply (rule_tac x="Suc (Suc 0)" in exI)
   16.69 +apply (rule conjI)
   16.70 +prefer 2
   16.71 +apply ( intro strip)
   16.72 +apply ( drule slen_mono)
   16.73 +apply ( drule (1) order_trans)
   16.74 +apply (force)+
   16.75 +done
   16.76 +
   16.77 +lemma adm_non_BufAC_Asm: "adm (%u. u~:BufAC_Asm)"
   16.78 +apply (unfold BufAC_Asm_def)
   16.79 +apply (rule cont_BufAC_Asm_F [THEN BufAC_Asm_F_stream_antiP [THEN fstream_non_gfp_admI]])
   16.80 +done
   16.81 +
   16.82 +(**** adm_BufAC ***************************************************************)
   16.83 +
   16.84 +(*adm_non_BufAC_Asm*)
   16.85 +lemma BufAC_Asm_cong [rule_format]: "!f ff. f:BufEq --> ff:BufEq --> s:BufAC_Asm --> f\<cdot>s = ff\<cdot>s"
   16.86 +apply (rule fstream_ind2)
   16.87 +apply (simp add: adm_non_BufAC_Asm)
   16.88 +apply   (force dest: Buf_f_empty)
   16.89 +apply  (force dest!: BufAC_Asm_d2
   16.90 +              dest: Buf_f_d elim: ssubst)
   16.91 +apply (safe dest!: BufAC_Asm_d3)
   16.92 +apply (drule Buf_f_d_req)+
   16.93 +apply (fast elim: ssubst)
   16.94 +done
   16.95 +
   16.96 +(*adm_non_BufAC_Asm,BufAC_Asm_cong*)
   16.97 +lemma BufAC_Cmt_d_req:
   16.98 +"!!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"
   16.99 +apply (rule BufAC_Cmt_unfold [THEN iffD2])
  16.100 +apply (intro strip)
  16.101 +apply (frule Buf_f_d_req)
  16.102 +apply (auto elim: BufAC_Asm_cong [THEN subst])
  16.103 +done
  16.104 +
  16.105 +(*adm_BufAC_Asm*)
  16.106 +lemma BufAC_Asm_antiton: "antitonP BufAC_Asm"
  16.107 +apply (rule antitonPI)
  16.108 +apply (rule allI)
  16.109 +apply (rule fstream_ind2)
  16.110 +apply (  rule adm_lemmas)+
  16.111 +apply (   rule cont_id)
  16.112 +apply (   rule adm_BufAC_Asm)
  16.113 +apply (  safe)
  16.114 +apply (  rule BufAC_Asm_empty)
  16.115 +apply ( force dest!: fstream_prefix
  16.116 +              dest: BufAC_Asm_d2 intro: BufAC_Asm_d)
  16.117 +apply ( force dest!: fstream_prefix
  16.118 +              dest: BufAC_Asm_d3 intro!: BufAC_Asm_d_req)
  16.119 +done
  16.120 +
  16.121 +(*adm_BufAC_Asm,BufAC_Asm_antiton,adm_non_BufAC_Asm,BufAC_Asm_cong*)
  16.122 +lemma BufAC_Cmt_2stream_monoP: "f:BufEq ==> ? l. !i x s. s:BufAC_Asm --> x << s --> Fin (l i) < #x --> 
  16.123 +                     (x,f\<cdot>x):down_iterate BufAC_Cmt_F i --> 
  16.124 +                     (s,f\<cdot>s):down_iterate BufAC_Cmt_F i"
  16.125 +apply (rule_tac x="%i. 2*i" in exI)
  16.126 +apply (rule allI)
  16.127 +apply (induct_tac "i")
  16.128 +apply ( simp)
  16.129 +apply (simp add: add_commute)
  16.130 +apply (intro strip)
  16.131 +apply (subst BufAC_Cmt_F_def3)
  16.132 +apply (drule_tac P="%x. x" in BufAC_Cmt_F_def3 [THEN subst])
  16.133 +apply safe
  16.134 +apply (   erule Buf_f_empty)
  16.135 +apply (  erule Buf_f_d)
  16.136 +apply ( drule Buf_f_d_req)
  16.137 +apply ( safe, erule ssubst, simp)
  16.138 +apply clarsimp
  16.139 +apply (rename_tac i d xa ya t)
  16.140 +(*
  16.141 + 1. \<And>i d xa ya t.
  16.142 +       \<lbrakk>f \<in> BufEq;
  16.143 +          \<forall>x s. s \<in> BufAC_Asm \<longrightarrow>
  16.144 +                x \<sqsubseteq> s \<longrightarrow>
  16.145 +                Fin (2 * i) < #x \<longrightarrow>
  16.146 +                (x, f\<cdot>x) \<in> down_iterate BufAC_Cmt_F i \<longrightarrow>
  16.147 +                (s, f\<cdot>s) \<in> down_iterate BufAC_Cmt_F i;
  16.148 +          Md d\<leadsto>\<bullet>\<leadsto>xa \<in> BufAC_Asm; Fin (2 * i) < #ya; f\<cdot>(Md d\<leadsto>\<bullet>\<leadsto>ya) = d\<leadsto>t;
  16.149 +          (ya, t) \<in> down_iterate BufAC_Cmt_F i; ya \<sqsubseteq> xa\<rbrakk>
  16.150 +       \<Longrightarrow> (xa, rt\<cdot>(f\<cdot>(Md d\<leadsto>\<bullet>\<leadsto>xa))) \<in> down_iterate BufAC_Cmt_F i
  16.151 +*)
  16.152 +apply (rotate_tac 2)
  16.153 +apply (drule BufAC_Asm_prefix2)
  16.154 +apply (frule Buf_f_d_req, erule exE, erule conjE, rotate_tac -1, erule ssubst)
  16.155 +apply (frule Buf_f_d_req, erule exE, erule conjE)
  16.156 +apply (            subgoal_tac "f\<cdot>(Md d\<leadsto>\<bullet>\<leadsto>ya) = d\<leadsto>ffa\<cdot>ya")
  16.157 +prefer 2
  16.158 +apply ( assumption)
  16.159 +apply (            rotate_tac -1)
  16.160 +apply (            simp)
  16.161 +apply (erule subst)
  16.162 +(*
  16.163 + 1. \<And>i d xa ya t ff ffa.
  16.164 +       \<lbrakk>f\<cdot>(Md d\<leadsto>\<bullet>\<leadsto>ya) = d\<leadsto>ffa\<cdot>ya; Fin (2 * i) < #ya;
  16.165 +          (ya, ffa\<cdot>ya) \<in> down_iterate BufAC_Cmt_F i; ya \<sqsubseteq> xa; f \<in> BufEq;
  16.166 +          \<forall>x s. s \<in> BufAC_Asm \<longrightarrow>
  16.167 +                x \<sqsubseteq> s \<longrightarrow>
  16.168 +                Fin (2 * i) < #x \<longrightarrow>
  16.169 +                (x, f\<cdot>x) \<in> down_iterate BufAC_Cmt_F i \<longrightarrow>
  16.170 +                (s, f\<cdot>s) \<in> down_iterate BufAC_Cmt_F i;
  16.171 +          xa \<in> BufAC_Asm; ff \<in> BufEq; ffa \<in> BufEq\<rbrakk>
  16.172 +       \<Longrightarrow> (xa, ff\<cdot>xa) \<in> down_iterate BufAC_Cmt_F i
  16.173 +*)
  16.174 +apply (drule spec, drule spec, drule (1) mp)
  16.175 +apply (drule (1) mp)
  16.176 +apply (drule (1) mp)
  16.177 +apply (erule impE)
  16.178 +apply ( subst BufAC_Asm_cong, assumption)
  16.179 +prefer 3 apply assumption
  16.180 +apply assumption
  16.181 +apply ( erule (1) BufAC_Asm_antiton [THEN antitonPD])
  16.182 +apply (subst BufAC_Asm_cong, assumption)
  16.183 +prefer 3 apply assumption
  16.184 +apply assumption
  16.185 +apply assumption
  16.186 +done
  16.187 +
  16.188 +lemma BufAC_Cmt_iterate_all: "(x\<in>BufAC_Cmt) = (\<forall>n. x\<in>down_iterate BufAC_Cmt_F n)"
  16.189 +apply (unfold BufAC_Cmt_def)
  16.190 +apply (subst cont_BufAC_Cmt_F [THEN INTER_down_iterate_is_gfp])
  16.191 +apply (fast)
  16.192 +done
  16.193 +
  16.194 +(*adm_BufAC_Asm,BufAC_Asm_antiton,adm_non_BufAC_Asm,BufAC_Asm_cong,
  16.195 +  BufAC_Cmt_2stream_monoP*)
  16.196 +lemma adm_BufAC: "f:BufEq ==> adm (%s. s:BufAC_Asm --> (s, f\<cdot>s):BufAC_Cmt)"
  16.197 +apply (rule flatstream_admI)
  16.198 +apply (subst BufAC_Cmt_iterate_all)
  16.199 +apply (drule BufAC_Cmt_2stream_monoP)
  16.200 +apply safe
  16.201 +apply (drule spec, erule exE)
  16.202 +apply (drule spec, erule impE)
  16.203 +apply  (erule BufAC_Asm_antiton [THEN antitonPD])
  16.204 +apply  (erule is_ub_thelub)
  16.205 +apply (tactic "smp_tac 3 1")
  16.206 +apply (drule is_ub_thelub)
  16.207 +apply (drule (1) mp)
  16.208 +apply (drule (1) mp)
  16.209 +apply (erule mp)
  16.210 +apply (drule BufAC_Cmt_iterate_all [THEN iffD1])
  16.211 +apply (erule spec)
  16.212 +done
  16.213 +
  16.214 +
  16.215 +
  16.216 +(**** Buf_Eq_imp_AC by induction **********************************************)
  16.217 +
  16.218 +(*adm_BufAC_Asm,BufAC_Asm_antiton,adm_non_BufAC_Asm,BufAC_Asm_cong,
  16.219 +  BufAC_Cmt_2stream_monoP,adm_BufAC,BufAC_Cmt_d_req*)
  16.220 +lemma Buf_Eq_imp_AC: "BufEq <= BufAC"
  16.221 +apply (unfold BufAC_def)
  16.222 +apply (rule subsetI)
  16.223 +apply (simp)
  16.224 +apply (rule allI)
  16.225 +apply (rule fstream_ind2)
  16.226 +back
  16.227 +apply (   erule adm_BufAC)
  16.228 +apply (  safe)
  16.229 +apply (   erule BufAC_Cmt_empty)
  16.230 +apply (  erule BufAC_Cmt_d)
  16.231 +apply ( drule BufAC_Asm_prefix2)
  16.232 +apply ( simp)
  16.233 +apply (fast intro: BufAC_Cmt_d_req BufAC_Asm_prefix2)
  16.234 +done
  16.235 +
  16.236 +(**** new approach for admissibility, reduces itself to absurdity *************)
  16.237 +
  16.238 +lemma adm_BufAC_Asm': "adm (\<lambda>x. x\<in>BufAC_Asm)"
  16.239 +apply (rule def_gfp_admI)
  16.240 +apply (rule BufAC_Asm_def [THEN eq_reflection])
  16.241 +apply (safe)
  16.242 +apply (unfold BufAC_Asm_F_def)
  16.243 +apply (safe)
  16.244 +apply (erule contrapos_np)
  16.245 +apply (drule fstream_exhaust_eq [THEN iffD1])
  16.246 +apply (clarsimp)
  16.247 +apply (drule (1) fstream_lub_lemma)
  16.248 +apply (clarify)
  16.249 +apply (erule_tac x="j" in all_dupE)
  16.250 +apply (simp)
  16.251 +apply (drule BufAC_Asm_d2)
  16.252 +apply (clarify)
  16.253 +apply (simp)
  16.254 +apply (rule disjCI)
  16.255 +apply (erule contrapos_np)
  16.256 +apply (drule fstream_exhaust_eq [THEN iffD1])
  16.257 +apply (clarsimp)
  16.258 +apply (drule (1) fstream_lub_lemma)
  16.259 +apply (clarsimp)
  16.260 +apply (tactic "simp_tac (HOL_basic_ss addsimps (ex_simps@all_simps RL[sym])) 1")
  16.261 +apply (rule_tac x="Xa" in exI)
  16.262 +apply (rule allI)
  16.263 +apply (rotate_tac -1)
  16.264 +apply (erule_tac x="i" in allE)
  16.265 +apply (clarsimp)
  16.266 +apply (erule_tac x="jb" in allE)
  16.267 +apply (clarsimp)
  16.268 +apply (erule_tac x="jc" in allE)
  16.269 +apply (clarsimp dest!: BufAC_Asm_d3)
  16.270 +done
  16.271 +
  16.272 +lemma adm_non_BufAC_Asm': "adm (\<lambda>u. u \<notin> BufAC_Asm)" (* uses antitonP *)
  16.273 +apply (rule def_gfp_adm_nonP)
  16.274 +apply (rule BufAC_Asm_def [THEN eq_reflection])
  16.275 +apply (unfold BufAC_Asm_F_def)
  16.276 +apply (safe)
  16.277 +apply (erule contrapos_np)
  16.278 +apply (drule fstream_exhaust_eq [THEN iffD1])
  16.279 +apply (clarsimp)
  16.280 +apply (frule fstream_prefix)
  16.281 +apply (clarsimp)
  16.282 +apply (frule BufAC_Asm_d2)
  16.283 +apply (clarsimp)
  16.284 +apply (rotate_tac -1)
  16.285 +apply (erule contrapos_pp)
  16.286 +apply (drule fstream_exhaust_eq [THEN iffD1])
  16.287 +apply (clarsimp)
  16.288 +apply (frule fstream_prefix)
  16.289 +apply (clarsimp)
  16.290 +apply (frule BufAC_Asm_d3)
  16.291 +apply (force)
  16.292 +done
  16.293 +
  16.294 +lemma adm_BufAC': "f \<in> BufEq \<Longrightarrow> adm (\<lambda>u. u \<in> BufAC_Asm \<longrightarrow> (u, f\<cdot>u) \<in> BufAC_Cmt)"
  16.295 +apply (rule triv_admI)
  16.296 +apply (clarify)
  16.297 +apply (erule (1) Buf_Eq_imp_AC_lemma)
  16.298 +      (* this is what we originally aimed to show, using admissibilty :-( *)
  16.299 +done
  16.300 +
  16.301 +end
  16.302 +
  16.303 +
    17.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    17.2 +++ b/src/HOL/HOLCF/FOCUS/FOCUS.thy	Sat Nov 27 16:08:10 2010 -0800
    17.3 @@ -0,0 +1,29 @@
    17.4 +(*  Title:      HOLCF/FOCUS/FOCUS.thy
    17.5 +    Author:     David von Oheimb, TU Muenchen
    17.6 +*)
    17.7 +
    17.8 +header {* Top level of FOCUS *}
    17.9 +
   17.10 +theory FOCUS
   17.11 +imports Fstream
   17.12 +begin
   17.13 +
   17.14 +lemma ex_eqI [intro!]: "? xx. x = xx"
   17.15 +by auto
   17.16 +
   17.17 +lemma ex2_eqI [intro!]: "? xx yy. x = xx & y = yy"
   17.18 +by auto
   17.19 +
   17.20 +lemma eq_UU_symf: "(UU = f x) = (f x = UU)"
   17.21 +by auto
   17.22 +
   17.23 +lemma fstream_exhaust_slen_eq: "(#x ~= 0) = (? a y. x = a~> y)"
   17.24 +by (simp add: slen_empty_eq fstream_exhaust_eq)
   17.25 +
   17.26 +lemmas [simp] =
   17.27 +  slen_less_1_eq fstream_exhaust_slen_eq
   17.28 +  slen_fscons_eq slen_fscons_less_eq Suc_ile_eq
   17.29 +
   17.30 +declare strictI [elim]
   17.31 +
   17.32 +end
    18.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    18.2 +++ b/src/HOL/HOLCF/FOCUS/Fstream.thy	Sat Nov 27 16:08:10 2010 -0800
    18.3 @@ -0,0 +1,263 @@
    18.4 +(*  Title:      HOLCF/FOCUS/Fstream.thy
    18.5 +    Author:     David von Oheimb, TU Muenchen
    18.6 +
    18.7 +FOCUS streams (with lifted elements).
    18.8 +
    18.9 +TODO: integrate Fstreams.thy
   18.10 +*)
   18.11 +
   18.12 +header {* FOCUS flat streams *}
   18.13 +
   18.14 +theory Fstream
   18.15 +imports Stream
   18.16 +begin
   18.17 +
   18.18 +default_sort type
   18.19 +
   18.20 +types 'a fstream = "'a lift stream"
   18.21 +
   18.22 +definition
   18.23 +  fscons        :: "'a     \<Rightarrow> 'a fstream \<rightarrow> 'a fstream" where
   18.24 +  "fscons a = (\<Lambda> s. Def a && s)"
   18.25 +
   18.26 +definition
   18.27 +  fsfilter      :: "'a set \<Rightarrow> 'a fstream \<rightarrow> 'a fstream" where
   18.28 +  "fsfilter A = (sfilter\<cdot>(flift2 (\<lambda>x. x\<in>A)))"
   18.29 +
   18.30 +abbreviation
   18.31 +  emptystream   :: "'a fstream"                          ("<>") where
   18.32 +  "<> == \<bottom>"
   18.33 +
   18.34 +abbreviation
   18.35 +  fscons'       :: "'a \<Rightarrow> 'a fstream \<Rightarrow> 'a fstream"       ("(_~>_)"    [66,65] 65) where
   18.36 +  "a~>s == fscons a\<cdot>s"
   18.37 +
   18.38 +abbreviation
   18.39 +  fsfilter'     :: "'a set \<Rightarrow> 'a fstream \<Rightarrow> 'a fstream"   ("(_'(C')_)" [64,63] 63) where
   18.40 +  "A(C)s == fsfilter A\<cdot>s"
   18.41 +
   18.42 +notation (xsymbols)
   18.43 +  fscons'  ("(_\<leadsto>_)"                                                 [66,65] 65) and
   18.44 +  fsfilter'  ("(_\<copyright>_)"                                               [64,63] 63)
   18.45 +
   18.46 +
   18.47 +lemma Def_maximal: "a = Def d \<Longrightarrow> a\<sqsubseteq>b \<Longrightarrow> b = Def d"
   18.48 +by simp
   18.49 +
   18.50 +
   18.51 +section "fscons"
   18.52 +
   18.53 +lemma fscons_def2: "a~>s = Def a && s"
   18.54 +apply (unfold fscons_def)
   18.55 +apply (simp)
   18.56 +done
   18.57 +
   18.58 +lemma fstream_exhaust: "x = UU |  (? a y. x = a~> y)"
   18.59 +apply (simp add: fscons_def2)
   18.60 +apply (cut_tac stream.nchotomy)
   18.61 +apply (fast dest: not_Undef_is_Def [THEN iffD1])
   18.62 +done
   18.63 +
   18.64 +lemma fstream_cases: "[| x = UU ==> P; !!a y. x = a~> y ==> P |] ==> P"
   18.65 +apply (cut_tac fstream_exhaust)
   18.66 +apply (erule disjE)
   18.67 +apply fast
   18.68 +apply fast
   18.69 +done
   18.70 +
   18.71 +lemma fstream_exhaust_eq: "(x ~= UU) = (? a y. x = a~> y)"
   18.72 +apply (simp add: fscons_def2 stream_exhaust_eq)
   18.73 +apply (fast dest: not_Undef_is_Def [THEN iffD1] elim: DefE)
   18.74 +done
   18.75 +
   18.76 +
   18.77 +lemma fscons_not_empty [simp]: "a~> s ~= <>"
   18.78 +by (simp add: fscons_def2)
   18.79 +
   18.80 +
   18.81 +lemma fscons_inject [simp]: "(a~> s = b~> t) = (a = b &  s = t)"
   18.82 +by (simp add: fscons_def2)
   18.83 +
   18.84 +lemma fstream_prefix: "a~> s << t ==> ? tt. t = a~> tt &  s << tt"
   18.85 +apply (cases t)
   18.86 +apply (cut_tac fscons_not_empty)
   18.87 +apply (fast dest: eq_UU_iff [THEN iffD2])
   18.88 +apply (simp add: fscons_def2)
   18.89 +done
   18.90 +
   18.91 +lemma fstream_prefix' [simp]:
   18.92 +        "x << a~> z = (x = <> |  (? y. x = a~> y &  y << z))"
   18.93 +apply (simp add: fscons_def2 Def_not_UU [THEN stream_prefix'])
   18.94 +apply (safe)
   18.95 +apply (erule_tac [!] contrapos_np)
   18.96 +prefer 2 apply (fast elim: DefE)
   18.97 +apply (rule lift.exhaust)
   18.98 +apply (erule (1) notE)
   18.99 +apply (safe)
  18.100 +apply (drule Def_below_Def [THEN iffD1])
  18.101 +apply fast
  18.102 +done
  18.103 +
  18.104 +(* ------------------------------------------------------------------------- *)
  18.105 +
  18.106 +section "ft & rt"
  18.107 +
  18.108 +lemmas ft_empty = stream.sel_rews (1)
  18.109 +lemma ft_fscons [simp]: "ft\<cdot>(m~> s) = Def m"
  18.110 +by (simp add: fscons_def)
  18.111 +
  18.112 +lemmas rt_empty = stream.sel_rews (2)
  18.113 +lemma rt_fscons [simp]: "rt\<cdot>(m~> s) = s"
  18.114 +by (simp add: fscons_def)
  18.115 +
  18.116 +lemma ft_eq [simp]: "(ft\<cdot>s = Def a) = (? t. s = a~> t)"
  18.117 +apply (unfold fscons_def)
  18.118 +apply (simp)
  18.119 +apply (safe)
  18.120 +apply (erule subst)
  18.121 +apply (rule exI)
  18.122 +apply (rule surjectiv_scons [symmetric])
  18.123 +apply (simp)
  18.124 +done
  18.125 +
  18.126 +lemma surjective_fscons_lemma: "(d\<leadsto>y = x) = (ft\<cdot>x = Def d & rt\<cdot>x = y)"
  18.127 +by auto
  18.128 +
  18.129 +lemma surjective_fscons: "ft\<cdot>x = Def d \<Longrightarrow> d\<leadsto>rt\<cdot>x = x"
  18.130 +by (simp add: surjective_fscons_lemma)
  18.131 +
  18.132 +
  18.133 +(* ------------------------------------------------------------------------- *)
  18.134 +
  18.135 +section "take"
  18.136 +
  18.137 +lemma fstream_take_Suc [simp]:
  18.138 +        "stream_take (Suc n)\<cdot>(a~> s) = a~> stream_take n\<cdot>s"
  18.139 +by (simp add: fscons_def)
  18.140 +
  18.141 +
  18.142 +(* ------------------------------------------------------------------------- *)
  18.143 +
  18.144 +section "slen"
  18.145 +
  18.146 +lemma slen_fscons: "#(m~> s) = iSuc (#s)"
  18.147 +by (simp add: fscons_def)
  18.148 +
  18.149 +lemma slen_fscons_eq:
  18.150 +        "(Fin (Suc n) < #x) = (? a y. x = a~> y & Fin n < #y)"
  18.151 +apply (simp add: fscons_def2 slen_scons_eq)
  18.152 +apply (fast dest: not_Undef_is_Def [THEN iffD1] elim: DefE)
  18.153 +done
  18.154 +
  18.155 +lemma slen_fscons_eq_rev:
  18.156 +        "(#x < Fin (Suc (Suc n))) = (!a y. x ~= a~> y | #y < Fin (Suc n))"
  18.157 +apply (simp add: fscons_def2 slen_scons_eq_rev)
  18.158 +apply (tactic {* step_tac (HOL_cs addSEs @{thms DefE}) 1 *})
  18.159 +apply (tactic {* step_tac (HOL_cs addSEs @{thms DefE}) 1 *})
  18.160 +apply (tactic {* step_tac (HOL_cs addSEs @{thms DefE}) 1 *})
  18.161 +apply (tactic {* step_tac (HOL_cs addSEs @{thms DefE}) 1 *})
  18.162 +apply (tactic {* step_tac (HOL_cs addSEs @{thms DefE}) 1 *})
  18.163 +apply (tactic {* step_tac (HOL_cs addSEs @{thms DefE}) 1 *})
  18.164 +apply (erule contrapos_np)
  18.165 +apply (fast dest: not_Undef_is_Def [THEN iffD1] elim: DefE)
  18.166 +done
  18.167 +
  18.168 +lemma slen_fscons_less_eq:
  18.169 +        "(#(a~> y) < Fin (Suc (Suc n))) = (#y < Fin (Suc n))"
  18.170 +apply (subst slen_fscons_eq_rev)
  18.171 +apply (fast dest!: fscons_inject [THEN iffD1])
  18.172 +done
  18.173 +
  18.174 +
  18.175 +(* ------------------------------------------------------------------------- *)
  18.176 +
  18.177 +section "induction"
  18.178 +
  18.179 +lemma fstream_ind:
  18.180 +        "[| adm P; P <>; !!a s. P s ==> P (a~> s) |] ==> P x"
  18.181 +apply (erule stream.induct)
  18.182 +apply (assumption)
  18.183 +apply (unfold fscons_def2)
  18.184 +apply (fast dest: not_Undef_is_Def [THEN iffD1])
  18.185 +done
  18.186 +
  18.187 +lemma fstream_ind2:
  18.188 +  "[| adm P; P UU; !!a. P (a~> UU); !!a b s. P s ==> P (a~> b~> s) |] ==> P x"
  18.189 +apply (erule stream_ind2)
  18.190 +apply (assumption)
  18.191 +apply (unfold fscons_def2)
  18.192 +apply (fast dest: not_Undef_is_Def [THEN iffD1])
  18.193 +apply (fast dest: not_Undef_is_Def [THEN iffD1])
  18.194 +done
  18.195 +
  18.196 +
  18.197 +(* ------------------------------------------------------------------------- *)
  18.198 +
  18.199 +section "fsfilter"
  18.200 +
  18.201 +lemma fsfilter_empty: "A(C)UU = UU"
  18.202 +apply (unfold fsfilter_def)
  18.203 +apply (rule sfilter_empty)
  18.204 +done
  18.205 +
  18.206 +lemma fsfilter_fscons:
  18.207 +        "A(C)x~> xs = (if x:A then x~> (A(C)xs) else A(C)xs)"
  18.208 +apply (unfold fsfilter_def)
  18.209 +apply (simp add: fscons_def2 If_and_if)
  18.210 +done
  18.211 +
  18.212 +lemma fsfilter_emptys: "{}(C)x = UU"
  18.213 +apply (rule_tac x="x" in fstream_ind)
  18.214 +apply (simp)
  18.215 +apply (rule fsfilter_empty)
  18.216 +apply (simp add: fsfilter_fscons)
  18.217 +done
  18.218 +
  18.219 +lemma fsfilter_insert: "(insert a A)(C)a~> x = a~> ((insert a A)(C)x)"
  18.220 +by (simp add: fsfilter_fscons)
  18.221 +
  18.222 +lemma fsfilter_single_in: "{a}(C)a~> x = a~> ({a}(C)x)"
  18.223 +by (rule fsfilter_insert)
  18.224 +
  18.225 +lemma fsfilter_single_out: "b ~= a ==> {a}(C)b~> x = ({a}(C)x)"
  18.226 +by (simp add: fsfilter_fscons)
  18.227 +
  18.228 +lemma fstream_lub_lemma1:
  18.229 +    "\<lbrakk>chain Y; (\<Squnion>i. Y i) = a\<leadsto>s\<rbrakk> \<Longrightarrow> \<exists>j t. Y j = a\<leadsto>t"
  18.230 +apply (case_tac "max_in_chain i Y")
  18.231 +apply  (drule (1) lub_finch1 [THEN lub_eqI, THEN sym])
  18.232 +apply  (force)
  18.233 +apply (unfold max_in_chain_def)
  18.234 +apply auto
  18.235 +apply (frule (1) chain_mono)
  18.236 +apply (rule_tac x="Y j" in fstream_cases)
  18.237 +apply  (force)
  18.238 +apply (drule_tac x="j" in is_ub_thelub)
  18.239 +apply (force)
  18.240 +done
  18.241 +
  18.242 +lemma fstream_lub_lemma:
  18.243 +      "\<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)"
  18.244 +apply (frule (1) fstream_lub_lemma1)
  18.245 +apply (clarsimp)
  18.246 +apply (rule_tac x="%i. rt\<cdot>(Y(i+j))" in exI)
  18.247 +apply (rule conjI)
  18.248 +apply  (erule chain_shift [THEN chain_monofun])
  18.249 +apply safe
  18.250 +apply  (drule_tac i="j" and j="i+j" in chain_mono)
  18.251 +apply   (simp)
  18.252 +apply  (simp)
  18.253 +apply  (rule_tac x="i+j" in exI)
  18.254 +apply  (drule fstream_prefix)
  18.255 +apply  (clarsimp)
  18.256 +apply  (subst contlub_cfun [symmetric])
  18.257 +apply   (rule chainI)
  18.258 +apply   (fast)
  18.259 +apply  (erule chain_shift)
  18.260 +apply (subst lub_const)
  18.261 +apply (subst lub_range_shift)
  18.262 +apply  (assumption)
  18.263 +apply (simp)
  18.264 +done
  18.265 +
  18.266 +end
    19.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    19.2 +++ b/src/HOL/HOLCF/FOCUS/Fstreams.thy	Sat Nov 27 16:08:10 2010 -0800
    19.3 @@ -0,0 +1,331 @@
    19.4 +(*  Title:      HOLCF/FOCUS/Fstreams.thy
    19.5 +    Author:     Borislav Gajanovic
    19.6 +
    19.7 +FOCUS flat streams (with lifted elements).
    19.8 +
    19.9 +TODO: integrate this with Fstream.
   19.10 +*)
   19.11 +
   19.12 +theory Fstreams
   19.13 +imports Stream
   19.14 +begin
   19.15 +
   19.16 +default_sort type
   19.17 +
   19.18 +types 'a fstream = "('a lift) stream"
   19.19 +
   19.20 +definition
   19.21 +  fsingleton    :: "'a => 'a fstream"  ("<_>" [1000] 999) where
   19.22 +  fsingleton_def2: "fsingleton = (%a. Def a && UU)"
   19.23 +
   19.24 +definition
   19.25 +  fsfilter      :: "'a set \<Rightarrow> 'a fstream \<rightarrow> 'a fstream" where
   19.26 +  "fsfilter A = sfilter\<cdot>(flift2 (\<lambda>x. x\<in>A))"
   19.27 +
   19.28 +definition
   19.29 +  fsmap         :: "('a => 'b) => 'a fstream -> 'b fstream" where
   19.30 +  "fsmap f = smap$(flift2 f)"
   19.31 +
   19.32 +definition
   19.33 +  jth           :: "nat => 'a fstream => 'a" where
   19.34 +  "jth = (%n s. if Fin n < #s then THE a. i_th n s = Def a else undefined)"
   19.35 +
   19.36 +definition
   19.37 +  first         :: "'a fstream => 'a" where
   19.38 +  "first = (%s. jth 0 s)"
   19.39 +
   19.40 +definition
   19.41 +  last          :: "'a fstream => 'a" where
   19.42 +  "last = (%s. case #s of Fin n => (if n~=0 then jth (THE k. Suc k = n) s else undefined))"
   19.43 +
   19.44 +
   19.45 +abbreviation
   19.46 +  emptystream :: "'a fstream"  ("<>") where
   19.47 +  "<> == \<bottom>"
   19.48 +
   19.49 +abbreviation
   19.50 +  fsfilter' :: "'a set \<Rightarrow> 'a fstream \<Rightarrow> 'a fstream"       ("(_'(C')_)" [64,63] 63) where
   19.51 +  "A(C)s == fsfilter A\<cdot>s"
   19.52 +
   19.53 +notation (xsymbols)
   19.54 +  fsfilter'  ("(_\<copyright>_)" [64,63] 63)
   19.55 +
   19.56 +
   19.57 +lemma ft_fsingleton[simp]: "ft$(<a>) = Def a"
   19.58 +by (simp add: fsingleton_def2)
   19.59 +
   19.60 +lemma slen_fsingleton[simp]: "#(<a>) = Fin 1"
   19.61 +by (simp add: fsingleton_def2 inat_defs)
   19.62 +
   19.63 +lemma slen_fstreams[simp]: "#(<a> ooo s) = iSuc (#s)"
   19.64 +by (simp add: fsingleton_def2)
   19.65 +
   19.66 +lemma slen_fstreams2[simp]: "#(s ooo <a>) = iSuc (#s)"
   19.67 +apply (cases "#s")
   19.68 +apply (auto simp add: iSuc_Fin)
   19.69 +apply (insert slen_sconc [of _ s "Suc 0" "<a>"], auto)
   19.70 +by (simp add: sconc_def)
   19.71 +
   19.72 +lemma j_th_0_fsingleton[simp]:"jth 0 (<a>) = a"
   19.73 +apply (simp add: fsingleton_def2 jth_def)
   19.74 +by (simp add: i_th_def Fin_0)
   19.75 +
   19.76 +lemma jth_0[simp]: "jth 0 (<a> ooo s) = a"  
   19.77 +apply (simp add: fsingleton_def2 jth_def)
   19.78 +by (simp add: i_th_def Fin_0)
   19.79 +
   19.80 +lemma first_sconc[simp]: "first (<a> ooo s) = a"
   19.81 +by (simp add: first_def)
   19.82 +
   19.83 +lemma first_fsingleton[simp]: "first (<a>) = a"
   19.84 +by (simp add: first_def)
   19.85 +
   19.86 +lemma jth_n[simp]: "Fin n = #s ==> jth n (s ooo <a>) = a"
   19.87 +apply (simp add: jth_def, auto)
   19.88 +apply (simp add: i_th_def rt_sconc1)
   19.89 +by (simp add: inat_defs split: inat_splits)
   19.90 +
   19.91 +lemma last_sconc[simp]: "Fin n = #s ==> last (s ooo <a>) = a"
   19.92 +apply (simp add: last_def)
   19.93 +apply (simp add: inat_defs split:inat_splits)
   19.94 +by (drule sym, auto)
   19.95 +
   19.96 +lemma last_fsingleton[simp]: "last (<a>) = a"
   19.97 +by (simp add: last_def)
   19.98 +
   19.99 +lemma first_UU[simp]: "first UU = undefined"
  19.100 +by (simp add: first_def jth_def)
  19.101 +
  19.102 +lemma last_UU[simp]:"last UU = undefined"
  19.103 +by (simp add: last_def jth_def inat_defs)
  19.104 +
  19.105 +lemma last_infinite[simp]:"#s = Infty ==> last s = undefined"
  19.106 +by (simp add: last_def)
  19.107 +
  19.108 +lemma jth_slen_lemma1:"n <= k & Fin n = #s ==> jth k s = undefined"
  19.109 +by (simp add: jth_def inat_defs split:inat_splits, auto)
  19.110 +
  19.111 +lemma jth_UU[simp]:"jth n UU = undefined" 
  19.112 +by (simp add: jth_def)
  19.113 +
  19.114 +lemma ext_last:"[|s ~= UU; Fin (Suc n) = #s|] ==> (stream_take n$s) ooo <(last s)> = s" 
  19.115 +apply (simp add: last_def)
  19.116 +apply (case_tac "#s", auto)
  19.117 +apply (simp add: fsingleton_def2)
  19.118 +apply (subgoal_tac "Def (jth n s) = i_th n s")
  19.119 +apply (auto simp add: i_th_last)
  19.120 +apply (drule slen_take_lemma1, auto)
  19.121 +apply (simp add: jth_def)
  19.122 +apply (case_tac "i_th n s = UU")
  19.123 +apply auto
  19.124 +apply (simp add: i_th_def)
  19.125 +apply (case_tac "i_rt n s = UU", auto)
  19.126 +apply (drule i_rt_slen [THEN iffD1])
  19.127 +apply (drule slen_take_eq_rev [rule_format, THEN iffD2],auto)
  19.128 +by (drule not_Undef_is_Def [THEN iffD1], auto)
  19.129 +
  19.130 +
  19.131 +lemma fsingleton_lemma1[simp]: "(<a> = <b>) = (a=b)"
  19.132 +by (simp add: fsingleton_def2)
  19.133 +
  19.134 +lemma fsingleton_lemma2[simp]: "<a> ~= <>"
  19.135 +by (simp add: fsingleton_def2)
  19.136 +
  19.137 +lemma fsingleton_sconc:"<a> ooo s = Def a && s"
  19.138 +by (simp add: fsingleton_def2)
  19.139 +
  19.140 +lemma fstreams_ind: 
  19.141 +  "[| adm P; P <>; !!a s. P s ==> P (<a> ooo s) |] ==> P x"
  19.142 +apply (simp add: fsingleton_def2)
  19.143 +apply (rule stream.induct, auto)
  19.144 +by (drule not_Undef_is_Def [THEN iffD1], auto)
  19.145 +
  19.146 +lemma fstreams_ind2:
  19.147 +  "[| adm P; P <>; !!a. P (<a>); !!a b s. P s ==> P (<a> ooo <b> ooo s) |] ==> P x"
  19.148 +apply (simp add: fsingleton_def2)
  19.149 +apply (rule stream_ind2, auto)
  19.150 +by (drule not_Undef_is_Def [THEN iffD1], auto)+
  19.151 +
  19.152 +lemma fstreams_take_Suc[simp]: "stream_take (Suc n)$(<a> ooo s) = <a> ooo stream_take n$s"
  19.153 +by (simp add: fsingleton_def2)
  19.154 +
  19.155 +lemma fstreams_not_empty[simp]: "<a> ooo s ~= <>"
  19.156 +by (simp add: fsingleton_def2)
  19.157 +
  19.158 +lemma fstreams_not_empty2[simp]: "s ooo <a> ~= <>"
  19.159 +by (case_tac "s=UU", auto)
  19.160 +
  19.161 +lemma fstreams_exhaust: "x = UU | (EX a s. x = <a> ooo s)"
  19.162 +apply (simp add: fsingleton_def2, auto)
  19.163 +apply (erule contrapos_pp, auto)
  19.164 +apply (drule stream_exhaust_eq [THEN iffD1], auto)
  19.165 +by (drule not_Undef_is_Def [THEN iffD1], auto)
  19.166 +
  19.167 +lemma fstreams_cases: "[| x = UU ==> P; !!a y. x = <a> ooo y ==> P |] ==> P"
  19.168 +by (insert fstreams_exhaust [of x], auto)
  19.169 +
  19.170 +lemma fstreams_exhaust_eq: "(x ~= UU) = (? a y. x = <a> ooo y)"
  19.171 +apply (simp add: fsingleton_def2, auto)
  19.172 +apply (drule stream_exhaust_eq [THEN iffD1], auto)
  19.173 +by (drule not_Undef_is_Def [THEN iffD1], auto)
  19.174 +
  19.175 +lemma fstreams_inject: "(<a> ooo s = <b> ooo t) = (a=b & s=t)"
  19.176 +by (simp add: fsingleton_def2)
  19.177 +
  19.178 +lemma fstreams_prefix: "<a> ooo s << t ==> EX tt. t = <a> ooo tt &  s << tt"
  19.179 +apply (simp add: fsingleton_def2)
  19.180 +apply (insert stream_prefix [of "Def a" s t], auto)
  19.181 +done
  19.182 +
  19.183 +lemma fstreams_prefix': "x << <a> ooo z = (x = <> |  (EX y. x = <a> ooo y &  y << z))"
  19.184 +apply (auto, case_tac "x=UU", auto)
  19.185 +apply (drule stream_exhaust_eq [THEN iffD1], auto)
  19.186 +apply (simp add: fsingleton_def2, auto)
  19.187 +apply (drule ax_flat, simp)
  19.188 +by (erule sconc_mono)
  19.189 +
  19.190 +lemma ft_fstreams[simp]: "ft$(<a> ooo s) = Def a"
  19.191 +by (simp add: fsingleton_def2)
  19.192 +
  19.193 +lemma rt_fstreams[simp]: "rt$(<a> ooo s) = s"
  19.194 +by (simp add: fsingleton_def2)
  19.195 +
  19.196 +lemma ft_eq[simp]: "(ft$s = Def a) = (EX t. s = <a> ooo t)"
  19.197 +apply (cases s, auto)
  19.198 +by ((*drule sym,*) auto simp add: fsingleton_def2)
  19.199 +
  19.200 +lemma surjective_fstreams: "(<d> ooo y = x) = (ft$x = Def d & rt$x = y)"
  19.201 +by auto
  19.202 +
  19.203 +lemma fstreams_mono: "<a> ooo b << <a> ooo c ==> b << c"
  19.204 +by (simp add: fsingleton_def2)
  19.205 +
  19.206 +lemma fsmap_UU[simp]: "fsmap f$UU = UU"
  19.207 +by (simp add: fsmap_def)
  19.208 +
  19.209 +lemma fsmap_fsingleton_sconc: "fsmap f$(<x> ooo xs) = <(f x)> ooo (fsmap f$xs)"
  19.210 +by (simp add: fsmap_def fsingleton_def2 flift2_def)
  19.211 +
  19.212 +lemma fsmap_fsingleton[simp]: "fsmap f$(<x>) = <(f x)>"
  19.213 +by (simp add: fsmap_def fsingleton_def2 flift2_def)
  19.214 +
  19.215 +
  19.216 +lemma fstreams_chain_lemma[rule_format]:
  19.217 +  "ALL s x y. stream_take n$(s::'a fstream) << x & x << y & y << s & x ~= y --> stream_take (Suc n)$s << y"
  19.218 +apply (induct_tac n, auto)
  19.219 +apply (case_tac "s=UU", auto)
  19.220 +apply (drule stream_exhaust_eq [THEN iffD1], auto)
  19.221 +apply (case_tac "y=UU", auto)
  19.222 +apply (drule stream_exhaust_eq [THEN iffD1], auto)
  19.223 +apply (simp add: flat_below_iff)
  19.224 +apply (case_tac "s=UU", auto)
  19.225 +apply (drule stream_exhaust_eq [THEN iffD1], auto)
  19.226 +apply (erule_tac x="ya" in allE)
  19.227 +apply (drule stream_prefix, auto)
  19.228 +apply (case_tac "y=UU",auto)
  19.229 +apply (drule stream_exhaust_eq [THEN iffD1], clarsimp)
  19.230 +apply auto
  19.231 +apply (simp add: flat_below_iff)
  19.232 +apply (erule_tac x="tt" in allE)
  19.233 +apply (erule_tac x="yb" in allE, auto)
  19.234 +apply (simp add: flat_below_iff)
  19.235 +by (simp add: flat_below_iff)
  19.236 +
  19.237 +lemma fstreams_lub_lemma1: "[| chain Y; (LUB i. Y i) = <a> ooo s |] ==> EX j t. Y j = <a> ooo t"
  19.238 +apply (subgoal_tac "(LUB i. Y i) ~= UU")
  19.239 +apply (drule chain_UU_I_inverse2, auto)
  19.240 +apply (drule_tac x="i" in is_ub_thelub, auto)
  19.241 +by (drule fstreams_prefix' [THEN iffD1], auto)
  19.242 +
  19.243 +lemma fstreams_lub1: 
  19.244 + "[| chain Y; (LUB i. Y i) = <a> ooo s |]
  19.245 +     ==> (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)"
  19.246 +apply (auto simp add: fstreams_lub_lemma1)
  19.247 +apply (rule_tac x="%n. stream_take n$s" in exI, auto)
  19.248 +apply (induct_tac i, auto)
  19.249 +apply (drule fstreams_lub_lemma1, auto)
  19.250 +apply (rule_tac x="j" in exI, auto)
  19.251 +apply (case_tac "max_in_chain j Y")
  19.252 +apply (frule lub_finch1 [THEN lub_eqI], auto)
  19.253 +apply (rule_tac x="j" in exI)
  19.254 +apply (erule subst) back back
  19.255 +apply (simp add: below_prod_def sconc_mono)
  19.256 +apply (simp add: max_in_chain_def, auto)
  19.257 +apply (rule_tac x="ja" in exI)
  19.258 +apply (subgoal_tac "Y j << Y ja")
  19.259 +apply (drule fstreams_prefix, auto)+
  19.260 +apply (rule sconc_mono)
  19.261 +apply (rule fstreams_chain_lemma, auto)
  19.262 +apply (subgoal_tac "Y ja << (LUB i. (Y i))", clarsimp)
  19.263 +apply (drule fstreams_mono, simp)
  19.264 +apply (rule is_ub_thelub, simp)
  19.265 +apply (blast intro: chain_mono)
  19.266 +by (rule stream_reach2)
  19.267 +
  19.268 +
  19.269 +lemma lub_Pair_not_UU_lemma: 
  19.270 +  "[| chain Y; (LUB i. Y i) = ((a::'a::flat), b); a ~= UU; b ~= UU |] 
  19.271 +      ==> EX j c d. Y j = (c, d) & c ~= UU & d ~= UU"
  19.272 +apply (frule lub_prod, clarsimp)
  19.273 +apply (drule chain_UU_I_inverse2, clarsimp)
  19.274 +apply (case_tac "Y i", clarsimp)
  19.275 +apply (case_tac "max_in_chain i Y")
  19.276 +apply (drule maxinch_is_thelub, auto)
  19.277 +apply (rule_tac x="i" in exI, auto)
  19.278 +apply (simp add: max_in_chain_def, auto)
  19.279 +apply (subgoal_tac "Y i << Y j",auto)
  19.280 +apply (simp add: below_prod_def, clarsimp)
  19.281 +apply (drule ax_flat, auto)
  19.282 +apply (case_tac "snd (Y j) = UU",auto)
  19.283 +apply (case_tac "Y j", auto)
  19.284 +apply (rule_tac x="j" in exI)
  19.285 +apply (case_tac "Y j",auto)
  19.286 +by (drule chain_mono, auto)
  19.287 +
  19.288 +lemma fstreams_lub_lemma2: 
  19.289 +  "[| chain Y; (LUB i. Y i) = (a, <m> ooo ms); (a::'a::flat) ~= UU |] ==> EX j t. Y j = (a, <m> ooo t)"
  19.290 +apply (frule lub_Pair_not_UU_lemma, auto)
  19.291 +apply (drule_tac x="j" in is_ub_thelub, auto)
  19.292 +apply (drule ax_flat, clarsimp)
  19.293 +by (drule fstreams_prefix' [THEN iffD1], auto)
  19.294 +
  19.295 +lemma fstreams_lub2:
  19.296 +  "[| chain Y; (LUB i. Y i) = (a, <m> ooo ms); (a::'a::flat) ~= UU |] 
  19.297 +      ==> (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)"
  19.298 +apply (auto simp add: fstreams_lub_lemma2)
  19.299 +apply (rule_tac x="%n. stream_take n$ms" in exI, auto)
  19.300 +apply (induct_tac i, auto)
  19.301 +apply (drule fstreams_lub_lemma2, auto)
  19.302 +apply (rule_tac x="j" in exI, auto)
  19.303 +apply (case_tac "max_in_chain j Y")
  19.304 +apply (frule lub_finch1 [THEN lub_eqI], auto)
  19.305 +apply (rule_tac x="j" in exI)
  19.306 +apply (erule subst) back back
  19.307 +apply (simp add: sconc_mono)
  19.308 +apply (simp add: max_in_chain_def, auto)
  19.309 +apply (rule_tac x="ja" in exI)
  19.310 +apply (subgoal_tac "Y j << Y ja")
  19.311 +apply (simp add: below_prod_def, auto)
  19.312 +apply (drule below_trans)
  19.313 +apply (simp add: ax_flat, auto)
  19.314 +apply (drule fstreams_prefix, auto)+
  19.315 +apply (rule sconc_mono)
  19.316 +apply (subgoal_tac "tt ~= tta" "tta << ms")
  19.317 +apply (blast intro: fstreams_chain_lemma)
  19.318 +apply (frule lub_prod, auto)
  19.319 +apply (subgoal_tac "snd (Y ja) << (LUB i. snd (Y i))", clarsimp)
  19.320 +apply (drule fstreams_mono, simp)
  19.321 +apply (rule is_ub_thelub chainI)
  19.322 +apply (simp add: chain_def below_prod_def)
  19.323 +apply (subgoal_tac "fst (Y j) ~= fst (Y ja) | snd (Y j) ~= snd (Y ja)", simp)
  19.324 +apply (drule ax_flat, simp)+
  19.325 +apply (drule prod_eqI, auto)
  19.326 +apply (simp add: chain_mono)
  19.327 +by (rule stream_reach2)
  19.328 +
  19.329 +
  19.330 +lemma cpo_cont_lemma:
  19.331 +  "[| monofun (f::'a::cpo => 'b::cpo); (!Y. chain Y --> f (lub(range Y)) << (LUB i. f (Y i))) |] ==> cont f"
  19.332 +by (erule contI2, simp)
  19.333 +
  19.334 +end
    20.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    20.2 +++ b/src/HOL/HOLCF/FOCUS/README.html	Sat Nov 27 16:08:10 2010 -0800
    20.3 @@ -0,0 +1,22 @@
    20.4 +<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN" "http://www.w3.org/TR/html4/loose.dtd">
    20.5 +
    20.6 +<HTML>
    20.7 +
    20.8 +<HEAD>
    20.9 +  <meta http-equiv="Content-Type" content="text/html; charset=iso-8859-1">
   20.10 +  <TITLE>HOLCF/README</TITLE>
   20.11 +</HEAD>
   20.12 +
   20.13 +<BODY>
   20.14 +
   20.15 +<H3>FOCUS: a theory of stream-processing functions Isabelle/<A HREF="..">HOLCF</A></H3>
   20.16 +
   20.17 +For introductions to FOCUSs, see 
   20.18 +<UL>
   20.19 +<LI><A HREF="http://www4.in.tum.de/publ/html.php?e=2">The Design of Distributed Systems - An Introduction to FOCUS</A>
   20.20 +<LI><A HREF="http://www4.in.tum.de/publ/html.php?e=15">Specification and Refinement of a Buffer of Length One</A>
   20.21 +<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>
   20.22 +</UL>
   20.23 +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>.
   20.24 +
   20.25 +</BODY></HTML>
    21.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    21.2 +++ b/src/HOL/HOLCF/FOCUS/ROOT.ML	Sat Nov 27 16:08:10 2010 -0800
    21.3 @@ -0,0 +1,1 @@
    21.4 +use_thys ["Fstreams", "FOCUS", "Buffer_adm"];
    22.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    22.2 +++ b/src/HOL/HOLCF/FOCUS/Stream_adm.thy	Sat Nov 27 16:08:10 2010 -0800
    22.3 @@ -0,0 +1,225 @@
    22.4 +(*  Title:      HOLCF/ex/Stream_adm.thy
    22.5 +    Author:     David von Oheimb, TU Muenchen
    22.6 +*)
    22.7 +
    22.8 +header {* Admissibility for streams *}
    22.9 +
   22.10 +theory Stream_adm
   22.11 +imports Stream Continuity
   22.12 +begin
   22.13 +
   22.14 +definition
   22.15 +  stream_monoP  :: "(('a stream) set \<Rightarrow> ('a stream) set) \<Rightarrow> bool" where
   22.16 +  "stream_monoP F = (\<exists>Q i. \<forall>P s. Fin i \<le> #s \<longrightarrow>
   22.17 +                    (s \<in> F P) = (stream_take i\<cdot>s \<in> Q \<and> iterate i\<cdot>rt\<cdot>s \<in> P))"
   22.18 +
   22.19 +definition
   22.20 +  stream_antiP  :: "(('a stream) set \<Rightarrow> ('a stream) set) \<Rightarrow> bool" where
   22.21 +  "stream_antiP F = (\<forall>P x. \<exists>Q i.
   22.22 +                (#x  < Fin i \<longrightarrow> (\<forall>y. x \<sqsubseteq> y \<longrightarrow> y \<in> F P \<longrightarrow> x \<in> F P)) \<and>
   22.23 +                (Fin i <= #x \<longrightarrow> (\<forall>y. x \<sqsubseteq> y \<longrightarrow>
   22.24 +                (y \<in> F P) = (stream_take i\<cdot>y \<in> Q \<and> iterate i\<cdot>rt\<cdot>y \<in> P))))"
   22.25 +
   22.26 +definition
   22.27 +  antitonP :: "'a set => bool" where
   22.28 +  "antitonP P = (\<forall>x y. x \<sqsubseteq> y \<longrightarrow> y\<in>P \<longrightarrow> x\<in>P)"
   22.29 +
   22.30 +
   22.31 +(* ----------------------------------------------------------------------- *)
   22.32 +
   22.33 +section "admissibility"
   22.34 +
   22.35 +lemma infinite_chain_adm_lemma:
   22.36 +  "\<lbrakk>Porder.chain Y; \<forall>i. P (Y i);  
   22.37 +    \<And>Y. \<lbrakk>Porder.chain Y; \<forall>i. P (Y i); \<not> finite_chain Y\<rbrakk> \<Longrightarrow> P (\<Squnion>i. Y i)\<rbrakk>
   22.38 +      \<Longrightarrow> P (\<Squnion>i. Y i)"
   22.39 +apply (case_tac "finite_chain Y")
   22.40 +prefer 2 apply fast
   22.41 +apply (unfold finite_chain_def)
   22.42 +apply safe
   22.43 +apply (erule lub_finch1 [THEN lub_eqI, THEN ssubst])
   22.44 +apply assumption
   22.45 +apply (erule spec)
   22.46 +done
   22.47 +
   22.48 +lemma increasing_chain_adm_lemma:
   22.49 +  "\<lbrakk>Porder.chain Y;  \<forall>i. P (Y i); \<And>Y. \<lbrakk>Porder.chain Y; \<forall>i. P (Y i);
   22.50 +    \<forall>i. \<exists>j>i. Y i \<noteq> Y j \<and> Y i \<sqsubseteq> Y j\<rbrakk> \<Longrightarrow> P (\<Squnion>i. Y i)\<rbrakk>
   22.51 +      \<Longrightarrow> P (\<Squnion>i. Y i)"
   22.52 +apply (erule infinite_chain_adm_lemma)
   22.53 +apply assumption
   22.54 +apply (erule thin_rl)
   22.55 +apply (unfold finite_chain_def)
   22.56 +apply (unfold max_in_chain_def)
   22.57 +apply (fast dest: le_imp_less_or_eq elim: chain_mono_less)
   22.58 +done
   22.59 +
   22.60 +lemma flatstream_adm_lemma:
   22.61 +  assumes 1: "Porder.chain Y"
   22.62 +  assumes 2: "!i. P (Y i)"
   22.63 +  assumes 3: "(!!Y. [| Porder.chain Y; !i. P (Y i); !k. ? j. Fin k < #((Y j)::'a::flat stream)|]
   22.64 +  ==> P(LUB i. Y i))"
   22.65 +  shows "P(LUB i. Y i)"
   22.66 +apply (rule increasing_chain_adm_lemma [of _ P, OF 1 2])
   22.67 +apply (erule 3, assumption)
   22.68 +apply (erule thin_rl)
   22.69 +apply (rule allI)
   22.70 +apply (case_tac "!j. stream_finite (Y j)")
   22.71 +apply ( rule chain_incr)
   22.72 +apply ( rule allI)
   22.73 +apply ( drule spec)
   22.74 +apply ( safe)
   22.75 +apply ( rule exI)
   22.76 +apply ( rule slen_strict_mono)
   22.77 +apply (   erule spec)
   22.78 +apply (  assumption)
   22.79 +apply ( assumption)
   22.80 +apply (metis inat_ord_code(4) slen_infinite)
   22.81 +done
   22.82 +
   22.83 +(* should be without reference to stream length? *)
   22.84 +lemma flatstream_admI: "[|(!!Y. [| Porder.chain Y; !i. P (Y i); 
   22.85 + !k. ? j. Fin k < #((Y j)::'a::flat stream)|] ==> P(LUB i. Y i))|]==> adm P"
   22.86 +apply (unfold adm_def)
   22.87 +apply (intro strip)
   22.88 +apply (erule (1) flatstream_adm_lemma)
   22.89 +apply (fast)
   22.90 +done
   22.91 +
   22.92 +
   22.93 +(* context (theory "Nat_InFinity");*)
   22.94 +lemma ile_lemma: "Fin (i + j) <= x ==> Fin i <= x"
   22.95 +  by (rule order_trans) auto
   22.96 +
   22.97 +lemma stream_monoP2I:
   22.98 +"!!X. stream_monoP F ==> !i. ? l. !x y. 
   22.99 +  Fin l <= #x --> (x::'a::flat stream) << y --> x:down_iterate F i --> y:down_iterate F i"
  22.100 +apply (unfold stream_monoP_def)
  22.101 +apply (safe)
  22.102 +apply (rule_tac x="i*ia" in exI)
  22.103 +apply (induct_tac "ia")
  22.104 +apply ( simp)
  22.105 +apply (simp)
  22.106 +apply (intro strip)
  22.107 +apply (erule allE, erule all_dupE, drule mp, erule ile_lemma)
  22.108 +apply (drule_tac P="%x. x" in subst, assumption)
  22.109 +apply (erule allE, drule mp, rule ile_lemma) back
  22.110 +apply ( erule order_trans)
  22.111 +apply ( erule slen_mono)
  22.112 +apply (erule ssubst)
  22.113 +apply (safe)
  22.114 +apply ( erule (2) ile_lemma [THEN slen_take_lemma3, THEN subst])
  22.115 +apply (erule allE)
  22.116 +apply (drule mp)
  22.117 +apply ( erule slen_rt_mult)
  22.118 +apply (erule allE)
  22.119 +apply (drule mp)
  22.120 +apply (erule monofun_rt_mult)
  22.121 +apply (drule (1) mp)
  22.122 +apply (assumption)
  22.123 +done
  22.124 +
  22.125 +lemma stream_monoP2_gfp_admI: "[| !i. ? l. !x y. 
  22.126 + Fin l <= #x --> (x::'a::flat stream) << y --> x:down_iterate F i --> y:down_iterate F i;
  22.127 +    down_cont F |] ==> adm (%x. x:gfp F)"
  22.128 +apply (erule INTER_down_iterate_is_gfp [THEN ssubst]) (* cont *)
  22.129 +apply (simp (no_asm))
  22.130 +apply (rule adm_lemmas)
  22.131 +apply (rule flatstream_admI)
  22.132 +apply (erule allE)
  22.133 +apply (erule exE)
  22.134 +apply (erule allE, erule exE)
  22.135 +apply (erule allE, erule allE, drule mp) (* stream_monoP *)
  22.136 +apply ( drule ileI1)
  22.137 +apply ( drule order_trans)
  22.138 +apply (  rule ile_iSuc)
  22.139 +apply ( drule iSuc_ile_mono [THEN iffD1])
  22.140 +apply ( assumption)
  22.141 +apply (drule mp)
  22.142 +apply ( erule is_ub_thelub)
  22.143 +apply (fast)
  22.144 +done
  22.145 +
  22.146 +lemmas fstream_gfp_admI = stream_monoP2I [THEN stream_monoP2_gfp_admI]
  22.147 +
  22.148 +lemma stream_antiP2I:
  22.149 +"!!X. [|stream_antiP (F::(('a::flat stream)set => ('a stream set)))|]
  22.150 +  ==> !i x y. x << y --> y:down_iterate F i --> x:down_iterate F i"
  22.151 +apply (unfold stream_antiP_def)
  22.152 +apply (rule allI)
  22.153 +apply (induct_tac "i")
  22.154 +apply ( simp)
  22.155 +apply (simp)
  22.156 +apply (intro strip)
  22.157 +apply (erule allE, erule all_dupE, erule exE, erule exE)
  22.158 +apply (erule conjE)
  22.159 +apply (case_tac "#x < Fin i")
  22.160 +apply ( fast)
  22.161 +apply (unfold linorder_not_less)
  22.162 +apply (drule (1) mp)
  22.163 +apply (erule all_dupE, drule mp, rule below_refl)
  22.164 +apply (erule ssubst)
  22.165 +apply (erule allE, drule (1) mp)
  22.166 +apply (drule_tac P="%x. x" in subst, assumption)
  22.167 +apply (erule conjE, rule conjI)
  22.168 +apply ( erule slen_take_lemma3 [THEN ssubst], assumption)
  22.169 +apply ( assumption)
  22.170 +apply (erule allE, erule allE, drule mp, erule monofun_rt_mult)
  22.171 +apply (drule (1) mp)
  22.172 +apply (assumption)
  22.173 +done
  22.174 +
  22.175 +lemma stream_antiP2_non_gfp_admI:
  22.176 +"!!X. [|!i x y. x << y --> y:down_iterate F i --> x:down_iterate F i; down_cont F |] 
  22.177 +  ==> adm (%u. ~ u:gfp F)"
  22.178 +apply (unfold adm_def)
  22.179 +apply (simp add: INTER_down_iterate_is_gfp)
  22.180 +apply (fast dest!: is_ub_thelub)
  22.181 +done
  22.182 +
  22.183 +lemmas fstream_non_gfp_admI = stream_antiP2I [THEN stream_antiP2_non_gfp_admI]
  22.184 +
  22.185 +
  22.186 +
  22.187 +(**new approach for adm********************************************************)
  22.188 +
  22.189 +section "antitonP"
  22.190 +
  22.191 +lemma antitonPD: "[| antitonP P; y:P; x<<y |] ==> x:P"
  22.192 +apply (unfold antitonP_def)
  22.193 +apply auto
  22.194 +done
  22.195 +
  22.196 +lemma antitonPI: "!x y. y:P --> x<<y --> x:P ==> antitonP P"
  22.197 +apply (unfold antitonP_def)
  22.198 +apply (fast)
  22.199 +done
  22.200 +
  22.201 +lemma antitonP_adm_non_P: "antitonP P ==> adm (%u. u~:P)"
  22.202 +apply (unfold adm_def)
  22.203 +apply (auto dest: antitonPD elim: is_ub_thelub)
  22.204 +done
  22.205 +
  22.206 +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> 
  22.207 +  adm (\<lambda>u. u\<notin>P)"
  22.208 +apply (simp)
  22.209 +apply (rule antitonP_adm_non_P)
  22.210 +apply (rule antitonPI)
  22.211 +apply (drule gfp_upperbound)
  22.212 +apply (fast)
  22.213 +done
  22.214 +
  22.215 +lemma adm_set:
  22.216 +"{\<Squnion>i. Y i |Y. Porder.chain Y & (\<forall>i. Y i \<in> P)} \<subseteq> P \<Longrightarrow> adm (\<lambda>x. x\<in>P)"
  22.217 +apply (unfold adm_def)
  22.218 +apply (fast)
  22.219 +done
  22.220 +
  22.221 +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> 
  22.222 +  F {\<Squnion>i. Y i |Y. Porder.chain Y \<and> (\<forall>i. Y i \<in> P)} \<Longrightarrow> adm (\<lambda>x. x\<in>P)"
  22.223 +apply (simp)
  22.224 +apply (rule adm_set)
  22.225 +apply (erule gfp_upperbound)
  22.226 +done
  22.227 +
  22.228 +end
    23.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    23.2 +++ b/src/HOL/HOLCF/Fix.thy	Sat Nov 27 16:08:10 2010 -0800
    23.3 @@ -0,0 +1,229 @@
    23.4 +(*  Title:      HOLCF/Fix.thy
    23.5 +    Author:     Franz Regensburger
    23.6 +    Author:     Brian Huffman
    23.7 +*)
    23.8 +
    23.9 +header {* Fixed point operator and admissibility *}
   23.10 +
   23.11 +theory Fix
   23.12 +imports Cfun
   23.13 +begin
   23.14 +
   23.15 +default_sort pcpo
   23.16 +
   23.17 +subsection {* Iteration *}
   23.18 +
   23.19 +primrec iterate :: "nat \<Rightarrow> ('a::cpo \<rightarrow> 'a) \<rightarrow> ('a \<rightarrow> 'a)" where
   23.20 +    "iterate 0 = (\<Lambda> F x. x)"
   23.21 +  | "iterate (Suc n) = (\<Lambda> F x. F\<cdot>(iterate n\<cdot>F\<cdot>x))"
   23.22 +
   23.23 +text {* Derive inductive properties of iterate from primitive recursion *}
   23.24 +
   23.25 +lemma iterate_0 [simp]: "iterate 0\<cdot>F\<cdot>x = x"
   23.26 +by simp
   23.27 +
   23.28 +lemma iterate_Suc [simp]: "iterate (Suc n)\<cdot>F\<cdot>x = F\<cdot>(iterate n\<cdot>F\<cdot>x)"
   23.29 +by simp
   23.30 +
   23.31 +declare iterate.simps [simp del]
   23.32 +
   23.33 +lemma iterate_Suc2: "iterate (Suc n)\<cdot>F\<cdot>x = iterate n\<cdot>F\<cdot>(F\<cdot>x)"
   23.34 +by (induct n) simp_all
   23.35 +
   23.36 +lemma iterate_iterate:
   23.37 +  "iterate m\<cdot>F\<cdot>(iterate n\<cdot>F\<cdot>x) = iterate (m + n)\<cdot>F\<cdot>x"
   23.38 +by (induct m) simp_all
   23.39 +
   23.40 +text {* The sequence of function iterations is a chain. *}
   23.41 +
   23.42 +lemma chain_iterate [simp]: "chain (\<lambda>i. iterate i\<cdot>F\<cdot>\<bottom>)"
   23.43 +by (rule chainI, unfold iterate_Suc2, rule monofun_cfun_arg, rule minimal)
   23.44 +
   23.45 +
   23.46 +subsection {* Least fixed point operator *}
   23.47 +
   23.48 +definition
   23.49 +  "fix" :: "('a \<rightarrow> 'a) \<rightarrow> 'a" where
   23.50 +  "fix = (\<Lambda> F. \<Squnion>i. iterate i\<cdot>F\<cdot>\<bottom>)"
   23.51 +
   23.52 +text {* Binder syntax for @{term fix} *}
   23.53 +
   23.54 +abbreviation
   23.55 +  fix_syn :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a"  (binder "FIX " 10) where
   23.56 +  "fix_syn (\<lambda>x. f x) \<equiv> fix\<cdot>(\<Lambda> x. f x)"
   23.57 +
   23.58 +notation (xsymbols)
   23.59 +  fix_syn  (binder "\<mu> " 10)
   23.60 +
   23.61 +text {* Properties of @{term fix} *}
   23.62 +
   23.63 +text {* direct connection between @{term fix} and iteration *}
   23.64 +
   23.65 +lemma fix_def2: "fix\<cdot>F = (\<Squnion>i. iterate i\<cdot>F\<cdot>\<bottom>)"
   23.66 +unfolding fix_def by simp
   23.67 +
   23.68 +lemma iterate_below_fix: "iterate n\<cdot>f\<cdot>\<bottom> \<sqsubseteq> fix\<cdot>f"
   23.69 +  unfolding fix_def2
   23.70 +  using chain_iterate by (rule is_ub_thelub)
   23.71 +
   23.72 +text {*
   23.73 +  Kleene's fixed point theorems for continuous functions in pointed
   23.74 +  omega cpo's
   23.75 +*}
   23.76 +
   23.77 +lemma fix_eq: "fix\<cdot>F = F\<cdot>(fix\<cdot>F)"
   23.78 +apply (simp add: fix_def2)
   23.79 +apply (subst lub_range_shift [of _ 1, symmetric])
   23.80 +apply (rule chain_iterate)
   23.81 +apply (subst contlub_cfun_arg)
   23.82 +apply (rule chain_iterate)
   23.83 +apply simp
   23.84 +done
   23.85 +
   23.86 +lemma fix_least_below: "F\<cdot>x \<sqsubseteq> x \<Longrightarrow> fix\<cdot>F \<sqsubseteq> x"
   23.87 +apply (simp add: fix_def2)
   23.88 +apply (rule lub_below)
   23.89 +apply (rule chain_iterate)
   23.90 +apply (induct_tac i)
   23.91 +apply simp
   23.92 +apply simp
   23.93 +apply (erule rev_below_trans)
   23.94 +apply (erule monofun_cfun_arg)
   23.95 +done
   23.96 +
   23.97 +lemma fix_least: "F\<cdot>x = x \<Longrightarrow> fix\<cdot>F \<sqsubseteq> x"
   23.98 +by (rule fix_least_below, simp)
   23.99 +
  23.100 +lemma fix_eqI:
  23.101 +  assumes fixed: "F\<cdot>x = x" and least: "\<And>z. F\<cdot>z = z \<Longrightarrow> x \<sqsubseteq> z"
  23.102 +  shows "fix\<cdot>F = x"
  23.103 +apply (rule below_antisym)
  23.104 +apply (rule fix_least [OF fixed])
  23.105 +apply (rule least [OF fix_eq [symmetric]])
  23.106 +done
  23.107 +
  23.108 +lemma fix_eq2: "f \<equiv> fix\<cdot>F \<Longrightarrow> f = F\<cdot>f"
  23.109 +by (simp add: fix_eq [symmetric])
  23.110 +
  23.111 +lemma fix_eq3: "f \<equiv> fix\<cdot>F \<Longrightarrow> f\<cdot>x = F\<cdot>f\<cdot>x"
  23.112 +by (erule fix_eq2 [THEN cfun_fun_cong])
  23.113 +
  23.114 +lemma fix_eq4: "f = fix\<cdot>F \<Longrightarrow> f = F\<cdot>f"
  23.115 +apply (erule ssubst)
  23.116 +apply (rule fix_eq)
  23.117 +done
  23.118 +
  23.119 +lemma fix_eq5: "f = fix\<cdot>F \<Longrightarrow> f\<cdot>x = F\<cdot>f\<cdot>x"
  23.120 +by (erule fix_eq4 [THEN cfun_fun_cong])
  23.121 +
  23.122 +text {* strictness of @{term fix} *}
  23.123 +
  23.124 +lemma fix_bottom_iff: "(fix\<cdot>F = \<bottom>) = (F\<cdot>\<bottom> = \<bottom>)"
  23.125 +apply (rule iffI)
  23.126 +apply (erule subst)
  23.127 +apply (rule fix_eq [symmetric])
  23.128 +apply (erule fix_least [THEN UU_I])
  23.129 +done
  23.130 +
  23.131 +lemma fix_strict: "F\<cdot>\<bottom> = \<bottom> \<Longrightarrow> fix\<cdot>F = \<bottom>"
  23.132 +by (simp add: fix_bottom_iff)
  23.133 +
  23.134 +lemma fix_defined: "F\<cdot>\<bottom> \<noteq> \<bottom> \<Longrightarrow> fix\<cdot>F \<noteq> \<bottom>"
  23.135 +by (simp add: fix_bottom_iff)
  23.136 +
  23.137 +text {* @{term fix} applied to identity and constant functions *}
  23.138 +
  23.139 +lemma fix_id: "(\<mu> x. x) = \<bottom>"
  23.140 +by (simp add: fix_strict)
  23.141 +
  23.142 +lemma fix_const: "(\<mu> x. c) = c"
  23.143 +by (subst fix_eq, simp)
  23.144 +
  23.145 +subsection {* Fixed point induction *}
  23.146 +
  23.147 +lemma fix_ind: "\<lbrakk>adm P; P \<bottom>; \<And>x. P x \<Longrightarrow> P (F\<cdot>x)\<rbrakk> \<Longrightarrow> P (fix\<cdot>F)"
  23.148 +unfolding fix_def2
  23.149 +apply (erule admD)
  23.150 +apply (rule chain_iterate)
  23.151 +apply (rule nat_induct, simp_all)
  23.152 +done
  23.153 +
  23.154 +lemma def_fix_ind:
  23.155 +  "\<lbrakk>f \<equiv> fix\<cdot>F; adm P; P \<bottom>; \<And>x. P x \<Longrightarrow> P (F\<cdot>x)\<rbrakk> \<Longrightarrow> P f"
  23.156 +by (simp add: fix_ind)
  23.157 +
  23.158 +lemma fix_ind2:
  23.159 +  assumes adm: "adm P"
  23.160 +  assumes 0: "P \<bottom>" and 1: "P (F\<cdot>\<bottom>)"
  23.161 +  assumes step: "\<And>x. \<lbrakk>P x; P (F\<cdot>x)\<rbrakk> \<Longrightarrow> P (F\<cdot>(F\<cdot>x))"
  23.162 +  shows "P (fix\<cdot>F)"
  23.163 +unfolding fix_def2
  23.164 +apply (rule admD [OF adm chain_iterate])
  23.165 +apply (rule nat_less_induct)
  23.166 +apply (case_tac n)
  23.167 +apply (simp add: 0)
  23.168 +apply (case_tac nat)
  23.169 +apply (simp add: 1)
  23.170 +apply (frule_tac x=nat in spec)
  23.171 +apply (simp add: step)
  23.172 +done
  23.173 +
  23.174 +lemma parallel_fix_ind:
  23.175 +  assumes adm: "adm (\<lambda>x. P (fst x) (snd x))"
  23.176 +  assumes base: "P \<bottom> \<bottom>"
  23.177 +  assumes step: "\<And>x y. P x y \<Longrightarrow> P (F\<cdot>x) (G\<cdot>y)"
  23.178 +  shows "P (fix\<cdot>F) (fix\<cdot>G)"
  23.179 +proof -
  23.180 +  from adm have adm': "adm (split P)"
  23.181 +    unfolding split_def .
  23.182 +  have "\<And>i. P (iterate i\<cdot>F\<cdot>\<bottom>) (iterate i\<cdot>G\<cdot>\<bottom>)"
  23.183 +    by (induct_tac i, simp add: base, simp add: step)
  23.184 +  hence "\<And>i. split P (iterate i\<cdot>F\<cdot>\<bottom>, iterate i\<cdot>G\<cdot>\<bottom>)"
  23.185 +    by simp
  23.186 +  hence "split P (\<Squnion>i. (iterate i\<cdot>F\<cdot>\<bottom>, iterate i\<cdot>G\<cdot>\<bottom>))"
  23.187 +    by - (rule admD [OF adm'], simp, assumption)
  23.188 +  hence "split P (\<Squnion>i. iterate i\<cdot>F\<cdot>\<bottom>, \<Squnion>i. iterate i\<cdot>G\<cdot>\<bottom>)"
  23.189 +    by (simp add: lub_Pair)
  23.190 +  hence "P (\<Squnion>i. iterate i\<cdot>F\<cdot>\<bottom>) (\<Squnion>i. iterate i\<cdot>G\<cdot>\<bottom>)"
  23.191 +    by simp
  23.192 +  thus "P (fix\<cdot>F) (fix\<cdot>G)"
  23.193 +    by (simp add: fix_def2)
  23.194 +qed
  23.195 +
  23.196 +subsection {* Fixed-points on product types *}
  23.197 +
  23.198 +text {*
  23.199 +  Bekic's Theorem: Simultaneous fixed points over pairs
  23.200 +  can be written in terms of separate fixed points.
  23.201 +*}
  23.202 +
  23.203 +lemma fix_cprod:
  23.204 +  "fix\<cdot>(F::'a \<times> 'b \<rightarrow> 'a \<times> 'b) =
  23.205 +   (\<mu> x. fst (F\<cdot>(x, \<mu> y. snd (F\<cdot>(x, y)))),
  23.206 +    \<mu> y. snd (F\<cdot>(\<mu> x. fst (F\<cdot>(x, \<mu> y. snd (F\<cdot>(x, y)))), y)))"
  23.207 +  (is "fix\<cdot>F = (?x, ?y)")
  23.208 +proof (rule fix_eqI)
  23.209 +  have 1: "fst (F\<cdot>(?x, ?y)) = ?x"
  23.210 +    by (rule trans [symmetric, OF fix_eq], simp)
  23.211 +  have 2: "snd (F\<cdot>(?x, ?y)) = ?y"
  23.212 +    by (rule trans [symmetric, OF fix_eq], simp)
  23.213 +  from 1 2 show "F\<cdot>(?x, ?y) = (?x, ?y)" by (simp add: Pair_fst_snd_eq)
  23.214 +next
  23.215 +  fix z assume F_z: "F\<cdot>z = z"
  23.216 +  obtain x y where z: "z = (x,y)" by (rule prod.exhaust)
  23.217 +  from F_z z have F_x: "fst (F\<cdot>(x, y)) = x" by simp
  23.218 +  from F_z z have F_y: "snd (F\<cdot>(x, y)) = y" by simp
  23.219 +  let ?y1 = "\<mu> y. snd (F\<cdot>(x, y))"
  23.220 +  have "?y1 \<sqsubseteq> y" by (rule fix_least, simp add: F_y)
  23.221 +  hence "fst (F\<cdot>(x, ?y1)) \<sqsubseteq> fst (F\<cdot>(x, y))"
  23.222 +    by (simp add: fst_monofun monofun_cfun)
  23.223 +  hence "fst (F\<cdot>(x, ?y1)) \<sqsubseteq> x" using F_x by simp
  23.224 +  hence 1: "?x \<sqsubseteq> x" by (simp add: fix_least_below)
  23.225 +  hence "snd (F\<cdot>(?x, y)) \<sqsubseteq> snd (F\<cdot>(x, y))"
  23.226 +    by (simp add: snd_monofun monofun_cfun)
  23.227 +  hence "snd (F\<cdot>(?x, y)) \<sqsubseteq> y" using F_y by simp
  23.228 +  hence 2: "?y \<sqsubseteq> y" by (simp add: fix_least_below)
  23.229 +  show "(?x, ?y) \<sqsubseteq> z" using z 1 2 by simp
  23.230 +qed
  23.231 +
  23.232 +end
    24.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    24.2 +++ b/src/HOL/HOLCF/Fixrec.thy	Sat Nov 27 16:08:10 2010 -0800
    24.3 @@ -0,0 +1,252 @@
    24.4 +(*  Title:      HOLCF/Fixrec.thy
    24.5 +    Author:     Amber Telfer and Brian Huffman
    24.6 +*)
    24.7 +
    24.8 +header "Package for defining recursive functions in HOLCF"
    24.9 +
   24.10 +theory Fixrec
   24.11 +imports Plain_HOLCF
   24.12 +uses
   24.13 +  ("Tools/holcf_library.ML")
   24.14 +  ("Tools/fixrec.ML")
   24.15 +begin
   24.16 +
   24.17 +subsection {* Pattern-match monad *}
   24.18 +
   24.19 +default_sort cpo
   24.20 +
   24.21 +pcpodef (open) 'a match = "UNIV::(one ++ 'a u) set"
   24.22 +by simp_all
   24.23 +
   24.24 +definition
   24.25 +  fail :: "'a match" where
   24.26 +  "fail = Abs_match (sinl\<cdot>ONE)"
   24.27 +
   24.28 +definition
   24.29 +  succeed :: "'a \<rightarrow> 'a match" where
   24.30 +  "succeed = (\<Lambda> x. Abs_match (sinr\<cdot>(up\<cdot>x)))"
   24.31 +
   24.32 +lemma matchE [case_names bottom fail succeed, cases type: match]:
   24.33 +  "\<lbrakk>p = \<bottom> \<Longrightarrow> Q; p = fail \<Longrightarrow> Q; \<And>x. p = succeed\<cdot>x \<Longrightarrow> Q\<rbrakk> \<Longrightarrow> Q"
   24.34 +unfolding fail_def succeed_def
   24.35 +apply (cases p, rename_tac r)
   24.36 +apply (rule_tac p=r in ssumE, simp add: Abs_match_strict)
   24.37 +apply (rule_tac p=x in oneE, simp, simp)
   24.38 +apply (rule_tac p=y in upE, simp, simp add: cont_Abs_match)
   24.39 +done
   24.40 +
   24.41 +lemma succeed_defined [simp]: "succeed\<cdot>x \<noteq> \<bottom>"
   24.42 +by (simp add: succeed_def cont_Abs_match Abs_match_defined)
   24.43 +
   24.44 +lemma fail_defined [simp]: "fail \<noteq> \<bottom>"
   24.45 +by (simp add: fail_def Abs_match_defined)
   24.46 +
   24.47 +lemma succeed_eq [simp]: "(succeed\<cdot>x = succeed\<cdot>y) = (x = y)"
   24.48 +by (simp add: succeed_def cont_Abs_match Abs_match_inject)
   24.49 +
   24.50 +lemma succeed_neq_fail [simp]:
   24.51 +  "succeed\<cdot>x \<noteq> fail" "fail \<noteq> succeed\<cdot>x"
   24.52 +by (simp_all add: succeed_def fail_def cont_Abs_match Abs_match_inject)
   24.53 +
   24.54 +subsubsection {* Run operator *}
   24.55 +
   24.56 +definition
   24.57 +  run :: "'a match \<rightarrow> 'a::pcpo" where
   24.58 +  "run = (\<Lambda> m. sscase\<cdot>\<bottom>\<cdot>(fup\<cdot>ID)\<cdot>(Rep_match m))"
   24.59 +
   24.60 +text {* rewrite rules for run *}
   24.61 +
   24.62 +lemma run_strict [simp]: "run\<cdot>\<bottom> = \<bottom>"
   24.63 +unfolding run_def
   24.64 +by (simp add: cont_Rep_match Rep_match_strict)
   24.65 +
   24.66 +lemma run_fail [simp]: "run\<cdot>fail = \<bottom>"
   24.67 +unfolding run_def fail_def
   24.68 +by (simp add: cont_Rep_match Abs_match_inverse)
   24.69 +
   24.70 +lemma run_succeed [simp]: "run\<cdot>(succeed\<cdot>x) = x"
   24.71 +unfolding run_def succeed_def
   24.72 +by (simp add: cont_Rep_match cont_Abs_match Abs_match_inverse)
   24.73 +
   24.74 +subsubsection {* Monad plus operator *}
   24.75 +
   24.76 +definition
   24.77 +  mplus :: "'a match \<rightarrow> 'a match \<rightarrow> 'a match" where
   24.78 +  "mplus = (\<Lambda> m1 m2. sscase\<cdot>(\<Lambda> _. m2)\<cdot>(\<Lambda> _. m1)\<cdot>(Rep_match m1))"
   24.79 +
   24.80 +abbreviation
   24.81 +  mplus_syn :: "['a match, 'a match] \<Rightarrow> 'a match"  (infixr "+++" 65)  where
   24.82 +  "m1 +++ m2 == mplus\<cdot>m1\<cdot>m2"
   24.83 +
   24.84 +text {* rewrite rules for mplus *}
   24.85 +
   24.86 +lemmas cont2cont_Rep_match = cont_Rep_match [THEN cont_compose]
   24.87 +
   24.88 +lemma mplus_strict [simp]: "\<bottom> +++ m = \<bottom>"
   24.89 +unfolding mplus_def
   24.90 +by (simp add: cont2cont_Rep_match Rep_match_strict)
   24.91 +
   24.92 +lemma mplus_fail [simp]: "fail +++ m = m"
   24.93 +unfolding mplus_def fail_def
   24.94 +by (simp add: cont2cont_Rep_match Abs_match_inverse)
   24.95 +
   24.96 +lemma mplus_succeed [simp]: "succeed\<cdot>x +++ m = succeed\<cdot>x"
   24.97 +unfolding mplus_def succeed_def
   24.98 +by (simp add: cont2cont_Rep_match cont_Abs_match Abs_match_inverse)
   24.99 +
  24.100 +lemma mplus_fail2 [simp]: "m +++ fail = m"
  24.101 +by (cases m, simp_all)
  24.102 +
  24.103 +lemma mplus_assoc: "(x +++ y) +++ z = x +++ (y +++ z)"
  24.104 +by (cases x, simp_all)
  24.105 +
  24.106 +subsection {* Match functions for built-in types *}
  24.107 +
  24.108 +default_sort pcpo
  24.109 +
  24.110 +definition
  24.111 +  match_bottom :: "'a \<rightarrow> 'c match \<rightarrow> 'c match"
  24.112 +where
  24.113 +  "match_bottom = (\<Lambda> x k. seq\<cdot>x\<cdot>fail)"
  24.114 +
  24.115 +definition
  24.116 +  match_Pair :: "'a::cpo \<times> 'b::cpo \<rightarrow> ('a \<rightarrow> 'b \<rightarrow> 'c match) \<rightarrow> 'c match"
  24.117 +where
  24.118 +  "match_Pair = (\<Lambda> x k. csplit\<cdot>k\<cdot>x)"
  24.119 +
  24.120 +definition
  24.121 +  match_spair :: "'a \<otimes> 'b \<rightarrow> ('a \<rightarrow> 'b \<rightarrow> 'c match) \<rightarrow> 'c match"
  24.122 +where
  24.123 +  "match_spair = (\<Lambda> x k. ssplit\<cdot>k\<cdot>x)"
  24.124 +
  24.125 +definition
  24.126 +  match_sinl :: "'a \<oplus> 'b \<rightarrow> ('a \<rightarrow> 'c match) \<rightarrow> 'c match"
  24.127 +where
  24.128 +  "match_sinl = (\<Lambda> x k. sscase\<cdot>k\<cdot>(\<Lambda> b. fail)\<cdot>x)"
  24.129 +
  24.130 +definition
  24.131 +  match_sinr :: "'a \<oplus> 'b \<rightarrow> ('b \<rightarrow> 'c match) \<rightarrow> 'c match"
  24.132 +where
  24.133 +  "match_sinr = (\<Lambda> x k. sscase\<cdot>(\<Lambda> a. fail)\<cdot>k\<cdot>x)"
  24.134 +
  24.135 +definition
  24.136 +  match_up :: "'a::cpo u \<rightarrow> ('a \<rightarrow> 'c match) \<rightarrow> 'c match"
  24.137 +where
  24.138 +  "match_up = (\<Lambda> x k. fup\<cdot>k\<cdot>x)"
  24.139 +
  24.140 +definition
  24.141 +  match_ONE :: "one \<rightarrow> 'c match \<rightarrow> 'c match"
  24.142 +where
  24.143 +  "match_ONE = (\<Lambda> ONE k. k)"
  24.144 +
  24.145 +definition
  24.146 +  match_TT :: "tr \<rightarrow> 'c match \<rightarrow> 'c match"
  24.147 +where
  24.148 +  "match_TT = (\<Lambda> x k. If x then k else fail)"
  24.149 + 
  24.150 +definition
  24.151 +  match_FF :: "tr \<rightarrow> 'c match \<rightarrow> 'c match"
  24.152 +where
  24.153 +  "match_FF = (\<Lambda> x k. If x then fail else k)"