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)"
24.154 +
24.155 +lemma match_bottom_simps [simp]:
24.156 + "match_bottom\<cdot>\<bottom>\<cdot>k = \<bottom>"
24.157 + "x \<noteq> \<bottom> \<Longrightarrow> match_bottom\<cdot>x\<cdot>k = fail"
24.158 +by (simp_all add: match_bottom_def)
24.159 +
24.160 +lemma match_Pair_simps [simp]:
24.161 + "match_Pair\<cdot>(x, y)\<cdot>k = k\<cdot>x\<cdot>y"
24.162 +by (simp_all add: match_Pair_def)
24.163 +
24.164 +lemma match_spair_simps [simp]:
24.165 + "\<lbrakk>x \<noteq> \<bottom>; y \<noteq> \<bottom>\<rbrakk> \<Longrightarrow> match_spair\<cdot>(:x, y:)\<cdot>k = k\<cdot>x\<cdot>y"
24.166 + "match_spair\<cdot>\<bottom>\<cdot>k = \<bottom>"
24.167 +by (simp_all add: match_spair_def)
24.168 +
24.169 +lemma match_sinl_simps [simp]:
24.170 + "x \<noteq> \<bottom> \<Longrightarrow> match_sinl\<cdot>(sinl\<cdot>x)\<cdot>k = k\<cdot>x"
24.171 + "y \<noteq> \<bottom> \<Longrightarrow> match_sinl\<cdot>(sinr\<cdot>y)\<cdot>k = fail"
24.172 + "match_sinl\<cdot>\<bottom>\<cdot>k = \<bottom>"
24.173 +by (simp_all add: match_sinl_def)
24.174 +
24.175 +lemma match_sinr_simps [simp]:
24.176 + "x \<noteq> \<bottom> \<Longrightarrow> match_sinr\<cdot>(sinl\<cdot>x)\<cdot>k = fail"
24.177 + "y \<noteq> \<bottom> \<Longrightarrow> match_sinr\<cdot>(sinr\<cdot>y)\<cdot>k = k\<cdot>y"
24.178 + "match_sinr\<cdot>\<bottom>\<cdot>k = \<bottom>"
24.179 +by (simp_all add: match_sinr_def)
24.180 +
24.181 +lemma match_up_simps [simp]:
24.182 + "match_up\<cdot>(up\<cdot>x)\<cdot>k = k\<cdot>x"
24.183 + "match_up\<cdot>\<bottom>\<cdot>k = \<bottom>"
24.184 +by (simp_all add: match_up_def)
24.185 +
24.186 +lemma match_ONE_simps [simp]:
24.187 + "match_ONE\<cdot>ONE\<cdot>k = k"
24.188 + "match_ONE\<cdot>\<bottom>\<cdot>k = \<bottom>"
24.189 +by (simp_all add: match_ONE_def)
24.190 +
24.191 +lemma match_TT_simps [simp]:
24.192 + "match_TT\<cdot>TT\<cdot>k = k"
24.193 + "match_TT\<cdot>FF\<cdot>k = fail"
24.194 + "match_TT\<cdot>\<bottom>\<cdot>k = \<bottom>"
24.195 +by (simp_all add: match_TT_def)
24.196 +
24.197 +lemma match_FF_simps [simp]:
24.198 + "match_FF\<cdot>FF\<cdot>k = k"
24.199 + "match_FF\<cdot>TT\<cdot>k = fail"
24.200 + "match_FF\<cdot>\<bottom>\<cdot>k = \<bottom>"
24.201 +by (simp_all add: match_FF_def)
24.202 +
24.203 +subsection {* Mutual recursion *}
24.204 +
24.205 +text {*
24.206 + The following rules are used to prove unfolding theorems from
24.207 + fixed-point definitions of mutually recursive functions.
24.208 +*}
24.209 +
24.210 +lemma Pair_equalI: "\<lbrakk>x \<equiv> fst p; y \<equiv> snd p\<rbrakk> \<Longrightarrow> (x, y) \<equiv> p"
24.211 +by simp
24.212 +
24.213 +lemma Pair_eqD1: "(x, y) = (x', y') \<Longrightarrow> x = x'"
24.214 +by simp
24.215 +
24.216 +lemma Pair_eqD2: "(x, y) = (x', y') \<Longrightarrow> y = y'"
24.217 +by simp
24.218 +
24.219 +lemma def_cont_fix_eq:
24.220 + "\<lbrakk>f \<equiv> fix\<cdot>(Abs_cfun F); cont F\<rbrakk> \<Longrightarrow> f = F f"
24.221 +by (simp, subst fix_eq, simp)
24.222 +
24.223 +lemma def_cont_fix_ind:
24.224 + "\<lbrakk>f \<equiv> fix\<cdot>(Abs_cfun F); cont F; adm P; P \<bottom>; \<And>x. P x \<Longrightarrow> P (F x)\<rbrakk> \<Longrightarrow> P f"
24.225 +by (simp add: fix_ind)
24.226 +
24.227 +text {* lemma for proving rewrite rules *}
24.228 +
24.229 +lemma ssubst_lhs: "\<lbrakk>t = s; P s = Q\<rbrakk> \<Longrightarrow> P t = Q"
24.230 +by simp
24.231 +
24.232 +
24.233 +subsection {* Initializing the fixrec package *}
24.234 +
24.235 +use "Tools/holcf_library.ML"
24.236 +use "Tools/fixrec.ML"
24.237 +
24.238 +setup {* Fixrec.setup *}
24.239 +
24.240 +setup {*
24.241 + Fixrec.add_matchers
24.242 + [ (@{const_name up}, @{const_name match_up}),
24.243 + (@{const_name sinl}, @{const_name match_sinl}),
24.244 + (@{const_name sinr}, @{const_name match_sinr}),
24.245 + (@{const_name spair}, @{const_name match_spair}),
24.246 + (@{const_name Pair}, @{const_name match_Pair}),
24.247 + (@{const_name ONE}, @{const_name match_ONE}),
24.248 + (@{const_name TT}, @{const_name match_TT}),
24.249 + (@{const_name FF}, @{const_name match_FF}),
24.250 + (@{const_name UU}, @{const_name match_bottom}) ]
24.251 +*}
24.252 +
24.253 +hide_const (open) succeed fail run
24.254 +
24.255 +end
25.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
25.2 +++ b/src/HOL/HOLCF/Fun_Cpo.thy Sat Nov 27 16:08:10 2010 -0800
25.3 @@ -0,0 +1,179 @@
25.4 +(* Title: HOLCF/Fun_Cpo.thy
25.5 + Author: Franz Regensburger
25.6 + Author: Brian Huffman
25.7 +*)
25.8 +
25.9 +header {* Class instances for the full function space *}
25.10 +
25.11 +theory Fun_Cpo
25.12 +imports Adm
25.13 +begin
25.14 +
25.15 +subsection {* Full function space is a partial order *}
25.16 +
25.17 +instantiation "fun" :: (type, below) below
25.18 +begin
25.19 +
25.20 +definition
25.21 + below_fun_def: "(op \<sqsubseteq>) \<equiv> (\<lambda>f g. \<forall>x. f x \<sqsubseteq> g x)"
25.22 +
25.23 +instance ..
25.24 +end
25.25 +
25.26 +instance "fun" :: (type, po) po
25.27 +proof
25.28 + fix f :: "'a \<Rightarrow> 'b"
25.29 + show "f \<sqsubseteq> f"
25.30 + by (simp add: below_fun_def)
25.31 +next
25.32 + fix f g :: "'a \<Rightarrow> 'b"
25.33 + assume "f \<sqsubseteq> g" and "g \<sqsubseteq> f" thus "f = g"
25.34 + by (simp add: below_fun_def fun_eq_iff below_antisym)
25.35 +next
25.36 + fix f g h :: "'a \<Rightarrow> 'b"
25.37 + assume "f \<sqsubseteq> g" and "g \<sqsubseteq> h" thus "f \<sqsubseteq> h"
25.38 + unfolding below_fun_def by (fast elim: below_trans)
25.39 +qed
25.40 +
25.41 +lemma fun_below_iff: "f \<sqsubseteq> g \<longleftrightarrow> (\<forall>x. f x \<sqsubseteq> g x)"
25.42 +by (simp add: below_fun_def)
25.43 +
25.44 +lemma fun_belowI: "(\<And>x. f x \<sqsubseteq> g x) \<Longrightarrow> f \<sqsubseteq> g"
25.45 +by (simp add: below_fun_def)
25.46 +
25.47 +lemma fun_belowD: "f \<sqsubseteq> g \<Longrightarrow> f x \<sqsubseteq> g x"
25.48 +by (simp add: below_fun_def)
25.49 +
25.50 +subsection {* Full function space is chain complete *}
25.51 +
25.52 +text {* Properties of chains of functions. *}
25.53 +
25.54 +lemma fun_chain_iff: "chain S \<longleftrightarrow> (\<forall>x. chain (\<lambda>i. S i x))"
25.55 +unfolding chain_def fun_below_iff by auto
25.56 +
25.57 +lemma ch2ch_fun: "chain S \<Longrightarrow> chain (\<lambda>i. S i x)"
25.58 +by (simp add: chain_def below_fun_def)
25.59 +
25.60 +lemma ch2ch_lambda: "(\<And>x. chain (\<lambda>i. S i x)) \<Longrightarrow> chain S"
25.61 +by (simp add: chain_def below_fun_def)
25.62 +
25.63 +text {* upper bounds of function chains yield upper bound in the po range *}
25.64 +
25.65 +lemma ub2ub_fun:
25.66 + "range S <| u \<Longrightarrow> range (\<lambda>i. S i x) <| u x"
25.67 +by (auto simp add: is_ub_def below_fun_def)
25.68 +
25.69 +text {* Type @{typ "'a::type => 'b::cpo"} is chain complete *}
25.70 +
25.71 +lemma is_lub_lambda:
25.72 + "(\<And>x. range (\<lambda>i. Y i x) <<| f x) \<Longrightarrow> range Y <<| f"
25.73 +unfolding is_lub_def is_ub_def below_fun_def by simp
25.74 +
25.75 +lemma lub_fun:
25.76 + "chain (S::nat \<Rightarrow> 'a::type \<Rightarrow> 'b::cpo)
25.77 + \<Longrightarrow> range S <<| (\<lambda>x. \<Squnion>i. S i x)"
25.78 +apply (rule is_lub_lambda)
25.79 +apply (rule cpo_lubI)
25.80 +apply (erule ch2ch_fun)
25.81 +done
25.82 +
25.83 +lemma thelub_fun:
25.84 + "chain (S::nat \<Rightarrow> 'a::type \<Rightarrow> 'b::cpo)
25.85 + \<Longrightarrow> (\<Squnion>i. S i) = (\<lambda>x. \<Squnion>i. S i x)"
25.86 +by (rule lub_fun [THEN lub_eqI])
25.87 +
25.88 +instance "fun" :: (type, cpo) cpo
25.89 +by intro_classes (rule exI, erule lub_fun)
25.90 +
25.91 +subsection {* Chain-finiteness of function space *}
25.92 +
25.93 +lemma maxinch2maxinch_lambda:
25.94 + "(\<And>x. max_in_chain n (\<lambda>i. S i x)) \<Longrightarrow> max_in_chain n S"
25.95 +unfolding max_in_chain_def fun_eq_iff by simp
25.96 +
25.97 +lemma maxinch_mono:
25.98 + "\<lbrakk>max_in_chain i Y; i \<le> j\<rbrakk> \<Longrightarrow> max_in_chain j Y"
25.99 +unfolding max_in_chain_def
25.100 +proof (intro allI impI)
25.101 + fix k
25.102 + assume Y: "\<forall>n\<ge>i. Y i = Y n"
25.103 + assume ij: "i \<le> j"
25.104 + assume jk: "j \<le> k"
25.105 + from ij jk have ik: "i \<le> k" by simp
25.106 + from Y ij have Yij: "Y i = Y j" by simp
25.107 + from Y ik have Yik: "Y i = Y k" by simp
25.108 + from Yij Yik show "Y j = Y k" by auto
25.109 +qed
25.110 +
25.111 +instance "fun" :: (type, discrete_cpo) discrete_cpo
25.112 +proof
25.113 + fix f g :: "'a \<Rightarrow> 'b"
25.114 + show "f \<sqsubseteq> g \<longleftrightarrow> f = g"
25.115 + unfolding fun_below_iff fun_eq_iff
25.116 + by simp
25.117 +qed
25.118 +
25.119 +subsection {* Full function space is pointed *}
25.120 +
25.121 +lemma minimal_fun: "(\<lambda>x. \<bottom>) \<sqsubseteq> f"
25.122 +by (simp add: below_fun_def)
25.123 +
25.124 +instance "fun" :: (type, pcpo) pcpo
25.125 +by default (fast intro: minimal_fun)
25.126 +
25.127 +lemma inst_fun_pcpo: "\<bottom> = (\<lambda>x. \<bottom>)"
25.128 +by (rule minimal_fun [THEN UU_I, symmetric])
25.129 +
25.130 +lemma app_strict [simp]: "\<bottom> x = \<bottom>"
25.131 +by (simp add: inst_fun_pcpo)
25.132 +
25.133 +lemma lambda_strict: "(\<lambda>x. \<bottom>) = \<bottom>"
25.134 +by (rule UU_I, rule minimal_fun)
25.135 +
25.136 +subsection {* Propagation of monotonicity and continuity *}
25.137 +
25.138 +text {* The lub of a chain of monotone functions is monotone. *}
25.139 +
25.140 +lemma adm_monofun: "adm monofun"
25.141 +by (rule admI, simp add: thelub_fun fun_chain_iff monofun_def lub_mono)
25.142 +
25.143 +text {* The lub of a chain of continuous functions is continuous. *}
25.144 +
25.145 +lemma adm_cont: "adm cont"
25.146 +by (rule admI, simp add: thelub_fun fun_chain_iff)
25.147 +
25.148 +text {* Function application preserves monotonicity and continuity. *}
25.149 +
25.150 +lemma mono2mono_fun: "monofun f \<Longrightarrow> monofun (\<lambda>x. f x y)"
25.151 +by (simp add: monofun_def fun_below_iff)
25.152 +
25.153 +lemma cont2cont_fun: "cont f \<Longrightarrow> cont (\<lambda>x. f x y)"
25.154 +apply (rule contI2)
25.155 +apply (erule cont2mono [THEN mono2mono_fun])
25.156 +apply (simp add: cont2contlubE thelub_fun ch2ch_cont)
25.157 +done
25.158 +
25.159 +lemma cont_fun: "cont (\<lambda>f. f x)"
25.160 +using cont_id by (rule cont2cont_fun)
25.161 +
25.162 +text {*
25.163 + Lambda abstraction preserves monotonicity and continuity.
25.164 + (Note @{text "(\<lambda>x. \<lambda>y. f x y) = f"}.)
25.165 +*}
25.166 +
25.167 +lemma mono2mono_lambda:
25.168 + assumes f: "\<And>y. monofun (\<lambda>x. f x y)" shows "monofun f"
25.169 +using f by (simp add: monofun_def fun_below_iff)
25.170 +
25.171 +lemma cont2cont_lambda [simp]:
25.172 + assumes f: "\<And>y. cont (\<lambda>x. f x y)" shows "cont f"
25.173 +by (rule contI, rule is_lub_lambda, rule contE [OF f])
25.174 +
25.175 +text {* What D.A.Schmidt calls continuity of abstraction; never used here *}
25.176 +
25.177 +lemma contlub_lambda:
25.178 + "(\<And>x::'a::type. chain (\<lambda>i. S i x::'b::cpo))
25.179 + \<Longrightarrow> (\<lambda>x. \<Squnion>i. S i x) = (\<Squnion>i. (\<lambda>x. S i x))"
25.180 +by (simp add: thelub_fun ch2ch_lambda)
25.181 +
25.182 +end
26.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
26.2 +++ b/src/HOL/HOLCF/HOLCF.thy Sat Nov 27 16:08:10 2010 -0800
26.3 @@ -0,0 +1,39 @@
26.4 +(* Title: HOLCF/HOLCF.thy
26.5 + Author: Franz Regensburger
26.6 +
26.7 +HOLCF -- a semantic extension of HOL by the LCF logic.
26.8 +*)
26.9 +
26.10 +theory HOLCF
26.11 +imports
26.12 + Main
26.13 + Domain
26.14 + Powerdomains
26.15 +begin
26.16 +
26.17 +default_sort "domain"
26.18 +
26.19 +ML {* path_add "~~/src/HOL/HOLCF/Library" *}
26.20 +
26.21 +text {* Legacy theorem names deprecated after Isabelle2009-2: *}
26.22 +
26.23 +lemmas expand_fun_below = fun_below_iff
26.24 +lemmas below_fun_ext = fun_belowI
26.25 +lemmas expand_cfun_eq = cfun_eq_iff
26.26 +lemmas ext_cfun = cfun_eqI
26.27 +lemmas expand_cfun_below = cfun_below_iff
26.28 +lemmas below_cfun_ext = cfun_belowI
26.29 +lemmas monofun_fun_fun = fun_belowD
26.30 +lemmas monofun_fun_arg = monofunE
26.31 +lemmas monofun_lub_fun = adm_monofun [THEN admD]
26.32 +lemmas cont_lub_fun = adm_cont [THEN admD]
26.33 +lemmas cont2cont_Rep_CFun = cont2cont_APP
26.34 +lemmas cont_Rep_CFun_app = cont_APP_app
26.35 +lemmas cont_Rep_CFun_app_app = cont_APP_app_app
26.36 +lemmas cont_cfun_fun = cont_Rep_cfun1 [THEN contE]
26.37 +lemmas cont_cfun_arg = cont_Rep_cfun2 [THEN contE]
26.38 +(*
26.39 +lemmas thelubI = lub_eqI
26.40 +*)
26.41 +
26.42 +end
27.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
27.2 +++ b/src/HOL/HOLCF/IMP/Denotational.thy Sat Nov 27 16:08:10 2010 -0800
27.3 @@ -0,0 +1,78 @@
27.4 +(* Title: HOLCF/IMP/Denotational.thy
27.5 + Author: Tobias Nipkow and Robert Sandner, TUM
27.6 + Copyright 1996 TUM
27.7 +*)
27.8 +
27.9 +header "Denotational Semantics of Commands in HOLCF"
27.10 +
27.11 +theory Denotational imports HOLCF "~~/src/HOL/IMP/Natural" begin
27.12 +
27.13 +text {* Disable conflicting syntax from HOL Map theory. *}
27.14 +
27.15 +no_syntax
27.16 + "_maplet" :: "['a, 'a] => maplet" ("_ /|->/ _")
27.17 + "_maplets" :: "['a, 'a] => maplet" ("_ /[|->]/ _")
27.18 + "" :: "maplet => maplets" ("_")
27.19 + "_Maplets" :: "[maplet, maplets] => maplets" ("_,/ _")
27.20 + "_MapUpd" :: "['a ~=> 'b, maplets] => 'a ~=> 'b" ("_/'(_')" [900,0]900)
27.21 + "_Map" :: "maplets => 'a ~=> 'b" ("(1[_])")
27.22 +
27.23 +subsection "Definition"
27.24 +
27.25 +definition
27.26 + dlift :: "(('a::type) discr -> 'b::pcpo) => ('a lift -> 'b)" where
27.27 + "dlift f = (LAM x. case x of UU => UU | Def y => f\<cdot>(Discr y))"
27.28 +
27.29 +primrec D :: "com => state discr -> state lift"
27.30 +where
27.31 + "D(\<SKIP>) = (LAM s. Def(undiscr s))"
27.32 +| "D(X :== a) = (LAM s. Def((undiscr s)[X \<mapsto> a(undiscr s)]))"
27.33 +| "D(c0 ; c1) = (dlift(D c1) oo (D c0))"
27.34 +| "D(\<IF> b \<THEN> c1 \<ELSE> c2) =
27.35 + (LAM s. if b (undiscr s) then (D c1)\<cdot>s else (D c2)\<cdot>s)"
27.36 +| "D(\<WHILE> b \<DO> c) =
27.37 + fix\<cdot>(LAM w s. if b (undiscr s) then (dlift w)\<cdot>((D c)\<cdot>s)
27.38 + else Def(undiscr s))"
27.39 +
27.40 +subsection
27.41 + "Equivalence of Denotational Semantics in HOLCF and Evaluation Semantics in HOL"
27.42 +
27.43 +lemma dlift_Def [simp]: "dlift f\<cdot>(Def x) = f\<cdot>(Discr x)"
27.44 + by (simp add: dlift_def)
27.45 +
27.46 +lemma cont_dlift [iff]: "cont (%f. dlift f)"
27.47 + by (simp add: dlift_def)
27.48 +
27.49 +lemma dlift_is_Def [simp]:
27.50 + "(dlift f\<cdot>l = Def y) = (\<exists>x. l = Def x \<and> f\<cdot>(Discr x) = Def y)"
27.51 + by (simp add: dlift_def split: lift.split)
27.52 +
27.53 +lemma eval_implies_D: "\<langle>c,s\<rangle> \<longrightarrow>\<^sub>c t ==> D c\<cdot>(Discr s) = (Def t)"
27.54 + apply (induct set: evalc)
27.55 + apply simp_all
27.56 + apply (subst fix_eq)
27.57 + apply simp
27.58 + apply (subst fix_eq)
27.59 + apply simp
27.60 + done
27.61 +
27.62 +lemma D_implies_eval: "!s t. D c\<cdot>(Discr s) = (Def t) --> \<langle>c,s\<rangle> \<longrightarrow>\<^sub>c t"
27.63 + apply (induct c)
27.64 + apply simp
27.65 + apply simp
27.66 + apply force
27.67 + apply (simp (no_asm))
27.68 + apply force
27.69 + apply (simp (no_asm))
27.70 + apply (rule fix_ind)
27.71 + apply (fast intro!: adm_lemmas adm_chfindom ax_flat)
27.72 + apply (simp (no_asm))
27.73 + apply (simp (no_asm))
27.74 + apply safe
27.75 + apply fast
27.76 + done
27.77 +
27.78 +theorem D_is_eval: "(D c\<cdot>(Discr s) = (Def t)) = (\<langle>c,s\<rangle> \<longrightarrow>\<^sub>c t)"
27.79 + by (fast elim!: D_implies_eval [rule_format] eval_implies_D)
27.80 +
27.81 +end
28.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
28.2 +++ b/src/HOL/HOLCF/IMP/HoareEx.thy Sat Nov 27 16:08:10 2010 -0800
28.3 @@ -0,0 +1,33 @@
28.4 +(* Title: HOLCF/IMP/HoareEx.thy
28.5 + Author: Tobias Nipkow, TUM
28.6 + Copyright 1997 TUM
28.7 +*)
28.8 +
28.9 +header "Correctness of Hoare by Fixpoint Reasoning"
28.10 +
28.11 +theory HoareEx imports Denotational begin
28.12 +
28.13 +text {*
28.14 + An example from the HOLCF paper by Müller, Nipkow, Oheimb, Slotosch
28.15 + \cite{MuellerNvOS99}. It demonstrates fixpoint reasoning by showing
28.16 + the correctness of the Hoare rule for while-loops.
28.17 +*}
28.18 +
28.19 +types assn = "state => bool"
28.20 +
28.21 +definition
28.22 + hoare_valid :: "[assn, com, assn] => bool" ("|= {(1_)}/ (_)/ {(1_)}" 50) where
28.23 + "|= {A} c {B} = (\<forall>s t. A s \<and> D c $(Discr s) = Def t --> B t)"
28.24 +
28.25 +lemma WHILE_rule_sound:
28.26 + "|= {A} c {A} ==> |= {A} \<WHILE> b \<DO> c {\<lambda>s. A s \<and> \<not> b s}"
28.27 + apply (unfold hoare_valid_def)
28.28 + apply (simp (no_asm))
28.29 + apply (rule fix_ind)
28.30 + apply (simp (no_asm)) -- "simplifier with enhanced @{text adm}-tactic"
28.31 + apply (simp (no_asm))
28.32 + apply (simp (no_asm))
28.33 + apply blast
28.34 + done
28.35 +
28.36 +end
29.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
29.2 +++ b/src/HOL/HOLCF/IMP/README.html Sat Nov 27 16:08:10 2010 -0800
29.3 @@ -0,0 +1,18 @@
29.4 +<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN" "http://www.w3.org/TR/html4/loose.dtd">
29.5 +
29.6 +<HTML>
29.7 +
29.8 +<HEAD>
29.9 + <meta http-equiv="Content-Type" content="text/html; charset=iso-8859-1">
29.10 + <TITLE>HOLCF/IMP/README</TITLE>
29.11 +</HEAD>
29.12 +
29.13 +<BODY>
29.14 +
29.15 +<H2>IMP -- A <KBD>WHILE</KBD>-language and its Semantics</H2>
29.16 +
29.17 +This is the HOLCF-based denotational semantics of a simple
29.18 +<tt>WHILE</tt>-language. For a full description see <A
29.19 +HREF="../../HOL/IMP/index.html">HOL/IMP</A>.
29.20 +</BODY>
29.21 +</HTML>
30.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
30.2 +++ b/src/HOL/HOLCF/IMP/ROOT.ML Sat Nov 27 16:08:10 2010 -0800
30.3 @@ -0,0 +1,1 @@
30.4 +use_thys ["HoareEx"];
31.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
31.2 +++ b/src/HOL/HOLCF/IMP/document/root.bib Sat Nov 27 16:08:10 2010 -0800
31.3 @@ -0,0 +1,7 @@
31.4 +@string{JFP="J. Functional Programming"}
31.5 +
31.6 +@article{MuellerNvOS99,
31.7 +author=
31.8 +{Olaf M{\"u}ller and Tobias Nipkow and Oheimb, David von and Oskar Slotosch},
31.9 +title={{HOLCF = HOL + LCF}},journal=JFP,year=1999,volume=9,pages={191--223}}
31.10 +
32.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
32.2 +++ b/src/HOL/HOLCF/IMP/document/root.tex Sat Nov 27 16:08:10 2010 -0800
32.3 @@ -0,0 +1,36 @@
32.4 +
32.5 +\documentclass[11pt,a4paper]{article}
32.6 +\usepackage[latin1]{inputenc}
32.7 +\usepackage{isabelle,isabellesym}
32.8 +\usepackage{pdfsetup}
32.9 +
32.10 +\urlstyle{rm}
32.11 +
32.12 +% pretty printing for the Com language
32.13 +%\newcommand{\CMD}[1]{\isatext{\bf\sffamily#1}}
32.14 +\newcommand{\CMD}[1]{\isatext{\rm\sffamily#1}}
32.15 +\newcommand{\isasymSKIP}{\CMD{skip}}
32.16 +\newcommand{\isasymIF}{\CMD{if}}
32.17 +\newcommand{\isasymTHEN}{\CMD{then}}
32.18 +\newcommand{\isasymELSE}{\CMD{else}}
32.19 +\newcommand{\isasymWHILE}{\CMD{while}}
32.20 +\newcommand{\isasymDO}{\CMD{do}}
32.21 +
32.22 +\addtolength{\hoffset}{-1cm}
32.23 +\addtolength{\textwidth}{2cm}
32.24 +
32.25 +\begin{document}
32.26 +
32.27 +\title{IMP in HOLCF}
32.28 +\author{Tobias Nipkow and Robert Sandner}
32.29 +\maketitle
32.30 +
32.31 +\tableofcontents
32.32 +
32.33 +\parindent 0pt\parskip 0.5ex
32.34 +\input{session}
32.35 +
32.36 +\bibliographystyle{abbrv}
32.37 +\bibliography{root}
32.38 +
32.39 +\end{document}
33.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
33.2 +++ b/src/HOL/HOLCF/IOA/ABP/Abschannel.thy Sat Nov 27 16:08:10 2010 -0800
33.3 @@ -0,0 +1,89 @@
33.4 +(* Title: HOLCF/IOA/ABP/Abschannel.thy
33.5 + Author: Olaf Müller
33.6 +*)
33.7 +
33.8 +header {* The transmission channel *}
33.9 +
33.10 +theory Abschannel
33.11 +imports IOA Action Lemmas
33.12 +begin
33.13 +
33.14 +datatype 'a abs_action = S 'a | R 'a
33.15 +
33.16 +
33.17 +(**********************************************************
33.18 + G e n e r i c C h a n n e l
33.19 + *********************************************************)
33.20 +
33.21 +definition
33.22 + ch_asig :: "'a abs_action signature" where
33.23 + "ch_asig = (UN b. {S(b)}, UN b. {R(b)}, {})"
33.24 +
33.25 +definition
33.26 + ch_trans :: "('a abs_action, 'a list)transition set" where
33.27 + "ch_trans =
33.28 + {tr. let s = fst(tr);
33.29 + t = snd(snd(tr))
33.30 + in
33.31 + case fst(snd(tr))
33.32 + of S(b) => ((t = s) | (t = s @ [b])) |
33.33 + R(b) => s ~= [] &
33.34 + b = hd(s) &
33.35 + ((t = s) | (t = tl(s)))}"
33.36 +
33.37 +definition
33.38 + ch_ioa :: "('a abs_action, 'a list)ioa" where
33.39 + "ch_ioa = (ch_asig, {[]}, ch_trans,{},{})"
33.40 +
33.41 +
33.42 +(**********************************************************
33.43 + C o n c r e t e C h a n n e l s b y R e n a m i n g
33.44 + *********************************************************)
33.45 +
33.46 +definition
33.47 + rsch_actions :: "'m action => bool abs_action option" where
33.48 + "rsch_actions (akt) =
33.49 + (case akt of
33.50 + Next => None |
33.51 + S_msg(m) => None |
33.52 + R_msg(m) => None |
33.53 + S_pkt(packet) => None |
33.54 + R_pkt(packet) => None |
33.55 + S_ack(b) => Some(S(b)) |
33.56 + R_ack(b) => Some(R(b)))"
33.57 +
33.58 +definition
33.59 + srch_actions :: "'m action =>(bool * 'm) abs_action option" where
33.60 + "srch_actions akt =
33.61 + (case akt of
33.62 + Next => None |
33.63 + S_msg(m) => None |
33.64 + R_msg(m) => None |
33.65 + S_pkt(p) => Some(S(p)) |
33.66 + R_pkt(p) => Some(R(p)) |
33.67 + S_ack(b) => None |
33.68 + R_ack(b) => None)"
33.69 +
33.70 +definition
33.71 + srch_ioa :: "('m action, 'm packet list)ioa" where
33.72 + "srch_ioa = rename ch_ioa srch_actions"
33.73 +definition
33.74 + rsch_ioa :: "('m action, bool list)ioa" where
33.75 + "rsch_ioa = rename ch_ioa rsch_actions"
33.76 +
33.77 +definition
33.78 + srch_asig :: "'m action signature" where
33.79 + "srch_asig = asig_of(srch_ioa)"
33.80 +
33.81 +definition
33.82 + rsch_asig :: "'m action signature" where
33.83 + "rsch_asig = asig_of(rsch_ioa)"
33.84 +
33.85 +definition
33.86 + srch_trans :: "('m action, 'm packet list)transition set" where
33.87 + "srch_trans = trans_of(srch_ioa)"
33.88 +definition
33.89 + rsch_trans :: "('m action, bool list)transition set" where
33.90 + "rsch_trans = trans_of(rsch_ioa)"
33.91 +
33.92 +end
34.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
34.2 +++ b/src/HOL/HOLCF/IOA/ABP/Abschannel_finite.thy Sat Nov 27 16:08:10 2010 -0800
34.3 @@ -0,0 +1,61 @@
34.4 +(* Title: HOLCF/IOA/ABP/Abschannels.thy
34.5 + Author: Olaf Müller
34.6 +*)
34.7 +
34.8 +header {* The transmission channel -- finite version *}
34.9 +
34.10 +theory Abschannel_finite
34.11 +imports Abschannel IOA Action Lemmas
34.12 +begin
34.13 +
34.14 +primrec reverse :: "'a list => 'a list"
34.15 +where
34.16 + reverse_Nil: "reverse([]) = []"
34.17 +| reverse_Cons: "reverse(x#xs) = reverse(xs)@[x]"
34.18 +
34.19 +definition
34.20 + ch_fin_asig :: "'a abs_action signature" where
34.21 + "ch_fin_asig = ch_asig"
34.22 +
34.23 +definition
34.24 + ch_fin_trans :: "('a abs_action, 'a list)transition set" where
34.25 + "ch_fin_trans =
34.26 + {tr. let s = fst(tr);
34.27 + t = snd(snd(tr))
34.28 + in
34.29 + case fst(snd(tr))
34.30 + of S(b) => ((t = s) |
34.31 + (if (b=hd(reverse(s)) & s~=[]) then t=s else t=s@[b])) |
34.32 + R(b) => s ~= [] &
34.33 + b = hd(s) &
34.34 + ((t = s) | (t = tl(s)))}"
34.35 +
34.36 +definition
34.37 + ch_fin_ioa :: "('a abs_action, 'a list)ioa" where
34.38 + "ch_fin_ioa = (ch_fin_asig, {[]}, ch_fin_trans,{},{})"
34.39 +
34.40 +definition
34.41 + srch_fin_ioa :: "('m action, 'm packet list)ioa" where
34.42 + "srch_fin_ioa = rename ch_fin_ioa srch_actions"
34.43 +
34.44 +definition
34.45 + rsch_fin_ioa :: "('m action, bool list)ioa" where
34.46 + "rsch_fin_ioa = rename ch_fin_ioa rsch_actions"
34.47 +
34.48 +definition
34.49 + srch_fin_asig :: "'m action signature" where
34.50 + "srch_fin_asig = asig_of(srch_fin_ioa)"
34.51 +
34.52 +definition
34.53 + rsch_fin_asig :: "'m action signature" where
34.54 + "rsch_fin_asig = asig_of(rsch_fin_ioa)"
34.55 +
34.56 +definition
34.57 + srch_fin_trans :: "('m action, 'm packet list)transition set" where
34.58 + "srch_fin_trans = trans_of(srch_fin_ioa)"
34.59 +
34.60 +definition
34.61 + rsch_fin_trans :: "('m action, bool list)transition set" where
34.62 + "rsch_fin_trans = trans_of(rsch_fin_ioa)"
34.63 +
34.64 +end
35.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
35.2 +++ b/src/HOL/HOLCF/IOA/ABP/Action.thy Sat Nov 27 16:08:10 2010 -0800
35.3 @@ -0,0 +1,16 @@
35.4 +(* Title: HOLCF/IOA/ABP/Action.thy
35.5 + Author: Olaf Müller
35.6 +*)
35.7 +
35.8 +header {* The set of all actions of the system *}
35.9 +
35.10 +theory Action
35.11 +imports Packet
35.12 +begin
35.13 +
35.14 +datatype 'm action =
35.15 + Next | S_msg 'm | R_msg 'm
35.16 + | S_pkt "'m packet" | R_pkt "'m packet"
35.17 + | S_ack bool | R_ack bool
35.18 +
35.19 +end
36.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
36.2 +++ b/src/HOL/HOLCF/IOA/ABP/Check.ML Sat Nov 27 16:08:10 2010 -0800
36.3 @@ -0,0 +1,178 @@
36.4 +(* Title: HOLCF/IOA/ABP/Check.ML
36.5 + Author: Olaf Mueller
36.6 +
36.7 +The Model Checker.
36.8 +*)
36.9 +
36.10 +structure Check =
36.11 +struct
36.12 +
36.13 +(* ----------------------------------------------------------------
36.14 + P r o t o t y p e M o d e l C h e c k e r
36.15 + ----------------------------------------------------------------*)
36.16 +
36.17 +fun check(extacts,intacts,string_of_a,startsI,string_of_s,
36.18 + nexts,hom,transA,startsS) =
36.19 + let fun check_s(s,unchecked,checked) =
36.20 + let fun check_sa a unchecked =
36.21 + let fun check_sas t unchecked =
36.22 + (if member (op =) extacts a then
36.23 + (if transA(hom s,a,hom t) then ( )
36.24 + else (writeln("Error: Mapping of Externals!");
36.25 + string_of_s s; writeln"";
36.26 + string_of_a a; writeln"";
36.27 + string_of_s t;writeln"";writeln"" ))
36.28 + else (if hom(s)=hom(t) then ( )
36.29 + else (writeln("Error: Mapping of Internals!");
36.30 + string_of_s s; writeln"";
36.31 + string_of_a a; writeln"";
36.32 + string_of_s t;writeln"";writeln"" ));
36.33 + if member (op =) checked t then unchecked else insert (op =) t unchecked)
36.34 + in fold check_sas (nexts s a) unchecked end;
36.35 + val unchecked' = fold check_sa (extacts @ intacts) unchecked
36.36 + in (if member (op =) startsI s then
36.37 + (if member (op =) startsS (hom s) then ()
36.38 + else writeln("Error: At start states!"))
36.39 + else ();
36.40 + checks(unchecked',s::checked)) end
36.41 + and checks([],_) = ()
36.42 + | checks(s::unchecked,checked) = check_s(s,unchecked,checked)
36.43 + in checks(startsI,[]) end;
36.44 +
36.45 +
36.46 +(* ------------------------------------------------------
36.47 + A B P E x a m p l e
36.48 + -------------------------------------------------------*)
36.49 +
36.50 +datatype msg = m | n | l;
36.51 +datatype act = Next | S_msg of msg | R_msg of msg
36.52 + | S_pkt of bool * msg | R_pkt of bool * msg
36.53 + | S_ack of bool | R_ack of bool;
36.54 +
36.55 +(* -------------------- Transition relation of Specification -----------*)
36.56 +
36.57 +fun transA((u,s),a,(v,t)) =
36.58 + (case a of
36.59 + Next => v andalso t = s |
36.60 + S_msg(q) => u andalso not(v) andalso t = s@[q] |
36.61 + R_msg(q) => u = v andalso s = (q::t) |
36.62 + S_pkt(b,q) => false |
36.63 + R_pkt(b,q) => false |
36.64 + S_ack(b) => false |
36.65 + R_ack(b) => false);
36.66 +
36.67 +
36.68 +(* ---------------------- Abstraction function --------------------------*)
36.69 +
36.70 +fun hom((env,p,a,q,b,_,_)) = (env,q@(if (a=b) then tl(p) else p));
36.71 +
36.72 +
36.73 +(* --------------------- Transition relation of Implementation ----------*)
36.74 +
36.75 +fun nexts (s as (env,p,a,q,b,ch1,ch2)) action =
36.76 + (case action of
36.77 + Next => if p=[] then [(true,p,a,q,b,ch1,ch2)] else [] |
36.78 + S_msg(mornorl) => if env then [(false,p@[mornorl],a,q,b,ch1,ch2)] else [] |
36.79 + R_msg(mornorl) => if (q<>[] andalso mornorl=hd(q))
36.80 + then [(env,p,a,tl(q),b,ch1,ch2)]
36.81 + else [] |
36.82 + S_pkt(h,mornorl) => if (p<>[] andalso mornorl=hd(p) andalso h=a)
36.83 + then (if (ch1<>[] andalso hd(rev(ch1))=(h,mornorl))
36.84 + then [s]
36.85 + else [s,(env,p,a,q,b,ch1@[(h,mornorl)],ch2)])
36.86 + else [] |
36.87 + R_pkt(h,mornorl) => if (ch1<>[] andalso hd(ch1)=(h,mornorl))
36.88 + then (if (h<>b andalso q=[])
36.89 + then [(env,p,a,q@[mornorl],not(b),ch1,ch2),
36.90 + (env,p,a,q@[mornorl],not(b),tl(ch1),ch2)]
36.91 + else [s,(env,p,a,q,b,tl(ch1),ch2)])
36.92 + else [] |
36.93 + S_ack(h) => if (h=b)
36.94 + then (if (ch2<>[] andalso h=hd(rev(ch2)))
36.95 + then [s]
36.96 + else [s,(env,p,a,q,b,ch1,ch2@[h])])
36.97 + else [] |
36.98 + R_ack(h) => if (ch2<>[] andalso hd(ch2)=h)
36.99 + then (if h=a
36.100 + then [(env,tl(p),not(a),q,b,ch1,ch2),
36.101 + (env,tl(p),not(a),q,b,ch1,tl(ch2))]
36.102 + else [s,(env,p,a,q,b,ch1,tl(ch2))])
36.103 + else [])
36.104 +
36.105 +
36.106 +val extactions = [Next,S_msg(m),R_msg(m),S_msg(n),R_msg(n),S_msg(l),R_msg(l)];
36.107 +val intactions = [S_pkt(true,m),R_pkt(true,m),S_ack(true),R_ack(true),
36.108 + S_pkt(false,m),R_pkt(false,m),S_ack(false),R_ack(false),
36.109 + S_pkt(true,n),R_pkt(true,n),S_pkt(true,l),R_pkt(true,l),
36.110 + S_pkt(false,n),R_pkt(false,n),S_pkt(false,l),R_pkt(false,l)];
36.111 +
36.112 +
36.113 +(* ------------------------------------
36.114 + Input / Output utilities
36.115 + ------------------------------------*)
36.116 +
36.117 +fun print_list (lpar, rpar, pre: 'a -> unit) (lll : 'a list) =
36.118 + let fun prec x = (Output.raw_stdout ","; pre x)
36.119 + in
36.120 + (case lll of
36.121 + [] => (Output.raw_stdout lpar; Output.raw_stdout rpar)
36.122 + | x::lll => (Output.raw_stdout lpar; pre x; List.app prec lll; Output.raw_stdout rpar))
36.123 + end;
36.124 +
36.125 +fun pr_bool true = Output.raw_stdout "true"
36.126 +| pr_bool false = Output.raw_stdout "false";
36.127 +
36.128 +fun pr_msg m = Output.raw_stdout "m"
36.129 +| pr_msg n = Output.raw_stdout "n"
36.130 +| pr_msg l = Output.raw_stdout "l";
36.131 +
36.132 +fun pr_act a = Output.raw_stdout (case a of
36.133 + Next => "Next"|
36.134 + S_msg(ma) => "S_msg(ma)" |
36.135 + R_msg(ma) => "R_msg(ma)" |
36.136 + S_pkt(b,ma) => "S_pkt(b,ma)" |
36.137 + R_pkt(b,ma) => "R_pkt(b,ma)" |
36.138 + S_ack(b) => "S_ack(b)" |
36.139 + R_ack(b) => "R_ack(b)");
36.140 +
36.141 +fun pr_pkt (b,ma) = (Output.raw_stdout "<"; pr_bool b;Output.raw_stdout ", "; pr_msg ma; Output.raw_stdout ">");
36.142 +
36.143 +val pr_bool_list = print_list("[","]",pr_bool);
36.144 +val pr_msg_list = print_list("[","]",pr_msg);
36.145 +val pr_pkt_list = print_list("[","]",pr_pkt);
36.146 +
36.147 +fun pr_tuple (env,p,a,q,b,ch1,ch2) =
36.148 + (Output.raw_stdout "{"; pr_bool env; Output.raw_stdout ", "; pr_msg_list p; Output.raw_stdout ", ";
36.149 + pr_bool a; Output.raw_stdout ", "; pr_msg_list q; Output.raw_stdout ", ";
36.150 + pr_bool b; Output.raw_stdout ", "; pr_pkt_list ch1; Output.raw_stdout ", ";
36.151 + pr_bool_list ch2; Output.raw_stdout "}");
36.152 +
36.153 +
36.154 +
36.155 +(* ---------------------------------
36.156 + Main function call
36.157 + ---------------------------------*)
36.158 +
36.159 +(*
36.160 +check(extactions,intactions,pr_act, [(true,[],true,[],false,[],[])],
36.161 + pr_tuple, nexts, hom, transA, [(true,[])]);
36.162 +*)
36.163 +
36.164 +
36.165 +
36.166 +
36.167 +
36.168 +(*
36.169 + Little test example
36.170 +
36.171 +datatype act = A;
36.172 +fun transA(s,a,t) = (not(s)=t);
36.173 +fun hom(i) = i mod 2 = 0;
36.174 +fun nexts s A = [(s+1) mod 4];
36.175 +check([A],[],K"A", [0], string_of_int, nexts, hom, transA, [true]);
36.176 +
36.177 +fun nexts s A = [(s+1) mod 5];
36.178 +
36.179 +*)
36.180 +
36.181 +end;
37.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
37.2 +++ b/src/HOL/HOLCF/IOA/ABP/Correctness.thy Sat Nov 27 16:08:10 2010 -0800
37.3 @@ -0,0 +1,326 @@
37.4 +(* Title: HOLCF/IOA/ABP/Correctness.thy
37.5 + Author: Olaf Müller
37.6 +*)
37.7 +
37.8 +header {* The main correctness proof: System_fin implements System *}
37.9 +
37.10 +theory Correctness
37.11 +imports IOA Env Impl Impl_finite
37.12 +uses "Check.ML"
37.13 +begin
37.14 +
37.15 +primrec reduce :: "'a list => 'a list"
37.16 +where
37.17 + reduce_Nil: "reduce [] = []"
37.18 +| reduce_Cons: "reduce(x#xs) =
37.19 + (case xs of
37.20 + [] => [x]
37.21 + | y#ys => (if (x=y)
37.22 + then reduce xs
37.23 + else (x#(reduce xs))))"
37.24 +
37.25 +definition
37.26 + abs where
37.27 + "abs =
37.28 + (%p.(fst(p),(fst(snd(p)),(fst(snd(snd(p))),
37.29 + (reduce(fst(snd(snd(snd(p))))),reduce(snd(snd(snd(snd(p))))))))))"
37.30 +
37.31 +definition
37.32 + system_ioa :: "('m action, bool * 'm impl_state)ioa" where
37.33 + "system_ioa = (env_ioa || impl_ioa)"
37.34 +
37.35 +definition
37.36 + system_fin_ioa :: "('m action, bool * 'm impl_state)ioa" where
37.37 + "system_fin_ioa = (env_ioa || impl_fin_ioa)"
37.38 +
37.39 +
37.40 +axiomatization where
37.41 + sys_IOA: "IOA system_ioa" and
37.42 + sys_fin_IOA: "IOA system_fin_ioa"
37.43 +
37.44 +
37.45 +
37.46 +declare split_paired_All [simp del] Collect_empty_eq [simp del]
37.47 +
37.48 +lemmas [simp] =
37.49 + srch_asig_def rsch_asig_def rsch_ioa_def srch_ioa_def ch_ioa_def
37.50 + ch_asig_def srch_actions_def rsch_actions_def rename_def rename_set_def asig_of_def
37.51 + actions_def exis_elim srch_trans_def rsch_trans_def ch_trans_def
37.52 + trans_of_def asig_projections set_lemmas
37.53 +
37.54 +lemmas abschannel_fin [simp] =
37.55 + srch_fin_asig_def rsch_fin_asig_def
37.56 + rsch_fin_ioa_def srch_fin_ioa_def
37.57 + ch_fin_ioa_def ch_fin_trans_def ch_fin_asig_def
37.58 +
37.59 +lemmas impl_ioas = sender_ioa_def receiver_ioa_def
37.60 + and impl_trans = sender_trans_def receiver_trans_def
37.61 + and impl_asigs = sender_asig_def receiver_asig_def
37.62 +
37.63 +declare let_weak_cong [cong]
37.64 +declare ioa_triple_proj [simp] starts_of_par [simp]
37.65 +
37.66 +lemmas env_ioas = env_ioa_def env_asig_def env_trans_def
37.67 +lemmas hom_ioas =
37.68 + env_ioas [simp] impl_ioas [simp] impl_trans [simp] impl_asigs [simp]
37.69 + asig_projections set_lemmas
37.70 +
37.71 +
37.72 +subsection {* lemmas about reduce *}
37.73 +
37.74 +lemma l_iff_red_nil: "(reduce l = []) = (l = [])"
37.75 + by (induct l) (auto split: list.split)
37.76 +
37.77 +lemma hd_is_reduce_hd: "s ~= [] --> hd s = hd (reduce s)"
37.78 + by (induct s) (auto split: list.split)
37.79 +
37.80 +text {* to be used in the following Lemma *}
37.81 +lemma rev_red_not_nil [rule_format]:
37.82 + "l ~= [] --> reverse (reduce l) ~= []"
37.83 + by (induct l) (auto split: list.split)
37.84 +
37.85 +text {* shows applicability of the induction hypothesis of the following Lemma 1 *}
37.86 +lemma last_ind_on_first:
37.87 + "l ~= [] ==> hd (reverse (reduce (a # l))) = hd (reverse (reduce l))"
37.88 + apply simp
37.89 + apply (tactic {* auto_tac (@{claset},
37.90 + HOL_ss addsplits [@{thm list.split}]
37.91 + addsimps (@{thms reverse.simps} @ [@{thm hd_append}, @{thm rev_red_not_nil}])) *})
37.92 + done
37.93 +
37.94 +text {* Main Lemma 1 for @{text "S_pkt"} in showing that reduce is refinement. *}
37.95 +lemma reduce_hd:
37.96 + "if x=hd(reverse(reduce(l))) & reduce(l)~=[] then
37.97 + reduce(l@[x])=reduce(l) else
37.98 + reduce(l@[x])=reduce(l)@[x]"
37.99 +apply (simplesubst split_if)
37.100 +apply (rule conjI)
37.101 +txt {* @{text "-->"} *}
37.102 +apply (induct_tac "l")
37.103 +apply (simp (no_asm))
37.104 +apply (case_tac "list=[]")
37.105 + apply simp
37.106 + apply (rule impI)
37.107 +apply (simp (no_asm))
37.108 +apply (cut_tac l = "list" in cons_not_nil)
37.109 + apply (simp del: reduce_Cons)
37.110 + apply (erule exE)+
37.111 + apply hypsubst
37.112 +apply (simp del: reduce_Cons add: last_ind_on_first l_iff_red_nil)
37.113 +txt {* @{text "<--"} *}
37.114 +apply (simp (no_asm) add: and_de_morgan_and_absorbe l_iff_red_nil)
37.115 +apply (induct_tac "l")
37.116 +apply (simp (no_asm))
37.117 +apply (case_tac "list=[]")
37.118 +apply (cut_tac [2] l = "list" in cons_not_nil)
37.119 +apply simp
37.120 +apply (auto simp del: reduce_Cons simp add: last_ind_on_first l_iff_red_nil split: split_if)
37.121 +apply simp
37.122 +done
37.123 +
37.124 +
37.125 +text {* Main Lemma 2 for R_pkt in showing that reduce is refinement. *}
37.126 +lemma reduce_tl: "s~=[] ==>
37.127 + if hd(s)=hd(tl(s)) & tl(s)~=[] then
37.128 + reduce(tl(s))=reduce(s) else
37.129 + reduce(tl(s))=tl(reduce(s))"
37.130 +apply (cut_tac l = "s" in cons_not_nil)
37.131 +apply simp
37.132 +apply (erule exE)+
37.133 +apply (auto split: list.split)
37.134 +done
37.135 +
37.136 +
37.137 +subsection {* Channel Abstraction *}
37.138 +
37.139 +declare split_if [split del]
37.140 +
37.141 +lemma channel_abstraction: "is_weak_ref_map reduce ch_ioa ch_fin_ioa"
37.142 +apply (simp (no_asm) add: is_weak_ref_map_def)
37.143 +txt {* main-part *}
37.144 +apply (rule allI)+
37.145 +apply (rule imp_conj_lemma)
37.146 +apply (induct_tac "a")
37.147 +txt {* 2 cases *}
37.148 +apply (simp_all (no_asm) cong del: if_weak_cong add: externals_def)
37.149 +txt {* fst case *}
37.150 + apply (rule impI)
37.151 + apply (rule disjI2)
37.152 +apply (rule reduce_hd)
37.153 +txt {* snd case *}
37.154 + apply (rule impI)
37.155 + apply (erule conjE)+
37.156 + apply (erule disjE)
37.157 +apply (simp add: l_iff_red_nil)
37.158 +apply (erule hd_is_reduce_hd [THEN mp])
37.159 +apply (simp add: l_iff_red_nil)
37.160 +apply (rule conjI)
37.161 +apply (erule hd_is_reduce_hd [THEN mp])
37.162 +apply (rule bool_if_impl_or [THEN mp])
37.163 +apply (erule reduce_tl)
37.164 +done
37.165 +
37.166 +declare split_if [split]
37.167 +
37.168 +lemma sender_abstraction: "is_weak_ref_map reduce srch_ioa srch_fin_ioa"
37.169 +apply (tactic {*
37.170 + simp_tac (HOL_ss addsimps [@{thm srch_fin_ioa_def}, @{thm rsch_fin_ioa_def},
37.171 + @{thm srch_ioa_def}, @{thm rsch_ioa_def}, @{thm rename_through_pmap},
37.172 + @{thm channel_abstraction}]) 1 *})
37.173 +done
37.174 +
37.175 +lemma receiver_abstraction: "is_weak_ref_map reduce rsch_ioa rsch_fin_ioa"
37.176 +apply (tactic {*
37.177 + simp_tac (HOL_ss addsimps [@{thm srch_fin_ioa_def}, @{thm rsch_fin_ioa_def},
37.178 + @{thm srch_ioa_def}, @{thm rsch_ioa_def}, @{thm rename_through_pmap},
37.179 + @{thm channel_abstraction}]) 1 *})
37.180 +done
37.181 +
37.182 +
37.183 +text {* 3 thms that do not hold generally! The lucky restriction here is
37.184 + the absence of internal actions. *}
37.185 +lemma sender_unchanged: "is_weak_ref_map (%id. id) sender_ioa sender_ioa"
37.186 +apply (simp (no_asm) add: is_weak_ref_map_def)
37.187 +txt {* main-part *}
37.188 +apply (rule allI)+
37.189 +apply (induct_tac a)
37.190 +txt {* 7 cases *}
37.191 +apply (simp_all (no_asm) add: externals_def)
37.192 +done
37.193 +
37.194 +text {* 2 copies of before *}
37.195 +lemma receiver_unchanged: "is_weak_ref_map (%id. id) receiver_ioa receiver_ioa"
37.196 +apply (simp (no_asm) add: is_weak_ref_map_def)
37.197 +txt {* main-part *}
37.198 +apply (rule allI)+
37.199 +apply (induct_tac a)
37.200 +txt {* 7 cases *}
37.201 +apply (simp_all (no_asm) add: externals_def)
37.202 +done
37.203 +
37.204 +lemma env_unchanged: "is_weak_ref_map (%id. id) env_ioa env_ioa"
37.205 +apply (simp (no_asm) add: is_weak_ref_map_def)
37.206 +txt {* main-part *}
37.207 +apply (rule allI)+
37.208 +apply (induct_tac a)
37.209 +txt {* 7 cases *}
37.210 +apply (simp_all (no_asm) add: externals_def)
37.211 +done
37.212 +
37.213 +
37.214 +lemma compat_single_ch: "compatible srch_ioa rsch_ioa"
37.215 +apply (simp add: compatible_def Int_def)
37.216 +apply (rule set_eqI)
37.217 +apply (induct_tac x)
37.218 +apply simp_all
37.219 +done
37.220 +
37.221 +text {* totally the same as before *}
37.222 +lemma compat_single_fin_ch: "compatible srch_fin_ioa rsch_fin_ioa"
37.223 +apply (simp add: compatible_def Int_def)
37.224 +apply (rule set_eqI)
37.225 +apply (induct_tac x)
37.226 +apply simp_all
37.227 +done
37.228 +
37.229 +lemmas del_simps = trans_of_def srch_asig_def rsch_asig_def
37.230 + asig_of_def actions_def srch_trans_def rsch_trans_def srch_ioa_def
37.231 + srch_fin_ioa_def rsch_fin_ioa_def rsch_ioa_def sender_trans_def
37.232 + receiver_trans_def set_lemmas
37.233 +
37.234 +lemma compat_rec: "compatible receiver_ioa (srch_ioa || rsch_ioa)"
37.235 +apply (simp del: del_simps
37.236 + add: compatible_def asig_of_par asig_comp_def actions_def Int_def)
37.237 +apply simp
37.238 +apply (rule set_eqI)
37.239 +apply (induct_tac x)
37.240 +apply simp_all
37.241 +done
37.242 +
37.243 +text {* 5 proofs totally the same as before *}
37.244 +lemma compat_rec_fin: "compatible receiver_ioa (srch_fin_ioa || rsch_fin_ioa)"
37.245 +apply (simp del: del_simps
37.246 + add: compatible_def asig_of_par asig_comp_def actions_def Int_def)
37.247 +apply simp
37.248 +apply (rule set_eqI)
37.249 +apply (induct_tac x)
37.250 +apply simp_all
37.251 +done
37.252 +
37.253 +lemma compat_sen: "compatible sender_ioa
37.254 + (receiver_ioa || srch_ioa || rsch_ioa)"
37.255 +apply (simp del: del_simps
37.256 + add: compatible_def asig_of_par asig_comp_def actions_def Int_def)
37.257 +apply simp
37.258 +apply (rule set_eqI)
37.259 +apply (induct_tac x)
37.260 +apply simp_all
37.261 +done
37.262 +
37.263 +lemma compat_sen_fin: "compatible sender_ioa
37.264 + (receiver_ioa || srch_fin_ioa || rsch_fin_ioa)"
37.265 +apply (simp del: del_simps
37.266 + add: compatible_def asig_of_par asig_comp_def actions_def Int_def)
37.267 +apply simp
37.268 +apply (rule set_eqI)
37.269 +apply (induct_tac x)
37.270 +apply simp_all
37.271 +done
37.272 +
37.273 +lemma compat_env: "compatible env_ioa
37.274 + (sender_ioa || receiver_ioa || srch_ioa || rsch_ioa)"
37.275 +apply (simp del: del_simps
37.276 + add: compatible_def asig_of_par asig_comp_def actions_def Int_def)
37.277 +apply simp
37.278 +apply (rule set_eqI)
37.279 +apply (induct_tac x)
37.280 +apply simp_all
37.281 +done
37.282 +
37.283 +lemma compat_env_fin: "compatible env_ioa
37.284 + (sender_ioa || receiver_ioa || srch_fin_ioa || rsch_fin_ioa)"
37.285 +apply (simp del: del_simps
37.286 + add: compatible_def asig_of_par asig_comp_def actions_def Int_def)
37.287 +apply simp
37.288 +apply (rule set_eqI)
37.289 +apply (induct_tac x)
37.290 +apply simp_all
37.291 +done
37.292 +
37.293 +
37.294 +text {* lemmata about externals of channels *}
37.295 +lemma ext_single_ch: "externals(asig_of(srch_fin_ioa)) = externals(asig_of(srch_ioa)) &
37.296 + externals(asig_of(rsch_fin_ioa)) = externals(asig_of(rsch_ioa))"
37.297 + by (simp add: externals_def)
37.298 +
37.299 +
37.300 +subsection {* Soundness of Abstraction *}
37.301 +
37.302 +lemmas ext_simps = externals_of_par ext_single_ch
37.303 + and compat_simps = compat_single_ch compat_single_fin_ch compat_rec
37.304 + compat_rec_fin compat_sen compat_sen_fin compat_env compat_env_fin
37.305 + and abstractions = env_unchanged sender_unchanged
37.306 + receiver_unchanged sender_abstraction receiver_abstraction
37.307 +
37.308 +
37.309 +(* FIX: this proof should be done with compositionality on trace level, not on
37.310 + weak_ref_map level, as done here with fxg_is_weak_ref_map_of_product_IOA
37.311 +
37.312 +Goal "is_weak_ref_map abs system_ioa system_fin_ioa"
37.313 +
37.314 +by (simp_tac (impl_ss delsimps ([srch_ioa_def, rsch_ioa_def, srch_fin_ioa_def,
37.315 + rsch_fin_ioa_def] @ env_ioas @ impl_ioas)
37.316 + addsimps [system_def, system_fin_def, abs_def,
37.317 + impl_ioa_def, impl_fin_ioa_def, sys_IOA,
37.318 + sys_fin_IOA]) 1);
37.319 +
37.320 +by (REPEAT (EVERY[rtac fxg_is_weak_ref_map_of_product_IOA 1,
37.321 + simp_tac (ss addsimps abstractions) 1,
37.322 + rtac conjI 1]));
37.323 +
37.324 +by (ALLGOALS (simp_tac (ss addsimps ext_ss @ compat_ss)));
37.325 +
37.326 +qed "system_refinement";
37.327 +*)
37.328 +
37.329 +end
38.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
38.2 +++ b/src/HOL/HOLCF/IOA/ABP/Env.thy Sat Nov 27 16:08:10 2010 -0800
38.3 @@ -0,0 +1,42 @@
38.4 +(* Title: HOLCF/IOA/ABP/Impl.thy
38.5 + Author: Olaf Müller
38.6 +*)
38.7 +
38.8 +header {* The environment *}
38.9 +
38.10 +theory Env
38.11 +imports IOA Action
38.12 +begin
38.13 +
38.14 +types
38.15 + 'm env_state = bool -- {* give next bit to system *}
38.16 +
38.17 +definition
38.18 + env_asig :: "'m action signature" where
38.19 + "env_asig == ({Next},
38.20 + UN m. {S_msg(m)},
38.21 + {})"
38.22 +
38.23 +definition
38.24 + env_trans :: "('m action, 'm env_state)transition set" where
38.25 + "env_trans =
38.26 + {tr. let s = fst(tr);
38.27 + t = snd(snd(tr))
38.28 + in case fst(snd(tr))
38.29 + of
38.30 + Next => t=True |
38.31 + S_msg(m) => s=True & t=False |
38.32 + R_msg(m) => False |
38.33 + S_pkt(pkt) => False |
38.34 + R_pkt(pkt) => False |
38.35 + S_ack(b) => False |
38.36 + R_ack(b) => False}"
38.37 +
38.38 +definition
38.39 + env_ioa :: "('m action, 'm env_state)ioa" where
38.40 + "env_ioa = (env_asig, {True}, env_trans,{},{})"
38.41 +
38.42 +axiomatization
38.43 + "next" :: "'m env_state => bool"
38.44 +
38.45 +end
39.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
39.2 +++ b/src/HOL/HOLCF/IOA/ABP/Impl.thy Sat Nov 27 16:08:10 2010 -0800
39.3 @@ -0,0 +1,35 @@
39.4 +(* Title: HOLCF/IOA/ABP/Impl.thy
39.5 + Author: Olaf Müller
39.6 +*)
39.7 +
39.8 +header {* The implementation *}
39.9 +
39.10 +theory Impl
39.11 +imports Sender Receiver Abschannel
39.12 +begin
39.13 +
39.14 +types
39.15 + 'm impl_state = "'m sender_state * 'm receiver_state * 'm packet list * bool list"
39.16 + (* sender_state * receiver_state * srch_state * rsch_state *)
39.17 +
39.18 +definition
39.19 + impl_ioa :: "('m action, 'm impl_state)ioa" where
39.20 + "impl_ioa = (sender_ioa || receiver_ioa || srch_ioa || rsch_ioa)"
39.21 +
39.22 +definition
39.23 + sen :: "'m impl_state => 'm sender_state" where
39.24 + "sen = fst"
39.25 +
39.26 +definition
39.27 + rec :: "'m impl_state => 'm receiver_state" where
39.28 + "rec = fst o snd"
39.29 +
39.30 +definition
39.31 + srch :: "'m impl_state => 'm packet list" where
39.32 + "srch = fst o snd o snd"
39.33 +
39.34 +definition
39.35 + rsch :: "'m impl_state => bool list" where
39.36 + "rsch = snd o snd o snd"
39.37 +
39.38 +end
40.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
40.2 +++ b/src/HOL/HOLCF/IOA/ABP/Impl_finite.thy Sat Nov 27 16:08:10 2010 -0800
40.3 @@ -0,0 +1,37 @@
40.4 +(* Title: HOLCF/IOA/ABP/Impl.thy
40.5 + Author: Olaf Müller
40.6 +*)
40.7 +
40.8 +header {* The implementation *}
40.9 +
40.10 +theory Impl_finite
40.11 +imports Sender Receiver Abschannel_finite
40.12 +begin
40.13 +
40.14 +types
40.15 + 'm impl_fin_state
40.16 + = "'m sender_state * 'm receiver_state * 'm packet list * bool list"
40.17 +(* sender_state * receiver_state * srch_state * rsch_state *)
40.18 +
40.19 +definition
40.20 + impl_fin_ioa :: "('m action, 'm impl_fin_state)ioa" where
40.21 + "impl_fin_ioa = (sender_ioa || receiver_ioa || srch_fin_ioa ||
40.22 + rsch_fin_ioa)"
40.23 +
40.24 +definition
40.25 + sen_fin :: "'m impl_fin_state => 'm sender_state" where
40.26 + "sen_fin = fst"
40.27 +
40.28 +definition
40.29 + rec_fin :: "'m impl_fin_state => 'm receiver_state" where
40.30 + "rec_fin = fst o snd"
40.31 +
40.32 +definition
40.33 + srch_fin :: "'m impl_fin_state => 'm packet list" where
40.34 + "srch_fin = fst o snd o snd"
40.35 +
40.36 +definition
40.37 + rsch_fin :: "'m impl_fin_state => bool list" where
40.38 + "rsch_fin = snd o snd o snd"
40.39 +
40.40 +end
41.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
41.2 +++ b/src/HOL/HOLCF/IOA/ABP/Lemmas.thy Sat Nov 27 16:08:10 2010 -0800
41.3 @@ -0,0 +1,44 @@
41.4 +(* Title: HOLCF/IOA/ABP/Lemmas.thy
41.5 + Author: Olaf Müller
41.6 +*)
41.7 +
41.8 +theory Lemmas
41.9 +imports Main
41.10 +begin
41.11 +
41.12 +subsection {* Logic *}
41.13 +
41.14 +lemma and_de_morgan_and_absorbe: "(~(A&B)) = ((~A)&B| ~B)"
41.15 + by blast
41.16 +
41.17 +lemma bool_if_impl_or: "(if C then A else B) --> (A|B)"
41.18 + by auto
41.19 +
41.20 +lemma exis_elim: "(? x. x=P & Q(x)) = Q(P)"
41.21 + by blast
41.22 +
41.23 +
41.24 +subsection {* Sets *}
41.25 +
41.26 +lemma set_lemmas:
41.27 + "f(x) : (UN x. {f(x)})"
41.28 + "f x y : (UN x y. {f x y})"
41.29 + "!!a. (!x. a ~= f(x)) ==> a ~: (UN x. {f(x)})"
41.30 + "!!a. (!x y. a ~= f x y) ==> a ~: (UN x y. {f x y})"
41.31 + by auto
41.32 +
41.33 +text {* 2 Lemmas to add to @{text "set_lemmas"}, used also for action handling,
41.34 + namely for Intersections and the empty list (compatibility of IOA!). *}
41.35 +lemma singleton_set: "(UN b.{x. x=f(b)})= (UN b.{f(b)})"
41.36 + by blast
41.37 +
41.38 +lemma de_morgan: "((A|B)=False) = ((~A)&(~B))"
41.39 + by blast
41.40 +
41.41 +
41.42 +subsection {* Lists *}
41.43 +
41.44 +lemma cons_not_nil: "l ~= [] --> (? x xs. l = (x#xs))"
41.45 + by (induct l) simp_all
41.46 +
41.47 +end
42.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
42.2 +++ b/src/HOL/HOLCF/IOA/ABP/Packet.thy Sat Nov 27 16:08:10 2010 -0800
42.3 @@ -0,0 +1,22 @@
42.4 +(* Title: HOLCF/IOA/ABP/Packet.thy
42.5 + Author: Olaf Müller
42.6 +*)
42.7 +
42.8 +header {* Packets *}
42.9 +
42.10 +theory Packet
42.11 +imports Main
42.12 +begin
42.13 +
42.14 +types
42.15 + 'msg packet = "bool * 'msg"
42.16 +
42.17 +definition
42.18 + hdr :: "'msg packet => bool" where
42.19 + "hdr = fst"
42.20 +
42.21 +definition
42.22 + msg :: "'msg packet => 'msg" where
42.23 + "msg = snd"
42.24 +
42.25 +end
43.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
43.2 +++ b/src/HOL/HOLCF/IOA/ABP/ROOT.ML Sat Nov 27 16:08:10 2010 -0800
43.3 @@ -0,0 +1,7 @@
43.4 +(* Title: HOLCF/IOA/ABP/ROOT.ML
43.5 + Author: Olaf Mueller
43.6 +
43.7 +This is the ROOT file for the Alternating Bit Protocol performed in
43.8 +I/O-Automata.
43.9 +*)
43.10 +use_thys ["Correctness"];
44.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
44.2 +++ b/src/HOL/HOLCF/IOA/ABP/Read_me Sat Nov 27 16:08:10 2010 -0800
44.3 @@ -0,0 +1,10 @@
44.4 +Isabelle Verification of the Alternating Bit Protocol by
44.5 +combining IOA with Model Checking
44.6 +
44.7 +-------------------------------------------------------------
44.8 +
44.9 +Correctness.ML contains the proof of the abstraction from unbounded
44.10 +channels to finite ones.
44.11 +
44.12 +Check.ML contains a simple ModelChecker prototype checking Spec against
44.13 +the finite version of the ABP-protocol.
45.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
45.2 +++ b/src/HOL/HOLCF/IOA/ABP/Receiver.thy Sat Nov 27 16:08:10 2010 -0800
45.3 @@ -0,0 +1,57 @@
45.4 +(* Title: HOLCF/IOA/ABP/Receiver.thy
45.5 + Author: Olaf Müller
45.6 +*)
45.7 +
45.8 +header {* The implementation: receiver *}
45.9 +
45.10 +theory Receiver
45.11 +imports IOA Action Lemmas
45.12 +begin
45.13 +
45.14 +types
45.15 + 'm receiver_state = "'m list * bool" -- {* messages, mode *}
45.16 +
45.17 +definition
45.18 + rq :: "'m receiver_state => 'm list" where
45.19 + "rq = fst"
45.20 +
45.21 +definition
45.22 + rbit :: "'m receiver_state => bool" where
45.23 + "rbit = snd"
45.24 +
45.25 +definition
45.26 + receiver_asig :: "'m action signature" where
45.27 + "receiver_asig =
45.28 + (UN pkt. {R_pkt(pkt)},
45.29 + (UN m. {R_msg(m)}) Un (UN b. {S_ack(b)}),
45.30 + {})"
45.31 +
45.32 +definition
45.33 + receiver_trans :: "('m action, 'm receiver_state)transition set" where
45.34 + "receiver_trans =
45.35 + {tr. let s = fst(tr);
45.36 + t = snd(snd(tr))
45.37 + in
45.38 + case fst(snd(tr))
45.39 + of
45.40 + Next => False |
45.41 + S_msg(m) => False |
45.42 + R_msg(m) => (rq(s) ~= []) &
45.43 + m = hd(rq(s)) &
45.44 + rq(t) = tl(rq(s)) &
45.45 + rbit(t)=rbit(s) |
45.46 + S_pkt(pkt) => False |
45.47 + R_pkt(pkt) => if (hdr(pkt) ~= rbit(s))&rq(s)=[] then
45.48 + rq(t) = (rq(s)@[msg(pkt)]) &rbit(t) = (~rbit(s)) else
45.49 + rq(t) =rq(s) & rbit(t)=rbit(s) |
45.50 + S_ack(b) => b = rbit(s) &
45.51 + rq(t) = rq(s) &
45.52 + rbit(t)=rbit(s) |
45.53 + R_ack(b) => False}"
45.54 +
45.55 +definition
45.56 + receiver_ioa :: "('m action, 'm receiver_state)ioa" where
45.57 + "receiver_ioa =
45.58 + (receiver_asig, {([],False)}, receiver_trans,{},{})"
45.59 +
45.60 +end
46.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
46.2 +++ b/src/HOL/HOLCF/IOA/ABP/Sender.thy Sat Nov 27 16:08:10 2010 -0800
46.3 @@ -0,0 +1,55 @@
46.4 +(* Title: HOLCF/IOA/ABP/Sender.thy
46.5 + Author: Olaf Müller
46.6 +*)
46.7 +
46.8 +header {* The implementation: sender *}
46.9 +
46.10 +theory Sender
46.11 +imports IOA Action Lemmas
46.12 +begin
46.13 +
46.14 +types
46.15 + 'm sender_state = "'m list * bool" -- {* messages, Alternating Bit *}
46.16 +
46.17 +definition
46.18 + sq :: "'m sender_state => 'm list" where
46.19 + "sq = fst"
46.20 +
46.21 +definition
46.22 + sbit :: "'m sender_state => bool" where
46.23 + "sbit = snd"
46.24 +
46.25 +definition
46.26 + sender_asig :: "'m action signature" where
46.27 + "sender_asig = ((UN m. {S_msg(m)}) Un (UN b. {R_ack(b)}),
46.28 + UN pkt. {S_pkt(pkt)},
46.29 + {})"
46.30 +
46.31 +definition
46.32 + sender_trans :: "('m action, 'm sender_state)transition set" where
46.33 + "sender_trans =
46.34 + {tr. let s = fst(tr);
46.35 + t = snd(snd(tr))
46.36 + in case fst(snd(tr))
46.37 + of
46.38 + Next => if sq(s)=[] then t=s else False |
46.39 + S_msg(m) => sq(t)=sq(s)@[m] &
46.40 + sbit(t)=sbit(s) |
46.41 + R_msg(m) => False |
46.42 + S_pkt(pkt) => sq(s) ~= [] &
46.43 + hdr(pkt) = sbit(s) &
46.44 + msg(pkt) = hd(sq(s)) &
46.45 + sq(t) = sq(s) &
46.46 + sbit(t) = sbit(s) |
46.47 + R_pkt(pkt) => False |
46.48 + S_ack(b) => False |
46.49 + R_ack(b) => if b = sbit(s) then
46.50 + sq(t)=tl(sq(s)) & sbit(t)=(~sbit(s)) else
46.51 + sq(t)=sq(s) & sbit(t)=sbit(s)}"
46.52 +
46.53 +definition
46.54 + sender_ioa :: "('m action, 'm sender_state)ioa" where
46.55 + "sender_ioa =
46.56 + (sender_asig, {([],True)}, sender_trans,{},{})"
46.57 +
46.58 +end
47.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
47.2 +++ b/src/HOL/HOLCF/IOA/ABP/Spec.thy Sat Nov 27 16:08:10 2010 -0800
47.3 @@ -0,0 +1,37 @@
47.4 +(* Title: HOLCF/IOA/ABP/Spec.thy
47.5 + Author: Olaf Müller
47.6 +*)
47.7 +
47.8 +header {* The specification of reliable transmission *}
47.9 +
47.10 +theory Spec
47.11 +imports IOA Action
47.12 +begin
47.13 +
47.14 +definition
47.15 + spec_sig :: "'m action signature" where
47.16 + sig_def: "spec_sig = (UN m.{S_msg(m)},
47.17 + UN m.{R_msg(m)} Un {Next},
47.18 + {})"
47.19 +
47.20 +definition
47.21 + spec_trans :: "('m action, 'm list)transition set" where
47.22 + trans_def: "spec_trans =
47.23 + {tr. let s = fst(tr);
47.24 + t = snd(snd(tr))
47.25 + in
47.26 + case fst(snd(tr))
47.27 + of
47.28 + Next => t=s | (* Note that there is condition as in Sender *)
47.29 + S_msg(m) => t = s@[m] |
47.30 + R_msg(m) => s = (m#t) |
47.31 + S_pkt(pkt) => False |
47.32 + R_pkt(pkt) => False |
47.33 + S_ack(b) => False |
47.34 + R_ack(b) => False}"
47.35 +
47.36 +definition
47.37 + spec_ioa :: "('m action, 'm list)ioa" where
47.38 + ioa_def: "spec_ioa = (spec_sig, {[]}, spec_trans)"
47.39 +
47.40 +end
48.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
48.2 +++ b/src/HOL/HOLCF/IOA/NTP/Abschannel.thy Sat Nov 27 16:08:10 2010 -0800
48.3 @@ -0,0 +1,141 @@
48.4 +(* Title: HOL/IOA/NTP/Abschannel.thy
48.5 + Author: Olaf Müller
48.6 +*)
48.7 +
48.8 +header {* The (faulty) transmission channel (both directions) *}
48.9 +
48.10 +theory Abschannel
48.11 +imports IOA Action
48.12 +begin
48.13 +
48.14 +datatype 'a abs_action = S 'a | R 'a
48.15 +
48.16 +definition
48.17 + ch_asig :: "'a abs_action signature" where
48.18 + "ch_asig = (UN b. {S(b)}, UN b. {R(b)}, {})"
48.19 +
48.20 +definition
48.21 + ch_trans :: "('a abs_action, 'a multiset)transition set" where
48.22 + "ch_trans =
48.23 + {tr. let s = fst(tr);
48.24 + t = snd(snd(tr))
48.25 + in
48.26 + case fst(snd(tr))
48.27 + of S(b) => t = addm s b |
48.28 + R(b) => count s b ~= 0 & t = delm s b}"
48.29 +
48.30 +definition
48.31 + ch_ioa :: "('a abs_action, 'a multiset)ioa" where
48.32 + "ch_ioa = (ch_asig, {{|}}, ch_trans,{},{})"
48.33 +
48.34 +definition
48.35 + rsch_actions :: "'m action => bool abs_action option" where
48.36 + "rsch_actions (akt) =
48.37 + (case akt of
48.38 + S_msg(m) => None |
48.39 + R_msg(m) => None |
48.40 + S_pkt(packet) => None |
48.41 + R_pkt(packet) => None |
48.42 + S_ack(b) => Some(S(b)) |
48.43 + R_ack(b) => Some(R(b)) |
48.44 + C_m_s => None |
48.45 + C_m_r => None |
48.46 + C_r_s => None |
48.47 + C_r_r(m) => None)"
48.48 +
48.49 +definition
48.50 + srch_actions :: "'m action =>(bool * 'm) abs_action option" where
48.51 + "srch_actions (akt) =
48.52 + (case akt of
48.53 + S_msg(m) => None |
48.54 + R_msg(m) => None |
48.55 + S_pkt(p) => Some(S(p)) |
48.56 + R_pkt(p) => Some(R(p)) |
48.57 + S_ack(b) => None |
48.58 + R_ack(b) => None |
48.59 + C_m_s => None |
48.60 + C_m_r => None |
48.61 + C_r_s => None |
48.62 + C_r_r(m) => None)"
48.63 +
48.64 +definition
48.65 + srch_ioa :: "('m action, 'm packet multiset)ioa" where
48.66 + "srch_ioa = rename ch_ioa srch_actions"
48.67 +
48.68 +definition
48.69 + rsch_ioa :: "('m action, bool multiset)ioa" where
48.70 + "rsch_ioa = rename ch_ioa rsch_actions"
48.71 +
48.72 +definition
48.73 + srch_asig :: "'m action signature" where
48.74 + "srch_asig = asig_of(srch_ioa)"
48.75 +
48.76 +definition
48.77 + rsch_asig :: "'m action signature" where
48.78 + "rsch_asig = asig_of(rsch_ioa)"
48.79 +
48.80 +definition
48.81 + srch_wfair :: "('m action)set set" where
48.82 + "srch_wfair = wfair_of(srch_ioa)"
48.83 +definition
48.84 + srch_sfair :: "('m action)set set" where
48.85 + "srch_sfair = sfair_of(srch_ioa)"
48.86 +definition
48.87 + rsch_sfair :: "('m action)set set" where
48.88 + "rsch_sfair = sfair_of(rsch_ioa)"
48.89 +definition
48.90 + rsch_wfair :: "('m action)set set" where
48.91 + "rsch_wfair = wfair_of(rsch_ioa)"
48.92 +
48.93 +definition
48.94 + srch_trans :: "('m action, 'm packet multiset)transition set" where
48.95 + "srch_trans = trans_of(srch_ioa)"
48.96 +definition
48.97 + rsch_trans :: "('m action, bool multiset)transition set" where
48.98 + "rsch_trans = trans_of(rsch_ioa)"
48.99 +
48.100 +
48.101 +lemmas unfold_renaming =
48.102 + srch_asig_def rsch_asig_def rsch_ioa_def srch_ioa_def ch_ioa_def
48.103 + ch_asig_def srch_actions_def rsch_actions_def rename_def rename_set_def asig_of_def
48.104 + actions_def srch_trans_def rsch_trans_def ch_trans_def starts_of_def
48.105 + trans_of_def asig_projections
48.106 +
48.107 +lemma in_srch_asig:
48.108 + "S_msg(m) ~: actions(srch_asig) &
48.109 + R_msg(m) ~: actions(srch_asig) &
48.110 + S_pkt(pkt) : actions(srch_asig) &
48.111 + R_pkt(pkt) : actions(srch_asig) &
48.112 + S_ack(b) ~: actions(srch_asig) &
48.113 + R_ack(b) ~: actions(srch_asig) &
48.114 + C_m_s ~: actions(srch_asig) &
48.115 + C_m_r ~: actions(srch_asig) &
48.116 + C_r_s ~: actions(srch_asig) & C_r_r(m) ~: actions(srch_asig)"
48.117 + by (simp add: unfold_renaming)
48.118 +
48.119 +lemma in_rsch_asig:
48.120 + "S_msg(m) ~: actions(rsch_asig) &
48.121 + R_msg(m) ~: actions(rsch_asig) &
48.122 + S_pkt(pkt) ~: actions(rsch_asig) &
48.123 + R_pkt(pkt) ~: actions(rsch_asig) &
48.124 + S_ack(b) : actions(rsch_asig) &
48.125 + R_ack(b) : actions(rsch_asig) &
48.126 + C_m_s ~: actions(rsch_asig) &
48.127 + C_m_r ~: actions(rsch_asig) &
48.128 + C_r_s ~: actions(rsch_asig) &
48.129 + C_r_r(m) ~: actions(rsch_asig)"
48.130 + by (simp add: unfold_renaming)
48.131 +
48.132 +lemma srch_ioa_thm: "srch_ioa =
48.133 + (srch_asig, {{|}}, srch_trans,srch_wfair,srch_sfair)"
48.134 +apply (simp (no_asm) add: srch_asig_def srch_trans_def asig_of_def trans_of_def wfair_of_def sfair_of_def srch_wfair_def srch_sfair_def)
48.135 +apply (simp (no_asm) add: unfold_renaming)
48.136 +done
48.137 +
48.138 +lemma rsch_ioa_thm: "rsch_ioa =
48.139 + (rsch_asig, {{|}}, rsch_trans,rsch_wfair,rsch_sfair)"
48.140 +apply (simp (no_asm) add: rsch_asig_def rsch_trans_def asig_of_def trans_of_def wfair_of_def sfair_of_def rsch_wfair_def rsch_sfair_def)
48.141 +apply (simp (no_asm) add: unfold_renaming)
48.142 +done
48.143 +
48.144 +end
49.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
49.2 +++ b/src/HOL/HOLCF/IOA/NTP/Action.thy Sat Nov 27 16:08:10 2010 -0800
49.3 @@ -0,0 +1,16 @@
49.4 +(* Title: HOL/IOA/NTP/Action.thy
49.5 + Author: Tobias Nipkow & Konrad Slind
49.6 +*)
49.7 +
49.8 +header {* The set of all actions of the system *}
49.9 +
49.10 +theory Action
49.11 +imports Packet
49.12 +begin
49.13 +
49.14 +datatype 'm action = S_msg 'm | R_msg 'm
49.15 + | S_pkt "'m packet" | R_pkt "'m packet"
49.16 + | S_ack bool | R_ack bool
49.17 + | C_m_s | C_m_r | C_r_s | C_r_r 'm
49.18 +
49.19 +end
50.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
50.2 +++ b/src/HOL/HOLCF/IOA/NTP/Correctness.thy Sat Nov 27 16:08:10 2010 -0800
50.3 @@ -0,0 +1,105 @@
50.4 +(* Title: HOL/IOA/NTP/Correctness.thy
50.5 + Author: Tobias Nipkow & Konrad Slind
50.6 +*)
50.7 +
50.8 +header {* The main correctness proof: Impl implements Spec *}
50.9 +
50.10 +theory Correctness
50.11 +imports Impl Spec
50.12 +begin
50.13 +
50.14 +definition
50.15 + hom :: "'m impl_state => 'm list" where
50.16 + "hom s = rq(rec(s)) @ (if rbit(rec s) = sbit(sen s) then sq(sen s)
50.17 + else tl(sq(sen s)))"
50.18 +
50.19 +declaration {* fn _ =>
50.20 + (* repeated from Traces.ML *)
50.21 + Classical.map_cs (fn cs => cs delSWrapper "split_all_tac")
50.22 +*}
50.23 +
50.24 +lemmas hom_ioas = Spec.ioa_def Spec.trans_def sender_trans_def receiver_trans_def impl_ioas
50.25 + and impl_asigs = sender_asig_def receiver_asig_def srch_asig_def rsch_asig_def
50.26 +
50.27 +declare split_paired_All [simp del]
50.28 +
50.29 +
50.30 +text {*
50.31 + A lemma about restricting the action signature of the implementation
50.32 + to that of the specification.
50.33 +*}
50.34 +
50.35 +lemma externals_lemma:
50.36 + "a:externals(asig_of(Automata.restrict impl_ioa (externals spec_sig))) =
50.37 + (case a of
50.38 + S_msg(m) => True
50.39 + | R_msg(m) => True
50.40 + | S_pkt(pkt) => False
50.41 + | R_pkt(pkt) => False
50.42 + | S_ack(b) => False
50.43 + | R_ack(b) => False
50.44 + | C_m_s => False
50.45 + | C_m_r => False
50.46 + | C_r_s => False
50.47 + | C_r_r(m) => False)"
50.48 + apply (simp (no_asm) add: externals_def restrict_def restrict_asig_def Spec.sig_def asig_projections)
50.49 +
50.50 + apply (induct_tac "a")
50.51 + apply (simp_all (no_asm) add: actions_def asig_projections)
50.52 + txt {* 2 *}
50.53 + apply (simp (no_asm) add: impl_ioas)
50.54 + apply (simp (no_asm) add: impl_asigs)
50.55 + apply (simp (no_asm) add: asig_of_par asig_comp_def asig_projections)
50.56 + apply (simp (no_asm) add: "transitions"(1) unfold_renaming)
50.57 + txt {* 1 *}
50.58 + apply (simp (no_asm) add: impl_ioas)
50.59 + apply (simp (no_asm) add: impl_asigs)
50.60 + apply (simp (no_asm) add: asig_of_par asig_comp_def asig_projections)
50.61 + done
50.62 +
50.63 +lemmas sels = sbit_def sq_def ssending_def rbit_def rq_def rsending_def
50.64 +
50.65 +
50.66 +text {* Proof of correctness *}
50.67 +lemma ntp_correct:
50.68 + "is_weak_ref_map hom (Automata.restrict impl_ioa (externals spec_sig)) spec_ioa"
50.69 +apply (unfold Spec.ioa_def is_weak_ref_map_def)
50.70 +apply (simp (no_asm) cong del: if_weak_cong split del: split_if add: Correctness.hom_def
50.71 + cancel_restrict externals_lemma)
50.72 +apply (rule conjI)
50.73 + apply (simp (no_asm) add: hom_ioas)
50.74 + apply (simp (no_asm_simp) add: sels)
50.75 +apply (rule allI)+
50.76 +apply (rule imp_conj_lemma)
50.77 +
50.78 +apply (induct_tac "a")
50.79 +apply (simp_all (no_asm_simp) add: hom_ioas)
50.80 +apply (frule inv4)
50.81 +apply force
50.82 +
50.83 +apply (frule inv4)
50.84 +apply (frule inv2)
50.85 +apply (erule disjE)
50.86 +apply (simp (no_asm_simp))
50.87 +apply force
50.88 +
50.89 +apply (frule inv2)
50.90 +apply (erule disjE)
50.91 +
50.92 +apply (frule inv3)
50.93 +apply (case_tac "sq (sen (s))=[]")
50.94 +
50.95 +apply (simp add: hom_ioas)
50.96 +apply (blast dest!: add_leD1 [THEN leD])
50.97 +
50.98 +apply (case_tac "m = hd (sq (sen (s)))")
50.99 +
50.100 +apply force
50.101 +
50.102 +apply simp
50.103 +apply (blast dest!: add_leD1 [THEN leD])
50.104 +
50.105 +apply simp
50.106 +done
50.107 +
50.108 +end
51.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
51.2 +++ b/src/HOL/HOLCF/IOA/NTP/Impl.thy Sat Nov 27 16:08:10 2010 -0800
51.3 @@ -0,0 +1,356 @@
51.4 +(* Title: HOL/IOA/NTP/Impl.thy
51.5 + Author: Tobias Nipkow & Konrad Slind
51.6 +*)
51.7 +
51.8 +header {* The implementation *}
51.9 +
51.10 +theory Impl
51.11 +imports Sender Receiver Abschannel
51.12 +begin
51.13 +
51.14 +types 'm impl_state
51.15 + = "'m sender_state * 'm receiver_state * 'm packet multiset * bool multiset"
51.16 + (* sender_state * receiver_state * srch_state * rsch_state *)
51.17 +
51.18 +
51.19 +definition
51.20 + impl_ioa :: "('m action, 'm impl_state)ioa" where
51.21 + impl_def: "impl_ioa == (sender_ioa || receiver_ioa || srch_ioa || rsch_ioa)"
51.22 +
51.23 +definition sen :: "'m impl_state => 'm sender_state" where "sen = fst"
51.24 +definition rec :: "'m impl_state => 'm receiver_state" where "rec = fst o snd"
51.25 +definition srch :: "'m impl_state => 'm packet multiset" where "srch = fst o snd o snd"
51.26 +definition rsch :: "'m impl_state => bool multiset" where "rsch = snd o snd o snd"
51.27 +
51.28 +definition
51.29 + hdr_sum :: "'m packet multiset => bool => nat" where
51.30 + "hdr_sum M b == countm M (%pkt. hdr(pkt) = b)"
51.31 +
51.32 +(* Lemma 5.1 *)
51.33 +definition
51.34 + "inv1(s) ==
51.35 + (!b. count (rsent(rec s)) b = count (srcvd(sen s)) b + count (rsch s) b)
51.36 + & (!b. count (ssent(sen s)) b
51.37 + = hdr_sum (rrcvd(rec s)) b + hdr_sum (srch s) b)"
51.38 +
51.39 +(* Lemma 5.2 *)
51.40 +definition
51.41 + "inv2(s) ==
51.42 + (rbit(rec(s)) = sbit(sen(s)) &
51.43 + ssending(sen(s)) &
51.44 + count (rsent(rec s)) (~sbit(sen s)) <= count (ssent(sen s)) (~sbit(sen s)) &
51.45 + count (ssent(sen s)) (~sbit(sen s)) <= count (rsent(rec s)) (sbit(sen s)))
51.46 + |
51.47 + (rbit(rec(s)) = (~sbit(sen(s))) &
51.48 + rsending(rec(s)) &
51.49 + count (ssent(sen s)) (~sbit(sen s)) <= count (rsent(rec s)) (sbit(sen s)) &
51.50 + count (rsent(rec s)) (sbit(sen s)) <= count (ssent(sen s)) (sbit(sen s)))"
51.51 +
51.52 +(* Lemma 5.3 *)
51.53 +definition
51.54 + "inv3(s) ==
51.55 + rbit(rec(s)) = sbit(sen(s))
51.56 + --> (!m. sq(sen(s))=[] | m ~= hd(sq(sen(s)))
51.57 + --> count (rrcvd(rec s)) (sbit(sen(s)),m)
51.58 + + count (srch s) (sbit(sen(s)),m)
51.59 + <= count (rsent(rec s)) (~sbit(sen s)))"
51.60 +
51.61 +(* Lemma 5.4 *)
51.62 +definition "inv4(s) == rbit(rec(s)) = (~sbit(sen(s))) --> sq(sen(s)) ~= []"
51.63 +
51.64 +
51.65 +subsection {* Invariants *}
51.66 +
51.67 +declare le_SucI [simp]
51.68 +
51.69 +lemmas impl_ioas =
51.70 + impl_def sender_ioa_def receiver_ioa_def srch_ioa_thm [THEN eq_reflection]
51.71 + rsch_ioa_thm [THEN eq_reflection]
51.72 +
51.73 +lemmas "transitions" =
51.74 + sender_trans_def receiver_trans_def srch_trans_def rsch_trans_def
51.75 +
51.76 +
51.77 +lemmas [simp] =
51.78 + ioa_triple_proj starts_of_par trans_of_par4 in_sender_asig
51.79 + in_receiver_asig in_srch_asig in_rsch_asig
51.80 +
51.81 +declare let_weak_cong [cong]
51.82 +
51.83 +lemma [simp]:
51.84 + "fst(x) = sen(x)"
51.85 + "fst(snd(x)) = rec(x)"
51.86 + "fst(snd(snd(x))) = srch(x)"
51.87 + "snd(snd(snd(x))) = rsch(x)"
51.88 + by (simp_all add: sen_def rec_def srch_def rsch_def)
51.89 +
51.90 +lemma [simp]:
51.91 + "a:actions(sender_asig)
51.92 + | a:actions(receiver_asig)
51.93 + | a:actions(srch_asig)
51.94 + | a:actions(rsch_asig)"
51.95 + by (induct a) simp_all
51.96 +
51.97 +declare split_paired_All [simp del]
51.98 +
51.99 +
51.100 +(* Three Simp_sets in different sizes
51.101 +----------------------------------------------
51.102 +
51.103 +1) simpset() does not unfold the transition relations
51.104 +2) ss unfolds transition relations
51.105 +3) renname_ss unfolds transitions and the abstract channel *)
51.106 +
51.107 +ML {*
51.108 +val ss = @{simpset} addsimps @{thms "transitions"};
51.109 +val rename_ss = ss addsimps @{thms unfold_renaming};
51.110 +
51.111 +val tac = asm_simp_tac (ss addcongs [@{thm conj_cong}] addsplits [@{thm split_if}])
51.112 +val tac_ren = asm_simp_tac (rename_ss addcongs [@{thm conj_cong}] addsplits [@{thm split_if}])
51.113 +*}
51.114 +
51.115 +
51.116 +subsubsection {* Invariant 1 *}
51.117 +
51.118 +lemma raw_inv1: "invariant impl_ioa inv1"
51.119 +
51.120 +apply (unfold impl_ioas)
51.121 +apply (rule invariantI)
51.122 +apply (simp add: inv1_def hdr_sum_def srcvd_def ssent_def rsent_def rrcvd_def)
51.123 +
51.124 +apply (simp (no_asm) del: trans_of_par4 add: imp_conjR inv1_def)
51.125 +
51.126 +txt {* Split proof in two *}
51.127 +apply (rule conjI)
51.128 +
51.129 +(* First half *)
51.130 +apply (simp add: Impl.inv1_def split del: split_if)
51.131 +apply (induct_tac a)
51.132 +
51.133 +apply (tactic "EVERY1[tac, tac, tac, tac]")
51.134 +apply (tactic "tac 1")
51.135 +apply (tactic "tac_ren 1")
51.136 +
51.137 +txt {* 5 + 1 *}
51.138 +
51.139 +apply (tactic "tac 1")
51.140 +apply (tactic "tac_ren 1")
51.141 +
51.142 +txt {* 4 + 1 *}
51.143 +apply (tactic {* EVERY1[tac, tac, tac, tac] *})
51.144 +
51.145 +
51.146 +txt {* Now the other half *}
51.147 +apply (simp add: Impl.inv1_def split del: split_if)
51.148 +apply (induct_tac a)
51.149 +apply (tactic "EVERY1 [tac, tac]")
51.150 +
51.151 +txt {* detour 1 *}
51.152 +apply (tactic "tac 1")
51.153 +apply (tactic "tac_ren 1")
51.154 +apply (rule impI)
51.155 +apply (erule conjE)+
51.156 +apply (simp (no_asm_simp) add: hdr_sum_def Multiset.count_def Multiset.countm_nonempty_def
51.157 + split add: split_if)
51.158 +txt {* detour 2 *}
51.159 +apply (tactic "tac 1")
51.160 +apply (tactic "tac_ren 1")
51.161 +apply (rule impI)
51.162 +apply (erule conjE)+
51.163 +apply (simp add: Impl.hdr_sum_def Multiset.count_def Multiset.countm_nonempty_def
51.164 + Multiset.delm_nonempty_def split add: split_if)
51.165 +apply (rule allI)
51.166 +apply (rule conjI)
51.167 +apply (rule impI)
51.168 +apply hypsubst
51.169 +apply (rule pred_suc [THEN iffD1])
51.170 +apply (drule less_le_trans)
51.171 +apply (cut_tac eq_packet_imp_eq_hdr [unfolded Packet.hdr_def, THEN countm_props])
51.172 +apply assumption
51.173 +apply assumption
51.174 +
51.175 +apply (rule countm_done_delm [THEN mp, symmetric])
51.176 +apply (rule refl)
51.177 +apply (simp (no_asm_simp) add: Multiset.count_def)
51.178 +
51.179 +apply (rule impI)
51.180 +apply (simp add: neg_flip)
51.181 +apply hypsubst
51.182 +apply (rule countm_spurious_delm)
51.183 +apply (simp (no_asm))
51.184 +
51.185 +apply (tactic "EVERY1 [tac, tac, tac, tac, tac, tac]")
51.186 +
51.187 +done
51.188 +
51.189 +
51.190 +
51.191 +subsubsection {* INVARIANT 2 *}
51.192 +
51.193 +lemma raw_inv2: "invariant impl_ioa inv2"
51.194 +
51.195 + apply (rule invariantI1)
51.196 + txt {* Base case *}
51.197 + apply (simp add: inv2_def receiver_projections sender_projections impl_ioas)
51.198 +
51.199 + apply (simp (no_asm_simp) add: impl_ioas split del: split_if)
51.200 + apply (induct_tac "a")
51.201 +
51.202 + txt {* 10 cases. First 4 are simple, since state doesn't change *}
51.203 +
51.204 + ML_prf {* val tac2 = asm_full_simp_tac (ss addsimps [@{thm inv2_def}]) *}
51.205 +
51.206 + txt {* 10 - 7 *}
51.207 + apply (tactic "EVERY1 [tac2,tac2,tac2,tac2]")
51.208 + txt {* 6 *}
51.209 + apply (tactic {* forward_tac [rewrite_rule [@{thm Impl.inv1_def}]
51.210 + (@{thm raw_inv1} RS @{thm invariantE}) RS conjunct1] 1 *})
51.211 +
51.212 + txt {* 6 - 5 *}
51.213 + apply (tactic "EVERY1 [tac2,tac2]")
51.214 +
51.215 + txt {* 4 *}
51.216 + apply (tactic {* forward_tac [rewrite_rule [@{thm Impl.inv1_def}]
51.217 + (@{thm raw_inv1} RS @{thm invariantE}) RS conjunct1] 1 *})
51.218 + apply (tactic "tac2 1")
51.219 +
51.220 + txt {* 3 *}
51.221 + apply (tactic {* forward_tac [rewrite_rule [@{thm Impl.inv1_def}]
51.222 + (@{thm raw_inv1} RS @{thm invariantE})] 1 *})
51.223 +
51.224 + apply (tactic "tac2 1")
51.225 + apply (tactic {* fold_goals_tac [rewrite_rule [@{thm Packet.hdr_def}]
51.226 + (@{thm Impl.hdr_sum_def})] *})
51.227 + apply arith
51.228 +
51.229 + txt {* 2 *}
51.230 + apply (tactic "tac2 1")
51.231 + apply (tactic {* forward_tac [rewrite_rule [@{thm Impl.inv1_def}]
51.232 + (@{thm raw_inv1} RS @{thm invariantE}) RS conjunct1] 1 *})
51.233 + apply (intro strip)
51.234 + apply (erule conjE)+
51.235 + apply simp
51.236 +
51.237 + txt {* 1 *}
51.238 + apply (tactic "tac2 1")
51.239 + apply (tactic {* forward_tac [rewrite_rule [@{thm Impl.inv1_def}]
51.240 + (@{thm raw_inv1} RS @{thm invariantE}) RS conjunct2] 1 *})
51.241 + apply (intro strip)
51.242 + apply (erule conjE)+
51.243 + apply (tactic {* fold_goals_tac [rewrite_rule [@{thm Packet.hdr_def}] (@{thm Impl.hdr_sum_def})] *})
51.244 + apply simp
51.245 +
51.246 + done
51.247 +
51.248 +
51.249 +subsubsection {* INVARIANT 3 *}
51.250 +
51.251 +lemma raw_inv3: "invariant impl_ioa inv3"
51.252 +
51.253 + apply (rule invariantI)
51.254 + txt {* Base case *}
51.255 + apply (simp add: Impl.inv3_def receiver_projections sender_projections impl_ioas)
51.256 +
51.257 + apply (simp (no_asm_simp) add: impl_ioas split del: split_if)
51.258 + apply (induct_tac "a")
51.259 +
51.260 + ML_prf {* val tac3 = asm_full_simp_tac (ss addsimps [@{thm inv3_def}]) *}
51.261 +
51.262 + txt {* 10 - 8 *}
51.263 +
51.264 + apply (tactic "EVERY1[tac3,tac3,tac3]")
51.265 +
51.266 + apply (tactic "tac_ren 1")
51.267 + apply (intro strip, (erule conjE)+)
51.268 + apply hypsubst
51.269 + apply (erule exE)
51.270 + apply simp
51.271 +
51.272 + txt {* 7 *}
51.273 + apply (tactic "tac3 1")
51.274 + apply (tactic "tac_ren 1")
51.275 + apply force
51.276 +
51.277 + txt {* 6 - 3 *}
51.278 +
51.279 + apply (tactic "EVERY1[tac3,tac3,tac3,tac3]")
51.280 +
51.281 + txt {* 2 *}
51.282 + apply (tactic "asm_full_simp_tac ss 1")
51.283 + apply (simp (no_asm) add: inv3_def)
51.284 + apply (intro strip, (erule conjE)+)
51.285 + apply (rule imp_disjL [THEN iffD1])
51.286 + apply (rule impI)
51.287 + apply (tactic {* forward_tac [rewrite_rule [@{thm Impl.inv2_def}]
51.288 + (@{thm raw_inv2} RS @{thm invariantE})] 1 *})
51.289 + apply simp
51.290 + apply (erule conjE)+
51.291 + apply (rule_tac j = "count (ssent (sen s)) (~sbit (sen s))" and
51.292 + k = "count (rsent (rec s)) (sbit (sen s))" in le_trans)
51.293 + apply (tactic {* forward_tac [rewrite_rule [@{thm inv1_def}]
51.294 + (@{thm raw_inv1} RS @{thm invariantE}) RS conjunct2] 1 *})
51.295 + apply (simp add: hdr_sum_def Multiset.count_def)
51.296 + apply (rule add_le_mono)
51.297 + apply (rule countm_props)
51.298 + apply (simp (no_asm))
51.299 + apply (rule countm_props)
51.300 + apply (simp (no_asm))
51.301 + apply assumption
51.302 +
51.303 + txt {* 1 *}
51.304 + apply (tactic "tac3 1")
51.305 + apply (intro strip, (erule conjE)+)
51.306 + apply (rule imp_disjL [THEN iffD1])
51.307 + apply (rule impI)
51.308 + apply (tactic {* forward_tac [rewrite_rule [@{thm Impl.inv2_def}]
51.309 + (@{thm raw_inv2} RS @{thm invariantE})] 1 *})
51.310 + apply simp
51.311 + done
51.312 +
51.313 +
51.314 +subsubsection {* INVARIANT 4 *}
51.315 +
51.316 +lemma raw_inv4: "invariant impl_ioa inv4"
51.317 +
51.318 + apply (rule invariantI)
51.319 + txt {* Base case *}
51.320 + apply (simp add: Impl.inv4_def receiver_projections sender_projections impl_ioas)
51.321 +
51.322 + apply (simp (no_asm_simp) add: impl_ioas split del: split_if)
51.323 + apply (induct_tac "a")
51.324 +
51.325 + ML_prf {* val tac4 = asm_full_simp_tac (ss addsimps [@{thm inv4_def}]) *}
51.326 +
51.327 + txt {* 10 - 2 *}
51.328 +
51.329 + apply (tactic "EVERY1[tac4,tac4,tac4,tac4,tac4,tac4,tac4,tac4,tac4]")
51.330 +
51.331 + txt {* 2 b *}
51.332 +
51.333 + apply (intro strip, (erule conjE)+)
51.334 + apply (tactic {* forward_tac [rewrite_rule [@{thm Impl.inv2_def}]
51.335 + (@{thm raw_inv2} RS @{thm invariantE})] 1 *})
51.336 + apply simp
51.337 +
51.338 + txt {* 1 *}
51.339 + apply (tactic "tac4 1")
51.340 + apply (intro strip, (erule conjE)+)
51.341 + apply (rule ccontr)
51.342 + apply (tactic {* forward_tac [rewrite_rule [@{thm Impl.inv2_def}]
51.343 + (@{thm raw_inv2} RS @{thm invariantE})] 1 *})
51.344 + apply (tactic {* forward_tac [rewrite_rule [@{thm Impl.inv3_def}]
51.345 + (@{thm raw_inv3} RS @{thm invariantE})] 1 *})
51.346 + apply simp
51.347 + apply (erule_tac x = "m" in allE)
51.348 + apply simp
51.349 + done
51.350 +
51.351 +
51.352 +text {* rebind them *}
51.353 +
51.354 +lemmas inv1 = raw_inv1 [THEN invariantE, unfolded inv1_def]
51.355 + and inv2 = raw_inv2 [THEN invariantE, unfolded inv2_def]
51.356 + and inv3 = raw_inv3 [THEN invariantE, unfolded inv3_def]
51.357 + and inv4 = raw_inv4 [THEN invariantE, unfolded inv4_def]
51.358 +
51.359 +end
52.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
52.2 +++ b/src/HOL/HOLCF/IOA/NTP/Lemmas.thy Sat Nov 27 16:08:10 2010 -0800
52.3 @@ -0,0 +1,32 @@
52.4 +(* Title: HOL/IOA/NTP/Lemmas.thy
52.5 + Author: Tobias Nipkow & Konrad Slind
52.6 +*)
52.7 +
52.8 +theory Lemmas
52.9 +imports Main
52.10 +begin
52.11 +
52.12 +subsubsection {* Logic *}
52.13 +
52.14 +lemma neg_flip: "(X = (~ Y)) = ((~X) = Y)"
52.15 + by blast
52.16 +
52.17 +
52.18 +subsection {* Sets *}
52.19 +
52.20 +lemma set_lemmas:
52.21 + "f(x) : (UN x. {f(x)})"
52.22 + "f x y : (UN x y. {f x y})"
52.23 + "!!a. (!x. a ~= f(x)) ==> a ~: (UN x. {f(x)})"
52.24 + "!!a. (!x y. a ~= f x y) ==> a ~: (UN x y. {f x y})"
52.25 + by auto
52.26 +
52.27 +
52.28 +subsection {* Arithmetic *}
52.29 +
52.30 +lemma pred_suc: "0<x ==> (x - 1 = y) = (x = Suc(y))"
52.31 + by (simp add: diff_Suc split add: nat.split)
52.32 +
52.33 +lemmas [simp] = hd_append set_lemmas
52.34 +
52.35 +end
53.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
53.2 +++ b/src/HOL/HOLCF/IOA/NTP/Multiset.thy Sat Nov 27 16:08:10 2010 -0800
53.3 @@ -0,0 +1,95 @@
53.4 +(* Title: HOL/IOA/NTP/Multiset.thy
53.5 + Author: Tobias Nipkow & Konrad Slind
53.6 +*)
53.7 +
53.8 +header {* Axiomatic multisets *}
53.9 +
53.10 +theory Multiset
53.11 +imports Lemmas
53.12 +begin
53.13 +
53.14 +typedecl
53.15 + 'a multiset
53.16 +
53.17 +consts
53.18 +
53.19 + "{|}" :: "'a multiset" ("{|}")
53.20 + addm :: "['a multiset, 'a] => 'a multiset"
53.21 + delm :: "['a multiset, 'a] => 'a multiset"
53.22 + countm :: "['a multiset, 'a => bool] => nat"
53.23 + count :: "['a multiset, 'a] => nat"
53.24 +
53.25 +axioms
53.26 +
53.27 +delm_empty_def:
53.28 + "delm {|} x = {|}"
53.29 +
53.30 +delm_nonempty_def:
53.31 + "delm (addm M x) y == (if x=y then M else addm (delm M y) x)"
53.32 +
53.33 +countm_empty_def:
53.34 + "countm {|} P == 0"
53.35 +
53.36 +countm_nonempty_def:
53.37 + "countm (addm M x) P == countm M P + (if P x then Suc 0 else 0)"
53.38 +
53.39 +count_def:
53.40 + "count M x == countm M (%y. y = x)"
53.41 +
53.42 +"induction":
53.43 + "[| P({|}); !!M x. P(M) ==> P(addm M x) |] ==> P(M)"
53.44 +
53.45 +lemma count_empty:
53.46 + "count {|} x = 0"
53.47 + by (simp add: Multiset.count_def Multiset.countm_empty_def)
53.48 +
53.49 +lemma count_addm_simp:
53.50 + "count (addm M x) y = (if y=x then Suc(count M y) else count M y)"
53.51 + by (simp add: Multiset.count_def Multiset.countm_nonempty_def)
53.52 +
53.53 +lemma count_leq_addm: "count M y <= count (addm M x) y"
53.54 + by (simp add: count_addm_simp)
53.55 +
53.56 +lemma count_delm_simp:
53.57 + "count (delm M x) y = (if y=x then count M y - 1 else count M y)"
53.58 +apply (unfold Multiset.count_def)
53.59 +apply (rule_tac M = "M" in Multiset.induction)
53.60 +apply (simp (no_asm_simp) add: Multiset.delm_empty_def Multiset.countm_empty_def)
53.61 +apply (simp add: Multiset.delm_nonempty_def Multiset.countm_nonempty_def)
53.62 +apply safe
53.63 +apply simp
53.64 +done
53.65 +
53.66 +lemma countm_props: "!!M. (!x. P(x) --> Q(x)) ==> (countm M P <= countm M Q)"
53.67 +apply (rule_tac M = "M" in Multiset.induction)
53.68 + apply (simp (no_asm) add: Multiset.countm_empty_def)
53.69 +apply (simp (no_asm) add: Multiset.countm_nonempty_def)
53.70 +apply auto
53.71 +done
53.72 +
53.73 +lemma countm_spurious_delm: "!!P. ~P(obj) ==> countm M P = countm (delm M obj) P"
53.74 + apply (rule_tac M = "M" in Multiset.induction)
53.75 + apply (simp (no_asm) add: Multiset.delm_empty_def Multiset.countm_empty_def)
53.76 + apply (simp (no_asm_simp) add: Multiset.countm_nonempty_def Multiset.delm_nonempty_def)
53.77 + done
53.78 +
53.79 +
53.80 +lemma pos_count_imp_pos_countm [rule_format (no_asm)]: "!!P. P(x) ==> 0<count M x --> countm M P > 0"
53.81 + apply (rule_tac M = "M" in Multiset.induction)
53.82 + apply (simp (no_asm) add: Multiset.delm_empty_def Multiset.count_def Multiset.countm_empty_def)
53.83 + apply (simp add: Multiset.count_def Multiset.delm_nonempty_def Multiset.countm_nonempty_def)
53.84 + done
53.85 +
53.86 +lemma countm_done_delm:
53.87 + "!!P. P(x) ==> 0<count M x --> countm (delm M x) P = countm M P - 1"
53.88 + apply (rule_tac M = "M" in Multiset.induction)
53.89 + apply (simp (no_asm) add: Multiset.delm_empty_def Multiset.countm_empty_def)
53.90 + apply (simp (no_asm_simp) add: count_addm_simp Multiset.delm_nonempty_def Multiset.countm_nonempty_def pos_count_imp_pos_countm)
53.91 + apply auto
53.92 + done
53.93 +
53.94 +
53.95 +declare count_addm_simp [simp] count_delm_simp [simp]
53.96 + Multiset.countm_empty_def [simp] Multiset.delm_empty_def [simp] count_empty [simp]
53.97 +
53.98 +end
54.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
54.2 +++ b/src/HOL/HOLCF/IOA/NTP/Packet.thy Sat Nov 27 16:08:10 2010 -0800
54.3 @@ -0,0 +1,27 @@
54.4 +(* Title: HOL/IOA/NTP/Packet.thy
54.5 + Author: Tobias Nipkow & Konrad Slind
54.6 +*)
54.7 +
54.8 +theory Packet
54.9 +imports Multiset
54.10 +begin
54.11 +
54.12 +types
54.13 + 'msg packet = "bool * 'msg"
54.14 +
54.15 +definition
54.16 + hdr :: "'msg packet => bool" where
54.17 + "hdr == fst"
54.18 +
54.19 +definition
54.20 + msg :: "'msg packet => 'msg" where
54.21 + "msg == snd"
54.22 +
54.23 +
54.24 +text {* Instantiation of a tautology? *}
54.25 +lemma eq_packet_imp_eq_hdr: "!x. x = packet --> hdr(x) = hdr(packet)"
54.26 + by simp
54.27 +
54.28 +declare hdr_def [simp] msg_def [simp]
54.29 +
54.30 +end
55.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
55.2 +++ b/src/HOL/HOLCF/IOA/NTP/ROOT.ML Sat Nov 27 16:08:10 2010 -0800
55.3 @@ -0,0 +1,9 @@
55.4 +(* Title: HOLCF/IOA/NTP/ROOT.ML
55.5 + Author: Tobias Nipkow & Konrad Slind
55.6 +
55.7 +This is the ROOT file for a network transmission protocol (NTP
55.8 +subdirectory), performed in the I/O automata formalization by Olaf
55.9 +Mueller.
55.10 +*)
55.11 +
55.12 +use_thys ["Correctness"];
56.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
56.2 +++ b/src/HOL/HOLCF/IOA/NTP/Read_me Sat Nov 27 16:08:10 2010 -0800
56.3 @@ -0,0 +1,167 @@
56.4 +Isabelle Verification of a protocol using IOA.
56.5 +
56.6 +------------------------------------------------------------------------------
56.7 +
56.8 +The System.
56.9 +
56.10 +The system being proved correct is a parallel composition of 4 processes:
56.11 +
56.12 + Sender || Schannel || Receiver || Rchannel
56.13 +
56.14 +Accordingly, the system state is a 4-tuple:
56.15 +
56.16 + (Sender_state, Schannel_state, Receiver_state, Rchannel_state)
56.17 +
56.18 +------------------------------------------------------------------------------
56.19 +Packets.
56.20 +
56.21 +The objects going over the medium from Sender to Receiver are modelled
56.22 +with the type
56.23 +
56.24 + 'm packet = bool * 'm
56.25 +
56.26 +This expresses that messages (modelled by polymorphic type "'m") are
56.27 +sent with a single header bit. Packet fields are accessed by
56.28 +
56.29 + hdr<b,m> = b
56.30 + mesg<b,m> = m
56.31 +------------------------------------------------------------------------------
56.32 +
56.33 +The Sender.
56.34 +
56.35 +The state of the process "Sender" is a 5-tuple:
56.36 +
56.37 + 1. messages : 'm list (* sq *)
56.38 + 2. sent : bool multiset (* ssent *)
56.39 + 3. received : bool multiset (* srcvd *)
56.40 + 4. header : bool (* sbit *)
56.41 + 5. mode : bool (* ssending *)
56.42 +
56.43 +
56.44 +The Receiver.
56.45 +
56.46 +The state of the process "Receiver" is a 5-tuple:
56.47 +
56.48 + 1. messages : 'm list (* rq *)
56.49 + 2. replies : bool multiset (* rsent *)
56.50 + 3. received : 'm packet multiset (* rrcvd *)
56.51 + 4. header : bool (* rbit *)
56.52 + 5. mode : bool (* rsending *)
56.53 +
56.54 +
56.55 +The Channels.
56.56 +
56.57 +The Sender and Receiver each have a proprietary channel, named
56.58 +"Schannel" and "Rchannel" respectively. The messages sent by the Sender
56.59 +and Receiver are never lost, but the channels may mix them
56.60 +up. Accordingly, multisets are used in modelling the state of the
56.61 +channels. The state of "Schannel" is modelled with the following type:
56.62 +
56.63 + 'm packet multiset
56.64 +
56.65 +The state of "Rchannel" is modelled with the following type:
56.66 +
56.67 + bool multiset
56.68 +
56.69 +This expresses that replies from the Receiver are just one bit.
56.70 +
56.71 +Both Channels are instances of an abstract channel, that is modelled with
56.72 +the type
56.73 +
56.74 + 'a multiset.
56.75 +
56.76 +------------------------------------------------------------------------------
56.77 +
56.78 +The events.
56.79 +
56.80 +An `execution' of the system is modelled by a sequence of
56.81 +
56.82 + <system_state, action, system_state>
56.83 +
56.84 +transitions. The actions, or events, of the system are described by the
56.85 +following ML-style datatype declaration:
56.86 +
56.87 + 'm action = S_msg ('m) (* Rqt for Sender to send mesg *)
56.88 + | R_msg ('m) (* Mesg taken from Receiver's queue *)
56.89 + | S_pkt_sr ('m packet) (* Packet arrives in Schannel *)
56.90 + | R_pkt_sr ('m packet) (* Packet leaves Schannel *)
56.91 + | S_pkt_rs (bool) (* Packet arrives in Rchannel *)
56.92 + | R_pkt_rs (bool) (* Packet leaves Rchannel *)
56.93 + | C_m_s (* Change mode in Sender *)
56.94 + | C_m_r (* Change mode in Receiver *)
56.95 + | C_r_s (* Change round in Sender *)
56.96 + | C_r_r ('m) (* Change round in Receiver *)
56.97 +
56.98 +------------------------------------------------------------------------------
56.99 +
56.100 +The Specification.
56.101 +
56.102 +The abstract description of system behaviour is given by defining an
56.103 +IO/automaton named "Spec". The state of Spec is a message queue,
56.104 +modelled as an "'m list". The only actions performed in the abstract
56.105 +system are: "S_msg(m)" (putting message "m" at the end of the queue);
56.106 +and "R_msg(m)" (taking message "m" from the head of the queue).
56.107 +
56.108 +
56.109 +------------------------------------------------------------------------------
56.110 +
56.111 +The Verification.
56.112 +
56.113 +The verification proceeds by showing that a certain mapping ("hom") from
56.114 +the concrete system state to the abstract system state is a `weak
56.115 +possibilities map` from "Impl" to "Spec".
56.116 +
56.117 +
56.118 + hom : (S_state * Sch_state * R_state * Rch_state) -> queue
56.119 +
56.120 +The verification depends on several system invariants that relate the
56.121 +states of the 4 processes. These invariants must hold in all reachable
56.122 +states of the system. These invariants are difficult to make sense of;
56.123 +however, we attempt to give loose English paraphrases of them.
56.124 +
56.125 +Invariant 1.
56.126 +
56.127 +This expresses that no packets from the Receiver to the Sender are
56.128 +dropped by Rchannel. The analogous statement for Schannel is also true.
56.129 +
56.130 + !b. R.replies b = S.received b + Rch b
56.131 + /\
56.132 + !pkt. S.sent(hdr(pkt)) = R.received(hdr(b)) + Sch(pkt)
56.133 +
56.134 +
56.135 +Invariant 2.
56.136 +
56.137 +This expresses a complicated relationship about how many messages are
56.138 +sent and header bits.
56.139 +
56.140 + R.header = S.header
56.141 + /\ S.mode = SENDING
56.142 + /\ R.replies (flip S.header) <= S.sent (flip S.header)
56.143 + /\ S.sent (flip S.header) <= R.replies header
56.144 + OR
56.145 + R.header = flip S.header
56.146 + /\ R.mode = SENDING
56.147 + /\ S.sent (flip S.header) <= R.replies S.header
56.148 + /\ R.replies S.header <= S.sent S.header
56.149 +
56.150 +
56.151 +Invariant 3.
56.152 +
56.153 +The number of incoming messages in the Receiver plus the number of those
56.154 +messages in transit (in Schannel) is not greater than the number of
56.155 +replies, provided the message isn't current and the header bits agree.
56.156 +
56.157 + let mesg = <S.header, m>
56.158 + in
56.159 + R.header = S.header
56.160 + ==>
56.161 + !m. (S.messages = [] \/ m ~= hd S.messages)
56.162 + ==> R.received mesg + Sch mesg <= R.replies (flip S.header)
56.163 +
56.164 +
56.165 +Invariant 4.
56.166 +
56.167 +If the headers are opposite, then the Sender queue has a message in it.
56.168 +
56.169 + R.header = flip S.header ==> S.messages ~= []
56.170 +
57.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
57.2 +++ b/src/HOL/HOLCF/IOA/NTP/Receiver.thy Sat Nov 27 16:08:10 2010 -0800
57.3 @@ -0,0 +1,96 @@
57.4 +(* Title: HOL/IOA/NTP/Receiver.thy
57.5 + Author: Tobias Nipkow & Konrad Slind
57.6 +*)
57.7 +
57.8 +header {* The implementation: receiver *}
57.9 +
57.10 +theory Receiver
57.11 +imports IOA Action
57.12 +begin
57.13 +
57.14 +types
57.15 +
57.16 +'m receiver_state
57.17 += "'m list * bool multiset * 'm packet multiset * bool * bool"
57.18 +(* messages #replies #received header mode *)
57.19 +
57.20 +definition rq :: "'m receiver_state => 'm list" where "rq == fst"
57.21 +definition rsent :: "'m receiver_state => bool multiset" where "rsent == fst o snd"
57.22 +definition rrcvd :: "'m receiver_state => 'm packet multiset" where "rrcvd == fst o snd o snd"
57.23 +definition rbit :: "'m receiver_state => bool" where "rbit == fst o snd o snd o snd"
57.24 +definition rsending :: "'m receiver_state => bool" where "rsending == snd o snd o snd o snd"
57.25 +
57.26 +definition
57.27 + receiver_asig :: "'m action signature" where
57.28 + "receiver_asig =
57.29 + (UN pkt. {R_pkt(pkt)},
57.30 + (UN m. {R_msg(m)}) Un (UN b. {S_ack(b)}),
57.31 + insert C_m_r (UN m. {C_r_r(m)}))"
57.32 +
57.33 +definition
57.34 + receiver_trans:: "('m action, 'm receiver_state)transition set" where
57.35 +"receiver_trans =
57.36 + {tr. let s = fst(tr);
57.37 + t = snd(snd(tr))
57.38 + in
57.39 + case fst(snd(tr))
57.40 + of
57.41 + S_msg(m) => False |
57.42 + R_msg(m) => rq(s) = (m # rq(t)) &
57.43 + rsent(t)=rsent(s) &
57.44 + rrcvd(t)=rrcvd(s) &
57.45 + rbit(t)=rbit(s) &
57.46 + rsending(t)=rsending(s) |
57.47 + S_pkt(pkt) => False |
57.48 + R_pkt(pkt) => rq(t) = rq(s) &
57.49 + rsent(t) = rsent(s) &
57.50 + rrcvd(t) = addm (rrcvd s) pkt &
57.51 + rbit(t) = rbit(s) &
57.52 + rsending(t) = rsending(s) |
57.53 + S_ack(b) => b = rbit(s) &
57.54 + rq(t) = rq(s) &
57.55 + rsent(t) = addm (rsent s) (rbit s) &
57.56 + rrcvd(t) = rrcvd(s) &
57.57 + rbit(t)=rbit(s) &
57.58 + rsending(s) &
57.59 + rsending(t) |
57.60 + R_ack(b) => False |
57.61 + C_m_s => False |
57.62 + C_m_r => count (rsent s) (~rbit s) < countm (rrcvd s) (%y. hdr(y)=rbit(s)) &
57.63 + rq(t) = rq(s) &
57.64 + rsent(t)=rsent(s) &
57.65 + rrcvd(t)=rrcvd(s) &
57.66 + rbit(t)=rbit(s) &
57.67 + rsending(s) &
57.68 + ~rsending(t) |
57.69 + C_r_s => False |
57.70 + C_r_r(m) => count (rsent s) (rbit s) <= countm (rrcvd s) (%y. hdr(y)=rbit(s)) &
57.71 + count (rsent s) (~rbit s) < count (rrcvd s) (rbit(s),m) &
57.72 + rq(t) = rq(s)@[m] &
57.73 + rsent(t)=rsent(s) &
57.74 + rrcvd(t)=rrcvd(s) &
57.75 + rbit(t) = (~rbit(s)) &
57.76 + ~rsending(s) &
57.77 + rsending(t)}"
57.78 +
57.79 +definition
57.80 + receiver_ioa :: "('m action, 'm receiver_state)ioa" where
57.81 + "receiver_ioa =
57.82 + (receiver_asig, {([],{|},{|},False,False)}, receiver_trans,{},{})"
57.83 +
57.84 +lemma in_receiver_asig:
57.85 + "S_msg(m) ~: actions(receiver_asig)"
57.86 + "R_msg(m) : actions(receiver_asig)"
57.87 + "S_pkt(pkt) ~: actions(receiver_asig)"
57.88 + "R_pkt(pkt) : actions(receiver_asig)"
57.89 + "S_ack(b) : actions(receiver_asig)"
57.90 + "R_ack(b) ~: actions(receiver_asig)"
57.91 + "C_m_s ~: actions(receiver_asig)"
57.92 + "C_m_r : actions(receiver_asig)"
57.93 + "C_r_s ~: actions(receiver_asig)"
57.94 + "C_r_r(m) : actions(receiver_asig)"
57.95 + by (simp_all add: receiver_asig_def actions_def asig_projections)
57.96 +
57.97 +lemmas receiver_projections = rq_def rsent_def rrcvd_def rbit_def rsending_def
57.98 +
57.99 +end
58.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
58.2 +++ b/src/HOL/HOLCF/IOA/NTP/Sender.thy Sat Nov 27 16:08:10 2010 -0800
58.3 @@ -0,0 +1,92 @@
58.4 +(* Title: HOL/IOA/NTP/Sender.thy
58.5 + Author: Tobias Nipkow & Konrad Slind
58.6 +*)
58.7 +
58.8 +header {* The implementation: sender *}
58.9 +
58.10 +theory Sender
58.11 +imports IOA Action
58.12 +begin
58.13 +
58.14 +types
58.15 +'m sender_state = "'m list * bool multiset * bool multiset * bool * bool"
58.16 +(* messages #sent #received header mode *)
58.17 +
58.18 +definition sq :: "'m sender_state => 'm list" where "sq = fst"
58.19 +definition ssent :: "'m sender_state => bool multiset" where "ssent = fst o snd"
58.20 +definition srcvd :: "'m sender_state => bool multiset" where "srcvd = fst o snd o snd"
58.21 +definition sbit :: "'m sender_state => bool" where "sbit = fst o snd o snd o snd"
58.22 +definition ssending :: "'m sender_state => bool" where "ssending = snd o snd o snd o snd"
58.23 +
58.24 +definition
58.25 + sender_asig :: "'m action signature" where
58.26 + "sender_asig = ((UN m. {S_msg(m)}) Un (UN b. {R_ack(b)}),
58.27 + UN pkt. {S_pkt(pkt)},
58.28 + {C_m_s,C_r_s})"
58.29 +
58.30 +definition
58.31 + sender_trans :: "('m action, 'm sender_state)transition set" where
58.32 + "sender_trans =
58.33 + {tr. let s = fst(tr);
58.34 + t = snd(snd(tr))
58.35 + in case fst(snd(tr))
58.36 + of
58.37 + S_msg(m) => sq(t)=sq(s)@[m] &
58.38 + ssent(t)=ssent(s) &
58.39 + srcvd(t)=srcvd(s) &
58.40 + sbit(t)=sbit(s) &
58.41 + ssending(t)=ssending(s) |
58.42 + R_msg(m) => False |
58.43 + S_pkt(pkt) => hdr(pkt) = sbit(s) &
58.44 + (? Q. sq(s) = (msg(pkt)#Q)) &
58.45 + sq(t) = sq(s) &
58.46 + ssent(t) = addm (ssent s) (sbit s) &
58.47 + srcvd(t) = srcvd(s) &
58.48 + sbit(t) = sbit(s) &
58.49 + ssending(s) &
58.50 + ssending(t) |
58.51 + R_pkt(pkt) => False |
58.52 + S_ack(b) => False |
58.53 + R_ack(b) => sq(t)=sq(s) &
58.54 + ssent(t)=ssent(s) &
58.55 + srcvd(t) = addm (srcvd s) b &
58.56 + sbit(t)=sbit(s) &
58.57 + ssending(t)=ssending(s) |
58.58 + C_m_s => count (ssent s) (~sbit s) < count (srcvd s) (~sbit s) &
58.59 + sq(t)=sq(s) &
58.60 + ssent(t)=ssent(s) &
58.61 + srcvd(t)=srcvd(s) &
58.62 + sbit(t)=sbit(s) &
58.63 + ssending(s) &
58.64 + ~ssending(t) |
58.65 + C_m_r => False |
58.66 + C_r_s => count (ssent s) (sbit s) <= count (srcvd s) (~sbit s) &
58.67 + sq(t)=tl(sq(s)) &
58.68 + ssent(t)=ssent(s) &
58.69 + srcvd(t)=srcvd(s) &
58.70 + sbit(t) = (~sbit(s)) &
58.71 + ~ssending(s) &
58.72 + ssending(t) |
58.73 + C_r_r(m) => False}"
58.74 +
58.75 +definition
58.76 + sender_ioa :: "('m action, 'm sender_state)ioa" where
58.77 + "sender_ioa =
58.78 + (sender_asig, {([],{|},{|},False,True)}, sender_trans,{},{})"
58.79 +
58.80 +lemma in_sender_asig:
58.81 + "S_msg(m) : actions(sender_asig)"
58.82 + "R_msg(m) ~: actions(sender_asig)"
58.83 + "S_pkt(pkt) : actions(sender_asig)"
58.84 + "R_pkt(pkt) ~: actions(sender_asig)"
58.85 + "S_ack(b) ~: actions(sender_asig)"
58.86 + "R_ack(b) : actions(sender_asig)"
58.87 + "C_m_s : actions(sender_asig)"
58.88 + "C_m_r ~: actions(sender_asig)"
58.89 + "C_r_s : actions(sender_asig)"
58.90 + "C_r_r(m) ~: actions(sender_asig)"
58.91 + by (simp_all add: sender_asig_def actions_def asig_projections)
58.92 +
58.93 +lemmas sender_projections = sq_def ssent_def srcvd_def sbit_def ssending_def
58.94 +
58.95 +end
59.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
59.2 +++ b/src/HOL/HOLCF/IOA/NTP/Spec.thy Sat Nov 27 16:08:10 2010 -0800
59.3 @@ -0,0 +1,40 @@
59.4 +(* Title: HOL/IOA/NTP/Spec.thy
59.5 + Author: Tobias Nipkow & Konrad Slind
59.6 +*)
59.7 +
59.8 +header {* The specification of reliable transmission *}
59.9 +
59.10 +theory Spec
59.11 +imports IOA Action
59.12 +begin
59.13 +
59.14 +definition
59.15 + spec_sig :: "'m action signature" where
59.16 + sig_def: "spec_sig = (UN m.{S_msg(m)},
59.17 + UN m.{R_msg(m)},
59.18 + {})"
59.19 +
59.20 +definition
59.21 + spec_trans :: "('m action, 'm list)transition set" where
59.22 + trans_def: "spec_trans =
59.23 + {tr. let s = fst(tr);
59.24 + t = snd(snd(tr))
59.25 + in
59.26 + case fst(snd(tr))
59.27 + of
59.28 + S_msg(m) => t = s@[m] |
59.29 + R_msg(m) => s = (m#t) |
59.30 + S_pkt(pkt) => False |
59.31 + R_pkt(pkt) => False |
59.32 + S_ack(b) => False |
59.33 + R_ack(b) => False |
59.34 + C_m_s => False |
59.35 + C_m_r => False |
59.36 + C_r_s => False |
59.37 + C_r_r(m) => False}"
59.38 +
59.39 +definition
59.40 + spec_ioa :: "('m action, 'm list)ioa" where
59.41 + ioa_def: "spec_ioa = (spec_sig, {[]}, spec_trans,{},{})"
59.42 +
59.43 +end
60.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
60.2 +++ b/src/HOL/HOLCF/IOA/README.html Sat Nov 27 16:08:10 2010 -0800
60.3 @@ -0,0 +1,24 @@
60.4 +<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN" "http://www.w3.org/TR/html4/loose.dtd">
60.5 +
60.6 +<HTML>
60.7 +
60.8 +<HEAD>
60.9 + <meta http-equiv="Content-Type" content="text/html; charset=iso-8859-1">
60.10 + <TITLE>HOLCF/IOA/README</TITLE>
60.11 +</HEAD>
60.12 +
60.13 +<BODY>
60.14 +
60.15 +<H3>IOA: A formalization of I/O automata in HOLCF</H3>
60.16 +
60.17 +Author: Olaf Müller<BR>
60.18 +Copyright 1997 Technische Universität München<P>
60.19 +
60.20 +The distribution contains simulation relations, temporal logic, and an abstraction theory.
60.21 +Everything is based upon a domain-theoretic model of finite and infinite sequences.
60.22 +<p>
60.23 +For details see the <A HREF="http://www4.informatik.tu-muenchen.de/~isabelle/IOA/">IOA project</a>.
60.24 +
60.25 +</BODY></HTML>
60.26 +
60.27 +
61.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
61.2 +++ b/src/HOL/HOLCF/IOA/ROOT.ML Sat Nov 27 16:08:10 2010 -0800
61.3 @@ -0,0 +1,8 @@
61.4 +(* Title: HOLCF/IOA/ROOT.ML
61.5 + Author: Olaf Mueller
61.6 +
61.7 +Formalization of a semantic model of I/O-Automata. See README.html
61.8 +for details.
61.9 +*)
61.10 +
61.11 +use_thys ["meta_theory/Abstraction"];
62.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
62.2 +++ b/src/HOL/HOLCF/IOA/Storage/Action.thy Sat Nov 27 16:08:10 2010 -0800
62.3 @@ -0,0 +1,16 @@
62.4 +(* Title: HOLCF/IOA/ABP/Action.thy
62.5 + Author: Olaf Müller
62.6 +*)
62.7 +
62.8 +header {* The set of all actions of the system *}
62.9 +
62.10 +theory Action
62.11 +imports Main
62.12 +begin
62.13 +
62.14 +datatype action = New | Loc nat | Free nat
62.15 +
62.16 +lemma [cong]: "!!x. x = y ==> action_case a b c x = action_case a b c y"
62.17 + by simp
62.18 +
62.19 +end
63.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
63.2 +++ b/src/HOL/HOLCF/IOA/Storage/Correctness.thy Sat Nov 27 16:08:10 2010 -0800
63.3 @@ -0,0 +1,75 @@
63.4 +(* Title: HOL/IOA/example/Correctness.thy
63.5 + Author: Olaf Müller
63.6 +*)
63.7 +
63.8 +header {* Correctness Proof *}
63.9 +
63.10 +theory Correctness
63.11 +imports SimCorrectness Spec Impl
63.12 +begin
63.13 +
63.14 +default_sort type
63.15 +
63.16 +definition
63.17 + sim_relation :: "((nat * bool) * (nat set * bool)) set" where
63.18 + "sim_relation = {qua. let c = fst qua; a = snd qua ;
63.19 + k = fst c; b = snd c;
63.20 + used = fst a; c = snd a
63.21 + in
63.22 + (! l:used. l < k) & b=c}"
63.23 +
63.24 +declare split_paired_Ex [simp del]
63.25 +
63.26 +
63.27 +(* Idea: instead of impl_con_lemma do not rewrite impl_ioa, but derive
63.28 + simple lemmas asig_of impl_ioa = impl_sig, trans_of impl_ioa = impl_trans
63.29 + Idea: ?ex. move .. should be generally replaced by a step via a subst tac if desired,
63.30 + as this can be done globally *)
63.31 +
63.32 +lemma issimulation:
63.33 + "is_simulation sim_relation impl_ioa spec_ioa"
63.34 +apply (simp (no_asm) add: is_simulation_def)
63.35 +apply (rule conjI)
63.36 +txt {* start states *}
63.37 +apply (auto)[1]
63.38 +apply (rule_tac x = " ({},False) " in exI)
63.39 +apply (simp add: sim_relation_def starts_of_def spec_ioa_def impl_ioa_def)
63.40 +txt {* main-part *}
63.41 +apply (rule allI)+
63.42 +apply (rule imp_conj_lemma)
63.43 +apply (rename_tac k b used c k' b' a)
63.44 +apply (induct_tac "a")
63.45 +apply (simp_all (no_asm) add: sim_relation_def impl_ioa_def impl_trans_def trans_of_def)
63.46 +apply auto
63.47 +txt {* NEW *}
63.48 +apply (rule_tac x = "(used,True)" in exI)
63.49 +apply simp
63.50 +apply (rule transition_is_ex)
63.51 +apply (simp (no_asm) add: spec_ioa_def spec_trans_def trans_of_def)
63.52 +txt {* LOC *}
63.53 +apply (rule_tac x = " (used Un {k},False) " in exI)
63.54 +apply (simp add: less_SucI)
63.55 +apply (rule transition_is_ex)
63.56 +apply (simp (no_asm) add: spec_ioa_def spec_trans_def trans_of_def)
63.57 +apply fast
63.58 +txt {* FREE *}
63.59 +apply (rule_tac x = " (used - {nat},c) " in exI)
63.60 +apply simp
63.61 +apply (rule transition_is_ex)
63.62 +apply (simp (no_asm) add: spec_ioa_def spec_trans_def trans_of_def)
63.63 +done
63.64 +
63.65 +
63.66 +lemma implementation:
63.67 +"impl_ioa =<| spec_ioa"
63.68 +apply (unfold ioa_implements_def)
63.69 +apply (rule conjI)
63.70 +apply (simp (no_asm) add: impl_sig_def spec_sig_def impl_ioa_def spec_ioa_def
63.71 + asig_outputs_def asig_of_def asig_inputs_def)
63.72 +apply (rule trace_inclusion_for_simulations)
63.73 +apply (simp (no_asm) add: impl_sig_def spec_sig_def impl_ioa_def spec_ioa_def
63.74 + externals_def asig_outputs_def asig_of_def asig_inputs_def)
63.75 +apply (rule issimulation)
63.76 +done
63.77 +
63.78 +end
64.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
64.2 +++ b/src/HOL/HOLCF/IOA/Storage/Impl.thy Sat Nov 27 16:08:10 2010 -0800
64.3 @@ -0,0 +1,39 @@
64.4 +(* Title: HOL/IOA/example/Spec.thy
64.5 + Author: Olaf Müller
64.6 +*)
64.7 +
64.8 +header {* The implementation of a memory *}
64.9 +
64.10 +theory Impl
64.11 +imports IOA Action
64.12 +begin
64.13 +
64.14 +definition
64.15 + impl_sig :: "action signature" where
64.16 + "impl_sig = (UN l.{Free l} Un {New},
64.17 + UN l.{Loc l},
64.18 + {})"
64.19 +
64.20 +definition
64.21 + impl_trans :: "(action, nat * bool)transition set" where
64.22 + "impl_trans =
64.23 + {tr. let s = fst(tr); k = fst s; b = snd s;
64.24 + t = snd(snd(tr)); k' = fst t; b' = snd t
64.25 + in
64.26 + case fst(snd(tr))
64.27 + of
64.28 + New => k' = k & b' |
64.29 + Loc l => b & l= k & k'= (Suc k) & ~b' |
64.30 + Free l => k'=k & b'=b}"
64.31 +
64.32 +definition
64.33 + impl_ioa :: "(action, nat * bool)ioa" where
64.34 + "impl_ioa = (impl_sig, {(0,False)}, impl_trans,{},{})"
64.35 +
64.36 +lemma in_impl_asig:
64.37 + "New : actions(impl_sig) &
64.38 + Loc l : actions(impl_sig) &
64.39 + Free l : actions(impl_sig) "
64.40 + by (simp add: impl_sig_def actions_def asig_projections)
64.41 +
64.42 +end
65.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
65.2 +++ b/src/HOL/HOLCF/IOA/Storage/ROOT.ML Sat Nov 27 16:08:10 2010 -0800
65.3 @@ -0,0 +1,6 @@
65.4 +(* Title: HOLCF/IOA/Storage/ROOT.ML
65.5 + Author: Olaf Mueller
65.6 +
65.7 +Memory storage case study.
65.8 +*)
65.9 +use_thys ["Correctness"];
66.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
66.2 +++ b/src/HOL/HOLCF/IOA/Storage/Spec.thy Sat Nov 27 16:08:10 2010 -0800
66.3 @@ -0,0 +1,33 @@
66.4 +(* Title: HOL/IOA/example/Spec.thy
66.5 + Author: Olaf Müller
66.6 +*)
66.7 +
66.8 +header {* The specification of a memory *}
66.9 +
66.10 +theory Spec
66.11 +imports IOA Action
66.12 +begin
66.13 +
66.14 +definition
66.15 + spec_sig :: "action signature" where
66.16 + "spec_sig = (UN l.{Free l} Un {New},
66.17 + UN l.{Loc l},
66.18 + {})"
66.19 +
66.20 +definition
66.21 + spec_trans :: "(action, nat set * bool)transition set" where
66.22 + "spec_trans =
66.23 + {tr. let s = fst(tr); used = fst s; c = snd s;
66.24 + t = snd(snd(tr)); used' = fst t; c' = snd t
66.25 + in
66.26 + case fst(snd(tr))
66.27 + of
66.28 + New => used' = used & c' |
66.29 + Loc l => c & l~:used & used'= used Un {l} & ~c' |
66.30 + Free l => used'=used - {l} & c'=c}"
66.31 +
66.32 +definition
66.33 + spec_ioa :: "(action, nat set * bool)ioa" where
66.34 + "spec_ioa = (spec_sig, {({},False)}, spec_trans,{},{})"
66.35 +
66.36 +end
67.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
67.2 +++ b/src/HOL/HOLCF/IOA/ex/ROOT.ML Sat Nov 27 16:08:10 2010 -0800
67.3 @@ -0,0 +1,5 @@
67.4 +(* Title: HOLCF/IOA/ex/ROOT.ML
67.5 + Author: Olaf Mueller
67.6 +*)
67.7 +
67.8 +use_thys ["TrivEx", "TrivEx2"];
68.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
68.2 +++ b/src/HOL/HOLCF/IOA/ex/TrivEx.thy Sat Nov 27 16:08:10 2010 -0800
68.3 @@ -0,0 +1,72 @@
68.4 +(* Title: HOLCF/IOA/TrivEx.thy
68.5 + Author: Olaf Müller
68.6 +*)
68.7 +
68.8 +header {* Trivial Abstraction Example *}
68.9 +
68.10 +theory TrivEx
68.11 +imports Abstraction
68.12 +begin
68.13 +
68.14 +datatype action = INC
68.15 +
68.16 +definition
68.17 + C_asig :: "action signature" where
68.18 + "C_asig = ({},{INC},{})"
68.19 +definition
68.20 + C_trans :: "(action, nat)transition set" where
68.21 + "C_trans =
68.22 + {tr. let s = fst(tr);
68.23 + t = snd(snd(tr))
68.24 + in case fst(snd(tr))
68.25 + of
68.26 + INC => t = Suc(s)}"
68.27 +definition
68.28 + C_ioa :: "(action, nat)ioa" where
68.29 + "C_ioa = (C_asig, {0}, C_trans,{},{})"
68.30 +
68.31 +definition
68.32 + A_asig :: "action signature" where
68.33 + "A_asig = ({},{INC},{})"
68.34 +definition
68.35 + A_trans :: "(action, bool)transition set" where
68.36 + "A_trans =
68.37 + {tr. let s = fst(tr);
68.38 + t = snd(snd(tr))
68.39 + in case fst(snd(tr))
68.40 + of
68.41 + INC => t = True}"
68.42 +definition
68.43 + A_ioa :: "(action, bool)ioa" where
68.44 + "A_ioa = (A_asig, {False}, A_trans,{},{})"
68.45 +
68.46 +definition
68.47 + h_abs :: "nat => bool" where
68.48 + "h_abs n = (n~=0)"
68.49 +
68.50 +axiomatization where
68.51 + MC_result: "validIOA A_ioa (<>[] <%(b,a,c). b>)"
68.52 +
68.53 +lemma h_abs_is_abstraction:
68.54 + "is_abstraction h_abs C_ioa A_ioa"
68.55 +apply (unfold is_abstraction_def)
68.56 +apply (rule conjI)
68.57 +txt {* start states *}
68.58 +apply (simp (no_asm) add: h_abs_def starts_of_def C_ioa_def A_ioa_def)
68.59 +txt {* step case *}
68.60 +apply (rule allI)+
68.61 +apply (rule imp_conj_lemma)
68.62 +apply (simp (no_asm) add: trans_of_def C_ioa_def A_ioa_def C_trans_def A_trans_def)
68.63 +apply (induct_tac "a")
68.64 +apply (simp add: h_abs_def)
68.65 +done
68.66 +
68.67 +lemma TrivEx_abstraction: "validIOA C_ioa (<>[] <%(n,a,m). n~=0>)"
68.68 +apply (rule AbsRuleT1)
68.69 +apply (rule h_abs_is_abstraction)
68.70 +apply (rule MC_result)
68.71 +apply abstraction
68.72 +apply (simp add: h_abs_def)
68.73 +done
68.74 +
68.75 +end
69.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
69.2 +++ b/src/HOL/HOLCF/IOA/ex/TrivEx2.thy Sat Nov 27 16:08:10 2010 -0800
69.3 @@ -0,0 +1,102 @@
69.4 +(* Title: HOLCF/IOA/TrivEx.thy
69.5 + Author: Olaf Müller
69.6 +*)
69.7 +
69.8 +header {* Trivial Abstraction Example with fairness *}
69.9 +
69.10 +theory TrivEx2
69.11 +imports IOA Abstraction
69.12 +begin
69.13 +
69.14 +datatype action = INC
69.15 +
69.16 +definition
69.17 + C_asig :: "action signature" where
69.18 + "C_asig = ({},{INC},{})"
69.19 +definition
69.20 + C_trans :: "(action, nat)transition set" where
69.21 + "C_trans =
69.22 + {tr. let s = fst(tr);
69.23 + t = snd(snd(tr))
69.24 + in case fst(snd(tr))
69.25 + of
69.26 + INC => t = Suc(s)}"
69.27 +definition
69.28 + C_ioa :: "(action, nat)ioa" where
69.29 + "C_ioa = (C_asig, {0}, C_trans,{},{})"
69.30 +definition
69.31 + C_live_ioa :: "(action, nat)live_ioa" where
69.32 + "C_live_ioa = (C_ioa, WF C_ioa {INC})"
69.33 +
69.34 +definition
69.35 + A_asig :: "action signature" where
69.36 + "A_asig = ({},{INC},{})"
69.37 +definition
69.38 + A_trans :: "(action, bool)transition set" where
69.39 + "A_trans =
69.40 + {tr. let s = fst(tr);
69.41 + t = snd(snd(tr))
69.42 + in case fst(snd(tr))
69.43 + of
69.44 + INC => t = True}"
69.45 +definition
69.46 + A_ioa :: "(action, bool)ioa" where
69.47 + "A_ioa = (A_asig, {False}, A_trans,{},{})"
69.48 +definition
69.49 + A_live_ioa :: "(action, bool)live_ioa" where
69.50 + "A_live_ioa = (A_ioa, WF A_ioa {INC})"
69.51 +
69.52 +definition
69.53 + h_abs :: "nat => bool" where
69.54 + "h_abs n = (n~=0)"
69.55 +
69.56 +axiomatization where
69.57 + MC_result: "validLIOA (A_ioa,WF A_ioa {INC}) (<>[] <%(b,a,c). b>)"
69.58 +
69.59 +
69.60 +lemma h_abs_is_abstraction:
69.61 +"is_abstraction h_abs C_ioa A_ioa"
69.62 +apply (unfold is_abstraction_def)
69.63 +apply (rule conjI)
69.64 +txt {* start states *}
69.65 +apply (simp (no_asm) add: h_abs_def starts_of_def C_ioa_def A_ioa_def)
69.66 +txt {* step case *}
69.67 +apply (rule allI)+
69.68 +apply (rule imp_conj_lemma)
69.69 +apply (simp (no_asm) add: trans_of_def C_ioa_def A_ioa_def C_trans_def A_trans_def)
69.70 +apply (induct_tac "a")
69.71 +apply (simp (no_asm) add: h_abs_def)
69.72 +done
69.73 +
69.74 +
69.75 +lemma Enabled_implication:
69.76 + "!!s. Enabled A_ioa {INC} (h_abs s) ==> Enabled C_ioa {INC} s"
69.77 + apply (unfold Enabled_def enabled_def h_abs_def A_ioa_def C_ioa_def A_trans_def
69.78 + C_trans_def trans_of_def)
69.79 + apply auto
69.80 + done
69.81 +
69.82 +
69.83 +lemma h_abs_is_liveabstraction:
69.84 +"is_live_abstraction h_abs (C_ioa, WF C_ioa {INC}) (A_ioa, WF A_ioa {INC})"
69.85 +apply (unfold is_live_abstraction_def)
69.86 +apply auto
69.87 +txt {* is_abstraction *}
69.88 +apply (rule h_abs_is_abstraction)
69.89 +txt {* temp_weakening *}
69.90 +apply abstraction
69.91 +apply (erule Enabled_implication)
69.92 +done
69.93 +
69.94 +
69.95 +lemma TrivEx2_abstraction:
69.96 + "validLIOA C_live_ioa (<>[] <%(n,a,m). n~=0>)"
69.97 +apply (unfold C_live_ioa_def)
69.98 +apply (rule AbsRuleT2)
69.99 +apply (rule h_abs_is_liveabstraction)
69.100 +apply (rule MC_result)
69.101 +apply abstraction
69.102 +apply (simp add: h_abs_def)
69.103 +done
69.104 +
69.105 +end
70.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
70.2 +++ b/src/HOL/HOLCF/IOA/meta_theory/Abstraction.thy Sat Nov 27 16:08:10 2010 -0800
70.3 @@ -0,0 +1,615 @@
70.4 +(* Title: HOLCF/IOA/meta_theory/Abstraction.thy
70.5 + Author: Olaf Müller
70.6 +*)
70.7 +
70.8 +header {* Abstraction Theory -- tailored for I/O automata *}
70.9 +
70.10 +theory Abstraction
70.11 +imports LiveIOA
70.12 +begin
70.13 +
70.14 +default_sort type
70.15 +
70.16 +definition
70.17 + cex_abs :: "('s1 => 's2) => ('a,'s1)execution => ('a,'s2)execution" where
70.18 + "cex_abs f ex = (f (fst ex), Map (%(a,t). (a,f t))$(snd ex))"
70.19 +definition
70.20 + -- {* equals cex_abs on Sequences -- after ex2seq application *}
70.21 + cex_absSeq :: "('s1 => 's2) => ('a option,'s1)transition Seq => ('a option,'s2)transition Seq" where
70.22 + "cex_absSeq f = (%s. Map (%(s,a,t). (f s,a,f t))$s)"
70.23 +
70.24 +definition
70.25 + is_abstraction ::"[('s1=>'s2),('a,'s1)ioa,('a,'s2)ioa] => bool" where
70.26 + "is_abstraction f C A =
70.27 + ((!s:starts_of(C). f(s):starts_of(A)) &
70.28 + (!s t a. reachable C s & s -a--C-> t
70.29 + --> (f s) -a--A-> (f t)))"
70.30 +
70.31 +definition
70.32 + weakeningIOA :: "('a,'s2)ioa => ('a,'s1)ioa => ('s1 => 's2) => bool" where
70.33 + "weakeningIOA A C h = (!ex. ex : executions C --> cex_abs h ex : executions A)"
70.34 +definition
70.35 + temp_strengthening :: "('a,'s2)ioa_temp => ('a,'s1)ioa_temp => ('s1 => 's2) => bool" where
70.36 + "temp_strengthening Q P h = (!ex. (cex_abs h ex |== Q) --> (ex |== P))"
70.37 +definition
70.38 + temp_weakening :: "('a,'s2)ioa_temp => ('a,'s1)ioa_temp => ('s1 => 's2) => bool" where
70.39 + "temp_weakening Q P h = temp_strengthening (.~ Q) (.~ P) h"
70.40 +
70.41 +definition
70.42 + state_strengthening :: "('a,'s2)step_pred => ('a,'s1)step_pred => ('s1 => 's2) => bool" where
70.43 + "state_strengthening Q P h = (!s t a. Q (h(s),a,h(t)) --> P (s,a,t))"
70.44 +definition
70.45 + state_weakening :: "('a,'s2)step_pred => ('a,'s1)step_pred => ('s1 => 's2) => bool" where
70.46 + "state_weakening Q P h = state_strengthening (.~Q) (.~P) h"
70.47 +
70.48 +definition
70.49 + is_live_abstraction :: "('s1 => 's2) => ('a,'s1)live_ioa => ('a,'s2)live_ioa => bool" where
70.50 + "is_live_abstraction h CL AM =
70.51 + (is_abstraction h (fst CL) (fst AM) &
70.52 + temp_weakening (snd AM) (snd CL) h)"
70.53 +
70.54 +
70.55 +axiomatization where
70.56 +(* thm about ex2seq which is not provable by induction as ex2seq is not continous *)
70.57 +ex2seq_abs_cex:
70.58 + "ex2seq (cex_abs h ex) = cex_absSeq h (ex2seq ex)"
70.59 +
70.60 +axiomatization where
70.61 +(* analog to the proved thm strength_Box - proof skipped as trivial *)
70.62 +weak_Box:
70.63 +"temp_weakening P Q h
70.64 + ==> temp_weakening ([] P) ([] Q) h"
70.65 +
70.66 +axiomatization where
70.67 +(* analog to the proved thm strength_Next - proof skipped as trivial *)
70.68 +weak_Next:
70.69 +"temp_weakening P Q h
70.70 + ==> temp_weakening (Next P) (Next Q) h"
70.71 +
70.72 +
70.73 +subsection "cex_abs"
70.74 +
70.75 +lemma cex_abs_UU: "cex_abs f (s,UU) = (f s, UU)"
70.76 + by (simp add: cex_abs_def)
70.77 +
70.78 +lemma cex_abs_nil: "cex_abs f (s,nil) = (f s, nil)"
70.79 + by (simp add: cex_abs_def)
70.80 +
70.81 +lemma cex_abs_cons: "cex_abs f (s,(a,t)>>ex) = (f s, (a,f t) >> (snd (cex_abs f (t,ex))))"
70.82 + by (simp add: cex_abs_def)
70.83 +
70.84 +declare cex_abs_UU [simp] cex_abs_nil [simp] cex_abs_cons [simp]
70.85 +
70.86 +
70.87 +subsection "lemmas"
70.88 +
70.89 +lemma temp_weakening_def2: "temp_weakening Q P h = (! ex. (ex |== P) --> (cex_abs h ex |== Q))"
70.90 + apply (simp add: temp_weakening_def temp_strengthening_def NOT_def temp_sat_def satisfies_def)
70.91 + apply auto
70.92 + done
70.93 +
70.94 +lemma state_weakening_def2: "state_weakening Q P h = (! s t a. P (s,a,t) --> Q (h(s),a,h(t)))"
70.95 + apply (simp add: state_weakening_def state_strengthening_def NOT_def)
70.96 + apply auto
70.97 + done
70.98 +
70.99 +
70.100 +subsection "Abstraction Rules for Properties"
70.101 +
70.102 +lemma exec_frag_abstraction [rule_format]:
70.103 + "[| is_abstraction h C A |] ==>
70.104 + !s. reachable C s & is_exec_frag C (s,xs)
70.105 + --> is_exec_frag A (cex_abs h (s,xs))"
70.106 +apply (unfold cex_abs_def)
70.107 +apply simp
70.108 +apply (tactic {* pair_induct_tac @{context} "xs" [@{thm is_exec_frag_def}] 1 *})
70.109 +txt {* main case *}
70.110 +apply (auto dest: reachable.reachable_n simp add: is_abstraction_def)
70.111 +done
70.112 +
70.113 +
70.114 +lemma abs_is_weakening: "is_abstraction h C A ==> weakeningIOA A C h"
70.115 +apply (simp add: weakeningIOA_def)
70.116 +apply auto
70.117 +apply (simp add: executions_def)
70.118 +txt {* start state *}
70.119 +apply (rule conjI)
70.120 +apply (simp add: is_abstraction_def cex_abs_def)
70.121 +txt {* is-execution-fragment *}
70.122 +apply (erule exec_frag_abstraction)
70.123 +apply (simp add: reachable.reachable_0)
70.124 +done
70.125 +
70.126 +
70.127 +lemma AbsRuleT1: "[|is_abstraction h C A; validIOA A Q; temp_strengthening Q P h |]
70.128 + ==> validIOA C P"
70.129 +apply (drule abs_is_weakening)
70.130 +apply (simp add: weakeningIOA_def validIOA_def temp_strengthening_def)
70.131 +apply (auto simp add: split_paired_all)
70.132 +done
70.133 +
70.134 +
70.135 +(* FIX: Nach TLS.ML *)
70.136 +
70.137 +lemma IMPLIES_temp_sat: "(ex |== P .--> Q) = ((ex |== P) --> (ex |== Q))"
70.138 + by (simp add: IMPLIES_def temp_sat_def satisfies_def)
70.139 +
70.140 +lemma AND_temp_sat: "(ex |== P .& Q) = ((ex |== P) & (ex |== Q))"
70.141 + by (simp add: AND_def temp_sat_def satisfies_def)
70.142 +
70.143 +lemma OR_temp_sat: "(ex |== P .| Q) = ((ex |== P) | (ex |== Q))"
70.144 + by (simp add: OR_def temp_sat_def satisfies_def)
70.145 +
70.146 +lemma NOT_temp_sat: "(ex |== .~ P) = (~ (ex |== P))"
70.147 + by (simp add: NOT_def temp_sat_def satisfies_def)
70.148 +
70.149 +declare IMPLIES_temp_sat [simp] AND_temp_sat [simp] OR_temp_sat [simp] NOT_temp_sat [simp]
70.150 +
70.151 +
70.152 +lemma AbsRuleT2:
70.153 + "[|is_live_abstraction h (C,L) (A,M);
70.154 + validLIOA (A,M) Q; temp_strengthening Q P h |]
70.155 + ==> validLIOA (C,L) P"
70.156 +apply (unfold is_live_abstraction_def)
70.157 +apply auto
70.158 +apply (drule abs_is_weakening)
70.159 +apply (simp add: weakeningIOA_def temp_weakening_def2 validLIOA_def validIOA_def temp_strengthening_def)
70.160 +apply (auto simp add: split_paired_all)
70.161 +done
70.162 +
70.163 +
70.164 +lemma AbsRuleTImprove:
70.165 + "[|is_live_abstraction h (C,L) (A,M);
70.166 + validLIOA (A,M) (H1 .--> Q); temp_strengthening Q P h;
70.167 + temp_weakening H1 H2 h; validLIOA (C,L) H2 |]
70.168 + ==> validLIOA (C,L) P"
70.169 +apply (unfold is_live_abstraction_def)
70.170 +apply auto
70.171 +apply (drule abs_is_weakening)
70.172 +apply (simp add: weakeningIOA_def temp_weakening_def2 validLIOA_def validIOA_def temp_strengthening_def)
70.173 +apply (auto simp add: split_paired_all)
70.174 +done
70.175 +
70.176 +
70.177 +subsection "Correctness of safe abstraction"
70.178 +
70.179 +lemma abstraction_is_ref_map:
70.180 +"is_abstraction h C A ==> is_ref_map h C A"
70.181 +apply (unfold is_abstraction_def is_ref_map_def)
70.182 +apply auto
70.183 +apply (rule_tac x = "(a,h t) >>nil" in exI)
70.184 +apply (simp add: move_def)
70.185 +done
70.186 +
70.187 +
70.188 +lemma abs_safety: "[| inp(C)=inp(A); out(C)=out(A);
70.189 + is_abstraction h C A |]
70.190 + ==> C =<| A"
70.191 +apply (simp add: ioa_implements_def)
70.192 +apply (rule trace_inclusion)
70.193 +apply (simp (no_asm) add: externals_def)
70.194 +apply (auto)[1]
70.195 +apply (erule abstraction_is_ref_map)
70.196 +done
70.197 +
70.198 +
70.199 +subsection "Correctness of life abstraction"
70.200 +
70.201 +(* Reduces to Filter (Map fst x) = Filter (Map fst (Map (%(a,t). (a,x)) x),
70.202 + that is to special Map Lemma *)
70.203 +lemma traces_coincide_abs:
70.204 + "ext C = ext A
70.205 + ==> mk_trace C$xs = mk_trace A$(snd (cex_abs f (s,xs)))"
70.206 +apply (unfold cex_abs_def mk_trace_def filter_act_def)
70.207 +apply simp
70.208 +apply (tactic {* pair_induct_tac @{context} "xs" [] 1 *})
70.209 +done
70.210 +
70.211 +
70.212 +(* Does not work with abstraction_is_ref_map as proof of abs_safety, because
70.213 + is_live_abstraction includes temp_strengthening which is necessarily based
70.214 + on cex_abs and not on corresp_ex. Thus, the proof is redoone in a more specific
70.215 + way for cex_abs *)
70.216 +lemma abs_liveness: "[| inp(C)=inp(A); out(C)=out(A);
70.217 + is_live_abstraction h (C,M) (A,L) |]
70.218 + ==> live_implements (C,M) (A,L)"
70.219 +apply (simp add: is_live_abstraction_def live_implements_def livetraces_def liveexecutions_def)
70.220 +apply auto
70.221 +apply (rule_tac x = "cex_abs h ex" in exI)
70.222 +apply auto
70.223 + (* Traces coincide *)
70.224 + apply (tactic {* pair_tac @{context} "ex" 1 *})
70.225 + apply (rule traces_coincide_abs)
70.226 + apply (simp (no_asm) add: externals_def)
70.227 + apply (auto)[1]
70.228 +
70.229 + (* cex_abs is execution *)
70.230 + apply (tactic {* pair_tac @{context} "ex" 1 *})
70.231 + apply (simp add: executions_def)
70.232 + (* start state *)
70.233 + apply (rule conjI)
70.234 + apply (simp add: is_abstraction_def cex_abs_def)
70.235 + (* is-execution-fragment *)
70.236 + apply (erule exec_frag_abstraction)
70.237 + apply (simp add: reachable.reachable_0)
70.238 +
70.239 + (* Liveness *)
70.240 +apply (simp add: temp_weakening_def2)
70.241 + apply (tactic {* pair_tac @{context} "ex" 1 *})
70.242 +done
70.243 +
70.244 +(* FIX: NAch Traces.ML bringen *)
70.245 +
70.246 +lemma implements_trans:
70.247 +"[| A =<| B; B =<| C|] ==> A =<| C"
70.248 +by (auto simp add: ioa_implements_def)
70.249 +
70.250 +
70.251 +subsection "Abstraction Rules for Automata"
70.252 +
70.253 +lemma AbsRuleA1: "[| inp(C)=inp(A); out(C)=out(A);
70.254 + inp(Q)=inp(P); out(Q)=out(P);
70.255 + is_abstraction h1 C A;
70.256 + A =<| Q ;
70.257 + is_abstraction h2 Q P |]
70.258 + ==> C =<| P"
70.259 +apply (drule abs_safety)
70.260 +apply assumption+
70.261 +apply (drule abs_safety)
70.262 +apply assumption+
70.263 +apply (erule implements_trans)
70.264 +apply (erule implements_trans)
70.265 +apply assumption
70.266 +done
70.267 +
70.268 +
70.269 +lemma AbsRuleA2: "!!LC. [| inp(C)=inp(A); out(C)=out(A);
70.270 + inp(Q)=inp(P); out(Q)=out(P);
70.271 + is_live_abstraction h1 (C,LC) (A,LA);
70.272 + live_implements (A,LA) (Q,LQ) ;
70.273 + is_live_abstraction h2 (Q,LQ) (P,LP) |]
70.274 + ==> live_implements (C,LC) (P,LP)"
70.275 +apply (drule abs_liveness)
70.276 +apply assumption+
70.277 +apply (drule abs_liveness)
70.278 +apply assumption+
70.279 +apply (erule live_implements_trans)
70.280 +apply (erule live_implements_trans)
70.281 +apply assumption
70.282 +done
70.283 +
70.284 +
70.285 +declare split_paired_All [simp del]
70.286 +
70.287 +
70.288 +subsection "Localizing Temporal Strengthenings and Weakenings"
70.289 +
70.290 +lemma strength_AND:
70.291 +"[| temp_strengthening P1 Q1 h;
70.292 + temp_strengthening P2 Q2 h |]
70.293 + ==> temp_strengthening (P1 .& P2) (Q1 .& Q2) h"
70.294 +apply (unfold temp_strengthening_def)
70.295 +apply auto
70.296 +done
70.297 +
70.298 +lemma strength_OR:
70.299 +"[| temp_strengthening P1 Q1 h;
70.300 + temp_strengthening P2 Q2 h |]
70.301 + ==> temp_strengthening (P1 .| P2) (Q1 .| Q2) h"
70.302 +apply (unfold temp_strengthening_def)
70.303 +apply auto
70.304 +done
70.305 +
70.306 +lemma strength_NOT:
70.307 +"[| temp_weakening P Q h |]
70.308 + ==> temp_strengthening (.~ P) (.~ Q) h"
70.309 +apply (unfold temp_strengthening_def)
70.310 +apply (simp add: temp_weakening_def2)
70.311 +apply auto
70.312 +done
70.313 +
70.314 +lemma strength_IMPLIES:
70.315 +"[| temp_weakening P1 Q1 h;
70.316 + temp_strengthening P2 Q2 h |]
70.317 + ==> temp_strengthening (P1 .--> P2) (Q1 .--> Q2) h"
70.318 +apply (unfold temp_strengthening_def)
70.319 +apply (simp add: temp_weakening_def2)
70.320 +done
70.321 +
70.322 +
70.323 +lemma weak_AND:
70.324 +"[| temp_weakening P1 Q1 h;
70.325 + temp_weakening P2 Q2 h |]
70.326 + ==> temp_weakening (P1 .& P2) (Q1 .& Q2) h"
70.327 +apply (simp add: temp_weakening_def2)
70.328 +done
70.329 +
70.330 +lemma weak_OR:
70.331 +"[| temp_weakening P1 Q1 h;
70.332 + temp_weakening P2 Q2 h |]
70.333 + ==> temp_weakening (P1 .| P2) (Q1 .| Q2) h"
70.334 +apply (simp add: temp_weakening_def2)
70.335 +done
70.336 +
70.337 +lemma weak_NOT:
70.338 +"[| temp_strengthening P Q h |]
70.339 + ==> temp_weakening (.~ P) (.~ Q) h"
70.340 +apply (unfold temp_strengthening_def)
70.341 +apply (simp add: temp_weakening_def2)
70.342 +apply auto
70.343 +done
70.344 +
70.345 +lemma weak_IMPLIES:
70.346 +"[| temp_strengthening P1 Q1 h;
70.347 + temp_weakening P2 Q2 h |]
70.348 + ==> temp_weakening (P1 .--> P2) (Q1 .--> Q2) h"
70.349 +apply (unfold temp_strengthening_def)
70.350 +apply (simp add: temp_weakening_def2)
70.351 +done
70.352 +
70.353 +
70.354 +subsubsection {* Box *}
70.355 +
70.356 +(* FIX: should be same as nil_is_Conc2 when all nils are turned to right side !! *)
70.357 +lemma UU_is_Conc: "(UU = x @@ y) = (((x::'a Seq)= UU) | (x=nil & y=UU))"
70.358 +apply (tactic {* Seq_case_simp_tac @{context} "x" 1 *})
70.359 +done
70.360 +
70.361 +lemma ex2seqConc [rule_format]:
70.362 +"Finite s1 -->
70.363 + (! ex. (s~=nil & s~=UU & ex2seq ex = s1 @@ s) --> (? ex'. s = ex2seq ex'))"
70.364 +apply (rule impI)
70.365 +apply (tactic {* Seq_Finite_induct_tac @{context} 1 *})
70.366 +apply blast
70.367 +(* main case *)
70.368 +apply clarify
70.369 +apply (tactic {* pair_tac @{context} "ex" 1 *})
70.370 +apply (tactic {* Seq_case_simp_tac @{context} "y" 1 *})
70.371 +(* UU case *)
70.372 +apply (simp add: nil_is_Conc)
70.373 +(* nil case *)
70.374 +apply (simp add: nil_is_Conc)
70.375 +(* cons case *)
70.376 +apply (tactic {* pair_tac @{context} "aa" 1 *})
70.377 +apply auto
70.378 +done
70.379 +
70.380 +(* important property of ex2seq: can be shiftet, as defined "pointwise" *)
70.381 +
70.382 +lemma ex2seq_tsuffix:
70.383 +"tsuffix s (ex2seq ex) ==> ? ex'. s = (ex2seq ex')"
70.384 +apply (unfold tsuffix_def suffix_def)
70.385 +apply auto
70.386 +apply (drule ex2seqConc)
70.387 +apply auto
70.388 +done
70.389 +
70.390 +
70.391 +(* FIX: NAch Sequence.ML bringen *)
70.392 +
70.393 +lemma Mapnil: "(Map f$s = nil) = (s=nil)"
70.394 +apply (tactic {* Seq_case_simp_tac @{context} "s" 1 *})
70.395 +done
70.396 +
70.397 +lemma MapUU: "(Map f$s = UU) = (s=UU)"
70.398 +apply (tactic {* Seq_case_simp_tac @{context} "s" 1 *})
70.399 +done
70.400 +
70.401 +
70.402 +(* important property of cex_absSeq: As it is a 1to1 correspondence,
70.403 + properties carry over *)
70.404 +
70.405 +lemma cex_absSeq_tsuffix:
70.406 +"tsuffix s t ==> tsuffix (cex_absSeq h s) (cex_absSeq h t)"
70.407 +apply (unfold tsuffix_def suffix_def cex_absSeq_def)
70.408 +apply auto
70.409 +apply (simp add: Mapnil)
70.410 +apply (simp add: MapUU)
70.411 +apply (rule_tac x = "Map (% (s,a,t) . (h s,a, h t))$s1" in exI)
70.412 +apply (simp add: Map2Finite MapConc)
70.413 +done
70.414 +
70.415 +
70.416 +lemma strength_Box:
70.417 +"[| temp_strengthening P Q h |]
70.418 + ==> temp_strengthening ([] P) ([] Q) h"
70.419 +apply (unfold temp_strengthening_def state_strengthening_def temp_sat_def satisfies_def Box_def)
70.420 +apply clarify
70.421 +apply (frule ex2seq_tsuffix)
70.422 +apply clarify
70.423 +apply (drule_tac h = "h" in cex_absSeq_tsuffix)
70.424 +apply (simp add: ex2seq_abs_cex)
70.425 +done
70.426 +
70.427 +
70.428 +subsubsection {* Init *}
70.429 +
70.430 +lemma strength_Init:
70.431 +"[| state_strengthening P Q h |]
70.432 + ==> temp_strengthening (Init P) (Init Q) h"
70.433 +apply (unfold temp_strengthening_def state_strengthening_def
70.434 + temp_sat_def satisfies_def Init_def unlift_def)
70.435 +apply auto
70.436 +apply (tactic {* pair_tac @{context} "ex" 1 *})
70.437 +apply (tactic {* Seq_case_simp_tac @{context} "y" 1 *})
70.438 +apply (tactic {* pair_tac @{context} "a" 1 *})
70.439 +done
70.440 +
70.441 +
70.442 +subsubsection {* Next *}
70.443 +
70.444 +lemma TL_ex2seq_UU:
70.445 +"(TL$(ex2seq (cex_abs h ex))=UU) = (TL$(ex2seq ex)=UU)"
70.446 +apply (tactic {* pair_tac @{context} "ex" 1 *})
70.447 +apply (tactic {* Seq_case_simp_tac @{context} "y" 1 *})
70.448 +apply (tactic {* pair_tac @{context} "a" 1 *})
70.449 +apply (tactic {* Seq_case_simp_tac @{context} "s" 1 *})
70.450 +apply (tactic {* pair_tac @{context} "a" 1 *})
70.451 +done
70.452 +
70.453 +lemma TL_ex2seq_nil:
70.454 +"(TL$(ex2seq (cex_abs h ex))=nil) = (TL$(ex2seq ex)=nil)"
70.455 +apply (tactic {* pair_tac @{context} "ex" 1 *})
70.456 +apply (tactic {* Seq_case_simp_tac @{context} "y" 1 *})
70.457 +apply (tactic {* pair_tac @{context} "a" 1 *})
70.458 +apply (tactic {* Seq_case_simp_tac @{context} "s" 1 *})
70.459 +apply (tactic {* pair_tac @{context} "a" 1 *})
70.460 +done
70.461 +
70.462 +(* FIX: put to Sequence Lemmas *)
70.463 +lemma MapTL: "Map f$(TL$s) = TL$(Map f$s)"
70.464 +apply (tactic {* Seq_induct_tac @{context} "s" [] 1 *})
70.465 +done
70.466 +
70.467 +(* important property of cex_absSeq: As it is a 1to1 correspondence,
70.468 + properties carry over *)
70.469 +
70.470 +lemma cex_absSeq_TL:
70.471 +"cex_absSeq h (TL$s) = (TL$(cex_absSeq h s))"
70.472 +apply (unfold cex_absSeq_def)
70.473 +apply (simp add: MapTL)
70.474 +done
70.475 +
70.476 +(* important property of ex2seq: can be shiftet, as defined "pointwise" *)
70.477 +
70.478 +lemma TLex2seq: "[| (snd ex)~=UU ; (snd ex)~=nil |] ==> (? ex'. TL$(ex2seq ex) = ex2seq ex')"
70.479 +apply (tactic {* pair_tac @{context} "ex" 1 *})
70.480 +apply (tactic {* Seq_case_simp_tac @{context} "y" 1 *})
70.481 +apply (tactic {* pair_tac @{context} "a" 1 *})
70.482 +apply auto
70.483 +done
70.484 +
70.485 +
70.486 +lemma ex2seqnilTL: "(TL$(ex2seq ex)~=nil) = ((snd ex)~=nil & (snd ex)~=UU)"
70.487 +apply (tactic {* pair_tac @{context} "ex" 1 *})
70.488 +apply (tactic {* Seq_case_simp_tac @{context} "y" 1 *})
70.489 +apply (tactic {* pair_tac @{context} "a" 1 *})
70.490 +apply (tactic {* Seq_case_simp_tac @{context} "s" 1 *})
70.491 +apply (tactic {* pair_tac @{context} "a" 1 *})
70.492 +done
70.493 +
70.494 +
70.495 +lemma strength_Next:
70.496 +"[| temp_strengthening P Q h |]
70.497 + ==> temp_strengthening (Next P) (Next Q) h"
70.498 +apply (unfold temp_strengthening_def state_strengthening_def temp_sat_def satisfies_def Next_def)
70.499 +apply simp
70.500 +apply auto
70.501 +apply (simp add: TL_ex2seq_nil TL_ex2seq_UU)
70.502 +apply (simp add: TL_ex2seq_nil TL_ex2seq_UU)
70.503 +apply (simp add: TL_ex2seq_nil TL_ex2seq_UU)
70.504 +apply (simp add: TL_ex2seq_nil TL_ex2seq_UU)
70.505 +(* cons case *)
70.506 +apply (simp add: TL_ex2seq_nil TL_ex2seq_UU ex2seq_abs_cex cex_absSeq_TL [symmetric] ex2seqnilTL)
70.507 +apply (erule conjE)
70.508 +apply (drule TLex2seq)
70.509 +apply assumption
70.510 +apply auto
70.511 +done
70.512 +
70.513 +
70.514 +text {* Localizing Temporal Weakenings - 2 *}
70.515 +
70.516 +lemma weak_Init:
70.517 +"[| state_weakening P Q h |]
70.518 + ==> temp_weakening (Init P) (Init Q) h"
70.519 +apply (simp add: temp_weakening_def2 state_weakening_def2
70.520 + temp_sat_def satisfies_def Init_def unlift_def)
70.521 +apply auto
70.522 +apply (tactic {* pair_tac @{context} "ex" 1 *})
70.523 +apply (tactic {* Seq_case_simp_tac @{context} "y" 1 *})
70.524 +apply (tactic {* pair_tac @{context} "a" 1 *})
70.525 +done
70.526 +
70.527 +
70.528 +text {* Localizing Temproal Strengthenings - 3 *}
70.529 +
70.530 +lemma strength_Diamond:
70.531 +"[| temp_strengthening P Q h |]
70.532 + ==> temp_strengthening (<> P) (<> Q) h"
70.533 +apply (unfold Diamond_def)
70.534 +apply (rule strength_NOT)
70.535 +apply (rule weak_Box)
70.536 +apply (erule weak_NOT)
70.537 +done
70.538 +
70.539 +lemma strength_Leadsto:
70.540 +"[| temp_weakening P1 P2 h;
70.541 + temp_strengthening Q1 Q2 h |]
70.542 + ==> temp_strengthening (P1 ~> Q1) (P2 ~> Q2) h"
70.543 +apply (unfold Leadsto_def)
70.544 +apply (rule strength_Box)
70.545 +apply (erule strength_IMPLIES)
70.546 +apply (erule strength_Diamond)
70.547 +done
70.548 +
70.549 +
70.550 +text {* Localizing Temporal Weakenings - 3 *}
70.551 +
70.552 +lemma weak_Diamond:
70.553 +"[| temp_weakening P Q h |]
70.554 + ==> temp_weakening (<> P) (<> Q) h"
70.555 +apply (unfold Diamond_def)
70.556 +apply (rule weak_NOT)
70.557 +apply (rule strength_Box)
70.558 +apply (erule strength_NOT)
70.559 +done
70.560 +
70.561 +lemma weak_Leadsto:
70.562 +"[| temp_strengthening P1 P2 h;
70.563 + temp_weakening Q1 Q2 h |]
70.564 + ==> temp_weakening (P1 ~> Q1) (P2 ~> Q2) h"
70.565 +apply (unfold Leadsto_def)
70.566 +apply (rule weak_Box)
70.567 +apply (erule weak_IMPLIES)
70.568 +apply (erule weak_Diamond)
70.569 +done
70.570 +
70.571 +lemma weak_WF:
70.572 + " !!A. [| !! s. Enabled A acts (h s) ==> Enabled C acts s|]
70.573 + ==> temp_weakening (WF A acts) (WF C acts) h"
70.574 +apply (unfold WF_def)
70.575 +apply (rule weak_IMPLIES)
70.576 +apply (rule strength_Diamond)
70.577 +apply (rule strength_Box)
70.578 +apply (rule strength_Init)
70.579 +apply (rule_tac [2] weak_Box)
70.580 +apply (rule_tac [2] weak_Diamond)
70.581 +apply (rule_tac [2] weak_Init)
70.582 +apply (auto simp add: state_weakening_def state_strengthening_def
70.583 + xt2_def plift_def option_lift_def NOT_def)
70.584 +done
70.585 +
70.586 +lemma weak_SF:
70.587 + " !!A. [| !! s. Enabled A acts (h s) ==> Enabled C acts s|]
70.588 + ==> temp_weakening (SF A acts) (SF C acts) h"
70.589 +apply (unfold SF_def)
70.590 +apply (rule weak_IMPLIES)
70.591 +apply (rule strength_Box)
70.592 +apply (rule strength_Diamond)
70.593 +apply (rule strength_Init)
70.594 +apply (rule_tac [2] weak_Box)
70.595 +apply (rule_tac [2] weak_Diamond)
70.596 +apply (rule_tac [2] weak_Init)
70.597 +apply (auto simp add: state_weakening_def state_strengthening_def
70.598 + xt2_def plift_def option_lift_def NOT_def)
70.599 +done
70.600 +
70.601 +
70.602 +lemmas weak_strength_lemmas =
70.603 + weak_OR weak_AND weak_NOT weak_IMPLIES weak_Box weak_Next weak_Init
70.604 + weak_Diamond weak_Leadsto strength_OR strength_AND strength_NOT
70.605 + strength_IMPLIES strength_Box strength_Next strength_Init
70.606 + strength_Diamond strength_Leadsto weak_WF weak_SF
70.607 +
70.608 +ML {*
70.609 +fun abstraction_tac ctxt =
70.610 + let val (cs, ss) = clasimpset_of ctxt in
70.611 + SELECT_GOAL (auto_tac (cs addSIs @{thms weak_strength_lemmas},
70.612 + ss addsimps [@{thm state_strengthening_def}, @{thm state_weakening_def}]))
70.613 + end
70.614 +*}
70.615 +
70.616 +method_setup abstraction = {* Scan.succeed (SIMPLE_METHOD' o abstraction_tac) *} ""
70.617 +
70.618 +end
71.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
71.2 +++ b/src/HOL/HOLCF/IOA/meta_theory/Asig.thy Sat Nov 27 16:08:10 2010 -0800
71.3 @@ -0,0 +1,101 @@
71.4 +(* Title: HOL/IOA/meta_theory/Asig.thy
71.5 + Author: Olaf Müller, Tobias Nipkow & Konrad Slind
71.6 +*)
71.7 +
71.8 +header {* Action signatures *}
71.9 +
71.10 +theory Asig
71.11 +imports Main
71.12 +begin
71.13 +
71.14 +types
71.15 + 'a signature = "('a set * 'a set * 'a set)"
71.16 +
71.17 +definition
71.18 + inputs :: "'action signature => 'action set" where
71.19 + asig_inputs_def: "inputs = fst"
71.20 +
71.21 +definition
71.22 + outputs :: "'action signature => 'action set" where
71.23 + asig_outputs_def: "outputs = (fst o snd)"
71.24 +
71.25 +definition
71.26 + internals :: "'action signature => 'action set" where
71.27 + asig_internals_def: "internals = (snd o snd)"
71.28 +
71.29 +definition
71.30 + actions :: "'action signature => 'action set" where
71.31 + "actions(asig) = (inputs(asig) Un outputs(asig) Un internals(asig))"
71.32 +
71.33 +definition
71.34 + externals :: "'action signature => 'action set" where
71.35 + "externals(asig) = (inputs(asig) Un outputs(asig))"
71.36 +
71.37 +definition
71.38 + locals :: "'action signature => 'action set" where
71.39 + "locals asig = ((internals asig) Un (outputs asig))"
71.40 +
71.41 +definition
71.42 + is_asig :: "'action signature => bool" where
71.43 + "is_asig(triple) =
71.44 + ((inputs(triple) Int outputs(triple) = {}) &
71.45 + (outputs(triple) Int internals(triple) = {}) &
71.46 + (inputs(triple) Int internals(triple) = {}))"
71.47 +
71.48 +definition
71.49 + mk_ext_asig :: "'action signature => 'action signature" where
71.50 + "mk_ext_asig(triple) = (inputs(triple), outputs(triple), {})"
71.51 +
71.52 +
71.53 +lemmas asig_projections = asig_inputs_def asig_outputs_def asig_internals_def
71.54 +
71.55 +lemma asig_triple_proj:
71.56 + "(outputs (a,b,c) = b) &
71.57 + (inputs (a,b,c) = a) &
71.58 + (internals (a,b,c) = c)"
71.59 + apply (simp add: asig_projections)
71.60 + done
71.61 +
71.62 +lemma int_and_ext_is_act: "[| a~:internals(S) ;a~:externals(S)|] ==> a~:actions(S)"
71.63 +apply (simp add: externals_def actions_def)
71.64 +done
71.65 +
71.66 +lemma ext_is_act: "[|a:externals(S)|] ==> a:actions(S)"
71.67 +apply (simp add: externals_def actions_def)
71.68 +done
71.69 +
71.70 +lemma int_is_act: "[|a:internals S|] ==> a:actions S"
71.71 +apply (simp add: asig_internals_def actions_def)
71.72 +done
71.73 +
71.74 +lemma inp_is_act: "[|a:inputs S|] ==> a:actions S"
71.75 +apply (simp add: asig_inputs_def actions_def)
71.76 +done
71.77 +
71.78 +lemma out_is_act: "[|a:outputs S|] ==> a:actions S"
71.79 +apply (simp add: asig_outputs_def actions_def)
71.80 +done
71.81 +
71.82 +lemma ext_and_act: "(x: actions S & x : externals S) = (x: externals S)"
71.83 +apply (fast intro!: ext_is_act)
71.84 +done
71.85 +
71.86 +lemma not_ext_is_int: "[|is_asig S;x: actions S|] ==> (x~:externals S) = (x: internals S)"
71.87 +apply (simp add: actions_def is_asig_def externals_def)
71.88 +apply blast
71.89 +done
71.90 +
71.91 +lemma not_ext_is_int_or_not_act: "is_asig S ==> (x~:externals S) = (x: internals S | x~:actions S)"
71.92 +apply (simp add: actions_def is_asig_def externals_def)
71.93 +apply blast
71.94 +done
71.95 +
71.96 +lemma int_is_not_ext:
71.97 + "[| is_asig (S); x:internals S |] ==> x~:externals S"
71.98 +apply (unfold externals_def actions_def is_asig_def)
71.99 +apply simp
71.100 +apply blast
71.101 +done
71.102 +
71.103 +
71.104 +end
72.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
72.2 +++ b/src/HOL/HOLCF/IOA/meta_theory/Automata.thy Sat Nov 27 16:08:10 2010 -0800
72.3 @@ -0,0 +1,691 @@
72.4 +(* Title: HOLCF/IOA/meta_theory/Automata.thy
72.5 + Author: Olaf Müller, Konrad Slind, Tobias Nipkow
72.6 +*)
72.7 +
72.8 +header {* The I/O automata of Lynch and Tuttle in HOLCF *}
72.9 +
72.10 +theory Automata
72.11 +imports Asig
72.12 +begin
72.13 +
72.14 +default_sort type
72.15 +
72.16 +types
72.17 + ('a, 's) transition = "'s * 'a * 's"
72.18 + ('a, 's) ioa = "'a signature * 's set * ('a,'s)transition set * ('a set set) * ('a set set)"
72.19 +
72.20 +consts
72.21 +
72.22 + (* IO automata *)
72.23 +
72.24 + asig_of ::"('a,'s)ioa => 'a signature"
72.25 + starts_of ::"('a,'s)ioa => 's set"
72.26 + trans_of ::"('a,'s)ioa => ('a,'s)transition set"
72.27 + wfair_of ::"('a,'s)ioa => ('a set) set"
72.28 + sfair_of ::"('a,'s)ioa => ('a set) set"
72.29 +
72.30 + is_asig_of ::"('a,'s)ioa => bool"
72.31 + is_starts_of ::"('a,'s)ioa => bool"
72.32 + is_trans_of ::"('a,'s)ioa => bool"
72.33 + input_enabled ::"('a,'s)ioa => bool"
72.34 + IOA ::"('a,'s)ioa => bool"
72.35 +
72.36 + (* constraints for fair IOA *)
72.37 +
72.38 + fairIOA ::"('a,'s)ioa => bool"
72.39 + input_resistant::"('a,'s)ioa => bool"
72.40 +
72.41 + (* enabledness of actions and action sets *)
72.42 +
72.43 + enabled ::"('a,'s)ioa => 'a => 's => bool"
72.44 + Enabled ::"('a,'s)ioa => 'a set => 's => bool"
72.45 +
72.46 + (* action set keeps enabled until probably disabled by itself *)
72.47 +
72.48 + en_persistent :: "('a,'s)ioa => 'a set => bool"
72.49 +
72.50 + (* post_conditions for actions and action sets *)
72.51 +
72.52 + was_enabled ::"('a,'s)ioa => 'a => 's => bool"
72.53 + set_was_enabled ::"('a,'s)ioa => 'a set => 's => bool"
72.54 +
72.55 + (* invariants *)
72.56 + invariant :: "[('a,'s)ioa, 's=>bool] => bool"
72.57 +
72.58 + (* binary composition of action signatures and automata *)
72.59 + asig_comp ::"['a signature, 'a signature] => 'a signature"
72.60 + compatible ::"[('a,'s)ioa, ('a,'t)ioa] => bool"
72.61 + par ::"[('a,'s)ioa, ('a,'t)ioa] => ('a,'s*'t)ioa" (infixr "||" 10)
72.62 +
72.63 + (* hiding and restricting *)
72.64 + hide_asig :: "['a signature, 'a set] => 'a signature"
72.65 + hide :: "[('a,'s)ioa, 'a set] => ('a,'s)ioa"
72.66 + restrict_asig :: "['a signature, 'a set] => 'a signature"
72.67 + restrict :: "[('a,'s)ioa, 'a set] => ('a,'s)ioa"
72.68 +
72.69 + (* renaming *)
72.70 + rename_set :: "'a set => ('c => 'a option) => 'c set"
72.71 + rename :: "('a, 'b)ioa => ('c => 'a option) => ('c,'b)ioa"
72.72 +
72.73 +notation (xsymbols)
72.74 + par (infixr "\<parallel>" 10)
72.75 +
72.76 +
72.77 +inductive
72.78 + reachable :: "('a, 's) ioa => 's => bool"
72.79 + for C :: "('a, 's) ioa"
72.80 + where
72.81 + reachable_0: "s : starts_of C ==> reachable C s"
72.82 + | reachable_n: "[| reachable C s; (s, a, t) : trans_of C |] ==> reachable C t"
72.83 +
72.84 +abbreviation
72.85 + trans_of_syn ("_ -_--_-> _" [81,81,81,81] 100) where
72.86 + "s -a--A-> t == (s,a,t):trans_of A"
72.87 +
72.88 +notation (xsymbols)
72.89 + trans_of_syn ("_ \<midarrow>_\<midarrow>_\<longrightarrow> _" [81,81,81,81] 100)
72.90 +
72.91 +abbreviation "act A == actions (asig_of A)"
72.92 +abbreviation "ext A == externals (asig_of A)"
72.93 +abbreviation int where "int A == internals (asig_of A)"
72.94 +abbreviation "inp A == inputs (asig_of A)"
72.95 +abbreviation "out A == outputs (asig_of A)"
72.96 +abbreviation "local A == locals (asig_of A)"
72.97 +
72.98 +defs
72.99 +
72.100 +(* --------------------------------- IOA ---------------------------------*)
72.101 +
72.102 +asig_of_def: "asig_of == fst"
72.103 +starts_of_def: "starts_of == (fst o snd)"
72.104 +trans_of_def: "trans_of == (fst o snd o snd)"
72.105 +wfair_of_def: "wfair_of == (fst o snd o snd o snd)"
72.106 +sfair_of_def: "sfair_of == (snd o snd o snd o snd)"
72.107 +
72.108 +is_asig_of_def:
72.109 + "is_asig_of A == is_asig (asig_of A)"
72.110 +
72.111 +is_starts_of_def:
72.112 + "is_starts_of A == (~ starts_of A = {})"
72.113 +
72.114 +is_trans_of_def:
72.115 + "is_trans_of A ==
72.116 + (!triple. triple:(trans_of A) --> fst(snd(triple)):actions(asig_of A))"
72.117 +
72.118 +input_enabled_def:
72.119 + "input_enabled A ==
72.120 + (!a. (a:inputs(asig_of A)) --> (!s1. ? s2. (s1,a,s2):(trans_of A)))"
72.121 +
72.122 +
72.123 +ioa_def:
72.124 + "IOA A == (is_asig_of A &
72.125 + is_starts_of A &
72.126 + is_trans_of A &
72.127 + input_enabled A)"
72.128 +
72.129 +
72.130 +invariant_def: "invariant A P == (!s. reachable A s --> P(s))"
72.131 +
72.132 +
72.133 +(* ------------------------- parallel composition --------------------------*)
72.134 +
72.135 +
72.136 +compatible_def:
72.137 + "compatible A B ==
72.138 + (((out A Int out B) = {}) &
72.139 + ((int A Int act B) = {}) &
72.140 + ((int B Int act A) = {}))"
72.141 +
72.142 +asig_comp_def:
72.143 + "asig_comp a1 a2 ==
72.144 + (((inputs(a1) Un inputs(a2)) - (outputs(a1) Un outputs(a2)),
72.145 + (outputs(a1) Un outputs(a2)),
72.146 + (internals(a1) Un internals(a2))))"
72.147 +
72.148 +par_def:
72.149 + "(A || B) ==
72.150 + (asig_comp (asig_of A) (asig_of B),
72.151 + {pr. fst(pr):starts_of(A) & snd(pr):starts_of(B)},
72.152 + {tr. let s = fst(tr); a = fst(snd(tr)); t = snd(snd(tr))
72.153 + in (a:act A | a:act B) &
72.154 + (if a:act A then
72.155 + (fst(s),a,fst(t)):trans_of(A)
72.156 + else fst(t) = fst(s))
72.157 + &
72.158 + (if a:act B then
72.159 + (snd(s),a,snd(t)):trans_of(B)
72.160 + else snd(t) = snd(s))},
72.161 + wfair_of A Un wfair_of B,
72.162 + sfair_of A Un sfair_of B)"
72.163 +
72.164 +
72.165 +(* ------------------------ hiding -------------------------------------------- *)
72.166 +
72.167 +restrict_asig_def:
72.168 + "restrict_asig asig actns ==
72.169 + (inputs(asig) Int actns,
72.170 + outputs(asig) Int actns,
72.171 + internals(asig) Un (externals(asig) - actns))"
72.172 +
72.173 +(* Notice that for wfair_of and sfair_of nothing has to be changed, as
72.174 + changes from the outputs to the internals does not touch the locals as
72.175 + a whole, which is of importance for fairness only *)
72.176 +
72.177 +restrict_def:
72.178 + "restrict A actns ==
72.179 + (restrict_asig (asig_of A) actns,
72.180 + starts_of A,
72.181 + trans_of A,
72.182 + wfair_of A,
72.183 + sfair_of A)"
72.184 +
72.185 +hide_asig_def:
72.186 + "hide_asig asig actns ==
72.187 + (inputs(asig) - actns,
72.188 + outputs(asig) - actns,
72.189 + internals(asig) Un actns)"
72.190 +
72.191 +hide_def:
72.192 + "hide A actns ==
72.193 + (hide_asig (asig_of A) actns,
72.194 + starts_of A,
72.195 + trans_of A,
72.196 + wfair_of A,
72.197 + sfair_of A)"
72.198 +
72.199 +(* ------------------------- renaming ------------------------------------------- *)
72.200 +
72.201 +rename_set_def:
72.202 + "rename_set A ren == {b. ? x. Some x = ren b & x : A}"
72.203 +
72.204 +rename_def:
72.205 +"rename ioa ren ==
72.206 + ((rename_set (inp ioa) ren,
72.207 + rename_set (out ioa) ren,
72.208 + rename_set (int ioa) ren),
72.209 + starts_of ioa,
72.210 + {tr. let s = fst(tr); a = fst(snd(tr)); t = snd(snd(tr))
72.211 + in
72.212 + ? x. Some(x) = ren(a) & (s,x,t):trans_of ioa},
72.213 + {rename_set s ren | s. s: wfair_of ioa},
72.214 + {rename_set s ren | s. s: sfair_of ioa})"
72.215 +
72.216 +(* ------------------------- fairness ----------------------------- *)
72.217 +
72.218 +fairIOA_def:
72.219 + "fairIOA A == (! S : wfair_of A. S<= local A) &
72.220 + (! S : sfair_of A. S<= local A)"
72.221 +
72.222 +input_resistant_def:
72.223 + "input_resistant A == ! W : sfair_of A. ! s a t.
72.224 + reachable A s & reachable A t & a:inp A &
72.225 + Enabled A W s & s -a--A-> t
72.226 + --> Enabled A W t"
72.227 +
72.228 +enabled_def:
72.229 + "enabled A a s == ? t. s-a--A-> t"
72.230 +
72.231 +Enabled_def:
72.232 + "Enabled A W s == ? w:W. enabled A w s"
72.233 +
72.234 +en_persistent_def:
72.235 + "en_persistent A W == ! s a t. Enabled A W s &
72.236 + a ~:W &
72.237 + s -a--A-> t
72.238 + --> Enabled A W t"
72.239 +was_enabled_def:
72.240 + "was_enabled A a t == ? s. s-a--A-> t"
72.241 +
72.242 +set_was_enabled_def:
72.243 + "set_was_enabled A W t == ? w:W. was_enabled A w t"
72.244 +
72.245 +
72.246 +declare split_paired_Ex [simp del]
72.247 +
72.248 +lemmas ioa_projections = asig_of_def starts_of_def trans_of_def wfair_of_def sfair_of_def
72.249 +
72.250 +
72.251 +subsection "asig_of, starts_of, trans_of"
72.252 +
72.253 +lemma ioa_triple_proj:
72.254 + "((asig_of (x,y,z,w,s)) = x) &
72.255 + ((starts_of (x,y,z,w,s)) = y) &
72.256 + ((trans_of (x,y,z,w,s)) = z) &
72.257 + ((wfair_of (x,y,z,w,s)) = w) &
72.258 + ((sfair_of (x,y,z,w,s)) = s)"
72.259 + apply (simp add: ioa_projections)
72.260 + done
72.261 +
72.262 +lemma trans_in_actions:
72.263 + "[| is_trans_of A; (s1,a,s2):trans_of(A) |] ==> a:act A"
72.264 +apply (unfold is_trans_of_def actions_def is_asig_def)
72.265 + apply (erule allE, erule impE, assumption)
72.266 + apply simp
72.267 +done
72.268 +
72.269 +lemma starts_of_par:
72.270 +"starts_of(A || B) = {p. fst(p):starts_of(A) & snd(p):starts_of(B)}"
72.271 + apply (simp add: par_def ioa_projections)
72.272 +done
72.273 +
72.274 +lemma trans_of_par:
72.275 +"trans_of(A || B) = {tr. let s = fst(tr); a = fst(snd(tr)); t = snd(snd(tr))
72.276 + in (a:act A | a:act B) &
72.277 + (if a:act A then
72.278 + (fst(s),a,fst(t)):trans_of(A)
72.279 + else fst(t) = fst(s))
72.280 + &
72.281 + (if a:act B then
72.282 + (snd(s),a,snd(t)):trans_of(B)
72.283 + else snd(t) = snd(s))}"
72.284 +
72.285 +apply (simp add: par_def ioa_projections)
72.286 +done
72.287 +
72.288 +
72.289 +subsection "actions and par"
72.290 +
72.291 +lemma actions_asig_comp:
72.292 + "actions(asig_comp a b) = actions(a) Un actions(b)"
72.293 + apply (simp (no_asm) add: actions_def asig_comp_def asig_projections)
72.294 + apply blast
72.295 + done
72.296 +
72.297 +lemma asig_of_par: "asig_of(A || B) = asig_comp (asig_of A) (asig_of B)"
72.298 + apply (simp add: par_def ioa_projections)
72.299 + done
72.300 +
72.301 +
72.302 +lemma externals_of_par: "ext (A1||A2) =
72.303 + (ext A1) Un (ext A2)"
72.304 +apply (simp add: externals_def asig_of_par asig_comp_def
72.305 + asig_inputs_def asig_outputs_def Un_def set_diff_eq)
72.306 +apply blast
72.307 +done
72.308 +
72.309 +lemma actions_of_par: "act (A1||A2) =
72.310 + (act A1) Un (act A2)"
72.311 +apply (simp add: actions_def asig_of_par asig_comp_def
72.312 + asig_inputs_def asig_outputs_def asig_internals_def Un_def set_diff_eq)
72.313 +apply blast
72.314 +done
72.315 +
72.316 +lemma inputs_of_par: "inp (A1||A2) =
72.317 + ((inp A1) Un (inp A2)) - ((out A1) Un (out A2))"
72.318 +apply (simp add: actions_def asig_of_par asig_comp_def
72.319 + asig_inputs_def asig_outputs_def Un_def set_diff_eq)
72.320 +done
72.321 +
72.322 +lemma outputs_of_par: "out (A1||A2) =
72.323 + (out A1) Un (out A2)"
72.324 +apply (simp add: actions_def asig_of_par asig_comp_def
72.325 + asig_outputs_def Un_def set_diff_eq)
72.326 +done
72.327 +
72.328 +lemma internals_of_par: "int (A1||A2) =
72.329 + (int A1) Un (int A2)"
72.330 +apply (simp add: actions_def asig_of_par asig_comp_def
72.331 + asig_inputs_def asig_outputs_def asig_internals_def Un_def set_diff_eq)
72.332 +done
72.333 +
72.334 +
72.335 +subsection "actions and compatibility"
72.336 +
72.337 +lemma compat_commute: "compatible A B = compatible B A"
72.338 +apply (simp add: compatible_def Int_commute)
72.339 +apply auto
72.340 +done
72.341 +
72.342 +lemma ext1_is_not_int2:
72.343 + "[| compatible A1 A2; a:ext A1|] ==> a~:int A2"
72.344 +apply (unfold externals_def actions_def compatible_def)
72.345 +apply simp
72.346 +apply blast
72.347 +done
72.348 +
72.349 +(* just commuting the previous one: better commute compatible *)
72.350 +lemma ext2_is_not_int1:
72.351 + "[| compatible A2 A1 ; a:ext A1|] ==> a~:int A2"
72.352 +apply (unfold externals_def actions_def compatible_def)
72.353 +apply simp
72.354 +apply blast
72.355 +done
72.356 +
72.357 +lemmas ext1_ext2_is_not_act2 = ext1_is_not_int2 [THEN int_and_ext_is_act, standard]
72.358 +lemmas ext1_ext2_is_not_act1 = ext2_is_not_int1 [THEN int_and_ext_is_act, standard]
72.359 +
72.360 +lemma intA_is_not_extB:
72.361 + "[| compatible A B; x:int A |] ==> x~:ext B"
72.362 +apply (unfold externals_def actions_def compatible_def)
72.363 +apply simp
72.364 +apply blast
72.365 +done
72.366 +
72.367 +lemma intA_is_not_actB:
72.368 +"[| compatible A B; a:int A |] ==> a ~: act B"
72.369 +apply (unfold externals_def actions_def compatible_def is_asig_def asig_of_def)
72.370 +apply simp
72.371 +apply blast
72.372 +done
72.373 +
72.374 +(* the only one that needs disjointness of outputs and of internals and _all_ acts *)
72.375 +lemma outAactB_is_inpB:
72.376 +"[| compatible A B; a:out A ;a:act B|] ==> a : inp B"
72.377 +apply (unfold asig_outputs_def asig_internals_def actions_def asig_inputs_def
72.378 + compatible_def is_asig_def asig_of_def)
72.379 +apply simp
72.380 +apply blast
72.381 +done
72.382 +
72.383 +(* needed for propagation of input_enabledness from A,B to A||B *)
72.384 +lemma inpAAactB_is_inpBoroutB:
72.385 +"[| compatible A B; a:inp A ;a:act B|] ==> a : inp B | a: out B"
72.386 +apply (unfold asig_outputs_def asig_internals_def actions_def asig_inputs_def
72.387 + compatible_def is_asig_def asig_of_def)
72.388 +apply simp
72.389 +apply blast
72.390 +done
72.391 +
72.392 +
72.393 +subsection "input_enabledness and par"
72.394 +
72.395 +
72.396 +(* ugly case distinctions. Heart of proof:
72.397 + 1. inpAAactB_is_inpBoroutB ie. internals are really hidden.
72.398 + 2. inputs_of_par: outputs are no longer inputs of par. This is important here *)
72.399 +lemma input_enabled_par:
72.400 +"[| compatible A B; input_enabled A; input_enabled B|]
72.401 + ==> input_enabled (A||B)"
72.402 +apply (unfold input_enabled_def)
72.403 +apply (simp add: Let_def inputs_of_par trans_of_par)
72.404 +apply (tactic "safe_tac (global_claset_of @{theory Fun})")
72.405 +apply (simp add: inp_is_act)
72.406 +prefer 2
72.407 +apply (simp add: inp_is_act)
72.408 +(* a: inp A *)
72.409 +apply (case_tac "a:act B")
72.410 +(* a:act B *)
72.411 +apply (erule_tac x = "a" in allE)
72.412 +apply simp
72.413 +apply (drule inpAAactB_is_inpBoroutB)
72.414 +apply assumption
72.415 +apply assumption
72.416 +apply (erule_tac x = "a" in allE)
72.417 +apply simp
72.418 +apply (erule_tac x = "aa" in allE)
72.419 +apply (erule_tac x = "b" in allE)
72.420 +apply (erule exE)
72.421 +apply (erule exE)
72.422 +apply (rule_tac x = " (s2,s2a) " in exI)
72.423 +apply (simp add: inp_is_act)
72.424 +(* a~: act B*)
72.425 +apply (simp add: inp_is_act)
72.426 +apply (erule_tac x = "a" in allE)
72.427 +apply simp
72.428 +apply (erule_tac x = "aa" in allE)
72.429 +apply (erule exE)
72.430 +apply (rule_tac x = " (s2,b) " in exI)
72.431 +apply simp
72.432 +
72.433 +(* a:inp B *)
72.434 +apply (case_tac "a:act A")
72.435 +(* a:act A *)
72.436 +apply (erule_tac x = "a" in allE)
72.437 +apply (erule_tac x = "a" in allE)
72.438 +apply (simp add: inp_is_act)
72.439 +apply (frule_tac A1 = "A" in compat_commute [THEN iffD1])
72.440 +apply (drule inpAAactB_is_inpBoroutB)
72.441 +back
72.442 +apply assumption
72.443 +apply assumption
72.444 +apply simp
72.445 +apply (erule_tac x = "aa" in allE)
72.446 +apply (erule_tac x = "b" in allE)
72.447 +apply (erule exE)
72.448 +apply (erule exE)
72.449 +apply (rule_tac x = " (s2,s2a) " in exI)
72.450 +apply (simp add: inp_is_act)
72.451 +(* a~: act B*)
72.452 +apply (simp add: inp_is_act)
72.453 +apply (erule_tac x = "a" in allE)
72.454 +apply (erule_tac x = "a" in allE)
72.455 +apply simp
72.456 +apply (erule_tac x = "b" in allE)
72.457 +apply (erule exE)
72.458 +apply (rule_tac x = " (aa,s2) " in exI)
72.459 +apply simp
72.460 +done
72.461 +
72.462 +
72.463 +subsection "invariants"
72.464 +
72.465 +lemma invariantI:
72.466 + "[| !!s. s:starts_of(A) ==> P(s);
72.467 + !!s t a. [|reachable A s; P(s)|] ==> (s,a,t): trans_of(A) --> P(t) |]
72.468 + ==> invariant A P"
72.469 +apply (unfold invariant_def)
72.470 +apply (rule allI)
72.471 +apply (rule impI)
72.472 +apply (rule_tac x = "s" in reachable.induct)
72.473 +apply assumption
72.474 +apply blast
72.475 +apply blast
72.476 +done
72.477 +
72.478 +lemma invariantI1:
72.479 + "[| !!s. s : starts_of(A) ==> P(s);
72.480 + !!s t a. reachable A s ==> P(s) --> (s,a,t):trans_of(A) --> P(t)
72.481 + |] ==> invariant A P"
72.482 + apply (blast intro: invariantI)
72.483 + done
72.484 +
72.485 +lemma invariantE: "[| invariant A P; reachable A s |] ==> P(s)"
72.486 + apply (unfold invariant_def)
72.487 + apply blast
72.488 + done
72.489 +
72.490 +
72.491 +subsection "restrict"
72.492 +
72.493 +
72.494 +lemmas reachable_0 = reachable.reachable_0
72.495 + and reachable_n = reachable.reachable_n
72.496 +
72.497 +lemma cancel_restrict_a: "starts_of(restrict ioa acts) = starts_of(ioa) &
72.498 + trans_of(restrict ioa acts) = trans_of(ioa)"
72.499 +apply (simp add: restrict_def ioa_projections)
72.500 +done
72.501 +
72.502 +lemma cancel_restrict_b: "reachable (restrict ioa acts) s = reachable ioa s"
72.503 +apply (rule iffI)
72.504 +apply (erule reachable.induct)
72.505 +apply (simp add: cancel_restrict_a reachable_0)
72.506 +apply (erule reachable_n)
72.507 +apply (simp add: cancel_restrict_a)
72.508 +(* <-- *)
72.509 +apply (erule reachable.induct)
72.510 +apply (rule reachable_0)
72.511 +apply (simp add: cancel_restrict_a)
72.512 +apply (erule reachable_n)
72.513 +apply (simp add: cancel_restrict_a)
72.514 +done
72.515 +
72.516 +lemma acts_restrict: "act (restrict A acts) = act A"
72.517 +apply (simp (no_asm) add: actions_def asig_internals_def
72.518 + asig_outputs_def asig_inputs_def externals_def asig_of_def restrict_def restrict_asig_def)
72.519 +apply auto
72.520 +done
72.521 +
72.522 +lemma cancel_restrict: "starts_of(restrict ioa acts) = starts_of(ioa) &
72.523 + trans_of(restrict ioa acts) = trans_of(ioa) &
72.524 + reachable (restrict ioa acts) s = reachable ioa s &
72.525 + act (restrict A acts) = act A"
72.526 + apply (simp (no_asm) add: cancel_restrict_a cancel_restrict_b acts_restrict)
72.527 + done
72.528 +
72.529 +
72.530 +subsection "rename"
72.531 +
72.532 +lemma trans_rename: "s -a--(rename C f)-> t ==> (? x. Some(x) = f(a) & s -x--C-> t)"
72.533 +apply (simp add: Let_def rename_def trans_of_def)
72.534 +done
72.535 +
72.536 +
72.537 +lemma reachable_rename: "[| reachable (rename C g) s |] ==> reachable C s"
72.538 +apply (erule reachable.induct)
72.539 +apply (rule reachable_0)
72.540 +apply (simp add: rename_def ioa_projections)
72.541 +apply (drule trans_rename)
72.542 +apply (erule exE)
72.543 +apply (erule conjE)
72.544 +apply (erule reachable_n)
72.545 +apply assumption
72.546 +done
72.547 +
72.548 +
72.549 +subsection "trans_of(A||B)"
72.550 +
72.551 +
72.552 +lemma trans_A_proj: "[|(s,a,t):trans_of (A||B); a:act A|]
72.553 + ==> (fst s,a,fst t):trans_of A"
72.554 +apply (simp add: Let_def par_def trans_of_def)
72.555 +done
72.556 +
72.557 +lemma trans_B_proj: "[|(s,a,t):trans_of (A||B); a:act B|]
72.558 + ==> (snd s,a,snd t):trans_of B"
72.559 +apply (simp add: Let_def par_def trans_of_def)
72.560 +done
72.561 +
72.562 +lemma trans_A_proj2: "[|(s,a,t):trans_of (A||B); a~:act A|]
72.563 + ==> fst s = fst t"
72.564 +apply (simp add: Let_def par_def trans_of_def)
72.565 +done
72.566 +
72.567 +lemma trans_B_proj2: "[|(s,a,t):trans_of (A||B); a~:act B|]
72.568 + ==> snd s = snd t"
72.569 +apply (simp add: Let_def par_def trans_of_def)
72.570 +done
72.571 +
72.572 +lemma trans_AB_proj: "(s,a,t):trans_of (A||B)
72.573 + ==> a :act A | a :act B"
72.574 +apply (simp add: Let_def par_def trans_of_def)
72.575 +done
72.576 +
72.577 +lemma trans_AB: "[|a:act A;a:act B;
72.578 + (fst s,a,fst t):trans_of A;(snd s,a,snd t):trans_of B|]
72.579 + ==> (s,a,t):trans_of (A||B)"
72.580 +apply (simp add: Let_def par_def trans_of_def)
72.581 +done
72.582 +
72.583 +lemma trans_A_notB: "[|a:act A;a~:act B;
72.584 + (fst s,a,fst t):trans_of A;snd s=snd t|]
72.585 + ==> (s,a,t):trans_of (A||B)"
72.586 +apply (simp add: Let_def par_def trans_of_def)
72.587 +done
72.588 +
72.589 +lemma trans_notA_B: "[|a~:act A;a:act B;
72.590 + (snd s,a,snd t):trans_of B;fst s=fst t|]
72.591 + ==> (s,a,t):trans_of (A||B)"
72.592 +apply (simp add: Let_def par_def trans_of_def)
72.593 +done
72.594 +
72.595 +lemmas trans_of_defs1 = trans_AB trans_A_notB trans_notA_B
72.596 + and trans_of_defs2 = trans_A_proj trans_B_proj trans_A_proj2 trans_B_proj2 trans_AB_proj
72.597 +
72.598 +
72.599 +lemma trans_of_par4:
72.600 +"((s,a,t) : trans_of(A || B || C || D)) =
72.601 + ((a:actions(asig_of(A)) | a:actions(asig_of(B)) | a:actions(asig_of(C)) |
72.602 + a:actions(asig_of(D))) &
72.603 + (if a:actions(asig_of(A)) then (fst(s),a,fst(t)):trans_of(A)
72.604 + else fst t=fst s) &
72.605 + (if a:actions(asig_of(B)) then (fst(snd(s)),a,fst(snd(t))):trans_of(B)
72.606 + else fst(snd(t))=fst(snd(s))) &
72.607 + (if a:actions(asig_of(C)) then
72.608 + (fst(snd(snd(s))),a,fst(snd(snd(t)))):trans_of(C)
72.609 + else fst(snd(snd(t)))=fst(snd(snd(s)))) &
72.610 + (if a:actions(asig_of(D)) then
72.611 + (snd(snd(snd(s))),a,snd(snd(snd(t)))):trans_of(D)
72.612 + else snd(snd(snd(t)))=snd(snd(snd(s)))))"
72.613 + apply (simp (no_asm) add: par_def actions_asig_comp Pair_fst_snd_eq Let_def ioa_projections)
72.614 + done
72.615 +
72.616 +
72.617 +subsection "proof obligation generator for IOA requirements"
72.618 +
72.619 +(* without assumptions on A and B because is_trans_of is also incorporated in ||def *)
72.620 +lemma is_trans_of_par: "is_trans_of (A||B)"
72.621 +apply (unfold is_trans_of_def)
72.622 +apply (simp add: Let_def actions_of_par trans_of_par)
72.623 +done
72.624 +
72.625 +lemma is_trans_of_restrict:
72.626 +"is_trans_of A ==> is_trans_of (restrict A acts)"
72.627 +apply (unfold is_trans_of_def)
72.628 +apply (simp add: cancel_restrict acts_restrict)
72.629 +done
72.630 +
72.631 +lemma is_trans_of_rename:
72.632 +"is_trans_of A ==> is_trans_of (rename A f)"
72.633 +apply (unfold is_trans_of_def restrict_def restrict_asig_def)
72.634 +apply (simp add: Let_def actions_def trans_of_def asig_internals_def
72.635 + asig_outputs_def asig_inputs_def externals_def asig_of_def rename_def rename_set_def)
72.636 +apply blast
72.637 +done
72.638 +
72.639 +lemma is_asig_of_par: "[| is_asig_of A; is_asig_of B; compatible A B|]
72.640 + ==> is_asig_of (A||B)"
72.641 +apply (simp add: is_asig_of_def asig_of_par asig_comp_def compatible_def
72.642 + asig_internals_def asig_outputs_def asig_inputs_def actions_def is_asig_def)
72.643 +apply (simp add: asig_of_def)
72.644 +apply auto
72.645 +done
72.646 +
72.647 +lemma is_asig_of_restrict:
72.648 +"is_asig_of A ==> is_asig_of (restrict A f)"
72.649 +apply (unfold is_asig_of_def is_asig_def asig_of_def restrict_def restrict_asig_def
72.650 + asig_internals_def asig_outputs_def asig_inputs_def externals_def o_def)
72.651 +apply simp
72.652 +apply auto
72.653 +done
72.654 +
72.655 +lemma is_asig_of_rename: "is_asig_of A ==> is_asig_of (rename A f)"
72.656 +apply (simp add: is_asig_of_def rename_def rename_set_def asig_internals_def
72.657 + asig_outputs_def asig_inputs_def actions_def is_asig_def asig_of_def)
72.658 +apply auto
72.659 +apply (drule_tac [!] s = "Some ?x" in sym)
72.660 +apply auto
72.661 +done
72.662 +
72.663 +lemmas [simp] = is_asig_of_par is_asig_of_restrict
72.664 + is_asig_of_rename is_trans_of_par is_trans_of_restrict is_trans_of_rename
72.665 +
72.666 +
72.667 +lemma compatible_par:
72.668 +"[|compatible A B; compatible A C |]==> compatible A (B||C)"
72.669 +apply (unfold compatible_def)
72.670 +apply (simp add: internals_of_par outputs_of_par actions_of_par)
72.671 +apply auto
72.672 +done
72.673 +
72.674 +(* better derive by previous one and compat_commute *)
72.675 +lemma compatible_par2:
72.676 +"[|compatible A C; compatible B C |]==> compatible (A||B) C"
72.677 +apply (unfold compatible_def)
72.678 +apply (simp add: internals_of_par outputs_of_par actions_of_par)
72.679 +apply auto
72.680 +done
72.681 +
72.682 +lemma compatible_restrict:
72.683 +"[| compatible A B; (ext B - S) Int ext A = {}|]
72.684 + ==> compatible A (restrict B S)"
72.685 +apply (unfold compatible_def)
72.686 +apply (simp add: ioa_triple_proj asig_triple_proj externals_def
72.687 + restrict_def restrict_asig_def actions_def)
72.688 +apply auto
72.689 +done
72.690 +
72.691 +
72.692 +declare split_paired_Ex [simp]
72.693 +
72.694 +end
73.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
73.2 +++ b/src/HOL/HOLCF/IOA/meta_theory/CompoExecs.thy Sat Nov 27 16:08:10 2010 -0800
73.3 @@ -0,0 +1,303 @@
73.4 +(* Title: HOLCF/IOA/meta_theory/CompoExecs.thy
73.5 + Author: Olaf Müller
73.6 +*)
73.7 +
73.8 +header {* Compositionality on Execution level *}
73.9 +
73.10 +theory CompoExecs
73.11 +imports Traces
73.12 +begin
73.13 +
73.14 +definition
73.15 + ProjA2 :: "('a,'s * 't)pairs -> ('a,'s)pairs" where
73.16 + "ProjA2 = Map (%x.(fst x,fst(snd x)))"
73.17 +
73.18 +definition
73.19 + ProjA :: "('a,'s * 't)execution => ('a,'s)execution" where
73.20 + "ProjA ex = (fst (fst ex), ProjA2$(snd ex))"
73.21 +
73.22 +definition
73.23 + ProjB2 :: "('a,'s * 't)pairs -> ('a,'t)pairs" where
73.24 + "ProjB2 = Map (%x.(fst x,snd(snd x)))"
73.25 +
73.26 +definition
73.27 + ProjB :: "('a,'s * 't)execution => ('a,'t)execution" where
73.28 + "ProjB ex = (snd (fst ex), ProjB2$(snd ex))"
73.29 +
73.30 +definition
73.31 + Filter_ex2 :: "'a signature => ('a,'s)pairs -> ('a,'s)pairs" where
73.32 + "Filter_ex2 sig = Filter (%x. fst x:actions sig)"
73.33 +
73.34 +definition
73.35 + Filter_ex :: "'a signature => ('a,'s)execution => ('a,'s)execution" where
73.36 + "Filter_ex sig ex = (fst ex,Filter_ex2 sig$(snd ex))"
73.37 +
73.38 +definition
73.39 + stutter2 :: "'a signature => ('a,'s)pairs -> ('s => tr)" where
73.40 + "stutter2 sig = (fix$(LAM h ex. (%s. case ex of
73.41 + nil => TT
73.42 + | x##xs => (flift1
73.43 + (%p.(If Def ((fst p)~:actions sig)
73.44 + then Def (s=(snd p))
73.45 + else TT)
73.46 + andalso (h$xs) (snd p))
73.47 + $x)
73.48 + )))"
73.49 +
73.50 +definition
73.51 + stutter :: "'a signature => ('a,'s)execution => bool" where
73.52 + "stutter sig ex = ((stutter2 sig$(snd ex)) (fst ex) ~= FF)"
73.53 +
73.54 +definition
73.55 + par_execs :: "[('a,'s)execution_module,('a,'t)execution_module] => ('a,'s*'t)execution_module" where
73.56 + "par_execs ExecsA ExecsB =
73.57 + (let exA = fst ExecsA; sigA = snd ExecsA;
73.58 + exB = fst ExecsB; sigB = snd ExecsB
73.59 + in
73.60 + ( {ex. Filter_ex sigA (ProjA ex) : exA}
73.61 + Int {ex. Filter_ex sigB (ProjB ex) : exB}
73.62 + Int {ex. stutter sigA (ProjA ex)}
73.63 + Int {ex. stutter sigB (ProjB ex)}
73.64 + Int {ex. Forall (%x. fst x:(actions sigA Un actions sigB)) (snd ex)},
73.65 + asig_comp sigA sigB))"
73.66 +
73.67 +
73.68 +lemmas [simp del] = split_paired_All
73.69 +
73.70 +
73.71 +section "recursive equations of operators"
73.72 +
73.73 +
73.74 +(* ---------------------------------------------------------------- *)
73.75 +(* ProjA2 *)
73.76 +(* ---------------------------------------------------------------- *)
73.77 +
73.78 +
73.79 +lemma ProjA2_UU: "ProjA2$UU = UU"
73.80 +apply (simp add: ProjA2_def)
73.81 +done
73.82 +
73.83 +lemma ProjA2_nil: "ProjA2$nil = nil"
73.84 +apply (simp add: ProjA2_def)
73.85 +done
73.86 +
73.87 +lemma ProjA2_cons: "ProjA2$((a,t)>>xs) = (a,fst t) >> ProjA2$xs"
73.88 +apply (simp add: ProjA2_def)
73.89 +done
73.90 +
73.91 +
73.92 +(* ---------------------------------------------------------------- *)
73.93 +(* ProjB2 *)
73.94 +(* ---------------------------------------------------------------- *)
73.95 +
73.96 +
73.97 +lemma ProjB2_UU: "ProjB2$UU = UU"
73.98 +apply (simp add: ProjB2_def)
73.99 +done
73.100 +
73.101 +lemma ProjB2_nil: "ProjB2$nil = nil"
73.102 +apply (simp add: ProjB2_def)
73.103 +done
73.104 +
73.105 +lemma ProjB2_cons: "ProjB2$((a,t)>>xs) = (a,snd t) >> ProjB2$xs"
73.106 +apply (simp add: ProjB2_def)
73.107 +done
73.108 +
73.109 +
73.110 +
73.111 +(* ---------------------------------------------------------------- *)
73.112 +(* Filter_ex2 *)
73.113 +(* ---------------------------------------------------------------- *)
73.114 +
73.115 +
73.116 +lemma Filter_ex2_UU: "Filter_ex2 sig$UU=UU"
73.117 +apply (simp add: Filter_ex2_def)
73.118 +done
73.119 +
73.120 +lemma Filter_ex2_nil: "Filter_ex2 sig$nil=nil"
73.121 +apply (simp add: Filter_ex2_def)
73.122 +done
73.123 +
73.124 +lemma Filter_ex2_cons: "Filter_ex2 sig$(at >> xs) =
73.125 + (if (fst at:actions sig)
73.126 + then at >> (Filter_ex2 sig$xs)
73.127 + else Filter_ex2 sig$xs)"
73.128 +
73.129 +apply (simp add: Filter_ex2_def)
73.130 +done
73.131 +
73.132 +
73.133 +(* ---------------------------------------------------------------- *)
73.134 +(* stutter2 *)
73.135 +(* ---------------------------------------------------------------- *)
73.136 +
73.137 +
73.138 +lemma stutter2_unfold: "stutter2 sig = (LAM ex. (%s. case ex of
73.139 + nil => TT
73.140 + | x##xs => (flift1
73.141 + (%p.(If Def ((fst p)~:actions sig)
73.142 + then Def (s=(snd p))
73.143 + else TT)
73.144 + andalso (stutter2 sig$xs) (snd p))
73.145 + $x)
73.146 + ))"
73.147 +apply (rule trans)
73.148 +apply (rule fix_eq2)
73.149 +apply (simp only: stutter2_def)
73.150 +apply (rule beta_cfun)
73.151 +apply (simp add: flift1_def)
73.152 +done
73.153 +
73.154 +lemma stutter2_UU: "(stutter2 sig$UU) s=UU"
73.155 +apply (subst stutter2_unfold)
73.156 +apply simp
73.157 +done
73.158 +
73.159 +lemma stutter2_nil: "(stutter2 sig$nil) s = TT"
73.160 +apply (subst stutter2_unfold)
73.161 +apply simp
73.162 +done
73.163 +
73.164 +lemma stutter2_cons: "(stutter2 sig$(at>>xs)) s =
73.165 + ((if (fst at)~:actions sig then Def (s=snd at) else TT)
73.166 + andalso (stutter2 sig$xs) (snd at))"
73.167 +apply (rule trans)
73.168 +apply (subst stutter2_unfold)
73.169 +apply (simp add: Consq_def flift1_def If_and_if)
73.170 +apply simp
73.171 +done
73.172 +
73.173 +
73.174 +declare stutter2_UU [simp] stutter2_nil [simp] stutter2_cons [simp]
73.175 +
73.176 +
73.177 +(* ---------------------------------------------------------------- *)
73.178 +(* stutter *)
73.179 +(* ---------------------------------------------------------------- *)
73.180 +
73.181 +lemma stutter_UU: "stutter sig (s, UU)"
73.182 +apply (simp add: stutter_def)
73.183 +done
73.184 +
73.185 +lemma stutter_nil: "stutter sig (s, nil)"
73.186 +apply (simp add: stutter_def)
73.187 +done
73.188 +
73.189 +lemma stutter_cons: "stutter sig (s, (a,t)>>ex) =
73.190 + ((a~:actions sig --> (s=t)) & stutter sig (t,ex))"
73.191 +apply (simp add: stutter_def)
73.192 +done
73.193 +
73.194 +(* ----------------------------------------------------------------------------------- *)
73.195 +
73.196 +declare stutter2_UU [simp del] stutter2_nil [simp del] stutter2_cons [simp del]
73.197 +
73.198 +lemmas compoex_simps = ProjA2_UU ProjA2_nil ProjA2_cons
73.199 + ProjB2_UU ProjB2_nil ProjB2_cons
73.200 + Filter_ex2_UU Filter_ex2_nil Filter_ex2_cons
73.201 + stutter_UU stutter_nil stutter_cons
73.202 +
73.203 +declare compoex_simps [simp]
73.204 +
73.205 +
73.206 +
73.207 +(* ------------------------------------------------------------------ *)
73.208 +(* The following lemmata aim for *)
73.209 +(* COMPOSITIONALITY on EXECUTION Level *)
73.210 +(* ------------------------------------------------------------------ *)
73.211 +
73.212 +
73.213 +(* --------------------------------------------------------------------- *)
73.214 +(* Lemma_1_1a : is_ex_fr propagates from A||B to Projections A and B *)
73.215 +(* --------------------------------------------------------------------- *)
73.216 +
73.217 +lemma lemma_1_1a: "!s. is_exec_frag (A||B) (s,xs)
73.218 + --> is_exec_frag A (fst s, Filter_ex2 (asig_of A)$(ProjA2$xs)) &
73.219 + is_exec_frag B (snd s, Filter_ex2 (asig_of B)$(ProjB2$xs))"
73.220 +
73.221 +apply (tactic {* pair_induct_tac @{context} "xs" [@{thm is_exec_frag_def}] 1 *})
73.222 +(* main case *)
73.223 +apply (auto simp add: trans_of_defs2)
73.224 +done
73.225 +
73.226 +
73.227 +(* --------------------------------------------------------------------- *)
73.228 +(* Lemma_1_1b : is_ex_fr (A||B) implies stuttering on Projections *)
73.229 +(* --------------------------------------------------------------------- *)
73.230 +
73.231 +lemma lemma_1_1b: "!s. is_exec_frag (A||B) (s,xs)
73.232 + --> stutter (asig_of A) (fst s,ProjA2$xs) &
73.233 + stutter (asig_of B) (snd s,ProjB2$xs)"
73.234 +
73.235 +apply (tactic {* pair_induct_tac @{context} "xs"
73.236 + [@{thm stutter_def}, @{thm is_exec_frag_def}] 1 *})
73.237 +(* main case *)
73.238 +apply (auto simp add: trans_of_defs2)
73.239 +done
73.240 +
73.241 +
73.242 +(* --------------------------------------------------------------------- *)
73.243 +(* Lemma_1_1c : Executions of A||B have only A- or B-actions *)
73.244 +(* --------------------------------------------------------------------- *)
73.245 +
73.246 +lemma lemma_1_1c: "!s. (is_exec_frag (A||B) (s,xs)
73.247 + --> Forall (%x. fst x:act (A||B)) xs)"
73.248 +
73.249 +apply (tactic {* pair_induct_tac @{context} "xs" [@{thm Forall_def}, @{thm sforall_def},
73.250 + @{thm is_exec_frag_def}] 1 *})
73.251 +(* main case *)
73.252 +apply auto
73.253 +apply (simp add: trans_of_defs2 actions_asig_comp asig_of_par)
73.254 +done
73.255 +
73.256 +
73.257 +(* ----------------------------------------------------------------------- *)
73.258 +(* Lemma_1_2 : ex A, exB, stuttering and forall a:A|B implies ex (A||B) *)
73.259 +(* ----------------------------------------------------------------------- *)
73.260 +
73.261 +lemma lemma_1_2:
73.262 +"!s. is_exec_frag A (fst s,Filter_ex2 (asig_of A)$(ProjA2$xs)) &
73.263 + is_exec_frag B (snd s,Filter_ex2 (asig_of B)$(ProjB2$xs)) &
73.264 + stutter (asig_of A) (fst s,(ProjA2$xs)) &
73.265 + stutter (asig_of B) (snd s,(ProjB2$xs)) &
73.266 + Forall (%x. fst x:act (A||B)) xs
73.267 + --> is_exec_frag (A||B) (s,xs)"
73.268 +
73.269 +apply (tactic {* pair_induct_tac @{context} "xs" [@{thm Forall_def}, @{thm sforall_def},
73.270 + @{thm is_exec_frag_def}, @{thm stutter_def}] 1 *})
73.271 +apply (auto simp add: trans_of_defs1 actions_asig_comp asig_of_par)
73.272 +done
73.273 +
73.274 +
73.275 +subsection {* COMPOSITIONALITY on EXECUTION Level -- Main Theorem *}
73.276 +
73.277 +lemma compositionality_ex:
73.278 +"(ex:executions(A||B)) =
73.279 + (Filter_ex (asig_of A) (ProjA ex) : executions A &
73.280 + Filter_ex (asig_of B) (ProjB ex) : executions B &
73.281 + stutter (asig_of A) (ProjA ex) & stutter (asig_of B) (ProjB ex) &
73.282 + Forall (%x. fst x:act (A||B)) (snd ex))"
73.283 +
73.284 +apply (simp (no_asm) add: executions_def ProjB_def Filter_ex_def ProjA_def starts_of_par)
73.285 +apply (tactic {* pair_tac @{context} "ex" 1 *})
73.286 +apply (rule iffI)
73.287 +(* ==> *)
73.288 +apply (erule conjE)+
73.289 +apply (simp add: lemma_1_1a lemma_1_1b lemma_1_1c)
73.290 +(* <== *)
73.291 +apply (erule conjE)+
73.292 +apply (simp add: lemma_1_2)
73.293 +done
73.294 +
73.295 +
73.296 +subsection {* COMPOSITIONALITY on EXECUTION Level -- for Modules *}
73.297 +
73.298 +lemma compositionality_ex_modules:
73.299 + "Execs (A||B) = par_execs (Execs A) (Execs B)"
73.300 +apply (unfold Execs_def par_execs_def)
73.301 +apply (simp add: asig_of_par)
73.302 +apply (rule set_eqI)
73.303 +apply (simp add: compositionality_ex actions_of_par)
73.304 +done
73.305 +
73.306 +end
74.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
74.2 +++ b/src/HOL/HOLCF/IOA/meta_theory/CompoScheds.thy Sat Nov 27 16:08:10 2010 -0800
74.3 @@ -0,0 +1,553 @@
74.4 +(* Title: HOLCF/IOA/meta_theory/CompoScheds.thy
74.5 + Author: Olaf Müller
74.6 +*)
74.7 +
74.8 +header {* Compositionality on Schedule level *}
74.9 +
74.10 +theory CompoScheds
74.11 +imports CompoExecs
74.12 +begin
74.13 +
74.14 +definition
74.15 + mkex2 :: "('a,'s)ioa => ('a,'t)ioa => 'a Seq ->
74.16 + ('a,'s)pairs -> ('a,'t)pairs ->
74.17 + ('s => 't => ('a,'s*'t)pairs)" where
74.18 + "mkex2 A B = (fix$(LAM h sch exA exB. (%s t. case sch of
74.19 + nil => nil
74.20 + | x##xs =>
74.21 + (case x of
74.22 + UU => UU
74.23 + | Def y =>
74.24 + (if y:act A then
74.25 + (if y:act B then
74.26 + (case HD$exA of
74.27 + UU => UU
74.28 + | Def a => (case HD$exB of
74.29 + UU => UU
74.30 + | Def b =>
74.31 + (y,(snd a,snd b))>>
74.32 + (h$xs$(TL$exA)$(TL$exB)) (snd a) (snd b)))
74.33 + else
74.34 + (case HD$exA of
74.35 + UU => UU
74.36 + | Def a =>
74.37 + (y,(snd a,t))>>(h$xs$(TL$exA)$exB) (snd a) t)
74.38 + )
74.39 + else
74.40 + (if y:act B then
74.41 + (case HD$exB of
74.42 + UU => UU
74.43 + | Def b =>
74.44 + (y,(s,snd b))>>(h$xs$exA$(TL$exB)) s (snd b))
74.45 + else
74.46 + UU
74.47 + )
74.48 + )
74.49 + ))))"
74.50 +
74.51 +definition
74.52 + mkex :: "('a,'s)ioa => ('a,'t)ioa => 'a Seq =>
74.53 + ('a,'s)execution => ('a,'t)execution =>('a,'s*'t)execution" where
74.54 + "mkex A B sch exA exB =
74.55 + ((fst exA,fst exB),
74.56 + (mkex2 A B$sch$(snd exA)$(snd exB)) (fst exA) (fst exB))"
74.57 +
74.58 +definition
74.59 + par_scheds ::"['a schedule_module,'a schedule_module] => 'a schedule_module" where
74.60 + "par_scheds SchedsA SchedsB =
74.61 + (let schA = fst SchedsA; sigA = snd SchedsA;
74.62 + schB = fst SchedsB; sigB = snd SchedsB
74.63 + in
74.64 + ( {sch. Filter (%a. a:actions sigA)$sch : schA}
74.65 + Int {sch. Filter (%a. a:actions sigB)$sch : schB}
74.66 + Int {sch. Forall (%x. x:(actions sigA Un actions sigB)) sch},
74.67 + asig_comp sigA sigB))"
74.68 +
74.69 +
74.70 +subsection "mkex rewrite rules"
74.71 +
74.72 +
74.73 +lemma mkex2_unfold:
74.74 +"mkex2 A B = (LAM sch exA exB. (%s t. case sch of
74.75 + nil => nil
74.76 + | x##xs =>
74.77 + (case x of
74.78 + UU => UU
74.79 + | Def y =>
74.80 + (if y:act A then
74.81 + (if y:act B then
74.82 + (case HD$exA of
74.83 + UU => UU
74.84 + | Def a => (case HD$exB of
74.85 + UU => UU
74.86 + | Def b =>
74.87 + (y,(snd a,snd b))>>
74.88 + (mkex2 A B$xs$(TL$exA)$(TL$exB)) (snd a) (snd b)))
74.89 + else
74.90 + (case HD$exA of
74.91 + UU => UU
74.92 + | Def a =>
74.93 + (y,(snd a,t))>>(mkex2 A B$xs$(TL$exA)$exB) (snd a) t)
74.94 + )
74.95 + else
74.96 + (if y:act B then
74.97 + (case HD$exB of
74.98 + UU => UU
74.99 + | Def b =>
74.100 + (y,(s,snd b))>>(mkex2 A B$xs$exA$(TL$exB)) s (snd b))
74.101 + else
74.102 + UU
74.103 + )
74.104 + )
74.105 + )))"
74.106 +apply (rule trans)
74.107 +apply (rule fix_eq2)
74.108 +apply (simp only: mkex2_def)
74.109 +apply (rule beta_cfun)
74.110 +apply simp
74.111 +done
74.112 +
74.113 +lemma mkex2_UU: "(mkex2 A B$UU$exA$exB) s t = UU"
74.114 +apply (subst mkex2_unfold)
74.115 +apply simp
74.116 +done
74.117 +
74.118 +lemma mkex2_nil: "(mkex2 A B$nil$exA$exB) s t= nil"
74.119 +apply (subst mkex2_unfold)
74.120 +apply simp
74.121 +done
74.122 +
74.123 +lemma mkex2_cons_1: "[| x:act A; x~:act B; HD$exA=Def a|]
74.124 + ==> (mkex2 A B$(x>>sch)$exA$exB) s t =
74.125 + (x,snd a,t) >> (mkex2 A B$sch$(TL$exA)$exB) (snd a) t"
74.126 +apply (rule trans)
74.127 +apply (subst mkex2_unfold)
74.128 +apply (simp add: Consq_def If_and_if)
74.129 +apply (simp add: Consq_def)
74.130 +done
74.131 +
74.132 +lemma mkex2_cons_2: "[| x~:act A; x:act B; HD$exB=Def b|]
74.133 + ==> (mkex2 A B$(x>>sch)$exA$exB) s t =
74.134 + (x,s,snd b) >> (mkex2 A B$sch$exA$(TL$exB)) s (snd b)"
74.135 +apply (rule trans)
74.136 +apply (subst mkex2_unfold)
74.137 +apply (simp add: Consq_def If_and_if)
74.138 +apply (simp add: Consq_def)
74.139 +done
74.140 +
74.141 +lemma mkex2_cons_3: "[| x:act A; x:act B; HD$exA=Def a;HD$exB=Def b|]
74.142 + ==> (mkex2 A B$(x>>sch)$exA$exB) s t =
74.143 + (x,snd a,snd b) >>
74.144 + (mkex2 A B$sch$(TL$exA)$(TL$exB)) (snd a) (snd b)"
74.145 +apply (rule trans)
74.146 +apply (subst mkex2_unfold)
74.147 +apply (simp add: Consq_def If_and_if)
74.148 +apply (simp add: Consq_def)
74.149 +done
74.150 +
74.151 +declare mkex2_UU [simp] mkex2_nil [simp] mkex2_cons_1 [simp]
74.152 + mkex2_cons_2 [simp] mkex2_cons_3 [simp]
74.153 +
74.154 +
74.155 +subsection {* mkex *}
74.156 +
74.157 +lemma mkex_UU: "mkex A B UU (s,exA) (t,exB) = ((s,t),UU)"
74.158 +apply (simp add: mkex_def)
74.159 +done
74.160 +
74.161 +lemma mkex_nil: "mkex A B nil (s,exA) (t,exB) = ((s,t),nil)"
74.162 +apply (simp add: mkex_def)
74.163 +done
74.164 +
74.165 +lemma mkex_cons_1: "[| x:act A; x~:act B |]
74.166 + ==> mkex A B (x>>sch) (s,a>>exA) (t,exB) =
74.167 + ((s,t), (x,snd a,t) >> snd (mkex A B sch (snd a,exA) (t,exB)))"
74.168 +apply (simp (no_asm) add: mkex_def)
74.169 +apply (cut_tac exA = "a>>exA" in mkex2_cons_1)
74.170 +apply auto
74.171 +done
74.172 +
74.173 +lemma mkex_cons_2: "[| x~:act A; x:act B |]
74.174 + ==> mkex A B (x>>sch) (s,exA) (t,b>>exB) =
74.175 + ((s,t), (x,s,snd b) >> snd (mkex A B sch (s,exA) (snd b,exB)))"
74.176 +apply (simp (no_asm) add: mkex_def)
74.177 +apply (cut_tac exB = "b>>exB" in mkex2_cons_2)
74.178 +apply auto
74.179 +done
74.180 +
74.181 +lemma mkex_cons_3: "[| x:act A; x:act B |]
74.182 + ==> mkex A B (x>>sch) (s,a>>exA) (t,b>>exB) =
74.183 + ((s,t), (x,snd a,snd b) >> snd (mkex A B sch (snd a,exA) (snd b,exB)))"
74.184 +apply (simp (no_asm) add: mkex_def)
74.185 +apply (cut_tac exB = "b>>exB" and exA = "a>>exA" in mkex2_cons_3)
74.186 +apply auto
74.187 +done
74.188 +
74.189 +declare mkex2_UU [simp del] mkex2_nil [simp del]
74.190 + mkex2_cons_1 [simp del] mkex2_cons_2 [simp del] mkex2_cons_3 [simp del]
74.191 +
74.192 +lemmas composch_simps = mkex_UU mkex_nil mkex_cons_1 mkex_cons_2 mkex_cons_3
74.193 +
74.194 +declare composch_simps [simp]
74.195 +
74.196 +
74.197 +subsection {* COMPOSITIONALITY on SCHEDULE Level *}
74.198 +
74.199 +subsubsection "Lemmas for ==>"
74.200 +
74.201 +(* --------------------------------------------------------------------- *)
74.202 +(* Lemma_2_1 : tfilter(ex) and filter_act are commutative *)
74.203 +(* --------------------------------------------------------------------- *)
74.204 +
74.205 +lemma lemma_2_1a:
74.206 + "filter_act$(Filter_ex2 (asig_of A)$xs)=
74.207 + Filter (%a. a:act A)$(filter_act$xs)"
74.208 +
74.209 +apply (unfold filter_act_def Filter_ex2_def)
74.210 +apply (simp (no_asm) add: MapFilter o_def)
74.211 +done
74.212 +
74.213 +
74.214 +(* --------------------------------------------------------------------- *)
74.215 +(* Lemma_2_2 : State-projections do not affect filter_act *)
74.216 +(* --------------------------------------------------------------------- *)
74.217 +
74.218 +lemma lemma_2_1b:
74.219 + "filter_act$(ProjA2$xs) =filter_act$xs &
74.220 + filter_act$(ProjB2$xs) =filter_act$xs"
74.221 +apply (tactic {* pair_induct_tac @{context} "xs" [] 1 *})
74.222 +done
74.223 +
74.224 +
74.225 +(* --------------------------------------------------------------------- *)
74.226 +(* Schedules of A||B have only A- or B-actions *)
74.227 +(* --------------------------------------------------------------------- *)
74.228 +
74.229 +(* very similar to lemma_1_1c, but it is not checking if every action element of
74.230 + an ex is in A or B, but after projecting it onto the action schedule. Of course, this
74.231 + is the same proposition, but we cannot change this one, when then rather lemma_1_1c *)
74.232 +
74.233 +lemma sch_actions_in_AorB: "!s. is_exec_frag (A||B) (s,xs)
74.234 + --> Forall (%x. x:act (A||B)) (filter_act$xs)"
74.235 +
74.236 +apply (tactic {* pair_induct_tac @{context} "xs" [@{thm is_exec_frag_def}, @{thm Forall_def},
74.237 + @{thm sforall_def}] 1 *})
74.238 +(* main case *)
74.239 +apply auto
74.240 +apply (simp add: trans_of_defs2 actions_asig_comp asig_of_par)
74.241 +done
74.242 +
74.243 +
74.244 +subsubsection "Lemmas for <=="
74.245 +
74.246 +(*---------------------------------------------------------------------------
74.247 + Filtering actions out of mkex(sch,exA,exB) yields the oracle sch
74.248 + structural induction
74.249 + --------------------------------------------------------------------------- *)
74.250 +
74.251 +lemma Mapfst_mkex_is_sch: "! exA exB s t.
74.252 + Forall (%x. x:act (A||B)) sch &
74.253 + Filter (%a. a:act A)$sch << filter_act$exA &
74.254 + Filter (%a. a:act B)$sch << filter_act$exB
74.255 + --> filter_act$(snd (mkex A B sch (s,exA) (t,exB))) = sch"
74.256 +
74.257 +apply (tactic {* Seq_induct_tac @{context} "sch" [@{thm Filter_def}, @{thm Forall_def},
74.258 + @{thm sforall_def}, @{thm mkex_def}] 1 *})
74.259 +
74.260 +(* main case *)
74.261 +(* splitting into 4 cases according to a:A, a:B *)
74.262 +apply auto
74.263 +
74.264 +(* Case y:A, y:B *)
74.265 +apply (tactic {* Seq_case_simp_tac @{context} "exA" 1 *})
74.266 +(* Case exA=UU, Case exA=nil*)
74.267 +(* These UU and nil cases are the only places where the assumption filter A sch<<f_act exA
74.268 + is used! --> to generate a contradiction using ~a>>ss<< UU(nil), using theorems
74.269 + Cons_not_less_UU and Cons_not_less_nil *)
74.270 +apply (tactic {* Seq_case_simp_tac @{context} "exB" 1 *})
74.271 +(* Case exA=a>>x, exB=b>>y *)
74.272 +(* here it is important that Seq_case_simp_tac uses no !full!_simp_tac for the cons case,
74.273 + as otherwise mkex_cons_3 would not be rewritten without use of rotate_tac: then tactic
74.274 + would not be generally applicable *)
74.275 +apply simp
74.276 +
74.277 +(* Case y:A, y~:B *)
74.278 +apply (tactic {* Seq_case_simp_tac @{context} "exA" 1 *})
74.279 +apply simp
74.280 +
74.281 +(* Case y~:A, y:B *)
74.282 +apply (tactic {* Seq_case_simp_tac @{context} "exB" 1 *})
74.283 +apply simp
74.284 +
74.285 +(* Case y~:A, y~:B *)
74.286 +apply (simp add: asig_of_par actions_asig_comp)
74.287 +done
74.288 +
74.289 +
74.290 +(* generalizing the proof above to a tactic *)
74.291 +
74.292 +ML {*
74.293 +
74.294 +local
74.295 + val defs = [@{thm Filter_def}, @{thm Forall_def}, @{thm sforall_def}, @{thm mkex_def},
74.296 + @{thm stutter_def}]
74.297 + val asigs = [@{thm asig_of_par}, @{thm actions_asig_comp}]
74.298 +in
74.299 +
74.300 +fun mkex_induct_tac ctxt sch exA exB =
74.301 + let val ss = simpset_of ctxt in
74.302 + EVERY1[Seq_induct_tac ctxt sch defs,
74.303 + asm_full_simp_tac ss,
74.304 + SELECT_GOAL (safe_tac (global_claset_of @{theory Fun})),
74.305 + Seq_case_simp_tac ctxt exA,
74.306 + Seq_case_simp_tac ctxt exB,
74.307 + asm_full_simp_tac ss,
74.308 + Seq_case_simp_tac ctxt exA,
74.309 + asm_full_simp_tac ss,
74.310 + Seq_case_simp_tac ctxt exB,
74.311 + asm_full_simp_tac ss,
74.312 + asm_full_simp_tac (ss addsimps asigs)
74.313 + ]
74.314 + end
74.315 +
74.316 +end
74.317 +*}
74.318 +
74.319 +
74.320 +(*---------------------------------------------------------------------------
74.321 + Projection of mkex(sch,exA,exB) onto A stutters on A
74.322 + structural induction
74.323 + --------------------------------------------------------------------------- *)
74.324 +
74.325 +lemma stutterA_mkex: "! exA exB s t.
74.326 + Forall (%x. x:act (A||B)) sch &
74.327 + Filter (%a. a:act A)$sch << filter_act$exA &
74.328 + Filter (%a. a:act B)$sch << filter_act$exB
74.329 + --> stutter (asig_of A) (s,ProjA2$(snd (mkex A B sch (s,exA) (t,exB))))"
74.330 +
74.331 +apply (tactic {* mkex_induct_tac @{context} "sch" "exA" "exB" *})
74.332 +done
74.333 +
74.334 +
74.335 +lemma stutter_mkex_on_A: "[|
74.336 + Forall (%x. x:act (A||B)) sch ;
74.337 + Filter (%a. a:act A)$sch << filter_act$(snd exA) ;
74.338 + Filter (%a. a:act B)$sch << filter_act$(snd exB) |]
74.339 + ==> stutter (asig_of A) (ProjA (mkex A B sch exA exB))"
74.340 +
74.341 +apply (cut_tac stutterA_mkex)
74.342 +apply (simp add: stutter_def ProjA_def mkex_def)
74.343 +apply (erule allE)+
74.344 +apply (drule mp)
74.345 +prefer 2 apply (assumption)
74.346 +apply simp
74.347 +done
74.348 +
74.349 +
74.350 +(*---------------------------------------------------------------------------
74.351 + Projection of mkex(sch,exA,exB) onto B stutters on B
74.352 + structural induction
74.353 + --------------------------------------------------------------------------- *)
74.354 +
74.355 +lemma stutterB_mkex: "! exA exB s t.
74.356 + Forall (%x. x:act (A||B)) sch &
74.357 + Filter (%a. a:act A)$sch << filter_act$exA &
74.358 + Filter (%a. a:act B)$sch << filter_act$exB
74.359 + --> stutter (asig_of B) (t,ProjB2$(snd (mkex A B sch (s,exA) (t,exB))))"
74.360 +apply (tactic {* mkex_induct_tac @{context} "sch" "exA" "exB" *})
74.361 +done
74.362 +
74.363 +
74.364 +lemma stutter_mkex_on_B: "[|
74.365 + Forall (%x. x:act (A||B)) sch ;
74.366 + Filter (%a. a:act A)$sch << filter_act$(snd exA) ;
74.367 + Filter (%a. a:act B)$sch << filter_act$(snd exB) |]
74.368 + ==> stutter (asig_of B) (ProjB (mkex A B sch exA exB))"
74.369 +apply (cut_tac stutterB_mkex)
74.370 +apply (simp add: stutter_def ProjB_def mkex_def)
74.371 +apply (erule allE)+
74.372 +apply (drule mp)
74.373 +prefer 2 apply (assumption)
74.374 +apply simp
74.375 +done
74.376 +
74.377 +
74.378 +(*---------------------------------------------------------------------------
74.379 + Filter of mkex(sch,exA,exB) to A after projection onto A is exA
74.380 + -- using zip$(proj1$exA)$(proj2$exA) instead of exA --
74.381 + -- because of admissibility problems --
74.382 + structural induction
74.383 + --------------------------------------------------------------------------- *)
74.384 +
74.385 +lemma filter_mkex_is_exA_tmp: "! exA exB s t.
74.386 + Forall (%x. x:act (A||B)) sch &
74.387 + Filter (%a. a:act A)$sch << filter_act$exA &
74.388 + Filter (%a. a:act B)$sch << filter_act$exB
74.389 + --> Filter_ex2 (asig_of A)$(ProjA2$(snd (mkex A B sch (s,exA) (t,exB)))) =
74.390 + Zip$(Filter (%a. a:act A)$sch)$(Map snd$exA)"
74.391 +apply (tactic {* mkex_induct_tac @{context} "sch" "exB" "exA" *})
74.392 +done
74.393 +
74.394 +(*---------------------------------------------------------------------------
74.395 + zip$(proj1$y)$(proj2$y) = y (using the lift operations)
74.396 + lemma for admissibility problems
74.397 + --------------------------------------------------------------------------- *)
74.398 +
74.399 +lemma Zip_Map_fst_snd: "Zip$(Map fst$y)$(Map snd$y) = y"
74.400 +apply (tactic {* Seq_induct_tac @{context} "y" [] 1 *})
74.401 +done
74.402 +
74.403 +
74.404 +(*---------------------------------------------------------------------------
74.405 + filter A$sch = proj1$ex --> zip$(filter A$sch)$(proj2$ex) = ex
74.406 + lemma for eliminating non admissible equations in assumptions
74.407 + --------------------------------------------------------------------------- *)
74.408 +
74.409 +lemma trick_against_eq_in_ass: "!! sch ex.
74.410 + Filter (%a. a:act AB)$sch = filter_act$ex
74.411 + ==> ex = Zip$(Filter (%a. a:act AB)$sch)$(Map snd$ex)"
74.412 +apply (simp add: filter_act_def)
74.413 +apply (rule Zip_Map_fst_snd [symmetric])
74.414 +done
74.415 +
74.416 +(*---------------------------------------------------------------------------
74.417 + Filter of mkex(sch,exA,exB) to A after projection onto A is exA
74.418 + using the above trick
74.419 + --------------------------------------------------------------------------- *)
74.420 +
74.421 +
74.422 +lemma filter_mkex_is_exA: "!!sch exA exB.
74.423 + [| Forall (%a. a:act (A||B)) sch ;
74.424 + Filter (%a. a:act A)$sch = filter_act$(snd exA) ;
74.425 + Filter (%a. a:act B)$sch = filter_act$(snd exB) |]
74.426 + ==> Filter_ex (asig_of A) (ProjA (mkex A B sch exA exB)) = exA"
74.427 +apply (simp add: ProjA_def Filter_ex_def)
74.428 +apply (tactic {* pair_tac @{context} "exA" 1 *})
74.429 +apply (tactic {* pair_tac @{context} "exB" 1 *})
74.430 +apply (rule conjI)
74.431 +apply (simp (no_asm) add: mkex_def)
74.432 +apply (simplesubst trick_against_eq_in_ass)
74.433 +back
74.434 +apply assumption
74.435 +apply (simp add: filter_mkex_is_exA_tmp)
74.436 +done
74.437 +
74.438 +
74.439 +(*---------------------------------------------------------------------------
74.440 + Filter of mkex(sch,exA,exB) to B after projection onto B is exB
74.441 + -- using zip$(proj1$exB)$(proj2$exB) instead of exB --
74.442 + -- because of admissibility problems --
74.443 + structural induction
74.444 + --------------------------------------------------------------------------- *)
74.445 +
74.446 +lemma filter_mkex_is_exB_tmp: "! exA exB s t.
74.447 + Forall (%x. x:act (A||B)) sch &
74.448 + Filter (%a. a:act A)$sch << filter_act$exA &
74.449 + Filter (%a. a:act B)$sch << filter_act$exB
74.450 + --> Filter_ex2 (asig_of B)$(ProjB2$(snd (mkex A B sch (s,exA) (t,exB)))) =
74.451 + Zip$(Filter (%a. a:act B)$sch)$(Map snd$exB)"
74.452 +
74.453 +(* notice necessary change of arguments exA and exB *)
74.454 +apply (tactic {* mkex_induct_tac @{context} "sch" "exA" "exB" *})
74.455 +done
74.456 +
74.457 +
74.458 +(*---------------------------------------------------------------------------
74.459 + Filter of mkex(sch,exA,exB) to A after projection onto B is exB
74.460 + using the above trick
74.461 + --------------------------------------------------------------------------- *)
74.462 +
74.463 +
74.464 +lemma filter_mkex_is_exB: "!!sch exA exB.
74.465 + [| Forall (%a. a:act (A||B)) sch ;
74.466 + Filter (%a. a:act A)$sch = filter_act$(snd exA) ;
74.467 + Filter (%a. a:act B)$sch = filter_act$(snd exB) |]
74.468 + ==> Filter_ex (asig_of B) (ProjB (mkex A B sch exA exB)) = exB"
74.469 +apply (simp add: ProjB_def Filter_ex_def)
74.470 +apply (tactic {* pair_tac @{context} "exA" 1 *})
74.471 +apply (tactic {* pair_tac @{context} "exB" 1 *})
74.472 +apply (rule conjI)
74.473 +apply (simp (no_asm) add: mkex_def)
74.474 +apply (simplesubst trick_against_eq_in_ass)
74.475 +back
74.476 +apply assumption
74.477 +apply (simp add: filter_mkex_is_exB_tmp)
74.478 +done
74.479 +
74.480 +(* --------------------------------------------------------------------- *)
74.481 +(* mkex has only A- or B-actions *)
74.482 +(* --------------------------------------------------------------------- *)
74.483 +
74.484 +
74.485 +lemma mkex_actions_in_AorB: "!s t exA exB.
74.486 + Forall (%x. x : act (A || B)) sch &
74.487 + Filter (%a. a:act A)$sch << filter_act$exA &
74.488 + Filter (%a. a:act B)$sch << filter_act$exB
74.489 + --> Forall (%x. fst x : act (A ||B))
74.490 + (snd (mkex A B sch (s,exA) (t,exB)))"
74.491 +apply (tactic {* mkex_induct_tac @{context} "sch" "exA" "exB" *})
74.492 +done
74.493 +
74.494 +
74.495 +(* ------------------------------------------------------------------ *)
74.496 +(* COMPOSITIONALITY on SCHEDULE Level *)
74.497 +(* Main Theorem *)
74.498 +(* ------------------------------------------------------------------ *)
74.499 +
74.500 +lemma compositionality_sch:
74.501 +"(sch : schedules (A||B)) =
74.502 + (Filter (%a. a:act A)$sch : schedules A &
74.503 + Filter (%a. a:act B)$sch : schedules B &
74.504 + Forall (%x. x:act (A||B)) sch)"
74.505 +apply (simp (no_asm) add: schedules_def has_schedule_def)
74.506 +apply auto
74.507 +(* ==> *)
74.508 +apply (rule_tac x = "Filter_ex (asig_of A) (ProjA ex) " in bexI)
74.509 +prefer 2
74.510 +apply (simp add: compositionality_ex)
74.511 +apply (simp (no_asm) add: Filter_ex_def ProjA_def lemma_2_1a lemma_2_1b)
74.512 +apply (rule_tac x = "Filter_ex (asig_of B) (ProjB ex) " in bexI)
74.513 +prefer 2
74.514 +apply (simp add: compositionality_ex)
74.515 +apply (simp (no_asm) add: Filter_ex_def ProjB_def lemma_2_1a lemma_2_1b)
74.516 +apply (simp add: executions_def)
74.517 +apply (tactic {* pair_tac @{context} "ex" 1 *})
74.518 +apply (erule conjE)
74.519 +apply (simp add: sch_actions_in_AorB)
74.520 +
74.521 +(* <== *)
74.522 +
74.523 +(* mkex is exactly the construction of exA||B out of exA, exB, and the oracle sch,
74.524 + we need here *)
74.525 +apply (rename_tac exA exB)
74.526 +apply (rule_tac x = "mkex A B sch exA exB" in bexI)
74.527 +(* mkex actions are just the oracle *)
74.528 +apply (tactic {* pair_tac @{context} "exA" 1 *})
74.529 +apply (tactic {* pair_tac @{context} "exB" 1 *})
74.530 +apply (simp add: Mapfst_mkex_is_sch)
74.531 +
74.532 +(* mkex is an execution -- use compositionality on ex-level *)
74.533 +apply (simp add: compositionality_ex)
74.534 +apply (simp add: stutter_mkex_on_A stutter_mkex_on_B filter_mkex_is_exB filter_mkex_is_exA)
74.535 +apply (tactic {* pair_tac @{context} "exA" 1 *})
74.536 +apply (tactic {* pair_tac @{context} "exB" 1 *})
74.537 +apply (simp add: mkex_actions_in_AorB)
74.538 +done
74.539 +
74.540 +
74.541 +subsection {* COMPOSITIONALITY on SCHEDULE Level -- for Modules *}
74.542 +
74.543 +lemma compositionality_sch_modules:
74.544 + "Scheds (A||B) = par_scheds (Scheds A) (Scheds B)"
74.545 +
74.546 +apply (unfold Scheds_def par_scheds_def)
74.547 +apply (simp add: asig_of_par)
74.548 +apply (rule set_eqI)
74.549 +apply (simp add: compositionality_sch actions_of_par)
74.550 +done
74.551 +
74.552 +
74.553 +declare compoex_simps [simp del]
74.554 +declare composch_simps [simp del]
74.555 +
74.556 +end
75.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
75.2 +++ b/src/HOL/HOLCF/IOA/meta_theory/CompoTraces.thy Sat Nov 27 16:08:10 2010 -0800
75.3 @@ -0,0 +1,973 @@
75.4 +(* Title: HOLCF/IOA/meta_theory/CompoTraces.thy
75.5 + Author: Olaf Müller
75.6 +*)
75.7 +
75.8 +header {* Compositionality on Trace level *}
75.9 +
75.10 +theory CompoTraces
75.11 +imports CompoScheds ShortExecutions
75.12 +begin
75.13 +
75.14 +
75.15 +consts
75.16 +
75.17 + mksch ::"('a,'s)ioa => ('a,'t)ioa => 'a Seq -> 'a Seq -> 'a Seq -> 'a Seq"
75.18 + par_traces ::"['a trace_module,'a trace_module] => 'a trace_module"
75.19 +
75.20 +defs
75.21 +
75.22 +mksch_def:
75.23 + "mksch A B == (fix$(LAM h tr schA schB. case tr of
75.24 + nil => nil
75.25 + | x##xs =>
75.26 + (case x of
75.27 + UU => UU
75.28 + | Def y =>
75.29 + (if y:act A then
75.30 + (if y:act B then
75.31 + ((Takewhile (%a. a:int A)$schA)
75.32 + @@ (Takewhile (%a. a:int B)$schB)
75.33 + @@ (y>>(h$xs
75.34 + $(TL$(Dropwhile (%a. a:int A)$schA))
75.35 + $(TL$(Dropwhile (%a. a:int B)$schB))
75.36 + )))
75.37 + else
75.38 + ((Takewhile (%a. a:int A)$schA)
75.39 + @@ (y>>(h$xs
75.40 + $(TL$(Dropwhile (%a. a:int A)$schA))
75.41 + $schB)))
75.42 + )
75.43 + else
75.44 + (if y:act B then
75.45 + ((Takewhile (%a. a:int B)$schB)
75.46 + @@ (y>>(h$xs
75.47 + $schA
75.48 + $(TL$(Dropwhile (%a. a:int B)$schB))
75.49 + )))
75.50 + else
75.51 + UU
75.52 + )
75.53 + )
75.54 + )))"
75.55 +
75.56 +
75.57 +par_traces_def:
75.58 + "par_traces TracesA TracesB ==
75.59 + let trA = fst TracesA; sigA = snd TracesA;
75.60 + trB = fst TracesB; sigB = snd TracesB
75.61 + in
75.62 + ( {tr. Filter (%a. a:actions sigA)$tr : trA}
75.63 + Int {tr. Filter (%a. a:actions sigB)$tr : trB}
75.64 + Int {tr. Forall (%x. x:(externals sigA Un externals sigB)) tr},
75.65 + asig_comp sigA sigB)"
75.66 +
75.67 +axioms
75.68 +
75.69 +finiteR_mksch:
75.70 + "Finite (mksch A B$tr$x$y) --> Finite tr"
75.71 +
75.72 +
75.73 +declaration {* fn _ => Simplifier.map_ss (fn ss => ss setmksym (K (K NONE))) *}
75.74 +
75.75 +
75.76 +subsection "mksch rewrite rules"
75.77 +
75.78 +lemma mksch_unfold:
75.79 +"mksch A B = (LAM tr schA schB. case tr of
75.80 + nil => nil
75.81 + | x##xs =>
75.82 + (case x of
75.83 + UU => UU
75.84 + | Def y =>
75.85 + (if y:act A then
75.86 + (if y:act B then
75.87 + ((Takewhile (%a. a:int A)$schA)
75.88 + @@(Takewhile (%a. a:int B)$schB)
75.89 + @@(y>>(mksch A B$xs
75.90 + $(TL$(Dropwhile (%a. a:int A)$schA))
75.91 + $(TL$(Dropwhile (%a. a:int B)$schB))
75.92 + )))
75.93 + else
75.94 + ((Takewhile (%a. a:int A)$schA)
75.95 + @@ (y>>(mksch A B$xs
75.96 + $(TL$(Dropwhile (%a. a:int A)$schA))
75.97 + $schB)))
75.98 + )
75.99 + else
75.100 + (if y:act B then
75.101 + ((Takewhile (%a. a:int B)$schB)
75.102 + @@ (y>>(mksch A B$xs
75.103 + $schA
75.104 + $(TL$(Dropwhile (%a. a:int B)$schB))
75.105 + )))
75.106 + else
75.107 + UU
75.108 + )
75.109 + )
75.110 + ))"
75.111 +apply (rule trans)
75.112 +apply (rule fix_eq2)
75.113 +apply (rule mksch_def)
75.114 +apply (rule beta_cfun)
75.115 +apply simp
75.116 +done
75.117 +
75.118 +lemma mksch_UU: "mksch A B$UU$schA$schB = UU"
75.119 +apply (subst mksch_unfold)
75.120 +apply simp
75.121 +done
75.122 +
75.123 +lemma mksch_nil: "mksch A B$nil$schA$schB = nil"
75.124 +apply (subst mksch_unfold)
75.125 +apply simp
75.126 +done
75.127 +
75.128 +lemma mksch_cons1: "[|x:act A;x~:act B|]
75.129 + ==> mksch A B$(x>>tr)$schA$schB =
75.130 + (Takewhile (%a. a:int A)$schA)
75.131 + @@ (x>>(mksch A B$tr$(TL$(Dropwhile (%a. a:int A)$schA))
75.132 + $schB))"
75.133 +apply (rule trans)
75.134 +apply (subst mksch_unfold)
75.135 +apply (simp add: Consq_def If_and_if)
75.136 +apply (simp add: Consq_def)
75.137 +done
75.138 +
75.139 +lemma mksch_cons2: "[|x~:act A;x:act B|]
75.140 + ==> mksch A B$(x>>tr)$schA$schB =
75.141 + (Takewhile (%a. a:int B)$schB)
75.142 + @@ (x>>(mksch A B$tr$schA$(TL$(Dropwhile (%a. a:int B)$schB))
75.143 + ))"
75.144 +apply (rule trans)
75.145 +apply (subst mksch_unfold)
75.146 +apply (simp add: Consq_def If_and_if)
75.147 +apply (simp add: Consq_def)
75.148 +done
75.149 +
75.150 +lemma mksch_cons3: "[|x:act A;x:act B|]
75.151 + ==> mksch A B$(x>>tr)$schA$schB =
75.152 + (Takewhile (%a. a:int A)$schA)
75.153 + @@ ((Takewhile (%a. a:int B)$schB)
75.154 + @@ (x>>(mksch A B$tr$(TL$(Dropwhile (%a. a:int A)$schA))
75.155 + $(TL$(Dropwhile (%a. a:int B)$schB))))
75.156 + )"
75.157 +apply (rule trans)
75.158 +apply (subst mksch_unfold)
75.159 +apply (simp add: Consq_def If_and_if)
75.160 +apply (simp add: Consq_def)
75.161 +done
75.162 +
75.163 +lemmas compotr_simps = mksch_UU mksch_nil mksch_cons1 mksch_cons2 mksch_cons3
75.164 +
75.165 +declare compotr_simps [simp]
75.166 +
75.167 +
75.168 +subsection {* COMPOSITIONALITY on TRACE Level *}
75.169 +
75.170 +subsubsection "Lemmata for ==>"
75.171 +
75.172 +(* Consequence out of ext1_ext2_is_not_act1(2), which in turn are consequences out of
75.173 + the compatibility of IOA, in particular out of the condition that internals are
75.174 + really hidden. *)
75.175 +
75.176 +lemma compatibility_consequence1: "(eB & ~eA --> ~A) -->
75.177 + (A & (eA | eB)) = (eA & A)"
75.178 +apply fast
75.179 +done
75.180 +
75.181 +
75.182 +(* very similar to above, only the commutativity of | is used to make a slight change *)
75.183 +
75.184 +lemma compatibility_consequence2: "(eB & ~eA --> ~A) -->
75.185 + (A & (eB | eA)) = (eA & A)"
75.186 +apply fast
75.187 +done
75.188 +
75.189 +
75.190 +subsubsection "Lemmata for <=="
75.191 +
75.192 +(* Lemma for substitution of looping assumption in another specific assumption *)
75.193 +lemma subst_lemma1: "[| f << (g x) ; x=(h x) |] ==> f << g (h x)"
75.194 +by (erule subst)
75.195 +
75.196 +(* Lemma for substitution of looping assumption in another specific assumption *)
75.197 +lemma subst_lemma2: "[| (f x) = y >> g; x=(h x) |] ==> (f (h x)) = y >> g"
75.198 +by (erule subst)
75.199 +
75.200 +lemma ForallAorB_mksch [rule_format]:
75.201 + "!!A B. compatible A B ==>
75.202 + ! schA schB. Forall (%x. x:act (A||B)) tr
75.203 + --> Forall (%x. x:act (A||B)) (mksch A B$tr$schA$schB)"
75.204 +apply (tactic {* Seq_induct_tac @{context} "tr"
75.205 + [@{thm Forall_def}, @{thm sforall_def}, @{thm mksch_def}] 1 *})
75.206 +apply auto
75.207 +apply (simp add: actions_of_par)
75.208 +apply (case_tac "a:act A")
75.209 +apply (case_tac "a:act B")
75.210 +(* a:A, a:B *)
75.211 +apply simp
75.212 +apply (rule Forall_Conc_impl [THEN mp])
75.213 +apply (simp add: intA_is_not_actB int_is_act)
75.214 +apply (rule Forall_Conc_impl [THEN mp])
75.215 +apply (simp add: intA_is_not_actB int_is_act)
75.216 +(* a:A,a~:B *)
75.217 +apply simp
75.218 +apply (rule Forall_Conc_impl [THEN mp])
75.219 +apply (simp add: intA_is_not_actB int_is_act)
75.220 +apply (case_tac "a:act B")
75.221 +(* a~:A, a:B *)
75.222 +apply simp
75.223 +apply (rule Forall_Conc_impl [THEN mp])
75.224 +apply (simp add: intA_is_not_actB int_is_act)
75.225 +(* a~:A,a~:B *)
75.226 +apply auto
75.227 +done
75.228 +
75.229 +lemma ForallBnAmksch [rule_format (no_asm)]: "!!A B. compatible B A ==>
75.230 + ! schA schB. (Forall (%x. x:act B & x~:act A) tr
75.231 + --> Forall (%x. x:act B & x~:act A) (mksch A B$tr$schA$schB))"
75.232 +apply (tactic {* Seq_induct_tac @{context} "tr"
75.233 + [@{thm Forall_def}, @{thm sforall_def}, @{thm mksch_def}] 1 *})
75.234 +apply auto
75.235 +apply (rule Forall_Conc_impl [THEN mp])
75.236 +apply (simp add: intA_is_not_actB int_is_act)
75.237 +done
75.238 +
75.239 +lemma ForallAnBmksch [rule_format (no_asm)]: "!!A B. compatible A B ==>
75.240 + ! schA schB. (Forall (%x. x:act A & x~:act B) tr
75.241 + --> Forall (%x. x:act A & x~:act B) (mksch A B$tr$schA$schB))"
75.242 +apply (tactic {* Seq_induct_tac @{context} "tr"
75.243 + [@{thm Forall_def}, @{thm sforall_def}, @{thm mksch_def}] 1 *})
75.244 +apply auto
75.245 +apply (rule Forall_Conc_impl [THEN mp])
75.246 +apply (simp add: intA_is_not_actB int_is_act)
75.247 +done
75.248 +
75.249 +(* safe-tac makes too many case distinctions with this lemma in the next proof *)
75.250 +declare FiniteConc [simp del]
75.251 +
75.252 +lemma FiniteL_mksch [rule_format (no_asm)]: "[| Finite tr; is_asig(asig_of A); is_asig(asig_of B) |] ==>
75.253 + ! x y. Forall (%x. x:act A) x & Forall (%x. x:act B) y &
75.254 + Filter (%a. a:ext A)$x = Filter (%a. a:act A)$tr &
75.255 + Filter (%a. a:ext B)$y = Filter (%a. a:act B)$tr &
75.256 + Forall (%x. x:ext (A||B)) tr
75.257 + --> Finite (mksch A B$tr$x$y)"
75.258 +
75.259 +apply (erule Seq_Finite_ind)
75.260 +apply simp
75.261 +(* main case *)
75.262 +apply simp
75.263 +apply auto
75.264 +
75.265 +(* a: act A; a: act B *)
75.266 +apply (frule sym [THEN eq_imp_below, THEN divide_Seq])
75.267 +apply (frule sym [THEN eq_imp_below, THEN divide_Seq])
75.268 +back
75.269 +apply (erule conjE)+
75.270 +(* Finite (tw iA x) and Finite (tw iB y) *)
75.271 +apply (simp add: not_ext_is_int_or_not_act FiniteConc)
75.272 +(* now for conclusion IH applicable, but assumptions have to be transformed *)
75.273 +apply (drule_tac x = "x" and g = "Filter (%a. a:act A) $s" in subst_lemma2)
75.274 +apply assumption
75.275 +apply (drule_tac x = "y" and g = "Filter (%a. a:act B) $s" in subst_lemma2)
75.276 +apply assumption
75.277 +(* IH *)
75.278 +apply (simp add: not_ext_is_int_or_not_act ForallTL ForallDropwhile)
75.279 +
75.280 +(* a: act B; a~: act A *)
75.281 +apply (frule sym [THEN eq_imp_below, THEN divide_Seq])
75.282 +
75.283 +apply (erule conjE)+
75.284 +(* Finite (tw iB y) *)
75.285 +apply (simp add: not_ext_is_int_or_not_act FiniteConc)
75.286 +(* now for conclusion IH applicable, but assumptions have to be transformed *)
75.287 +apply (drule_tac x = "y" and g = "Filter (%a. a:act B) $s" in subst_lemma2)
75.288 +apply assumption
75.289 +(* IH *)
75.290 +apply (simp add: not_ext_is_int_or_not_act ForallTL ForallDropwhile)
75.291 +
75.292 +(* a~: act B; a: act A *)
75.293 +apply (frule sym [THEN eq_imp_below, THEN divide_Seq])
75.294 +
75.295 +apply (erule conjE)+
75.296 +(* Finite (tw iA x) *)
75.297 +apply (simp add: not_ext_is_int_or_not_act FiniteConc)
75.298 +(* now for conclusion IH applicable, but assumptions have to be transformed *)
75.299 +apply (drule_tac x = "x" and g = "Filter (%a. a:act A) $s" in subst_lemma2)
75.300 +apply assumption
75.301 +(* IH *)
75.302 +apply (simp add: not_ext_is_int_or_not_act ForallTL ForallDropwhile)
75.303 +
75.304 +(* a~: act B; a~: act A *)
75.305 +apply (fastsimp intro!: ext_is_act simp: externals_of_par)
75.306 +done
75.307 +
75.308 +declare FiniteConc [simp]
75.309 +
75.310 +declare FilterConc [simp del]
75.311 +
75.312 +lemma reduceA_mksch1 [rule_format (no_asm)]: " [| Finite bs; is_asig(asig_of A); is_asig(asig_of B);compatible A B|] ==>
75.313 + ! y. Forall (%x. x:act B) y & Forall (%x. x:act B & x~:act A) bs &
75.314 + Filter (%a. a:ext B)$y = Filter (%a. a:act B)$(bs @@ z)
75.315 + --> (? y1 y2. (mksch A B$(bs @@ z)$x$y) = (y1 @@ (mksch A B$z$x$y2)) &
75.316 + Forall (%x. x:act B & x~:act A) y1 &
75.317 + Finite y1 & y = (y1 @@ y2) &
75.318 + Filter (%a. a:ext B)$y1 = bs)"
75.319 +apply (frule_tac A1 = "A" in compat_commute [THEN iffD1])
75.320 +apply (erule Seq_Finite_ind)
75.321 +apply (rule allI)+
75.322 +apply (rule impI)
75.323 +apply (rule_tac x = "nil" in exI)
75.324 +apply (rule_tac x = "y" in exI)
75.325 +apply simp
75.326 +(* main case *)
75.327 +apply (rule allI)+
75.328 +apply (rule impI)
75.329 +apply simp
75.330 +apply (erule conjE)+
75.331 +apply simp
75.332 +(* divide_Seq on s *)
75.333 +apply (frule sym [THEN eq_imp_below, THEN divide_Seq])
75.334 +apply (erule conjE)+
75.335 +(* transform assumption f eB y = f B (s@z) *)
75.336 +apply (drule_tac x = "y" and g = "Filter (%a. a:act B) $ (s@@z) " in subst_lemma2)
75.337 +apply assumption
75.338 +apply (simp add: not_ext_is_int_or_not_act FilterConc)
75.339 +(* apply IH *)
75.340 +apply (erule_tac x = "TL$ (Dropwhile (%a. a:int B) $y) " in allE)
75.341 +apply (simp add: ForallTL ForallDropwhile FilterConc)
75.342 +apply (erule exE)+
75.343 +apply (erule conjE)+
75.344 +apply (simp add: FilterConc)
75.345 +(* for replacing IH in conclusion *)
75.346 +apply (rotate_tac -2)
75.347 +(* instantiate y1a and y2a *)
75.348 +apply (rule_tac x = "Takewhile (%a. a:int B) $y @@ a>>y1" in exI)
75.349 +apply (rule_tac x = "y2" in exI)
75.350 +(* elminate all obligations up to two depending on Conc_assoc *)
75.351 +apply (simp add: intA_is_not_actB int_is_act int_is_not_ext FilterConc)
75.352 +apply (simp (no_asm) add: Conc_assoc FilterConc)
75.353 +done
75.354 +
75.355 +lemmas reduceA_mksch = conjI [THEN [6] conjI [THEN [5] reduceA_mksch1]]
75.356 +
75.357 +lemma reduceB_mksch1 [rule_format]:
75.358 +" [| Finite a_s; is_asig(asig_of A); is_asig(asig_of B);compatible A B|] ==>
75.359 + ! x. Forall (%x. x:act A) x & Forall (%x. x:act A & x~:act B) a_s &
75.360 + Filter (%a. a:ext A)$x = Filter (%a. a:act A)$(a_s @@ z)
75.361 + --> (? x1 x2. (mksch A B$(a_s @@ z)$x$y) = (x1 @@ (mksch A B$z$x2$y)) &
75.362 + Forall (%x. x:act A & x~:act B) x1 &
75.363 + Finite x1 & x = (x1 @@ x2) &
75.364 + Filter (%a. a:ext A)$x1 = a_s)"
75.365 +apply (frule_tac A1 = "A" in compat_commute [THEN iffD1])
75.366 +apply (erule Seq_Finite_ind)
75.367 +apply (rule allI)+
75.368 +apply (rule impI)
75.369 +apply (rule_tac x = "nil" in exI)
75.370 +apply (rule_tac x = "x" in exI)
75.371 +apply simp
75.372 +(* main case *)
75.373 +apply (rule allI)+
75.374 +apply (rule impI)
75.375 +apply simp
75.376 +apply (erule conjE)+
75.377 +apply simp
75.378 +(* divide_Seq on s *)
75.379 +apply (frule sym [THEN eq_imp_below, THEN divide_Seq])
75.380 +apply (erule conjE)+
75.381 +(* transform assumption f eA x = f A (s@z) *)
75.382 +apply (drule_tac x = "x" and g = "Filter (%a. a:act A) $ (s@@z) " in subst_lemma2)
75.383 +apply assumption
75.384 +apply (simp add: not_ext_is_int_or_not_act FilterConc)
75.385 +(* apply IH *)
75.386 +apply (erule_tac x = "TL$ (Dropwhile (%a. a:int A) $x) " in allE)
75.387 +apply (simp add: ForallTL ForallDropwhile FilterConc)
75.388 +apply (erule exE)+
75.389 +apply (erule conjE)+
75.390 +apply (simp add: FilterConc)
75.391 +(* for replacing IH in conclusion *)
75.392 +apply (rotate_tac -2)
75.393 +(* instantiate y1a and y2a *)
75.394 +apply (rule_tac x = "Takewhile (%a. a:int A) $x @@ a>>x1" in exI)
75.395 +apply (rule_tac x = "x2" in exI)
75.396 +(* elminate all obligations up to two depending on Conc_assoc *)
75.397 +apply (simp add: intA_is_not_actB int_is_act int_is_not_ext FilterConc)
75.398 +apply (simp (no_asm) add: Conc_assoc FilterConc)
75.399 +done
75.400 +
75.401 +lemmas reduceB_mksch = conjI [THEN [6] conjI [THEN [5] reduceB_mksch1]]
75.402 +
75.403 +declare FilterConc [simp]
75.404 +
75.405 +
75.406 +subsection "Filtering external actions out of mksch(tr,schA,schB) yields the oracle tr"
75.407 +
75.408 +lemma FilterA_mksch_is_tr:
75.409 +"!! A B. [| compatible A B; compatible B A;
75.410 + is_asig(asig_of A); is_asig(asig_of B) |] ==>
75.411 + ! schA schB. Forall (%x. x:act A) schA & Forall (%x. x:act B) schB &
75.412 + Forall (%x. x:ext (A||B)) tr &
75.413 + Filter (%a. a:act A)$tr << Filter (%a. a:ext A)$schA &
75.414 + Filter (%a. a:act B)$tr << Filter (%a. a:ext B)$schB
75.415 + --> Filter (%a. a:ext (A||B))$(mksch A B$tr$schA$schB) = tr"
75.416 +
75.417 +apply (tactic {* Seq_induct_tac @{context} "tr"
75.418 + [@{thm Forall_def}, @{thm sforall_def}, @{thm mksch_def}] 1 *})
75.419 +(* main case *)
75.420 +(* splitting into 4 cases according to a:A, a:B *)
75.421 +apply auto
75.422 +
75.423 +(* Case a:A, a:B *)
75.424 +apply (frule divide_Seq)
75.425 +apply (frule divide_Seq)
75.426 +back
75.427 +apply (erule conjE)+
75.428 +(* filtering internals of A in schA and of B in schB is nil *)
75.429 +apply (simp add: not_ext_is_int_or_not_act externals_of_par intA_is_not_extB int_is_not_ext)
75.430 +(* conclusion of IH ok, but assumptions of IH have to be transformed *)
75.431 +apply (drule_tac x = "schA" in subst_lemma1)
75.432 +apply assumption
75.433 +apply (drule_tac x = "schB" in subst_lemma1)
75.434 +apply assumption
75.435 +(* IH *)
75.436 +apply (simp add: not_ext_is_int_or_not_act ForallTL ForallDropwhile)
75.437 +
75.438 +(* Case a:A, a~:B *)
75.439 +apply (frule divide_Seq)
75.440 +apply (erule conjE)+
75.441 +(* filtering internals of A is nil *)
75.442 +apply (simp add: not_ext_is_int_or_not_act externals_of_par intA_is_not_extB int_is_not_ext)
75.443 +apply (drule_tac x = "schA" in subst_lemma1)
75.444 +apply assumption
75.445 +apply (simp add: not_ext_is_int_or_not_act ForallTL ForallDropwhile)
75.446 +
75.447 +(* Case a:B, a~:A *)
75.448 +apply (frule divide_Seq)
75.449 +apply (erule conjE)+
75.450 +(* filtering internals of A is nil *)
75.451 +apply (simp add: not_ext_is_int_or_not_act externals_of_par intA_is_not_extB int_is_not_ext)
75.452 +apply (drule_tac x = "schB" in subst_lemma1)
75.453 +back
75.454 +apply assumption
75.455 +apply (simp add: not_ext_is_int_or_not_act ForallTL ForallDropwhile)
75.456 +
75.457 +(* Case a~:A, a~:B *)
75.458 +apply (fastsimp intro!: ext_is_act simp: externals_of_par)
75.459 +done
75.460 +
75.461 +
75.462 +subsection" Filter of mksch(tr,schA,schB) to A is schA -- take lemma proof"
75.463 +
75.464 +lemma FilterAmksch_is_schA: "!! A B. [| compatible A B; compatible B A;
75.465 + is_asig(asig_of A); is_asig(asig_of B) |] ==>
75.466 + Forall (%x. x:ext (A||B)) tr &
75.467 + Forall (%x. x:act A) schA & Forall (%x. x:act B) schB &
75.468 + Filter (%a. a:ext A)$schA = Filter (%a. a:act A)$tr &
75.469 + Filter (%a. a:ext B)$schB = Filter (%a. a:act B)$tr &
75.470 + LastActExtsch A schA & LastActExtsch B schB
75.471 + --> Filter (%a. a:act A)$(mksch A B$tr$schA$schB) = schA"
75.472 +apply (intro strip)
75.473 +apply (rule seq.take_lemma)
75.474 +apply (rule mp)
75.475 +prefer 2 apply assumption
75.476 +back back back back
75.477 +apply (rule_tac x = "schA" in spec)
75.478 +apply (rule_tac x = "schB" in spec)
75.479 +apply (rule_tac x = "tr" in spec)
75.480 +apply (tactic "thin_tac' 5 1")
75.481 +apply (rule nat_less_induct)
75.482 +apply (rule allI)+
75.483 +apply (rename_tac tr schB schA)
75.484 +apply (intro strip)
75.485 +apply (erule conjE)+
75.486 +
75.487 +apply (case_tac "Forall (%x. x:act B & x~:act A) tr")
75.488 +
75.489 +apply (rule seq_take_lemma [THEN iffD2, THEN spec])
75.490 +apply (tactic "thin_tac' 5 1")
75.491 +
75.492 +
75.493 +apply (case_tac "Finite tr")
75.494 +
75.495 +(* both sides of this equation are nil *)
75.496 +apply (subgoal_tac "schA=nil")
75.497 +apply (simp (no_asm_simp))
75.498 +(* first side: mksch = nil *)
75.499 +apply (auto intro!: ForallQFilterPnil ForallBnAmksch FiniteL_mksch)[1]
75.500 +(* second side: schA = nil *)
75.501 +apply (erule_tac A = "A" in LastActExtimplnil)
75.502 +apply (simp (no_asm_simp))
75.503 +apply (erule_tac Q = "%x. x:act B & x~:act A" in ForallQFilterPnil)
75.504 +apply assumption
75.505 +apply fast
75.506 +
75.507 +(* case ~ Finite s *)
75.508 +
75.509 +(* both sides of this equation are UU *)
75.510 +apply (subgoal_tac "schA=UU")
75.511 +apply (simp (no_asm_simp))
75.512 +(* first side: mksch = UU *)
75.513 +apply (auto intro!: ForallQFilterPUU finiteR_mksch [THEN mp, COMP rev_contrapos] ForallBnAmksch)[1]
75.514 +(* schA = UU *)
75.515 +apply (erule_tac A = "A" in LastActExtimplUU)
75.516 +apply (simp (no_asm_simp))
75.517 +apply (erule_tac Q = "%x. x:act B & x~:act A" in ForallQFilterPUU)
75.518 +apply assumption
75.519 +apply fast
75.520 +
75.521 +(* case" ~ Forall (%x.x:act B & x~:act A) s" *)
75.522 +
75.523 +apply (drule divide_Seq3)
75.524 +
75.525 +apply (erule exE)+
75.526 +apply (erule conjE)+
75.527 +apply hypsubst
75.528 +
75.529 +(* bring in lemma reduceA_mksch *)
75.530 +apply (frule_tac x = "schA" and y = "schB" and A = "A" and B = "B" in reduceA_mksch)
75.531 +apply assumption+
75.532 +apply (erule exE)+
75.533 +apply (erule conjE)+
75.534 +
75.535 +(* use reduceA_mksch to rewrite conclusion *)
75.536 +apply hypsubst
75.537 +apply simp
75.538 +
75.539 +(* eliminate the B-only prefix *)
75.540 +
75.541 +apply (subgoal_tac " (Filter (%a. a :act A) $y1) = nil")
75.542 +apply (erule_tac [2] ForallQFilterPnil)
75.543 +prefer 2 apply assumption
75.544 +prefer 2 apply fast
75.545 +
75.546 +(* Now real recursive step follows (in y) *)
75.547 +
75.548 +apply simp
75.549 +apply (case_tac "x:act A")
75.550 +apply (case_tac "x~:act B")
75.551 +apply (rotate_tac -2)
75.552 +apply simp
75.553 +
75.554 +apply (subgoal_tac "Filter (%a. a:act A & a:ext B) $y1=nil")
75.555 +apply (rotate_tac -1)
75.556 +apply simp
75.557 +(* eliminate introduced subgoal 2 *)
75.558 +apply (erule_tac [2] ForallQFilterPnil)
75.559 +prefer 2 apply assumption
75.560 +prefer 2 apply fast
75.561 +
75.562 +(* bring in divide Seq for s *)
75.563 +apply (frule sym [THEN eq_imp_below, THEN divide_Seq])
75.564 +apply (erule conjE)+
75.565 +
75.566 +(* subst divide_Seq in conclusion, but only at the righest occurence *)
75.567 +apply (rule_tac t = "schA" in ssubst)
75.568 +back
75.569 +back
75.570 +back
75.571 +apply assumption
75.572 +
75.573 +(* reduce trace_takes from n to strictly smaller k *)
75.574 +apply (rule take_reduction)
75.575 +
75.576 +(* f A (tw iA) = tw ~eA *)
75.577 +apply (simp add: int_is_act not_ext_is_int_or_not_act)
75.578 +apply (rule refl)
75.579 +apply (simp add: int_is_act not_ext_is_int_or_not_act)
75.580 +apply (rotate_tac -11)
75.581 +
75.582 +(* now conclusion fulfills induction hypothesis, but assumptions are not ready *)
75.583 +
75.584 +(* assumption Forall tr *)
75.585 +(* assumption schB *)
75.586 +apply (simp add: ext_and_act)
75.587 +(* assumption schA *)
75.588 +apply (drule_tac x = "schA" and g = "Filter (%a. a:act A) $rs" in subst_lemma2)
75.589 +apply assumption
75.590 +apply (simp add: int_is_not_ext)
75.591 +(* assumptions concerning LastActExtsch, cannot be rewritten, as LastActExtsmalli are looping *)
75.592 +apply (drule_tac sch = "schA" and P = "%a. a:int A" in LastActExtsmall1)
75.593 +apply (frule_tac ?sch1.0 = "y1" in LastActExtsmall2)
75.594 +apply assumption
75.595 +
75.596 +(* assumption Forall schA *)
75.597 +apply (drule_tac s = "schA" and P = "Forall (%x. x:act A) " in subst)
75.598 +apply assumption
75.599 +apply (simp add: int_is_act)
75.600 +
75.601 +(* case x:actions(asig_of A) & x: actions(asig_of B) *)
75.602 +
75.603 +
75.604 +apply (rotate_tac -2)
75.605 +apply simp
75.606 +
75.607 +apply (subgoal_tac "Filter (%a. a:act A & a:ext B) $y1=nil")
75.608 +apply (rotate_tac -1)
75.609 +apply simp
75.610 +(* eliminate introduced subgoal 2 *)
75.611 +apply (erule_tac [2] ForallQFilterPnil)
75.612 +prefer 2 apply (assumption)
75.613 +prefer 2 apply (fast)
75.614 +
75.615 +(* bring in divide Seq for s *)
75.616 +apply (frule sym [THEN eq_imp_below, THEN divide_Seq])
75.617 +apply (erule conjE)+
75.618 +
75.619 +(* subst divide_Seq in conclusion, but only at the righest occurence *)
75.620 +apply (rule_tac t = "schA" in ssubst)
75.621 +back
75.622 +back
75.623 +back
75.624 +apply assumption
75.625 +
75.626 +(* f A (tw iA) = tw ~eA *)
75.627 +apply (simp add: int_is_act not_ext_is_int_or_not_act)
75.628 +
75.629 +(* rewrite assumption forall and schB *)
75.630 +apply (rotate_tac 13)
75.631 +apply (simp add: ext_and_act)
75.632 +
75.633 +(* divide_Seq for schB2 *)
75.634 +apply (frule_tac y = "y2" in sym [THEN eq_imp_below, THEN divide_Seq])
75.635 +apply (erule conjE)+
75.636 +(* assumption schA *)
75.637 +apply (drule_tac x = "schA" and g = "Filter (%a. a:act A) $rs" in subst_lemma2)
75.638 +apply assumption
75.639 +apply (simp add: int_is_not_ext)
75.640 +
75.641 +(* f A (tw iB schB2) = nil *)
75.642 +apply (simp add: int_is_not_ext not_ext_is_int_or_not_act intA_is_not_actB)
75.643 +
75.644 +
75.645 +(* reduce trace_takes from n to strictly smaller k *)
75.646 +apply (rule take_reduction)
75.647 +apply (rule refl)
75.648 +apply (rule refl)
75.649 +
75.650 +(* now conclusion fulfills induction hypothesis, but assumptions are not all ready *)
75.651 +
75.652 +(* assumption schB *)
75.653 +apply (drule_tac x = "y2" and g = "Filter (%a. a:act B) $rs" in subst_lemma2)
75.654 +apply assumption
75.655 +apply (simp add: intA_is_not_actB int_is_not_ext)
75.656 +
75.657 +(* conclusions concerning LastActExtsch, cannot be rewritten, as LastActExtsmalli are looping *)
75.658 +apply (drule_tac sch = "schA" and P = "%a. a:int A" in LastActExtsmall1)
75.659 +apply (frule_tac ?sch1.0 = "y1" in LastActExtsmall2)
75.660 +apply assumption
75.661 +apply (drule_tac sch = "y2" and P = "%a. a:int B" in LastActExtsmall1)
75.662 +
75.663 +(* assumption Forall schA, and Forall schA are performed by ForallTL,ForallDropwhile *)
75.664 +apply (simp add: ForallTL ForallDropwhile)
75.665 +
75.666 +(* case x~:A & x:B *)
75.667 +(* cannot occur, as just this case has been scheduled out before as the B-only prefix *)
75.668 +apply (case_tac "x:act B")
75.669 +apply fast
75.670 +
75.671 +(* case x~:A & x~:B *)
75.672 +(* cannot occur because of assumption: Forall (a:ext A | a:ext B) *)
75.673 +apply (rotate_tac -9)
75.674 +(* reduce forall assumption from tr to (x>>rs) *)
75.675 +apply (simp add: externals_of_par)
75.676 +apply (fast intro!: ext_is_act)
75.677 +
75.678 +done
75.679 +
75.680 +
75.681 +
75.682 +subsection" Filter of mksch(tr,schA,schB) to B is schB -- take lemma proof"
75.683 +
75.684 +lemma FilterBmksch_is_schB: "!! A B. [| compatible A B; compatible B A;
75.685 + is_asig(asig_of A); is_asig(asig_of B) |] ==>
75.686 + Forall (%x. x:ext (A||B)) tr &
75.687 + Forall (%x. x:act A) schA & Forall (%x. x:act B) schB &
75.688 + Filter (%a. a:ext A)$schA = Filter (%a. a:act A)$tr &
75.689 + Filter (%a. a:ext B)$schB = Filter (%a. a:act B)$tr &
75.690 + LastActExtsch A schA & LastActExtsch B schB
75.691 + --> Filter (%a. a:act B)$(mksch A B$tr$schA$schB) = schB"
75.692 +apply (intro strip)
75.693 +apply (rule seq.take_lemma)
75.694 +apply (rule mp)
75.695 +prefer 2 apply assumption
75.696 +back back back back
75.697 +apply (rule_tac x = "schA" in spec)
75.698 +apply (rule_tac x = "schB" in spec)
75.699 +apply (rule_tac x = "tr" in spec)
75.700 +apply (tactic "thin_tac' 5 1")
75.701 +apply (rule nat_less_induct)
75.702 +apply (rule allI)+
75.703 +apply (rename_tac tr schB schA)
75.704 +apply (intro strip)
75.705 +apply (erule conjE)+
75.706 +
75.707 +apply (case_tac "Forall (%x. x:act A & x~:act B) tr")
75.708 +
75.709 +apply (rule seq_take_lemma [THEN iffD2, THEN spec])
75.710 +apply (tactic "thin_tac' 5 1")
75.711 +
75.712 +apply (case_tac "Finite tr")
75.713 +
75.714 +(* both sides of this equation are nil *)
75.715 +apply (subgoal_tac "schB=nil")
75.716 +apply (simp (no_asm_simp))
75.717 +(* first side: mksch = nil *)
75.718 +apply (auto intro!: ForallQFilterPnil ForallAnBmksch FiniteL_mksch)[1]
75.719 +(* second side: schA = nil *)
75.720 +apply (erule_tac A = "B" in LastActExtimplnil)
75.721 +apply (simp (no_asm_simp))
75.722 +apply (erule_tac Q = "%x. x:act A & x~:act B" in ForallQFilterPnil)
75.723 +apply assumption
75.724 +apply fast
75.725 +
75.726 +(* case ~ Finite tr *)
75.727 +
75.728 +(* both sides of this equation are UU *)
75.729 +apply (subgoal_tac "schB=UU")
75.730 +apply (simp (no_asm_simp))
75.731 +(* first side: mksch = UU *)
75.732 +apply (force intro!: ForallQFilterPUU finiteR_mksch [THEN mp, COMP rev_contrapos] ForallAnBmksch)
75.733 +(* schA = UU *)
75.734 +apply (erule_tac A = "B" in LastActExtimplUU)
75.735 +apply (simp (no_asm_simp))
75.736 +apply (erule_tac Q = "%x. x:act A & x~:act B" in ForallQFilterPUU)
75.737 +apply assumption
75.738 +apply fast
75.739 +
75.740 +(* case" ~ Forall (%x.x:act B & x~:act A) s" *)
75.741 +
75.742 +apply (drule divide_Seq3)
75.743 +
75.744 +apply (erule exE)+
75.745 +apply (erule conjE)+
75.746 +apply hypsubst
75.747 +
75.748 +(* bring in lemma reduceB_mksch *)
75.749 +apply (frule_tac y = "schB" and x = "schA" and A = "A" and B = "B" in reduceB_mksch)
75.750 +apply assumption+
75.751 +apply (erule exE)+
75.752 +apply (erule conjE)+
75.753 +
75.754 +(* use reduceB_mksch to rewrite conclusion *)
75.755 +apply hypsubst
75.756 +apply simp
75.757 +
75.758 +(* eliminate the A-only prefix *)
75.759 +
75.760 +apply (subgoal_tac "(Filter (%a. a :act B) $x1) = nil")
75.761 +apply (erule_tac [2] ForallQFilterPnil)
75.762 +prefer 2 apply (assumption)
75.763 +prefer 2 apply (fast)
75.764 +
75.765 +(* Now real recursive step follows (in x) *)
75.766 +
75.767 +apply simp
75.768 +apply (case_tac "x:act B")
75.769 +apply (case_tac "x~:act A")
75.770 +apply (rotate_tac -2)
75.771 +apply simp
75.772 +
75.773 +apply (subgoal_tac "Filter (%a. a:act B & a:ext A) $x1=nil")
75.774 +apply (rotate_tac -1)
75.775 +apply simp
75.776 +(* eliminate introduced subgoal 2 *)
75.777 +apply (erule_tac [2] ForallQFilterPnil)
75.778 +prefer 2 apply (assumption)
75.779 +prefer 2 apply (fast)
75.780 +
75.781 +(* bring in divide Seq for s *)
75.782 +apply (frule sym [THEN eq_imp_below, THEN divide_Seq])
75.783 +apply (erule conjE)+
75.784 +
75.785 +(* subst divide_Seq in conclusion, but only at the righest occurence *)
75.786 +apply (rule_tac t = "schB" in ssubst)
75.787 +back
75.788 +back
75.789 +back
75.790 +apply assumption
75.791 +
75.792 +(* reduce trace_takes from n to strictly smaller k *)
75.793 +apply (rule take_reduction)
75.794 +
75.795 +(* f B (tw iB) = tw ~eB *)
75.796 +apply (simp add: int_is_act not_ext_is_int_or_not_act)
75.797 +apply (rule refl)
75.798 +apply (simp add: int_is_act not_ext_is_int_or_not_act)
75.799 +apply (rotate_tac -11)
75.800 +
75.801 +(* now conclusion fulfills induction hypothesis, but assumptions are not ready *)
75.802 +
75.803 +(* assumption schA *)
75.804 +apply (simp add: ext_and_act)
75.805 +(* assumption schB *)
75.806 +apply (drule_tac x = "schB" and g = "Filter (%a. a:act B) $rs" in subst_lemma2)
75.807 +apply assumption
75.808 +apply (simp add: int_is_not_ext)
75.809 +(* assumptions concerning LastActExtsch, cannot be rewritten, as LastActExtsmalli are looping *)
75.810 +apply (drule_tac sch = "schB" and P = "%a. a:int B" in LastActExtsmall1)
75.811 +apply (frule_tac ?sch1.0 = "x1" in LastActExtsmall2)
75.812 +apply assumption
75.813 +
75.814 +(* assumption Forall schB *)
75.815 +apply (drule_tac s = "schB" and P = "Forall (%x. x:act B) " in subst)
75.816 +apply assumption
75.817 +apply (simp add: int_is_act)
75.818 +
75.819 +(* case x:actions(asig_of A) & x: actions(asig_of B) *)
75.820 +
75.821 +apply (rotate_tac -2)
75.822 +apply simp
75.823 +
75.824 +apply (subgoal_tac "Filter (%a. a:act B & a:ext A) $x1=nil")
75.825 +apply (rotate_tac -1)
75.826 +apply simp
75.827 +(* eliminate introduced subgoal 2 *)
75.828 +apply (erule_tac [2] ForallQFilterPnil)
75.829 +prefer 2 apply (assumption)
75.830 +prefer 2 apply (fast)
75.831 +
75.832 +(* bring in divide Seq for s *)
75.833 +apply (frule sym [THEN eq_imp_below, THEN divide_Seq])
75.834 +apply (erule conjE)+
75.835 +
75.836 +(* subst divide_Seq in conclusion, but only at the righest occurence *)
75.837 +apply (rule_tac t = "schB" in ssubst)
75.838 +back
75.839 +back
75.840 +back
75.841 +apply assumption
75.842 +
75.843 +(* f B (tw iB) = tw ~eB *)
75.844 +apply (simp add: int_is_act not_ext_is_int_or_not_act)
75.845 +
75.846 +(* rewrite assumption forall and schB *)
75.847 +apply (rotate_tac 13)
75.848 +apply (simp add: ext_and_act)
75.849 +
75.850 +(* divide_Seq for schB2 *)
75.851 +apply (frule_tac y = "x2" in sym [THEN eq_imp_below, THEN divide_Seq])
75.852 +apply (erule conjE)+
75.853 +(* assumption schA *)
75.854 +apply (drule_tac x = "schB" and g = "Filter (%a. a:act B) $rs" in subst_lemma2)
75.855 +apply assumption
75.856 +apply (simp add: int_is_not_ext)
75.857 +
75.858 +(* f B (tw iA schA2) = nil *)
75.859 +apply (simp add: int_is_not_ext not_ext_is_int_or_not_act intA_is_not_actB)
75.860 +
75.861 +
75.862 +(* reduce trace_takes from n to strictly smaller k *)
75.863 +apply (rule take_reduction)
75.864 +apply (rule refl)
75.865 +apply (rule refl)
75.866 +
75.867 +(* now conclusion fulfills induction hypothesis, but assumptions are not all ready *)
75.868 +
75.869 +(* assumption schA *)
75.870 +apply (drule_tac x = "x2" and g = "Filter (%a. a:act A) $rs" in subst_lemma2)
75.871 +apply assumption
75.872 +apply (simp add: intA_is_not_actB int_is_not_ext)
75.873 +
75.874 +(* conclusions concerning LastActExtsch, cannot be rewritten, as LastActExtsmalli are looping *)
75.875 +apply (drule_tac sch = "schB" and P = "%a. a:int B" in LastActExtsmall1)
75.876 +apply (frule_tac ?sch1.0 = "x1" in LastActExtsmall2)
75.877 +apply assumption
75.878 +apply (drule_tac sch = "x2" and P = "%a. a:int A" in LastActExtsmall1)
75.879 +
75.880 +(* assumption Forall schA, and Forall schA are performed by ForallTL,ForallDropwhile *)
75.881 +apply (simp add: ForallTL ForallDropwhile)
75.882 +
75.883 +(* case x~:B & x:A *)
75.884 +(* cannot occur, as just this case has been scheduled out before as the B-only prefix *)
75.885 +apply (case_tac "x:act A")
75.886 +apply fast
75.887 +
75.888 +(* case x~:B & x~:A *)
75.889 +(* cannot occur because of assumption: Forall (a:ext A | a:ext B) *)
75.890 +apply (rotate_tac -9)
75.891 +(* reduce forall assumption from tr to (x>>rs) *)
75.892 +apply (simp add: externals_of_par)
75.893 +apply (fast intro!: ext_is_act)
75.894 +
75.895 +done
75.896 +
75.897 +
75.898 +subsection "COMPOSITIONALITY on TRACE Level -- Main Theorem"
75.899 +
75.900 +lemma compositionality_tr:
75.901 +"!! A B. [| is_trans_of A; is_trans_of B; compatible A B; compatible B A;
75.902 + is_asig(asig_of A); is_asig(asig_of B)|]
75.903 + ==> (tr: traces(A||B)) =
75.904 + (Filter (%a. a:act A)$tr : traces A &
75.905 + Filter (%a. a:act B)$tr : traces B &
75.906 + Forall (%x. x:ext(A||B)) tr)"
75.907 +
75.908 +apply (simp (no_asm) add: traces_def has_trace_def)
75.909 +apply auto
75.910 +
75.911 +(* ==> *)
75.912 +(* There is a schedule of A *)
75.913 +apply (rule_tac x = "Filter (%a. a:act A) $sch" in bexI)
75.914 +prefer 2
75.915 +apply (simp add: compositionality_sch)
75.916 +apply (simp add: compatibility_consequence1 externals_of_par ext1_ext2_is_not_act1)
75.917 +(* There is a schedule of B *)
75.918 +apply (rule_tac x = "Filter (%a. a:act B) $sch" in bexI)
75.919 +prefer 2
75.920 +apply (simp add: compositionality_sch)
75.921 +apply (simp add: compatibility_consequence2 externals_of_par ext1_ext2_is_not_act2)
75.922 +(* Traces of A||B have only external actions from A or B *)
75.923 +apply (rule ForallPFilterP)
75.924 +
75.925 +(* <== *)
75.926 +
75.927 +(* replace schA and schB by Cut(schA) and Cut(schB) *)
75.928 +apply (drule exists_LastActExtsch)
75.929 +apply assumption
75.930 +apply (drule exists_LastActExtsch)
75.931 +apply assumption
75.932 +apply (erule exE)+
75.933 +apply (erule conjE)+
75.934 +(* Schedules of A(B) have only actions of A(B) *)
75.935 +apply (drule scheds_in_sig)
75.936 +apply assumption
75.937 +apply (drule scheds_in_sig)
75.938 +apply assumption
75.939 +
75.940 +apply (rename_tac h1 h2 schA schB)
75.941 +(* mksch is exactly the construction of trA||B out of schA, schB, and the oracle tr,
75.942 + we need here *)
75.943 +apply (rule_tac x = "mksch A B$tr$schA$schB" in bexI)
75.944 +
75.945 +(* External actions of mksch are just the oracle *)
75.946 +apply (simp add: FilterA_mksch_is_tr)
75.947 +
75.948 +(* mksch is a schedule -- use compositionality on sch-level *)
75.949 +apply (simp add: compositionality_sch)
75.950 +apply (simp add: FilterAmksch_is_schA FilterBmksch_is_schB)
75.951 +apply (erule ForallAorB_mksch)
75.952 +apply (erule ForallPForallQ)
75.953 +apply (erule ext_is_act)
75.954 +done
75.955 +
75.956 +
75.957 +
75.958 +subsection {* COMPOSITIONALITY on TRACE Level -- for Modules *}
75.959 +
75.960 +lemma compositionality_tr_modules:
75.961 +
75.962 +"!! A B. [| is_trans_of A; is_trans_of B; compatible A B; compatible B A;
75.963 + is_asig(asig_of A); is_asig(asig_of B)|]
75.964 + ==> Traces (A||B) = par_traces (Traces A) (Traces B)"
75.965 +
75.966 +apply (unfold Traces_def par_traces_def)
75.967 +apply (simp add: asig_of_par)
75.968 +apply (rule set_eqI)
75.969 +apply (simp add: compositionality_tr externals_of_par)
75.970 +done
75.971 +
75.972 +
75.973 +declaration {* fn _ => Simplifier.map_ss (fn ss => ss setmksym (K (SOME o symmetric_fun))) *}
75.974 +
75.975 +
75.976 +end
76.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
76.2 +++ b/src/HOL/HOLCF/IOA/meta_theory/Compositionality.thy Sat Nov 27 16:08:10 2010 -0800
76.3 @@ -0,0 +1,75 @@
76.4 +(* Title: HOLCF/IOA/meta_theory/Compositionality.thy
76.5 + Author: Olaf Müller
76.6 +*)
76.7 +
76.8 +header {* Compositionality of I/O automata *}
76.9 +theory Compositionality
76.10 +imports CompoTraces
76.11 +begin
76.12 +
76.13 +lemma compatibility_consequence3: "[|eA --> A ; eB & ~eA --> ~A|] ==> (eA | eB) --> A=eA"
76.14 +apply auto
76.15 +done
76.16 +
76.17 +
76.18 +lemma Filter_actAisFilter_extA:
76.19 +"!! A B. [| compatible A B; Forall (%a. a: ext A | a: ext B) tr |] ==>
76.20 + Filter (%a. a: act A)$tr= Filter (%a. a: ext A)$tr"
76.21 +apply (rule ForallPFilterQR)
76.22 +(* i.e.: [| (! x. P x --> (Q x = R x)) ; Forall P tr |] ==> Filter Q$tr = Filter R$tr *)
76.23 +prefer 2 apply (assumption)
76.24 +apply (rule compatibility_consequence3)
76.25 +apply (simp_all add: ext_is_act ext1_ext2_is_not_act1)
76.26 +done
76.27 +
76.28 +
76.29 +(* the next two theorems are only necessary, as there is no theorem ext (A||B) = ext (B||A) *)
76.30 +
76.31 +lemma compatibility_consequence4: "[|eA --> A ; eB & ~eA --> ~A|] ==> (eB | eA) --> A=eA"
76.32 +apply auto
76.33 +done
76.34 +
76.35 +lemma Filter_actAisFilter_extA2: "[| compatible A B; Forall (%a. a: ext B | a: ext A) tr |] ==>
76.36 + Filter (%a. a: act A)$tr= Filter (%a. a: ext A)$tr"
76.37 +apply (rule ForallPFilterQR)
76.38 +prefer 2 apply (assumption)
76.39 +apply (rule compatibility_consequence4)
76.40 +apply (simp_all add: ext_is_act ext1_ext2_is_not_act1)
76.41 +done
76.42 +
76.43 +
76.44 +subsection " Main Compositionality Theorem "
76.45 +
76.46 +lemma compositionality: "[| is_trans_of A1; is_trans_of A2; is_trans_of B1; is_trans_of B2;
76.47 + is_asig_of A1; is_asig_of A2;
76.48 + is_asig_of B1; is_asig_of B2;
76.49 + compatible A1 B1; compatible A2 B2;
76.50 + A1 =<| A2;
76.51 + B1 =<| B2 |]
76.52 + ==> (A1 || B1) =<| (A2 || B2)"
76.53 +apply (simp add: is_asig_of_def)
76.54 +apply (frule_tac A1 = "A1" in compat_commute [THEN iffD1])
76.55 +apply (frule_tac A1 = "A2" in compat_commute [THEN iffD1])
76.56 +apply (simp add: ioa_implements_def inputs_of_par outputs_of_par externals_of_par)
76.57 +apply auto
76.58 +apply (simp add: compositionality_tr)
76.59 +apply (subgoal_tac "ext A1 = ext A2 & ext B1 = ext B2")
76.60 +prefer 2
76.61 +apply (simp add: externals_def)
76.62 +apply (erule conjE)+
76.63 +(* rewrite with proven subgoal *)
76.64 +apply (simp add: externals_of_par)
76.65 +apply auto
76.66 +
76.67 +(* 2 goals, the 3rd has been solved automatically *)
76.68 +(* 1: Filter A2 x : traces A2 *)
76.69 +apply (drule_tac A = "traces A1" in subsetD)
76.70 +apply assumption
76.71 +apply (simp add: Filter_actAisFilter_extA)
76.72 +(* 2: Filter B2 x : traces B2 *)
76.73 +apply (drule_tac A = "traces B1" in subsetD)
76.74 +apply assumption
76.75 +apply (simp add: Filter_actAisFilter_extA2)
76.76 +done
76.77 +
76.78 +end
77.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
77.2 +++ b/src/HOL/HOLCF/IOA/meta_theory/Deadlock.thy Sat Nov 27 16:08:10 2010 -0800
77.3 @@ -0,0 +1,92 @@
77.4 +(* Title: HOLCF/IOA/meta_theory/Deadlock.thy
77.5 + Author: Olaf Müller
77.6 +*)
77.7 +
77.8 +header {* Deadlock freedom of I/O Automata *}
77.9 +
77.10 +theory Deadlock
77.11 +imports RefCorrectness CompoScheds
77.12 +begin
77.13 +
77.14 +text {* input actions may always be added to a schedule *}
77.15 +
77.16 +lemma scheds_input_enabled:
77.17 + "[| Filter (%x. x:act A)$sch : schedules A; a:inp A; input_enabled A; Finite sch|]
77.18 + ==> Filter (%x. x:act A)$sch @@ a>>nil : schedules A"
77.19 +apply (simp add: schedules_def has_schedule_def)
77.20 +apply auto
77.21 +apply (frule inp_is_act)
77.22 +apply (simp add: executions_def)
77.23 +apply (tactic {* pair_tac @{context} "ex" 1 *})
77.24 +apply (rename_tac s ex)
77.25 +apply (subgoal_tac "Finite ex")
77.26 +prefer 2
77.27 +apply (simp add: filter_act_def)
77.28 +defer
77.29 +apply (rule_tac [2] Map2Finite [THEN iffD1])
77.30 +apply (rule_tac [2] t = "Map fst$ex" in subst)
77.31 +prefer 2 apply (assumption)
77.32 +apply (erule_tac [2] FiniteFilter)
77.33 +(* subgoal 1 *)
77.34 +apply (frule exists_laststate)
77.35 +apply (erule allE)
77.36 +apply (erule exE)
77.37 +(* using input-enabledness *)
77.38 +apply (simp add: input_enabled_def)
77.39 +apply (erule conjE)+
77.40 +apply (erule_tac x = "a" in allE)
77.41 +apply simp
77.42 +apply (erule_tac x = "u" in allE)
77.43 +apply (erule exE)
77.44 +(* instantiate execution *)
77.45 +apply (rule_tac x = " (s,ex @@ (a,s2) >>nil) " in exI)
77.46 +apply (simp add: filter_act_def MapConc)
77.47 +apply (erule_tac t = "u" in lemma_2_1)
77.48 +apply simp
77.49 +apply (rule sym)
77.50 +apply assumption
77.51 +done
77.52 +
77.53 +text {*
77.54 + Deadlock freedom: component B cannot block an out or int action
77.55 + of component A in every schedule.
77.56 + Needs compositionality on schedule level, input-enabledness, compatibility
77.57 + and distributivity of is_exec_frag over @@
77.58 +*}
77.59 +
77.60 +declare split_if [split del]
77.61 +lemma IOA_deadlock_free: "[| a : local A; Finite sch; sch : schedules (A||B);
77.62 + Filter (%x. x:act A)$(sch @@ a>>nil) : schedules A; compatible A B; input_enabled B |]
77.63 + ==> (sch @@ a>>nil) : schedules (A||B)"
77.64 +apply (simp add: compositionality_sch locals_def)
77.65 +apply (rule conjI)
77.66 +(* a : act (A||B) *)
77.67 +prefer 2
77.68 +apply (simp add: actions_of_par)
77.69 +apply (blast dest: int_is_act out_is_act)
77.70 +
77.71 +(* Filter B (sch@@[a]) : schedules B *)
77.72 +
77.73 +apply (case_tac "a:int A")
77.74 +apply (drule intA_is_not_actB)
77.75 +apply (assumption) (* --> a~:act B *)
77.76 +apply simp
77.77 +
77.78 +(* case a~:int A , i.e. a:out A *)
77.79 +apply (case_tac "a~:act B")
77.80 +apply simp
77.81 +(* case a:act B *)
77.82 +apply simp
77.83 +apply (subgoal_tac "a:out A")
77.84 +prefer 2 apply (blast)
77.85 +apply (drule outAactB_is_inpB)
77.86 +apply assumption
77.87 +apply assumption
77.88 +apply (rule scheds_input_enabled)
77.89 +apply simp
77.90 +apply assumption+
77.91 +done
77.92 +
77.93 +declare split_if [split]
77.94 +
77.95 +end
78.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
78.2 +++ b/src/HOL/HOLCF/IOA/meta_theory/IOA.thy Sat Nov 27 16:08:10 2010 -0800
78.3 @@ -0,0 +1,11 @@
78.4 +(* Title: HOLCF/IOA/meta_theory/IOA.thy
78.5 + Author: Olaf Müller
78.6 +*)
78.7 +
78.8 +header {* The theory of I/O automata in HOLCF *}
78.9 +
78.10 +theory IOA
78.11 +imports SimCorrectness Compositionality Deadlock
78.12 +begin
78.13 +
78.14 +end
79.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
79.2 +++ b/src/HOL/HOLCF/IOA/meta_theory/LiveIOA.thy Sat Nov 27 16:08:10 2010 -0800
79.3 @@ -0,0 +1,82 @@
79.4 +(* Title: HOLCF/IOA/meta_theory/LiveIOA.thy
79.5 + Author: Olaf Müller
79.6 +*)
79.7 +
79.8 +header {* Live I/O automata -- specified by temproal formulas *}
79.9 +
79.10 +theory LiveIOA
79.11 +imports TLS
79.12 +begin
79.13 +
79.14 +default_sort type
79.15 +
79.16 +types
79.17 + ('a, 's) live_ioa = "('a,'s)ioa * ('a,'s)ioa_temp"
79.18 +
79.19 +definition
79.20 + validLIOA :: "('a,'s)live_ioa => ('a,'s)ioa_temp => bool" where
79.21 + "validLIOA AL P = validIOA (fst AL) ((snd AL) .--> P)"
79.22 +
79.23 +definition
79.24 + WF :: "('a,'s)ioa => 'a set => ('a,'s)ioa_temp" where
79.25 + "WF A acts = (<> [] <%(s,a,t) . Enabled A acts s> .--> [] <> <xt2 (plift (%a. a : acts))>)"
79.26 +definition
79.27 + SF :: "('a,'s)ioa => 'a set => ('a,'s)ioa_temp" where
79.28 + "SF A acts = ([] <> <%(s,a,t) . Enabled A acts s> .--> [] <> <xt2 (plift (%a. a : acts))>)"
79.29 +
79.30 +definition
79.31 + liveexecutions :: "('a,'s)live_ioa => ('a,'s)execution set" where
79.32 + "liveexecutions AP = {exec. exec : executions (fst AP) & (exec |== (snd AP))}"
79.33 +definition
79.34 + livetraces :: "('a,'s)live_ioa => 'a trace set" where
79.35 + "livetraces AP = {mk_trace (fst AP)$(snd ex) | ex. ex:liveexecutions AP}"
79.36 +definition
79.37 + live_implements :: "('a,'s1)live_ioa => ('a,'s2)live_ioa => bool" where
79.38 + "live_implements CL AM = ((inp (fst CL) = inp (fst AM)) &
79.39 + (out (fst CL) = out (fst AM)) &
79.40 + livetraces CL <= livetraces AM)"
79.41 +definition
79.42 + is_live_ref_map :: "('s1 => 's2) => ('a,'s1)live_ioa => ('a,'s2)live_ioa => bool" where
79.43 + "is_live_ref_map f CL AM =
79.44 + (is_ref_map f (fst CL ) (fst AM) &
79.45 + (! exec : executions (fst CL). (exec |== (snd CL)) -->
79.46 + ((corresp_ex (fst AM) f exec) |== (snd AM))))"
79.47 +
79.48 +
79.49 +lemma live_implements_trans:
79.50 +"!!LC. [| live_implements (A,LA) (B,LB); live_implements (B,LB) (C,LC) |]
79.51 + ==> live_implements (A,LA) (C,LC)"
79.52 +apply (unfold live_implements_def)
79.53 +apply auto
79.54 +done
79.55 +
79.56 +
79.57 +subsection "Correctness of live refmap"
79.58 +
79.59 +lemma live_implements: "[| inp(C)=inp(A); out(C)=out(A);
79.60 + is_live_ref_map f (C,M) (A,L) |]
79.61 + ==> live_implements (C,M) (A,L)"
79.62 +apply (simp add: is_live_ref_map_def live_implements_def livetraces_def liveexecutions_def)
79.63 +apply auto
79.64 +apply (rule_tac x = "corresp_ex A f ex" in exI)
79.65 +apply auto
79.66 + (* Traces coincide, Lemma 1 *)
79.67 + apply (tactic {* pair_tac @{context} "ex" 1 *})
79.68 + apply (erule lemma_1 [THEN spec, THEN mp])
79.69 + apply (simp (no_asm) add: externals_def)
79.70 + apply (auto)[1]
79.71 + apply (simp add: executions_def reachable.reachable_0)
79.72 +
79.73 + (* corresp_ex is execution, Lemma 2 *)
79.74 + apply (tactic {* pair_tac @{context} "ex" 1 *})
79.75 + apply (simp add: executions_def)
79.76 + (* start state *)
79.77 + apply (rule conjI)
79.78 + apply (simp add: is_ref_map_def corresp_ex_def)
79.79 + (* is-execution-fragment *)
79.80 + apply (erule lemma_2 [THEN spec, THEN mp])
79.81 + apply (simp add: reachable.reachable_0)
79.82 +
79.83 +done
79.84 +
79.85 +end
80.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
80.2 +++ b/src/HOL/HOLCF/IOA/meta_theory/Pred.thy Sat Nov 27 16:08:10 2010 -0800
80.3 @@ -0,0 +1,69 @@
80.4 +(* Title: HOLCF/IOA/meta_theory/Pred.thy
80.5 + Author: Olaf Müller
80.6 +*)
80.7 +
80.8 +header {* Logical Connectives lifted to predicates *}
80.9 +
80.10 +theory Pred
80.11 +imports Main
80.12 +begin
80.13 +
80.14 +default_sort type
80.15 +
80.16 +types
80.17 + 'a predicate = "'a => bool"
80.18 +
80.19 +consts
80.20 +
80.21 +satisfies ::"'a => 'a predicate => bool" ("_ |= _" [100,9] 8)
80.22 +valid ::"'a predicate => bool" (* ("|-") *)
80.23 +
80.24 +NOT ::"'a predicate => 'a predicate" (".~ _" [40] 40)
80.25 +AND ::"'a predicate => 'a predicate => 'a predicate" (infixr ".&" 35)
80.26 +OR ::"'a predicate => 'a predicate => 'a predicate" (infixr ".|" 30)
80.27 +IMPLIES ::"'a predicate => 'a predicate => 'a predicate" (infixr ".-->" 25)
80.28 +
80.29 +
80.30 +notation (output)
80.31 + NOT ("~ _" [40] 40) and
80.32 + AND (infixr "&" 35) and
80.33 + OR (infixr "|" 30) and
80.34 + IMPLIES (infixr "-->" 25)
80.35 +
80.36 +notation (xsymbols output)
80.37 + NOT ("\<not> _" [40] 40) and
80.38 + AND (infixr "\<and>" 35) and
80.39 + OR (infixr "\<or>" 30) and
80.40 + IMPLIES (infixr "\<longrightarrow>" 25)
80.41 +
80.42 +notation (xsymbols)
80.43 + satisfies ("_ \<Turnstile> _" [100,9] 8)
80.44 +
80.45 +notation (HTML output)
80.46 + NOT ("\<not> _" [40] 40) and
80.47 + AND (infixr "\<and>" 35) and
80.48 + OR (infixr "\<or>" 30)
80.49 +
80.50 +
80.51 +defs
80.52 +
80.53 +satisfies_def:
80.54 + "s |= P == P s"
80.55 +
80.56 +(* priority einfuegen, da clash mit |=, wenn graphisches Symbol *)
80.57 +valid_def:
80.58 + "valid P == (! s. (s |= P))"
80.59 +
80.60 +NOT_def:
80.61 + "NOT P s == ~ (P s)"
80.62 +
80.63 +AND_def:
80.64 + "(P .& Q) s == (P s) & (Q s)"
80.65 +
80.66 +OR_def:
80.67 + "(P .| Q) s == (P s) | (Q s)"
80.68 +
80.69 +IMPLIES_def:
80.70 + "(P .--> Q) s == (P s) --> (Q s)"
80.71 +
80.72 +end
81.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
81.2 +++ b/src/HOL/HOLCF/IOA/meta_theory/RefCorrectness.thy Sat Nov 27 16:08:10 2010 -0800
81.3 @@ -0,0 +1,371 @@
81.4 +(* Title: HOLCF/IOA/meta_theory/RefCorrectness.thy
81.5 + Author: Olaf Müller
81.6 +*)
81.7 +
81.8 +header {* Correctness of Refinement Mappings in HOLCF/IOA *}
81.9 +
81.10 +theory RefCorrectness
81.11 +imports RefMappings
81.12 +begin
81.13 +
81.14 +definition
81.15 + corresp_exC :: "('a,'s2)ioa => ('s1 => 's2) => ('a,'s1)pairs
81.16 + -> ('s1 => ('a,'s2)pairs)" where
81.17 + "corresp_exC A f = (fix$(LAM h ex. (%s. case ex of
81.18 + nil => nil
81.19 + | x##xs => (flift1 (%pr. (@cex. move A cex (f s) (fst pr) (f (snd pr)))
81.20 + @@ ((h$xs) (snd pr)))
81.21 + $x) )))"
81.22 +definition
81.23 + corresp_ex :: "('a,'s2)ioa => ('s1 => 's2) =>
81.24 + ('a,'s1)execution => ('a,'s2)execution" where
81.25 + "corresp_ex A f ex = (f (fst ex),(corresp_exC A f$(snd ex)) (fst ex))"
81.26 +
81.27 +definition
81.28 + is_fair_ref_map :: "('s1 => 's2) => ('a,'s1)ioa => ('a,'s2)ioa => bool" where
81.29 + "is_fair_ref_map f C A =
81.30 + (is_ref_map f C A &
81.31 + (! ex : executions(C). fair_ex C ex --> fair_ex A (corresp_ex A f ex)))"
81.32 +
81.33 +(* Axioms for fair trace inclusion proof support, not for the correctness proof
81.34 + of refinement mappings!
81.35 + Note: Everything is superseded by LiveIOA.thy! *)
81.36 +
81.37 +axiomatization where
81.38 +corresp_laststate:
81.39 + "Finite ex ==> laststate (corresp_ex A f (s,ex)) = f (laststate (s,ex))"
81.40 +
81.41 +axiomatization where
81.42 +corresp_Finite:
81.43 + "Finite (snd (corresp_ex A f (s,ex))) = Finite ex"
81.44 +
81.45 +axiomatization where
81.46 +FromAtoC:
81.47 + "fin_often (%x. P (snd x)) (snd (corresp_ex A f (s,ex))) ==> fin_often (%y. P (f (snd y))) ex"
81.48 +
81.49 +axiomatization where
81.50 +FromCtoA:
81.51 + "inf_often (%y. P (fst y)) ex ==> inf_often (%x. P (fst x)) (snd (corresp_ex A f (s,ex)))"
81.52 +
81.53 +
81.54 +(* Proof by case on inf W in ex: If so, ok. If not, only fin W in ex, ie there is
81.55 + an index i from which on no W in ex. But W inf enabled, ie at least once after i
81.56 + W is enabled. As W does not occur after i and W is enabling_persistent, W keeps
81.57 + enabled until infinity, ie. indefinitely *)
81.58 +axiomatization where
81.59 +persistent:
81.60 + "[|inf_often (%x. Enabled A W (snd x)) ex; en_persistent A W|]
81.61 + ==> inf_often (%x. fst x :W) ex | fin_often (%x. ~Enabled A W (snd x)) ex"
81.62 +
81.63 +axiomatization where
81.64 +infpostcond:
81.65 + "[| is_exec_frag A (s,ex); inf_often (%x. fst x:W) ex|]
81.66 + ==> inf_often (% x. set_was_enabled A W (snd x)) ex"
81.67 +
81.68 +
81.69 +subsection "corresp_ex"
81.70 +
81.71 +lemma corresp_exC_unfold: "corresp_exC A f = (LAM ex. (%s. case ex of
81.72 + nil => nil
81.73 + | x##xs => (flift1 (%pr. (@cex. move A cex (f s) (fst pr) (f (snd pr)))
81.74 + @@ ((corresp_exC A f $xs) (snd pr)))
81.75 + $x) ))"
81.76 +apply (rule trans)
81.77 +apply (rule fix_eq2)
81.78 +apply (simp only: corresp_exC_def)
81.79 +apply (rule beta_cfun)
81.80 +apply (simp add: flift1_def)
81.81 +done
81.82 +
81.83 +lemma corresp_exC_UU: "(corresp_exC A f$UU) s=UU"
81.84 +apply (subst corresp_exC_unfold)
81.85 +apply simp
81.86 +done
81.87 +
81.88 +lemma corresp_exC_nil: "(corresp_exC A f$nil) s = nil"
81.89 +apply (subst corresp_exC_unfold)
81.90 +apply simp
81.91 +done
81.92 +
81.93 +lemma corresp_exC_cons: "(corresp_exC A f$(at>>xs)) s =
81.94 + (@cex. move A cex (f s) (fst at) (f (snd at)))
81.95 + @@ ((corresp_exC A f$xs) (snd at))"
81.96 +apply (rule trans)
81.97 +apply (subst corresp_exC_unfold)
81.98 +apply (simp add: Consq_def flift1_def)
81.99 +apply simp
81.100 +done
81.101 +
81.102 +
81.103 +declare corresp_exC_UU [simp] corresp_exC_nil [simp] corresp_exC_cons [simp]
81.104 +
81.105 +
81.106 +
81.107 +subsection "properties of move"
81.108 +
81.109 +lemma move_is_move:
81.110 + "[|is_ref_map f C A; reachable C s; (s,a,t):trans_of C|] ==>
81.111 + move A (@x. move A x (f s) a (f t)) (f s) a (f t)"
81.112 +apply (unfold is_ref_map_def)
81.113 +apply (subgoal_tac "? ex. move A ex (f s) a (f t) ")
81.114 +prefer 2
81.115 +apply simp
81.116 +apply (erule exE)
81.117 +apply (rule someI)
81.118 +apply assumption
81.119 +done
81.120 +
81.121 +lemma move_subprop1:
81.122 + "[|is_ref_map f C A; reachable C s; (s,a,t):trans_of C|] ==>
81.123 + is_exec_frag A (f s,@x. move A x (f s) a (f t))"
81.124 +apply (cut_tac move_is_move)
81.125 +defer
81.126 +apply assumption+
81.127 +apply (simp add: move_def)
81.128 +done
81.129 +
81.130 +lemma move_subprop2:
81.131 + "[|is_ref_map f C A; reachable C s; (s,a,t):trans_of C|] ==>
81.132 + Finite ((@x. move A x (f s) a (f t)))"
81.133 +apply (cut_tac move_is_move)
81.134 +defer
81.135 +apply assumption+
81.136 +apply (simp add: move_def)
81.137 +done
81.138 +
81.139 +lemma move_subprop3:
81.140 + "[|is_ref_map f C A; reachable C s; (s,a,t):trans_of C|] ==>
81.141 + laststate (f s,@x. move A x (f s) a (f t)) = (f t)"
81.142 +apply (cut_tac move_is_move)
81.143 +defer
81.144 +apply assumption+
81.145 +apply (simp add: move_def)
81.146 +done
81.147 +
81.148 +lemma move_subprop4:
81.149 + "[|is_ref_map f C A; reachable C s; (s,a,t):trans_of C|] ==>
81.150 + mk_trace A$((@x. move A x (f s) a (f t))) =
81.151 + (if a:ext A then a>>nil else nil)"
81.152 +apply (cut_tac move_is_move)
81.153 +defer
81.154 +apply assumption+
81.155 +apply (simp add: move_def)
81.156 +done
81.157 +
81.158 +
81.159 +(* ------------------------------------------------------------------ *)
81.160 +(* The following lemmata contribute to *)
81.161 +(* TRACE INCLUSION Part 1: Traces coincide *)
81.162 +(* ------------------------------------------------------------------ *)
81.163 +
81.164 +section "Lemmata for <=="
81.165 +
81.166 +(* --------------------------------------------------- *)
81.167 +(* Lemma 1.1: Distribution of mk_trace and @@ *)
81.168 +(* --------------------------------------------------- *)
81.169 +
81.170 +lemma mk_traceConc: "mk_trace C$(ex1 @@ ex2)= (mk_trace C$ex1) @@ (mk_trace C$ex2)"
81.171 +apply (simp add: mk_trace_def filter_act_def MapConc)
81.172 +done
81.173 +
81.174 +
81.175 +
81.176 +(* ------------------------------------------------------
81.177 + Lemma 1 :Traces coincide
81.178 + ------------------------------------------------------- *)
81.179 +declare split_if [split del]
81.180 +
81.181 +lemma lemma_1:
81.182 + "[|is_ref_map f C A; ext C = ext A|] ==>
81.183 + !s. reachable C s & is_exec_frag C (s,xs) -->
81.184 + mk_trace C$xs = mk_trace A$(snd (corresp_ex A f (s,xs)))"
81.185 +apply (unfold corresp_ex_def)
81.186 +apply (tactic {* pair_induct_tac @{context} "xs" [@{thm is_exec_frag_def}] 1 *})
81.187 +(* cons case *)
81.188 +apply (auto simp add: mk_traceConc)
81.189 +apply (frule reachable.reachable_n)
81.190 +apply assumption
81.191 +apply (erule_tac x = "y" in allE)
81.192 +apply (simp add: move_subprop4 split add: split_if)
81.193 +done
81.194 +
81.195 +declare split_if [split]
81.196 +
81.197 +(* ------------------------------------------------------------------ *)
81.198 +(* The following lemmata contribute to *)
81.199 +(* TRACE INCLUSION Part 2: corresp_ex is execution *)
81.200 +(* ------------------------------------------------------------------ *)
81.201 +
81.202 +section "Lemmata for ==>"
81.203 +
81.204 +(* -------------------------------------------------- *)
81.205 +(* Lemma 2.1 *)
81.206 +(* -------------------------------------------------- *)
81.207 +
81.208 +lemma lemma_2_1 [rule_format (no_asm)]:
81.209 +"Finite xs -->
81.210 + (!s .is_exec_frag A (s,xs) & is_exec_frag A (t,ys) &
81.211 + t = laststate (s,xs)
81.212 + --> is_exec_frag A (s,xs @@ ys))"
81.213 +
81.214 +apply (rule impI)
81.215 +apply (tactic {* Seq_Finite_induct_tac @{context} 1 *})
81.216 +(* main case *)
81.217 +apply (auto simp add: split_paired_all)
81.218 +done
81.219 +
81.220 +
81.221 +(* ----------------------------------------------------------- *)
81.222 +(* Lemma 2 : corresp_ex is execution *)
81.223 +(* ----------------------------------------------------------- *)
81.224 +
81.225 +
81.226 +
81.227 +lemma lemma_2:
81.228 + "[| is_ref_map f C A |] ==>
81.229 + !s. reachable C s & is_exec_frag C (s,xs)
81.230 + --> is_exec_frag A (corresp_ex A f (s,xs))"
81.231 +
81.232 +apply (unfold corresp_ex_def)
81.233 +
81.234 +apply simp
81.235 +apply (tactic {* pair_induct_tac @{context} "xs" [@{thm is_exec_frag_def}] 1 *})
81.236 +(* main case *)
81.237 +apply auto
81.238 +apply (rule_tac t = "f y" in lemma_2_1)
81.239 +
81.240 +(* Finite *)
81.241 +apply (erule move_subprop2)
81.242 +apply assumption+
81.243 +apply (rule conjI)
81.244 +
81.245 +(* is_exec_frag *)
81.246 +apply (erule move_subprop1)
81.247 +apply assumption+
81.248 +apply (rule conjI)
81.249 +
81.250 +(* Induction hypothesis *)
81.251 +(* reachable_n looping, therefore apply it manually *)
81.252 +apply (erule_tac x = "y" in allE)
81.253 +apply simp
81.254 +apply (frule reachable.reachable_n)
81.255 +apply assumption
81.256 +apply simp
81.257 +(* laststate *)
81.258 +apply (erule move_subprop3 [symmetric])
81.259 +apply assumption+
81.260 +done
81.261 +
81.262 +
81.263 +subsection "Main Theorem: TRACE - INCLUSION"
81.264 +
81.265 +lemma trace_inclusion:
81.266 + "[| ext C = ext A; is_ref_map f C A |]
81.267 + ==> traces C <= traces A"
81.268 +
81.269 + apply (unfold traces_def)
81.270 +
81.271 + apply (simp (no_asm) add: has_trace_def2)
81.272 + apply auto
81.273 +
81.274 + (* give execution of abstract automata *)
81.275 + apply (rule_tac x = "corresp_ex A f ex" in bexI)
81.276 +
81.277 + (* Traces coincide, Lemma 1 *)
81.278 + apply (tactic {* pair_tac @{context} "ex" 1 *})
81.279 + apply (erule lemma_1 [THEN spec, THEN mp])
81.280 + apply assumption+
81.281 + apply (simp add: executions_def reachable.reachable_0)
81.282 +
81.283 + (* corresp_ex is execution, Lemma 2 *)
81.284 + apply (tactic {* pair_tac @{context} "ex" 1 *})
81.285 + apply (simp add: executions_def)
81.286 + (* start state *)
81.287 + apply (rule conjI)
81.288 + apply (simp add: is_ref_map_def corresp_ex_def)
81.289 + (* is-execution-fragment *)
81.290 + apply (erule lemma_2 [THEN spec, THEN mp])
81.291 + apply (simp add: reachable.reachable_0)
81.292 + done
81.293 +
81.294 +
81.295 +subsection "Corollary: FAIR TRACE - INCLUSION"
81.296 +
81.297 +lemma fininf: "(~inf_often P s) = fin_often P s"
81.298 +apply (unfold fin_often_def)
81.299 +apply auto
81.300 +done
81.301 +
81.302 +
81.303 +lemma WF_alt: "is_wfair A W (s,ex) =
81.304 + (fin_often (%x. ~Enabled A W (snd x)) ex --> inf_often (%x. fst x :W) ex)"
81.305 +apply (simp add: is_wfair_def fin_often_def)
81.306 +apply auto
81.307 +done
81.308 +
81.309 +lemma WF_persistent: "[|is_wfair A W (s,ex); inf_often (%x. Enabled A W (snd x)) ex;
81.310 + en_persistent A W|]
81.311 + ==> inf_often (%x. fst x :W) ex"
81.312 +apply (drule persistent)
81.313 +apply assumption
81.314 +apply (simp add: WF_alt)
81.315 +apply auto
81.316 +done
81.317 +
81.318 +
81.319 +lemma fair_trace_inclusion: "!! C A.
81.320 + [| is_ref_map f C A; ext C = ext A;
81.321 + !! ex. [| ex:executions C; fair_ex C ex|] ==> fair_ex A (corresp_ex A f ex) |]
81.322 + ==> fairtraces C <= fairtraces A"
81.323 +apply (simp (no_asm) add: fairtraces_def fairexecutions_def)
81.324 +apply auto
81.325 +apply (rule_tac x = "corresp_ex A f ex" in exI)
81.326 +apply auto
81.327 +
81.328 + (* Traces coincide, Lemma 1 *)
81.329 + apply (tactic {* pair_tac @{context} "ex" 1 *})
81.330 + apply (erule lemma_1 [THEN spec, THEN mp])
81.331 + apply assumption+
81.332 + apply (simp add: executions_def reachable.reachable_0)
81.333 +
81.334 + (* corresp_ex is execution, Lemma 2 *)
81.335 + apply (tactic {* pair_tac @{context} "ex" 1 *})
81.336 + apply (simp add: executions_def)
81.337 + (* start state *)
81.338 + apply (rule conjI)
81.339 + apply (simp add: is_ref_map_def corresp_ex_def)
81.340 + (* is-execution-fragment *)
81.341 + apply (erule lemma_2 [THEN spec, THEN mp])
81.342 + apply (simp add: reachable.reachable_0)
81.343 +
81.344 +done
81.345 +
81.346 +lemma fair_trace_inclusion2: "!! C A.
81.347 + [| inp(C) = inp(A); out(C)=out(A);
81.348 + is_fair_ref_map f C A |]
81.349 + ==> fair_implements C A"
81.350 +apply (simp add: is_fair_ref_map_def fair_implements_def fairtraces_def fairexecutions_def)
81.351 +apply auto
81.352 +apply (rule_tac x = "corresp_ex A f ex" in exI)
81.353 +apply auto
81.354 +
81.355 + (* Traces coincide, Lemma 1 *)
81.356 + apply (tactic {* pair_tac @{context} "ex" 1 *})
81.357 + apply (erule lemma_1 [THEN spec, THEN mp])
81.358 + apply (simp (no_asm) add: externals_def)
81.359 + apply (auto)[1]
81.360 + apply (simp add: executions_def reachable.reachable_0)
81.361 +
81.362 + (* corresp_ex is execution, Lemma 2 *)
81.363 + apply (tactic {* pair_tac @{context} "ex" 1 *})
81.364 + apply (simp add: executions_def)
81.365 + (* start state *)
81.366 + apply (rule conjI)
81.367 + apply (simp add: is_ref_map_def corresp_ex_def)
81.368 + (* is-execution-fragment *)
81.369 + apply (erule lemma_2 [THEN spec, THEN mp])
81.370 + apply (simp add: reachable.reachable_0)
81.371 +
81.372 +done
81.373 +
81.374 +end
82.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
82.2 +++ b/src/HOL/HOLCF/IOA/meta_theory/RefMappings.thy Sat Nov 27 16:08:10 2010 -0800
82.3 @@ -0,0 +1,129 @@
82.4 +(* Title: HOLCF/IOA/meta_theory/RefMappings.thy
82.5 + Author: Olaf Müller
82.6 +*)
82.7 +
82.8 +header {* Refinement Mappings in HOLCF/IOA *}
82.9 +
82.10 +theory RefMappings
82.11 +imports Traces
82.12 +begin
82.13 +
82.14 +default_sort type
82.15 +
82.16 +definition
82.17 + move :: "[('a,'s)ioa,('a,'s)pairs,'s,'a,'s] => bool" where
82.18 + "move ioa ex s a t =
82.19 + (is_exec_frag ioa (s,ex) & Finite ex &
82.20 + laststate (s,ex)=t &
82.21 + mk_trace ioa$ex = (if a:ext(ioa) then a>>nil else nil))"
82.22 +
82.23 +definition
82.24 + is_ref_map :: "[('s1=>'s2),('a,'s1)ioa,('a,'s2)ioa] => bool" where
82.25 + "is_ref_map f C A =
82.26 + ((!s:starts_of(C). f(s):starts_of(A)) &
82.27 + (!s t a. reachable C s &
82.28 + s -a--C-> t
82.29 + --> (? ex. move A ex (f s) a (f t))))"
82.30 +
82.31 +definition
82.32 + is_weak_ref_map :: "[('s1=>'s2),('a,'s1)ioa,('a,'s2)ioa] => bool" where
82.33 + "is_weak_ref_map f C A =
82.34 + ((!s:starts_of(C). f(s):starts_of(A)) &
82.35 + (!s t a. reachable C s &
82.36 + s -a--C-> t
82.37 + --> (if a:ext(C)
82.38 + then (f s) -a--A-> (f t)
82.39 + else (f s)=(f t))))"
82.40 +
82.41 +
82.42 +subsection "transitions and moves"
82.43 +
82.44 +
82.45 +lemma transition_is_ex: "s -a--A-> t ==> ? ex. move A ex s a t"
82.46 +apply (rule_tac x = " (a,t) >>nil" in exI)
82.47 +apply (simp add: move_def)
82.48 +done
82.49 +
82.50 +
82.51 +lemma nothing_is_ex: "(~a:ext A) & s=t ==> ? ex. move A ex s a t"
82.52 +apply (rule_tac x = "nil" in exI)
82.53 +apply (simp add: move_def)
82.54 +done
82.55 +
82.56 +
82.57 +lemma ei_transitions_are_ex: "(s -a--A-> s') & (s' -a'--A-> s'') & (~a':ext A)
82.58 + ==> ? ex. move A ex s a s''"
82.59 +apply (rule_tac x = " (a,s') >> (a',s'') >>nil" in exI)
82.60 +apply (simp add: move_def)
82.61 +done
82.62 +
82.63 +
82.64 +lemma eii_transitions_are_ex: "(s1 -a1--A-> s2) & (s2 -a2--A-> s3) & (s3 -a3--A-> s4) &
82.65 + (~a2:ext A) & (~a3:ext A) ==>
82.66 + ? ex. move A ex s1 a1 s4"
82.67 +apply (rule_tac x = " (a1,s2) >> (a2,s3) >> (a3,s4) >>nil" in exI)
82.68 +apply (simp add: move_def)
82.69 +done
82.70 +
82.71 +
82.72 +subsection "weak_ref_map and ref_map"
82.73 +
82.74 +lemma weak_ref_map2ref_map:
82.75 + "[| ext C = ext A;
82.76 + is_weak_ref_map f C A |] ==> is_ref_map f C A"
82.77 +apply (unfold is_weak_ref_map_def is_ref_map_def)
82.78 +apply auto
82.79 +apply (case_tac "a:ext A")
82.80 +apply (auto intro: transition_is_ex nothing_is_ex)
82.81 +done
82.82 +
82.83 +
82.84 +lemma imp_conj_lemma: "(P ==> Q-->R) ==> P&Q --> R"
82.85 + by blast
82.86 +
82.87 +declare split_if [split del]
82.88 +declare if_weak_cong [cong del]
82.89 +
82.90 +lemma rename_through_pmap: "[| is_weak_ref_map f C A |]
82.91 + ==> (is_weak_ref_map f (rename C g) (rename A g))"
82.92 +apply (simp add: is_weak_ref_map_def)
82.93 +apply (rule conjI)
82.94 +(* 1: start states *)
82.95 +apply (simp add: rename_def rename_set_def starts_of_def)
82.96 +(* 2: reachable transitions *)
82.97 +apply (rule allI)+
82.98 +apply (rule imp_conj_lemma)
82.99 +apply (simp (no_asm) add: rename_def rename_set_def)
82.100 +apply (simp add: externals_def asig_inputs_def asig_outputs_def asig_of_def trans_of_def)
82.101 +apply safe
82.102 +apply (simplesubst split_if)
82.103 + apply (rule conjI)
82.104 + apply (rule impI)
82.105 + apply (erule disjE)
82.106 + apply (erule exE)
82.107 +apply (erule conjE)
82.108 +(* x is input *)
82.109 + apply (drule sym)
82.110 + apply (drule sym)
82.111 +apply simp
82.112 +apply hypsubst+
82.113 +apply (frule reachable_rename)
82.114 +apply simp
82.115 +(* x is output *)
82.116 + apply (erule exE)
82.117 +apply (erule conjE)
82.118 + apply (drule sym)
82.119 + apply (drule sym)
82.120 +apply simp
82.121 +apply hypsubst+
82.122 +apply (frule reachable_rename)
82.123 +apply simp
82.124 +(* x is internal *)
82.125 +apply (frule reachable_rename)
82.126 +apply auto
82.127 +done
82.128 +
82.129 +declare split_if [split]
82.130 +declare if_weak_cong [cong]
82.131 +
82.132 +end
83.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
83.2 +++ b/src/HOL/HOLCF/IOA/meta_theory/Seq.thy Sat Nov 27 16:08:10 2010 -0800
83.3 @@ -0,0 +1,328 @@
83.4 +(* Title: HOLCF/IOA/meta_theory/Seq.thy
83.5 + Author: Olaf Müller
83.6 +*)
83.7 +
83.8 +header {* Partial, Finite and Infinite Sequences (lazy lists), modeled as domain *}
83.9 +
83.10 +theory Seq
83.11 +imports HOLCF
83.12 +begin
83.13 +
83.14 +default_sort pcpo
83.15 +
83.16 +domain (unsafe) 'a seq = nil ("nil") | cons (HD :: 'a) (lazy TL :: "'a seq") (infixr "##" 65)
83.17 +
83.18 +(*
83.19 + sfilter :: "('a -> tr) -> 'a seq -> 'a seq"
83.20 + smap :: "('a -> 'b) -> 'a seq -> 'b seq"
83.21 + sforall :: "('a -> tr) => 'a seq => bool"
83.22 + sforall2 :: "('a -> tr) -> 'a seq -> tr"
83.23 + slast :: "'a seq -> 'a"
83.24 + sconc :: "'a seq -> 'a seq -> 'a seq"
83.25 + sdropwhile :: "('a -> tr) -> 'a seq -> 'a seq"
83.26 + stakewhile :: "('a -> tr) -> 'a seq -> 'a seq"
83.27 + szip :: "'a seq -> 'b seq -> ('a*'b) seq"
83.28 + sflat :: "('a seq) seq -> 'a seq"
83.29 +
83.30 + sfinite :: "'a seq set"
83.31 + Partial :: "'a seq => bool"
83.32 + Infinite :: "'a seq => bool"
83.33 +
83.34 + nproj :: "nat => 'a seq => 'a"
83.35 + sproj :: "nat => 'a seq => 'a seq"
83.36 +*)
83.37 +
83.38 +inductive
83.39 + Finite :: "'a seq => bool"
83.40 + where
83.41 + sfinite_0: "Finite nil"
83.42 + | sfinite_n: "[| Finite tr; a~=UU |] ==> Finite (a##tr)"
83.43 +
83.44 +declare Finite.intros [simp]
83.45 +
83.46 +definition
83.47 + Partial :: "'a seq => bool"
83.48 +where
83.49 + "Partial x == (seq_finite x) & ~(Finite x)"
83.50 +
83.51 +definition
83.52 + Infinite :: "'a seq => bool"
83.53 +where
83.54 + "Infinite x == ~(seq_finite x)"
83.55 +
83.56 +
83.57 +subsection {* recursive equations of operators *}
83.58 +
83.59 +subsubsection {* smap *}
83.60 +
83.61 +fixrec
83.62 + smap :: "('a -> 'b) -> 'a seq -> 'b seq"
83.63 +where
83.64 + smap_nil: "smap$f$nil=nil"
83.65 +| smap_cons: "[|x~=UU|] ==> smap$f$(x##xs)= (f$x)##smap$f$xs"
83.66 +
83.67 +lemma smap_UU [simp]: "smap$f$UU=UU"
83.68 +by fixrec_simp
83.69 +
83.70 +subsubsection {* sfilter *}
83.71 +
83.72 +fixrec
83.73 + sfilter :: "('a -> tr) -> 'a seq -> 'a seq"
83.74 +where
83.75 + sfilter_nil: "sfilter$P$nil=nil"
83.76 +| sfilter_cons:
83.77 + "x~=UU ==> sfilter$P$(x##xs)=
83.78 + (If P$x then x##(sfilter$P$xs) else sfilter$P$xs)"
83.79 +
83.80 +lemma sfilter_UU [simp]: "sfilter$P$UU=UU"
83.81 +by fixrec_simp
83.82 +
83.83 +subsubsection {* sforall2 *}
83.84 +
83.85 +fixrec
83.86 + sforall2 :: "('a -> tr) -> 'a seq -> tr"
83.87 +where
83.88 + sforall2_nil: "sforall2$P$nil=TT"
83.89 +| sforall2_cons:
83.90 + "x~=UU ==> sforall2$P$(x##xs)= ((P$x) andalso sforall2$P$xs)"
83.91 +
83.92 +lemma sforall2_UU [simp]: "sforall2$P$UU=UU"
83.93 +by fixrec_simp
83.94 +
83.95 +definition
83.96 + sforall_def: "sforall P t == (sforall2$P$t ~=FF)"
83.97 +
83.98 +subsubsection {* stakewhile *}
83.99 +
83.100 +fixrec
83.101 + stakewhile :: "('a -> tr) -> 'a seq -> 'a seq"
83.102 +where
83.103 + stakewhile_nil: "stakewhile$P$nil=nil"
83.104 +| stakewhile_cons:
83.105 + "x~=UU ==> stakewhile$P$(x##xs) =
83.106 + (If P$x then x##(stakewhile$P$xs) else nil)"
83.107 +
83.108 +lemma stakewhile_UU [simp]: "stakewhile$P$UU=UU"
83.109 +by fixrec_simp
83.110 +
83.111 +subsubsection {* sdropwhile *}
83.112 +
83.113 +fixrec
83.114 + sdropwhile :: "('a -> tr) -> 'a seq -> 'a seq"
83.115 +where
83.116 + sdropwhile_nil: "sdropwhile$P$nil=nil"
83.117 +| sdropwhile_cons:
83.118 + "x~=UU ==> sdropwhile$P$(x##xs) =
83.119 + (If P$x then sdropwhile$P$xs else x##xs)"
83.120 +
83.121 +lemma sdropwhile_UU [simp]: "sdropwhile$P$UU=UU"
83.122 +by fixrec_simp
83.123 +
83.124 +subsubsection {* slast *}
83.125 +
83.126 +fixrec
83.127 + slast :: "'a seq -> 'a"
83.128 +where
83.129 + slast_nil: "slast$nil=UU"
83.130 +| slast_cons:
83.131 + "x~=UU ==> slast$(x##xs)= (If is_nil$xs then x else slast$xs)"
83.132 +
83.133 +lemma slast_UU [simp]: "slast$UU=UU"
83.134 +by fixrec_simp
83.135 +
83.136 +subsubsection {* sconc *}
83.137 +
83.138 +fixrec
83.139 + sconc :: "'a seq -> 'a seq -> 'a seq"
83.140 +where
83.141 + sconc_nil: "sconc$nil$y = y"
83.142 +| sconc_cons':
83.143 + "x~=UU ==> sconc$(x##xs)$y = x##(sconc$xs$y)"
83.144 +
83.145 +abbreviation
83.146 + sconc_syn :: "'a seq => 'a seq => 'a seq" (infixr "@@" 65) where
83.147 + "xs @@ ys == sconc $ xs $ ys"
83.148 +
83.149 +lemma sconc_UU [simp]: "UU @@ y=UU"
83.150 +by fixrec_simp
83.151 +
83.152 +lemma sconc_cons [simp]: "(x##xs) @@ y=x##(xs @@ y)"
83.153 +apply (cases "x=UU")
83.154 +apply simp_all
83.155 +done
83.156 +
83.157 +declare sconc_cons' [simp del]
83.158 +
83.159 +subsubsection {* sflat *}
83.160 +
83.161 +fixrec
83.162 + sflat :: "('a seq) seq -> 'a seq"
83.163 +where
83.164 + sflat_nil: "sflat$nil=nil"
83.165 +| sflat_cons': "x~=UU ==> sflat$(x##xs)= x@@(sflat$xs)"
83.166 +
83.167 +lemma sflat_UU [simp]: "sflat$UU=UU"
83.168 +by fixrec_simp
83.169 +
83.170 +lemma sflat_cons [simp]: "sflat$(x##xs)= x@@(sflat$xs)"
83.171 +by (cases "x=UU", simp_all)
83.172 +
83.173 +declare sflat_cons' [simp del]
83.174 +
83.175 +subsubsection {* szip *}
83.176 +
83.177 +fixrec
83.178 + szip :: "'a seq -> 'b seq -> ('a*'b) seq"
83.179 +where
83.180 + szip_nil: "szip$nil$y=nil"
83.181 +| szip_cons_nil: "x~=UU ==> szip$(x##xs)$nil=UU"
83.182 +| szip_cons:
83.183 + "[| x~=UU; y~=UU|] ==> szip$(x##xs)$(y##ys) = (x,y)##szip$xs$ys"
83.184 +
83.185 +lemma szip_UU1 [simp]: "szip$UU$y=UU"
83.186 +by fixrec_simp
83.187 +
83.188 +lemma szip_UU2 [simp]: "x~=nil ==> szip$x$UU=UU"
83.189 +by (cases x, simp_all, fixrec_simp)
83.190 +
83.191 +
83.192 +subsection "scons, nil"
83.193 +
83.194 +lemma scons_inject_eq:
83.195 + "[|x~=UU;y~=UU|]==> (x##xs=y##ys) = (x=y & xs=ys)"
83.196 +by simp
83.197 +
83.198 +lemma nil_less_is_nil: "nil<<x ==> nil=x"
83.199 +apply (cases x)
83.200 +apply simp
83.201 +apply simp
83.202 +apply simp
83.203 +done
83.204 +
83.205 +subsection "sfilter, sforall, sconc"
83.206 +
83.207 +lemma if_and_sconc [simp]: "(if b then tr1 else tr2) @@ tr
83.208 + = (if b then tr1 @@ tr else tr2 @@ tr)"
83.209 +by simp
83.210 +
83.211 +
83.212 +lemma sfiltersconc: "sfilter$P$(x @@ y) = (sfilter$P$x @@ sfilter$P$y)"
83.213 +apply (induct x)
83.214 +(* adm *)
83.215 +apply simp
83.216 +(* base cases *)
83.217 +apply simp
83.218 +apply simp
83.219 +(* main case *)
83.220 +apply (rule_tac p="P$a" in trE)
83.221 +apply simp
83.222 +apply simp
83.223 +apply simp
83.224 +done
83.225 +
83.226 +lemma sforallPstakewhileP: "sforall P (stakewhile$P$x)"
83.227 +apply (simp add: sforall_def)
83.228 +apply (induct x)
83.229 +(* adm *)
83.230 +apply simp
83.231 +(* base cases *)
83.232 +apply simp
83.233 +apply simp
83.234 +(* main case *)
83.235 +apply (rule_tac p="P$a" in trE)
83.236 +apply simp
83.237 +apply simp
83.238 +apply simp
83.239 +done
83.240 +
83.241 +lemma forallPsfilterP: "sforall P (sfilter$P$x)"
83.242 +apply (simp add: sforall_def)
83.243 +apply (induct x)
83.244 +(* adm *)
83.245 +apply simp
83.246 +(* base cases *)
83.247 +apply simp
83.248 +apply simp
83.249 +(* main case *)
83.250 +apply (rule_tac p="P$a" in trE)
83.251 +apply simp
83.252 +apply simp
83.253 +apply simp
83.254 +done
83.255 +
83.256 +
83.257 +subsection "Finite"
83.258 +
83.259 +(* ---------------------------------------------------- *)
83.260 +(* Proofs of rewrite rules for Finite: *)
83.261 +(* 1. Finite(nil), (by definition) *)
83.262 +(* 2. ~Finite(UU), *)
83.263 +(* 3. a~=UU==> Finite(a##x)=Finite(x) *)
83.264 +(* ---------------------------------------------------- *)
83.265 +
83.266 +lemma Finite_UU_a: "Finite x --> x~=UU"
83.267 +apply (rule impI)
83.268 +apply (erule Finite.induct)
83.269 + apply simp
83.270 +apply simp
83.271 +done
83.272 +
83.273 +lemma Finite_UU [simp]: "~(Finite UU)"
83.274 +apply (cut_tac x="UU" in Finite_UU_a)
83.275 +apply fast
83.276 +done
83.277 +
83.278 +lemma Finite_cons_a: "Finite x --> a~=UU --> x=a##xs --> Finite xs"
83.279 +apply (intro strip)
83.280 +apply (erule Finite.cases)
83.281 +apply fastsimp
83.282 +apply simp
83.283 +done
83.284 +
83.285 +lemma Finite_cons: "a~=UU ==>(Finite (a##x)) = (Finite x)"
83.286 +apply (rule iffI)
83.287 +apply (erule (1) Finite_cons_a [rule_format])
83.288 +apply fast
83.289 +apply simp
83.290 +done
83.291 +
83.292 +lemma Finite_upward: "\<lbrakk>Finite x; x \<sqsubseteq> y\<rbrakk> \<Longrightarrow> Finite y"
83.293 +apply (induct arbitrary: y set: Finite)
83.294 +apply (case_tac y, simp, simp, simp)
83.295 +apply (case_tac y, simp, simp)
83.296 +apply simp
83.297 +done
83.298 +
83.299 +lemma adm_Finite [simp]: "adm Finite"
83.300 +by (rule adm_upward, rule Finite_upward)
83.301 +
83.302 +
83.303 +subsection "induction"
83.304 +
83.305 +
83.306 +(*-------------------------------- *)
83.307 +(* Extensions to Induction Theorems *)
83.308 +(*-------------------------------- *)
83.309 +
83.310 +
83.311 +lemma seq_finite_ind_lemma:
83.312 + assumes "(!!n. P(seq_take n$s))"
83.313 + shows "seq_finite(s) -->P(s)"
83.314 +apply (unfold seq.finite_def)
83.315 +apply (intro strip)
83.316 +apply (erule exE)
83.317 +apply (erule subst)
83.318 +apply (rule prems)
83.319 +done
83.320 +
83.321 +
83.322 +lemma seq_finite_ind: "!!P.[|P(UU);P(nil);
83.323 + !! x s1.[|x~=UU;P(s1)|] ==> P(x##s1)
83.324 + |] ==> seq_finite(s) --> P(s)"
83.325 +apply (rule seq_finite_ind_lemma)
83.326 +apply (erule seq.finite_induct)
83.327 + apply assumption
83.328 +apply simp
83.329 +done
83.330 +
83.331 +end
84.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
84.2 +++ b/src/HOL/HOLCF/IOA/meta_theory/Sequence.thy Sat Nov 27 16:08:10 2010 -0800
84.3 @@ -0,0 +1,1118 @@
84.4 +(* Title: HOLCF/IOA/meta_theory/Sequence.thy
84.5 + Author: Olaf Müller
84.6 +
84.7 +Sequences over flat domains with lifted elements.
84.8 +*)
84.9 +
84.10 +theory Sequence
84.11 +imports Seq
84.12 +begin
84.13 +
84.14 +default_sort type
84.15 +
84.16 +types 'a Seq = "'a lift seq"
84.17 +
84.18 +consts
84.19 +
84.20 + Consq ::"'a => 'a Seq -> 'a Seq"
84.21 + Filter ::"('a => bool) => 'a Seq -> 'a Seq"
84.22 + Map ::"('a => 'b) => 'a Seq -> 'b Seq"
84.23 + Forall ::"('a => bool) => 'a Seq => bool"
84.24 + Last ::"'a Seq -> 'a lift"
84.25 + Dropwhile ::"('a => bool) => 'a Seq -> 'a Seq"
84.26 + Takewhile ::"('a => bool) => 'a Seq -> 'a Seq"
84.27 + Zip ::"'a Seq -> 'b Seq -> ('a * 'b) Seq"
84.28 + Flat ::"('a Seq) seq -> 'a Seq"
84.29 +
84.30 + Filter2 ::"('a => bool) => 'a Seq -> 'a Seq"
84.31 +
84.32 +abbreviation
84.33 + Consq_syn ("(_/>>_)" [66,65] 65) where
84.34 + "a>>s == Consq a$s"
84.35 +
84.36 +notation (xsymbols)
84.37 + Consq_syn ("(_\<leadsto>_)" [66,65] 65)
84.38 +
84.39 +
84.40 +(* list Enumeration *)
84.41 +syntax
84.42 + "_totlist" :: "args => 'a Seq" ("[(_)!]")
84.43 + "_partlist" :: "args => 'a Seq" ("[(_)?]")
84.44 +translations
84.45 + "[x, xs!]" == "x>>[xs!]"
84.46 + "[x!]" == "x>>nil"
84.47 + "[x, xs?]" == "x>>[xs?]"
84.48 + "[x?]" == "x>>CONST UU"
84.49 +
84.50 +defs
84.51 +
84.52 +Consq_def: "Consq a == LAM s. Def a ## s"
84.53 +
84.54 +Filter_def: "Filter P == sfilter$(flift2 P)"
84.55 +
84.56 +Map_def: "Map f == smap$(flift2 f)"
84.57 +
84.58 +Forall_def: "Forall P == sforall (flift2 P)"
84.59 +
84.60 +Last_def: "Last == slast"
84.61 +
84.62 +Dropwhile_def: "Dropwhile P == sdropwhile$(flift2 P)"
84.63 +
84.64 +Takewhile_def: "Takewhile P == stakewhile$(flift2 P)"
84.65 +
84.66 +Flat_def: "Flat == sflat"
84.67 +
84.68 +Zip_def:
84.69 + "Zip == (fix$(LAM h t1 t2. case t1 of
84.70 + nil => nil
84.71 + | x##xs => (case t2 of
84.72 + nil => UU
84.73 + | y##ys => (case x of
84.74 + UU => UU
84.75 + | Def a => (case y of
84.76 + UU => UU
84.77 + | Def b => Def (a,b)##(h$xs$ys))))))"
84.78 +
84.79 +Filter2_def: "Filter2 P == (fix$(LAM h t. case t of
84.80 + nil => nil
84.81 + | x##xs => (case x of UU => UU | Def y => (if P y
84.82 + then x##(h$xs)
84.83 + else h$xs))))"
84.84 +
84.85 +declare andalso_and [simp]
84.86 +declare andalso_or [simp]
84.87 +
84.88 +subsection "recursive equations of operators"
84.89 +
84.90 +subsubsection "Map"
84.91 +
84.92 +lemma Map_UU: "Map f$UU =UU"
84.93 +by (simp add: Map_def)
84.94 +
84.95 +lemma Map_nil: "Map f$nil =nil"
84.96 +by (simp add: Map_def)
84.97 +
84.98 +lemma Map_cons: "Map f$(x>>xs)=(f x) >> Map f$xs"
84.99 +by (simp add: Map_def Consq_def flift2_def)
84.100 +
84.101 +
84.102 +subsubsection {* Filter *}
84.103 +
84.104 +lemma Filter_UU: "Filter P$UU =UU"
84.105 +by (simp add: Filter_def)
84.106 +
84.107 +lemma Filter_nil: "Filter P$nil =nil"
84.108 +by (simp add: Filter_def)
84.109 +
84.110 +lemma Filter_cons:
84.111 + "Filter P$(x>>xs)= (if P x then x>>(Filter P$xs) else Filter P$xs)"
84.112 +by (simp add: Filter_def Consq_def flift2_def If_and_if)
84.113 +
84.114 +
84.115 +subsubsection {* Forall *}
84.116 +
84.117 +lemma Forall_UU: "Forall P UU"
84.118 +by (simp add: Forall_def sforall_def)
84.119 +
84.120 +lemma Forall_nil: "Forall P nil"
84.121 +by (simp add: Forall_def sforall_def)
84.122 +
84.123 +lemma Forall_cons: "Forall P (x>>xs)= (P x & Forall P xs)"
84.124 +by (simp add: Forall_def sforall_def Consq_def flift2_def)
84.125 +
84.126 +
84.127 +subsubsection {* Conc *}
84.128 +
84.129 +lemma Conc_cons: "(x>>xs) @@ y = x>>(xs @@y)"
84.130 +by (simp add: Consq_def)
84.131 +
84.132 +
84.133 +subsubsection {* Takewhile *}
84.134 +
84.135 +lemma Takewhile_UU: "Takewhile P$UU =UU"
84.136 +by (simp add: Takewhile_def)
84.137 +
84.138 +lemma Takewhile_nil: "Takewhile P$nil =nil"
84.139 +by (simp add: Takewhile_def)
84.140 +
84.141 +lemma Takewhile_cons:
84.142 + "Takewhile P$(x>>xs)= (if P x then x>>(Takewhile P$xs) else nil)"
84.143 +by (simp add: Takewhile_def Consq_def flift2_def If_and_if)
84.144 +
84.145 +
84.146 +subsubsection {* DropWhile *}
84.147 +
84.148 +lemma Dropwhile_UU: "Dropwhile P$UU =UU"
84.149 +by (simp add: Dropwhile_def)
84.150 +
84.151 +lemma Dropwhile_nil: "Dropwhile P$nil =nil"
84.152 +by (simp add: Dropwhile_def)
84.153 +
84.154 +lemma Dropwhile_cons:
84.155 + "Dropwhile P$(x>>xs)= (if P x then Dropwhile P$xs else x>>xs)"
84.156 +by (simp add: Dropwhile_def Consq_def flift2_def If_and_if)
84.157 +
84.158 +
84.159 +subsubsection {* Last *}
84.160 +
84.161 +lemma Last_UU: "Last$UU =UU"
84.162 +by (simp add: Last_def)
84.163 +
84.164 +lemma Last_nil: "Last$nil =UU"
84.165 +by (simp add: Last_def)
84.166 +
84.167 +lemma Last_cons: "Last$(x>>xs)= (if xs=nil then Def x else Last$xs)"
84.168 +apply (simp add: Last_def Consq_def)
84.169 +apply (cases xs)
84.170 +apply simp_all
84.171 +done
84.172 +
84.173 +
84.174 +subsubsection {* Flat *}
84.175 +
84.176 +lemma Flat_UU: "Flat$UU =UU"
84.177 +by (simp add: Flat_def)
84.178 +
84.179 +lemma Flat_nil: "Flat$nil =nil"
84.180 +by (simp add: Flat_def)
84.181 +
84.182 +lemma Flat_cons: "Flat$(x##xs)= x @@ (Flat$xs)"
84.183 +by (simp add: Flat_def Consq_def)
84.184 +
84.185 +
84.186 +subsubsection {* Zip *}
84.187 +
84.188 +lemma Zip_unfold:
84.189 +"Zip = (LAM t1 t2. case t1 of
84.190 + nil => nil
84.191 + | x##xs => (case t2 of
84.192 + nil => UU
84.193 + | y##ys => (case x of
84.194 + UU => UU
84.195 + | Def a => (case y of
84.196 + UU => UU
84.197 + | Def b => Def (a,b)##(Zip$xs$ys)))))"
84.198 +apply (rule trans)
84.199 +apply (rule fix_eq2)
84.200 +apply (rule Zip_def)
84.201 +apply (rule beta_cfun)
84.202 +apply simp
84.203 +done
84.204 +
84.205 +lemma Zip_UU1: "Zip$UU$y =UU"
84.206 +apply (subst Zip_unfold)
84.207 +apply simp
84.208 +done
84.209 +
84.210 +lemma Zip_UU2: "x~=nil ==> Zip$x$UU =UU"
84.211 +apply (subst Zip_unfold)
84.212 +apply simp
84.213 +apply (cases x)
84.214 +apply simp_all
84.215 +done
84.216 +
84.217 +lemma Zip_nil: "Zip$nil$y =nil"
84.218 +apply (subst Zip_unfold)
84.219 +apply simp
84.220 +done
84.221 +
84.222 +lemma Zip_cons_nil: "Zip$(x>>xs)$nil= UU"
84.223 +apply (subst Zip_unfold)
84.224 +apply (simp add: Consq_def)
84.225 +done
84.226 +
84.227 +lemma Zip_cons: "Zip$(x>>xs)$(y>>ys)= (x,y) >> Zip$xs$ys"
84.228 +apply (rule trans)
84.229 +apply (subst Zip_unfold)
84.230 +apply simp
84.231 +apply (simp add: Consq_def)
84.232 +done
84.233 +
84.234 +lemmas [simp del] =
84.235 + sfilter_UU sfilter_nil sfilter_cons
84.236 + smap_UU smap_nil smap_cons
84.237 + sforall2_UU sforall2_nil sforall2_cons
84.238 + slast_UU slast_nil slast_cons
84.239 + stakewhile_UU stakewhile_nil stakewhile_cons
84.240 + sdropwhile_UU sdropwhile_nil sdropwhile_cons
84.241 + sflat_UU sflat_nil sflat_cons
84.242 + szip_UU1 szip_UU2 szip_nil szip_cons_nil szip_cons
84.243 +
84.244 +lemmas [simp] =
84.245 + Filter_UU Filter_nil Filter_cons
84.246 + Map_UU Map_nil Map_cons
84.247 + Forall_UU Forall_nil Forall_cons
84.248 + Last_UU Last_nil Last_cons
84.249 + Conc_cons
84.250 + Takewhile_UU Takewhile_nil Takewhile_cons
84.251 + Dropwhile_UU Dropwhile_nil Dropwhile_cons
84.252 + Zip_UU1 Zip_UU2 Zip_nil Zip_cons_nil Zip_cons
84.253 +
84.254 +
84.255 +
84.256 +section "Cons"
84.257 +
84.258 +lemma Consq_def2: "a>>s = (Def a)##s"
84.259 +apply (simp add: Consq_def)
84.260 +done
84.261 +
84.262 +lemma Seq_exhaust: "x = UU | x = nil | (? a s. x = a >> s)"
84.263 +apply (simp add: Consq_def2)
84.264 +apply (cut_tac seq.nchotomy)
84.265 +apply (fast dest: not_Undef_is_Def [THEN iffD1])
84.266 +done
84.267 +
84.268 +
84.269 +lemma Seq_cases:
84.270 +"!!P. [| x = UU ==> P; x = nil ==> P; !!a s. x = a >> s ==> P |] ==> P"
84.271 +apply (cut_tac x="x" in Seq_exhaust)
84.272 +apply (erule disjE)
84.273 +apply simp
84.274 +apply (erule disjE)
84.275 +apply simp
84.276 +apply (erule exE)+
84.277 +apply simp
84.278 +done
84.279 +
84.280 +(*
84.281 +fun Seq_case_tac s i = rule_tac x",s)] Seq_cases i
84.282 + THEN hyp_subst_tac i THEN hyp_subst_tac (i+1) THEN hyp_subst_tac (i+2);
84.283 +*)
84.284 +(* on a>>s only simp_tac, as full_simp_tac is uncomplete and often causes errors *)
84.285 +(*
84.286 +fun Seq_case_simp_tac s i = Seq_case_tac s i THEN Asm_simp_tac (i+2)
84.287 + THEN Asm_full_simp_tac (i+1)
84.288 + THEN Asm_full_simp_tac i;
84.289 +*)
84.290 +
84.291 +lemma Cons_not_UU: "a>>s ~= UU"
84.292 +apply (subst Consq_def2)
84.293 +apply simp
84.294 +done
84.295 +
84.296 +
84.297 +lemma Cons_not_less_UU: "~(a>>x) << UU"
84.298 +apply (rule notI)
84.299 +apply (drule below_antisym)
84.300 +apply simp
84.301 +apply (simp add: Cons_not_UU)
84.302 +done
84.303 +
84.304 +lemma Cons_not_less_nil: "~a>>s << nil"
84.305 +apply (simp add: Consq_def2)
84.306 +done
84.307 +
84.308 +lemma Cons_not_nil: "a>>s ~= nil"
84.309 +apply (simp add: Consq_def2)
84.310 +done
84.311 +
84.312 +lemma Cons_not_nil2: "nil ~= a>>s"
84.313 +apply (simp add: Consq_def2)
84.314 +done
84.315 +
84.316 +lemma Cons_inject_eq: "(a>>s = b>>t) = (a = b & s = t)"
84.317 +apply (simp only: Consq_def2)
84.318 +apply (simp add: scons_inject_eq)
84.319 +done
84.320 +
84.321 +lemma Cons_inject_less_eq: "(a>>s<<b>>t) = (a = b & s<<t)"
84.322 +apply (simp add: Consq_def2)
84.323 +done
84.324 +
84.325 +lemma seq_take_Cons: "seq_take (Suc n)$(a>>x) = a>> (seq_take n$x)"
84.326 +apply (simp add: Consq_def)
84.327 +done
84.328 +
84.329 +lemmas [simp] =
84.330 + Cons_not_nil2 Cons_inject_eq Cons_inject_less_eq seq_take_Cons
84.331 + Cons_not_UU Cons_not_less_UU Cons_not_less_nil Cons_not_nil
84.332 +
84.333 +
84.334 +subsection "induction"
84.335 +
84.336 +lemma Seq_induct:
84.337 +"!! P. [| adm P; P UU; P nil; !! a s. P s ==> P (a>>s)|] ==> P x"
84.338 +apply (erule (2) seq.induct)
84.339 +apply defined
84.340 +apply (simp add: Consq_def)
84.341 +done
84.342 +
84.343 +lemma Seq_FinitePartial_ind:
84.344 +"!! P.[|P UU;P nil; !! a s. P s ==> P(a>>s) |]
84.345 + ==> seq_finite x --> P x"
84.346 +apply (erule (1) seq_finite_ind)
84.347 +apply defined
84.348 +apply (simp add: Consq_def)
84.349 +done
84.350 +
84.351 +lemma Seq_Finite_ind:
84.352 +"!! P.[| Finite x; P nil; !! a s. [| Finite s; P s|] ==> P (a>>s) |] ==> P x"
84.353 +apply (erule (1) Finite.induct)
84.354 +apply defined
84.355 +apply (simp add: Consq_def)
84.356 +done
84.357 +
84.358 +
84.359 +(* rws are definitions to be unfolded for admissibility check *)
84.360 +(*
84.361 +fun Seq_induct_tac s rws i = rule_tac x",s)] Seq_induct i
84.362 + THEN (REPEAT_DETERM (CHANGED (Asm_simp_tac (i+1))))
84.363 + THEN simp add: rws) i;
84.364 +
84.365 +fun Seq_Finite_induct_tac i = erule Seq_Finite_ind i
84.366 + THEN (REPEAT_DETERM (CHANGED (Asm_simp_tac i)));
84.367 +
84.368 +fun pair_tac s = rule_tac p",s)] PairE
84.369 + THEN' hyp_subst_tac THEN' Simp_tac;
84.370 +*)
84.371 +(* induction on a sequence of pairs with pairsplitting and simplification *)
84.372 +(*
84.373 +fun pair_induct_tac s rws i =
84.374 + rule_tac x",s)] Seq_induct i
84.375 + THEN pair_tac "a" (i+3)
84.376 + THEN (REPEAT_DETERM (CHANGED (Simp_tac (i+1))))
84.377 + THEN simp add: rws) i;
84.378 +*)
84.379 +
84.380 +
84.381 +(* ------------------------------------------------------------------------------------ *)
84.382 +
84.383 +subsection "HD,TL"
84.384 +
84.385 +lemma HD_Cons [simp]: "HD$(x>>y) = Def x"
84.386 +apply (simp add: Consq_def)
84.387 +done
84.388 +
84.389 +lemma TL_Cons [simp]: "TL$(x>>y) = y"
84.390 +apply (simp add: Consq_def)
84.391 +done
84.392 +
84.393 +(* ------------------------------------------------------------------------------------ *)
84.394 +
84.395 +subsection "Finite, Partial, Infinite"
84.396 +
84.397 +lemma Finite_Cons [simp]: "Finite (a>>xs) = Finite xs"
84.398 +apply (simp add: Consq_def2 Finite_cons)
84.399 +done
84.400 +
84.401 +lemma FiniteConc_1: "Finite (x::'a Seq) ==> Finite y --> Finite (x@@y)"
84.402 +apply (erule Seq_Finite_ind, simp_all)
84.403 +done
84.404 +
84.405 +lemma FiniteConc_2:
84.406 +"Finite (z::'a Seq) ==> !x y. z= x@@y --> (Finite x & Finite y)"
84.407 +apply (erule Seq_Finite_ind)
84.408 +(* nil*)
84.409 +apply (intro strip)
84.410 +apply (rule_tac x="x" in Seq_cases, simp_all)
84.411 +(* cons *)
84.412 +apply (intro strip)
84.413 +apply (rule_tac x="x" in Seq_cases, simp_all)
84.414 +apply (rule_tac x="y" in Seq_cases, simp_all)
84.415 +done
84.416 +
84.417 +lemma FiniteConc [simp]: "Finite(x@@y) = (Finite (x::'a Seq) & Finite y)"
84.418 +apply (rule iffI)
84.419 +apply (erule FiniteConc_2 [rule_format])
84.420 +apply (rule refl)
84.421 +apply (rule FiniteConc_1 [rule_format])
84.422 +apply auto
84.423 +done
84.424 +
84.425 +
84.426 +lemma FiniteMap1: "Finite s ==> Finite (Map f$s)"
84.427 +apply (erule Seq_Finite_ind, simp_all)
84.428 +done
84.429 +
84.430 +lemma FiniteMap2: "Finite s ==> ! t. (s = Map f$t) --> Finite t"
84.431 +apply (erule Seq_Finite_ind)
84.432 +apply (intro strip)
84.433 +apply (rule_tac x="t" in Seq_cases, simp_all)
84.434 +(* main case *)
84.435 +apply auto
84.436 +apply (rule_tac x="t" in Seq_cases, simp_all)
84.437 +done
84.438 +
84.439 +lemma Map2Finite: "Finite (Map f$s) = Finite s"
84.440 +apply auto
84.441 +apply (erule FiniteMap2 [rule_format])
84.442 +apply (rule refl)
84.443 +apply (erule FiniteMap1)
84.444 +done
84.445 +
84.446 +
84.447 +lemma FiniteFilter: "Finite s ==> Finite (Filter P$s)"
84.448 +apply (erule Seq_Finite_ind, simp_all)
84.449 +done
84.450 +
84.451 +
84.452 +(* ----------------------------------------------------------------------------------- *)
84.453 +
84.454 +subsection "Conc"
84.455 +
84.456 +lemma Conc_cong: "!! x::'a Seq. Finite x ==> ((x @@ y) = (x @@ z)) = (y = z)"
84.457 +apply (erule Seq_Finite_ind, simp_all)
84.458 +done
84.459 +
84.460 +lemma Conc_assoc: "(x @@ y) @@ z = (x::'a Seq) @@ y @@ z"
84.461 +apply (rule_tac x="x" in Seq_induct, simp_all)
84.462 +done
84.463 +
84.464 +lemma nilConc [simp]: "s@@ nil = s"
84.465 +apply (induct s)
84.466 +apply simp
84.467 +apply simp
84.468 +apply simp
84.469 +apply simp
84.470 +done
84.471 +
84.472 +
84.473 +(* should be same as nil_is_Conc2 when all nils are turned to right side !! *)
84.474 +lemma nil_is_Conc: "(nil = x @@ y) = ((x::'a Seq)= nil & y = nil)"
84.475 +apply (rule_tac x="x" in Seq_cases)
84.476 +apply auto
84.477 +done
84.478 +
84.479 +lemma nil_is_Conc2: "(x @@ y = nil) = ((x::'a Seq)= nil & y = nil)"
84.480 +apply (rule_tac x="x" in Seq_cases)
84.481 +apply auto
84.482 +done
84.483 +
84.484 +
84.485 +(* ------------------------------------------------------------------------------------ *)
84.486 +
84.487 +subsection "Last"
84.488 +
84.489 +lemma Finite_Last1: "Finite s ==> s~=nil --> Last$s~=UU"
84.490 +apply (erule Seq_Finite_ind, simp_all)
84.491 +done
84.492 +
84.493 +lemma Finite_Last2: "Finite s ==> Last$s=UU --> s=nil"
84.494 +apply (erule Seq_Finite_ind, simp_all)
84.495 +apply fast
84.496 +done
84.497 +
84.498 +
84.499 +(* ------------------------------------------------------------------------------------ *)
84.500 +
84.501 +
84.502 +subsection "Filter, Conc"
84.503 +
84.504 +
84.505 +lemma FilterPQ: "Filter P$(Filter Q$s) = Filter (%x. P x & Q x)$s"
84.506 +apply (rule_tac x="s" in Seq_induct, simp_all)
84.507 +done
84.508 +
84.509 +lemma FilterConc: "Filter P$(x @@ y) = (Filter P$x @@ Filter P$y)"
84.510 +apply (simp add: Filter_def sfiltersconc)
84.511 +done
84.512 +
84.513 +(* ------------------------------------------------------------------------------------ *)
84.514 +
84.515 +subsection "Map"
84.516 +
84.517 +lemma MapMap: "Map f$(Map g$s) = Map (f o g)$s"
84.518 +apply (rule_tac x="s" in Seq_induct, simp_all)
84.519 +done
84.520 +
84.521 +lemma MapConc: "Map f$(x@@y) = (Map f$x) @@ (Map f$y)"
84.522 +apply (rule_tac x="x" in Seq_induct, simp_all)
84.523 +done
84.524 +
84.525 +lemma MapFilter: "Filter P$(Map f$x) = Map f$(Filter (P o f)$x)"
84.526 +apply (rule_tac x="x" in Seq_induct, simp_all)
84.527 +done
84.528 +
84.529 +lemma nilMap: "nil = (Map f$s) --> s= nil"
84.530 +apply (rule_tac x="s" in Seq_cases, simp_all)
84.531 +done
84.532 +
84.533 +
84.534 +lemma ForallMap: "Forall P (Map f$s) = Forall (P o f) s"
84.535 +apply (rule_tac x="s" in Seq_induct)
84.536 +apply (simp add: Forall_def sforall_def)
84.537 +apply simp_all
84.538 +done
84.539 +
84.540 +
84.541 +
84.542 +
84.543 +(* ------------------------------------------------------------------------------------ *)
84.544 +
84.545 +subsection "Forall"
84.546 +
84.547 +
84.548 +lemma ForallPForallQ1: "Forall P ys & (! x. P x --> Q x)
84.549 + --> Forall Q ys"
84.550 +apply (rule_tac x="ys" in Seq_induct)
84.551 +apply (simp add: Forall_def sforall_def)
84.552 +apply simp_all
84.553 +done
84.554 +
84.555 +lemmas ForallPForallQ =
84.556 + ForallPForallQ1 [THEN mp, OF conjI, OF _ allI, OF _ impI]
84.557 +
84.558 +lemma Forall_Conc_impl: "(Forall P x & Forall P y) --> Forall P (x @@ y)"
84.559 +apply (rule_tac x="x" in Seq_induct)
84.560 +apply (simp add: Forall_def sforall_def)
84.561 +apply simp_all
84.562 +done
84.563 +
84.564 +lemma Forall_Conc [simp]:
84.565 + "Finite x ==> Forall P (x @@ y) = (Forall P x & Forall P y)"
84.566 +apply (erule Seq_Finite_ind, simp_all)
84.567 +done
84.568 +
84.569 +lemma ForallTL1: "Forall P s --> Forall P (TL$s)"
84.570 +apply (rule_tac x="s" in Seq_induct)
84.571 +apply (simp add: Forall_def sforall_def)
84.572 +apply simp_all
84.573 +done
84.574 +
84.575 +lemmas ForallTL = ForallTL1 [THEN mp]
84.576 +
84.577 +lemma ForallDropwhile1: "Forall P s --> Forall P (Dropwhile Q$s)"
84.578 +apply (rule_tac x="s" in Seq_induct)
84.579 +apply (simp add: Forall_def sforall_def)
84.580 +apply simp_all
84.581 +done
84.582 +
84.583 +lemmas ForallDropwhile = ForallDropwhile1 [THEN mp]
84.584 +
84.585 +
84.586 +(* only admissible in t, not if done in s *)
84.587 +
84.588 +lemma Forall_prefix: "! s. Forall P s --> t<<s --> Forall P t"
84.589 +apply (rule_tac x="t" in Seq_induct)
84.590 +apply (simp add: Forall_def sforall_def)
84.591 +apply simp_all
84.592 +apply (intro strip)
84.593 +apply (rule_tac x="sa" in Seq_cases)
84.594 +apply simp
84.595 +apply auto
84.596 +done
84.597 +
84.598 +lemmas Forall_prefixclosed = Forall_prefix [rule_format]
84.599 +
84.600 +lemma Forall_postfixclosed:
84.601 + "[| Finite h; Forall P s; s= h @@ t |] ==> Forall P t"
84.602 +apply auto
84.603 +done
84.604 +
84.605 +
84.606 +lemma ForallPFilterQR1:
84.607 + "((! x. P x --> (Q x = R x)) & Forall P tr) --> Filter Q$tr = Filter R$tr"
84.608 +apply (rule_tac x="tr" in Seq_induct)
84.609 +apply (simp add: Forall_def sforall_def)
84.610 +apply simp_all
84.611 +done
84.612 +
84.613 +lemmas ForallPFilterQR = ForallPFilterQR1 [THEN mp, OF conjI, OF allI]
84.614 +
84.615 +
84.616 +(* ------------------------------------------------------------------------------------- *)
84.617 +
84.618 +subsection "Forall, Filter"
84.619 +
84.620 +
84.621 +lemma ForallPFilterP: "Forall P (Filter P$x)"
84.622 +apply (simp add: Filter_def Forall_def forallPsfilterP)
84.623 +done
84.624 +
84.625 +(* holds also in other direction, then equal to forallPfilterP *)
84.626 +lemma ForallPFilterPid1: "Forall P x --> Filter P$x = x"
84.627 +apply (rule_tac x="x" in Seq_induct)
84.628 +apply (simp add: Forall_def sforall_def Filter_def)
84.629 +apply simp_all
84.630 +done
84.631 +
84.632 +lemmas ForallPFilterPid = ForallPFilterPid1 [THEN mp]
84.633 +
84.634 +
84.635 +(* holds also in other direction *)
84.636 +lemma ForallnPFilterPnil1: "!! ys . Finite ys ==>
84.637 + Forall (%x. ~P x) ys --> Filter P$ys = nil "
84.638 +apply (erule Seq_Finite_ind, simp_all)
84.639 +done
84.640 +
84.641 +lemmas ForallnPFilterPnil = ForallnPFilterPnil1 [THEN mp]
84.642 +
84.643 +
84.644 +(* holds also in other direction *)
84.645 +lemma ForallnPFilterPUU1: "~Finite ys & Forall (%x. ~P x) ys
84.646 + --> Filter P$ys = UU "
84.647 +apply (rule_tac x="ys" in Seq_induct)
84.648 +apply (simp add: Forall_def sforall_def)
84.649 +apply simp_all
84.650 +done
84.651 +
84.652 +lemmas ForallnPFilterPUU = ForallnPFilterPUU1 [THEN mp, OF conjI]
84.653 +
84.654 +
84.655 +(* inverse of ForallnPFilterPnil *)
84.656 +
84.657 +lemma FilternPnilForallP1: "!! ys . Filter P$ys = nil -->
84.658 + (Forall (%x. ~P x) ys & Finite ys)"
84.659 +apply (rule_tac x="ys" in Seq_induct)
84.660 +(* adm *)
84.661 +apply (simp add: Forall_def sforall_def)
84.662 +(* base cases *)
84.663 +apply simp
84.664 +apply simp
84.665 +(* main case *)
84.666 +apply simp
84.667 +done
84.668 +
84.669 +lemmas FilternPnilForallP = FilternPnilForallP1 [THEN mp]
84.670 +
84.671 +(* inverse of ForallnPFilterPUU. proved apply 2 lemmas because of adm problems *)
84.672 +
84.673 +lemma FilterUU_nFinite_lemma1: "Finite ys ==> Filter P$ys ~= UU"
84.674 +apply (erule Seq_Finite_ind, simp_all)
84.675 +done
84.676 +
84.677 +lemma FilterUU_nFinite_lemma2: "~ Forall (%x. ~P x) ys --> Filter P$ys ~= UU"
84.678 +apply (rule_tac x="ys" in Seq_induct)
84.679 +apply (simp add: Forall_def sforall_def)
84.680 +apply simp_all
84.681 +done
84.682 +
84.683 +lemma FilternPUUForallP:
84.684 + "Filter P$ys = UU ==> (Forall (%x. ~P x) ys & ~Finite ys)"
84.685 +apply (rule conjI)
84.686 +apply (cut_tac FilterUU_nFinite_lemma2 [THEN mp, COMP rev_contrapos])
84.687 +apply auto
84.688 +apply (blast dest!: FilterUU_nFinite_lemma1)
84.689 +done
84.690 +
84.691 +
84.692 +lemma ForallQFilterPnil:
84.693 + "!! Q P.[| Forall Q ys; Finite ys; !!x. Q x ==> ~P x|]
84.694 + ==> Filter P$ys = nil"
84.695 +apply (erule ForallnPFilterPnil)
84.696 +apply (erule ForallPForallQ)
84.697 +apply auto
84.698 +done
84.699 +
84.700 +lemma ForallQFilterPUU:
84.701 + "!! Q P. [| ~Finite ys; Forall Q ys; !!x. Q x ==> ~P x|]
84.702 + ==> Filter P$ys = UU "
84.703 +apply (erule ForallnPFilterPUU)
84.704 +apply (erule ForallPForallQ)
84.705 +apply auto
84.706 +done
84.707 +
84.708 +
84.709 +
84.710 +(* ------------------------------------------------------------------------------------- *)
84.711 +
84.712 +subsection "Takewhile, Forall, Filter"
84.713 +
84.714 +
84.715 +lemma ForallPTakewhileP [simp]: "Forall P (Takewhile P$x)"
84.716 +apply (simp add: Forall_def Takewhile_def sforallPstakewhileP)
84.717 +done
84.718 +
84.719 +
84.720 +lemma ForallPTakewhileQ [simp]:
84.721 +"!! P. [| !!x. Q x==> P x |] ==> Forall P (Takewhile Q$x)"
84.722 +apply (rule ForallPForallQ)
84.723 +apply (rule ForallPTakewhileP)
84.724 +apply auto
84.725 +done
84.726 +
84.727 +
84.728 +lemma FilterPTakewhileQnil [simp]:
84.729 + "!! Q P.[| Finite (Takewhile Q$ys); !!x. Q x ==> ~P x |]
84.730 + ==> Filter P$(Takewhile Q$ys) = nil"
84.731 +apply (erule ForallnPFilterPnil)
84.732 +apply (rule ForallPForallQ)
84.733 +apply (rule ForallPTakewhileP)
84.734 +apply auto
84.735 +done
84.736 +
84.737 +lemma FilterPTakewhileQid [simp]:
84.738 + "!! Q P. [| !!x. Q x ==> P x |] ==>
84.739 + Filter P$(Takewhile Q$ys) = (Takewhile Q$ys)"
84.740 +apply (rule ForallPFilterPid)
84.741 +apply (rule ForallPForallQ)
84.742 +apply (rule ForallPTakewhileP)
84.743 +apply auto
84.744 +done
84.745 +
84.746 +
84.747 +lemma Takewhile_idempotent: "Takewhile P$(Takewhile P$s) = Takewhile P$s"
84.748 +apply (rule_tac x="s" in Seq_induct)
84.749 +apply (simp add: Forall_def sforall_def)
84.750 +apply simp_all
84.751 +done
84.752 +
84.753 +lemma ForallPTakewhileQnP [simp]:
84.754 + "Forall P s --> Takewhile (%x. Q x | (~P x))$s = Takewhile Q$s"
84.755 +apply (rule_tac x="s" in Seq_induct)
84.756 +apply (simp add: Forall_def sforall_def)
84.757 +apply simp_all
84.758 +done
84.759 +
84.760 +lemma ForallPDropwhileQnP [simp]:
84.761 + "Forall P s --> Dropwhile (%x. Q x | (~P x))$s = Dropwhile Q$s"
84.762 +apply (rule_tac x="s" in Seq_induct)
84.763 +apply (simp add: Forall_def sforall_def)
84.764 +apply simp_all
84.765 +done
84.766 +
84.767 +
84.768 +lemma TakewhileConc1:
84.769 + "Forall P s --> Takewhile P$(s @@ t) = s @@ (Takewhile P$t)"
84.770 +apply (rule_tac x="s" in Seq_induct)
84.771 +apply (simp add: Forall_def sforall_def)
84.772 +apply simp_all
84.773 +done
84.774 +
84.775 +lemmas TakewhileConc = TakewhileConc1 [THEN mp]
84.776 +
84.777 +lemma DropwhileConc1:
84.778 + "Finite s ==> Forall P s --> Dropwhile P$(s @@ t) = Dropwhile P$t"
84.779 +apply (erule Seq_Finite_ind, simp_all)
84.780 +done
84.781 +
84.782 +lemmas DropwhileConc = DropwhileConc1 [THEN mp]
84.783 +
84.784 +
84.785 +
84.786 +(* ----------------------------------------------------------------------------------- *)
84.787 +
84.788 +subsection "coinductive characterizations of Filter"
84.789 +
84.790 +
84.791 +lemma divide_Seq_lemma:
84.792 + "HD$(Filter P$y) = Def x
84.793 + --> y = ((Takewhile (%x. ~P x)$y) @@ (x >> TL$(Dropwhile (%a.~P a)$y)))
84.794 + & Finite (Takewhile (%x. ~ P x)$y) & P x"
84.795 +
84.796 +(* FIX: pay attention: is only admissible with chain-finite package to be added to
84.797 + adm test and Finite f x admissibility *)
84.798 +apply (rule_tac x="y" in Seq_induct)
84.799 +apply (simp add: adm_subst [OF _ adm_Finite])
84.800 +apply simp
84.801 +apply simp
84.802 +apply (case_tac "P a")
84.803 + apply simp
84.804 + apply blast
84.805 +(* ~ P a *)
84.806 +apply simp
84.807 +done
84.808 +
84.809 +lemma divide_Seq: "(x>>xs) << Filter P$y
84.810 + ==> y = ((Takewhile (%a. ~ P a)$y) @@ (x >> TL$(Dropwhile (%a.~P a)$y)))
84.811 + & Finite (Takewhile (%a. ~ P a)$y) & P x"
84.812 +apply (rule divide_Seq_lemma [THEN mp])
84.813 +apply (drule_tac f="HD" and x="x>>xs" in monofun_cfun_arg)
84.814 +apply simp
84.815 +done
84.816 +
84.817 +
84.818 +lemma nForall_HDFilter:
84.819 + "~Forall P y --> (? x. HD$(Filter (%a. ~P a)$y) = Def x)"
84.820 +unfolding not_Undef_is_Def [symmetric]
84.821 +apply (induct y rule: Seq_induct)
84.822 +apply (simp add: Forall_def sforall_def)
84.823 +apply simp_all
84.824 +done
84.825 +
84.826 +
84.827 +lemma divide_Seq2: "~Forall P y
84.828 + ==> ? x. y= (Takewhile P$y @@ (x >> TL$(Dropwhile P$y))) &
84.829 + Finite (Takewhile P$y) & (~ P x)"
84.830 +apply (drule nForall_HDFilter [THEN mp])
84.831 +apply safe
84.832 +apply (rule_tac x="x" in exI)
84.833 +apply (cut_tac P1="%x. ~ P x" in divide_Seq_lemma [THEN mp])
84.834 +apply auto
84.835 +done
84.836 +
84.837 +
84.838 +lemma divide_Seq3: "~Forall P y
84.839 + ==> ? x bs rs. y= (bs @@ (x>>rs)) & Finite bs & Forall P bs & (~ P x)"
84.840 +apply (drule divide_Seq2)
84.841 +(*Auto_tac no longer proves it*)
84.842 +apply fastsimp
84.843 +done
84.844 +
84.845 +lemmas [simp] = FilterPQ FilterConc Conc_cong
84.846 +
84.847 +
84.848 +(* ------------------------------------------------------------------------------------- *)
84.849 +
84.850 +
84.851 +subsection "take_lemma"
84.852 +
84.853 +lemma seq_take_lemma: "(!n. seq_take n$x = seq_take n$x') = (x = x')"
84.854 +apply (rule iffI)
84.855 +apply (rule seq.take_lemma)
84.856 +apply auto
84.857 +done
84.858 +
84.859 +lemma take_reduction1:
84.860 +" ! n. ((! k. k < n --> seq_take k$y1 = seq_take k$y2)
84.861 + --> seq_take n$(x @@ (t>>y1)) = seq_take n$(x @@ (t>>y2)))"
84.862 +apply (rule_tac x="x" in Seq_induct)
84.863 +apply simp_all
84.864 +apply (intro strip)
84.865 +apply (case_tac "n")
84.866 +apply auto
84.867 +apply (case_tac "n")
84.868 +apply auto
84.869 +done
84.870 +
84.871 +
84.872 +lemma take_reduction:
84.873 + "!! n.[| x=y; s=t; !! k. k<n ==> seq_take k$y1 = seq_take k$y2|]
84.874 + ==> seq_take n$(x @@ (s>>y1)) = seq_take n$(y @@ (t>>y2))"
84.875 +apply (auto intro!: take_reduction1 [rule_format])
84.876 +done
84.877 +
84.878 +(* ------------------------------------------------------------------
84.879 + take-lemma and take_reduction for << instead of =
84.880 + ------------------------------------------------------------------ *)
84.881 +
84.882 +lemma take_reduction_less1:
84.883 +" ! n. ((! k. k < n --> seq_take k$y1 << seq_take k$y2)
84.884 + --> seq_take n$(x @@ (t>>y1)) << seq_take n$(x @@ (t>>y2)))"
84.885 +apply (rule_tac x="x" in Seq_induct)
84.886 +apply simp_all
84.887 +apply (intro strip)
84.888 +apply (case_tac "n")
84.889 +apply auto
84.890 +apply (case_tac "n")
84.891 +apply auto
84.892 +done
84.893 +
84.894 +
84.895 +lemma take_reduction_less:
84.896 + "!! n.[| x=y; s=t;!! k. k<n ==> seq_take k$y1 << seq_take k$y2|]
84.897 + ==> seq_take n$(x @@ (s>>y1)) << seq_take n$(y @@ (t>>y2))"
84.898 +apply (auto intro!: take_reduction_less1 [rule_format])
84.899 +done
84.900 +
84.901 +lemma take_lemma_less1:
84.902 + assumes "!! n. seq_take n$s1 << seq_take n$s2"
84.903 + shows "s1<<s2"
84.904 +apply (rule_tac t="s1" in seq.reach [THEN subst])
84.905 +apply (rule_tac t="s2" in seq.reach [THEN subst])
84.906 +apply (rule lub_mono)
84.907 +apply (rule seq.chain_take [THEN ch2ch_Rep_cfunL])
84.908 +apply (rule seq.chain_take [THEN ch2ch_Rep_cfunL])
84.909 +apply (rule assms)
84.910 +done
84.911 +
84.912 +
84.913 +lemma take_lemma_less: "(!n. seq_take n$x << seq_take n$x') = (x << x')"
84.914 +apply (rule iffI)
84.915 +apply (rule take_lemma_less1)
84.916 +apply auto
84.917 +apply (erule monofun_cfun_arg)
84.918 +done
84.919 +
84.920 +(* ------------------------------------------------------------------
84.921 + take-lemma proof principles
84.922 + ------------------------------------------------------------------ *)
84.923 +
84.924 +lemma take_lemma_principle1:
84.925 + "!! Q. [|!! s. [| Forall Q s; A s |] ==> (f s) = (g s) ;
84.926 + !! s1 s2 y. [| Forall Q s1; Finite s1; ~ Q y; A (s1 @@ y>>s2)|]
84.927 + ==> (f (s1 @@ y>>s2)) = (g (s1 @@ y>>s2)) |]
84.928 + ==> A x --> (f x)=(g x)"
84.929 +apply (case_tac "Forall Q x")
84.930 +apply (auto dest!: divide_Seq3)
84.931 +done
84.932 +
84.933 +lemma take_lemma_principle2:
84.934 + "!! Q. [|!! s. [| Forall Q s; A s |] ==> (f s) = (g s) ;
84.935 + !! s1 s2 y. [| Forall Q s1; Finite s1; ~ Q y; A (s1 @@ y>>s2)|]
84.936 + ==> ! n. seq_take n$(f (s1 @@ y>>s2))
84.937 + = seq_take n$(g (s1 @@ y>>s2)) |]
84.938 + ==> A x --> (f x)=(g x)"
84.939 +apply (case_tac "Forall Q x")
84.940 +apply (auto dest!: divide_Seq3)
84.941 +apply (rule seq.take_lemma)
84.942 +apply auto
84.943 +done
84.944 +
84.945 +
84.946 +(* Note: in the following proofs the ordering of proof steps is very
84.947 + important, as otherwise either (Forall Q s1) would be in the IH as
84.948 + assumption (then rule useless) or it is not possible to strengthen
84.949 + the IH apply doing a forall closure of the sequence t (then rule also useless).
84.950 + This is also the reason why the induction rule (nat_less_induct or nat_induct) has to
84.951 + to be imbuilt into the rule, as induction has to be done early and the take lemma
84.952 + has to be used in the trivial direction afterwards for the (Forall Q x) case. *)
84.953 +
84.954 +lemma take_lemma_induct:
84.955 +"!! Q. [|!! s. [| Forall Q s; A s |] ==> (f s) = (g s) ;
84.956 + !! s1 s2 y n. [| ! t. A t --> seq_take n$(f t) = seq_take n$(g t);
84.957 + Forall Q s1; Finite s1; ~ Q y; A (s1 @@ y>>s2) |]
84.958 + ==> seq_take (Suc n)$(f (s1 @@ y>>s2))
84.959 + = seq_take (Suc n)$(g (s1 @@ y>>s2)) |]
84.960 + ==> A x --> (f x)=(g x)"
84.961 +apply (rule impI)
84.962 +apply (rule seq.take_lemma)
84.963 +apply (rule mp)
84.964 +prefer 2 apply assumption
84.965 +apply (rule_tac x="x" in spec)
84.966 +apply (rule nat.induct)
84.967 +apply simp
84.968 +apply (rule allI)
84.969 +apply (case_tac "Forall Q xa")
84.970 +apply (force intro!: seq_take_lemma [THEN iffD2, THEN spec])
84.971 +apply (auto dest!: divide_Seq3)
84.972 +done
84.973 +
84.974 +
84.975 +lemma take_lemma_less_induct:
84.976 +"!! Q. [|!! s. [| Forall Q s; A s |] ==> (f s) = (g s) ;
84.977 + !! s1 s2 y n. [| ! t m. m < n --> A t --> seq_take m$(f t) = seq_take m$(g t);
84.978 + Forall Q s1; Finite s1; ~ Q y; A (s1 @@ y>>s2) |]
84.979 + ==> seq_take n$(f (s1 @@ y>>s2))
84.980 + = seq_take n$(g (s1 @@ y>>s2)) |]
84.981 + ==> A x --> (f x)=(g x)"
84.982 +apply (rule impI)
84.983 +apply (rule seq.take_lemma)
84.984 +apply (rule mp)
84.985 +prefer 2 apply assumption
84.986 +apply (rule_tac x="x" in spec)
84.987 +apply (rule nat_less_induct)
84.988 +apply (rule allI)
84.989 +apply (case_tac "Forall Q xa")
84.990 +apply (force intro!: seq_take_lemma [THEN iffD2, THEN spec])
84.991 +apply (auto dest!: divide_Seq3)
84.992 +done
84.993 +
84.994 +
84.995 +
84.996 +lemma take_lemma_in_eq_out:
84.997 +"!! Q. [| A UU ==> (f UU) = (g UU) ;
84.998 + A nil ==> (f nil) = (g nil) ;
84.999 + !! s y n. [| ! t. A t --> seq_take n$(f t) = seq_take n$(g t);
84.1000 + A (y>>s) |]
84.1001 + ==> seq_take (Suc n)$(f (y>>s))
84.1002 + = seq_take (Suc n)$(g (y>>s)) |]
84.1003 + ==> A x --> (f x)=(g x)"
84.1004 +apply (rule impI)
84.1005 +apply (rule seq.take_lemma)
84.1006 +apply (rule mp)
84.1007 +prefer 2 apply assumption
84.1008 +apply (rule_tac x="x" in spec)
84.1009 +apply (rule nat.induct)
84.1010 +apply simp
84.1011 +apply (rule allI)
84.1012 +apply (rule_tac x="xa" in Seq_cases)
84.1013 +apply simp_all
84.1014 +done
84.1015 +
84.1016 +
84.1017 +(* ------------------------------------------------------------------------------------ *)
84.1018 +
84.1019 +subsection "alternative take_lemma proofs"
84.1020 +
84.1021 +
84.1022 +(* --------------------------------------------------------------- *)
84.1023 +(* Alternative Proof of FilterPQ *)
84.1024 +(* --------------------------------------------------------------- *)
84.1025 +
84.1026 +declare FilterPQ [simp del]
84.1027 +
84.1028 +
84.1029 +(* In general: How to do this case without the same adm problems
84.1030 + as for the entire proof ? *)
84.1031 +lemma Filter_lemma1: "Forall (%x.~(P x & Q x)) s
84.1032 + --> Filter P$(Filter Q$s) =
84.1033 + Filter (%x. P x & Q x)$s"
84.1034 +
84.1035 +apply (rule_tac x="s" in Seq_induct)
84.1036 +apply (simp add: Forall_def sforall_def)
84.1037 +apply simp_all
84.1038 +done
84.1039 +
84.1040 +lemma Filter_lemma2: "Finite s ==>
84.1041 + (Forall (%x. (~P x) | (~ Q x)) s
84.1042 + --> Filter P$(Filter Q$s) = nil)"
84.1043 +apply (erule Seq_Finite_ind, simp_all)
84.1044 +done
84.1045 +
84.1046 +lemma Filter_lemma3: "Finite s ==>
84.1047 + Forall (%x. (~P x) | (~ Q x)) s
84.1048 + --> Filter (%x. P x & Q x)$s = nil"
84.1049 +apply (erule Seq_Finite_ind, simp_all)
84.1050 +done
84.1051 +
84.1052 +
84.1053 +lemma FilterPQ_takelemma: "Filter P$(Filter Q$s) = Filter (%x. P x & Q x)$s"
84.1054 +apply (rule_tac A1="%x. True" and
84.1055 + Q1="%x.~(P x & Q x)" and x1="s" in
84.1056 + take_lemma_induct [THEN mp])
84.1057 +(* better support for A = %x. True *)
84.1058 +apply (simp add: Filter_lemma1)
84.1059 +apply (simp add: Filter_lemma2 Filter_lemma3)
84.1060 +apply simp
84.1061 +done
84.1062 +
84.1063 +declare FilterPQ [simp]
84.1064 +
84.1065 +
84.1066 +(* --------------------------------------------------------------- *)
84.1067 +(* Alternative Proof of MapConc *)
84.1068 +(* --------------------------------------------------------------- *)
84.1069 +
84.1070 +
84.1071 +
84.1072 +lemma MapConc_takelemma: "Map f$(x@@y) = (Map f$x) @@ (Map f$y)"
84.1073 +apply (rule_tac A1="%x. True" and x1="x" in
84.1074 + take_lemma_in_eq_out [THEN mp])
84.1075 +apply auto
84.1076 +done
84.1077 +
84.1078 +
84.1079 +ML {*
84.1080 +
84.1081 +fun Seq_case_tac ctxt s i =
84.1082 + res_inst_tac ctxt [(("x", 0), s)] @{thm Seq_cases} i
84.1083 + THEN hyp_subst_tac i THEN hyp_subst_tac (i+1) THEN hyp_subst_tac (i+2);
84.1084 +
84.1085 +(* on a>>s only simp_tac, as full_simp_tac is uncomplete and often causes errors *)
84.1086 +fun Seq_case_simp_tac ctxt s i =
84.1087 + let val ss = simpset_of ctxt in
84.1088 + Seq_case_tac ctxt s i
84.1089 + THEN asm_simp_tac ss (i+2)
84.1090 + THEN asm_full_simp_tac ss (i+1)
84.1091 + THEN asm_full_simp_tac ss i
84.1092 + end;
84.1093 +
84.1094 +(* rws are definitions to be unfolded for admissibility check *)
84.1095 +fun Seq_induct_tac ctxt s rws i =
84.1096 + let val ss = simpset_of ctxt in
84.1097 + res_inst_tac ctxt [(("x", 0), s)] @{thm Seq_induct} i
84.1098 + THEN (REPEAT_DETERM (CHANGED (asm_simp_tac ss (i+1))))
84.1099 + THEN simp_tac (ss addsimps rws) i
84.1100 + end;
84.1101 +
84.1102 +fun Seq_Finite_induct_tac ctxt i =
84.1103 + etac @{thm Seq_Finite_ind} i
84.1104 + THEN (REPEAT_DETERM (CHANGED (asm_simp_tac (simpset_of ctxt) i)));
84.1105 +
84.1106 +fun pair_tac ctxt s =
84.1107 + res_inst_tac ctxt [(("p", 0), s)] @{thm PairE}
84.1108 + THEN' hyp_subst_tac THEN' asm_full_simp_tac (simpset_of ctxt);
84.1109 +
84.1110 +(* induction on a sequence of pairs with pairsplitting and simplification *)
84.1111 +fun pair_induct_tac ctxt s rws i =
84.1112 + let val ss = simpset_of ctxt in
84.1113 + res_inst_tac ctxt [(("x", 0), s)] @{thm Seq_induct} i
84.1114 + THEN pair_tac ctxt "a" (i+3)
84.1115 + THEN (REPEAT_DETERM (CHANGED (simp_tac ss (i+1))))
84.1116 + THEN simp_tac (ss addsimps rws) i
84.1117 + end;
84.1118 +
84.1119 +*}
84.1120 +
84.1121 +end
85.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
85.2 +++ b/src/HOL/HOLCF/IOA/meta_theory/ShortExecutions.thy Sat Nov 27 16:08:10 2010 -0800
85.3 @@ -0,0 +1,278 @@
85.4 +(* Title: HOLCF/IOA/meta_theory/ShortExecutions.thy
85.5 + Author: Olaf Müller
85.6 +*)
85.7 +
85.8 +theory ShortExecutions
85.9 +imports Traces
85.10 +begin
85.11 +
85.12 +text {*
85.13 + Some properties about @{text "Cut ex"}, defined as follows:
85.14 +
85.15 + For every execution ex there is another shorter execution @{text "Cut ex"}
85.16 + that has the same trace as ex, but its schedule ends with an external action.
85.17 +*}
85.18 +
85.19 +definition
85.20 + oraclebuild :: "('a => bool) => 'a Seq -> 'a Seq -> 'a Seq" where
85.21 + "oraclebuild P = (fix$(LAM h s t. case t of
85.22 + nil => nil
85.23 + | x##xs =>
85.24 + (case x of
85.25 + UU => UU
85.26 + | Def y => (Takewhile (%x.~P x)$s)
85.27 + @@ (y>>(h$(TL$(Dropwhile (%x.~ P x)$s))$xs))
85.28 + )
85.29 + ))"
85.30 +
85.31 +definition
85.32 + Cut :: "('a => bool) => 'a Seq => 'a Seq" where
85.33 + "Cut P s = oraclebuild P$s$(Filter P$s)"
85.34 +
85.35 +definition
85.36 + LastActExtsch :: "('a,'s)ioa => 'a Seq => bool" where
85.37 + "LastActExtsch A sch = (Cut (%x. x: ext A) sch = sch)"
85.38 +
85.39 +(* LastActExtex ::"('a,'s)ioa => ('a,'s) pairs => bool"*)
85.40 +(* LastActExtex_def:
85.41 + "LastActExtex A ex == LastActExtsch A (filter_act$ex)" *)
85.42 +
85.43 +axiomatization where
85.44 + Cut_prefixcl_Finite: "Finite s ==> (? y. s = Cut P s @@ y)"
85.45 +
85.46 +axiomatization where
85.47 + LastActExtsmall1: "LastActExtsch A sch ==> LastActExtsch A (TL$(Dropwhile P$sch))"
85.48 +
85.49 +axiomatization where
85.50 + LastActExtsmall2: "[| Finite sch1; LastActExtsch A (sch1 @@ sch2) |] ==> LastActExtsch A sch2"
85.51 +
85.52 +
85.53 +ML {*
85.54 +fun thin_tac' j =
85.55 + rotate_tac (j - 1) THEN'
85.56 + etac thin_rl THEN'
85.57 + rotate_tac (~ (j - 1))
85.58 +*}
85.59 +
85.60 +
85.61 +subsection "oraclebuild rewrite rules"
85.62 +
85.63 +
85.64 +lemma oraclebuild_unfold:
85.65 +"oraclebuild P = (LAM s t. case t of
85.66 + nil => nil
85.67 + | x##xs =>
85.68 + (case x of
85.69 + UU => UU
85.70 + | Def y => (Takewhile (%a.~ P a)$s)
85.71 + @@ (y>>(oraclebuild P$(TL$(Dropwhile (%a.~ P a)$s))$xs))
85.72 + )
85.73 + )"
85.74 +apply (rule trans)
85.75 +apply (rule fix_eq2)
85.76 +apply (simp only: oraclebuild_def)
85.77 +apply (rule beta_cfun)
85.78 +apply simp
85.79 +done
85.80 +
85.81 +lemma oraclebuild_UU: "oraclebuild P$sch$UU = UU"
85.82 +apply (subst oraclebuild_unfold)
85.83 +apply simp
85.84 +done
85.85 +
85.86 +lemma oraclebuild_nil: "oraclebuild P$sch$nil = nil"
85.87 +apply (subst oraclebuild_unfold)
85.88 +apply simp
85.89 +done
85.90 +
85.91 +lemma oraclebuild_cons: "oraclebuild P$s$(x>>t) =
85.92 + (Takewhile (%a.~ P a)$s)
85.93 + @@ (x>>(oraclebuild P$(TL$(Dropwhile (%a.~ P a)$s))$t))"
85.94 +apply (rule trans)
85.95 +apply (subst oraclebuild_unfold)
85.96 +apply (simp add: Consq_def)
85.97 +apply (simp add: Consq_def)
85.98 +done
85.99 +
85.100 +
85.101 +subsection "Cut rewrite rules"
85.102 +
85.103 +lemma Cut_nil:
85.104 +"[| Forall (%a.~ P a) s; Finite s|]
85.105 + ==> Cut P s =nil"
85.106 +apply (unfold Cut_def)
85.107 +apply (subgoal_tac "Filter P$s = nil")
85.108 +apply (simp (no_asm_simp) add: oraclebuild_nil)
85.109 +apply (rule ForallQFilterPnil)
85.110 +apply assumption+
85.111 +done
85.112 +
85.113 +lemma Cut_UU:
85.114 +"[| Forall (%a.~ P a) s; ~Finite s|]
85.115 + ==> Cut P s =UU"
85.116 +apply (unfold Cut_def)
85.117 +apply (subgoal_tac "Filter P$s= UU")
85.118 +apply (simp (no_asm_simp) add: oraclebuild_UU)
85.119 +apply (rule ForallQFilterPUU)
85.120 +apply assumption+
85.121 +done
85.122 +
85.123 +lemma Cut_Cons:
85.124 +"[| P t; Forall (%x.~ P x) ss; Finite ss|]
85.125 + ==> Cut P (ss @@ (t>> rs))
85.126 + = ss @@ (t >> Cut P rs)"
85.127 +apply (unfold Cut_def)
85.128 +apply (simp add: ForallQFilterPnil oraclebuild_cons TakewhileConc DropwhileConc)
85.129 +done
85.130 +
85.131 +
85.132 +subsection "Cut lemmas for main theorem"
85.133 +
85.134 +lemma FilterCut: "Filter P$s = Filter P$(Cut P s)"
85.135 +apply (rule_tac A1 = "%x. True" and Q1 = "%x.~ P x" and x1 = "s" in take_lemma_induct [THEN mp])
85.136 +prefer 3 apply (fast)
85.137 +apply (case_tac "Finite s")
85.138 +apply (simp add: Cut_nil ForallQFilterPnil)
85.139 +apply (simp add: Cut_UU ForallQFilterPUU)
85.140 +(* main case *)
85.141 +apply (simp add: Cut_Cons ForallQFilterPnil)
85.142 +done
85.143 +
85.144 +
85.145 +lemma Cut_idemp: "Cut P (Cut P s) = (Cut P s)"
85.146 +apply (rule_tac A1 = "%x. True" and Q1 = "%x.~ P x" and x1 = "s" in
85.147 + take_lemma_less_induct [THEN mp])
85.148 +prefer 3 apply (fast)
85.149 +apply (case_tac "Finite s")
85.150 +apply (simp add: Cut_nil ForallQFilterPnil)
85.151 +apply (simp add: Cut_UU ForallQFilterPUU)
85.152 +(* main case *)
85.153 +apply (simp add: Cut_Cons ForallQFilterPnil)
85.154 +apply (rule take_reduction)
85.155 +apply auto
85.156 +done
85.157 +
85.158 +
85.159 +lemma MapCut: "Map f$(Cut (P o f) s) = Cut P (Map f$s)"
85.160 +apply (rule_tac A1 = "%x. True" and Q1 = "%x.~ P (f x) " and x1 = "s" in
85.161 + take_lemma_less_induct [THEN mp])
85.162 +prefer 3 apply (fast)
85.163 +apply (case_tac "Finite s")
85.164 +apply (simp add: Cut_nil)
85.165 +apply (rule Cut_nil [symmetric])
85.166 +apply (simp add: ForallMap o_def)
85.167 +apply (simp add: Map2Finite)
85.168 +(* csae ~ Finite s *)
85.169 +apply (simp add: Cut_UU)
85.170 +apply (rule Cut_UU)
85.171 +apply (simp add: ForallMap o_def)
85.172 +apply (simp add: Map2Finite)
85.173 +(* main case *)
85.174 +apply (simp add: Cut_Cons MapConc ForallMap FiniteMap1 o_def)
85.175 +apply (rule take_reduction)
85.176 +apply auto
85.177 +done
85.178 +
85.179 +
85.180 +lemma Cut_prefixcl_nFinite [rule_format (no_asm)]: "~Finite s --> Cut P s << s"
85.181 +apply (intro strip)
85.182 +apply (rule take_lemma_less [THEN iffD1])
85.183 +apply (intro strip)
85.184 +apply (rule mp)
85.185 +prefer 2 apply (assumption)
85.186 +apply (tactic "thin_tac' 1 1")
85.187 +apply (rule_tac x = "s" in spec)
85.188 +apply (rule nat_less_induct)
85.189 +apply (intro strip)
85.190 +apply (rename_tac na n s)
85.191 +apply (case_tac "Forall (%x. ~ P x) s")
85.192 +apply (rule take_lemma_less [THEN iffD2, THEN spec])
85.193 +apply (simp add: Cut_UU)
85.194 +(* main case *)
85.195 +apply (drule divide_Seq3)
85.196 +apply (erule exE)+
85.197 +apply (erule conjE)+
85.198 +apply hypsubst
85.199 +apply (simp add: Cut_Cons)
85.200 +apply (rule take_reduction_less)
85.201 +(* auto makes also reasoning about Finiteness of parts of s ! *)
85.202 +apply auto
85.203 +done
85.204 +
85.205 +
85.206 +lemma execThruCut: "!!ex .is_exec_frag A (s,ex) ==> is_exec_frag A (s,Cut P ex)"
85.207 +apply (case_tac "Finite ex")
85.208 +apply (cut_tac s = "ex" and P = "P" in Cut_prefixcl_Finite)
85.209 +apply assumption
85.210 +apply (erule exE)
85.211 +apply (rule exec_prefix2closed)
85.212 +apply (erule_tac s = "ex" and t = "Cut P ex @@ y" in subst)
85.213 +apply assumption
85.214 +apply (erule exec_prefixclosed)
85.215 +apply (erule Cut_prefixcl_nFinite)
85.216 +done
85.217 +
85.218 +
85.219 +subsection "Main Cut Theorem"
85.220 +
85.221 +lemma exists_LastActExtsch:
85.222 + "[|sch : schedules A ; tr = Filter (%a. a:ext A)$sch|]
85.223 + ==> ? sch. sch : schedules A &
85.224 + tr = Filter (%a. a:ext A)$sch &
85.225 + LastActExtsch A sch"
85.226 +
85.227 +apply (unfold schedules_def has_schedule_def)
85.228 +apply auto
85.229 +apply (rule_tac x = "filter_act$ (Cut (%a. fst a:ext A) (snd ex))" in exI)
85.230 +apply (simp add: executions_def)
85.231 +apply (tactic {* pair_tac @{context} "ex" 1 *})
85.232 +apply auto
85.233 +apply (rule_tac x = " (x,Cut (%a. fst a:ext A) y) " in exI)
85.234 +apply (simp (no_asm_simp))
85.235 +
85.236 +(* Subgoal 1: Lemma: propagation of execution through Cut *)
85.237 +
85.238 +apply (simp add: execThruCut)
85.239 +
85.240 +(* Subgoal 2: Lemma: Filter P s = Filter P (Cut P s) *)
85.241 +
85.242 +apply (simp (no_asm) add: filter_act_def)
85.243 +apply (subgoal_tac "Map fst$ (Cut (%a. fst a: ext A) y) = Cut (%a. a:ext A) (Map fst$y) ")
85.244 +
85.245 +apply (rule_tac [2] MapCut [unfolded o_def])
85.246 +apply (simp add: FilterCut [symmetric])
85.247 +
85.248 +(* Subgoal 3: Lemma: Cut idempotent *)
85.249 +
85.250 +apply (simp (no_asm) add: LastActExtsch_def filter_act_def)
85.251 +apply (subgoal_tac "Map fst$ (Cut (%a. fst a: ext A) y) = Cut (%a. a:ext A) (Map fst$y) ")
85.252 +apply (rule_tac [2] MapCut [unfolded o_def])
85.253 +apply (simp add: Cut_idemp)
85.254 +done
85.255 +
85.256 +
85.257 +subsection "Further Cut lemmas"
85.258 +
85.259 +lemma LastActExtimplnil:
85.260 + "[| LastActExtsch A sch; Filter (%x. x:ext A)$sch = nil |]
85.261 + ==> sch=nil"
85.262 +apply (unfold LastActExtsch_def)
85.263 +apply (drule FilternPnilForallP)
85.264 +apply (erule conjE)
85.265 +apply (drule Cut_nil)
85.266 +apply assumption
85.267 +apply simp
85.268 +done
85.269 +
85.270 +lemma LastActExtimplUU:
85.271 + "[| LastActExtsch A sch; Filter (%x. x:ext A)$sch = UU |]
85.272 + ==> sch=UU"
85.273 +apply (unfold LastActExtsch_def)
85.274 +apply (drule FilternPUUForallP)
85.275 +apply (erule conjE)
85.276 +apply (drule Cut_UU)
85.277 +apply assumption
85.278 +apply simp
85.279 +done
85.280 +
85.281 +end
86.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
86.2 +++ b/src/HOL/HOLCF/IOA/meta_theory/SimCorrectness.thy Sat Nov 27 16:08:10 2010 -0800
86.3 @@ -0,0 +1,292 @@
86.4 +(* Title: HOLCF/IOA/meta_theory/SimCorrectness.thy
86.5 + Author: Olaf Müller
86.6 +*)
86.7 +
86.8 +header {* Correctness of Simulations in HOLCF/IOA *}
86.9 +
86.10 +theory SimCorrectness
86.11 +imports Simulations
86.12 +begin
86.13 +
86.14 +definition
86.15 + (* Note: s2 instead of s1 in last argument type !! *)
86.16 + corresp_ex_simC :: "('a,'s2)ioa => (('s1 * 's2)set) => ('a,'s1)pairs
86.17 + -> ('s2 => ('a,'s2)pairs)" where
86.18 + "corresp_ex_simC A R = (fix$(LAM h ex. (%s. case ex of
86.19 + nil => nil
86.20 + | x##xs => (flift1 (%pr. let a = (fst pr); t = (snd pr);
86.21 + T' = @t'. ? ex1. (t,t'):R & move A ex1 s a t'
86.22 + in
86.23 + (@cex. move A cex s a T')
86.24 + @@ ((h$xs) T'))
86.25 + $x) )))"
86.26 +
86.27 +definition
86.28 + corresp_ex_sim :: "('a,'s2)ioa => (('s1 *'s2)set) =>
86.29 + ('a,'s1)execution => ('a,'s2)execution" where
86.30 + "corresp_ex_sim A R ex == let S'= (@s'.(fst ex,s'):R & s': starts_of A)
86.31 + in
86.32 + (S',(corresp_ex_simC A R$(snd ex)) S')"
86.33 +
86.34 +
86.35 +subsection "corresp_ex_sim"
86.36 +
86.37 +lemma corresp_ex_simC_unfold: "corresp_ex_simC A R = (LAM ex. (%s. case ex of
86.38 + nil => nil
86.39 + | x##xs => (flift1 (%pr. let a = (fst pr); t = (snd pr);
86.40 + T' = @t'. ? ex1. (t,t'):R & move A ex1 s a t'
86.41 + in
86.42 + (@cex. move A cex s a T')
86.43 + @@ ((corresp_ex_simC A R $xs) T'))
86.44 + $x) ))"
86.45 +apply (rule trans)
86.46 +apply (rule fix_eq2)
86.47 +apply (simp only: corresp_ex_simC_def)
86.48 +apply (rule beta_cfun)
86.49 +apply (simp add: flift1_def)
86.50 +done
86.51 +
86.52 +lemma corresp_ex_simC_UU: "(corresp_ex_simC A R$UU) s=UU"
86.53 +apply (subst corresp_ex_simC_unfold)
86.54 +apply simp
86.55 +done
86.56 +
86.57 +lemma corresp_ex_simC_nil: "(corresp_ex_simC A R$nil) s = nil"
86.58 +apply (subst corresp_ex_simC_unfold)
86.59 +apply simp
86.60 +done
86.61 +
86.62 +lemma corresp_ex_simC_cons: "(corresp_ex_simC A R$((a,t)>>xs)) s =
86.63 + (let T' = @t'. ? ex1. (t,t'):R & move A ex1 s a t'
86.64 + in
86.65 + (@cex. move A cex s a T')
86.66 + @@ ((corresp_ex_simC A R$xs) T'))"
86.67 +apply (rule trans)
86.68 +apply (subst corresp_ex_simC_unfold)
86.69 +apply (simp add: Consq_def flift1_def)
86.70 +apply simp
86.71 +done
86.72 +
86.73 +
86.74 +declare corresp_ex_simC_UU [simp] corresp_ex_simC_nil [simp] corresp_ex_simC_cons [simp]
86.75 +
86.76 +
86.77 +subsection "properties of move"
86.78 +
86.79 +declare Let_def [simp del]
86.80 +
86.81 +lemma move_is_move_sim:
86.82 + "[|is_simulation R C A; reachable C s; s -a--C-> t; (s,s'):R|] ==>
86.83 + let T' = @t'. ? ex1. (t,t'):R & move A ex1 s' a t' in
86.84 + (t,T'): R & move A (@ex2. move A ex2 s' a T') s' a T'"
86.85 +apply (unfold is_simulation_def)
86.86 +
86.87 +(* Does not perform conditional rewriting on assumptions automatically as
86.88 + usual. Instantiate all variables per hand. Ask Tobias?? *)
86.89 +apply (subgoal_tac "? t' ex. (t,t') :R & move A ex s' a t'")
86.90 +prefer 2
86.91 +apply simp
86.92 +apply (erule conjE)
86.93 +apply (erule_tac x = "s" in allE)
86.94 +apply (erule_tac x = "s'" in allE)
86.95 +apply (erule_tac x = "t" in allE)
86.96 +apply (erule_tac x = "a" in allE)
86.97 +apply simp
86.98 +(* Go on as usual *)
86.99 +apply (erule exE)
86.100 +apply (drule_tac x = "t'" and P = "%t'. ? ex. (t,t') :R & move A ex s' a t'" in someI)
86.101 +apply (erule exE)
86.102 +apply (erule conjE)
86.103 +apply (simp add: Let_def)
86.104 +apply (rule_tac x = "ex" in someI)
86.105 +apply (erule conjE)
86.106 +apply assumption
86.107 +done
86.108 +
86.109 +declare Let_def [simp]
86.110 +
86.111 +lemma move_subprop1_sim:
86.112 + "[|is_simulation R C A; reachable C s; s-a--C-> t; (s,s'):R|] ==>
86.113 + let T' = @t'. ? ex1. (t,t'):R & move A ex1 s' a t' in
86.114 + is_exec_frag A (s',@x. move A x s' a T')"
86.115 +apply (cut_tac move_is_move_sim)
86.116 +defer
86.117 +apply assumption+
86.118 +apply (simp add: move_def)
86.119 +done
86.120 +
86.121 +lemma move_subprop2_sim:
86.122 + "[|is_simulation R C A; reachable C s; s-a--C-> t; (s,s'):R|] ==>
86.123 + let T' = @t'. ? ex1. (t,t'):R & move A ex1 s' a t' in
86.124 + Finite (@x. move A x s' a T')"
86.125 +apply (cut_tac move_is_move_sim)
86.126 +defer
86.127 +apply assumption+
86.128 +apply (simp add: move_def)
86.129 +done
86.130 +
86.131 +lemma move_subprop3_sim:
86.132 + "[|is_simulation R C A; reachable C s; s-a--C-> t; (s,s'):R|] ==>
86.133 + let T' = @t'. ? ex1. (t,t'):R & move A ex1 s' a t' in
86.134 + laststate (s',@x. move A x s' a T') = T'"
86.135 +apply (cut_tac move_is_move_sim)
86.136 +defer
86.137 +apply assumption+
86.138 +apply (simp add: move_def)
86.139 +done
86.140 +
86.141 +lemma move_subprop4_sim:
86.142 + "[|is_simulation R C A; reachable C s; s-a--C-> t; (s,s'):R|] ==>
86.143 + let T' = @t'. ? ex1. (t,t'):R & move A ex1 s' a t' in
86.144 + mk_trace A$((@x. move A x s' a T')) =
86.145 + (if a:ext A then a>>nil else nil)"
86.146 +apply (cut_tac move_is_move_sim)
86.147 +defer
86.148 +apply assumption+
86.149 +apply (simp add: move_def)
86.150 +done
86.151 +
86.152 +lemma move_subprop5_sim:
86.153 + "[|is_simulation R C A; reachable C s; s-a--C-> t; (s,s'):R|] ==>
86.154 + let T' = @t'. ? ex1. (t,t'):R & move A ex1 s' a t' in
86.155 + (t,T'):R"
86.156 +apply (cut_tac move_is_move_sim)
86.157 +defer
86.158 +apply assumption+
86.159 +apply (simp add: move_def)
86.160 +done
86.161 +
86.162 +
86.163 +subsection {* TRACE INCLUSION Part 1: Traces coincide *}
86.164 +
86.165 +subsubsection "Lemmata for <=="
86.166 +
86.167 +(* ------------------------------------------------------
86.168 + Lemma 1 :Traces coincide
86.169 + ------------------------------------------------------- *)
86.170 +
86.171 +declare split_if [split del]
86.172 +lemma traces_coincide_sim [rule_format (no_asm)]:
86.173 + "[|is_simulation R C A; ext C = ext A|] ==>
86.174 + !s s'. reachable C s & is_exec_frag C (s,ex) & (s,s'): R -->
86.175 + mk_trace C$ex = mk_trace A$((corresp_ex_simC A R$ex) s')"
86.176 +
86.177 +apply (tactic {* pair_induct_tac @{context} "ex" [@{thm is_exec_frag_def}] 1 *})
86.178 +(* cons case *)
86.179 +apply auto
86.180 +apply (rename_tac ex a t s s')
86.181 +apply (simp add: mk_traceConc)
86.182 +apply (frule reachable.reachable_n)
86.183 +apply assumption
86.184 +apply (erule_tac x = "t" in allE)
86.185 +apply (erule_tac x = "@t'. ? ex1. (t,t') :R & move A ex1 s' a t'" in allE)
86.186 +apply (simp add: move_subprop5_sim [unfolded Let_def]
86.187 + move_subprop4_sim [unfolded Let_def] split add: split_if)
86.188 +done
86.189 +declare split_if [split]
86.190 +
86.191 +
86.192 +(* ----------------------------------------------------------- *)
86.193 +(* Lemma 2 : corresp_ex_sim is execution *)
86.194 +(* ----------------------------------------------------------- *)
86.195 +
86.196 +
86.197 +lemma correspsim_is_execution [rule_format (no_asm)]:
86.198 + "[| is_simulation R C A |] ==>
86.199 + !s s'. reachable C s & is_exec_frag C (s,ex) & (s,s'):R
86.200 + --> is_exec_frag A (s',(corresp_ex_simC A R$ex) s')"
86.201 +
86.202 +apply (tactic {* pair_induct_tac @{context} "ex" [@{thm is_exec_frag_def}] 1 *})
86.203 +(* main case *)
86.204 +apply auto
86.205 +apply (rename_tac ex a t s s')
86.206 +apply (rule_tac t = "@t'. ? ex1. (t,t') :R & move A ex1 s' a t'" in lemma_2_1)
86.207 +
86.208 +(* Finite *)
86.209 +apply (erule move_subprop2_sim [unfolded Let_def])
86.210 +apply assumption+
86.211 +apply (rule conjI)
86.212 +
86.213 +(* is_exec_frag *)
86.214 +apply (erule move_subprop1_sim [unfolded Let_def])
86.215 +apply assumption+
86.216 +apply (rule conjI)
86.217 +
86.218 +(* Induction hypothesis *)
86.219 +(* reachable_n looping, therefore apply it manually *)
86.220 +apply (erule_tac x = "t" in allE)
86.221 +apply (erule_tac x = "@t'. ? ex1. (t,t') :R & move A ex1 s' a t'" in allE)
86.222 +apply simp
86.223 +apply (frule reachable.reachable_n)
86.224 +apply assumption
86.225 +apply (simp add: move_subprop5_sim [unfolded Let_def])
86.226 +(* laststate *)
86.227 +apply (erule move_subprop3_sim [unfolded Let_def, symmetric])
86.228 +apply assumption+
86.229 +done
86.230 +
86.231 +
86.232 +subsection "Main Theorem: TRACE - INCLUSION"
86.233 +
86.234 +(* -------------------------------------------------------------------------------- *)
86.235 +
86.236 + (* generate condition (s,S'):R & S':starts_of A, the first being intereting
86.237 + for the induction cases concerning the two lemmas correpsim_is_execution and
86.238 + traces_coincide_sim, the second for the start state case.
86.239 + S':= @s'. (s,s'):R & s':starts_of A, where s:starts_of C *)
86.240 +
86.241 +lemma simulation_starts:
86.242 +"[| is_simulation R C A; s:starts_of C |]
86.243 + ==> let S' = @s'. (s,s'):R & s':starts_of A in
86.244 + (s,S'):R & S':starts_of A"
86.245 + apply (simp add: is_simulation_def corresp_ex_sim_def Int_non_empty Image_def)
86.246 + apply (erule conjE)+
86.247 + apply (erule ballE)
86.248 + prefer 2 apply (blast)
86.249 + apply (erule exE)
86.250 + apply (rule someI2)
86.251 + apply assumption
86.252 + apply blast
86.253 + done
86.254 +
86.255 +lemmas sim_starts1 = simulation_starts [unfolded Let_def, THEN conjunct1, standard]
86.256 +lemmas sim_starts2 = simulation_starts [unfolded Let_def, THEN conjunct2, standard]
86.257 +
86.258 +
86.259 +lemma trace_inclusion_for_simulations:
86.260 + "[| ext C = ext A; is_simulation R C A |]
86.261 + ==> traces C <= traces A"
86.262 +
86.263 + apply (unfold traces_def)
86.264 +
86.265 + apply (simp (no_asm) add: has_trace_def2)
86.266 + apply auto
86.267 +
86.268 + (* give execution of abstract automata *)
86.269 + apply (rule_tac x = "corresp_ex_sim A R ex" in bexI)
86.270 +
86.271 + (* Traces coincide, Lemma 1 *)
86.272 + apply (tactic {* pair_tac @{context} "ex" 1 *})
86.273 + apply (rename_tac s ex)
86.274 + apply (simp (no_asm) add: corresp_ex_sim_def)
86.275 + apply (rule_tac s = "s" in traces_coincide_sim)
86.276 + apply assumption+
86.277 + apply (simp add: executions_def reachable.reachable_0 sim_starts1)
86.278 +
86.279 + (* corresp_ex_sim is execution, Lemma 2 *)
86.280 + apply (tactic {* pair_tac @{context} "ex" 1 *})
86.281 + apply (simp add: executions_def)
86.282 + apply (rename_tac s ex)
86.283 +
86.284 + (* start state *)
86.285 + apply (rule conjI)
86.286 + apply (simp add: sim_starts2 corresp_ex_sim_def)
86.287 +
86.288 + (* is-execution-fragment *)
86.289 + apply (simp add: corresp_ex_sim_def)
86.290 + apply (rule_tac s = s in correspsim_is_execution)
86.291 + apply assumption
86.292 + apply (simp add: reachable.reachable_0 sim_starts1)
86.293 + done
86.294 +
86.295 +end
87.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
87.2 +++ b/src/HOL/HOLCF/IOA/meta_theory/Simulations.thy Sat Nov 27 16:08:10 2010 -0800
87.3 @@ -0,0 +1,85 @@
87.4 +(* Title: HOLCF/IOA/meta_theory/Simulations.thy
87.5 + Author: Olaf Müller
87.6 +*)
87.7 +
87.8 +header {* Simulations in HOLCF/IOA *}
87.9 +
87.10 +theory Simulations
87.11 +imports RefCorrectness
87.12 +begin
87.13 +
87.14 +default_sort type
87.15 +
87.16 +definition
87.17 + is_simulation :: "[('s1 * 's2)set,('a,'s1)ioa,('a,'s2)ioa] => bool" where
87.18 + "is_simulation R C A =
87.19 + ((!s:starts_of C. R``{s} Int starts_of A ~= {}) &
87.20 + (!s s' t a. reachable C s &
87.21 + s -a--C-> t &
87.22 + (s,s') : R
87.23 + --> (? t' ex. (t,t'):R & move A ex s' a t')))"
87.24 +
87.25 +definition
87.26 + is_backward_simulation :: "[('s1 * 's2)set,('a,'s1)ioa,('a,'s2)ioa] => bool" where
87.27 + "is_backward_simulation R C A =
87.28 + ((!s:starts_of C. R``{s} <= starts_of A) &
87.29 + (!s t t' a. reachable C s &
87.30 + s -a--C-> t &
87.31 + (t,t') : R
87.32 + --> (? ex s'. (s,s'):R & move A ex s' a t')))"
87.33 +
87.34 +definition
87.35 + is_forw_back_simulation :: "[('s1 * 's2 set)set,('a,'s1)ioa,('a,'s2)ioa] => bool" where
87.36 + "is_forw_back_simulation R C A =
87.37 + ((!s:starts_of C. ? S'. (s,S'):R & S'<= starts_of A) &
87.38 + (!s S' t a. reachable C s &
87.39 + s -a--C-> t &
87.40 + (s,S') : R
87.41 + --> (? T'. (t,T'):R & (! t':T'. ? s':S'. ? ex. move A ex s' a t'))))"
87.42 +
87.43 +definition
87.44 + is_back_forw_simulation :: "[('s1 * 's2 set)set,('a,'s1)ioa,('a,'s2)ioa] => bool" where
87.45 + "is_back_forw_simulation R C A =
87.46 + ((!s:starts_of C. ! S'. (s,S'):R --> S' Int starts_of A ~={}) &
87.47 + (!s t T' a. reachable C s &
87.48 + s -a--C-> t &
87.49 + (t,T') : R
87.50 + --> (? S'. (s,S'):R & (! s':S'. ? t':T'. ? ex. move A ex s' a t'))))"
87.51 +
87.52 +definition
87.53 + is_history_relation :: "[('s1 * 's2)set,('a,'s1)ioa,('a,'s2)ioa] => bool" where
87.54 + "is_history_relation R C A = (is_simulation R C A &
87.55 + is_ref_map (%x.(@y. (x,y):(R^-1))) A C)"
87.56 +
87.57 +definition
87.58 + is_prophecy_relation :: "[('s1 * 's2)set,('a,'s1)ioa,('a,'s2)ioa] => bool" where
87.59 + "is_prophecy_relation R C A = (is_backward_simulation R C A &
87.60 + is_ref_map (%x.(@y. (x,y):(R^-1))) A C)"
87.61 +
87.62 +
87.63 +lemma set_non_empty: "(A~={}) = (? x. x:A)"
87.64 +apply auto
87.65 +done
87.66 +
87.67 +lemma Int_non_empty: "(A Int B ~= {}) = (? x. x: A & x:B)"
87.68 +apply (simp add: set_non_empty)
87.69 +done
87.70 +
87.71 +
87.72 +lemma Sim_start_convert:
87.73 +"(R``{x} Int S ~= {}) = (? y. (x,y):R & y:S)"
87.74 +apply (unfold Image_def)
87.75 +apply (simp add: Int_non_empty)
87.76 +done
87.77 +
87.78 +declare Sim_start_convert [simp]
87.79 +
87.80 +
87.81 +lemma ref_map_is_simulation:
87.82 +"!! f. is_ref_map f C A ==> is_simulation {p. (snd p) = f (fst p)} C A"
87.83 +
87.84 +apply (unfold is_ref_map_def is_simulation_def)
87.85 +apply simp
87.86 +done
87.87 +
87.88 +end
88.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
88.2 +++ b/src/HOL/HOLCF/IOA/meta_theory/TL.thy Sat Nov 27 16:08:10 2010 -0800
88.3 @@ -0,0 +1,203 @@
88.4 +(* Title: HOLCF/IOA/meta_theory/TLS.thy
88.5 + Author: Olaf Müller
88.6 +*)
88.7 +
88.8 +header {* A General Temporal Logic *}
88.9 +
88.10 +theory TL
88.11 +imports Pred Sequence
88.12 +begin
88.13 +
88.14 +default_sort type
88.15 +
88.16 +types
88.17 + 'a temporal = "'a Seq predicate"
88.18 +
88.19 +
88.20 +consts
88.21 +suffix :: "'a Seq => 'a Seq => bool"
88.22 +tsuffix :: "'a Seq => 'a Seq => bool"
88.23 +
88.24 +validT :: "'a Seq predicate => bool"
88.25 +
88.26 +unlift :: "'a lift => 'a"
88.27 +
88.28 +Init ::"'a predicate => 'a temporal" ("<_>" [0] 1000)
88.29 +
88.30 +Box ::"'a temporal => 'a temporal" ("[] (_)" [80] 80)
88.31 +Diamond ::"'a temporal => 'a temporal" ("<> (_)" [80] 80)
88.32 +Next ::"'a temporal => 'a temporal"
88.33 +Leadsto ::"'a temporal => 'a temporal => 'a temporal" (infixr "~>" 22)
88.34 +
88.35 +notation (xsymbols)
88.36 + Box ("\<box> (_)" [80] 80) and
88.37 + Diamond ("\<diamond> (_)" [80] 80) and
88.38 + Leadsto (infixr "\<leadsto>" 22)
88.39 +
88.40 +defs
88.41 +
88.42 +unlift_def:
88.43 + "unlift x == (case x of Def y => y)"
88.44 +
88.45 +(* this means that for nil and UU the effect is unpredictable *)
88.46 +Init_def:
88.47 + "Init P s == (P (unlift (HD$s)))"
88.48 +
88.49 +suffix_def:
88.50 + "suffix s2 s == ? s1. (Finite s1 & s = s1 @@ s2)"
88.51 +
88.52 +tsuffix_def:
88.53 + "tsuffix s2 s == s2 ~= nil & s2 ~= UU & suffix s2 s"
88.54 +
88.55 +Box_def:
88.56 + "([] P) s == ! s2. tsuffix s2 s --> P s2"
88.57 +
88.58 +Next_def:
88.59 + "(Next P) s == if (TL$s=UU | TL$s=nil) then (P s) else P (TL$s)"
88.60 +
88.61 +Diamond_def:
88.62 + "<> P == .~ ([] (.~ P))"
88.63 +
88.64 +Leadsto_def:
88.65 + "P ~> Q == ([] (P .--> (<> Q)))"
88.66 +
88.67 +validT_def:
88.68 + "validT P == ! s. s~=UU & s~=nil --> (s |= P)"
88.69 +
88.70 +
88.71 +lemma simple: "[] <> (.~ P) = (.~ <> [] P)"
88.72 +apply (rule ext)
88.73 +apply (simp add: Diamond_def NOT_def Box_def)
88.74 +done
88.75 +
88.76 +lemma Boxnil: "nil |= [] P"
88.77 +apply (simp add: satisfies_def Box_def tsuffix_def suffix_def nil_is_Conc)
88.78 +done
88.79 +
88.80 +lemma Diamondnil: "~(nil |= <> P)"
88.81 +apply (simp add: Diamond_def satisfies_def NOT_def)
88.82 +apply (cut_tac Boxnil)
88.83 +apply (simp add: satisfies_def)
88.84 +done
88.85 +
88.86 +lemma Diamond_def2: "(<> F) s = (? s2. tsuffix s2 s & F s2)"
88.87 +apply (simp add: Diamond_def NOT_def Box_def)
88.88 +done
88.89 +
88.90 +
88.91 +
88.92 +subsection "TLA Axiomatization by Merz"
88.93 +
88.94 +lemma suffix_refl: "suffix s s"
88.95 +apply (simp add: suffix_def)
88.96 +apply (rule_tac x = "nil" in exI)
88.97 +apply auto
88.98 +done
88.99 +
88.100 +lemma reflT: "s~=UU & s~=nil --> (s |= [] F .--> F)"
88.101 +apply (simp add: satisfies_def IMPLIES_def Box_def)
88.102 +apply (rule impI)+
88.103 +apply (erule_tac x = "s" in allE)
88.104 +apply (simp add: tsuffix_def suffix_refl)
88.105 +done
88.106 +
88.107 +
88.108 +lemma suffix_trans: "[| suffix y x ; suffix z y |] ==> suffix z x"
88.109 +apply (simp add: suffix_def)
88.110 +apply auto
88.111 +apply (rule_tac x = "s1 @@ s1a" in exI)
88.112 +apply auto
88.113 +apply (simp (no_asm) add: Conc_assoc)
88.114 +done
88.115 +
88.116 +lemma transT: "s |= [] F .--> [] [] F"
88.117 +apply (simp (no_asm) add: satisfies_def IMPLIES_def Box_def tsuffix_def)
88.118 +apply auto
88.119 +apply (drule suffix_trans)
88.120 +apply assumption
88.121 +apply (erule_tac x = "s2a" in allE)
88.122 +apply auto
88.123 +done
88.124 +
88.125 +
88.126 +lemma normalT: "s |= [] (F .--> G) .--> [] F .--> [] G"
88.127 +apply (simp (no_asm) add: satisfies_def IMPLIES_def Box_def)
88.128 +done
88.129 +
88.130 +
88.131 +subsection "TLA Rules by Lamport"
88.132 +
88.133 +lemma STL1a: "validT P ==> validT ([] P)"
88.134 +apply (simp add: validT_def satisfies_def Box_def tsuffix_def)
88.135 +done
88.136 +
88.137 +lemma STL1b: "valid P ==> validT (Init P)"
88.138 +apply (simp add: valid_def validT_def satisfies_def Init_def)
88.139 +done
88.140 +
88.141 +lemma STL1: "valid P ==> validT ([] (Init P))"
88.142 +apply (rule STL1a)
88.143 +apply (erule STL1b)
88.144 +done
88.145 +
88.146 +(* Note that unlift and HD is not at all used !!! *)
88.147 +lemma STL4: "valid (P .--> Q) ==> validT ([] (Init P) .--> [] (Init Q))"
88.148 +apply (simp add: valid_def validT_def satisfies_def IMPLIES_def Box_def Init_def)
88.149 +done
88.150 +
88.151 +
88.152 +subsection "LTL Axioms by Manna/Pnueli"
88.153 +
88.154 +lemma tsuffix_TL [rule_format (no_asm)]:
88.155 +"s~=UU & s~=nil --> tsuffix s2 (TL$s) --> tsuffix s2 s"
88.156 +apply (unfold tsuffix_def suffix_def)
88.157 +apply auto
88.158 +apply (tactic {* Seq_case_simp_tac @{context} "s" 1 *})
88.159 +apply (rule_tac x = "a>>s1" in exI)
88.160 +apply auto
88.161 +done
88.162 +
88.163 +lemmas tsuffix_TL2 = conjI [THEN tsuffix_TL]
88.164 +
88.165 +declare split_if [split del]
88.166 +lemma LTL1:
88.167 + "s~=UU & s~=nil --> (s |= [] F .--> (F .& (Next ([] F))))"
88.168 +apply (unfold Next_def satisfies_def NOT_def IMPLIES_def AND_def Box_def)
88.169 +apply auto
88.170 +(* []F .--> F *)
88.171 +apply (erule_tac x = "s" in allE)
88.172 +apply (simp add: tsuffix_def suffix_refl)
88.173 +(* []F .--> Next [] F *)
88.174 +apply (simp split add: split_if)
88.175 +apply auto
88.176 +apply (drule tsuffix_TL2)
88.177 +apply assumption+
88.178 +apply auto
88.179 +done
88.180 +declare split_if [split]
88.181 +
88.182 +
88.183 +lemma LTL2a:
88.184 + "s |= .~ (Next F) .--> (Next (.~ F))"
88.185 +apply (unfold Next_def satisfies_def NOT_def IMPLIES_def)
88.186 +apply simp
88.187 +done
88.188 +
88.189 +lemma LTL2b:
88.190 + "s |= (Next (.~ F)) .--> (.~ (Next F))"
88.191 +apply (unfold Next_def satisfies_def NOT_def IMPLIES_def)
88.192 +apply simp
88.193 +done
88.194 +
88.195 +lemma LTL3:
88.196 +"ex |= (Next (F .--> G)) .--> (Next F) .--> (Next G)"
88.197 +apply (unfold Next_def satisfies_def NOT_def IMPLIES_def)
88.198 +apply simp
88.199 +done
88.200 +
88.201 +
88.202 +lemma ModusPonens: "[| validT (P .--> Q); validT P |] ==> validT Q"
88.203 +apply (simp add: validT_def satisfies_def IMPLIES_def)
88.204 +done
88.205 +
88.206 +end
89.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
89.2 +++ b/src/HOL/HOLCF/IOA/meta_theory/TLS.thy Sat Nov 27 16:08:10 2010 -0800
89.3 @@ -0,0 +1,201 @@
89.4 +(* Title: HOLCF/IOA/meta_theory/TLS.thy
89.5 + Author: Olaf Müller
89.6 +*)
89.7 +
89.8 +header {* Temporal Logic of Steps -- tailored for I/O automata *}
89.9 +
89.10 +theory TLS
89.11 +imports IOA TL
89.12 +begin
89.13 +
89.14 +default_sort type
89.15 +
89.16 +types
89.17 + ('a, 's) ioa_temp = "('a option,'s)transition temporal"
89.18 + ('a, 's) step_pred = "('a option,'s)transition predicate"
89.19 + 's state_pred = "'s predicate"
89.20 +
89.21 +consts
89.22 +
89.23 +option_lift :: "('a => 'b) => 'b => ('a option => 'b)"
89.24 +plift :: "('a => bool) => ('a option => bool)"
89.25 +
89.26 +temp_sat :: "('a,'s)execution => ('a,'s)ioa_temp => bool" (infixr "|==" 22)
89.27 +xt1 :: "'s predicate => ('a,'s)step_pred"
89.28 +xt2 :: "'a option predicate => ('a,'s)step_pred"
89.29 +
89.30 +validTE :: "('a,'s)ioa_temp => bool"
89.31 +validIOA :: "('a,'s)ioa => ('a,'s)ioa_temp => bool"
89.32 +
89.33 +mkfin :: "'a Seq => 'a Seq"
89.34 +
89.35 +ex2seq :: "('a,'s)execution => ('a option,'s)transition Seq"
89.36 +ex2seqC :: "('a,'s)pairs -> ('s => ('a option,'s)transition Seq)"
89.37 +
89.38 +
89.39 +defs
89.40 +
89.41 +mkfin_def:
89.42 + "mkfin s == if Partial s then @t. Finite t & s = t @@ UU
89.43 + else s"
89.44 +
89.45 +option_lift_def:
89.46 + "option_lift f s y == case y of None => s | Some x => (f x)"
89.47 +
89.48 +(* plift is used to determine that None action is always false in
89.49 + transition predicates *)
89.50 +plift_def:
89.51 + "plift P == option_lift P False"
89.52 +
89.53 +temp_sat_def:
89.54 + "ex |== P == ((ex2seq ex) |= P)"
89.55 +
89.56 +xt1_def:
89.57 + "xt1 P tr == P (fst tr)"
89.58 +
89.59 +xt2_def:
89.60 + "xt2 P tr == P (fst (snd tr))"
89.61 +
89.62 +ex2seq_def:
89.63 + "ex2seq ex == ((ex2seqC $(mkfin (snd ex))) (fst ex))"
89.64 +
89.65 +ex2seqC_def:
89.66 + "ex2seqC == (fix$(LAM h ex. (%s. case ex of
89.67 + nil => (s,None,s)>>nil
89.68 + | x##xs => (flift1 (%pr.
89.69 + (s,Some (fst pr), snd pr)>> (h$xs) (snd pr))
89.70 + $x)
89.71 + )))"
89.72 +
89.73 +validTE_def:
89.74 + "validTE P == ! ex. (ex |== P)"
89.75 +
89.76 +validIOA_def:
89.77 + "validIOA A P == ! ex : executions A . (ex |== P)"
89.78 +
89.79 +
89.80 +axioms
89.81 +
89.82 +mkfin_UU:
89.83 + "mkfin UU = nil"
89.84 +
89.85 +mkfin_nil:
89.86 + "mkfin nil =nil"
89.87 +
89.88 +mkfin_cons:
89.89 + "(mkfin (a>>s)) = (a>>(mkfin s))"
89.90 +
89.91 +
89.92 +lemmas [simp del] = HOL.ex_simps HOL.all_simps split_paired_Ex
89.93 +
89.94 +declaration {* fn _ => Classical.map_cs (fn cs => cs delSWrapper "split_all_tac") *}
89.95 +
89.96 +
89.97 +subsection {* ex2seqC *}
89.98 +
89.99 +lemma ex2seqC_unfold: "ex2seqC = (LAM ex. (%s. case ex of
89.100 + nil => (s,None,s)>>nil
89.101 + | x##xs => (flift1 (%pr.
89.102 + (s,Some (fst pr), snd pr)>> (ex2seqC$xs) (snd pr))
89.103 + $x)
89.104 + ))"
89.105 +apply (rule trans)
89.106 +apply (rule fix_eq2)
89.107 +apply (rule ex2seqC_def)
89.108 +apply (rule beta_cfun)
89.109 +apply (simp add: flift1_def)
89.110 +done
89.111 +
89.112 +lemma ex2seqC_UU: "(ex2seqC $UU) s=UU"
89.113 +apply (subst ex2seqC_unfold)
89.114 +apply simp
89.115 +done
89.116 +
89.117 +lemma ex2seqC_nil: "(ex2seqC $nil) s = (s,None,s)>>nil"
89.118 +apply (subst ex2seqC_unfold)
89.119 +apply simp
89.120 +done
89.121 +
89.122 +lemma ex2seqC_cons: "(ex2seqC $((a,t)>>xs)) s =
89.123 + (s,Some a,t)>> ((ex2seqC$xs) t)"
89.124 +apply (rule trans)
89.125 +apply (subst ex2seqC_unfold)
89.126 +apply (simp add: Consq_def flift1_def)
89.127 +apply (simp add: Consq_def flift1_def)
89.128 +done
89.129 +
89.130 +declare ex2seqC_UU [simp] ex2seqC_nil [simp] ex2seqC_cons [simp]
89.131 +
89.132 +
89.133 +
89.134 +declare mkfin_UU [simp] mkfin_nil [simp] mkfin_cons [simp]
89.135 +
89.136 +lemma ex2seq_UU: "ex2seq (s, UU) = (s,None,s)>>nil"
89.137 +apply (simp add: ex2seq_def)
89.138 +done
89.139 +
89.140 +lemma ex2seq_nil: "ex2seq (s, nil) = (s,None,s)>>nil"
89.141 +apply (simp add: ex2seq_def)
89.142 +done
89.143 +
89.144 +lemma ex2seq_cons: "ex2seq (s, (a,t)>>ex) = (s,Some a,t) >> ex2seq (t, ex)"
89.145 +apply (simp add: ex2seq_def)
89.146 +done
89.147 +
89.148 +declare ex2seqC_UU [simp del] ex2seqC_nil [simp del] ex2seqC_cons [simp del]
89.149 +declare ex2seq_UU [simp] ex2seq_nil [simp] ex2seq_cons [simp]
89.150 +
89.151 +
89.152 +lemma ex2seq_nUUnnil: "ex2seq exec ~= UU & ex2seq exec ~= nil"
89.153 +apply (tactic {* pair_tac @{context} "exec" 1 *})
89.154 +apply (tactic {* Seq_case_simp_tac @{context} "y" 1 *})
89.155 +apply (tactic {* pair_tac @{context} "a" 1 *})
89.156 +done
89.157 +
89.158 +
89.159 +subsection {* Interface TL -- TLS *}
89.160 +
89.161 +(* uses the fact that in executions states overlap, which is lost in
89.162 + after the translation via ex2seq !! *)
89.163 +
89.164 +lemma TL_TLS:
89.165 + "[| ! s a t. (P s) & s-a--A-> t --> (Q t) |]
89.166 + ==> ex |== (Init (%(s,a,t). P s) .& Init (%(s,a,t). s -a--A-> t)
89.167 + .--> (Next (Init (%(s,a,t).Q s))))"
89.168 +apply (unfold Init_def Next_def temp_sat_def satisfies_def IMPLIES_def AND_def)
89.169 +
89.170 +apply clarify
89.171 +apply (simp split add: split_if)
89.172 +(* TL = UU *)
89.173 +apply (rule conjI)
89.174 +apply (tactic {* pair_tac @{context} "ex" 1 *})
89.175 +apply (tactic {* Seq_case_simp_tac @{context} "y" 1 *})
89.176 +apply (tactic {* pair_tac @{context} "a" 1 *})
89.177 +apply (tactic {* Seq_case_simp_tac @{context} "s" 1 *})
89.178 +apply (tactic {* pair_tac @{context} "a" 1 *})
89.179 +(* TL = nil *)
89.180 +apply (rule conjI)
89.181 +apply (tactic {* pair_tac @{context} "ex" 1 *})
89.182 +apply (tactic {* Seq_case_tac @{context} "y" 1 *})
89.183 +apply (simp add: unlift_def)
89.184 +apply fast
89.185 +apply (simp add: unlift_def)
89.186 +apply fast
89.187 +apply (simp add: unlift_def)
89.188 +apply (tactic {* pair_tac @{context} "a" 1 *})
89.189 +apply (tactic {* Seq_case_simp_tac @{context} "s" 1 *})
89.190 +apply (tactic {* pair_tac @{context} "a" 1 *})
89.191 +(* TL =cons *)
89.192 +apply (simp add: unlift_def)
89.193 +
89.194 +apply (tactic {* pair_tac @{context} "ex" 1 *})
89.195 +apply (tactic {* Seq_case_simp_tac @{context} "y" 1 *})
89.196 +apply (tactic {* pair_tac @{context} "a" 1 *})
89.197 +apply (tactic {* Seq_case_simp_tac @{context} "s" 1 *})
89.198 +apply blast
89.199 +apply fastsimp
89.200 +apply (tactic {* pair_tac @{context} "a" 1 *})
89.201 + apply fastsimp
89.202 +done
89.203 +
89.204 +end
90.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
90.2 +++ b/src/HOL/HOLCF/IOA/meta_theory/Traces.thy Sat Nov 27 16:08:10 2010 -0800
90.3 @@ -0,0 +1,410 @@
90.4 +(* Title: HOLCF/IOA/meta_theory/Traces.thy
90.5 + Author: Olaf Müller
90.6 +*)
90.7 +
90.8 +header {* Executions and Traces of I/O automata in HOLCF *}
90.9 +
90.10 +theory Traces
90.11 +imports Sequence Automata
90.12 +begin
90.13 +
90.14 +default_sort type
90.15 +
90.16 +types
90.17 + ('a,'s)pairs = "('a * 's) Seq"
90.18 + ('a,'s)execution = "'s * ('a,'s)pairs"
90.19 + 'a trace = "'a Seq"
90.20 +
90.21 + ('a,'s)execution_module = "('a,'s)execution set * 'a signature"
90.22 + 'a schedule_module = "'a trace set * 'a signature"
90.23 + 'a trace_module = "'a trace set * 'a signature"
90.24 +
90.25 +consts
90.26 +
90.27 + (* Executions *)
90.28 +
90.29 + is_exec_fragC ::"('a,'s)ioa => ('a,'s)pairs -> 's => tr"
90.30 + is_exec_frag ::"[('a,'s)ioa, ('a,'s)execution] => bool"
90.31 + has_execution ::"[('a,'s)ioa, ('a,'s)execution] => bool"
90.32 + executions :: "('a,'s)ioa => ('a,'s)execution set"
90.33 +
90.34 + (* Schedules and traces *)
90.35 + filter_act ::"('a,'s)pairs -> 'a trace"
90.36 + has_schedule :: "[('a,'s)ioa, 'a trace] => bool"
90.37 + has_trace :: "[('a,'s)ioa, 'a trace] => bool"
90.38 + schedules :: "('a,'s)ioa => 'a trace set"
90.39 + traces :: "('a,'s)ioa => 'a trace set"
90.40 + mk_trace :: "('a,'s)ioa => ('a,'s)pairs -> 'a trace"
90.41 +
90.42 + laststate ::"('a,'s)execution => 's"
90.43 +
90.44 + (* A predicate holds infinitely (finitely) often in a sequence *)
90.45 +
90.46 + inf_often ::"('a => bool) => 'a Seq => bool"
90.47 + fin_often ::"('a => bool) => 'a Seq => bool"
90.48 +
90.49 + (* fairness of executions *)
90.50 +
90.51 + wfair_ex ::"('a,'s)ioa => ('a,'s)execution => bool"
90.52 + sfair_ex ::"('a,'s)ioa => ('a,'s)execution => bool"
90.53 + is_wfair ::"('a,'s)ioa => 'a set => ('a,'s)execution => bool"
90.54 + is_sfair ::"('a,'s)ioa => 'a set => ('a,'s)execution => bool"
90.55 + fair_ex ::"('a,'s)ioa => ('a,'s)execution => bool"
90.56 +
90.57 + (* fair behavior sets *)
90.58 +
90.59 + fairexecutions ::"('a,'s)ioa => ('a,'s)execution set"
90.60 + fairtraces ::"('a,'s)ioa => 'a trace set"
90.61 +
90.62 + (* Notions of implementation *)
90.63 + ioa_implements :: "[('a,'s1)ioa, ('a,'s2)ioa] => bool" (infixr "=<|" 12)
90.64 + fair_implements :: "('a,'s1)ioa => ('a,'s2)ioa => bool"
90.65 +
90.66 + (* Execution, schedule and trace modules *)
90.67 + Execs :: "('a,'s)ioa => ('a,'s)execution_module"
90.68 + Scheds :: "('a,'s)ioa => 'a schedule_module"
90.69 + Traces :: "('a,'s)ioa => 'a trace_module"
90.70 +
90.71 +
90.72 +defs
90.73 +
90.74 +
90.75 +(* ------------------- Executions ------------------------------ *)
90.76 +
90.77 +
90.78 +is_exec_frag_def:
90.79 + "is_exec_frag A ex == ((is_exec_fragC A$(snd ex)) (fst ex) ~= FF)"
90.80 +
90.81 +
90.82 +is_exec_fragC_def:
90.83 + "is_exec_fragC A ==(fix$(LAM h ex. (%s. case ex of
90.84 + nil => TT
90.85 + | x##xs => (flift1
90.86 + (%p. Def ((s,p):trans_of A) andalso (h$xs) (snd p))
90.87 + $x)
90.88 + )))"
90.89 +
90.90 +
90.91 +
90.92 +executions_def:
90.93 + "executions ioa == {e. ((fst e) : starts_of(ioa)) &
90.94 + is_exec_frag ioa e}"
90.95 +
90.96 +
90.97 +(* ------------------- Schedules ------------------------------ *)
90.98 +
90.99 +
90.100 +filter_act_def:
90.101 + "filter_act == Map fst"
90.102 +
90.103 +has_schedule_def:
90.104 + "has_schedule ioa sch ==
90.105 + (? ex:executions ioa. sch = filter_act$(snd ex))"
90.106 +
90.107 +schedules_def:
90.108 + "schedules ioa == {sch. has_schedule ioa sch}"
90.109 +
90.110 +
90.111 +(* ------------------- Traces ------------------------------ *)
90.112 +
90.113 +has_trace_def:
90.114 + "has_trace ioa tr ==
90.115 + (? sch:schedules ioa. tr = Filter (%a. a:ext(ioa))$sch)"
90.116 +
90.117 +traces_def:
90.118 + "traces ioa == {tr. has_trace ioa tr}"
90.119 +
90.120 +
90.121 +mk_trace_def:
90.122 + "mk_trace ioa == LAM tr.
90.123 + Filter (%a. a:ext(ioa))$(filter_act$tr)"
90.124 +
90.125 +
90.126 +(* ------------------- Fair Traces ------------------------------ *)
90.127 +
90.128 +laststate_def:
90.129 + "laststate ex == case Last$(snd ex) of
90.130 + UU => fst ex
90.131 + | Def at => snd at"
90.132 +
90.133 +inf_often_def:
90.134 + "inf_often P s == Infinite (Filter P$s)"
90.135 +
90.136 +(* filtering P yields a finite or partial sequence *)
90.137 +fin_often_def:
90.138 + "fin_often P s == ~inf_often P s"
90.139 +
90.140 +(* Note that partial execs cannot be wfair as the inf_often predicate in the
90.141 + else branch prohibits it. However they can be sfair in the case when all W
90.142 + are only finitely often enabled: Is this the right model?
90.143 + See LiveIOA for solution conforming with the literature and superseding this one *)
90.144 +wfair_ex_def:
90.145 + "wfair_ex A ex == ! W : wfair_of A.
90.146 + if Finite (snd ex)
90.147 + then ~Enabled A W (laststate ex)
90.148 + else is_wfair A W ex"
90.149 +
90.150 +is_wfair_def:
90.151 + "is_wfair A W ex == (inf_often (%x. fst x:W) (snd ex)
90.152 + | inf_often (%x.~Enabled A W (snd x)) (snd ex))"
90.153 +
90.154 +sfair_ex_def:
90.155 + "sfair_ex A ex == ! W : sfair_of A.
90.156 + if Finite (snd ex)
90.157 + then ~Enabled A W (laststate ex)
90.158 + else is_sfair A W ex"
90.159 +
90.160 +is_sfair_def:
90.161 + "is_sfair A W ex == (inf_often (%x. fst x:W) (snd ex)
90.162 + | fin_often (%x. Enabled A W (snd x)) (snd ex))"
90.163 +
90.164 +fair_ex_def:
90.165 + "fair_ex A ex == wfair_ex A ex & sfair_ex A ex"
90.166 +
90.167 +fairexecutions_def:
90.168 + "fairexecutions A == {ex. ex:executions A & fair_ex A ex}"
90.169 +
90.170 +fairtraces_def:
90.171 + "fairtraces A == {mk_trace A$(snd ex) | ex. ex:fairexecutions A}"
90.172 +
90.173 +
90.174 +(* ------------------- Implementation ------------------------------ *)
90.175 +
90.176 +ioa_implements_def:
90.177 + "ioa1 =<| ioa2 ==
90.178 + (((inputs(asig_of(ioa1)) = inputs(asig_of(ioa2))) &
90.179 + (outputs(asig_of(ioa1)) = outputs(asig_of(ioa2)))) &
90.180 + traces(ioa1) <= traces(ioa2))"
90.181 +
90.182 +fair_implements_def:
90.183 + "fair_implements C A == inp(C) = inp(A) & out(C)=out(A) &
90.184 + fairtraces(C) <= fairtraces(A)"
90.185 +
90.186 +(* ------------------- Modules ------------------------------ *)
90.187 +
90.188 +Execs_def:
90.189 + "Execs A == (executions A, asig_of A)"
90.190 +
90.191 +Scheds_def:
90.192 + "Scheds A == (schedules A, asig_of A)"
90.193 +
90.194 +Traces_def:
90.195 + "Traces A == (traces A,asig_of A)"
90.196 +
90.197 +
90.198 +lemmas [simp del] = HOL.ex_simps HOL.all_simps split_paired_Ex
90.199 +declare Let_def [simp]
90.200 +declaration {* fn _ => Classical.map_cs (fn cs => cs delSWrapper "split_all_tac") *}
90.201 +
90.202 +lemmas exec_rws = executions_def is_exec_frag_def
90.203 +
90.204 +
90.205 +
90.206 +subsection "recursive equations of operators"
90.207 +
90.208 +(* ---------------------------------------------------------------- *)
90.209 +(* filter_act *)
90.210 +(* ---------------------------------------------------------------- *)
90.211 +
90.212 +
90.213 +lemma filter_act_UU: "filter_act$UU = UU"
90.214 +apply (simp add: filter_act_def)
90.215 +done
90.216 +
90.217 +lemma filter_act_nil: "filter_act$nil = nil"
90.218 +apply (simp add: filter_act_def)
90.219 +done
90.220 +
90.221 +lemma filter_act_cons: "filter_act$(x>>xs) = (fst x) >> filter_act$xs"
90.222 +apply (simp add: filter_act_def)
90.223 +done
90.224 +
90.225 +declare filter_act_UU [simp] filter_act_nil [simp] filter_act_cons [simp]
90.226 +
90.227 +
90.228 +(* ---------------------------------------------------------------- *)
90.229 +(* mk_trace *)
90.230 +(* ---------------------------------------------------------------- *)
90.231 +
90.232 +lemma mk_trace_UU: "mk_trace A$UU=UU"
90.233 +apply (simp add: mk_trace_def)
90.234 +done
90.235 +
90.236 +lemma mk_trace_nil: "mk_trace A$nil=nil"
90.237 +apply (simp add: mk_trace_def)
90.238 +done
90.239 +
90.240 +lemma mk_trace_cons: "mk_trace A$(at >> xs) =
90.241 + (if ((fst at):ext A)
90.242 + then (fst at) >> (mk_trace A$xs)
90.243 + else mk_trace A$xs)"
90.244 +
90.245 +apply (simp add: mk_trace_def)
90.246 +done
90.247 +
90.248 +declare mk_trace_UU [simp] mk_trace_nil [simp] mk_trace_cons [simp]
90.249 +
90.250 +(* ---------------------------------------------------------------- *)
90.251 +(* is_exec_fragC *)
90.252 +(* ---------------------------------------------------------------- *)
90.253 +
90.254 +
90.255 +lemma is_exec_fragC_unfold: "is_exec_fragC A = (LAM ex. (%s. case ex of
90.256 + nil => TT
90.257 + | x##xs => (flift1
90.258 + (%p. Def ((s,p):trans_of A) andalso (is_exec_fragC A$xs) (snd p))
90.259 + $x)
90.260 + ))"
90.261 +apply (rule trans)
90.262 +apply (rule fix_eq2)
90.263 +apply (rule is_exec_fragC_def)
90.264 +apply (rule beta_cfun)
90.265 +apply (simp add: flift1_def)
90.266 +done
90.267 +
90.268 +lemma is_exec_fragC_UU: "(is_exec_fragC A$UU) s=UU"
90.269 +apply (subst is_exec_fragC_unfold)
90.270 +apply simp
90.271 +done
90.272 +
90.273 +lemma is_exec_fragC_nil: "(is_exec_fragC A$nil) s = TT"
90.274 +apply (subst is_exec_fragC_unfold)
90.275 +apply simp
90.276 +done
90.277 +
90.278 +lemma is_exec_fragC_cons: "(is_exec_fragC A$(pr>>xs)) s =
90.279 + (Def ((s,pr):trans_of A)
90.280 + andalso (is_exec_fragC A$xs)(snd pr))"
90.281 +apply (rule trans)
90.282 +apply (subst is_exec_fragC_unfold)
90.283 +apply (simp add: Consq_def flift1_def)
90.284 +apply simp
90.285 +done
90.286 +
90.287 +
90.288 +declare is_exec_fragC_UU [simp] is_exec_fragC_nil [simp] is_exec_fragC_cons [simp]
90.289 +
90.290 +
90.291 +(* ---------------------------------------------------------------- *)
90.292 +(* is_exec_frag *)
90.293 +(* ---------------------------------------------------------------- *)
90.294 +
90.295 +lemma is_exec_frag_UU: "is_exec_frag A (s, UU)"
90.296 +apply (simp add: is_exec_frag_def)
90.297 +done
90.298 +
90.299 +lemma is_exec_frag_nil: "is_exec_frag A (s, nil)"
90.300 +apply (simp add: is_exec_frag_def)
90.301 +done
90.302 +
90.303 +lemma is_exec_frag_cons: "is_exec_frag A (s, (a,t)>>ex) =
90.304 + (((s,a,t):trans_of A) &
90.305 + is_exec_frag A (t, ex))"
90.306 +apply (simp add: is_exec_frag_def)
90.307 +done
90.308 +
90.309 +
90.310 +(* Delsimps [is_exec_fragC_UU,is_exec_fragC_nil,is_exec_fragC_cons]; *)
90.311 +declare is_exec_frag_UU [simp] is_exec_frag_nil [simp] is_exec_frag_cons [simp]
90.312 +
90.313 +(* ---------------------------------------------------------------------------- *)
90.314 + section "laststate"
90.315 +(* ---------------------------------------------------------------------------- *)
90.316 +
90.317 +lemma laststate_UU: "laststate (s,UU) = s"
90.318 +apply (simp add: laststate_def)
90.319 +done
90.320 +
90.321 +lemma laststate_nil: "laststate (s,nil) = s"
90.322 +apply (simp add: laststate_def)
90.323 +done
90.324 +
90.325 +lemma laststate_cons: "!! ex. Finite ex ==> laststate (s,at>>ex) = laststate (snd at,ex)"
90.326 +apply (simp (no_asm) add: laststate_def)
90.327 +apply (case_tac "ex=nil")
90.328 +apply (simp (no_asm_simp))
90.329 +apply (simp (no_asm_simp))
90.330 +apply (drule Finite_Last1 [THEN mp])
90.331 +apply assumption
90.332 +apply defined
90.333 +done
90.334 +
90.335 +declare laststate_UU [simp] laststate_nil [simp] laststate_cons [simp]
90.336 +
90.337 +lemma exists_laststate: "!!ex. Finite ex ==> (! s. ? u. laststate (s,ex)=u)"
90.338 +apply (tactic "Seq_Finite_induct_tac @{context} 1")
90.339 +done
90.340 +
90.341 +
90.342 +subsection "has_trace, mk_trace"
90.343 +
90.344 +(* alternative definition of has_trace tailored for the refinement proof, as it does not
90.345 + take the detour of schedules *)
90.346 +
90.347 +lemma has_trace_def2:
90.348 +"has_trace A b = (? ex:executions A. b = mk_trace A$(snd ex))"
90.349 +apply (unfold executions_def mk_trace_def has_trace_def schedules_def has_schedule_def)
90.350 +apply auto
90.351 +done
90.352 +
90.353 +
90.354 +subsection "signatures and executions, schedules"
90.355 +
90.356 +(* All executions of A have only actions of A. This is only true because of the
90.357 + predicate state_trans (part of the predicate IOA): We have no dependent types.
90.358 + For executions of parallel automata this assumption is not needed, as in par_def
90.359 + this condition is included once more. (see Lemmas 1.1.1c in CompoExecs for example) *)
90.360 +
90.361 +lemma execfrag_in_sig:
90.362 + "!! A. is_trans_of A ==>
90.363 + ! s. is_exec_frag A (s,xs) --> Forall (%a. a:act A) (filter_act$xs)"
90.364 +apply (tactic {* pair_induct_tac @{context} "xs" [@{thm is_exec_frag_def},
90.365 + @{thm Forall_def}, @{thm sforall_def}] 1 *})
90.366 +(* main case *)
90.367 +apply (auto simp add: is_trans_of_def)
90.368 +done
90.369 +
90.370 +lemma exec_in_sig:
90.371 + "!! A.[| is_trans_of A; x:executions A |] ==>
90.372 + Forall (%a. a:act A) (filter_act$(snd x))"
90.373 +apply (simp add: executions_def)
90.374 +apply (tactic {* pair_tac @{context} "x" 1 *})
90.375 +apply (rule execfrag_in_sig [THEN spec, THEN mp])
90.376 +apply auto
90.377 +done
90.378 +
90.379 +lemma scheds_in_sig:
90.380 + "!! A.[| is_trans_of A; x:schedules A |] ==>
90.381 + Forall (%a. a:act A) x"
90.382 +apply (unfold schedules_def has_schedule_def)
90.383 +apply (fast intro!: exec_in_sig)
90.384 +done
90.385 +
90.386 +
90.387 +subsection "executions are prefix closed"
90.388 +
90.389 +(* only admissible in y, not if done in x !! *)
90.390 +lemma execfrag_prefixclosed: "!x s. is_exec_frag A (s,x) & y<<x --> is_exec_frag A (s,y)"
90.391 +apply (tactic {* pair_induct_tac @{context} "y" [@{thm is_exec_frag_def}] 1 *})
90.392 +apply (intro strip)
90.393 +apply (tactic {* Seq_case_simp_tac @{context} "xa" 1 *})
90.394 +apply (tactic {* pair_tac @{context} "a" 1 *})
90.395 +apply auto
90.396 +done
90.397 +
90.398 +lemmas exec_prefixclosed =
90.399 + conjI [THEN execfrag_prefixclosed [THEN spec, THEN spec, THEN mp], standard]
90.400 +
90.401 +
90.402 +(* second prefix notion for Finite x *)
90.403 +
90.404 +lemma exec_prefix2closed [rule_format]:
90.405 + "! y s. is_exec_frag A (s,x@@y) --> is_exec_frag A (s,x)"
90.406 +apply (tactic {* pair_induct_tac @{context} "x" [@{thm is_exec_frag_def}] 1 *})
90.407 +apply (intro strip)
90.408 +apply (tactic {* Seq_case_simp_tac @{context} "s" 1 *})
90.409 +apply (tactic {* pair_tac @{context} "a" 1 *})
90.410 +apply auto
90.411 +done
90.412 +
90.413 +end
91.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
91.2 +++ b/src/HOL/HOLCF/IsaMakefile Sat Nov 27 16:08:10 2010 -0800
91.3 @@ -0,0 +1,224 @@
91.4 +#
91.5 +# IsaMakefile for HOLCF
91.6 +#
91.7 +
91.8 +## targets
91.9 +
91.10 +default: HOLCF
91.11 +images: HOLCF IOA
91.12 +test: \
91.13 + HOLCF-FOCUS \
91.14 + HOLCF-IMP \
91.15 + HOLCF-Library \
91.16 + HOLCF-Tutorial \
91.17 + HOLCF-ex \
91.18 + IOA-ABP \
91.19 + IOA-NTP \
91.20 + IOA-Storage \
91.21 + IOA-ex
91.22 +all: images test
91.23 +
91.24 +
91.25 +## global settings
91.26 +
91.27 +SRC = $(ISABELLE_HOME)/src
91.28 +OUT = $(ISABELLE_OUTPUT)
91.29 +LOG = $(OUT)/log
91.30 +
91.31 +
91.32 +## HOLCF
91.33 +
91.34 +HOLCF: HOL $(OUT)/HOLCF
91.35 +
91.36 +HOL:
91.37 + @cd $(SRC)/HOL; $(ISABELLE_TOOL) make HOL
91.38 +
91.39 +$(OUT)/HOLCF: $(OUT)/HOL \
91.40 + ROOT.ML \
91.41 + Adm.thy \
91.42 + Algebraic.thy \
91.43 + Bifinite.thy \
91.44 + Cfun.thy \
91.45 + CompactBasis.thy \
91.46 + Completion.thy \
91.47 + Cont.thy \
91.48 + ConvexPD.thy \
91.49 + Cpodef.thy \
91.50 + Cprod.thy \
91.51 + Discrete.thy \
91.52 + Deflation.thy \
91.53 + Domain.thy \
91.54 + Domain_Aux.thy \
91.55 + Fixrec.thy \
91.56 + Fix.thy \
91.57 + Fun_Cpo.thy \
91.58 + HOLCF.thy \
91.59 + Lift.thy \
91.60 + LowerPD.thy \
91.61 + Map_Functions.thy \
91.62 + One.thy \
91.63 + Pcpo.thy \
91.64 + Plain_HOLCF.thy \
91.65 + Porder.thy \
91.66 + Powerdomains.thy \
91.67 + Product_Cpo.thy \
91.68 + Sfun.thy \
91.69 + Sprod.thy \
91.70 + Ssum.thy \
91.71 + Tr.thy \
91.72 + Universal.thy \
91.73 + UpperPD.thy \
91.74 + Up.thy \
91.75 + Tools/cont_consts.ML \
91.76 + Tools/cont_proc.ML \
91.77 + Tools/holcf_library.ML \
91.78 + Tools/Domain/domain.ML \
91.79 + Tools/Domain/domain_axioms.ML \
91.80 + Tools/Domain/domain_constructors.ML \
91.81 + Tools/Domain/domain_induction.ML \
91.82 + Tools/Domain/domain_isomorphism.ML \
91.83 + Tools/Domain/domain_take_proofs.ML \
91.84 + Tools/cpodef.ML \
91.85 + Tools/domaindef.ML \
91.86 + Tools/fixrec.ML \
91.87 + document/root.tex
91.88 + @$(ISABELLE_TOOL) usedir -b -g true $(OUT)/HOL HOLCF
91.89 +
91.90 +
91.91 +## HOLCF-Tutorial
91.92 +
91.93 +HOLCF-Tutorial: HOLCF $(LOG)/HOLCF-Tutorial.gz
91.94 +
91.95 +$(LOG)/HOLCF-Tutorial.gz: $(OUT)/HOLCF \
91.96 + Tutorial/Domain_ex.thy \
91.97 + Tutorial/Fixrec_ex.thy \
91.98 + Tutorial/New_Domain.thy \
91.99 + Tutorial/document/root.tex \
91.100 + Tutorial/ROOT.ML
91.101 + @$(ISABELLE_TOOL) usedir $(OUT)/HOLCF Tutorial
91.102 +
91.103 +
91.104 +## HOLCF-Library
91.105 +
91.106 +HOLCF-Library: HOLCF $(LOG)/HOLCF-Library.gz
91.107 +
91.108 +$(LOG)/HOLCF-Library.gz: $(OUT)/HOLCF \
91.109 + Library/Defl_Bifinite.thy \
91.110 + Library/List_Cpo.thy \
91.111 + Library/Stream.thy \
91.112 + Library/Sum_Cpo.thy \
91.113 + Library/HOLCF_Library.thy \
91.114 + Library/ROOT.ML
91.115 + @$(ISABELLE_TOOL) usedir $(OUT)/HOLCF Library
91.116 +
91.117 +
91.118 +## HOLCF-IMP
91.119 +
91.120 +HOLCF-IMP: HOLCF $(LOG)/HOLCF-IMP.gz
91.121 +
91.122 +$(LOG)/HOLCF-IMP.gz: $(OUT)/HOLCF IMP/HoareEx.thy \
91.123 + IMP/Denotational.thy IMP/ROOT.ML IMP/document/root.tex
91.124 + @$(ISABELLE_TOOL) usedir $(OUT)/HOLCF IMP
91.125 +
91.126 +
91.127 +## HOLCF-ex
91.128 +
91.129 +HOLCF-ex: HOLCF $(LOG)/HOLCF-ex.gz
91.130 +
91.131 +$(LOG)/HOLCF-ex.gz: $(OUT)/HOLCF \
91.132 + ../Library/Nat_Infinity.thy \
91.133 + ex/Dagstuhl.thy \
91.134 + ex/Dnat.thy \
91.135 + ex/Domain_Proofs.thy \
91.136 + ex/Fix2.thy \
91.137 + ex/Focus_ex.thy \
91.138 + ex/Hoare.thy \
91.139 + ex/Letrec.thy \
91.140 + ex/Loop.thy \
91.141 + ex/Pattern_Match.thy \
91.142 + ex/Powerdomain_ex.thy \
91.143 + ex/ROOT.ML
91.144 + @$(ISABELLE_TOOL) usedir $(OUT)/HOLCF ex
91.145 +
91.146 +
91.147 +## HOLCF-FOCUS
91.148 +
91.149 +HOLCF-FOCUS: HOLCF $(LOG)/HOLCF-FOCUS.gz
91.150 +
91.151 +$(LOG)/HOLCF-FOCUS.gz: $(OUT)/HOLCF \
91.152 + Library/Stream.thy \
91.153 + FOCUS/Fstreams.thy \
91.154 + FOCUS/Fstream.thy FOCUS/FOCUS.thy \
91.155 + FOCUS/Stream_adm.thy ../Library/Continuity.thy \
91.156 + FOCUS/Buffer.thy FOCUS/Buffer_adm.thy
91.157 + @$(ISABELLE_TOOL) usedir $(OUT)/HOLCF FOCUS
91.158 +
91.159 +## IOA
91.160 +
91.161 +IOA: HOLCF $(OUT)/IOA
91.162 +
91.163 +$(OUT)/IOA: $(OUT)/HOLCF IOA/ROOT.ML IOA/meta_theory/Traces.thy \
91.164 + IOA/meta_theory/Asig.thy IOA/meta_theory/CompoScheds.thy \
91.165 + IOA/meta_theory/CompoTraces.thy IOA/meta_theory/Seq.thy \
91.166 + IOA/meta_theory/RefCorrectness.thy IOA/meta_theory/Automata.thy \
91.167 + IOA/meta_theory/ShortExecutions.thy IOA/meta_theory/IOA.thy \
91.168 + IOA/meta_theory/Sequence.thy IOA/meta_theory/CompoExecs.thy \
91.169 + IOA/meta_theory/RefMappings.thy IOA/meta_theory/Compositionality.thy \
91.170 + IOA/meta_theory/TL.thy IOA/meta_theory/TLS.thy \
91.171 + IOA/meta_theory/LiveIOA.thy IOA/meta_theory/Pred.thy \
91.172 + IOA/meta_theory/Abstraction.thy IOA/meta_theory/Simulations.thy \
91.173 + IOA/meta_theory/SimCorrectness.thy
91.174 + @cd IOA; $(ISABELLE_TOOL) usedir -b $(OUT)/HOLCF IOA
91.175 +
91.176 +
91.177 +## IOA-ABP
91.178 +
91.179 +IOA-ABP: IOA $(LOG)/IOA-ABP.gz
91.180 +
91.181 +$(LOG)/IOA-ABP.gz: $(OUT)/IOA IOA/ABP/Abschannel.thy \
91.182 + IOA/ABP/Abschannel_finite.thy IOA/ABP/Action.thy \
91.183 + IOA/ABP/Check.ML IOA/ABP/Correctness.thy \
91.184 + IOA/ABP/Env.thy IOA/ABP/Impl.thy IOA/ABP/Impl_finite.thy \
91.185 + IOA/ABP/Lemmas.thy IOA/ABP/Packet.thy \
91.186 + IOA/ABP/ROOT.ML IOA/ABP/Receiver.thy IOA/ABP/Sender.thy \
91.187 + IOA/ABP/Spec.thy
91.188 + @cd IOA; $(ISABELLE_TOOL) usedir $(OUT)/IOA ABP
91.189 +
91.190 +## IOA-NTP
91.191 +
91.192 +IOA-NTP: IOA $(LOG)/IOA-NTP.gz
91.193 +
91.194 +$(LOG)/IOA-NTP.gz: $(OUT)/IOA \
91.195 + IOA/NTP/Abschannel.thy IOA/NTP/Action.thy IOA/NTP/Correctness.thy \
91.196 + IOA/NTP/Impl.thy IOA/NTP/Lemmas.thy IOA/NTP/Multiset.thy \
91.197 + IOA/NTP/Packet.thy IOA/NTP/ROOT.ML IOA/NTP/Receiver.thy IOA/NTP/Sender.thy \
91.198 + IOA/NTP/Spec.thy
91.199 + @cd IOA; $(ISABELLE_TOOL) usedir $(OUT)/IOA NTP
91.200 +
91.201 +
91.202 +## IOA-Storage
91.203 +
91.204 +IOA-Storage: IOA $(LOG)/IOA-Storage.gz
91.205 +
91.206 +$(LOG)/IOA-Storage.gz: $(OUT)/IOA IOA/Storage/Action.thy \
91.207 + IOA/Storage/Correctness.thy IOA/Storage/Impl.thy \
91.208 + IOA/Storage/ROOT.ML IOA/Storage/Spec.thy
91.209 + @cd IOA; $(ISABELLE_TOOL) usedir $(OUT)/IOA Storage
91.210 +
91.211 +
91.212 +## IOA-ex
91.213 +
91.214 +IOA-ex: IOA $(LOG)/IOA-ex.gz
91.215 +
91.216 +$(LOG)/IOA-ex.gz: $(OUT)/IOA IOA/ex/ROOT.ML IOA/ex/TrivEx.thy IOA/ex/TrivEx2.thy
91.217 + @cd IOA; $(ISABELLE_TOOL) usedir $(OUT)/IOA ex
91.218 +
91.219 +
91.220 +## clean
91.221 +
91.222 +clean:
91.223 + @rm -f $(OUT)/HOLCF $(LOG)/HOLCF.gz $(LOG)/HOLCF-IMP.gz \
91.224 + $(LOG)/HOLCF-ex.gz $(LOG)/HOLCF-FOCUS.gz $(OUT)/IOA \
91.225 + $(LOG)/IOA.gz $(LOG)/IOA-ABP.gz $(LOG)/IOA-NTP.gz \
91.226 + $(LOG)/IOA-Storage.gz $(LOG)/HOLCF-Library.gz \
91.227 + $(LOG)/IOA-ex.gz $(LOG)/HOLCF-Tutorial.gz
92.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
92.2 +++ b/src/HOL/HOLCF/Library/Defl_Bifinite.thy Sat Nov 27 16:08:10 2010 -0800
92.3 @@ -0,0 +1,661 @@
92.4 +(* Title: HOLCF/Library/Defl_Bifinite.thy
92.5 + Author: Brian Huffman
92.6 +*)
92.7 +
92.8 +header {* Algebraic deflations are a bifinite domain *}
92.9 +
92.10 +theory Defl_Bifinite
92.11 +imports HOLCF Infinite_Set
92.12 +begin
92.13 +
92.14 +subsection {* Lemmas about MOST *}
92.15 +
92.16 +default_sort type
92.17 +
92.18 +lemma MOST_INFM:
92.19 + assumes inf: "infinite (UNIV::'a set)"
92.20 + shows "MOST x::'a. P x \<Longrightarrow> INFM x::'a. P x"
92.21 + unfolding Alm_all_def Inf_many_def
92.22 + apply (auto simp add: Collect_neg_eq)
92.23 + apply (drule (1) finite_UnI)
92.24 + apply (simp add: Compl_partition2 inf)
92.25 + done
92.26 +
92.27 +lemma MOST_SucI: "MOST n. P n \<Longrightarrow> MOST n. P (Suc n)"
92.28 +by (rule MOST_inj [OF _ inj_Suc])
92.29 +
92.30 +lemma MOST_SucD: "MOST n. P (Suc n) \<Longrightarrow> MOST n. P n"
92.31 +unfolding MOST_nat
92.32 +apply (clarify, rule_tac x="Suc m" in exI, clarify)
92.33 +apply (erule Suc_lessE, simp)
92.34 +done
92.35 +
92.36 +lemma MOST_Suc_iff: "(MOST n. P (Suc n)) \<longleftrightarrow> (MOST n. P n)"
92.37 +by (rule iffI [OF MOST_SucD MOST_SucI])
92.38 +
92.39 +lemma INFM_finite_Bex_distrib:
92.40 + "finite A \<Longrightarrow> (INFM y. \<exists>x\<in>A. P x y) \<longleftrightarrow> (\<exists>x\<in>A. INFM y. P x y)"
92.41 +by (induct set: finite, simp, simp add: INFM_disj_distrib)
92.42 +
92.43 +lemma MOST_finite_Ball_distrib:
92.44 + "finite A \<Longrightarrow> (MOST y. \<forall>x\<in>A. P x y) \<longleftrightarrow> (\<forall>x\<in>A. MOST y. P x y)"
92.45 +by (induct set: finite, simp, simp add: MOST_conj_distrib)
92.46 +
92.47 +lemma MOST_ge_nat: "MOST n::nat. m \<le> n"
92.48 +unfolding MOST_nat_le by fast
92.49 +
92.50 +subsection {* Eventually constant sequences *}
92.51 +
92.52 +definition
92.53 + eventually_constant :: "(nat \<Rightarrow> 'a) \<Rightarrow> bool"
92.54 +where
92.55 + "eventually_constant S = (\<exists>x. MOST i. S i = x)"
92.56 +
92.57 +lemma eventually_constant_MOST_MOST:
92.58 + "eventually_constant S \<longleftrightarrow> (MOST m. MOST n. S n = S m)"
92.59 +unfolding eventually_constant_def MOST_nat
92.60 +apply safe
92.61 +apply (rule_tac x=m in exI, clarify)
92.62 +apply (rule_tac x=m in exI, clarify)
92.63 +apply simp
92.64 +apply fast
92.65 +done
92.66 +
92.67 +lemma eventually_constantI: "MOST i. S i = x \<Longrightarrow> eventually_constant S"
92.68 +unfolding eventually_constant_def by fast
92.69 +
92.70 +lemma eventually_constant_comp:
92.71 + "eventually_constant (\<lambda>i. S i) \<Longrightarrow> eventually_constant (\<lambda>i. f (S i))"
92.72 +unfolding eventually_constant_def
92.73 +apply (erule exE, rule_tac x="f x" in exI)
92.74 +apply (erule MOST_mono, simp)
92.75 +done
92.76 +
92.77 +lemma eventually_constant_Suc_iff:
92.78 + "eventually_constant (\<lambda>i. S (Suc i)) \<longleftrightarrow> eventually_constant (\<lambda>i. S i)"
92.79 +unfolding eventually_constant_def
92.80 +by (subst MOST_Suc_iff, rule refl)
92.81 +
92.82 +lemma eventually_constant_SucD:
92.83 + "eventually_constant (\<lambda>i. S (Suc i)) \<Longrightarrow> eventually_constant (\<lambda>i. S i)"
92.84 +by (rule eventually_constant_Suc_iff [THEN iffD1])
92.85 +
92.86 +subsection {* Limits of eventually constant sequences *}
92.87 +
92.88 +definition
92.89 + eventual :: "(nat \<Rightarrow> 'a) \<Rightarrow> 'a" where
92.90 + "eventual S = (THE x. MOST i. S i = x)"
92.91 +
92.92 +lemma eventual_eqI: "MOST i. S i = x \<Longrightarrow> eventual S = x"
92.93 +unfolding eventual_def
92.94 +apply (rule the_equality, assumption)
92.95 +apply (rename_tac y)
92.96 +apply (subgoal_tac "MOST i::nat. y = x", simp)
92.97 +apply (erule MOST_rev_mp)
92.98 +apply (erule MOST_rev_mp)
92.99 +apply simp
92.100 +done
92.101 +
92.102 +lemma MOST_eq_eventual:
92.103 + "eventually_constant S \<Longrightarrow> MOST i. S i = eventual S"
92.104 +unfolding eventually_constant_def
92.105 +by (erule exE, simp add: eventual_eqI)
92.106 +
92.107 +lemma eventual_mem_range:
92.108 + "eventually_constant S \<Longrightarrow> eventual S \<in> range S"
92.109 +apply (drule MOST_eq_eventual)
92.110 +apply (simp only: MOST_nat_le, clarify)
92.111 +apply (drule spec, drule mp, rule order_refl)
92.112 +apply (erule range_eqI [OF sym])
92.113 +done
92.114 +
92.115 +lemma eventually_constant_MOST_iff:
92.116 + assumes S: "eventually_constant S"
92.117 + shows "(MOST n. P (S n)) \<longleftrightarrow> P (eventual S)"
92.118 +apply (subgoal_tac "(MOST n. P (S n)) \<longleftrightarrow> (MOST n::nat. P (eventual S))")
92.119 +apply simp
92.120 +apply (rule iffI)
92.121 +apply (rule MOST_rev_mp [OF MOST_eq_eventual [OF S]])
92.122 +apply (erule MOST_mono, force)
92.123 +apply (rule MOST_rev_mp [OF MOST_eq_eventual [OF S]])
92.124 +apply (erule MOST_mono, simp)
92.125 +done
92.126 +
92.127 +lemma MOST_eventual:
92.128 + "\<lbrakk>eventually_constant S; MOST n. P (S n)\<rbrakk> \<Longrightarrow> P (eventual S)"
92.129 +proof -
92.130 + assume "eventually_constant S"
92.131 + hence "MOST n. S n = eventual S"
92.132 + by (rule MOST_eq_eventual)
92.133 + moreover assume "MOST n. P (S n)"
92.134 + ultimately have "MOST n. S n = eventual S \<and> P (S n)"
92.135 + by (rule MOST_conj_distrib [THEN iffD2, OF conjI])
92.136 + hence "MOST n::nat. P (eventual S)"
92.137 + by (rule MOST_mono) auto
92.138 + thus ?thesis by simp
92.139 +qed
92.140 +
92.141 +lemma eventually_constant_MOST_Suc_eq:
92.142 + "eventually_constant S \<Longrightarrow> MOST n. S (Suc n) = S n"
92.143 +apply (drule MOST_eq_eventual)
92.144 +apply (frule MOST_Suc_iff [THEN iffD2])
92.145 +apply (erule MOST_rev_mp)
92.146 +apply (erule MOST_rev_mp)
92.147 +apply simp
92.148 +done
92.149 +
92.150 +lemma eventual_comp:
92.151 + "eventually_constant S \<Longrightarrow> eventual (\<lambda>i. f (S i)) = f (eventual (\<lambda>i. S i))"
92.152 +apply (rule eventual_eqI)
92.153 +apply (rule MOST_mono)
92.154 +apply (erule MOST_eq_eventual)
92.155 +apply simp
92.156 +done
92.157 +
92.158 +subsection {* Constructing finite deflations by iteration *}
92.159 +
92.160 +default_sort cpo
92.161 +
92.162 +lemma le_Suc_induct:
92.163 + assumes le: "i \<le> j"
92.164 + assumes step: "\<And>i. P i (Suc i)"
92.165 + assumes refl: "\<And>i. P i i"
92.166 + assumes trans: "\<And>i j k. \<lbrakk>P i j; P j k\<rbrakk> \<Longrightarrow> P i k"
92.167 + shows "P i j"
92.168 +proof (cases "i = j")
92.169 + assume "i = j"
92.170 + thus "P i j" by (simp add: refl)
92.171 +next
92.172 + assume "i \<noteq> j"
92.173 + with le have "i < j" by simp
92.174 + thus "P i j" using step trans by (rule less_Suc_induct)
92.175 +qed
92.176 +
92.177 +definition
92.178 + eventual_iterate :: "('a \<rightarrow> 'a::cpo) \<Rightarrow> ('a \<rightarrow> 'a)"
92.179 +where
92.180 + "eventual_iterate f = eventual (\<lambda>n. iterate n\<cdot>f)"
92.181 +
92.182 +text {* A pre-deflation is like a deflation, but not idempotent. *}
92.183 +
92.184 +locale pre_deflation =
92.185 + fixes f :: "'a \<rightarrow> 'a::cpo"
92.186 + assumes below: "\<And>x. f\<cdot>x \<sqsubseteq> x"
92.187 + assumes finite_range: "finite (range (\<lambda>x. f\<cdot>x))"
92.188 +begin
92.189 +
92.190 +lemma iterate_below: "iterate i\<cdot>f\<cdot>x \<sqsubseteq> x"
92.191 +by (induct i, simp_all add: below_trans [OF below])
92.192 +
92.193 +lemma iterate_fixed: "f\<cdot>x = x \<Longrightarrow> iterate i\<cdot>f\<cdot>x = x"
92.194 +by (induct i, simp_all)
92.195 +
92.196 +lemma antichain_iterate_app: "i \<le> j \<Longrightarrow> iterate j\<cdot>f\<cdot>x \<sqsubseteq> iterate i\<cdot>f\<cdot>x"
92.197 +apply (erule le_Suc_induct)
92.198 +apply (simp add: below)
92.199 +apply (rule below_refl)
92.200 +apply (erule (1) below_trans)
92.201 +done
92.202 +
92.203 +lemma finite_range_iterate_app: "finite (range (\<lambda>i. iterate i\<cdot>f\<cdot>x))"
92.204 +proof (rule finite_subset)
92.205 + show "range (\<lambda>i. iterate i\<cdot>f\<cdot>x) \<subseteq> insert x (range (\<lambda>x. f\<cdot>x))"
92.206 + by (clarify, case_tac i, simp_all)
92.207 + show "finite (insert x (range (\<lambda>x. f\<cdot>x)))"
92.208 + by (simp add: finite_range)
92.209 +qed
92.210 +
92.211 +lemma eventually_constant_iterate_app:
92.212 + "eventually_constant (\<lambda>i. iterate i\<cdot>f\<cdot>x)"
92.213 +unfolding eventually_constant_def MOST_nat_le
92.214 +proof -
92.215 + let ?Y = "\<lambda>i. iterate i\<cdot>f\<cdot>x"
92.216 + have "\<exists>j. \<forall>k. ?Y j \<sqsubseteq> ?Y k"
92.217 + apply (rule finite_range_has_max)
92.218 + apply (erule antichain_iterate_app)
92.219 + apply (rule finite_range_iterate_app)
92.220 + done
92.221 + then obtain j where j: "\<And>k. ?Y j \<sqsubseteq> ?Y k" by fast
92.222 + show "\<exists>z m. \<forall>n\<ge>m. ?Y n = z"
92.223 + proof (intro exI allI impI)
92.224 + fix k
92.225 + assume "j \<le> k"
92.226 + hence "?Y k \<sqsubseteq> ?Y j" by (rule antichain_iterate_app)
92.227 + also have "?Y j \<sqsubseteq> ?Y k" by (rule j)
92.228 + finally show "?Y k = ?Y j" .
92.229 + qed
92.230 +qed
92.231 +
92.232 +lemma eventually_constant_iterate:
92.233 + "eventually_constant (\<lambda>n. iterate n\<cdot>f)"
92.234 +proof -
92.235 + have "\<forall>y\<in>range (\<lambda>x. f\<cdot>x). eventually_constant (\<lambda>i. iterate i\<cdot>f\<cdot>y)"
92.236 + by (simp add: eventually_constant_iterate_app)
92.237 + hence "\<forall>y\<in>range (\<lambda>x. f\<cdot>x). MOST i. MOST j. iterate j\<cdot>f\<cdot>y = iterate i\<cdot>f\<cdot>y"
92.238 + unfolding eventually_constant_MOST_MOST .
92.239 + hence "MOST i. MOST j. \<forall>y\<in>range (\<lambda>x. f\<cdot>x). iterate j\<cdot>f\<cdot>y = iterate i\<cdot>f\<cdot>y"
92.240 + by (simp only: MOST_finite_Ball_distrib [OF finite_range])
92.241 + hence "MOST i. MOST j. \<forall>x. iterate j\<cdot>f\<cdot>(f\<cdot>x) = iterate i\<cdot>f\<cdot>(f\<cdot>x)"
92.242 + by simp
92.243 + hence "MOST i. MOST j. \<forall>x. iterate (Suc j)\<cdot>f\<cdot>x = iterate (Suc i)\<cdot>f\<cdot>x"
92.244 + by (simp only: iterate_Suc2)
92.245 + hence "MOST i. MOST j. iterate (Suc j)\<cdot>f = iterate (Suc i)\<cdot>f"
92.246 + by (simp only: cfun_eq_iff)
92.247 + hence "eventually_constant (\<lambda>i. iterate (Suc i)\<cdot>f)"
92.248 + unfolding eventually_constant_MOST_MOST .
92.249 + thus "eventually_constant (\<lambda>i. iterate i\<cdot>f)"
92.250 + by (rule eventually_constant_SucD)
92.251 +qed
92.252 +
92.253 +abbreviation
92.254 + d :: "'a \<rightarrow> 'a"
92.255 +where
92.256 + "d \<equiv> eventual_iterate f"
92.257 +
92.258 +lemma MOST_d: "MOST n. P (iterate n\<cdot>f) \<Longrightarrow> P d"
92.259 +unfolding eventual_iterate_def
92.260 +using eventually_constant_iterate by (rule MOST_eventual)
92.261 +
92.262 +lemma f_d: "f\<cdot>(d\<cdot>x) = d\<cdot>x"
92.263 +apply (rule MOST_d)
92.264 +apply (subst iterate_Suc [symmetric])
92.265 +apply (rule eventually_constant_MOST_Suc_eq)
92.266 +apply (rule eventually_constant_iterate_app)
92.267 +done
92.268 +
92.269 +lemma d_fixed_iff: "d\<cdot>x = x \<longleftrightarrow> f\<cdot>x = x"
92.270 +proof
92.271 + assume "d\<cdot>x = x"
92.272 + with f_d [where x=x]
92.273 + show "f\<cdot>x = x" by simp
92.274 +next
92.275 + assume f: "f\<cdot>x = x"
92.276 + have "\<forall>n. iterate n\<cdot>f\<cdot>x = x"
92.277 + by (rule allI, rule nat.induct, simp, simp add: f)
92.278 + hence "MOST n. iterate n\<cdot>f\<cdot>x = x"
92.279 + by (rule ALL_MOST)
92.280 + thus "d\<cdot>x = x"
92.281 + by (rule MOST_d)
92.282 +qed
92.283 +
92.284 +lemma finite_deflation_d: "finite_deflation d"
92.285 +proof
92.286 + fix x :: 'a
92.287 + have "d \<in> range (\<lambda>n. iterate n\<cdot>f)"
92.288 + unfolding eventual_iterate_def
92.289 + using eventually_constant_iterate
92.290 + by (rule eventual_mem_range)
92.291 + then obtain n where n: "d = iterate n\<cdot>f" ..
92.292 + have "iterate n\<cdot>f\<cdot>(d\<cdot>x) = d\<cdot>x"
92.293 + using f_d by (rule iterate_fixed)
92.294 + thus "d\<cdot>(d\<cdot>x) = d\<cdot>x"
92.295 + by (simp add: n)
92.296 +next
92.297 + fix x :: 'a
92.298 + show "d\<cdot>x \<sqsubseteq> x"
92.299 + by (rule MOST_d, simp add: iterate_below)
92.300 +next
92.301 + from finite_range
92.302 + have "finite {x. f\<cdot>x = x}"
92.303 + by (rule finite_range_imp_finite_fixes)
92.304 + thus "finite {x. d\<cdot>x = x}"
92.305 + by (simp add: d_fixed_iff)
92.306 +qed
92.307 +
92.308 +lemma deflation_d: "deflation d"
92.309 +using finite_deflation_d
92.310 +by (rule finite_deflation_imp_deflation)
92.311 +
92.312 +end
92.313 +
92.314 +lemma finite_deflation_eventual_iterate:
92.315 + "pre_deflation d \<Longrightarrow> finite_deflation (eventual_iterate d)"
92.316 +by (rule pre_deflation.finite_deflation_d)
92.317 +
92.318 +lemma pre_deflation_oo:
92.319 + assumes "finite_deflation d"
92.320 + assumes f: "\<And>x. f\<cdot>x \<sqsubseteq> x"
92.321 + shows "pre_deflation (d oo f)"
92.322 +proof
92.323 + interpret d: finite_deflation d by fact
92.324 + fix x
92.325 + show "\<And>x. (d oo f)\<cdot>x \<sqsubseteq> x"
92.326 + by (simp, rule below_trans [OF d.below f])
92.327 + show "finite (range (\<lambda>x. (d oo f)\<cdot>x))"
92.328 + by (rule finite_subset [OF _ d.finite_range], auto)
92.329 +qed
92.330 +
92.331 +lemma eventual_iterate_oo_fixed_iff:
92.332 + assumes "finite_deflation d"
92.333 + assumes f: "\<And>x. f\<cdot>x \<sqsubseteq> x"
92.334 + shows "eventual_iterate (d oo f)\<cdot>x = x \<longleftrightarrow> d\<cdot>x = x \<and> f\<cdot>x = x"
92.335 +proof -
92.336 + interpret d: finite_deflation d by fact
92.337 + let ?e = "d oo f"
92.338 + interpret e: pre_deflation "d oo f"
92.339 + using `finite_deflation d` f
92.340 + by (rule pre_deflation_oo)
92.341 + let ?g = "eventual (\<lambda>n. iterate n\<cdot>?e)"
92.342 + show ?thesis
92.343 + apply (subst e.d_fixed_iff)
92.344 + apply simp
92.345 + apply safe
92.346 + apply (erule subst)
92.347 + apply (rule d.idem)
92.348 + apply (rule below_antisym)
92.349 + apply (rule f)
92.350 + apply (erule subst, rule d.below)
92.351 + apply simp
92.352 + done
92.353 +qed
92.354 +
92.355 +lemma eventual_mono:
92.356 + assumes A: "eventually_constant A"
92.357 + assumes B: "eventually_constant B"
92.358 + assumes below: "\<And>n. A n \<sqsubseteq> B n"
92.359 + shows "eventual A \<sqsubseteq> eventual B"
92.360 +proof -
92.361 + from A have "MOST n. A n = eventual A"
92.362 + by (rule MOST_eq_eventual)
92.363 + then have "MOST n. eventual A \<sqsubseteq> B n"
92.364 + by (rule MOST_mono) (erule subst, rule below)
92.365 + with B show "eventual A \<sqsubseteq> eventual B"
92.366 + by (rule MOST_eventual)
92.367 +qed
92.368 +
92.369 +lemma eventual_iterate_mono:
92.370 + assumes f: "pre_deflation f" and g: "pre_deflation g" and "f \<sqsubseteq> g"
92.371 + shows "eventual_iterate f \<sqsubseteq> eventual_iterate g"
92.372 +unfolding eventual_iterate_def
92.373 +apply (rule eventual_mono)
92.374 +apply (rule pre_deflation.eventually_constant_iterate [OF f])
92.375 +apply (rule pre_deflation.eventually_constant_iterate [OF g])
92.376 +apply (rule monofun_cfun_arg [OF `f \<sqsubseteq> g`])
92.377 +done
92.378 +
92.379 +lemma cont2cont_eventual_iterate_oo:
92.380 + assumes d: "finite_deflation d"
92.381 + assumes cont: "cont f" and below: "\<And>x y. f x\<cdot>y \<sqsubseteq> y"
92.382 + shows "cont (\<lambda>x. eventual_iterate (d oo f x))"
92.383 + (is "cont ?e")
92.384 +proof (rule contI2)
92.385 + show "monofun ?e"
92.386 + apply (rule monofunI)
92.387 + apply (rule eventual_iterate_mono)
92.388 + apply (rule pre_deflation_oo [OF d below])
92.389 + apply (rule pre_deflation_oo [OF d below])
92.390 + apply (rule monofun_cfun_arg)
92.391 + apply (erule cont2monofunE [OF cont])
92.392 + done
92.393 +next
92.394 + fix Y :: "nat \<Rightarrow> 'b"
92.395 + assume Y: "chain Y"
92.396 + with cont have fY: "chain (\<lambda>i. f (Y i))"
92.397 + by (rule ch2ch_cont)
92.398 + assume eY: "chain (\<lambda>i. ?e (Y i))"
92.399 + have lub_below: "\<And>x. f (\<Squnion>i. Y i)\<cdot>x \<sqsubseteq> x"
92.400 + by (rule admD [OF _ Y], simp add: cont, rule below)
92.401 + have "deflation (?e (\<Squnion>i. Y i))"
92.402 + apply (rule pre_deflation.deflation_d)
92.403 + apply (rule pre_deflation_oo [OF d lub_below])
92.404 + done
92.405 + then show "?e (\<Squnion>i. Y i) \<sqsubseteq> (\<Squnion>i. ?e (Y i))"
92.406 + proof (rule deflation.belowI)
92.407 + fix x :: 'a
92.408 + assume "?e (\<Squnion>i. Y i)\<cdot>x = x"
92.409 + hence "d\<cdot>x = x" and "f (\<Squnion>i. Y i)\<cdot>x = x"
92.410 + by (simp_all add: eventual_iterate_oo_fixed_iff [OF d lub_below])
92.411 + hence "(\<Squnion>i. f (Y i)\<cdot>x) = x"
92.412 + apply (simp only: cont2contlubE [OF cont Y])
92.413 + apply (simp only: contlub_cfun_fun [OF fY])
92.414 + done
92.415 + have "compact (d\<cdot>x)"
92.416 + using d by (rule finite_deflation.compact)
92.417 + then have "compact x"
92.418 + using `d\<cdot>x = x` by simp
92.419 + then have "compact (\<Squnion>i. f (Y i)\<cdot>x)"
92.420 + using `(\<Squnion>i. f (Y i)\<cdot>x) = x` by simp
92.421 + then have "\<exists>n. max_in_chain n (\<lambda>i. f (Y i)\<cdot>x)"
92.422 + by - (rule compact_imp_max_in_chain, simp add: fY, assumption)
92.423 + then obtain n where n: "max_in_chain n (\<lambda>i. f (Y i)\<cdot>x)" ..
92.424 + then have "f (Y n)\<cdot>x = x"
92.425 + using `(\<Squnion>i. f (Y i)\<cdot>x) = x` fY by (simp add: maxinch_is_thelub)
92.426 + with `d\<cdot>x = x` have "?e (Y n)\<cdot>x = x"
92.427 + by (simp add: eventual_iterate_oo_fixed_iff [OF d below])
92.428 + moreover have "?e (Y n)\<cdot>x \<sqsubseteq> (\<Squnion>i. ?e (Y i)\<cdot>x)"
92.429 + by (rule is_ub_thelub, simp add: eY)
92.430 + ultimately have "x \<sqsubseteq> (\<Squnion>i. ?e (Y i))\<cdot>x"
92.431 + by (simp add: contlub_cfun_fun eY)
92.432 + also have "(\<Squnion>i. ?e (Y i))\<cdot>x \<sqsubseteq> x"
92.433 + apply (rule deflation.below)
92.434 + apply (rule admD [OF adm_deflation eY])
92.435 + apply (rule pre_deflation.deflation_d)
92.436 + apply (rule pre_deflation_oo [OF d below])
92.437 + done
92.438 + finally show "(\<Squnion>i. ?e (Y i))\<cdot>x = x" ..
92.439 + qed
92.440 +qed
92.441 +
92.442 +subsection {* Take function for finite deflations *}
92.443 +
92.444 +definition
92.445 + defl_take :: "nat \<Rightarrow> (udom \<rightarrow> udom) \<Rightarrow> (udom \<rightarrow> udom)"
92.446 +where
92.447 + "defl_take i d = eventual_iterate (udom_approx i oo d)"
92.448 +
92.449 +lemma finite_deflation_defl_take:
92.450 + "deflation d \<Longrightarrow> finite_deflation (defl_take i d)"
92.451 +unfolding defl_take_def
92.452 +apply (rule pre_deflation.finite_deflation_d)
92.453 +apply (rule pre_deflation_oo)
92.454 +apply (rule finite_deflation_udom_approx)
92.455 +apply (erule deflation.below)
92.456 +done
92.457 +
92.458 +lemma deflation_defl_take:
92.459 + "deflation d \<Longrightarrow> deflation (defl_take i d)"
92.460 +apply (rule finite_deflation_imp_deflation)
92.461 +apply (erule finite_deflation_defl_take)
92.462 +done
92.463 +
92.464 +lemma defl_take_fixed_iff:
92.465 + "deflation d \<Longrightarrow> defl_take i d\<cdot>x = x \<longleftrightarrow> udom_approx i\<cdot>x = x \<and> d\<cdot>x = x"
92.466 +unfolding defl_take_def
92.467 +apply (rule eventual_iterate_oo_fixed_iff)
92.468 +apply (rule finite_deflation_udom_approx)
92.469 +apply (erule deflation.below)
92.470 +done
92.471 +
92.472 +lemma defl_take_below:
92.473 + "\<lbrakk>a \<sqsubseteq> b; deflation a; deflation b\<rbrakk> \<Longrightarrow> defl_take i a \<sqsubseteq> defl_take i b"
92.474 +apply (rule deflation.belowI)
92.475 +apply (erule deflation_defl_take)
92.476 +apply (simp add: defl_take_fixed_iff)
92.477 +apply (erule (1) deflation.belowD)
92.478 +apply (erule conjunct2)
92.479 +done
92.480 +
92.481 +lemma cont2cont_defl_take:
92.482 + assumes cont: "cont f" and below: "\<And>x y. f x\<cdot>y \<sqsubseteq> y"
92.483 + shows "cont (\<lambda>x. defl_take i (f x))"
92.484 +unfolding defl_take_def
92.485 +using finite_deflation_udom_approx assms
92.486 +by (rule cont2cont_eventual_iterate_oo)
92.487 +
92.488 +definition
92.489 + fd_take :: "nat \<Rightarrow> fin_defl \<Rightarrow> fin_defl"
92.490 +where
92.491 + "fd_take i d = Abs_fin_defl (defl_take i (Rep_fin_defl d))"
92.492 +
92.493 +lemma Rep_fin_defl_fd_take:
92.494 + "Rep_fin_defl (fd_take i d) = defl_take i (Rep_fin_defl d)"
92.495 +unfolding fd_take_def
92.496 +apply (rule Abs_fin_defl_inverse [unfolded mem_Collect_eq])
92.497 +apply (rule finite_deflation_defl_take)
92.498 +apply (rule deflation_Rep_fin_defl)
92.499 +done
92.500 +
92.501 +lemma fd_take_fixed_iff:
92.502 + "Rep_fin_defl (fd_take i d)\<cdot>x = x \<longleftrightarrow>
92.503 + udom_approx i\<cdot>x = x \<and> Rep_fin_defl d\<cdot>x = x"
92.504 +unfolding Rep_fin_defl_fd_take
92.505 +apply (rule defl_take_fixed_iff)
92.506 +apply (rule deflation_Rep_fin_defl)
92.507 +done
92.508 +
92.509 +lemma fd_take_below: "fd_take n d \<sqsubseteq> d"
92.510 +apply (rule fin_defl_belowI)
92.511 +apply (simp add: fd_take_fixed_iff)
92.512 +done
92.513 +
92.514 +lemma fd_take_idem: "fd_take n (fd_take n d) = fd_take n d"
92.515 +apply (rule fin_defl_eqI)
92.516 +apply (simp add: fd_take_fixed_iff)
92.517 +done
92.518 +
92.519 +lemma fd_take_mono: "a \<sqsubseteq> b \<Longrightarrow> fd_take n a \<sqsubseteq> fd_take n b"
92.520 +apply (rule fin_defl_belowI)
92.521 +apply (simp add: fd_take_fixed_iff)
92.522 +apply (simp add: fin_defl_belowD)
92.523 +done
92.524 +
92.525 +lemma approx_fixed_le_lemma: "\<lbrakk>i \<le> j; udom_approx i\<cdot>x = x\<rbrakk> \<Longrightarrow> udom_approx j\<cdot>x = x"
92.526 +apply (rule deflation.belowD)
92.527 +apply (rule finite_deflation_imp_deflation)
92.528 +apply (rule finite_deflation_udom_approx)
92.529 +apply (erule chain_mono [OF chain_udom_approx])
92.530 +apply assumption
92.531 +done
92.532 +
92.533 +lemma fd_take_chain: "m \<le> n \<Longrightarrow> fd_take m a \<sqsubseteq> fd_take n a"
92.534 +apply (rule fin_defl_belowI)
92.535 +apply (simp add: fd_take_fixed_iff)
92.536 +apply (simp add: approx_fixed_le_lemma)
92.537 +done
92.538 +
92.539 +lemma finite_range_fd_take: "finite (range (fd_take n))"
92.540 +apply (rule finite_imageD [where f="\<lambda>a. {x. Rep_fin_defl a\<cdot>x = x}"])
92.541 +apply (rule finite_subset [where B="Pow {x. udom_approx n\<cdot>x = x}"])
92.542 +apply (clarify, simp add: fd_take_fixed_iff)
92.543 +apply (simp add: finite_deflation.finite_fixes [OF finite_deflation_udom_approx])
92.544 +apply (rule inj_onI, clarify)
92.545 +apply (simp add: set_eq_iff fin_defl_eqI)
92.546 +done
92.547 +
92.548 +lemma fd_take_covers: "\<exists>n. fd_take n a = a"
92.549 +apply (rule_tac x=
92.550 + "Max ((\<lambda>x. LEAST n. udom_approx n\<cdot>x = x) ` {x. Rep_fin_defl a\<cdot>x = x})" in exI)
92.551 +apply (rule below_antisym)
92.552 +apply (rule fd_take_below)
92.553 +apply (rule fin_defl_belowI)
92.554 +apply (simp add: fd_take_fixed_iff)
92.555 +apply (rule approx_fixed_le_lemma)
92.556 +apply (rule Max_ge)
92.557 +apply (rule finite_imageI)
92.558 +apply (rule Rep_fin_defl.finite_fixes)
92.559 +apply (rule imageI)
92.560 +apply (erule CollectI)
92.561 +apply (rule LeastI_ex)
92.562 +apply (rule approx_chain.compact_eq_approx [OF udom_approx])
92.563 +apply (erule subst)
92.564 +apply (rule Rep_fin_defl.compact)
92.565 +done
92.566 +
92.567 +subsection {* Chain of approx functions on algebraic deflations *}
92.568 +
92.569 +definition
92.570 + defl_approx :: "nat \<Rightarrow> defl \<rightarrow> defl"
92.571 +where
92.572 + "defl_approx = (\<lambda>i. defl.basis_fun (\<lambda>d. defl_principal (fd_take i d)))"
92.573 +
92.574 +lemma defl_approx_principal:
92.575 + "defl_approx i\<cdot>(defl_principal d) = defl_principal (fd_take i d)"
92.576 +unfolding defl_approx_def
92.577 +by (simp add: defl.basis_fun_principal fd_take_mono)
92.578 +
92.579 +lemma defl_approx: "approx_chain defl_approx"
92.580 +proof
92.581 + show chain: "chain defl_approx"
92.582 + unfolding defl_approx_def
92.583 + by (simp add: chainI defl.basis_fun_mono fd_take_mono fd_take_chain)
92.584 + show idem: "\<And>i x. defl_approx i\<cdot>(defl_approx i\<cdot>x) = defl_approx i\<cdot>x"
92.585 + apply (induct_tac x rule: defl.principal_induct, simp)
92.586 + apply (simp add: defl_approx_principal fd_take_idem)
92.587 + done
92.588 + show below: "\<And>i x. defl_approx i\<cdot>x \<sqsubseteq> x"
92.589 + apply (induct_tac x rule: defl.principal_induct, simp)
92.590 + apply (simp add: defl_approx_principal fd_take_below)
92.591 + done
92.592 + show lub: "(\<Squnion>i. defl_approx i) = ID"
92.593 + apply (rule cfun_eqI, rule below_antisym)
92.594 + apply (simp add: contlub_cfun_fun chain lub_below_iff chain below)
92.595 + apply (induct_tac x rule: defl.principal_induct, simp)
92.596 + apply (simp add: contlub_cfun_fun chain)
92.597 + apply (simp add: compact_below_lub_iff defl.compact_principal chain)
92.598 + apply (simp add: defl_approx_principal)
92.599 + apply (subgoal_tac "\<exists>i. fd_take i a = a", metis below_refl)
92.600 + apply (rule fd_take_covers)
92.601 + done
92.602 + show "\<And>i. finite {x. defl_approx i\<cdot>x = x}"
92.603 + apply (rule finite_range_imp_finite_fixes)
92.604 + apply (rule_tac B="defl_principal ` range (fd_take i)" in rev_finite_subset)
92.605 + apply (simp add: finite_range_fd_take)
92.606 + apply (clarsimp, rename_tac x)
92.607 + apply (induct_tac x rule: defl.principal_induct)
92.608 + apply (simp add: adm_mem_finite finite_range_fd_take)
92.609 + apply (simp add: defl_approx_principal)
92.610 + done
92.611 +qed
92.612 +
92.613 +subsection {* Algebraic deflations are a bifinite domain *}
92.614 +
92.615 +instantiation defl :: liftdomain
92.616 +begin
92.617 +
92.618 +definition
92.619 + "emb = udom_emb defl_approx"
92.620 +
92.621 +definition
92.622 + "prj = udom_prj defl_approx"
92.623 +
92.624 +definition
92.625 + "defl (t::defl itself) =
92.626 + (\<Squnion>i. defl_principal (Abs_fin_defl (emb oo defl_approx i oo prj)))"
92.627 +
92.628 +definition
92.629 + "(liftemb :: defl u \<rightarrow> udom) = udom_emb u_approx oo u_map\<cdot>emb"
92.630 +
92.631 +definition
92.632 + "(liftprj :: udom \<rightarrow> defl u) = u_map\<cdot>prj oo udom_prj u_approx"
92.633 +
92.634 +definition
92.635 + "liftdefl (t::defl itself) = u_defl\<cdot>DEFL(defl)"
92.636 +
92.637 +instance
92.638 +using liftemb_defl_def liftprj_defl_def liftdefl_defl_def
92.639 +proof (rule liftdomain_class_intro)
92.640 + show ep: "ep_pair emb (prj :: udom \<rightarrow> defl)"
92.641 + unfolding emb_defl_def prj_defl_def
92.642 + by (rule ep_pair_udom [OF defl_approx])
92.643 + show "cast\<cdot>DEFL(defl) = emb oo (prj :: udom \<rightarrow> defl)"
92.644 + unfolding defl_defl_def
92.645 + apply (subst contlub_cfun_arg)
92.646 + apply (rule chainI)
92.647 + apply (rule defl.principal_mono)
92.648 + apply (simp add: below_fin_defl_def)
92.649 + apply (simp add: Abs_fin_defl_inverse approx_chain.finite_deflation_approx [OF defl_approx]
92.650 + ep_pair.finite_deflation_e_d_p [OF ep])
92.651 + apply (intro monofun_cfun below_refl)
92.652 + apply (rule chainE)
92.653 + apply (rule approx_chain.chain_approx [OF defl_approx])
92.654 + apply (subst cast_defl_principal)
92.655 + apply (simp add: Abs_fin_defl_inverse approx_chain.finite_deflation_approx [OF defl_approx]
92.656 + ep_pair.finite_deflation_e_d_p [OF ep])
92.657 + apply (simp add: lub_distribs approx_chain.chain_approx [OF defl_approx]
92.658 + approx_chain.lub_approx [OF defl_approx])
92.659 + done
92.660 +qed
92.661 +
92.662 +end
92.663 +
92.664 +end
93.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
93.2 +++ b/src/HOL/HOLCF/Library/HOLCF_Library.thy Sat Nov 27 16:08:10 2010 -0800
93.3 @@ -0,0 +1,9 @@
93.4 +theory HOLCF_Library
93.5 +imports
93.6 + Defl_Bifinite
93.7 + List_Cpo
93.8 + Stream
93.9 + Sum_Cpo
93.10 +begin
93.11 +
93.12 +end
94.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
94.2 +++ b/src/HOL/HOLCF/Library/List_Cpo.thy Sat Nov 27 16:08:10 2010 -0800
94.3 @@ -0,0 +1,268 @@
94.4 +(* Title: HOLCF/Library/List_Cpo.thy
94.5 + Author: Brian Huffman
94.6 +*)
94.7 +
94.8 +header {* Lists as a complete partial order *}
94.9 +
94.10 +theory List_Cpo
94.11 +imports HOLCF
94.12 +begin
94.13 +
94.14 +subsection {* Lists are a partial order *}
94.15 +
94.16 +instantiation list :: (po) po
94.17 +begin
94.18 +
94.19 +definition
94.20 + "xs \<sqsubseteq> ys \<longleftrightarrow> list_all2 (op \<sqsubseteq>) xs ys"
94.21 +
94.22 +instance proof
94.23 + fix xs :: "'a list"
94.24 + from below_refl show "xs \<sqsubseteq> xs"
94.25 + unfolding below_list_def
94.26 + by (rule list_all2_refl)
94.27 +next
94.28 + fix xs ys zs :: "'a list"
94.29 + assume "xs \<sqsubseteq> ys" and "ys \<sqsubseteq> zs"
94.30 + with below_trans show "xs \<sqsubseteq> zs"
94.31 + unfolding below_list_def
94.32 + by (rule list_all2_trans)
94.33 +next
94.34 + fix xs ys zs :: "'a list"
94.35 + assume "xs \<sqsubseteq> ys" and "ys \<sqsubseteq> xs"
94.36 + with below_antisym show "xs = ys"
94.37 + unfolding below_list_def
94.38 + by (rule list_all2_antisym)
94.39 +qed
94.40 +
94.41 +end
94.42 +
94.43 +lemma below_list_simps [simp]:
94.44 + "[] \<sqsubseteq> []"
94.45 + "x # xs \<sqsubseteq> y # ys \<longleftrightarrow> x \<sqsubseteq> y \<and> xs \<sqsubseteq> ys"
94.46 + "\<not> [] \<sqsubseteq> y # ys"
94.47 + "\<not> x # xs \<sqsubseteq> []"
94.48 +by (simp_all add: below_list_def)
94.49 +
94.50 +lemma Nil_below_iff [simp]: "[] \<sqsubseteq> xs \<longleftrightarrow> xs = []"
94.51 +by (cases xs, simp_all)
94.52 +
94.53 +lemma below_Nil_iff [simp]: "xs \<sqsubseteq> [] \<longleftrightarrow> xs = []"
94.54 +by (cases xs, simp_all)
94.55 +
94.56 +lemma list_below_induct [consumes 1, case_names Nil Cons]:
94.57 + assumes "xs \<sqsubseteq> ys"
94.58 + assumes 1: "P [] []"
94.59 + assumes 2: "\<And>x y xs ys. \<lbrakk>x \<sqsubseteq> y; xs \<sqsubseteq> ys; P xs ys\<rbrakk> \<Longrightarrow> P (x # xs) (y # ys)"
94.60 + shows "P xs ys"
94.61 +using `xs \<sqsubseteq> ys`
94.62 +proof (induct xs arbitrary: ys)
94.63 + case Nil thus ?case by (simp add: 1)
94.64 +next
94.65 + case (Cons x xs) thus ?case by (cases ys, simp_all add: 2)
94.66 +qed
94.67 +
94.68 +lemma list_below_cases:
94.69 + assumes "xs \<sqsubseteq> ys"
94.70 + obtains "xs = []" and "ys = []" |
94.71 + x y xs' ys' where "xs = x # xs'" and "ys = y # ys'"
94.72 +using assms by (cases xs, simp, cases ys, auto)
94.73 +
94.74 +text "Thanks to Joachim Breitner"
94.75 +
94.76 +lemma list_Cons_below:
94.77 + assumes "a # as \<sqsubseteq> xs"
94.78 + obtains b and bs where "a \<sqsubseteq> b" and "as \<sqsubseteq> bs" and "xs = b # bs"
94.79 + using assms by (cases xs, auto)
94.80 +
94.81 +lemma list_below_Cons:
94.82 + assumes "xs \<sqsubseteq> b # bs"
94.83 + obtains a and as where "a \<sqsubseteq> b" and "as \<sqsubseteq> bs" and "xs = a # as"
94.84 + using assms by (cases xs, auto)
94.85 +
94.86 +lemma hd_mono: "xs \<sqsubseteq> ys \<Longrightarrow> hd xs \<sqsubseteq> hd ys"
94.87 +by (cases xs, simp, cases ys, simp, simp)
94.88 +
94.89 +lemma tl_mono: "xs \<sqsubseteq> ys \<Longrightarrow> tl xs \<sqsubseteq> tl ys"
94.90 +by (cases xs, simp, cases ys, simp, simp)
94.91 +
94.92 +lemma ch2ch_hd [simp]: "chain (\<lambda>i. S i) \<Longrightarrow> chain (\<lambda>i. hd (S i))"
94.93 +by (rule chainI, rule hd_mono, erule chainE)
94.94 +
94.95 +lemma ch2ch_tl [simp]: "chain (\<lambda>i. S i) \<Longrightarrow> chain (\<lambda>i. tl (S i))"
94.96 +by (rule chainI, rule tl_mono, erule chainE)
94.97 +
94.98 +lemma below_same_length: "xs \<sqsubseteq> ys \<Longrightarrow> length xs = length ys"
94.99 +unfolding below_list_def by (rule list_all2_lengthD)
94.100 +
94.101 +lemma list_chain_induct [consumes 1, case_names Nil Cons]:
94.102 + assumes "chain S"
94.103 + assumes 1: "P (\<lambda>i. [])"
94.104 + assumes 2: "\<And>A B. chain A \<Longrightarrow> chain B \<Longrightarrow> P B \<Longrightarrow> P (\<lambda>i. A i # B i)"
94.105 + shows "P S"
94.106 +using `chain S`
94.107 +proof (induct "S 0" arbitrary: S)
94.108 + case Nil
94.109 + have "\<forall>i. S 0 \<sqsubseteq> S i" by (simp add: chain_mono [OF `chain S`])
94.110 + with Nil have "\<forall>i. S i = []" by simp
94.111 + thus ?case by (simp add: 1)
94.112 +next
94.113 + case (Cons x xs)
94.114 + have "\<forall>i. S 0 \<sqsubseteq> S i" by (simp add: chain_mono [OF `chain S`])
94.115 + hence *: "\<forall>i. S i \<noteq> []" by (rule all_forward, insert Cons) auto
94.116 + have "chain (\<lambda>i. hd (S i))" and "chain (\<lambda>i. tl (S i))"
94.117 + using `chain S` by simp_all
94.118 + moreover have "P (\<lambda>i. tl (S i))"
94.119 + using `chain S` and `x # xs = S 0` [symmetric]
94.120 + by (simp add: Cons(1))
94.121 + ultimately have "P (\<lambda>i. hd (S i) # tl (S i))"
94.122 + by (rule 2)
94.123 + thus "P S" by (simp add: *)
94.124 +qed
94.125 +
94.126 +lemma list_chain_cases:
94.127 + assumes S: "chain S"
94.128 + obtains "S = (\<lambda>i. [])" |
94.129 + A B where "chain A" and "chain B" and "S = (\<lambda>i. A i # B i)"
94.130 +using S by (induct rule: list_chain_induct) simp_all
94.131 +
94.132 +subsection {* Lists are a complete partial order *}
94.133 +
94.134 +lemma is_lub_Cons:
94.135 + assumes A: "range A <<| x"
94.136 + assumes B: "range B <<| xs"
94.137 + shows "range (\<lambda>i. A i # B i) <<| x # xs"
94.138 +using assms
94.139 +unfolding is_lub_def is_ub_def
94.140 +by (clarsimp, case_tac u, simp_all)
94.141 +
94.142 +instance list :: (cpo) cpo
94.143 +proof
94.144 + fix S :: "nat \<Rightarrow> 'a list"
94.145 + assume "chain S" thus "\<exists>x. range S <<| x"
94.146 + proof (induct rule: list_chain_induct)
94.147 + case Nil thus ?case by (auto intro: is_lub_const)
94.148 + next
94.149 + case (Cons A B) thus ?case by (auto intro: is_lub_Cons cpo_lubI)
94.150 + qed
94.151 +qed
94.152 +
94.153 +subsection {* Continuity of list operations *}
94.154 +
94.155 +lemma cont2cont_Cons [simp, cont2cont]:
94.156 + assumes f: "cont (\<lambda>x. f x)"
94.157 + assumes g: "cont (\<lambda>x. g x)"
94.158 + shows "cont (\<lambda>x. f x # g x)"
94.159 +apply (rule contI)
94.160 +apply (rule is_lub_Cons)
94.161 +apply (erule contE [OF f])
94.162 +apply (erule contE [OF g])
94.163 +done
94.164 +
94.165 +lemma lub_Cons:
94.166 + fixes A :: "nat \<Rightarrow> 'a::cpo"
94.167 + assumes A: "chain A" and B: "chain B"
94.168 + shows "(\<Squnion>i. A i # B i) = (\<Squnion>i. A i) # (\<Squnion>i. B i)"
94.169 +by (intro lub_eqI is_lub_Cons cpo_lubI A B)
94.170 +
94.171 +lemma cont2cont_list_case:
94.172 + assumes f: "cont (\<lambda>x. f x)"
94.173 + assumes g: "cont (\<lambda>x. g x)"
94.174 + assumes h1: "\<And>y ys. cont (\<lambda>x. h x y ys)"
94.175 + assumes h2: "\<And>x ys. cont (\<lambda>y. h x y ys)"
94.176 + assumes h3: "\<And>x y. cont (\<lambda>ys. h x y ys)"
94.177 + shows "cont (\<lambda>x. case f x of [] \<Rightarrow> g x | y # ys \<Rightarrow> h x y ys)"
94.178 +apply (rule cont_apply [OF f])
94.179 +apply (rule contI)
94.180 +apply (erule list_chain_cases)
94.181 +apply (simp add: is_lub_const)
94.182 +apply (simp add: lub_Cons)
94.183 +apply (simp add: cont2contlubE [OF h2])
94.184 +apply (simp add: cont2contlubE [OF h3])
94.185 +apply (simp add: diag_lub ch2ch_cont [OF h2] ch2ch_cont [OF h3])
94.186 +apply (rule cpo_lubI, rule chainI, rule below_trans)
94.187 +apply (erule cont2monofunE [OF h2 chainE])
94.188 +apply (erule cont2monofunE [OF h3 chainE])
94.189 +apply (case_tac y, simp_all add: g h1)
94.190 +done
94.191 +
94.192 +lemma cont2cont_list_case' [simp, cont2cont]:
94.193 + assumes f: "cont (\<lambda>x. f x)"
94.194 + assumes g: "cont (\<lambda>x. g x)"
94.195 + assumes h: "cont (\<lambda>p. h (fst p) (fst (snd p)) (snd (snd p)))"
94.196 + shows "cont (\<lambda>x. case f x of [] \<Rightarrow> g x | y # ys \<Rightarrow> h x y ys)"
94.197 +using assms by (simp add: cont2cont_list_case prod_cont_iff)
94.198 +
94.199 +text {* The simple version (due to Joachim Breitner) is needed if the
94.200 + element type of the list is not a cpo. *}
94.201 +
94.202 +lemma cont2cont_list_case_simple [simp, cont2cont]:
94.203 + assumes "cont (\<lambda>x. f1 x)"
94.204 + assumes "\<And>y ys. cont (\<lambda>x. f2 x y ys)"
94.205 + shows "cont (\<lambda>x. case l of [] \<Rightarrow> f1 x | y # ys \<Rightarrow> f2 x y ys)"
94.206 +using assms by (cases l) auto
94.207 +
94.208 +text {* Lemma for proving continuity of recursive list functions: *}
94.209 +
94.210 +lemma list_contI:
94.211 + fixes f :: "'a::cpo list \<Rightarrow> 'b::cpo"
94.212 + assumes f: "\<And>x xs. f (x # xs) = g x xs (f xs)"
94.213 + assumes g1: "\<And>xs y. cont (\<lambda>x. g x xs y)"
94.214 + assumes g2: "\<And>x y. cont (\<lambda>xs. g x xs y)"
94.215 + assumes g3: "\<And>x xs. cont (\<lambda>y. g x xs y)"
94.216 + shows "cont f"
94.217 +proof (rule contI2)
94.218 + obtain h where h: "\<And>x xs y. g x xs y = h\<cdot>x\<cdot>xs\<cdot>y"
94.219 + proof
94.220 + fix x xs y show "g x xs y = (\<Lambda> x xs y. g x xs y)\<cdot>x\<cdot>xs\<cdot>y"
94.221 + by (simp add: cont2cont_LAM g1 g2 g3)
94.222 + qed
94.223 + show mono: "monofun f"
94.224 + apply (rule monofunI)
94.225 + apply (erule list_below_induct)
94.226 + apply simp
94.227 + apply (simp add: f h monofun_cfun)
94.228 + done
94.229 + fix Y :: "nat \<Rightarrow> 'a list"
94.230 + assume "chain Y" thus "f (\<Squnion>i. Y i) \<sqsubseteq> (\<Squnion>i. f (Y i))"
94.231 + apply (induct rule: list_chain_induct)
94.232 + apply simp
94.233 + apply (simp add: lub_Cons f h)
94.234 + apply (simp add: contlub_cfun [symmetric] ch2ch_monofun [OF mono])
94.235 + apply (simp add: monofun_cfun)
94.236 + done
94.237 +qed
94.238 +
94.239 +text {* There are probably lots of other list operations that also
94.240 +deserve to have continuity lemmas. I'll add more as they are
94.241 +needed. *}
94.242 +
94.243 +subsection {* Using lists with fixrec *}
94.244 +
94.245 +definition
94.246 + match_Nil :: "'a::cpo list \<rightarrow> 'b match \<rightarrow> 'b match"
94.247 +where
94.248 + "match_Nil = (\<Lambda> xs k. case xs of [] \<Rightarrow> k | y # ys \<Rightarrow> Fixrec.fail)"
94.249 +
94.250 +definition
94.251 + match_Cons :: "'a::cpo list \<rightarrow> ('a \<rightarrow> 'a list \<rightarrow> 'b match) \<rightarrow> 'b match"
94.252 +where
94.253 + "match_Cons = (\<Lambda> xs k. case xs of [] \<Rightarrow> Fixrec.fail | y # ys \<Rightarrow> k\<cdot>y\<cdot>ys)"
94.254 +
94.255 +lemma match_Nil_simps [simp]:
94.256 + "match_Nil\<cdot>[]\<cdot>k = k"
94.257 + "match_Nil\<cdot>(x # xs)\<cdot>k = Fixrec.fail"
94.258 +unfolding match_Nil_def by simp_all
94.259 +
94.260 +lemma match_Cons_simps [simp]:
94.261 + "match_Cons\<cdot>[]\<cdot>k = Fixrec.fail"
94.262 + "match_Cons\<cdot>(x # xs)\<cdot>k = k\<cdot>x\<cdot>xs"
94.263 +unfolding match_Cons_def by simp_all
94.264 +
94.265 +setup {*
94.266 + Fixrec.add_matchers
94.267 + [ (@{const_name Nil}, @{const_name match_Nil}),
94.268 + (@{const_name Cons}, @{const_name match_Cons}) ]
94.269 +*}
94.270 +
94.271 +end
95.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
95.2 +++ b/src/HOL/HOLCF/Library/ROOT.ML Sat Nov 27 16:08:10 2010 -0800
95.3 @@ -0,0 +1,1 @@
95.4 +use_thys ["HOLCF_Library"];
96.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
96.2 +++ b/src/HOL/HOLCF/Library/Stream.thy Sat Nov 27 16:08:10 2010 -0800
96.3 @@ -0,0 +1,967 @@
96.4 +(* Title: HOLCF/ex/Stream.thy
96.5 + Author: Franz Regensburger, David von Oheimb, Borislav Gajanovic
96.6 +*)
96.7 +
96.8 +header {* General Stream domain *}
96.9 +
96.10 +theory Stream
96.11 +imports HOLCF Nat_Infinity
96.12 +begin
96.13 +
96.14 +default_sort pcpo
96.15 +
96.16 +domain (unsafe) 'a stream = scons (ft::'a) (lazy rt::"'a stream") (infixr "&&" 65)
96.17 +
96.18 +definition
96.19 + smap :: "('a \<rightarrow> 'b) \<rightarrow> 'a stream \<rightarrow> 'b stream" where
96.20 + "smap = fix\<cdot>(\<Lambda> h f s. case s of x && xs \<Rightarrow> f\<cdot>x && h\<cdot>f\<cdot>xs)"
96.21 +
96.22 +definition
96.23 + sfilter :: "('a \<rightarrow> tr) \<rightarrow> 'a stream \<rightarrow> 'a stream" where
96.24 + "sfilter = fix\<cdot>(\<Lambda> h p s. case s of x && xs \<Rightarrow>
96.25 + If p\<cdot>x then x && h\<cdot>p\<cdot>xs else h\<cdot>p\<cdot>xs)"
96.26 +
96.27 +definition
96.28 + slen :: "'a stream \<Rightarrow> inat" ("#_" [1000] 1000) where
96.29 + "#s = (if stream_finite s then Fin (LEAST n. stream_take n\<cdot>s = s) else \<infinity>)"
96.30 +
96.31 +
96.32 +(* concatenation *)
96.33 +
96.34 +definition
96.35 + i_rt :: "nat => 'a stream => 'a stream" where (* chops the first i elements *)
96.36 + "i_rt = (%i s. iterate i$rt$s)"
96.37 +
96.38 +definition
96.39 + i_th :: "nat => 'a stream => 'a" where (* the i-th element *)
96.40 + "i_th = (%i s. ft$(i_rt i s))"
96.41 +
96.42 +definition
96.43 + sconc :: "'a stream => 'a stream => 'a stream" (infixr "ooo" 65) where
96.44 + "s1 ooo s2 = (case #s1 of
96.45 + Fin n \<Rightarrow> (SOME s. (stream_take n$s=s1) & (i_rt n s = s2))
96.46 + | \<infinity> \<Rightarrow> s1)"
96.47 +
96.48 +primrec constr_sconc' :: "nat => 'a stream => 'a stream => 'a stream"
96.49 +where
96.50 + constr_sconc'_0: "constr_sconc' 0 s1 s2 = s2"
96.51 +| constr_sconc'_Suc: "constr_sconc' (Suc n) s1 s2 = ft$s1 &&
96.52 + constr_sconc' n (rt$s1) s2"
96.53 +
96.54 +definition
96.55 + constr_sconc :: "'a stream => 'a stream => 'a stream" where (* constructive *)
96.56 + "constr_sconc s1 s2 = (case #s1 of
96.57 + Fin n \<Rightarrow> constr_sconc' n s1 s2
96.58 + | \<infinity> \<Rightarrow> s1)"
96.59 +
96.60 +
96.61 +(* ----------------------------------------------------------------------- *)
96.62 +(* theorems about scons *)
96.63 +(* ----------------------------------------------------------------------- *)
96.64 +
96.65 +
96.66 +section "scons"
96.67 +
96.68 +lemma scons_eq_UU: "(a && s = UU) = (a = UU)"
96.69 +by simp
96.70 +
96.71 +lemma scons_not_empty: "[| a && x = UU; a ~= UU |] ==> R"
96.72 +by simp
96.73 +
96.74 +lemma stream_exhaust_eq: "(x ~= UU) = (EX a y. a ~= UU & x = a && y)"
96.75 +by (cases x, auto)
96.76 +
96.77 +lemma stream_neq_UU: "x~=UU ==> EX a a_s. x=a&&a_s & a~=UU"
96.78 +by (simp add: stream_exhaust_eq,auto)
96.79 +
96.80 +lemma stream_prefix:
96.81 + "[| a && s << t; a ~= UU |] ==> EX b tt. t = b && tt & b ~= UU & s << tt"
96.82 +by (cases t, auto)
96.83 +
96.84 +lemma stream_prefix':
96.85 + "b ~= UU ==> x << b && z =
96.86 + (x = UU | (EX a y. x = a && y & a ~= UU & a << b & y << z))"
96.87 +by (cases x, auto)
96.88 +
96.89 +
96.90 +(*
96.91 +lemma stream_prefix1: "[| x<<y; xs<<ys |] ==> x&&xs << y&&ys"
96.92 +by (insert stream_prefix' [of y "x&&xs" ys],force)
96.93 +*)
96.94 +
96.95 +lemma stream_flat_prefix:
96.96 + "[| x && xs << y && ys; (x::'a::flat) ~= UU|] ==> x = y & xs << ys"
96.97 +apply (case_tac "y=UU",auto)
96.98 +by (drule ax_flat,simp)
96.99 +
96.100 +
96.101 +
96.102 +
96.103 +(* ----------------------------------------------------------------------- *)
96.104 +(* theorems about stream_case *)
96.105 +(* ----------------------------------------------------------------------- *)
96.106 +
96.107 +section "stream_case"
96.108 +
96.109 +
96.110 +lemma stream_case_strictf: "stream_case$UU$s=UU"
96.111 +by (cases s, auto)
96.112 +
96.113 +
96.114 +
96.115 +(* ----------------------------------------------------------------------- *)
96.116 +(* theorems about ft and rt *)
96.117 +(* ----------------------------------------------------------------------- *)
96.118 +
96.119 +
96.120 +section "ft & rt"
96.121 +
96.122 +
96.123 +lemma ft_defin: "s~=UU ==> ft$s~=UU"
96.124 +by simp
96.125 +
96.126 +lemma rt_strict_rev: "rt$s~=UU ==> s~=UU"
96.127 +by auto
96.128 +
96.129 +lemma surjectiv_scons: "(ft$s)&&(rt$s)=s"
96.130 +by (cases s, auto)
96.131 +
96.132 +lemma monofun_rt_mult: "x << s ==> iterate i$rt$x << iterate i$rt$s"
96.133 +by (rule monofun_cfun_arg)
96.134 +
96.135 +
96.136 +
96.137 +(* ----------------------------------------------------------------------- *)
96.138 +(* theorems about stream_take *)
96.139 +(* ----------------------------------------------------------------------- *)
96.140 +
96.141 +
96.142 +section "stream_take"
96.143 +
96.144 +
96.145 +lemma stream_reach2: "(LUB i. stream_take i$s) = s"
96.146 +by (rule stream.reach)
96.147 +
96.148 +lemma chain_stream_take: "chain (%i. stream_take i$s)"
96.149 +by simp
96.150 +
96.151 +lemma stream_take_prefix [simp]: "stream_take n$s << s"
96.152 +apply (insert stream_reach2 [of s])
96.153 +apply (erule subst) back
96.154 +apply (rule is_ub_thelub)
96.155 +by (simp only: chain_stream_take)
96.156 +
96.157 +lemma stream_take_more [rule_format]:
96.158 + "ALL x. stream_take n$x = x --> stream_take (Suc n)$x = x"
96.159 +apply (induct_tac n,auto)
96.160 +apply (case_tac "x=UU",auto)
96.161 +by (drule stream_exhaust_eq [THEN iffD1],auto)
96.162 +
96.163 +lemma stream_take_lemma3 [rule_format]:
96.164 + "ALL x xs. x~=UU --> stream_take n$(x && xs) = x && xs --> stream_take n$xs=xs"
96.165 +apply (induct_tac n,clarsimp)
96.166 +(*apply (drule sym, erule scons_not_empty, simp)*)
96.167 +apply (clarify, rule stream_take_more)
96.168 +apply (erule_tac x="x" in allE)
96.169 +by (erule_tac x="xs" in allE,simp)
96.170 +
96.171 +lemma stream_take_lemma4:
96.172 + "ALL x xs. stream_take n$xs=xs --> stream_take (Suc n)$(x && xs) = x && xs"
96.173 +by auto
96.174 +
96.175 +lemma stream_take_idempotent [rule_format, simp]:
96.176 + "ALL s. stream_take n$(stream_take n$s) = stream_take n$s"
96.177 +apply (induct_tac n, auto)
96.178 +apply (case_tac "s=UU", auto)
96.179 +by (drule stream_exhaust_eq [THEN iffD1], auto)
96.180 +
96.181 +lemma stream_take_take_Suc [rule_format, simp]:
96.182 + "ALL s. stream_take n$(stream_take (Suc n)$s) =
96.183 + stream_take n$s"
96.184 +apply (induct_tac n, auto)
96.185 +apply (case_tac "s=UU", auto)
96.186 +by (drule stream_exhaust_eq [THEN iffD1], auto)
96.187 +
96.188 +lemma mono_stream_take_pred:
96.189 + "stream_take (Suc n)$s1 << stream_take (Suc n)$s2 ==>
96.190 + stream_take n$s1 << stream_take n$s2"
96.191 +by (insert monofun_cfun_arg [of "stream_take (Suc n)$s1"
96.192 + "stream_take (Suc n)$s2" "stream_take n"], auto)
96.193 +(*
96.194 +lemma mono_stream_take_pred:
96.195 + "stream_take (Suc n)$s1 << stream_take (Suc n)$s2 ==>
96.196 + stream_take n$s1 << stream_take n$s2"
96.197 +by (drule mono_stream_take [of _ _ n],simp)
96.198 +*)
96.199 +
96.200 +lemma stream_take_lemma10 [rule_format]:
96.201 + "ALL k<=n. stream_take n$s1 << stream_take n$s2
96.202 + --> stream_take k$s1 << stream_take k$s2"
96.203 +apply (induct_tac n,simp,clarsimp)
96.204 +apply (case_tac "k=Suc n",blast)
96.205 +apply (erule_tac x="k" in allE)
96.206 +by (drule mono_stream_take_pred,simp)
96.207 +
96.208 +lemma stream_take_le_mono : "k<=n ==> stream_take k$s1 << stream_take n$s1"
96.209 +apply (insert chain_stream_take [of s1])
96.210 +by (drule chain_mono,auto)
96.211 +
96.212 +lemma mono_stream_take: "s1 << s2 ==> stream_take n$s1 << stream_take n$s2"
96.213 +by (simp add: monofun_cfun_arg)
96.214 +
96.215 +(*
96.216 +lemma stream_take_prefix [simp]: "stream_take n$s << s"
96.217 +apply (subgoal_tac "s=(LUB n. stream_take n$s)")
96.218 + apply (erule ssubst, rule is_ub_thelub)
96.219 + apply (simp only: chain_stream_take)
96.220 +by (simp only: stream_reach2)
96.221 +*)
96.222 +
96.223 +lemma stream_take_take_less:"stream_take k$(stream_take n$s) << stream_take k$s"
96.224 +by (rule monofun_cfun_arg,auto)
96.225 +
96.226 +
96.227 +(* ------------------------------------------------------------------------- *)
96.228 +(* special induction rules *)
96.229 +(* ------------------------------------------------------------------------- *)
96.230 +
96.231 +
96.232 +section "induction"
96.233 +
96.234 +lemma stream_finite_ind:
96.235 + "[| stream_finite x; P UU; !!a s. [| a ~= UU; P s |] ==> P (a && s) |] ==> P x"
96.236 +apply (simp add: stream.finite_def,auto)
96.237 +apply (erule subst)
96.238 +by (drule stream.finite_induct [of P _ x], auto)
96.239 +
96.240 +lemma stream_finite_ind2:
96.241 +"[| P UU; !! x. x ~= UU ==> P (x && UU); !! y z s. [| y ~= UU; z ~= UU; P s |] ==> P (y && z && s )|] ==>
96.242 + !s. P (stream_take n$s)"
96.243 +apply (rule nat_less_induct [of _ n],auto)
96.244 +apply (case_tac n, auto)
96.245 +apply (case_tac nat, auto)
96.246 +apply (case_tac "s=UU",clarsimp)
96.247 +apply (drule stream_exhaust_eq [THEN iffD1],clarsimp)
96.248 +apply (case_tac "s=UU",clarsimp)
96.249 +apply (drule stream_exhaust_eq [THEN iffD1],clarsimp)
96.250 +apply (case_tac "y=UU",clarsimp)
96.251 +by (drule stream_exhaust_eq [THEN iffD1],clarsimp)
96.252 +
96.253 +lemma stream_ind2:
96.254 +"[| adm P; P UU; !!a. a ~= UU ==> P (a && UU); !!a b s. [| a ~= UU; b ~= UU; P s |] ==> P (a && b && s) |] ==> P x"
96.255 +apply (insert stream.reach [of x],erule subst)
96.256 +apply (erule admD, rule chain_stream_take)
96.257 +apply (insert stream_finite_ind2 [of P])
96.258 +by simp
96.259 +
96.260 +
96.261 +
96.262 +(* ----------------------------------------------------------------------- *)
96.263 +(* simplify use of coinduction *)
96.264 +(* ----------------------------------------------------------------------- *)
96.265 +
96.266 +
96.267 +section "coinduction"
96.268 +
96.269 +lemma stream_coind_lemma2: "!s1 s2. R s1 s2 --> ft$s1 = ft$s2 & R (rt$s1) (rt$s2) ==> stream_bisim R"
96.270 + apply (simp add: stream.bisim_def,clarsimp)
96.271 + apply (drule spec, drule spec, drule (1) mp)
96.272 + apply (case_tac "x", simp)
96.273 + apply (case_tac "y", simp)
96.274 +by auto
96.275 +
96.276 +
96.277 +
96.278 +(* ----------------------------------------------------------------------- *)
96.279 +(* theorems about stream_finite *)
96.280 +(* ----------------------------------------------------------------------- *)
96.281 +
96.282 +
96.283 +section "stream_finite"
96.284 +
96.285 +lemma stream_finite_UU [simp]: "stream_finite UU"
96.286 +by (simp add: stream.finite_def)
96.287 +
96.288 +lemma stream_finite_UU_rev: "~ stream_finite s ==> s ~= UU"
96.289 +by (auto simp add: stream.finite_def)
96.290 +
96.291 +lemma stream_finite_lemma1: "stream_finite xs ==> stream_finite (x && xs)"
96.292 +apply (simp add: stream.finite_def,auto)
96.293 +apply (rule_tac x="Suc n" in exI)
96.294 +by (simp add: stream_take_lemma4)
96.295 +
96.296 +lemma stream_finite_lemma2: "[| x ~= UU; stream_finite (x && xs) |] ==> stream_finite xs"
96.297 +apply (simp add: stream.finite_def, auto)
96.298 +apply (rule_tac x="n" in exI)
96.299 +by (erule stream_take_lemma3,simp)
96.300 +
96.301 +lemma stream_finite_rt_eq: "stream_finite (rt$s) = stream_finite s"
96.302 +apply (cases s, auto)
96.303 +apply (rule stream_finite_lemma1, simp)
96.304 +by (rule stream_finite_lemma2,simp)
96.305 +
96.306 +lemma stream_finite_less: "stream_finite s ==> !t. t<<s --> stream_finite t"
96.307 +apply (erule stream_finite_ind [of s], auto)
96.308 +apply (case_tac "t=UU", auto)
96.309 +apply (drule stream_exhaust_eq [THEN iffD1],auto)
96.310 +apply (erule_tac x="y" in allE, simp)
96.311 +by (rule stream_finite_lemma1, simp)
96.312 +
96.313 +lemma stream_take_finite [simp]: "stream_finite (stream_take n$s)"
96.314 +apply (simp add: stream.finite_def)
96.315 +by (rule_tac x="n" in exI,simp)
96.316 +
96.317 +lemma adm_not_stream_finite: "adm (%x. ~ stream_finite x)"
96.318 +apply (rule adm_upward)
96.319 +apply (erule contrapos_nn)
96.320 +apply (erule (1) stream_finite_less [rule_format])
96.321 +done
96.322 +
96.323 +
96.324 +
96.325 +(* ----------------------------------------------------------------------- *)
96.326 +(* theorems about stream length *)
96.327 +(* ----------------------------------------------------------------------- *)
96.328 +
96.329 +
96.330 +section "slen"
96.331 +
96.332 +lemma slen_empty [simp]: "#\<bottom> = 0"
96.333 +by (simp add: slen_def stream.finite_def zero_inat_def Least_equality)
96.334 +
96.335 +lemma slen_scons [simp]: "x ~= \<bottom> ==> #(x&&xs) = iSuc (#xs)"
96.336 +apply (case_tac "stream_finite (x && xs)")
96.337 +apply (simp add: slen_def, auto)
96.338 +apply (simp add: stream.finite_def, auto simp add: iSuc_Fin)
96.339 +apply (rule Least_Suc2, auto)
96.340 +(*apply (drule sym)*)
96.341 +(*apply (drule sym scons_eq_UU [THEN iffD1],simp)*)
96.342 +apply (erule stream_finite_lemma2, simp)
96.343 +apply (simp add: slen_def, auto)
96.344 +by (drule stream_finite_lemma1,auto)
96.345 +
96.346 +lemma slen_less_1_eq: "(#x < Fin (Suc 0)) = (x = \<bottom>)"
96.347 +by (cases x, auto simp add: Fin_0 iSuc_Fin[THEN sym])
96.348 +
96.349 +lemma slen_empty_eq: "(#x = 0) = (x = \<bottom>)"
96.350 +by (cases x, auto)
96.351 +
96.352 +lemma slen_scons_eq: "(Fin (Suc n) < #x) = (? a y. x = a && y & a ~= \<bottom> & Fin n < #y)"
96.353 +apply (auto, case_tac "x=UU",auto)
96.354 +apply (drule stream_exhaust_eq [THEN iffD1], auto)
96.355 +apply (case_tac "#y") apply simp_all
96.356 +apply (case_tac "#y") apply simp_all
96.357 +done
96.358 +
96.359 +lemma slen_iSuc: "#x = iSuc n --> (? a y. x = a&&y & a ~= \<bottom> & #y = n)"
96.360 +by (cases x, auto)
96.361 +
96.362 +lemma slen_stream_take_finite [simp]: "#(stream_take n$s) ~= \<infinity>"
96.363 +by (simp add: slen_def)
96.364 +
96.365 +lemma slen_scons_eq_rev: "(#x < Fin (Suc (Suc n))) = (!a y. x ~= a && y | a = \<bottom> | #y < Fin (Suc n))"
96.366 + apply (cases x, auto)
96.367 + apply (simp add: zero_inat_def)
96.368 + apply (case_tac "#stream") apply (simp_all add: iSuc_Fin)
96.369 + apply (case_tac "#stream") apply (simp_all add: iSuc_Fin)
96.370 +done
96.371 +
96.372 +lemma slen_take_lemma4 [rule_format]:
96.373 + "!s. stream_take n$s ~= s --> #(stream_take n$s) = Fin n"
96.374 +apply (induct n, auto simp add: Fin_0)
96.375 +apply (case_tac "s=UU", simp)
96.376 +by (drule stream_exhaust_eq [THEN iffD1], auto simp add: iSuc_Fin)
96.377 +
96.378 +(*
96.379 +lemma stream_take_idempotent [simp]:
96.380 + "stream_take n$(stream_take n$s) = stream_take n$s"
96.381 +apply (case_tac "stream_take n$s = s")
96.382 +apply (auto,insert slen_take_lemma4 [of n s]);
96.383 +by (auto,insert slen_take_lemma1 [of "stream_take n$s" n],simp)
96.384 +
96.385 +lemma stream_take_take_Suc [simp]: "stream_take n$(stream_take (Suc n)$s) =
96.386 + stream_take n$s"
96.387 +apply (simp add: po_eq_conv,auto)
96.388 + apply (simp add: stream_take_take_less)
96.389 +apply (subgoal_tac "stream_take n$s = stream_take n$(stream_take n$s)")
96.390 + apply (erule ssubst)
96.391 + apply (rule_tac monofun_cfun_arg)
96.392 + apply (insert chain_stream_take [of s])
96.393 +by (simp add: chain_def,simp)
96.394 +*)
96.395 +
96.396 +lemma slen_take_eq: "ALL x. (Fin n < #x) = (stream_take n\<cdot>x ~= x)"
96.397 +apply (induct_tac n, auto)
96.398 +apply (simp add: Fin_0, clarsimp)
96.399 +apply (drule not_sym)
96.400 +apply (drule slen_empty_eq [THEN iffD1], simp)
96.401 +apply (case_tac "x=UU", simp)
96.402 +apply (drule stream_exhaust_eq [THEN iffD1], clarsimp)
96.403 +apply (erule_tac x="y" in allE, auto)
96.404 +apply (simp_all add: not_less iSuc_Fin)
96.405 +apply (case_tac "#y") apply simp_all
96.406 +apply (case_tac "x=UU", simp)
96.407 +apply (drule stream_exhaust_eq [THEN iffD1], clarsimp)
96.408 +apply (erule_tac x="y" in allE, simp)
96.409 +apply (case_tac "#y") by simp_all
96.410 +
96.411 +lemma slen_take_eq_rev: "(#x <= Fin n) = (stream_take n\<cdot>x = x)"
96.412 +by (simp add: linorder_not_less [symmetric] slen_take_eq)
96.413 +
96.414 +lemma slen_take_lemma1: "#x = Fin n ==> stream_take n\<cdot>x = x"
96.415 +by (rule slen_take_eq_rev [THEN iffD1], auto)
96.416 +
96.417 +lemma slen_rt_mono: "#s2 <= #s1 ==> #(rt$s2) <= #(rt$s1)"
96.418 +apply (cases s1)
96.419 + by (cases s2, simp+)+
96.420 +
96.421 +lemma slen_take_lemma5: "#(stream_take n$s) <= Fin n"
96.422 +apply (case_tac "stream_take n$s = s")
96.423 + apply (simp add: slen_take_eq_rev)
96.424 +by (simp add: slen_take_lemma4)
96.425 +
96.426 +lemma slen_take_lemma2: "!x. ~stream_finite x --> #(stream_take i\<cdot>x) = Fin i"
96.427 +apply (simp add: stream.finite_def, auto)
96.428 +by (simp add: slen_take_lemma4)
96.429 +
96.430 +lemma slen_infinite: "stream_finite x = (#x ~= Infty)"
96.431 +by (simp add: slen_def)
96.432 +
96.433 +lemma slen_mono_lemma: "stream_finite s ==> ALL t. s << t --> #s <= #t"
96.434 +apply (erule stream_finite_ind [of s], auto)
96.435 +apply (case_tac "t=UU", auto)
96.436 +apply (drule stream_exhaust_eq [THEN iffD1], auto)
96.437 +done
96.438 +
96.439 +lemma slen_mono: "s << t ==> #s <= #t"
96.440 +apply (case_tac "stream_finite t")
96.441 +apply (frule stream_finite_less)
96.442 +apply (erule_tac x="s" in allE, simp)
96.443 +apply (drule slen_mono_lemma, auto)
96.444 +by (simp add: slen_def)
96.445 +
96.446 +lemma iterate_lemma: "F$(iterate n$F$x) = iterate n$F$(F$x)"
96.447 +by (insert iterate_Suc2 [of n F x], auto)
96.448 +
96.449 +lemma slen_rt_mult [rule_format]: "!x. Fin (i + j) <= #x --> Fin j <= #(iterate i$rt$x)"
96.450 +apply (induct i, auto)
96.451 +apply (case_tac "x=UU", auto simp add: zero_inat_def)
96.452 +apply (drule stream_exhaust_eq [THEN iffD1], auto)
96.453 +apply (erule_tac x="y" in allE, auto)
96.454 +apply (simp add: not_le) apply (case_tac "#y") apply (simp_all add: iSuc_Fin)
96.455 +by (simp add: iterate_lemma)
96.456 +
96.457 +lemma slen_take_lemma3 [rule_format]:
96.458 + "!(x::'a::flat stream) y. Fin n <= #x --> x << y --> stream_take n\<cdot>x = stream_take n\<cdot>y"
96.459 +apply (induct_tac n, auto)
96.460 +apply (case_tac "x=UU", auto)
96.461 +apply (simp add: zero_inat_def)
96.462 +apply (simp add: Suc_ile_eq)
96.463 +apply (case_tac "y=UU", clarsimp)
96.464 +apply (drule stream_exhaust_eq [THEN iffD1], clarsimp)+
96.465 +apply (erule_tac x="ya" in allE, simp)
96.466 +by (drule ax_flat, simp)
96.467 +
96.468 +lemma slen_strict_mono_lemma:
96.469 + "stream_finite t ==> !s. #(s::'a::flat stream) = #t & s << t --> s = t"
96.470 +apply (erule stream_finite_ind, auto)
96.471 +apply (case_tac "sa=UU", auto)
96.472 +apply (drule stream_exhaust_eq [THEN iffD1], clarsimp)
96.473 +by (drule ax_flat, simp)
96.474 +
96.475 +lemma slen_strict_mono: "[|stream_finite t; s ~= t; s << (t::'a::flat stream) |] ==> #s < #t"
96.476 +by (auto simp add: slen_mono less_le dest: slen_strict_mono_lemma)
96.477 +
96.478 +lemma stream_take_Suc_neq: "stream_take (Suc n)$s ~=s ==>
96.479 + stream_take n$s ~= stream_take (Suc n)$s"
96.480 +apply auto
96.481 +apply (subgoal_tac "stream_take n$s ~=s")
96.482 + apply (insert slen_take_lemma4 [of n s],auto)
96.483 +apply (cases s, simp)
96.484 +by (simp add: slen_take_lemma4 iSuc_Fin)
96.485 +
96.486 +(* ----------------------------------------------------------------------- *)
96.487 +(* theorems about smap *)
96.488 +(* ----------------------------------------------------------------------- *)
96.489 +
96.490 +
96.491 +section "smap"
96.492 +
96.493 +lemma smap_unfold: "smap = (\<Lambda> f t. case t of x&&xs \<Rightarrow> f$x && smap$f$xs)"
96.494 +by (insert smap_def [where 'a='a and 'b='b, THEN eq_reflection, THEN fix_eq2], auto)
96.495 +
96.496 +lemma smap_empty [simp]: "smap\<cdot>f\<cdot>\<bottom> = \<bottom>"
96.497 +by (subst smap_unfold, simp)
96.498 +
96.499 +lemma smap_scons [simp]: "x~=\<bottom> ==> smap\<cdot>f\<cdot>(x&&xs) = (f\<cdot>x)&&(smap\<cdot>f\<cdot>xs)"
96.500 +by (subst smap_unfold, force)
96.501 +
96.502 +
96.503 +
96.504 +(* ----------------------------------------------------------------------- *)
96.505 +(* theorems about sfilter *)
96.506 +(* ----------------------------------------------------------------------- *)
96.507 +
96.508 +section "sfilter"
96.509 +
96.510 +lemma sfilter_unfold:
96.511 + "sfilter = (\<Lambda> p s. case s of x && xs \<Rightarrow>
96.512 + If p\<cdot>x then x && sfilter\<cdot>p\<cdot>xs else sfilter\<cdot>p\<cdot>xs)"
96.513 +by (insert sfilter_def [where 'a='a, THEN eq_reflection, THEN fix_eq2], auto)
96.514 +
96.515 +lemma strict_sfilter: "sfilter\<cdot>\<bottom> = \<bottom>"
96.516 +apply (rule cfun_eqI)
96.517 +apply (subst sfilter_unfold, auto)
96.518 +apply (case_tac "x=UU", auto)
96.519 +by (drule stream_exhaust_eq [THEN iffD1], auto)
96.520 +
96.521 +lemma sfilter_empty [simp]: "sfilter\<cdot>f\<cdot>\<bottom> = \<bottom>"
96.522 +by (subst sfilter_unfold, force)
96.523 +
96.524 +lemma sfilter_scons [simp]:
96.525 + "x ~= \<bottom> ==> sfilter\<cdot>f\<cdot>(x && xs) =
96.526 + If f\<cdot>x then x && sfilter\<cdot>f\<cdot>xs else sfilter\<cdot>f\<cdot>xs"
96.527 +by (subst sfilter_unfold, force)
96.528 +
96.529 +
96.530 +(* ----------------------------------------------------------------------- *)
96.531 + section "i_rt"
96.532 +(* ----------------------------------------------------------------------- *)
96.533 +
96.534 +lemma i_rt_UU [simp]: "i_rt n UU = UU"
96.535 + by (induct n) (simp_all add: i_rt_def)
96.536 +
96.537 +lemma i_rt_0 [simp]: "i_rt 0 s = s"
96.538 +by (simp add: i_rt_def)
96.539 +
96.540 +lemma i_rt_Suc [simp]: "a ~= UU ==> i_rt (Suc n) (a&&s) = i_rt n s"
96.541 +by (simp add: i_rt_def iterate_Suc2 del: iterate_Suc)
96.542 +
96.543 +lemma i_rt_Suc_forw: "i_rt (Suc n) s = i_rt n (rt$s)"
96.544 +by (simp only: i_rt_def iterate_Suc2)
96.545 +
96.546 +lemma i_rt_Suc_back:"i_rt (Suc n) s = rt$(i_rt n s)"
96.547 +by (simp only: i_rt_def,auto)
96.548 +
96.549 +lemma i_rt_mono: "x << s ==> i_rt n x << i_rt n s"
96.550 +by (simp add: i_rt_def monofun_rt_mult)
96.551 +
96.552 +lemma i_rt_ij_lemma: "Fin (i + j) <= #x ==> Fin j <= #(i_rt i x)"
96.553 +by (simp add: i_rt_def slen_rt_mult)
96.554 +
96.555 +lemma slen_i_rt_mono: "#s2 <= #s1 ==> #(i_rt n s2) <= #(i_rt n s1)"
96.556 +apply (induct_tac n,auto)
96.557 +apply (simp add: i_rt_Suc_back)
96.558 +by (drule slen_rt_mono,simp)
96.559 +
96.560 +lemma i_rt_take_lemma1 [rule_format]: "ALL s. i_rt n (stream_take n$s) = UU"
96.561 +apply (induct_tac n)
96.562 + apply (simp add: i_rt_Suc_back,auto)
96.563 +apply (case_tac "s=UU",auto)
96.564 +by (drule stream_exhaust_eq [THEN iffD1],auto)
96.565 +
96.566 +lemma i_rt_slen: "(i_rt n s = UU) = (stream_take n$s = s)"
96.567 +apply auto
96.568 + apply (insert i_rt_ij_lemma [of n "Suc 0" s])
96.569 + apply (subgoal_tac "#(i_rt n s)=0")
96.570 + apply (case_tac "stream_take n$s = s",simp+)
96.571 + apply (insert slen_take_eq [rule_format,of n s],simp)
96.572 + apply (cases "#s") apply (simp_all add: zero_inat_def)
96.573 + apply (simp add: slen_take_eq)
96.574 + apply (cases "#s")
96.575 + using i_rt_take_lemma1 [of n s]
96.576 + apply (simp_all add: zero_inat_def)
96.577 + done
96.578 +
96.579 +lemma i_rt_lemma_slen: "#s=Fin n ==> i_rt n s = UU"
96.580 +by (simp add: i_rt_slen slen_take_lemma1)
96.581 +
96.582 +lemma stream_finite_i_rt [simp]: "stream_finite (i_rt n s) = stream_finite s"
96.583 +apply (induct_tac n, auto)
96.584 + apply (cases s, auto simp del: i_rt_Suc)
96.585 +by (simp add: i_rt_Suc_back stream_finite_rt_eq)+
96.586 +
96.587 +lemma take_i_rt_len_lemma: "ALL sl x j t. Fin sl = #x & n <= sl &
96.588 + #(stream_take n$x) = Fin t & #(i_rt n x)= Fin j
96.589 + --> Fin (j + t) = #x"
96.590 +apply (induct n, auto)
96.591 + apply (simp add: zero_inat_def)
96.592 +apply (case_tac "x=UU",auto)
96.593 + apply (simp add: zero_inat_def)
96.594 +apply (drule stream_exhaust_eq [THEN iffD1],clarsimp)
96.595 +apply (subgoal_tac "EX k. Fin k = #y",clarify)
96.596 + apply (erule_tac x="k" in allE)
96.597 + apply (erule_tac x="y" in allE,auto)
96.598 + apply (erule_tac x="THE p. Suc p = t" in allE,auto)
96.599 + apply (simp add: iSuc_def split: inat.splits)
96.600 + apply (simp add: iSuc_def split: inat.splits)
96.601 + apply (simp only: the_equality)
96.602 + apply (simp add: iSuc_def split: inat.splits)
96.603 + apply force
96.604 +apply (simp add: iSuc_def split: inat.splits)
96.605 +done
96.606 +
96.607 +lemma take_i_rt_len:
96.608 +"[| Fin sl = #x; n <= sl; #(stream_take n$x) = Fin t; #(i_rt n x) = Fin j |] ==>
96.609 + Fin (j + t) = #x"
96.610 +by (blast intro: take_i_rt_len_lemma [rule_format])
96.611 +
96.612 +
96.613 +(* ----------------------------------------------------------------------- *)
96.614 + section "i_th"
96.615 +(* ----------------------------------------------------------------------- *)
96.616 +
96.617 +lemma i_th_i_rt_step:
96.618 +"[| i_th n s1 << i_th n s2; i_rt (Suc n) s1 << i_rt (Suc n) s2 |] ==>
96.619 + i_rt n s1 << i_rt n s2"
96.620 +apply (simp add: i_th_def i_rt_Suc_back)
96.621 +apply (cases "i_rt n s1", simp)
96.622 +apply (cases "i_rt n s2", auto)
96.623 +done
96.624 +
96.625 +lemma i_th_stream_take_Suc [rule_format]:
96.626 + "ALL s. i_th n (stream_take (Suc n)$s) = i_th n s"
96.627 +apply (induct_tac n,auto)
96.628 + apply (simp add: i_th_def)
96.629 + apply (case_tac "s=UU",auto)
96.630 + apply (drule stream_exhaust_eq [THEN iffD1],auto)
96.631 +apply (case_tac "s=UU",simp add: i_th_def)
96.632 +apply (drule stream_exhaust_eq [THEN iffD1],auto)
96.633 +by (simp add: i_th_def i_rt_Suc_forw)
96.634 +
96.635 +lemma i_th_last: "i_th n s && UU = i_rt n (stream_take (Suc n)$s)"
96.636 +apply (insert surjectiv_scons [of "i_rt n (stream_take (Suc n)$s)"])
96.637 +apply (rule i_th_stream_take_Suc [THEN subst])
96.638 +apply (simp add: i_th_def i_rt_Suc_back [symmetric])
96.639 +by (simp add: i_rt_take_lemma1)
96.640 +
96.641 +lemma i_th_last_eq:
96.642 +"i_th n s1 = i_th n s2 ==> i_rt n (stream_take (Suc n)$s1) = i_rt n (stream_take (Suc n)$s2)"
96.643 +apply (insert i_th_last [of n s1])
96.644 +apply (insert i_th_last [of n s2])
96.645 +by auto
96.646 +
96.647 +lemma i_th_prefix_lemma:
96.648 +"[| k <= n; stream_take (Suc n)$s1 << stream_take (Suc n)$s2 |] ==>
96.649 + i_th k s1 << i_th k s2"
96.650 +apply (insert i_th_stream_take_Suc [of k s1, THEN sym])
96.651 +apply (insert i_th_stream_take_Suc [of k s2, THEN sym],auto)
96.652 +apply (simp add: i_th_def)
96.653 +apply (rule monofun_cfun, auto)
96.654 +apply (rule i_rt_mono)
96.655 +by (blast intro: stream_take_lemma10)
96.656 +
96.657 +lemma take_i_rt_prefix_lemma1:
96.658 + "stream_take (Suc n)$s1 << stream_take (Suc n)$s2 ==>
96.659 + i_rt (Suc n) s1 << i_rt (Suc n) s2 ==>
96.660 + i_rt n s1 << i_rt n s2 & stream_take n$s1 << stream_take n$s2"
96.661 +apply auto
96.662 + apply (insert i_th_prefix_lemma [of n n s1 s2])
96.663 + apply (rule i_th_i_rt_step,auto)
96.664 +by (drule mono_stream_take_pred,simp)
96.665 +
96.666 +lemma take_i_rt_prefix_lemma:
96.667 +"[| stream_take n$s1 << stream_take n$s2; i_rt n s1 << i_rt n s2 |] ==> s1 << s2"
96.668 +apply (case_tac "n=0",simp)
96.669 +apply (auto)
96.670 +apply (subgoal_tac "stream_take 0$s1 << stream_take 0$s2 &
96.671 + i_rt 0 s1 << i_rt 0 s2")
96.672 + defer 1
96.673 + apply (rule zero_induct,blast)
96.674 + apply (blast dest: take_i_rt_prefix_lemma1)
96.675 +by simp
96.676 +
96.677 +lemma streams_prefix_lemma: "(s1 << s2) =
96.678 + (stream_take n$s1 << stream_take n$s2 & i_rt n s1 << i_rt n s2)"
96.679 +apply auto
96.680 + apply (simp add: monofun_cfun_arg)
96.681 + apply (simp add: i_rt_mono)
96.682 +by (erule take_i_rt_prefix_lemma,simp)
96.683 +
96.684 +lemma streams_prefix_lemma1:
96.685 + "[| stream_take n$s1 = stream_take n$s2; i_rt n s1 = i_rt n s2 |] ==> s1 = s2"
96.686 +apply (simp add: po_eq_conv,auto)
96.687 + apply (insert streams_prefix_lemma)
96.688 + by blast+
96.689 +
96.690 +
96.691 +(* ----------------------------------------------------------------------- *)
96.692 + section "sconc"
96.693 +(* ----------------------------------------------------------------------- *)
96.694 +
96.695 +lemma UU_sconc [simp]: " UU ooo s = s "
96.696 +by (simp add: sconc_def zero_inat_def)
96.697 +
96.698 +lemma scons_neq_UU: "a~=UU ==> a && s ~=UU"
96.699 +by auto
96.700 +
96.701 +lemma singleton_sconc [rule_format, simp]: "x~=UU --> (x && UU) ooo y = x && y"
96.702 +apply (simp add: sconc_def zero_inat_def iSuc_def split: inat.splits, auto)
96.703 +apply (rule someI2_ex,auto)
96.704 + apply (rule_tac x="x && y" in exI,auto)
96.705 +apply (simp add: i_rt_Suc_forw)
96.706 +apply (case_tac "xa=UU",simp)
96.707 +by (drule stream_exhaust_eq [THEN iffD1],auto)
96.708 +
96.709 +lemma ex_sconc [rule_format]:
96.710 + "ALL k y. #x = Fin k --> (EX w. stream_take k$w = x & i_rt k w = y)"
96.711 +apply (case_tac "#x")
96.712 + apply (rule stream_finite_ind [of x],auto)
96.713 + apply (simp add: stream.finite_def)
96.714 + apply (drule slen_take_lemma1,blast)
96.715 + apply (simp_all add: zero_inat_def iSuc_def split: inat.splits)
96.716 +apply (erule_tac x="y" in allE,auto)
96.717 +by (rule_tac x="a && w" in exI,auto)
96.718 +
96.719 +lemma rt_sconc1: "Fin n = #x ==> i_rt n (x ooo y) = y"
96.720 +apply (simp add: sconc_def split: inat.splits, arith?,auto)
96.721 +apply (rule someI2_ex,auto)
96.722 +by (drule ex_sconc,simp)
96.723 +
96.724 +lemma sconc_inj2: "\<lbrakk>Fin n = #x; x ooo y = x ooo z\<rbrakk> \<Longrightarrow> y = z"
96.725 +apply (frule_tac y=y in rt_sconc1)
96.726 +by (auto elim: rt_sconc1)
96.727 +
96.728 +lemma sconc_UU [simp]:"s ooo UU = s"
96.729 +apply (case_tac "#s")
96.730 + apply (simp add: sconc_def)
96.731 + apply (rule someI2_ex)
96.732 + apply (rule_tac x="s" in exI)
96.733 + apply auto
96.734 + apply (drule slen_take_lemma1,auto)
96.735 + apply (simp add: i_rt_lemma_slen)
96.736 + apply (drule slen_take_lemma1,auto)
96.737 + apply (simp add: i_rt_slen)
96.738 +by (simp add: sconc_def)
96.739 +
96.740 +lemma stream_take_sconc [simp]: "Fin n = #x ==> stream_take n$(x ooo y) = x"
96.741 +apply (simp add: sconc_def)
96.742 +apply (cases "#x")
96.743 +apply auto
96.744 +apply (rule someI2_ex, auto)
96.745 +by (drule ex_sconc,simp)
96.746 +
96.747 +lemma scons_sconc [rule_format,simp]: "a~=UU --> (a && x) ooo y = a && x ooo y"
96.748 +apply (cases "#x",auto)
96.749 + apply (simp add: sconc_def iSuc_Fin)
96.750 + apply (rule someI2_ex)
96.751 + apply (drule ex_sconc, simp)
96.752 + apply (rule someI2_ex, auto)
96.753 + apply (simp add: i_rt_Suc_forw)
96.754 + apply (rule_tac x="a && x" in exI, auto)
96.755 + apply (case_tac "xa=UU",auto)
96.756 + apply (drule stream_exhaust_eq [THEN iffD1],auto)
96.757 + apply (drule streams_prefix_lemma1,simp+)
96.758 +by (simp add: sconc_def)
96.759 +
96.760 +lemma ft_sconc: "x ~= UU ==> ft$(x ooo y) = ft$x"
96.761 +by (cases x, auto)
96.762 +
96.763 +lemma sconc_assoc: "(x ooo y) ooo z = x ooo y ooo z"
96.764 +apply (case_tac "#x")
96.765 + apply (rule stream_finite_ind [of x],auto simp del: scons_sconc)
96.766 + apply (simp add: stream.finite_def del: scons_sconc)
96.767 + apply (drule slen_take_lemma1,auto simp del: scons_sconc)
96.768 + apply (case_tac "a = UU", auto)
96.769 +by (simp add: sconc_def)
96.770 +
96.771 +
96.772 +(* ----------------------------------------------------------------------- *)
96.773 +
96.774 +lemma cont_sconc_lemma1: "stream_finite x \<Longrightarrow> cont (\<lambda>y. x ooo y)"
96.775 +by (erule stream_finite_ind, simp_all)
96.776 +
96.777 +lemma cont_sconc_lemma2: "\<not> stream_finite x \<Longrightarrow> cont (\<lambda>y. x ooo y)"
96.778 +by (simp add: sconc_def slen_def)
96.779 +
96.780 +lemma cont_sconc: "cont (\<lambda>y. x ooo y)"
96.781 +apply (cases "stream_finite x")
96.782 +apply (erule cont_sconc_lemma1)
96.783 +apply (erule cont_sconc_lemma2)
96.784 +done
96.785 +
96.786 +lemma sconc_mono: "y << y' ==> x ooo y << x ooo y'"
96.787 +by (rule cont_sconc [THEN cont2mono, THEN monofunE])
96.788 +
96.789 +lemma sconc_mono1 [simp]: "x << x ooo y"
96.790 +by (rule sconc_mono [of UU, simplified])
96.791 +
96.792 +(* ----------------------------------------------------------------------- *)
96.793 +
96.794 +lemma empty_sconc [simp]: "(x ooo y = UU) = (x = UU & y = UU)"
96.795 +apply (case_tac "#x",auto)
96.796 + apply (insert sconc_mono1 [of x y])
96.797 + by auto
96.798 +
96.799 +(* ----------------------------------------------------------------------- *)
96.800 +
96.801 +lemma rt_sconc [rule_format, simp]: "s~=UU --> rt$(s ooo x) = rt$s ooo x"
96.802 +by (cases s, auto)
96.803 +
96.804 +lemma i_th_sconc_lemma [rule_format]:
96.805 + "ALL x y. Fin n < #x --> i_th n (x ooo y) = i_th n x"
96.806 +apply (induct_tac n, auto)
96.807 +apply (simp add: Fin_0 i_th_def)
96.808 +apply (simp add: slen_empty_eq ft_sconc)
96.809 +apply (simp add: i_th_def)
96.810 +apply (case_tac "x=UU",auto)
96.811 +apply (drule stream_exhaust_eq [THEN iffD1], auto)
96.812 +apply (erule_tac x="ya" in allE)
96.813 +apply (case_tac "#ya") by simp_all
96.814 +
96.815 +
96.816 +
96.817 +(* ----------------------------------------------------------------------- *)
96.818 +
96.819 +lemma sconc_lemma [rule_format, simp]: "ALL s. stream_take n$s ooo i_rt n s = s"
96.820 +apply (induct_tac n,auto)
96.821 +apply (case_tac "s=UU",auto)
96.822 +by (drule stream_exhaust_eq [THEN iffD1],auto)
96.823 +
96.824 +(* ----------------------------------------------------------------------- *)
96.825 + subsection "pointwise equality"
96.826 +(* ----------------------------------------------------------------------- *)
96.827 +
96.828 +lemma ex_last_stream_take_scons: "stream_take (Suc n)$s =
96.829 + stream_take n$s ooo i_rt n (stream_take (Suc n)$s)"
96.830 +by (insert sconc_lemma [of n "stream_take (Suc n)$s"],simp)
96.831 +
96.832 +lemma i_th_stream_take_eq:
96.833 +"!!n. ALL n. i_th n s1 = i_th n s2 ==> stream_take n$s1 = stream_take n$s2"
96.834 +apply (induct_tac n,auto)
96.835 +apply (subgoal_tac "stream_take (Suc na)$s1 =
96.836 + stream_take na$s1 ooo i_rt na (stream_take (Suc na)$s1)")
96.837 + apply (subgoal_tac "i_rt na (stream_take (Suc na)$s1) =
96.838 + i_rt na (stream_take (Suc na)$s2)")
96.839 + apply (subgoal_tac "stream_take (Suc na)$s2 =
96.840 + stream_take na$s2 ooo i_rt na (stream_take (Suc na)$s2)")
96.841 + apply (insert ex_last_stream_take_scons,simp)
96.842 + apply blast
96.843 + apply (erule_tac x="na" in allE)
96.844 + apply (insert i_th_last_eq [of _ s1 s2])
96.845 +by blast+
96.846 +
96.847 +lemma pointwise_eq_lemma[rule_format]: "ALL n. i_th n s1 = i_th n s2 ==> s1 = s2"
96.848 +by (insert i_th_stream_take_eq [THEN stream.take_lemma],blast)
96.849 +
96.850 +(* ----------------------------------------------------------------------- *)
96.851 + subsection "finiteness"
96.852 +(* ----------------------------------------------------------------------- *)
96.853 +
96.854 +lemma slen_sconc_finite1:
96.855 + "[| #(x ooo y) = Infty; Fin n = #x |] ==> #y = Infty"
96.856 +apply (case_tac "#y ~= Infty",auto)
96.857 +apply (drule_tac y=y in rt_sconc1)
96.858 +apply (insert stream_finite_i_rt [of n "x ooo y"])
96.859 +by (simp add: slen_infinite)
96.860 +
96.861 +lemma slen_sconc_infinite1: "#x=Infty ==> #(x ooo y) = Infty"
96.862 +by (simp add: sconc_def)
96.863 +
96.864 +lemma slen_sconc_infinite2: "#y=Infty ==> #(x ooo y) = Infty"
96.865 +apply (case_tac "#x")
96.866 + apply (simp add: sconc_def)
96.867 + apply (rule someI2_ex)
96.868 + apply (drule ex_sconc,auto)
96.869 + apply (erule contrapos_pp)
96.870 + apply (insert stream_finite_i_rt)
96.871 + apply (fastsimp simp add: slen_infinite,auto)
96.872 +by (simp add: sconc_def)
96.873 +
96.874 +lemma sconc_finite: "(#x~=Infty & #y~=Infty) = (#(x ooo y)~=Infty)"
96.875 +apply auto
96.876 + apply (metis not_Infty_eq slen_sconc_finite1)
96.877 + apply (metis not_Infty_eq slen_sconc_infinite1)
96.878 +apply (metis not_Infty_eq slen_sconc_infinite2)
96.879 +done
96.880 +
96.881 +(* ----------------------------------------------------------------------- *)
96.882 +
96.883 +lemma slen_sconc_mono3: "[| Fin n = #x; Fin k = #(x ooo y) |] ==> n <= k"
96.884 +apply (insert slen_mono [of "x" "x ooo y"])
96.885 +apply (cases "#x") apply simp_all
96.886 +apply (cases "#(x ooo y)") apply simp_all
96.887 +done
96.888 +
96.889 +(* ----------------------------------------------------------------------- *)
96.890 + subsection "finite slen"
96.891 +(* ----------------------------------------------------------------------- *)
96.892 +
96.893 +lemma slen_sconc: "[| Fin n = #x; Fin m = #y |] ==> #(x ooo y) = Fin (n + m)"
96.894 +apply (case_tac "#(x ooo y)")
96.895 + apply (frule_tac y=y in rt_sconc1)
96.896 + apply (insert take_i_rt_len [of "THE j. Fin j = #(x ooo y)" "x ooo y" n n m],simp)
96.897 + apply (insert slen_sconc_mono3 [of n x _ y],simp)
96.898 +by (insert sconc_finite [of x y],auto)
96.899 +
96.900 +(* ----------------------------------------------------------------------- *)
96.901 + subsection "flat prefix"
96.902 +(* ----------------------------------------------------------------------- *)
96.903 +
96.904 +lemma sconc_prefix: "(s1::'a::flat stream) << s2 ==> EX t. s1 ooo t = s2"
96.905 +apply (case_tac "#s1")
96.906 + apply (subgoal_tac "stream_take nat$s1 = stream_take nat$s2")
96.907 + apply (rule_tac x="i_rt nat s2" in exI)
96.908 + apply (simp add: sconc_def)
96.909 + apply (rule someI2_ex)
96.910 + apply (drule ex_sconc)
96.911 + apply (simp,clarsimp,drule streams_prefix_lemma1)
96.912 + apply (simp+,rule slen_take_lemma3 [of _ s1 s2])
96.913 + apply (simp+,rule_tac x="UU" in exI)
96.914 +apply (insert slen_take_lemma3 [of _ s1 s2])
96.915 +by (rule stream.take_lemma,simp)
96.916 +
96.917 +(* ----------------------------------------------------------------------- *)
96.918 + subsection "continuity"
96.919 +(* ----------------------------------------------------------------------- *)
96.920 +
96.921 +lemma chain_sconc: "chain S ==> chain (%i. (x ooo S i))"
96.922 +by (simp add: chain_def,auto simp add: sconc_mono)
96.923 +
96.924 +lemma chain_scons: "chain S ==> chain (%i. a && S i)"
96.925 +apply (simp add: chain_def,auto)
96.926 +by (rule monofun_cfun_arg,simp)
96.927 +
96.928 +lemma contlub_scons_lemma: "chain S ==> (LUB i. a && S i) = a && (LUB i. S i)"
96.929 +by (rule cont2contlubE [OF cont_Rep_cfun2, symmetric])
96.930 +
96.931 +lemma finite_lub_sconc: "chain Y ==> (stream_finite x) ==>
96.932 + (LUB i. x ooo Y i) = (x ooo (LUB i. Y i))"
96.933 +apply (rule stream_finite_ind [of x])
96.934 + apply (auto)
96.935 +apply (subgoal_tac "(LUB i. a && (s ooo Y i)) = a && (LUB i. s ooo Y i)")
96.936 + by (force,blast dest: contlub_scons_lemma chain_sconc)
96.937 +
96.938 +lemma contlub_sconc_lemma:
96.939 + "chain Y ==> (LUB i. x ooo Y i) = (x ooo (LUB i. Y i))"
96.940 +apply (case_tac "#x=Infty")
96.941 + apply (simp add: sconc_def)
96.942 +apply (drule finite_lub_sconc,auto simp add: slen_infinite)
96.943 +done
96.944 +
96.945 +lemma monofun_sconc: "monofun (%y. x ooo y)"
96.946 +by (simp add: monofun_def sconc_mono)
96.947 +
96.948 +
96.949 +(* ----------------------------------------------------------------------- *)
96.950 + section "constr_sconc"
96.951 +(* ----------------------------------------------------------------------- *)
96.952 +
96.953 +lemma constr_sconc_UUs [simp]: "constr_sconc UU s = s"
96.954 +by (simp add: constr_sconc_def zero_inat_def)
96.955 +
96.956 +lemma "x ooo y = constr_sconc x y"
96.957 +apply (case_tac "#x")
96.958 + apply (rule stream_finite_ind [of x],auto simp del: scons_sconc)
96.959 + defer 1
96.960 + apply (simp add: constr_sconc_def del: scons_sconc)
96.961 + apply (case_tac "#s")
96.962 + apply (simp add: iSuc_Fin)
96.963 + apply (case_tac "a=UU",auto simp del: scons_sconc)
96.964 + apply (simp)
96.965 + apply (simp add: sconc_def)
96.966 + apply (simp add: constr_sconc_def)
96.967 +apply (simp add: stream.finite_def)
96.968 +by (drule slen_take_lemma1,auto)
96.969 +
96.970 +end
97.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
97.2 +++ b/src/HOL/HOLCF/Library/Sum_Cpo.thy Sat Nov 27 16:08:10 2010 -0800
97.3 @@ -0,0 +1,292 @@
97.4 +(* Title: HOLCF/Sum_Cpo.thy
97.5 + Author: Brian Huffman
97.6 +*)
97.7 +
97.8 +header {* The cpo of disjoint sums *}
97.9 +
97.10 +theory Sum_Cpo
97.11 +imports HOLCF
97.12 +begin
97.13 +
97.14 +subsection {* Ordering on sum type *}
97.15 +
97.16 +instantiation sum :: (below, below) below
97.17 +begin
97.18 +
97.19 +definition below_sum_def:
97.20 + "x \<sqsubseteq> y \<equiv> case x of
97.21 + Inl a \<Rightarrow> (case y of Inl b \<Rightarrow> a \<sqsubseteq> b | Inr b \<Rightarrow> False) |
97.22 + Inr a \<Rightarrow> (case y of Inl b \<Rightarrow> False | Inr b \<Rightarrow> a \<sqsubseteq> b)"
97.23 +
97.24 +instance ..
97.25 +end
97.26 +
97.27 +lemma Inl_below_Inl [simp]: "Inl x \<sqsubseteq> Inl y \<longleftrightarrow> x \<sqsubseteq> y"
97.28 +unfolding below_sum_def by simp
97.29 +
97.30 +lemma Inr_below_Inr [simp]: "Inr x \<sqsubseteq> Inr y \<longleftrightarrow> x \<sqsubseteq> y"
97.31 +unfolding below_sum_def by simp
97.32 +
97.33 +lemma Inl_below_Inr [simp]: "\<not> Inl x \<sqsubseteq> Inr y"
97.34 +unfolding below_sum_def by simp
97.35 +
97.36 +lemma Inr_below_Inl [simp]: "\<not> Inr x \<sqsubseteq> Inl y"
97.37 +unfolding below_sum_def by simp
97.38 +
97.39 +lemma Inl_mono: "x \<sqsubseteq> y \<Longrightarrow> Inl x \<sqsubseteq> Inl y"
97.40 +by simp
97.41 +
97.42 +lemma Inr_mono: "x \<sqsubseteq> y \<Longrightarrow> Inr x \<sqsubseteq> Inr y"
97.43 +by simp
97.44 +
97.45 +lemma Inl_belowE: "\<lbrakk>Inl a \<sqsubseteq> x; \<And>b. \<lbrakk>x = Inl b; a \<sqsubseteq> b\<rbrakk> \<Longrightarrow> R\<rbrakk> \<Longrightarrow> R"
97.46 +by (cases x, simp_all)
97.47 +
97.48 +lemma Inr_belowE: "\<lbrakk>Inr a \<sqsubseteq> x; \<And>b. \<lbrakk>x = Inr b; a \<sqsubseteq> b\<rbrakk> \<Longrightarrow> R\<rbrakk> \<Longrightarrow> R"
97.49 +by (cases x, simp_all)
97.50 +
97.51 +lemmas sum_below_elims = Inl_belowE Inr_belowE
97.52 +
97.53 +lemma sum_below_cases:
97.54 + "\<lbrakk>x \<sqsubseteq> y;
97.55 + \<And>a b. \<lbrakk>x = Inl a; y = Inl b; a \<sqsubseteq> b\<rbrakk> \<Longrightarrow> R;
97.56 + \<And>a b. \<lbrakk>x = Inr a; y = Inr b; a \<sqsubseteq> b\<rbrakk> \<Longrightarrow> R\<rbrakk>
97.57 + \<Longrightarrow> R"
97.58 +by (cases x, safe elim!: sum_below_elims, auto)
97.59 +
97.60 +subsection {* Sum type is a complete partial order *}
97.61 +
97.62 +instance sum :: (po, po) po
97.63 +proof
97.64 + fix x :: "'a + 'b"
97.65 + show "x \<sqsubseteq> x"
97.66 + by (induct x, simp_all)
97.67 +next
97.68 + fix x y :: "'a + 'b"
97.69 + assume "x \<sqsubseteq> y" and "y \<sqsubseteq> x" thus "x = y"
97.70 + by (induct x, auto elim!: sum_below_elims intro: below_antisym)
97.71 +next
97.72 + fix x y z :: "'a + 'b"
97.73 + assume "x \<sqsubseteq> y" and "y \<sqsubseteq> z" thus "x \<sqsubseteq> z"
97.74 + by (induct x, auto elim!: sum_below_elims intro: below_trans)
97.75 +qed
97.76 +
97.77 +lemma monofun_inv_Inl: "monofun (\<lambda>p. THE a. p = Inl a)"
97.78 +by (rule monofunI, erule sum_below_cases, simp_all)
97.79 +
97.80 +lemma monofun_inv_Inr: "monofun (\<lambda>p. THE b. p = Inr b)"
97.81 +by (rule monofunI, erule sum_below_cases, simp_all)
97.82 +
97.83 +lemma sum_chain_cases:
97.84 + assumes Y: "chain Y"
97.85 + assumes A: "\<And>A. \<lbrakk>chain A; Y = (\<lambda>i. Inl (A i))\<rbrakk> \<Longrightarrow> R"
97.86 + assumes B: "\<And>B. \<lbrakk>chain B; Y = (\<lambda>i. Inr (B i))\<rbrakk> \<Longrightarrow> R"
97.87 + shows "R"
97.88 + apply (cases "Y 0")
97.89 + apply (rule A)
97.90 + apply (rule ch2ch_monofun [OF monofun_inv_Inl Y])
97.91 + apply (rule ext)
97.92 + apply (cut_tac j=i in chain_mono [OF Y le0], simp)
97.93 + apply (erule Inl_belowE, simp)
97.94 + apply (rule B)
97.95 + apply (rule ch2ch_monofun [OF monofun_inv_Inr Y])
97.96 + apply (rule ext)
97.97 + apply (cut_tac j=i in chain_mono [OF Y le0], simp)
97.98 + apply (erule Inr_belowE, simp)
97.99 +done
97.100 +
97.101 +lemma is_lub_Inl: "range S <<| x \<Longrightarrow> range (\<lambda>i. Inl (S i)) <<| Inl x"
97.102 + apply (rule is_lubI)
97.103 + apply (rule ub_rangeI)
97.104 + apply (simp add: is_lub_rangeD1)
97.105 + apply (frule ub_rangeD [where i=arbitrary])
97.106 + apply (erule Inl_belowE, simp)
97.107 + apply (erule is_lubD2)
97.108 + apply (rule ub_rangeI)
97.109 + apply (drule ub_rangeD, simp)
97.110 +done
97.111 +
97.112 +lemma is_lub_Inr: "range S <<| x \<Longrightarrow> range (\<lambda>i. Inr (S i)) <<| Inr x"
97.113 + apply (rule is_lubI)
97.114 + apply (rule ub_rangeI)
97.115 + apply (simp add: is_lub_rangeD1)
97.116 + apply (frule ub_rangeD [where i=arbitrary])
97.117 + apply (erule Inr_belowE, simp)
97.118 + apply (erule is_lubD2)
97.119 + apply (rule ub_rangeI)
97.120 + apply (drule ub_rangeD, simp)
97.121 +done
97.122 +
97.123 +instance sum :: (cpo, cpo) cpo
97.124 + apply intro_classes
97.125 + apply (erule sum_chain_cases, safe)
97.126 + apply (rule exI)
97.127 + apply (rule is_lub_Inl)
97.128 + apply (erule cpo_lubI)
97.129 + apply (rule exI)
97.130 + apply (rule is_lub_Inr)
97.131 + apply (erule cpo_lubI)
97.132 +done
97.133 +
97.134 +subsection {* Continuity of \emph{Inl}, \emph{Inr}, and case function *}
97.135 +
97.136 +lemma cont_Inl: "cont Inl"
97.137 +by (intro contI is_lub_Inl cpo_lubI)
97.138 +
97.139 +lemma cont_Inr: "cont Inr"
97.140 +by (intro contI is_lub_Inr cpo_lubI)
97.141 +
97.142 +lemmas cont2cont_Inl [simp, cont2cont] = cont_compose [OF cont_Inl]
97.143 +lemmas cont2cont_Inr [simp, cont2cont] = cont_compose [OF cont_Inr]
97.144 +
97.145 +lemmas ch2ch_Inl [simp] = ch2ch_cont [OF cont_Inl]
97.146 +lemmas ch2ch_Inr [simp] = ch2ch_cont [OF cont_Inr]
97.147 +
97.148 +lemmas lub_Inl = cont2contlubE [OF cont_Inl, symmetric]
97.149 +lemmas lub_Inr = cont2contlubE [OF cont_Inr, symmetric]
97.150 +
97.151 +lemma cont_sum_case1:
97.152 + assumes f: "\<And>a. cont (\<lambda>x. f x a)"
97.153 + assumes g: "\<And>b. cont (\<lambda>x. g x b)"
97.154 + shows "cont (\<lambda>x. case y of Inl a \<Rightarrow> f x a | Inr b \<Rightarrow> g x b)"
97.155 +by (induct y, simp add: f, simp add: g)
97.156 +
97.157 +lemma cont_sum_case2: "\<lbrakk>cont f; cont g\<rbrakk> \<Longrightarrow> cont (sum_case f g)"
97.158 +apply (rule contI)
97.159 +apply (erule sum_chain_cases)
97.160 +apply (simp add: cont2contlubE [OF cont_Inl, symmetric] contE)
97.161 +apply (simp add: cont2contlubE [OF cont_Inr, symmetric] contE)
97.162 +done
97.163 +
97.164 +lemma cont2cont_sum_case:
97.165 + assumes f1: "\<And>a. cont (\<lambda>x. f x a)" and f2: "\<And>x. cont (\<lambda>a. f x a)"
97.166 + assumes g1: "\<And>b. cont (\<lambda>x. g x b)" and g2: "\<And>x. cont (\<lambda>b. g x b)"
97.167 + assumes h: "cont (\<lambda>x. h x)"
97.168 + shows "cont (\<lambda>x. case h x of Inl a \<Rightarrow> f x a | Inr b \<Rightarrow> g x b)"
97.169 +apply (rule cont_apply [OF h])
97.170 +apply (rule cont_sum_case2 [OF f2 g2])
97.171 +apply (rule cont_sum_case1 [OF f1 g1])
97.172 +done
97.173 +
97.174 +lemma cont2cont_sum_case' [simp, cont2cont]:
97.175 + assumes f: "cont (\<lambda>p. f (fst p) (snd p))"
97.176 + assumes g: "cont (\<lambda>p. g (fst p) (snd p))"
97.177 + assumes h: "cont (\<lambda>x. h x)"
97.178 + shows "cont (\<lambda>x. case h x of Inl a \<Rightarrow> f x a | Inr b \<Rightarrow> g x b)"
97.179 +using assms by (simp add: cont2cont_sum_case prod_cont_iff)
97.180 +
97.181 +subsection {* Compactness and chain-finiteness *}
97.182 +
97.183 +lemma compact_Inl: "compact a \<Longrightarrow> compact (Inl a)"
97.184 +apply (rule compactI2)
97.185 +apply (erule sum_chain_cases, safe)
97.186 +apply (simp add: lub_Inl)
97.187 +apply (erule (2) compactD2)
97.188 +apply (simp add: lub_Inr)
97.189 +done
97.190 +
97.191 +lemma compact_Inr: "compact a \<Longrightarrow> compact (Inr a)"
97.192 +apply (rule compactI2)
97.193 +apply (erule sum_chain_cases, safe)
97.194 +apply (simp add: lub_Inl)
97.195 +apply (simp add: lub_Inr)
97.196 +apply (erule (2) compactD2)
97.197 +done
97.198 +
97.199 +lemma compact_Inl_rev: "compact (Inl a) \<Longrightarrow> compact a"
97.200 +unfolding compact_def
97.201 +by (drule adm_subst [OF cont_Inl], simp)
97.202 +
97.203 +lemma compact_Inr_rev: "compact (Inr a) \<Longrightarrow> compact a"
97.204 +unfolding compact_def
97.205 +by (drule adm_subst [OF cont_Inr], simp)
97.206 +
97.207 +lemma compact_Inl_iff [simp]: "compact (Inl a) = compact a"
97.208 +by (safe elim!: compact_Inl compact_Inl_rev)
97.209 +
97.210 +lemma compact_Inr_iff [simp]: "compact (Inr a) = compact a"
97.211 +by (safe elim!: compact_Inr compact_Inr_rev)
97.212 +
97.213 +instance sum :: (chfin, chfin) chfin
97.214 +apply intro_classes
97.215 +apply (erule compact_imp_max_in_chain)
97.216 +apply (case_tac "\<Squnion>i. Y i", simp_all)
97.217 +done
97.218 +
97.219 +instance sum :: (discrete_cpo, discrete_cpo) discrete_cpo
97.220 +by intro_classes (simp add: below_sum_def split: sum.split)
97.221 +
97.222 +subsection {* Using sum types with fixrec *}
97.223 +
97.224 +definition
97.225 + "match_Inl = (\<Lambda> x k. case x of Inl a \<Rightarrow> k\<cdot>a | Inr b \<Rightarrow> Fixrec.fail)"
97.226 +
97.227 +definition
97.228 + "match_Inr = (\<Lambda> x k. case x of Inl a \<Rightarrow> Fixrec.fail | Inr b \<Rightarrow> k\<cdot>b)"
97.229 +
97.230 +lemma match_Inl_simps [simp]:
97.231 + "match_Inl\<cdot>(Inl a)\<cdot>k = k\<cdot>a"
97.232 + "match_Inl\<cdot>(Inr b)\<cdot>k = Fixrec.fail"
97.233 +unfolding match_Inl_def by simp_all
97.234 +
97.235 +lemma match_Inr_simps [simp]:
97.236 + "match_Inr\<cdot>(Inl a)\<cdot>k = Fixrec.fail"
97.237 + "match_Inr\<cdot>(Inr b)\<cdot>k = k\<cdot>b"
97.238 +unfolding match_Inr_def by simp_all
97.239 +
97.240 +setup {*
97.241 + Fixrec.add_matchers
97.242 + [ (@{const_name Inl}, @{const_name match_Inl}),
97.243 + (@{const_name Inr}, @{const_name match_Inr}) ]
97.244 +*}
97.245 +
97.246 +subsection {* Disjoint sum is a predomain *}
97.247 +
97.248 +definition
97.249 + "encode_sum_u =
97.250 + (\<Lambda>(up\<cdot>x). case x of Inl a \<Rightarrow> sinl\<cdot>(up\<cdot>a) | Inr b \<Rightarrow> sinr\<cdot>(up\<cdot>b))"
97.251 +
97.252 +definition
97.253 + "decode_sum_u = sscase\<cdot>(\<Lambda>(up\<cdot>a). up\<cdot>(Inl a))\<cdot>(\<Lambda>(up\<cdot>b). up\<cdot>(Inr b))"
97.254 +
97.255 +lemma decode_encode_sum_u [simp]: "decode_sum_u\<cdot>(encode_sum_u\<cdot>x) = x"
97.256 +unfolding decode_sum_u_def encode_sum_u_def
97.257 +by (case_tac x, simp, rename_tac y, case_tac y, simp_all)
97.258 +
97.259 +lemma encode_decode_sum_u [simp]: "encode_sum_u\<cdot>(decode_sum_u\<cdot>x) = x"
97.260 +unfolding decode_sum_u_def encode_sum_u_def
97.261 +apply (case_tac x, simp)
97.262 +apply (rename_tac a, case_tac a, simp, simp)
97.263 +apply (rename_tac b, case_tac b, simp, simp)
97.264 +done
97.265 +
97.266 +instantiation sum :: (predomain, predomain) predomain
97.267 +begin
97.268 +
97.269 +definition
97.270 + "liftemb = (udom_emb ssum_approx oo ssum_map\<cdot>emb\<cdot>emb) oo encode_sum_u"
97.271 +
97.272 +definition
97.273 + "liftprj =
97.274 + decode_sum_u oo (ssum_map\<cdot>prj\<cdot>prj oo udom_prj ssum_approx)"
97.275 +
97.276 +definition
97.277 + "liftdefl (t::('a + 'b) itself) = ssum_defl\<cdot>DEFL('a u)\<cdot>DEFL('b u)"
97.278 +
97.279 +instance proof
97.280 + show "ep_pair liftemb (liftprj :: udom \<rightarrow> ('a + 'b) u)"
97.281 + unfolding liftemb_sum_def liftprj_sum_def
97.282 + apply (rule ep_pair_comp)
97.283 + apply (rule ep_pair.intro, simp, simp)
97.284 + apply (rule ep_pair_comp)
97.285 + apply (intro ep_pair_ssum_map ep_pair_emb_prj)
97.286 + apply (rule ep_pair_udom [OF ssum_approx])
97.287 + done
97.288 + show "cast\<cdot>LIFTDEFL('a + 'b) = liftemb oo (liftprj :: udom \<rightarrow> ('a + 'b) u)"
97.289 + unfolding liftemb_sum_def liftprj_sum_def liftdefl_sum_def
97.290 + by (simp add: cast_ssum_defl cast_DEFL cfcomp1 ssum_map_map)
97.291 +qed
97.292 +
97.293 +end
97.294 +
97.295 +end
98.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
98.2 +++ b/src/HOL/HOLCF/Lift.thy Sat Nov 27 16:08:10 2010 -0800
98.3 @@ -0,0 +1,133 @@
98.4 +(* Title: HOLCF/Lift.thy
98.5 + Author: Olaf Mueller
98.6 +*)
98.7 +
98.8 +header {* Lifting types of class type to flat pcpo's *}
98.9 +
98.10 +theory Lift
98.11 +imports Discrete Up
98.12 +begin
98.13 +
98.14 +default_sort type
98.15 +
98.16 +pcpodef (open) 'a lift = "UNIV :: 'a discr u set"
98.17 +by simp_all
98.18 +
98.19 +lemmas inst_lift_pcpo = Abs_lift_strict [symmetric]
98.20 +
98.21 +definition
98.22 + Def :: "'a \<Rightarrow> 'a lift" where
98.23 + "Def x = Abs_lift (up\<cdot>(Discr x))"
98.24 +
98.25 +subsection {* Lift as a datatype *}
98.26 +
98.27 +lemma lift_induct: "\<lbrakk>P \<bottom>; \<And>x. P (Def x)\<rbrakk> \<Longrightarrow> P y"
98.28 +apply (induct y)
98.29 +apply (rule_tac p=y in upE)
98.30 +apply (simp add: Abs_lift_strict)
98.31 +apply (case_tac x)
98.32 +apply (simp add: Def_def)
98.33 +done
98.34 +
98.35 +rep_datatype "\<bottom>\<Colon>'a lift" Def
98.36 + by (erule lift_induct) (simp_all add: Def_def Abs_lift_inject inst_lift_pcpo)
98.37 +
98.38 +lemmas lift_distinct1 = lift.distinct(1)
98.39 +lemmas lift_distinct2 = lift.distinct(2)
98.40 +lemmas Def_not_UU = lift.distinct(2)
98.41 +lemmas Def_inject = lift.inject
98.42 +
98.43 +
98.44 +text {* @{term UU} and @{term Def} *}
98.45 +
98.46 +lemma not_Undef_is_Def: "(x \<noteq> \<bottom>) = (\<exists>y. x = Def y)"
98.47 + by (cases x) simp_all
98.48 +
98.49 +lemma lift_definedE: "\<lbrakk>x \<noteq> \<bottom>; \<And>a. x = Def a \<Longrightarrow> R\<rbrakk> \<Longrightarrow> R"
98.50 + by (cases x) simp_all
98.51 +
98.52 +text {*
98.53 + For @{term "x ~= UU"} in assumptions @{text defined} replaces @{text
98.54 + x} by @{text "Def a"} in conclusion. *}
98.55 +
98.56 +method_setup defined = {*
98.57 + Scan.succeed (fn ctxt => SIMPLE_METHOD'
98.58 + (etac @{thm lift_definedE} THEN' asm_simp_tac (simpset_of ctxt)))
98.59 +*} ""
98.60 +
98.61 +lemma DefE: "Def x = \<bottom> \<Longrightarrow> R"
98.62 + by simp
98.63 +
98.64 +lemma DefE2: "\<lbrakk>x = Def s; x = \<bottom>\<rbrakk> \<Longrightarrow> R"
98.65 + by simp
98.66 +
98.67 +lemma Def_below_Def: "Def x \<sqsubseteq> Def y \<longleftrightarrow> x = y"
98.68 +by (simp add: below_lift_def Def_def Abs_lift_inverse)
98.69 +
98.70 +lemma Def_below_iff [simp]: "Def x \<sqsubseteq> y \<longleftrightarrow> Def x = y"
98.71 +by (induct y, simp, simp add: Def_below_Def)
98.72 +
98.73 +
98.74 +subsection {* Lift is flat *}
98.75 +
98.76 +instance lift :: (type) flat
98.77 +proof
98.78 + fix x y :: "'a lift"
98.79 + assume "x \<sqsubseteq> y" thus "x = \<bottom> \<or> x = y"
98.80 + by (induct x) auto
98.81 +qed
98.82 +
98.83 +subsection {* Continuity of @{const lift_case} *}
98.84 +
98.85 +lemma lift_case_eq: "lift_case \<bottom> f x = fup\<cdot>(\<Lambda> y. f (undiscr y))\<cdot>(Rep_lift x)"
98.86 +apply (induct x, unfold lift.cases)
98.87 +apply (simp add: Rep_lift_strict)
98.88 +apply (simp add: Def_def Abs_lift_inverse)
98.89 +done
98.90 +
98.91 +lemma cont2cont_lift_case [simp]:
98.92 + "\<lbrakk>\<And>y. cont (\<lambda>x. f x y); cont g\<rbrakk> \<Longrightarrow> cont (\<lambda>x. lift_case \<bottom> (f x) (g x))"
98.93 +unfolding lift_case_eq by (simp add: cont_Rep_lift [THEN cont_compose])
98.94 +
98.95 +subsection {* Further operations *}
98.96 +
98.97 +definition
98.98 + flift1 :: "('a \<Rightarrow> 'b::pcpo) \<Rightarrow> ('a lift \<rightarrow> 'b)" (binder "FLIFT " 10) where
98.99 + "flift1 = (\<lambda>f. (\<Lambda> x. lift_case \<bottom> f x))"
98.100 +
98.101 +translations
98.102 + "\<Lambda>(XCONST Def x). t" => "CONST flift1 (\<lambda>x. t)"
98.103 + "\<Lambda>(CONST Def x). FLIFT y. t" <= "FLIFT x y. t"
98.104 + "\<Lambda>(CONST Def x). t" <= "FLIFT x. t"
98.105 +
98.106 +definition
98.107 + flift2 :: "('a \<Rightarrow> 'b) \<Rightarrow> ('a lift \<rightarrow> 'b lift)" where
98.108 + "flift2 f = (FLIFT x. Def (f x))"
98.109 +
98.110 +lemma flift1_Def [simp]: "flift1 f\<cdot>(Def x) = (f x)"
98.111 +by (simp add: flift1_def)
98.112 +
98.113 +lemma flift2_Def [simp]: "flift2 f\<cdot>(Def x) = Def (f x)"
98.114 +by (simp add: flift2_def)
98.115 +
98.116 +lemma flift1_strict [simp]: "flift1 f\<cdot>\<bottom> = \<bottom>"
98.117 +by (simp add: flift1_def)
98.118 +
98.119 +lemma flift2_strict [simp]: "flift2 f\<cdot>\<bottom> = \<bottom>"
98.120 +by (simp add: flift2_def)
98.121 +
98.122 +lemma flift2_defined [simp]: "x \<noteq> \<bottom> \<Longrightarrow> (flift2 f)\<cdot>x \<noteq> \<bottom>"
98.123 +by (erule lift_definedE, simp)
98.124 +
98.125 +lemma flift2_bottom_iff [simp]: "(flift2 f\<cdot>x = \<bottom>) = (x = \<bottom>)"
98.126 +by (cases x, simp_all)
98.127 +
98.128 +lemma FLIFT_mono:
98.129 + "(\<And>x. f x \<sqsubseteq> g x) \<Longrightarrow> (FLIFT x. f x) \<sqsubseteq> (FLIFT x. g x)"
98.130 +by (rule cfun_belowI, case_tac x, simp_all)
98.131 +
98.132 +lemma cont2cont_flift1 [simp, cont2cont]:
98.133 + "\<lbrakk>\<And>y. cont (\<lambda>x. f x y)\<rbrakk> \<Longrightarrow> cont (\<lambda>x. FLIFT y. f x y)"
98.134 +by (simp add: flift1_def cont2cont_LAM)
98.135 +
98.136 +end
99.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
99.2 +++ b/src/HOL/HOLCF/LowerPD.thy Sat Nov 27 16:08:10 2010 -0800
99.3 @@ -0,0 +1,534 @@
99.4 +(* Title: HOLCF/LowerPD.thy
99.5 + Author: Brian Huffman
99.6 +*)
99.7 +
99.8 +header {* Lower powerdomain *}
99.9 +
99.10 +theory LowerPD
99.11 +imports CompactBasis
99.12 +begin
99.13 +
99.14 +subsection {* Basis preorder *}
99.15 +
99.16 +definition
99.17 + lower_le :: "'a pd_basis \<Rightarrow> 'a pd_basis \<Rightarrow> bool" (infix "\<le>\<flat>" 50) where
99.18 + "lower_le = (\<lambda>u v. \<forall>x\<in>Rep_pd_basis u. \<exists>y\<in>Rep_pd_basis v. x \<sqsubseteq> y)"
99.19 +
99.20 +lemma lower_le_refl [simp]: "t \<le>\<flat> t"
99.21 +unfolding lower_le_def by fast
99.22 +
99.23 +lemma lower_le_trans: "\<lbrakk>t \<le>\<flat> u; u \<le>\<flat> v\<rbrakk> \<Longrightarrow> t \<le>\<flat> v"
99.24 +unfolding lower_le_def
99.25 +apply (rule ballI)
99.26 +apply (drule (1) bspec, erule bexE)
99.27 +apply (drule (1) bspec, erule bexE)
99.28 +apply (erule rev_bexI)
99.29 +apply (erule (1) below_trans)
99.30 +done
99.31 +
99.32 +interpretation lower_le: preorder lower_le
99.33 +by (rule preorder.intro, rule lower_le_refl, rule lower_le_trans)
99.34 +
99.35 +lemma lower_le_minimal [simp]: "PDUnit compact_bot \<le>\<flat> t"
99.36 +unfolding lower_le_def Rep_PDUnit
99.37 +by (simp, rule Rep_pd_basis_nonempty [folded ex_in_conv])
99.38 +
99.39 +lemma PDUnit_lower_mono: "x \<sqsubseteq> y \<Longrightarrow> PDUnit x \<le>\<flat> PDUnit y"
99.40 +unfolding lower_le_def Rep_PDUnit by fast
99.41 +
99.42 +lemma PDPlus_lower_mono: "\<lbrakk>s \<le>\<flat> t; u \<le>\<flat> v\<rbrakk> \<Longrightarrow> PDPlus s u \<le>\<flat> PDPlus t v"
99.43 +unfolding lower_le_def Rep_PDPlus by fast
99.44 +
99.45 +lemma PDPlus_lower_le: "t \<le>\<flat> PDPlus t u"
99.46 +unfolding lower_le_def Rep_PDPlus by fast
99.47 +
99.48 +lemma lower_le_PDUnit_PDUnit_iff [simp]:
99.49 + "(PDUnit a \<le>\<flat> PDUnit b) = (a \<sqsubseteq> b)"
99.50 +unfolding lower_le_def Rep_PDUnit by fast
99.51 +
99.52 +lemma lower_le_PDUnit_PDPlus_iff:
99.53 + "(PDUnit a \<le>\<flat> PDPlus t u) = (PDUnit a \<le>\<flat> t \<or> PDUnit a \<le>\<flat> u)"
99.54 +unfolding lower_le_def Rep_PDPlus Rep_PDUnit by fast
99.55 +
99.56 +lemma lower_le_PDPlus_iff: "(PDPlus t u \<le>\<flat> v) = (t \<le>\<flat> v \<and> u \<le>\<flat> v)"
99.57 +unfolding lower_le_def Rep_PDPlus by fast
99.58 +
99.59 +lemma lower_le_induct [induct set: lower_le]:
99.60 + assumes le: "t \<le>\<flat> u"
99.61 + assumes 1: "\<And>a b. a \<sqsubseteq> b \<Longrightarrow> P (PDUnit a) (PDUnit b)"
99.62 + assumes 2: "\<And>t u a. P (PDUnit a) t \<Longrightarrow> P (PDUnit a) (PDPlus t u)"
99.63 + assumes 3: "\<And>t u v. \<lbrakk>P t v; P u v\<rbrakk> \<Longrightarrow> P (PDPlus t u) v"
99.64 + shows "P t u"
99.65 +using le
99.66 +apply (induct t arbitrary: u rule: pd_basis_induct)
99.67 +apply (erule rev_mp)
99.68 +apply (induct_tac u rule: pd_basis_induct)
99.69 +apply (simp add: 1)
99.70 +apply (simp add: lower_le_PDUnit_PDPlus_iff)
99.71 +apply (simp add: 2)
99.72 +apply (subst PDPlus_commute)
99.73 +apply (simp add: 2)
99.74 +apply (simp add: lower_le_PDPlus_iff 3)
99.75 +done
99.76 +
99.77 +
99.78 +subsection {* Type definition *}
99.79 +
99.80 +typedef (open) 'a lower_pd =
99.81 + "{S::'a pd_basis set. lower_le.ideal S}"
99.82 +by (fast intro: lower_le.ideal_principal)
99.83 +
99.84 +instantiation lower_pd :: ("domain") below
99.85 +begin
99.86 +
99.87 +definition
99.88 + "x \<sqsubseteq> y \<longleftrightarrow> Rep_lower_pd x \<subseteq> Rep_lower_pd y"
99.89 +
99.90 +instance ..
99.91 +end
99.92 +
99.93 +instance lower_pd :: ("domain") po
99.94 +using type_definition_lower_pd below_lower_pd_def
99.95 +by (rule lower_le.typedef_ideal_po)
99.96 +
99.97 +instance lower_pd :: ("domain") cpo
99.98 +using type_definition_lower_pd below_lower_pd_def
99.99 +by (rule lower_le.typedef_ideal_cpo)
99.100 +
99.101 +definition
99.102 + lower_principal :: "'a pd_basis \<Rightarrow> 'a lower_pd" where
99.103 + "lower_principal t = Abs_lower_pd {u. u \<le>\<flat> t}"
99.104 +
99.105 +interpretation lower_pd:
99.106 + ideal_completion lower_le lower_principal Rep_lower_pd
99.107 +using type_definition_lower_pd below_lower_pd_def
99.108 +using lower_principal_def pd_basis_countable
99.109 +by (rule lower_le.typedef_ideal_completion)
99.110 +
99.111 +text {* Lower powerdomain is pointed *}
99.112 +
99.113 +lemma lower_pd_minimal: "lower_principal (PDUnit compact_bot) \<sqsubseteq> ys"
99.114 +by (induct ys rule: lower_pd.principal_induct, simp, simp)
99.115 +
99.116 +instance lower_pd :: ("domain") pcpo
99.117 +by intro_classes (fast intro: lower_pd_minimal)
99.118 +
99.119 +lemma inst_lower_pd_pcpo: "\<bottom> = lower_principal (PDUnit compact_bot)"
99.120 +by (rule lower_pd_minimal [THEN UU_I, symmetric])
99.121 +
99.122 +
99.123 +subsection {* Monadic unit and plus *}
99.124 +
99.125 +definition
99.126 + lower_unit :: "'a \<rightarrow> 'a lower_pd" where
99.127 + "lower_unit = compact_basis.basis_fun (\<lambda>a. lower_principal (PDUnit a))"
99.128 +
99.129 +definition
99.130 + lower_plus :: "'a lower_pd \<rightarrow> 'a lower_pd \<rightarrow> 'a lower_pd" where
99.131 + "lower_plus = lower_pd.basis_fun (\<lambda>t. lower_pd.basis_fun (\<lambda>u.
99.132 + lower_principal (PDPlus t u)))"
99.133 +
99.134 +abbreviation
99.135 + lower_add :: "'a lower_pd \<Rightarrow> 'a lower_pd \<Rightarrow> 'a lower_pd"
99.136 + (infixl "+\<flat>" 65) where
99.137 + "xs +\<flat> ys == lower_plus\<cdot>xs\<cdot>ys"
99.138 +
99.139 +syntax
99.140 + "_lower_pd" :: "args \<Rightarrow> 'a lower_pd" ("{_}\<flat>")
99.141 +
99.142 +translations
99.143 + "{x,xs}\<flat>" == "{x}\<flat> +\<flat> {xs}\<flat>"
99.144 + "{x}\<flat>" == "CONST lower_unit\<cdot>x"
99.145 +
99.146 +lemma lower_unit_Rep_compact_basis [simp]:
99.147 + "{Rep_compact_basis a}\<flat> = lower_principal (PDUnit a)"
99.148 +unfolding lower_unit_def
99.149 +by (simp add: compact_basis.basis_fun_principal PDUnit_lower_mono)
99.150 +
99.151 +lemma lower_plus_principal [simp]:
99.152 + "lower_principal t +\<flat> lower_principal u = lower_principal (PDPlus t u)"
99.153 +unfolding lower_plus_def
99.154 +by (simp add: lower_pd.basis_fun_principal
99.155 + lower_pd.basis_fun_mono PDPlus_lower_mono)
99.156 +
99.157 +interpretation lower_add: semilattice lower_add proof
99.158 + fix xs ys zs :: "'a lower_pd"
99.159 + show "(xs +\<flat> ys) +\<flat> zs = xs +\<flat> (ys +\<flat> zs)"
99.160 + apply (induct xs ys arbitrary: zs rule: lower_pd.principal_induct2, simp, simp)
99.161 + apply (rule_tac x=zs in lower_pd.principal_induct, simp)
99.162 + apply (simp add: PDPlus_assoc)
99.163 + done
99.164 + show "xs +\<flat> ys = ys +\<flat> xs"
99.165 + apply (induct xs ys rule: lower_pd.principal_induct2, simp, simp)
99.166 + apply (simp add: PDPlus_commute)
99.167 + done
99.168 + show "xs +\<flat> xs = xs"
99.169 + apply (induct xs rule: lower_pd.principal_induct, simp)
99.170 + apply (simp add: PDPlus_absorb)
99.171 + done
99.172 +qed
99.173 +
99.174 +lemmas lower_plus_assoc = lower_add.assoc
99.175 +lemmas lower_plus_commute = lower_add.commute
99.176 +lemmas lower_plus_absorb = lower_add.idem
99.177 +lemmas lower_plus_left_commute = lower_add.left_commute
99.178 +lemmas lower_plus_left_absorb = lower_add.left_idem
99.179 +
99.180 +text {* Useful for @{text "simp add: lower_plus_ac"} *}
99.181 +lemmas lower_plus_ac =
99.182 + lower_plus_assoc lower_plus_commute lower_plus_left_commute
99.183 +
99.184 +text {* Useful for @{text "simp only: lower_plus_aci"} *}
99.185 +lemmas lower_plus_aci =
99.186 + lower_plus_ac lower_plus_absorb lower_plus_left_absorb
99.187 +
99.188 +lemma lower_plus_below1: "xs \<sqsubseteq> xs +\<flat> ys"
99.189 +apply (induct xs ys rule: lower_pd.principal_induct2, simp, simp)
99.190 +apply (simp add: PDPlus_lower_le)
99.191 +done
99.192 +
99.193 +lemma lower_plus_below2: "ys \<sqsubseteq> xs +\<flat> ys"
99.194 +by (subst lower_plus_commute, rule lower_plus_below1)
99.195 +
99.196 +lemma lower_plus_least: "\<lbrakk>xs \<sqsubseteq> zs; ys \<sqsubseteq> zs\<rbrakk> \<Longrightarrow> xs +\<flat> ys \<sqsubseteq> zs"
99.197 +apply (subst lower_plus_absorb [of zs, symmetric])
99.198 +apply (erule (1) monofun_cfun [OF monofun_cfun_arg])
99.199 +done
99.200 +
99.201 +lemma lower_plus_below_iff [simp]:
99.202 + "xs +\<flat> ys \<sqsubseteq> zs \<longleftrightarrow> xs \<sqsubseteq> zs \<and> ys \<sqsubseteq> zs"
99.203 +apply safe
99.204 +apply (erule below_trans [OF lower_plus_below1])
99.205 +apply (erule below_trans [OF lower_plus_below2])
99.206 +apply (erule (1) lower_plus_least)
99.207 +done
99.208 +
99.209 +lemma lower_unit_below_plus_iff [simp]:
99.210 + "{x}\<flat> \<sqsubseteq> ys +\<flat> zs \<longleftrightarrow> {x}\<flat> \<sqsubseteq> ys \<or> {x}\<flat> \<sqsubseteq> zs"
99.211 +apply (induct x rule: compact_basis.principal_induct, simp)
99.212 +apply (induct ys rule: lower_pd.principal_induct, simp)
99.213 +apply (induct zs rule: lower_pd.principal_induct, simp)
99.214 +apply (simp add: lower_le_PDUnit_PDPlus_iff)
99.215 +done
99.216 +
99.217 +lemma lower_unit_below_iff [simp]: "{x}\<flat> \<sqsubseteq> {y}\<flat> \<longleftrightarrow> x \<sqsubseteq> y"
99.218 +apply (induct x rule: compact_basis.principal_induct, simp)
99.219 +apply (induct y rule: compact_basis.principal_induct, simp)
99.220 +apply simp
99.221 +done
99.222 +
99.223 +lemmas lower_pd_below_simps =
99.224 + lower_unit_below_iff
99.225 + lower_plus_below_iff
99.226 + lower_unit_below_plus_iff
99.227 +
99.228 +lemma lower_unit_eq_iff [simp]: "{x}\<flat> = {y}\<flat> \<longleftrightarrow> x = y"
99.229 +by (simp add: po_eq_conv)
99.230 +
99.231 +lemma lower_unit_strict [simp]: "{\<bottom>}\<flat> = \<bottom>"
99.232 +using lower_unit_Rep_compact_basis [of compact_bot]
99.233 +by (simp add: inst_lower_pd_pcpo)
99.234 +
99.235 +lemma lower_unit_bottom_iff [simp]: "{x}\<flat> = \<bottom> \<longleftrightarrow> x = \<bottom>"
99.236 +unfolding lower_unit_strict [symmetric] by (rule lower_unit_eq_iff)
99.237 +
99.238 +lemma lower_plus_bottom_iff [simp]:
99.239 + "xs +\<flat> ys = \<bottom> \<longleftrightarrow> xs = \<bottom> \<and> ys = \<bottom>"
99.240 +apply safe
99.241 +apply (rule UU_I, erule subst, rule lower_plus_below1)
99.242 +apply (rule UU_I, erule subst, rule lower_plus_below2)
99.243 +apply (rule lower_plus_absorb)
99.244 +done
99.245 +
99.246 +lemma lower_plus_strict1 [simp]: "\<bottom> +\<flat> ys = ys"
99.247 +apply (rule below_antisym [OF _ lower_plus_below2])
99.248 +apply (simp add: lower_plus_least)
99.249 +done
99.250 +
99.251 +lemma lower_plus_strict2 [simp]: "xs +\<flat> \<bottom> = xs"
99.252 +apply (rule below_antisym [OF _ lower_plus_below1])
99.253 +apply (simp add: lower_plus_least)
99.254 +done
99.255 +
99.256 +lemma compact_lower_unit: "compact x \<Longrightarrow> compact {x}\<flat>"
99.257 +by (auto dest!: compact_basis.compact_imp_principal)
99.258 +
99.259 +lemma compact_lower_unit_iff [simp]: "compact {x}\<flat> \<longleftrightarrow> compact x"
99.260 +apply (safe elim!: compact_lower_unit)
99.261 +apply (simp only: compact_def lower_unit_below_iff [symmetric])
99.262 +apply (erule adm_subst [OF cont_Rep_cfun2])
99.263 +done
99.264 +
99.265 +lemma compact_lower_plus [simp]:
99.266 + "\<lbrakk>compact xs; compact ys\<rbrakk> \<Longrightarrow> compact (xs +\<flat> ys)"
99.267 +by (auto dest!: lower_pd.compact_imp_principal)
99.268 +
99.269 +
99.270 +subsection {* Induction rules *}
99.271 +
99.272 +lemma lower_pd_induct1:
99.273 + assumes P: "adm P"
99.274 + assumes unit: "\<And>x. P {x}\<flat>"
99.275 + assumes insert:
99.276 + "\<And>x ys. \<lbrakk>P {x}\<flat>; P ys\<rbrakk> \<Longrightarrow> P ({x}\<flat> +\<flat> ys)"
99.277 + shows "P (xs::'a lower_pd)"
99.278 +apply (induct xs rule: lower_pd.principal_induct, rule P)
99.279 +apply (induct_tac a rule: pd_basis_induct1)
99.280 +apply (simp only: lower_unit_Rep_compact_basis [symmetric])
99.281 +apply (rule unit)
99.282 +apply (simp only: lower_unit_Rep_compact_basis [symmetric]
99.283 + lower_plus_principal [symmetric])
99.284 +apply (erule insert [OF unit])
99.285 +done
99.286 +
99.287 +lemma lower_pd_induct
99.288 + [case_names adm lower_unit lower_plus, induct type: lower_pd]:
99.289 + assumes P: "adm P"
99.290 + assumes unit: "\<And>x. P {x}\<flat>"
99.291 + assumes plus: "\<And>xs ys. \<lbrakk>P xs; P ys\<rbrakk> \<Longrightarrow> P (xs +\<flat> ys)"
99.292 + shows "P (xs::'a lower_pd)"
99.293 +apply (induct xs rule: lower_pd.principal_induct, rule P)
99.294 +apply (induct_tac a rule: pd_basis_induct)
99.295 +apply (simp only: lower_unit_Rep_compact_basis [symmetric] unit)
99.296 +apply (simp only: lower_plus_principal [symmetric] plus)
99.297 +done
99.298 +
99.299 +
99.300 +subsection {* Monadic bind *}
99.301 +
99.302 +definition
99.303 + lower_bind_basis ::
99.304 + "'a pd_basis \<Rightarrow> ('a \<rightarrow> 'b lower_pd) \<rightarrow> 'b lower_pd" where
99.305 + "lower_bind_basis = fold_pd
99.306 + (\<lambda>a. \<Lambda> f. f\<cdot>(Rep_compact_basis a))
99.307 + (\<lambda>x y. \<Lambda> f. x\<cdot>f +\<flat> y\<cdot>f)"
99.308 +
99.309 +lemma ACI_lower_bind:
99.310 + "class.ab_semigroup_idem_mult (\<lambda>x y. \<Lambda> f. x\<cdot>f +\<flat> y\<cdot>f)"
99.311 +apply unfold_locales
99.312 +apply (simp add: lower_plus_assoc)
99.313 +apply (simp add: lower_plus_commute)
99.314 +apply (simp add: eta_cfun)
99.315 +done
99.316 +
99.317 +lemma lower_bind_basis_simps [simp]:
99.318 + "lower_bind_basis (PDUnit a) =
99.319 + (\<Lambda> f. f\<cdot>(Rep_compact_basis a))"
99.320 + "lower_bind_basis (PDPlus t u) =
99.321 + (\<Lambda> f. lower_bind_basis t\<cdot>f +\<flat> lower_bind_basis u\<cdot>f)"
99.322 +unfolding lower_bind_basis_def
99.323 +apply -
99.324 +apply (rule fold_pd_PDUnit [OF ACI_lower_bind])
99.325 +apply (rule fold_pd_PDPlus [OF ACI_lower_bind])
99.326 +done
99.327 +
99.328 +lemma lower_bind_basis_mono:
99.329 + "t \<le>\<flat> u \<Longrightarrow> lower_bind_basis t \<sqsubseteq> lower_bind_basis u"
99.330 +unfolding cfun_below_iff
99.331 +apply (erule lower_le_induct, safe)
99.332 +apply (simp add: monofun_cfun)
99.333 +apply (simp add: rev_below_trans [OF lower_plus_below1])
99.334 +apply simp
99.335 +done
99.336 +
99.337 +definition
99.338 + lower_bind :: "'a lower_pd \<rightarrow> ('a \<rightarrow> 'b lower_pd) \<rightarrow> 'b lower_pd" where
99.339 + "lower_bind = lower_pd.basis_fun lower_bind_basis"
99.340 +
99.341 +lemma lower_bind_principal [simp]:
99.342 + "lower_bind\<cdot>(lower_principal t) = lower_bind_basis t"
99.343 +unfolding lower_bind_def
99.344 +apply (rule lower_pd.basis_fun_principal)
99.345 +apply (erule lower_bind_basis_mono)
99.346 +done
99.347 +
99.348 +lemma lower_bind_unit [simp]:
99.349 + "lower_bind\<cdot>{x}\<flat>\<cdot>f = f\<cdot>x"
99.350 +by (induct x rule: compact_basis.principal_induct, simp, simp)
99.351 +
99.352 +lemma lower_bind_plus [simp]:
99.353 + "lower_bind\<cdot>(xs +\<flat> ys)\<cdot>f = lower_bind\<cdot>xs\<cdot>f +\<flat> lower_bind\<cdot>ys\<cdot>f"
99.354 +by (induct xs ys rule: lower_pd.principal_induct2, simp, simp, simp)
99.355 +
99.356 +lemma lower_bind_strict [simp]: "lower_bind\<cdot>\<bottom>\<cdot>f = f\<cdot>\<bottom>"
99.357 +unfolding lower_unit_strict [symmetric] by (rule lower_bind_unit)
99.358 +
99.359 +lemma lower_bind_bind:
99.360 + "lower_bind\<cdot>(lower_bind\<cdot>xs\<cdot>f)\<cdot>g = lower_bind\<cdot>xs\<cdot>(\<Lambda> x. lower_bind\<cdot>(f\<cdot>x)\<cdot>g)"
99.361 +by (induct xs, simp_all)
99.362 +
99.363 +
99.364 +subsection {* Map *}
99.365 +
99.366 +definition
99.367 + lower_map :: "('a \<rightarrow> 'b) \<rightarrow> 'a lower_pd \<rightarrow> 'b lower_pd" where
99.368 + "lower_map = (\<Lambda> f xs. lower_bind\<cdot>xs\<cdot>(\<Lambda> x. {f\<cdot>x}\<flat>))"
99.369 +
99.370 +lemma lower_map_unit [simp]:
99.371 + "lower_map\<cdot>f\<cdot>{x}\<flat> = {f\<cdot>x}\<flat>"
99.372 +unfolding lower_map_def by simp
99.373 +
99.374 +lemma lower_map_plus [simp]:
99.375 + "lower_map\<cdot>f\<cdot>(xs +\<flat> ys) = lower_map\<cdot>f\<cdot>xs +\<flat> lower_map\<cdot>f\<cdot>ys"
99.376 +unfolding lower_map_def by simp
99.377 +
99.378 +lemma lower_map_bottom [simp]: "lower_map\<cdot>f\<cdot>\<bottom> = {f\<cdot>\<bottom>}\<flat>"
99.379 +unfolding lower_map_def by simp
99.380 +
99.381 +lemma lower_map_ident: "lower_map\<cdot>(\<Lambda> x. x)\<cdot>xs = xs"
99.382 +by (induct xs rule: lower_pd_induct, simp_all)
99.383 +
99.384 +lemma lower_map_ID: "lower_map\<cdot>ID = ID"
99.385 +by (simp add: cfun_eq_iff ID_def lower_map_ident)
99.386 +
99.387 +lemma lower_map_map:
99.388 + "lower_map\<cdot>f\<cdot>(lower_map\<cdot>g\<cdot>xs) = lower_map\<cdot>(\<Lambda> x. f\<cdot>(g\<cdot>x))\<cdot>xs"
99.389 +by (induct xs rule: lower_pd_induct, simp_all)
99.390 +
99.391 +lemma ep_pair_lower_map: "ep_pair e p \<Longrightarrow> ep_pair (lower_map\<cdot>e) (lower_map\<cdot>p)"
99.392 +apply default
99.393 +apply (induct_tac x rule: lower_pd_induct, simp_all add: ep_pair.e_inverse)
99.394 +apply (induct_tac y rule: lower_pd_induct)
99.395 +apply (simp_all add: ep_pair.e_p_below monofun_cfun del: lower_plus_below_iff)
99.396 +done
99.397 +
99.398 +lemma deflation_lower_map: "deflation d \<Longrightarrow> deflation (lower_map\<cdot>d)"
99.399 +apply default
99.400 +apply (induct_tac x rule: lower_pd_induct, simp_all add: deflation.idem)
99.401 +apply (induct_tac x rule: lower_pd_induct)
99.402 +apply (simp_all add: deflation.below monofun_cfun del: lower_plus_below_iff)
99.403 +done
99.404 +
99.405 +(* FIXME: long proof! *)
99.406 +lemma finite_deflation_lower_map:
99.407 + assumes "finite_deflation d" shows "finite_deflation (lower_map\<cdot>d)"
99.408 +proof (rule finite_deflation_intro)
99.409 + interpret d: finite_deflation d by fact
99.410 + have "deflation d" by fact
99.411 + thus "deflation (lower_map\<cdot>d)" by (rule deflation_lower_map)
99.412 + have "finite (range (\<lambda>x. d\<cdot>x))" by (rule d.finite_range)
99.413 + hence "finite (Rep_compact_basis -` range (\<lambda>x. d\<cdot>x))"
99.414 + by (rule finite_vimageI, simp add: inj_on_def Rep_compact_basis_inject)
99.415 + hence "finite (Pow (Rep_compact_basis -` range (\<lambda>x. d\<cdot>x)))" by simp
99.416 + hence "finite (Rep_pd_basis -` (Pow (Rep_compact_basis -` range (\<lambda>x. d\<cdot>x))))"
99.417 + by (rule finite_vimageI, simp add: inj_on_def Rep_pd_basis_inject)
99.418 + hence *: "finite (lower_principal ` Rep_pd_basis -` (Pow (Rep_compact_basis -` range (\<lambda>x. d\<cdot>x))))" by simp
99.419 + hence "finite (range (\<lambda>xs. lower_map\<cdot>d\<cdot>xs))"
99.420 + apply (rule rev_finite_subset)
99.421 + apply clarsimp
99.422 + apply (induct_tac xs rule: lower_pd.principal_induct)
99.423 + apply (simp add: adm_mem_finite *)
99.424 + apply (rename_tac t, induct_tac t rule: pd_basis_induct)
99.425 + apply (simp only: lower_unit_Rep_compact_basis [symmetric] lower_map_unit)
99.426 + apply simp
99.427 + apply (subgoal_tac "\<exists>b. d\<cdot>(Rep_compact_basis a) = Rep_compact_basis b")
99.428 + apply clarsimp
99.429 + apply (rule imageI)
99.430 + apply (rule vimageI2)
99.431 + apply (simp add: Rep_PDUnit)
99.432 + apply (rule range_eqI)
99.433 + apply (erule sym)
99.434 + apply (rule exI)
99.435 + apply (rule Abs_compact_basis_inverse [symmetric])
99.436 + apply (simp add: d.compact)
99.437 + apply (simp only: lower_plus_principal [symmetric] lower_map_plus)
99.438 + apply clarsimp
99.439 + apply (rule imageI)
99.440 + apply (rule vimageI2)
99.441 + apply (simp add: Rep_PDPlus)
99.442 + done
99.443 + thus "finite {xs. lower_map\<cdot>d\<cdot>xs = xs}"
99.444 + by (rule finite_range_imp_finite_fixes)
99.445 +qed
99.446 +
99.447 +subsection {* Lower powerdomain is a domain *}
99.448 +
99.449 +definition
99.450 + lower_approx :: "nat \<Rightarrow> udom lower_pd \<rightarrow> udom lower_pd"
99.451 +where
99.452 + "lower_approx = (\<lambda>i. lower_map\<cdot>(udom_approx i))"
99.453 +
99.454 +lemma lower_approx: "approx_chain lower_approx"
99.455 +using lower_map_ID finite_deflation_lower_map
99.456 +unfolding lower_approx_def by (rule approx_chain_lemma1)
99.457 +
99.458 +definition lower_defl :: "defl \<rightarrow> defl"
99.459 +where "lower_defl = defl_fun1 lower_approx lower_map"
99.460 +
99.461 +lemma cast_lower_defl:
99.462 + "cast\<cdot>(lower_defl\<cdot>A) =
99.463 + udom_emb lower_approx oo lower_map\<cdot>(cast\<cdot>A) oo udom_prj lower_approx"
99.464 +using lower_approx finite_deflation_lower_map
99.465 +unfolding lower_defl_def by (rule cast_defl_fun1)
99.466 +
99.467 +instantiation lower_pd :: ("domain") liftdomain
99.468 +begin
99.469 +
99.470 +definition
99.471 + "emb = udom_emb lower_approx oo lower_map\<cdot>emb"
99.472 +
99.473 +definition
99.474 + "prj = lower_map\<cdot>prj oo udom_prj lower_approx"
99.475 +
99.476 +definition
99.477 + "defl (t::'a lower_pd itself) = lower_defl\<cdot>DEFL('a)"
99.478 +
99.479 +definition
99.480 + "(liftemb :: 'a lower_pd u \<rightarrow> udom) = udom_emb u_approx oo u_map\<cdot>emb"
99.481 +
99.482 +definition
99.483 + "(liftprj :: udom \<rightarrow> 'a lower_pd u) = u_map\<cdot>prj oo udom_prj u_approx"
99.484 +
99.485 +definition
99.486 + "liftdefl (t::'a lower_pd itself) = u_defl\<cdot>DEFL('a lower_pd)"
99.487 +
99.488 +instance
99.489 +using liftemb_lower_pd_def liftprj_lower_pd_def liftdefl_lower_pd_def
99.490 +proof (rule liftdomain_class_intro)
99.491 + show "ep_pair emb (prj :: udom \<rightarrow> 'a lower_pd)"
99.492 + unfolding emb_lower_pd_def prj_lower_pd_def
99.493 + using ep_pair_udom [OF lower_approx]
99.494 + by (intro ep_pair_comp ep_pair_lower_map ep_pair_emb_prj)
99.495 +next
99.496 + show "cast\<cdot>DEFL('a lower_pd) = emb oo (prj :: udom \<rightarrow> 'a lower_pd)"
99.497 + unfolding emb_lower_pd_def prj_lower_pd_def defl_lower_pd_def cast_lower_defl
99.498 + by (simp add: cast_DEFL oo_def cfun_eq_iff lower_map_map)
99.499 +qed
99.500 +
99.501 +end
99.502 +
99.503 +lemma DEFL_lower: "DEFL('a lower_pd) = lower_defl\<cdot>DEFL('a)"
99.504 +by (rule defl_lower_pd_def)
99.505 +
99.506 +
99.507 +subsection {* Join *}
99.508 +
99.509 +definition
99.510 + lower_join :: "'a lower_pd lower_pd \<rightarrow> 'a lower_pd" where
99.511 + "lower_join = (\<Lambda> xss. lower_bind\<cdot>xss\<cdot>(\<Lambda> xs. xs))"
99.512 +
99.513 +lemma lower_join_unit [simp]:
99.514 + "lower_join\<cdot>{xs}\<flat> = xs"
99.515 +unfolding lower_join_def by simp
99.516 +
99.517 +lemma lower_join_plus [simp]:
99.518 + "lower_join\<cdot>(xss +\<flat> yss) = lower_join\<cdot>xss +\<flat> lower_join\<cdot>yss"
99.519 +unfolding lower_join_def by simp
99.520 +
99.521 +lemma lower_join_bottom [simp]: "lower_join\<cdot>\<bottom> = \<bottom>"
99.522 +unfolding lower_join_def by simp
99.523 +
99.524 +lemma lower_join_map_unit:
99.525 + "lower_join\<cdot>(lower_map\<cdot>lower_unit\<cdot>xs) = xs"
99.526 +by (induct xs rule: lower_pd_induct, simp_all)
99.527 +
99.528 +lemma lower_join_map_join:
99.529 + "lower_join\<cdot>(lower_map\<cdot>lower_join\<cdot>xsss) = lower_join\<cdot>(lower_join\<cdot>xsss)"
99.530 +by (induct xsss rule: lower_pd_induct, simp_all)
99.531 +
99.532 +lemma lower_join_map_map:
99.533 + "lower_join\<cdot>(lower_map\<cdot>(lower_map\<cdot>f)\<cdot>xss) =
99.534 + lower_map\<cdot>f\<cdot>(lower_join\<cdot>xss)"
99.535 +by (induct xss rule: lower_pd_induct, simp_all)
99.536 +
99.537 +end
100.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
100.2 +++ b/src/HOL/HOLCF/Map_Functions.thy Sat Nov 27 16:08:10 2010 -0800
100.3 @@ -0,0 +1,464 @@
100.4 +(* Title: HOLCF/Map_Functions.thy
100.5 + Author: Brian Huffman
100.6 +*)
100.7 +
100.8 +header {* Map functions for various types *}
100.9 +
100.10 +theory Map_Functions
100.11 +imports Deflation
100.12 +begin
100.13 +
100.14 +subsection {* Map operator for continuous function space *}
100.15 +
100.16 +default_sort cpo
100.17 +
100.18 +definition
100.19 + cfun_map :: "('b \<rightarrow> 'a) \<rightarrow> ('c \<rightarrow> 'd) \<rightarrow> ('a \<rightarrow> 'c) \<rightarrow> ('b \<rightarrow> 'd)"
100.20 +where
100.21 + "cfun_map = (\<Lambda> a b f x. b\<cdot>(f\<cdot>(a\<cdot>x)))"
100.22 +
100.23 +lemma cfun_map_beta [simp]: "cfun_map\<cdot>a\<cdot>b\<cdot>f\<cdot>x = b\<cdot>(f\<cdot>(a\<cdot>x))"
100.24 +unfolding cfun_map_def by simp
100.25 +
100.26 +lemma cfun_map_ID: "cfun_map\<cdot>ID\<cdot>ID = ID"
100.27 +unfolding cfun_eq_iff by simp
100.28 +
100.29 +lemma cfun_map_map:
100.30 + "cfun_map\<cdot>f1\<cdot>g1\<cdot>(cfun_map\<cdot>f2\<cdot>g2\<cdot>p) =
100.31 + cfun_map\<cdot>(\<Lambda> x. f2\<cdot>(f1\<cdot>x))\<cdot>(\<Lambda> x. g1\<cdot>(g2\<cdot>x))\<cdot>p"
100.32 +by (rule cfun_eqI) simp
100.33 +
100.34 +lemma ep_pair_cfun_map:
100.35 + assumes "ep_pair e1 p1" and "ep_pair e2 p2"
100.36 + shows "ep_pair (cfun_map\<cdot>p1\<cdot>e2) (cfun_map\<cdot>e1\<cdot>p2)"
100.37 +proof
100.38 + interpret e1p1: ep_pair e1 p1 by fact
100.39 + interpret e2p2: ep_pair e2 p2 by fact
100.40 + fix f show "cfun_map\<cdot>e1\<cdot>p2\<cdot>(cfun_map\<cdot>p1\<cdot>e2\<cdot>f) = f"
100.41 + by (simp add: cfun_eq_iff)
100.42 + fix g show "cfun_map\<cdot>p1\<cdot>e2\<cdot>(cfun_map\<cdot>e1\<cdot>p2\<cdot>g) \<sqsubseteq> g"
100.43 + apply (rule cfun_belowI, simp)
100.44 + apply (rule below_trans [OF e2p2.e_p_below])
100.45 + apply (rule monofun_cfun_arg)
100.46 + apply (rule e1p1.e_p_below)
100.47 + done
100.48 +qed
100.49 +
100.50 +lemma deflation_cfun_map:
100.51 + assumes "deflation d1" and "deflation d2"
100.52 + shows "deflation (cfun_map\<cdot>d1\<cdot>d2)"
100.53 +proof
100.54 + interpret d1: deflation d1 by fact
100.55 + interpret d2: deflation d2 by fact
100.56 + fix f
100.57 + show "cfun_map\<cdot>d1\<cdot>d2\<cdot>(cfun_map\<cdot>d1\<cdot>d2\<cdot>f) = cfun_map\<cdot>d1\<cdot>d2\<cdot>f"
100.58 + by (simp add: cfun_eq_iff d1.idem d2.idem)
100.59 + show "cfun_map\<cdot>d1\<cdot>d2\<cdot>f \<sqsubseteq> f"
100.60 + apply (rule cfun_belowI, simp)
100.61 + apply (rule below_trans [OF d2.below])
100.62 + apply (rule monofun_cfun_arg)
100.63 + apply (rule d1.below)
100.64 + done
100.65 +qed
100.66 +
100.67 +lemma finite_range_cfun_map:
100.68 + assumes a: "finite (range (\<lambda>x. a\<cdot>x))"
100.69 + assumes b: "finite (range (\<lambda>y. b\<cdot>y))"
100.70 + shows "finite (range (\<lambda>f. cfun_map\<cdot>a\<cdot>b\<cdot>f))" (is "finite (range ?h)")
100.71 +proof (rule finite_imageD)
100.72 + let ?f = "\<lambda>g. range (\<lambda>x. (a\<cdot>x, g\<cdot>x))"
100.73 + show "finite (?f ` range ?h)"
100.74 + proof (rule finite_subset)
100.75 + let ?B = "Pow (range (\<lambda>x. a\<cdot>x) \<times> range (\<lambda>y. b\<cdot>y))"
100.76 + show "?f ` range ?h \<subseteq> ?B"
100.77 + by clarsimp
100.78 + show "finite ?B"
100.79 + by (simp add: a b)
100.80 + qed
100.81 + show "inj_on ?f (range ?h)"
100.82 + proof (rule inj_onI, rule cfun_eqI, clarsimp)
100.83 + fix x f g
100.84 + assume "range (\<lambda>x. (a\<cdot>x, b\<cdot>(f\<cdot>(a\<cdot>x)))) = range (\<lambda>x. (a\<cdot>x, b\<cdot>(g\<cdot>(a\<cdot>x))))"
100.85 + hence "range (\<lambda>x. (a\<cdot>x, b\<cdot>(f\<cdot>(a\<cdot>x)))) \<subseteq> range (\<lambda>x. (a\<cdot>x, b\<cdot>(g\<cdot>(a\<cdot>x))))"
100.86 + by (rule equalityD1)
100.87 + hence "(a\<cdot>x, b\<cdot>(f\<cdot>(a\<cdot>x))) \<in> range (\<lambda>x. (a\<cdot>x, b\<cdot>(g\<cdot>(a\<cdot>x))))"
100.88 + by (simp add: subset_eq)
100.89 + then obtain y where "(a\<cdot>x, b\<cdot>(f\<cdot>(a\<cdot>x))) = (a\<cdot>y, b\<cdot>(g\<cdot>(a\<cdot>y)))"
100.90 + by (rule rangeE)
100.91 + thus "b\<cdot>(f\<cdot>(a\<cdot>x)) = b\<cdot>(g\<cdot>(a\<cdot>x))"
100.92 + by clarsimp
100.93 + qed
100.94 +qed
100.95 +
100.96 +lemma finite_deflation_cfun_map:
100.97 + assumes "finite_deflation d1" and "finite_deflation d2"
100.98 + shows "finite_deflation (cfun_map\<cdot>d1\<cdot>d2)"
100.99 +proof (rule finite_deflation_intro)
100.100 + interpret d1: finite_deflation d1 by fact
100.101 + interpret d2: finite_deflation d2 by fact
100.102 + have "deflation d1" and "deflation d2" by fact+
100.103 + thus "deflation (cfun_map\<cdot>d1\<cdot>d2)" by (rule deflation_cfun_map)
100.104 + have "finite (range (\<lambda>f. cfun_map\<cdot>d1\<cdot>d2\<cdot>f))"
100.105 + using d1.finite_range d2.finite_range
100.106 + by (rule finite_range_cfun_map)
100.107 + thus "finite {f. cfun_map\<cdot>d1\<cdot>d2\<cdot>f = f}"
100.108 + by (rule finite_range_imp_finite_fixes)
100.109 +qed
100.110 +
100.111 +text {* Finite deflations are compact elements of the function space *}
100.112 +
100.113 +lemma finite_deflation_imp_compact: "finite_deflation d \<Longrightarrow> compact d"
100.114 +apply (frule finite_deflation_imp_deflation)
100.115 +apply (subgoal_tac "compact (cfun_map\<cdot>d\<cdot>d\<cdot>d)")
100.116 +apply (simp add: cfun_map_def deflation.idem eta_cfun)
100.117 +apply (rule finite_deflation.compact)
100.118 +apply (simp only: finite_deflation_cfun_map)
100.119 +done
100.120 +
100.121 +subsection {* Map operator for product type *}
100.122 +
100.123 +definition
100.124 + cprod_map :: "('a \<rightarrow> 'b) \<rightarrow> ('c \<rightarrow> 'd) \<rightarrow> 'a \<times> 'c \<rightarrow> 'b \<times> 'd"
100.125 +where
100.126 + "cprod_map = (\<Lambda> f g p. (f\<cdot>(fst p), g\<cdot>(snd p)))"
100.127 +
100.128 +lemma cprod_map_Pair [simp]: "cprod_map\<cdot>f\<cdot>g\<cdot>(x, y) = (f\<cdot>x, g\<cdot>y)"
100.129 +unfolding cprod_map_def by simp
100.130 +
100.131 +lemma cprod_map_ID: "cprod_map\<cdot>ID\<cdot>ID = ID"
100.132 +unfolding cfun_eq_iff by auto
100.133 +
100.134 +lemma cprod_map_map:
100.135 + "cprod_map\<cdot>f1\<cdot>g1\<cdot>(cprod_map\<cdot>f2\<cdot>g2\<cdot>p) =
100.136 + cprod_map\<cdot>(\<Lambda> x. f1\<cdot>(f2\<cdot>x))\<cdot>(\<Lambda> x. g1\<cdot>(g2\<cdot>x))\<cdot>p"
100.137 +by (induct p) simp
100.138 +
100.139 +lemma ep_pair_cprod_map:
100.140 + assumes "ep_pair e1 p1" and "ep_pair e2 p2"
100.141 + shows "ep_pair (cprod_map\<cdot>e1\<cdot>e2) (cprod_map\<cdot>p1\<cdot>p2)"
100.142 +proof
100.143 + interpret e1p1: ep_pair e1 p1 by fact
100.144 + interpret e2p2: ep_pair e2 p2 by fact
100.145 + fix x show "cprod_map\<cdot>p1\<cdot>p2\<cdot>(cprod_map\<cdot>e1\<cdot>e2\<cdot>x) = x"
100.146 + by (induct x) simp
100.147 + fix y show "cprod_map\<cdot>e1\<cdot>e2\<cdot>(cprod_map\<cdot>p1\<cdot>p2\<cdot>y) \<sqsubseteq> y"
100.148 + by (induct y) (simp add: e1p1.e_p_below e2p2.e_p_below)
100.149 +qed
100.150 +
100.151 +lemma deflation_cprod_map:
100.152 + assumes "deflation d1" and "deflation d2"
100.153 + shows "deflation (cprod_map\<cdot>d1\<cdot>d2)"
100.154 +proof
100.155 + interpret d1: deflation d1 by fact
100.156 + interpret d2: deflation d2 by fact
100.157 + fix x
100.158 + show "cprod_map\<cdot>d1\<cdot>d2\<cdot>(cprod_map\<cdot>d1\<cdot>d2\<cdot>x) = cprod_map\<cdot>d1\<cdot>d2\<cdot>x"
100.159 + by (induct x) (simp add: d1.idem d2.idem)
100.160 + show "cprod_map\<cdot>d1\<cdot>d2\<cdot>x \<sqsubseteq> x"
100.161 + by (induct x) (simp add: d1.below d2.below)
100.162 +qed
100.163 +
100.164 +lemma finite_deflation_cprod_map:
100.165 + assumes "finite_deflation d1" and "finite_deflation d2"
100.166 + shows "finite_deflation (cprod_map\<cdot>d1\<cdot>d2)"
100.167 +proof (rule finite_deflation_intro)
100.168 + interpret d1: finite_deflation d1 by fact
100.169 + interpret d2: finite_deflation d2 by fact
100.170 + have "deflation d1" and "deflation d2" by fact+
100.171 + thus "deflation (cprod_map\<cdot>d1\<cdot>d2)" by (rule deflation_cprod_map)
100.172 + have "{p. cprod_map\<cdot>d1\<cdot>d2\<cdot>p = p} \<subseteq> {x. d1\<cdot>x = x} \<times> {y. d2\<cdot>y = y}"
100.173 + by clarsimp
100.174 + thus "finite {p. cprod_map\<cdot>d1\<cdot>d2\<cdot>p = p}"
100.175 + by (rule finite_subset, simp add: d1.finite_fixes d2.finite_fixes)
100.176 +qed
100.177 +
100.178 +subsection {* Map function for lifted cpo *}
100.179 +
100.180 +definition
100.181 + u_map :: "('a \<rightarrow> 'b) \<rightarrow> 'a u \<rightarrow> 'b u"
100.182 +where
100.183 + "u_map = (\<Lambda> f. fup\<cdot>(up oo f))"
100.184 +
100.185 +lemma u_map_strict [simp]: "u_map\<cdot>f\<cdot>\<bottom> = \<bottom>"
100.186 +unfolding u_map_def by simp
100.187 +
100.188 +lemma u_map_up [simp]: "u_map\<cdot>f\<cdot>(up\<cdot>x) = up\<cdot>(f\<cdot>x)"
100.189 +unfolding u_map_def by simp
100.190 +
100.191 +lemma u_map_ID: "u_map\<cdot>ID = ID"
100.192 +unfolding u_map_def by (simp add: cfun_eq_iff eta_cfun)
100.193 +
100.194 +lemma u_map_map: "u_map\<cdot>f\<cdot>(u_map\<cdot>g\<cdot>p) = u_map\<cdot>(\<Lambda> x. f\<cdot>(g\<cdot>x))\<cdot>p"
100.195 +by (induct p) simp_all
100.196 +
100.197 +lemma ep_pair_u_map: "ep_pair e p \<Longrightarrow> ep_pair (u_map\<cdot>e) (u_map\<cdot>p)"
100.198 +apply default
100.199 +apply (case_tac x, simp, simp add: ep_pair.e_inverse)
100.200 +apply (case_tac y, simp, simp add: ep_pair.e_p_below)
100.201 +done
100.202 +
100.203 +lemma deflation_u_map: "deflation d \<Longrightarrow> deflation (u_map\<cdot>d)"
100.204 +apply default
100.205 +apply (case_tac x, simp, simp add: deflation.idem)
100.206 +apply (case_tac x, simp, simp add: deflation.below)
100.207 +done
100.208 +
100.209 +lemma finite_deflation_u_map:
100.210 + assumes "finite_deflation d" shows "finite_deflation (u_map\<cdot>d)"
100.211 +proof (rule finite_deflation_intro)
100.212 + interpret d: finite_deflation d by fact
100.213 + have "deflation d" by fact
100.214 + thus "deflation (u_map\<cdot>d)" by (rule deflation_u_map)
100.215 + have "{x. u_map\<cdot>d\<cdot>x = x} \<subseteq> insert \<bottom> ((\<lambda>x. up\<cdot>x) ` {x. d\<cdot>x = x})"
100.216 + by (rule subsetI, case_tac x, simp_all)
100.217 + thus "finite {x. u_map\<cdot>d\<cdot>x = x}"
100.218 + by (rule finite_subset, simp add: d.finite_fixes)
100.219 +qed
100.220 +
100.221 +subsection {* Map function for strict products *}
100.222 +
100.223 +default_sort pcpo
100.224 +
100.225 +definition
100.226 + sprod_map :: "('a \<rightarrow> 'b) \<rightarrow> ('c \<rightarrow> 'd) \<rightarrow> 'a \<otimes> 'c \<rightarrow> 'b \<otimes> 'd"
100.227 +where
100.228 + "sprod_map = (\<Lambda> f g. ssplit\<cdot>(\<Lambda> x y. (:f\<cdot>x, g\<cdot>y:)))"
100.229 +
100.230 +lemma sprod_map_strict [simp]: "sprod_map\<cdot>a\<cdot>b\<cdot>\<bottom> = \<bottom>"
100.231 +unfolding sprod_map_def by simp
100.232 +
100.233 +lemma sprod_map_spair [simp]:
100.234 + "x \<noteq> \<bottom> \<Longrightarrow> y \<noteq> \<bottom> \<Longrightarrow> sprod_map\<cdot>f\<cdot>g\<cdot>(:x, y:) = (:f\<cdot>x, g\<cdot>y:)"
100.235 +by (simp add: sprod_map_def)
100.236 +
100.237 +lemma sprod_map_spair':
100.238 + "f\<cdot>\<bottom> = \<bottom> \<Longrightarrow> g\<cdot>\<bottom> = \<bottom> \<Longrightarrow> sprod_map\<cdot>f\<cdot>g\<cdot>(:x, y:) = (:f\<cdot>x, g\<cdot>y:)"
100.239 +by (cases "x = \<bottom> \<or> y = \<bottom>") auto
100.240 +
100.241 +lemma sprod_map_ID: "sprod_map\<cdot>ID\<cdot>ID = ID"
100.242 +unfolding sprod_map_def by (simp add: cfun_eq_iff eta_cfun)
100.243 +
100.244 +lemma sprod_map_map:
100.245 + "\<lbrakk>f1\<cdot>\<bottom> = \<bottom>; g1\<cdot>\<bottom> = \<bottom>\<rbrakk> \<Longrightarrow>
100.246 + sprod_map\<cdot>f1\<cdot>g1\<cdot>(sprod_map\<cdot>f2\<cdot>g2\<cdot>p) =
100.247 + sprod_map\<cdot>(\<Lambda> x. f1\<cdot>(f2\<cdot>x))\<cdot>(\<Lambda> x. g1\<cdot>(g2\<cdot>x))\<cdot>p"
100.248 +apply (induct p, simp)
100.249 +apply (case_tac "f2\<cdot>x = \<bottom>", simp)
100.250 +apply (case_tac "g2\<cdot>y = \<bottom>", simp)
100.251 +apply simp
100.252 +done
100.253 +
100.254 +lemma ep_pair_sprod_map:
100.255 + assumes "ep_pair e1 p1" and "ep_pair e2 p2"
100.256 + shows "ep_pair (sprod_map\<cdot>e1\<cdot>e2) (sprod_map\<cdot>p1\<cdot>p2)"
100.257 +proof
100.258 + interpret e1p1: pcpo_ep_pair e1 p1 unfolding pcpo_ep_pair_def by fact
100.259 + interpret e2p2: pcpo_ep_pair e2 p2 unfolding pcpo_ep_pair_def by fact
100.260 + fix x show "sprod_map\<cdot>p1\<cdot>p2\<cdot>(sprod_map\<cdot>e1\<cdot>e2\<cdot>x) = x"
100.261 + by (induct x) simp_all
100.262 + fix y show "sprod_map\<cdot>e1\<cdot>e2\<cdot>(sprod_map\<cdot>p1\<cdot>p2\<cdot>y) \<sqsubseteq> y"
100.263 + apply (induct y, simp)
100.264 + apply (case_tac "p1\<cdot>x = \<bottom>", simp, case_tac "p2\<cdot>y = \<bottom>", simp)
100.265 + apply (simp add: monofun_cfun e1p1.e_p_below e2p2.e_p_below)
100.266 + done
100.267 +qed
100.268 +
100.269 +lemma deflation_sprod_map:
100.270 + assumes "deflation d1" and "deflation d2"
100.271 + shows "deflation (sprod_map\<cdot>d1\<cdot>d2)"
100.272 +proof
100.273 + interpret d1: deflation d1 by fact
100.274 + interpret d2: deflation d2 by fact
100.275 + fix x
100.276 + show "sprod_map\<cdot>d1\<cdot>d2\<cdot>(sprod_map\<cdot>d1\<cdot>d2\<cdot>x) = sprod_map\<cdot>d1\<cdot>d2\<cdot>x"
100.277 + apply (induct x, simp)
100.278 + apply (case_tac "d1\<cdot>x = \<bottom>", simp, case_tac "d2\<cdot>y = \<bottom>", simp)
100.279 + apply (simp add: d1.idem d2.idem)
100.280 + done
100.281 + show "sprod_map\<cdot>d1\<cdot>d2\<cdot>x \<sqsubseteq> x"
100.282 + apply (induct x, simp)
100.283 + apply (simp add: monofun_cfun d1.below d2.below)
100.284 + done
100.285 +qed
100.286 +
100.287 +lemma finite_deflation_sprod_map:
100.288 + assumes "finite_deflation d1" and "finite_deflation d2"
100.289 + shows "finite_deflation (sprod_map\<cdot>d1\<cdot>d2)"
100.290 +proof (rule finite_deflation_intro)
100.291 + interpret d1: finite_deflation d1 by fact
100.292 + interpret d2: finite_deflation d2 by fact
100.293 + have "deflation d1" and "deflation d2" by fact+
100.294 + thus "deflation (sprod_map\<cdot>d1\<cdot>d2)" by (rule deflation_sprod_map)
100.295 + have "{x. sprod_map\<cdot>d1\<cdot>d2\<cdot>x = x} \<subseteq> insert \<bottom>
100.296 + ((\<lambda>(x, y). (:x, y:)) ` ({x. d1\<cdot>x = x} \<times> {y. d2\<cdot>y = y}))"
100.297 + by (rule subsetI, case_tac x, auto simp add: spair_eq_iff)
100.298 + thus "finite {x. sprod_map\<cdot>d1\<cdot>d2\<cdot>x = x}"
100.299 + by (rule finite_subset, simp add: d1.finite_fixes d2.finite_fixes)
100.300 +qed
100.301 +
100.302 +subsection {* Map function for strict sums *}
100.303 +
100.304 +definition
100.305 + ssum_map :: "('a \<rightarrow> 'b) \<rightarrow> ('c \<rightarrow> 'd) \<rightarrow> 'a \<oplus> 'c \<rightarrow> 'b \<oplus> 'd"
100.306 +where
100.307 + "ssum_map = (\<Lambda> f g. sscase\<cdot>(sinl oo f)\<cdot>(sinr oo g))"
100.308 +
100.309 +lemma ssum_map_strict [simp]: "ssum_map\<cdot>f\<cdot>g\<cdot>\<bottom> = \<bottom>"
100.310 +unfolding ssum_map_def by simp
100.311 +
100.312 +lemma ssum_map_sinl [simp]: "x \<noteq> \<bottom> \<Longrightarrow> ssum_map\<cdot>f\<cdot>g\<cdot>(sinl\<cdot>x) = sinl\<cdot>(f\<cdot>x)"
100.313 +unfolding ssum_map_def by simp
100.314 +
100.315 +lemma ssum_map_sinr [simp]: "x \<noteq> \<bottom> \<Longrightarrow> ssum_map\<cdot>f\<cdot>g\<cdot>(sinr\<cdot>x) = sinr\<cdot>(g\<cdot>x)"
100.316 +unfolding ssum_map_def by simp
100.317 +
100.318 +lemma ssum_map_sinl': "f\<cdot>\<bottom> = \<bottom> \<Longrightarrow> ssum_map\<cdot>f\<cdot>g\<cdot>(sinl\<cdot>x) = sinl\<cdot>(f\<cdot>x)"
100.319 +by (cases "x = \<bottom>") simp_all
100.320 +
100.321 +lemma ssum_map_sinr': "g\<cdot>\<bottom> = \<bottom> \<Longrightarrow> ssum_map\<cdot>f\<cdot>g\<cdot>(sinr\<cdot>x) = sinr\<cdot>(g\<cdot>x)"
100.322 +by (cases "x = \<bottom>") simp_all
100.323 +
100.324 +lemma ssum_map_ID: "ssum_map\<cdot>ID\<cdot>ID = ID"
100.325 +unfolding ssum_map_def by (simp add: cfun_eq_iff eta_cfun)
100.326 +
100.327 +lemma ssum_map_map:
100.328 + "\<lbrakk>f1\<cdot>\<bottom> = \<bottom>; g1\<cdot>\<bottom> = \<bottom>\<rbrakk> \<Longrightarrow>
100.329 + ssum_map\<cdot>f1\<cdot>g1\<cdot>(ssum_map\<cdot>f2\<cdot>g2\<cdot>p) =
100.330 + ssum_map\<cdot>(\<Lambda> x. f1\<cdot>(f2\<cdot>x))\<cdot>(\<Lambda> x. g1\<cdot>(g2\<cdot>x))\<cdot>p"
100.331 +apply (induct p, simp)
100.332 +apply (case_tac "f2\<cdot>x = \<bottom>", simp, simp)
100.333 +apply (case_tac "g2\<cdot>y = \<bottom>", simp, simp)
100.334 +done
100.335 +
100.336 +lemma ep_pair_ssum_map:
100.337 + assumes "ep_pair e1 p1" and "ep_pair e2 p2"
100.338 + shows "ep_pair (ssum_map\<cdot>e1\<cdot>e2) (ssum_map\<cdot>p1\<cdot>p2)"
100.339 +proof
100.340 + interpret e1p1: pcpo_ep_pair e1 p1 unfolding pcpo_ep_pair_def by fact
100.341 + interpret e2p2: pcpo_ep_pair e2 p2 unfolding pcpo_ep_pair_def by fact
100.342 + fix x show "ssum_map\<cdot>p1\<cdot>p2\<cdot>(ssum_map\<cdot>e1\<cdot>e2\<cdot>x) = x"
100.343 + by (induct x) simp_all
100.344 + fix y show "ssum_map\<cdot>e1\<cdot>e2\<cdot>(ssum_map\<cdot>p1\<cdot>p2\<cdot>y) \<sqsubseteq> y"
100.345 + apply (induct y, simp)
100.346 + apply (case_tac "p1\<cdot>x = \<bottom>", simp, simp add: e1p1.e_p_below)
100.347 + apply (case_tac "p2\<cdot>y = \<bottom>", simp, simp add: e2p2.e_p_below)
100.348 + done
100.349 +qed
100.350 +
100.351 +lemma deflation_ssum_map:
100.352 + assumes "deflation d1" and "deflation d2"
100.353 + shows "deflation (ssum_map\<cdot>d1\<cdot>d2)"
100.354 +proof
100.355 + interpret d1: deflation d1 by fact
100.356 + interpret d2: deflation d2 by fact
100.357 + fix x
100.358 + show "ssum_map\<cdot>d1\<cdot>d2\<cdot>(ssum_map\<cdot>d1\<cdot>d2\<cdot>x) = ssum_map\<cdot>d1\<cdot>d2\<cdot>x"
100.359 + apply (induct x, simp)
100.360 + apply (case_tac "d1\<cdot>x = \<bottom>", simp, simp add: d1.idem)
100.361 + apply (case_tac "d2\<cdot>y = \<bottom>", simp, simp add: d2.idem)
100.362 + done
100.363 + show "ssum_map\<cdot>d1\<cdot>d2\<cdot>x \<sqsubseteq> x"
100.364 + apply (induct x, simp)
100.365 + apply (case_tac "d1\<cdot>x = \<bottom>", simp, simp add: d1.below)
100.366 + apply (case_tac "d2\<cdot>y = \<bottom>", simp, simp add: d2.below)
100.367 + done
100.368 +qed
100.369 +
100.370 +lemma finite_deflation_ssum_map:
100.371 + assumes "finite_deflation d1" and "finite_deflation d2"
100.372 + shows "finite_deflation (ssum_map\<cdot>d1\<cdot>d2)"
100.373 +proof (rule finite_deflation_intro)
100.374 + interpret d1: finite_deflation d1 by fact
100.375 + interpret d2: finite_deflation d2 by fact
100.376 + have "deflation d1" and "deflation d2" by fact+
100.377 + thus "deflation (ssum_map\<cdot>d1\<cdot>d2)" by (rule deflation_ssum_map)
100.378 + have "{x. ssum_map\<cdot>d1\<cdot>d2\<cdot>x = x} \<subseteq>
100.379 + (\<lambda>x. sinl\<cdot>x) ` {x. d1\<cdot>x = x} \<union>
100.380 + (\<lambda>x. sinr\<cdot>x) ` {x. d2\<cdot>x = x} \<union> {\<bottom>}"
100.381 + by (rule subsetI, case_tac x, simp_all)
100.382 + thus "finite {x. ssum_map\<cdot>d1\<cdot>d2\<cdot>x = x}"
100.383 + by (rule finite_subset, simp add: d1.finite_fixes d2.finite_fixes)
100.384 +qed
100.385 +
100.386 +subsection {* Map operator for strict function space *}
100.387 +
100.388 +definition
100.389 + sfun_map :: "('b \<rightarrow> 'a) \<rightarrow> ('c \<rightarrow> 'd) \<rightarrow> ('a \<rightarrow>! 'c) \<rightarrow> ('b \<rightarrow>! 'd)"
100.390 +where
100.391 + "sfun_map = (\<Lambda> a b. sfun_abs oo cfun_map\<cdot>a\<cdot>b oo sfun_rep)"
100.392 +
100.393 +lemma sfun_map_ID: "sfun_map\<cdot>ID\<cdot>ID = ID"
100.394 + unfolding sfun_map_def
100.395 + by (simp add: cfun_map_ID cfun_eq_iff)
100.396 +
100.397 +lemma sfun_map_map:
100.398 + assumes "f2\<cdot>\<bottom> = \<bottom>" and "g2\<cdot>\<bottom> = \<bottom>" shows
100.399 + "sfun_map\<cdot>f1\<cdot>g1\<cdot>(sfun_map\<cdot>f2\<cdot>g2\<cdot>p) =
100.400 + sfun_map\<cdot>(\<Lambda> x. f2\<cdot>(f1\<cdot>x))\<cdot>(\<Lambda> x. g1\<cdot>(g2\<cdot>x))\<cdot>p"
100.401 +unfolding sfun_map_def
100.402 +by (simp add: cfun_eq_iff strictify_cancel assms cfun_map_map)
100.403 +
100.404 +lemma ep_pair_sfun_map:
100.405 + assumes 1: "ep_pair e1 p1"
100.406 + assumes 2: "ep_pair e2 p2"
100.407 + shows "ep_pair (sfun_map\<cdot>p1\<cdot>e2) (sfun_map\<cdot>e1\<cdot>p2)"
100.408 +proof
100.409 + interpret e1p1: pcpo_ep_pair e1 p1
100.410 + unfolding pcpo_ep_pair_def by fact
100.411 + interpret e2p2: pcpo_ep_pair e2 p2
100.412 + unfolding pcpo_ep_pair_def by fact
100.413 + fix f show "sfun_map\<cdot>e1\<cdot>p2\<cdot>(sfun_map\<cdot>p1\<cdot>e2\<cdot>f) = f"
100.414 + unfolding sfun_map_def
100.415 + apply (simp add: sfun_eq_iff strictify_cancel)
100.416 + apply (rule ep_pair.e_inverse)
100.417 + apply (rule ep_pair_cfun_map [OF 1 2])
100.418 + done
100.419 + fix g show "sfun_map\<cdot>p1\<cdot>e2\<cdot>(sfun_map\<cdot>e1\<cdot>p2\<cdot>g) \<sqsubseteq> g"
100.420 + unfolding sfun_map_def
100.421 + apply (simp add: sfun_below_iff strictify_cancel)
100.422 + apply (rule ep_pair.e_p_below)
100.423 + apply (rule ep_pair_cfun_map [OF 1 2])
100.424 + done
100.425 +qed
100.426 +
100.427 +lemma deflation_sfun_map:
100.428 + assumes 1: "deflation d1"
100.429 + assumes 2: "deflation d2"
100.430 + shows "deflation (sfun_map\<cdot>d1\<cdot>d2)"
100.431 +apply (simp add: sfun_map_def)
100.432 +apply (rule deflation.intro)
100.433 +apply simp
100.434 +apply (subst strictify_cancel)
100.435 +apply (simp add: cfun_map_def deflation_strict 1 2)
100.436 +apply (simp add: cfun_map_def deflation.idem 1 2)
100.437 +apply (simp add: sfun_below_iff)
100.438 +apply (subst strictify_cancel)
100.439 +apply (simp add: cfun_map_def deflation_strict 1 2)
100.440 +apply (rule deflation.below)
100.441 +apply (rule deflation_cfun_map [OF 1 2])
100.442 +done
100.443 +
100.444 +lemma finite_deflation_sfun_map:
100.445 + assumes 1: "finite_deflation d1"
100.446 + assumes 2: "finite_deflation d2"
100.447 + shows "finite_deflation (sfun_map\<cdot>d1\<cdot>d2)"
100.448 +proof (intro finite_deflation_intro)
100.449 + interpret d1: finite_deflation d1 by fact
100.450 + interpret d2: finite_deflation d2 by fact
100.451 + have "deflation d1" and "deflation d2" by fact+
100.452 + thus "deflation (sfun_map\<cdot>d1\<cdot>d2)" by (rule deflation_sfun_map)
100.453 + from 1 2 have "finite_deflation (cfun_map\<cdot>d1\<cdot>d2)"
100.454 + by (rule finite_deflation_cfun_map)
100.455 + then have "finite {f. cfun_map\<cdot>d1\<cdot>d2\<cdot>f = f}"
100.456 + by (rule finite_deflation.finite_fixes)
100.457 + moreover have "inj (\<lambda>f. sfun_rep\<cdot>f)"
100.458 + by (rule inj_onI, simp add: sfun_eq_iff)
100.459 + ultimately have "finite ((\<lambda>f. sfun_rep\<cdot>f) -` {f. cfun_map\<cdot>d1\<cdot>d2\<cdot>f = f})"
100.460 + by (rule finite_vimageI)
100.461 + then show "finite {f. sfun_map\<cdot>d1\<cdot>d2\<cdot>f = f}"
100.462 + unfolding sfun_map_def sfun_eq_iff
100.463 + by (simp add: strictify_cancel
100.464 + deflation_strict `deflation d1` `deflation d2`)
100.465 +qed
100.466 +
100.467 +end
101.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
101.2 +++ b/src/HOL/HOLCF/One.thy Sat Nov 27 16:08:10 2010 -0800
101.3 @@ -0,0 +1,72 @@
101.4 +(* Title: HOLCF/One.thy
101.5 + Author: Oscar Slotosch
101.6 +*)
101.7 +
101.8 +header {* The unit domain *}
101.9 +
101.10 +theory One
101.11 +imports Lift
101.12 +begin
101.13 +
101.14 +types one = "unit lift"
101.15 +translations
101.16 + (type) "one" <= (type) "unit lift"
101.17 +
101.18 +definition
101.19 + ONE :: "one"
101.20 +where
101.21 + "ONE == Def ()"
101.22 +
101.23 +text {* Exhaustion and Elimination for type @{typ one} *}
101.24 +
101.25 +lemma Exh_one: "t = \<bottom> \<or> t = ONE"
101.26 +unfolding ONE_def by (induct t) simp_all
101.27 +
101.28 +lemma oneE [case_names bottom ONE]: "\<lbrakk>p = \<bottom> \<Longrightarrow> Q; p = ONE \<Longrightarrow> Q\<rbrakk> \<Longrightarrow> Q"
101.29 +unfolding ONE_def by (induct p) simp_all
101.30 +
101.31 +lemma one_induct [case_names bottom ONE]: "\<lbrakk>P \<bottom>; P ONE\<rbrakk> \<Longrightarrow> P x"
101.32 +by (cases x rule: oneE) simp_all
101.33 +
101.34 +lemma dist_below_one [simp]: "\<not> ONE \<sqsubseteq> \<bottom>"
101.35 +unfolding ONE_def by simp
101.36 +
101.37 +lemma below_ONE [simp]: "x \<sqsubseteq> ONE"
101.38 +by (induct x rule: one_induct) simp_all
101.39 +
101.40 +lemma ONE_below_iff [simp]: "ONE \<sqsubseteq> x \<longleftrightarrow> x = ONE"
101.41 +by (induct x rule: one_induct) simp_all
101.42 +
101.43 +lemma ONE_defined [simp]: "ONE \<noteq> \<bottom>"
101.44 +unfolding ONE_def by simp
101.45 +
101.46 +lemma one_neq_iffs [simp]:
101.47 + "x \<noteq> ONE \<longleftrightarrow> x = \<bottom>"
101.48 + "ONE \<noteq> x \<longleftrightarrow> x = \<bottom>"
101.49 + "x \<noteq> \<bottom> \<longleftrightarrow> x = ONE"
101.50 + "\<bottom> \<noteq> x \<longleftrightarrow> x = ONE"
101.51 +by (induct x rule: one_induct) simp_all
101.52 +
101.53 +lemma compact_ONE: "compact ONE"
101.54 +by (rule compact_chfin)
101.55 +
101.56 +text {* Case analysis function for type @{typ one} *}
101.57 +
101.58 +definition
101.59 + one_case :: "'a::pcpo \<rightarrow> one \<rightarrow> 'a" where
101.60 + "one_case = (\<Lambda> a x. seq\<cdot>x\<cdot>a)"
101.61 +
101.62 +translations
101.63 + "case x of XCONST ONE \<Rightarrow> t" == "CONST one_case\<cdot>t\<cdot>x"
101.64 + "\<Lambda> (XCONST ONE). t" == "CONST one_case\<cdot>t"
101.65 +
101.66 +lemma one_case1 [simp]: "(case \<bottom> of ONE \<Rightarrow> t) = \<bottom>"
101.67 +by (simp add: one_case_def)
101.68 +
101.69 +lemma one_case2 [simp]: "(case ONE of ONE \<Rightarrow> t) = t"
101.70 +by (simp add: one_case_def)
101.71 +
101.72 +lemma one_case3 [simp]: "(case x of ONE \<Rightarrow> ONE) = x"
101.73 +by (induct x rule: one_induct) simp_all
101.74 +
101.75 +end
102.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
102.2 +++ b/src/HOL/HOLCF/Pcpo.thy Sat Nov 27 16:08:10 2010 -0800
102.3 @@ -0,0 +1,284 @@
102.4 +(* Title: HOLCF/Pcpo.thy
102.5 + Author: Franz Regensburger
102.6 +*)
102.7 +
102.8 +header {* Classes cpo and pcpo *}
102.9 +
102.10 +theory Pcpo
102.11 +imports Porder
102.12 +begin
102.13 +
102.14 +subsection {* Complete partial orders *}
102.15 +
102.16 +text {* The class cpo of chain complete partial orders *}
102.17 +
102.18 +class cpo = po +
102.19 + assumes cpo: "chain S \<Longrightarrow> \<exists>x. range S <<| x"
102.20 +begin
102.21 +
102.22 +text {* in cpo's everthing equal to THE lub has lub properties for every chain *}
102.23 +
102.24 +lemma cpo_lubI: "chain S \<Longrightarrow> range S <<| (\<Squnion>i. S i)"
102.25 + by (fast dest: cpo elim: is_lub_lub)
102.26 +
102.27 +lemma thelubE: "\<lbrakk>chain S; (\<Squnion>i. S i) = l\<rbrakk> \<Longrightarrow> range S <<| l"
102.28 + by (blast dest: cpo intro: is_lub_lub)
102.29 +
102.30 +text {* Properties of the lub *}
102.31 +
102.32 +lemma is_ub_thelub: "chain S \<Longrightarrow> S x \<sqsubseteq> (\<Squnion>i. S i)"
102.33 + by (blast dest: cpo intro: is_lub_lub [THEN is_lub_rangeD1])
102.34 +
102.35 +lemma is_lub_thelub:
102.36 + "\<lbrakk>chain S; range S <| x\<rbrakk> \<Longrightarrow> (\<Squnion>i. S i) \<sqsubseteq> x"
102.37 + by (blast dest: cpo intro: is_lub_lub [THEN is_lubD2])
102.38 +
102.39 +lemma lub_below_iff: "chain S \<Longrightarrow> (\<Squnion>i. S i) \<sqsubseteq> x \<longleftrightarrow> (\<forall>i. S i \<sqsubseteq> x)"
102.40 + by (simp add: is_lub_below_iff [OF cpo_lubI] is_ub_def)
102.41 +
102.42 +lemma lub_below: "\<lbrakk>chain S; \<And>i. S i \<sqsubseteq> x\<rbrakk> \<Longrightarrow> (\<Squnion>i. S i) \<sqsubseteq> x"
102.43 + by (simp add: lub_below_iff)
102.44 +
102.45 +lemma below_lub: "\<lbrakk>chain S; x \<sqsubseteq> S i\<rbrakk> \<Longrightarrow> x \<sqsubseteq> (\<Squnion>i. S i)"
102.46 + by (erule below_trans, erule is_ub_thelub)
102.47 +
102.48 +lemma lub_range_mono:
102.49 + "\<lbrakk>range X \<subseteq> range Y; chain Y; chain X\<rbrakk>
102.50 + \<Longrightarrow> (\<Squnion>i. X i) \<sqsubseteq> (\<Squnion>i. Y i)"
102.51 +apply (erule lub_below)
102.52 +apply (subgoal_tac "\<exists>j. X i = Y j")
102.53 +apply clarsimp
102.54 +apply (erule is_ub_thelub)
102.55 +apply auto
102.56 +done
102.57 +
102.58 +lemma lub_range_shift:
102.59 + "chain Y \<Longrightarrow> (\<Squnion>i. Y (i + j)) = (\<Squnion>i. Y i)"
102.60 +apply (rule below_antisym)
102.61 +apply (rule lub_range_mono)
102.62 +apply fast
102.63 +apply assumption
102.64 +apply (erule chain_shift)
102.65 +apply (rule lub_below)
102.66 +apply assumption
102.67 +apply (rule_tac i="i" in below_lub)
102.68 +apply (erule chain_shift)
102.69 +apply (erule chain_mono)
102.70 +apply (rule le_add1)
102.71 +done
102.72 +
102.73 +lemma maxinch_is_thelub:
102.74 + "chain Y \<Longrightarrow> max_in_chain i Y = ((\<Squnion>i. Y i) = Y i)"
102.75 +apply (rule iffI)
102.76 +apply (fast intro!: lub_eqI lub_finch1)
102.77 +apply (unfold max_in_chain_def)
102.78 +apply (safe intro!: below_antisym)
102.79 +apply (fast elim!: chain_mono)
102.80 +apply (drule sym)
102.81 +apply (force elim!: is_ub_thelub)
102.82 +done
102.83 +
102.84 +text {* the @{text "\<sqsubseteq>"} relation between two chains is preserved by their lubs *}
102.85 +
102.86 +lemma lub_mono:
102.87 + "\<lbrakk>chain X; chain Y; \<And>i. X i \<sqsubseteq> Y i\<rbrakk>
102.88 + \<Longrightarrow> (\<Squnion>i. X i) \<sqsubseteq> (\<Squnion>i. Y i)"
102.89 +by (fast elim: lub_below below_lub)
102.90 +
102.91 +text {* the = relation between two chains is preserved by their lubs *}
102.92 +
102.93 +lemma lub_eq:
102.94 + "(\<And>i. X i = Y i) \<Longrightarrow> (\<Squnion>i. X i) = (\<Squnion>i. Y i)"
102.95 + by simp
102.96 +
102.97 +lemma ch2ch_lub:
102.98 + assumes 1: "\<And>j. chain (\<lambda>i. Y i j)"
102.99 + assumes 2: "\<And>i. chain (\<lambda>j. Y i j)"
102.100 + shows "chain (\<lambda>i. \<Squnion>j. Y i j)"
102.101 +apply (rule chainI)
102.102 +apply (rule lub_mono [OF 2 2])
102.103 +apply (rule chainE [OF 1])
102.104 +done
102.105 +
102.106 +lemma diag_lub:
102.107 + assumes 1: "\<And>j. chain (\<lambda>i. Y i j)"
102.108 + assumes 2: "\<And>i. chain (\<lambda>j. Y i j)"
102.109 + shows "(\<Squnion>i. \<Squnion>j. Y i j) = (\<Squnion>i. Y i i)"
102.110 +proof (rule below_antisym)
102.111 + have 3: "chain (\<lambda>i. Y i i)"
102.112 + apply (rule chainI)
102.113 + apply (rule below_trans)
102.114 + apply (rule chainE [OF 1])
102.115 + apply (rule chainE [OF 2])
102.116 + done
102.117 + have 4: "chain (\<lambda>i. \<Squnion>j. Y i j)"
102.118 + by (rule ch2ch_lub [OF 1 2])
102.119 + show "(\<Squnion>i. \<Squnion>j. Y i j) \<sqsubseteq> (\<Squnion>i. Y i i)"
102.120 + apply (rule lub_below [OF 4])
102.121 + apply (rule lub_below [OF 2])
102.122 + apply (rule below_lub [OF 3])
102.123 + apply (rule below_trans)
102.124 + apply (rule chain_mono [OF 1 le_maxI1])
102.125 + apply (rule chain_mono [OF 2 le_maxI2])
102.126 + done
102.127 + show "(\<Squnion>i. Y i i) \<sqsubseteq> (\<Squnion>i. \<Squnion>j. Y i j)"
102.128 + apply (rule lub_mono [OF 3 4])
102.129 + apply (rule is_ub_thelub [OF 2])
102.130 + done
102.131 +qed
102.132 +
102.133 +lemma ex_lub:
102.134 + assumes 1: "\<And>j. chain (\<lambda>i. Y i j)"
102.135 + assumes 2: "\<And>i. chain (\<lambda>j. Y i j)"
102.136 + shows "(\<Squnion>i. \<Squnion>j. Y i j) = (\<Squnion>j. \<Squnion>i. Y i j)"
102.137 + by (simp add: diag_lub 1 2)
102.138 +
102.139 +end
102.140 +
102.141 +subsection {* Pointed cpos *}
102.142 +
102.143 +text {* The class pcpo of pointed cpos *}
102.144 +
102.145 +class pcpo = cpo +
102.146 + assumes least: "\<exists>x. \<forall>y. x \<sqsubseteq> y"
102.147 +begin
102.148 +
102.149 +definition UU :: 'a where
102.150 + "UU = (THE x. \<forall>y. x \<sqsubseteq> y)"
102.151 +
102.152 +notation (xsymbols)
102.153 + UU ("\<bottom>")
102.154 +
102.155 +text {* derive the old rule minimal *}
102.156 +
102.157 +lemma UU_least: "\<forall>z. \<bottom> \<sqsubseteq> z"
102.158 +apply (unfold UU_def)
102.159 +apply (rule theI')
102.160 +apply (rule ex_ex1I)
102.161 +apply (rule least)
102.162 +apply (blast intro: below_antisym)
102.163 +done
102.164 +
102.165 +lemma minimal [iff]: "\<bottom> \<sqsubseteq> x"
102.166 +by (rule UU_least [THEN spec])
102.167 +
102.168 +end
102.169 +
102.170 +text {* Simproc to rewrite @{term "\<bottom> = x"} to @{term "x = \<bottom>"}. *}
102.171 +
102.172 +setup {*
102.173 + Reorient_Proc.add
102.174 + (fn Const(@{const_name UU}, _) => true | _ => false)
102.175 +*}
102.176 +
102.177 +simproc_setup reorient_bottom ("\<bottom> = x") = Reorient_Proc.proc
102.178 +
102.179 +context pcpo
102.180 +begin
102.181 +
102.182 +text {* useful lemmas about @{term \<bottom>} *}
102.183 +
102.184 +lemma below_UU_iff [simp]: "(x \<sqsubseteq> \<bottom>) = (x = \<bottom>)"
102.185 +by (simp add: po_eq_conv)
102.186 +
102.187 +lemma eq_UU_iff: "(x = \<bottom>) = (x \<sqsubseteq> \<bottom>)"
102.188 +by simp
102.189 +
102.190 +lemma UU_I: "x \<sqsubseteq> \<bottom> \<Longrightarrow> x = \<bottom>"
102.191 +by (subst eq_UU_iff)
102.192 +
102.193 +lemma lub_eq_bottom_iff: "chain Y \<Longrightarrow> (\<Squnion>i. Y i) = \<bottom> \<longleftrightarrow> (\<forall>i. Y i = \<bottom>)"
102.194 +by (simp only: eq_UU_iff lub_below_iff)
102.195 +
102.196 +lemma chain_UU_I: "\<lbrakk>chain Y; (\<Squnion>i. Y i) = \<bottom>\<rbrakk> \<Longrightarrow> \<forall>i. Y i = \<bottom>"
102.197 +by (simp add: lub_eq_bottom_iff)
102.198 +
102.199 +lemma chain_UU_I_inverse: "\<forall>i::nat. Y i = \<bottom> \<Longrightarrow> (\<Squnion>i. Y i) = \<bottom>"
102.200 +by simp
102.201 +
102.202 +lemma chain_UU_I_inverse2: "(\<Squnion>i. Y i) \<noteq> \<bottom> \<Longrightarrow> \<exists>i::nat. Y i \<noteq> \<bottom>"
102.203 + by (blast intro: chain_UU_I_inverse)
102.204 +
102.205 +lemma notUU_I: "\<lbrakk>x \<sqsubseteq> y; x \<noteq> \<bottom>\<rbrakk> \<Longrightarrow> y \<noteq> \<bottom>"
102.206 + by (blast intro: UU_I)
102.207 +
102.208 +end
102.209 +
102.210 +subsection {* Chain-finite and flat cpos *}
102.211 +
102.212 +text {* further useful classes for HOLCF domains *}
102.213 +
102.214 +class chfin = po +
102.215 + assumes chfin: "chain Y \<Longrightarrow> \<exists>n. max_in_chain n Y"
102.216 +begin
102.217 +
102.218 +subclass cpo
102.219 +apply default
102.220 +apply (frule chfin)
102.221 +apply (blast intro: lub_finch1)
102.222 +done
102.223 +
102.224 +lemma chfin2finch: "chain Y \<Longrightarrow> finite_chain Y"
102.225 + by (simp add: chfin finite_chain_def)
102.226 +
102.227 +end
102.228 +
102.229 +class flat = pcpo +
102.230 + assumes ax_flat: "x \<sqsubseteq> y \<Longrightarrow> x = \<bottom> \<or> x = y"
102.231 +begin
102.232 +
102.233 +subclass chfin
102.234 +apply default
102.235 +apply (unfold max_in_chain_def)
102.236 +apply (case_tac "\<forall>i. Y i = \<bottom>")
102.237 +apply simp
102.238 +apply simp
102.239 +apply (erule exE)
102.240 +apply (rule_tac x="i" in exI)
102.241 +apply clarify
102.242 +apply (blast dest: chain_mono ax_flat)
102.243 +done
102.244 +
102.245 +lemma flat_below_iff:
102.246 + shows "(x \<sqsubseteq> y) = (x = \<bottom> \<or> x = y)"
102.247 + by (safe dest!: ax_flat)
102.248 +
102.249 +lemma flat_eq: "a \<noteq> \<bottom> \<Longrightarrow> a \<sqsubseteq> b = (a = b)"
102.250 + by (safe dest!: ax_flat)
102.251 +
102.252 +end
102.253 +
102.254 +subsection {* Discrete cpos *}
102.255 +
102.256 +class discrete_cpo = below +
102.257 + assumes discrete_cpo [simp]: "x \<sqsubseteq> y \<longleftrightarrow> x = y"
102.258 +begin
102.259 +
102.260 +subclass po
102.261 +proof qed simp_all
102.262 +
102.263 +text {* In a discrete cpo, every chain is constant *}
102.264 +
102.265 +lemma discrete_chain_const:
102.266 + assumes S: "chain S"
102.267 + shows "\<exists>x. S = (\<lambda>i. x)"
102.268 +proof (intro exI ext)
102.269 + fix i :: nat
102.270 + have "S 0 \<sqsubseteq> S i" using S le0 by (rule chain_mono)
102.271 + hence "S 0 = S i" by simp
102.272 + thus "S i = S 0" by (rule sym)
102.273 +qed
102.274 +
102.275 +subclass chfin
102.276 +proof
102.277 + fix S :: "nat \<Rightarrow> 'a"
102.278 + assume S: "chain S"
102.279 + hence "\<exists>x. S = (\<lambda>i. x)" by (rule discrete_chain_const)
102.280 + hence "max_in_chain 0 S"
102.281 + unfolding max_in_chain_def by auto
102.282 + thus "\<exists>i. max_in_chain i S" ..
102.283 +qed
102.284 +
102.285 +end
102.286 +
102.287 +end
103.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
103.2 +++ b/src/HOL/HOLCF/Plain_HOLCF.thy Sat Nov 27 16:08:10 2010 -0800
103.3 @@ -0,0 +1,15 @@
103.4 +(* Title: HOLCF/Plain_HOLCF.thy
103.5 + Author: Brian Huffman
103.6 +*)
103.7 +
103.8 +header {* Plain HOLCF *}
103.9 +
103.10 +theory Plain_HOLCF
103.11 +imports Cfun Sfun Cprod Sprod Ssum Up Discrete Lift One Tr Fix
103.12 +begin
103.13 +
103.14 +text {*
103.15 + Basic HOLCF concepts and types; does not include definition packages.
103.16 +*}
103.17 +
103.18 +end
104.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
104.2 +++ b/src/HOL/HOLCF/Porder.thy Sat Nov 27 16:08:10 2010 -0800
104.3 @@ -0,0 +1,336 @@
104.4 +(* Title: HOLCF/Porder.thy
104.5 + Author: Franz Regensburger and Brian Huffman
104.6 +*)
104.7 +
104.8 +header {* Partial orders *}
104.9 +
104.10 +theory Porder
104.11 +imports Main
104.12 +begin
104.13 +
104.14 +subsection {* Type class for partial orders *}
104.15 +
104.16 +class below =
104.17 + fixes below :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
104.18 +begin
104.19 +
104.20 +notation
104.21 + below (infix "<<" 50)
104.22 +
104.23 +notation (xsymbols)
104.24 + below (infix "\<sqsubseteq>" 50)
104.25 +
104.26 +lemma below_eq_trans: "\<lbrakk>a \<sqsubseteq> b; b = c\<rbrakk> \<Longrightarrow> a \<sqsubseteq> c"
104.27 + by (rule subst)
104.28 +
104.29 +lemma eq_below_trans: "\<lbrakk>a = b; b \<sqsubseteq> c\<rbrakk> \<Longrightarrow> a \<sqsubseteq> c"
104.30 + by (rule ssubst)
104.31 +
104.32 +end
104.33 +
104.34 +class po = below +
104.35 + assumes below_refl [iff]: "x \<sqsubseteq> x"
104.36 + assumes below_trans: "x \<sqsubseteq> y \<Longrightarrow> y \<sqsubseteq> z \<Longrightarrow> x \<sqsubseteq> z"
104.37 + assumes below_antisym: "x \<sqsubseteq> y \<Longrightarrow> y \<sqsubseteq> x \<Longrightarrow> x = y"
104.38 +begin
104.39 +
104.40 +lemma eq_imp_below: "x = y \<Longrightarrow> x \<sqsubseteq> y"
104.41 + by simp
104.42 +
104.43 +lemma box_below: "a \<sqsubseteq> b \<Longrightarrow> c \<sqsubseteq> a \<Longrightarrow> b \<sqsubseteq> d \<Longrightarrow> c \<sqsubseteq> d"
104.44 + by (rule below_trans [OF below_trans])
104.45 +
104.46 +lemma po_eq_conv: "x = y \<longleftrightarrow> x \<sqsubseteq> y \<and> y \<sqsubseteq> x"
104.47 + by (fast intro!: below_antisym)
104.48 +
104.49 +lemma rev_below_trans: "y \<sqsubseteq> z \<Longrightarrow> x \<sqsubseteq> y \<Longrightarrow> x \<sqsubseteq> z"
104.50 + by (rule below_trans)
104.51 +
104.52 +lemma not_below2not_eq: "\<not> x \<sqsubseteq> y \<Longrightarrow> x \<noteq> y"
104.53 + by auto
104.54 +
104.55 +end
104.56 +
104.57 +lemmas HOLCF_trans_rules [trans] =
104.58 + below_trans
104.59 + below_antisym
104.60 + below_eq_trans
104.61 + eq_below_trans
104.62 +
104.63 +context po
104.64 +begin
104.65 +
104.66 +subsection {* Upper bounds *}
104.67 +
104.68 +definition is_ub :: "'a set \<Rightarrow> 'a \<Rightarrow> bool" (infix "<|" 55) where
104.69 + "S <| x \<longleftrightarrow> (\<forall>y\<in>S. y \<sqsubseteq> x)"
104.70 +
104.71 +lemma is_ubI: "(\<And>x. x \<in> S \<Longrightarrow> x \<sqsubseteq> u) \<Longrightarrow> S <| u"
104.72 + by (simp add: is_ub_def)
104.73 +
104.74 +lemma is_ubD: "\<lbrakk>S <| u; x \<in> S\<rbrakk> \<Longrightarrow> x \<sqsubseteq> u"
104.75 + by (simp add: is_ub_def)
104.76 +
104.77 +lemma ub_imageI: "(\<And>x. x \<in> S \<Longrightarrow> f x \<sqsubseteq> u) \<Longrightarrow> (\<lambda>x. f x) ` S <| u"
104.78 + unfolding is_ub_def by fast
104.79 +
104.80 +lemma ub_imageD: "\<lbrakk>f ` S <| u; x \<in> S\<rbrakk> \<Longrightarrow> f x \<sqsubseteq> u"
104.81 + unfolding is_ub_def by fast
104.82 +
104.83 +lemma ub_rangeI: "(\<And>i. S i \<sqsubseteq> x) \<Longrightarrow> range S <| x"
104.84 + unfolding is_ub_def by fast
104.85 +
104.86 +lemma ub_rangeD: "range S <| x \<Longrightarrow> S i \<sqsubseteq> x"
104.87 + unfolding is_ub_def by fast
104.88 +
104.89 +lemma is_ub_empty [simp]: "{} <| u"
104.90 + unfolding is_ub_def by fast
104.91 +
104.92 +lemma is_ub_insert [simp]: "(insert x A) <| y = (x \<sqsubseteq> y \<and> A <| y)"
104.93 + unfolding is_ub_def by fast
104.94 +
104.95 +lemma is_ub_upward: "\<lbrakk>S <| x; x \<sqsubseteq> y\<rbrakk> \<Longrightarrow> S <| y"
104.96 + unfolding is_ub_def by (fast intro: below_trans)
104.97 +
104.98 +subsection {* Least upper bounds *}
104.99 +
104.100 +definition is_lub :: "'a set \<Rightarrow> 'a \<Rightarrow> bool" (infix "<<|" 55) where
104.101 + "S <<| x \<longleftrightarrow> S <| x \<and> (\<forall>u. S <| u \<longrightarrow> x \<sqsubseteq> u)"
104.102 +
104.103 +definition lub :: "'a set \<Rightarrow> 'a" where
104.104 + "lub S = (THE x. S <<| x)"
104.105 +
104.106 +end
104.107 +
104.108 +syntax
104.109 + "_BLub" :: "[pttrn, 'a set, 'b] \<Rightarrow> 'b" ("(3LUB _:_./ _)" [0,0, 10] 10)
104.110 +
104.111 +syntax (xsymbols)
104.112 + "_BLub" :: "[pttrn, 'a set, 'b] \<Rightarrow> 'b" ("(3\<Squnion>_\<in>_./ _)" [0,0, 10] 10)
104.113 +
104.114 +translations
104.115 + "LUB x:A. t" == "CONST lub ((%x. t) ` A)"
104.116 +
104.117 +context po
104.118 +begin
104.119 +
104.120 +abbreviation
104.121 + Lub (binder "LUB " 10) where
104.122 + "LUB n. t n == lub (range t)"
104.123 +
104.124 +notation (xsymbols)
104.125 + Lub (binder "\<Squnion> " 10)
104.126 +
104.127 +text {* access to some definition as inference rule *}
104.128 +
104.129 +lemma is_lubD1: "S <<| x \<Longrightarrow> S <| x"
104.130 + unfolding is_lub_def by fast
104.131 +
104.132 +lemma is_lubD2: "\<lbrakk>S <<| x; S <| u\<rbrakk> \<Longrightarrow> x \<sqsubseteq> u"
104.133 + unfolding is_lub_def by fast
104.134 +
104.135 +lemma is_lubI: "\<lbrakk>S <| x; \<And>u. S <| u \<Longrightarrow> x \<sqsubseteq> u\<rbrakk> \<Longrightarrow> S <<| x"
104.136 + unfolding is_lub_def by fast
104.137 +
104.138 +lemma is_lub_below_iff: "S <<| x \<Longrightarrow> x \<sqsubseteq> u \<longleftrightarrow> S <| u"
104.139 + unfolding is_lub_def is_ub_def by (metis below_trans)
104.140 +
104.141 +text {* lubs are unique *}
104.142 +
104.143 +lemma is_lub_unique: "\<lbrakk>S <<| x; S <<| y\<rbrakk> \<Longrightarrow> x = y"
104.144 + unfolding is_lub_def is_ub_def by (blast intro: below_antisym)
104.145 +
104.146 +text {* technical lemmas about @{term lub} and @{term is_lub} *}
104.147 +
104.148 +lemma is_lub_lub: "M <<| x \<Longrightarrow> M <<| lub M"
104.149 + unfolding lub_def by (rule theI [OF _ is_lub_unique])
104.150 +
104.151 +lemma lub_eqI: "M <<| l \<Longrightarrow> lub M = l"
104.152 + by (rule is_lub_unique [OF is_lub_lub])
104.153 +
104.154 +lemma is_lub_singleton: "{x} <<| x"
104.155 + by (simp add: is_lub_def)
104.156 +
104.157 +lemma lub_singleton [simp]: "lub {x} = x"
104.158 + by (rule is_lub_singleton [THEN lub_eqI])
104.159 +
104.160 +lemma is_lub_bin: "x \<sqsubseteq> y \<Longrightarrow> {x, y} <<| y"
104.161 + by (simp add: is_lub_def)
104.162 +
104.163 +lemma lub_bin: "x \<sqsubseteq> y \<Longrightarrow> lub {x, y} = y"
104.164 + by (rule is_lub_bin [THEN lub_eqI])
104.165 +
104.166 +lemma is_lub_maximal: "\<lbrakk>S <| x; x \<in> S\<rbrakk> \<Longrightarrow> S <<| x"
104.167 + by (erule is_lubI, erule (1) is_ubD)
104.168 +
104.169 +lemma lub_maximal: "\<lbrakk>S <| x; x \<in> S\<rbrakk> \<Longrightarrow> lub S = x"
104.170 + by (rule is_lub_maximal [THEN lub_eqI])
104.171 +
104.172 +subsection {* Countable chains *}
104.173 +
104.174 +definition chain :: "(nat \<Rightarrow> 'a) \<Rightarrow> bool" where
104.175 + -- {* Here we use countable chains and I prefer to code them as functions! *}
104.176 + "chain Y = (\<forall>i. Y i \<sqsubseteq> Y (Suc i))"
104.177 +
104.178 +lemma chainI: "(\<And>i. Y i \<sqsubseteq> Y (Suc i)) \<Longrightarrow> chain Y"
104.179 + unfolding chain_def by fast
104.180 +
104.181 +lemma chainE: "chain Y \<Longrightarrow> Y i \<sqsubseteq> Y (Suc i)"
104.182 + unfolding chain_def by fast
104.183 +
104.184 +text {* chains are monotone functions *}
104.185 +
104.186 +lemma chain_mono_less: "\<lbrakk>chain Y; i < j\<rbrakk> \<Longrightarrow> Y i \<sqsubseteq> Y j"
104.187 + by (erule less_Suc_induct, erule chainE, erule below_trans)
104.188 +
104.189 +lemma chain_mono: "\<lbrakk>chain Y; i \<le> j\<rbrakk> \<Longrightarrow> Y i \<sqsubseteq> Y j"
104.190 + by (cases "i = j", simp, simp add: chain_mono_less)
104.191 +
104.192 +lemma chain_shift: "chain Y \<Longrightarrow> chain (\<lambda>i. Y (i + j))"
104.193 + by (rule chainI, simp, erule chainE)
104.194 +
104.195 +text {* technical lemmas about (least) upper bounds of chains *}
104.196 +
104.197 +lemma is_lub_rangeD1: "range S <<| x \<Longrightarrow> S i \<sqsubseteq> x"
104.198 + by (rule is_lubD1 [THEN ub_rangeD])
104.199 +
104.200 +lemma is_ub_range_shift:
104.201 + "chain S \<Longrightarrow> range (\<lambda>i. S (i + j)) <| x = range S <| x"
104.202 +apply (rule iffI)
104.203 +apply (rule ub_rangeI)
104.204 +apply (rule_tac y="S (i + j)" in below_trans)
104.205 +apply (erule chain_mono)
104.206 +apply (rule le_add1)
104.207 +apply (erule ub_rangeD)
104.208 +apply (rule ub_rangeI)
104.209 +apply (erule ub_rangeD)
104.210 +done
104.211 +
104.212 +lemma is_lub_range_shift:
104.213 + "chain S \<Longrightarrow> range (\<lambda>i. S (i + j)) <<| x = range S <<| x"
104.214 + by (simp add: is_lub_def is_ub_range_shift)
104.215 +
104.216 +text {* the lub of a constant chain is the constant *}
104.217 +
104.218 +lemma chain_const [simp]: "chain (\<lambda>i. c)"
104.219 + by (simp add: chainI)
104.220 +
104.221 +lemma is_lub_const: "range (\<lambda>x. c) <<| c"
104.222 +by (blast dest: ub_rangeD intro: is_lubI ub_rangeI)
104.223 +
104.224 +lemma lub_const [simp]: "(\<Squnion>i. c) = c"
104.225 + by (rule is_lub_const [THEN lub_eqI])
104.226 +
104.227 +subsection {* Finite chains *}
104.228 +
104.229 +definition max_in_chain :: "nat \<Rightarrow> (nat \<Rightarrow> 'a) \<Rightarrow> bool" where
104.230 + -- {* finite chains, needed for monotony of continuous functions *}
104.231 + "max_in_chain i C \<longleftrightarrow> (\<forall>j. i \<le> j \<longrightarrow> C i = C j)"
104.232 +
104.233 +definition finite_chain :: "(nat \<Rightarrow> 'a) \<Rightarrow> bool" where
104.234 + "finite_chain C = (chain C \<and> (\<exists>i. max_in_chain i C))"
104.235 +
104.236 +text {* results about finite chains *}
104.237 +
104.238 +lemma max_in_chainI: "(\<And>j. i \<le> j \<Longrightarrow> Y i = Y j) \<Longrightarrow> max_in_chain i Y"
104.239 + unfolding max_in_chain_def by fast
104.240 +
104.241 +lemma max_in_chainD: "\<lbrakk>max_in_chain i Y; i \<le> j\<rbrakk> \<Longrightarrow> Y i = Y j"
104.242 + unfolding max_in_chain_def by fast
104.243 +
104.244 +lemma finite_chainI:
104.245 + "\<lbrakk>chain C; max_in_chain i C\<rbrakk> \<Longrightarrow> finite_chain C"
104.246 + unfolding finite_chain_def by fast
104.247 +
104.248 +lemma finite_chainE:
104.249 + "\<lbrakk>finite_chain C; \<And>i. \<lbrakk>chain C; max_in_chain i C\<rbrakk> \<Longrightarrow> R\<rbrakk> \<Longrightarrow> R"
104.250 + unfolding finite_chain_def by fast
104.251 +
104.252 +lemma lub_finch1: "\<lbrakk>chain C; max_in_chain i C\<rbrakk> \<Longrightarrow> range C <<| C i"
104.253 +apply (rule is_lubI)
104.254 +apply (rule ub_rangeI, rename_tac j)
104.255 +apply (rule_tac x=i and y=j in linorder_le_cases)
104.256 +apply (drule (1) max_in_chainD, simp)
104.257 +apply (erule (1) chain_mono)
104.258 +apply (erule ub_rangeD)
104.259 +done
104.260 +
104.261 +lemma lub_finch2:
104.262 + "finite_chain C \<Longrightarrow> range C <<| C (LEAST i. max_in_chain i C)"
104.263 +apply (erule finite_chainE)
104.264 +apply (erule LeastI2 [where Q="\<lambda>i. range C <<| C i"])
104.265 +apply (erule (1) lub_finch1)
104.266 +done
104.267 +
104.268 +lemma finch_imp_finite_range: "finite_chain Y \<Longrightarrow> finite (range Y)"
104.269 + apply (erule finite_chainE)
104.270 + apply (rule_tac B="Y ` {..i}" in finite_subset)
104.271 + apply (rule subsetI)
104.272 + apply (erule rangeE, rename_tac j)
104.273 + apply (rule_tac x=i and y=j in linorder_le_cases)
104.274 + apply (subgoal_tac "Y j = Y i", simp)
104.275 + apply (simp add: max_in_chain_def)
104.276 + apply simp
104.277 + apply simp
104.278 +done
104.279 +
104.280 +lemma finite_range_has_max:
104.281 + fixes f :: "nat \<Rightarrow> 'a" and r :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
104.282 + assumes mono: "\<And>i j. i \<le> j \<Longrightarrow> r (f i) (f j)"
104.283 + assumes finite_range: "finite (range f)"
104.284 + shows "\<exists>k. \<forall>i. r (f i) (f k)"
104.285 +proof (intro exI allI)
104.286 + fix i :: nat
104.287 + let ?j = "LEAST k. f k = f i"
104.288 + let ?k = "Max ((\<lambda>x. LEAST k. f k = x) ` range f)"
104.289 + have "?j \<le> ?k"
104.290 + proof (rule Max_ge)
104.291 + show "finite ((\<lambda>x. LEAST k. f k = x) ` range f)"
104.292 + using finite_range by (rule finite_imageI)
104.293 + show "?j \<in> (\<lambda>x. LEAST k. f k = x) ` range f"
104.294 + by (intro imageI rangeI)
104.295 + qed
104.296 + hence "r (f ?j) (f ?k)"
104.297 + by (rule mono)
104.298 + also have "f ?j = f i"
104.299 + by (rule LeastI, rule refl)
104.300 + finally show "r (f i) (f ?k)" .
104.301 +qed
104.302 +
104.303 +lemma finite_range_imp_finch:
104.304 + "\<lbrakk>chain Y; finite (range Y)\<rbrakk> \<Longrightarrow> finite_chain Y"
104.305 + apply (subgoal_tac "\<exists>k. \<forall>i. Y i \<sqsubseteq> Y k")
104.306 + apply (erule exE)
104.307 + apply (rule finite_chainI, assumption)
104.308 + apply (rule max_in_chainI)
104.309 + apply (rule below_antisym)
104.310 + apply (erule (1) chain_mono)
104.311 + apply (erule spec)
104.312 + apply (rule finite_range_has_max)
104.313 + apply (erule (1) chain_mono)
104.314 + apply assumption
104.315 +done
104.316 +
104.317 +lemma bin_chain: "x \<sqsubseteq> y \<Longrightarrow> chain (\<lambda>i. if i=0 then x else y)"
104.318 + by (rule chainI, simp)
104.319 +
104.320 +lemma bin_chainmax:
104.321 + "x \<sqsubseteq> y \<Longrightarrow> max_in_chain (Suc 0) (\<lambda>i. if i=0 then x else y)"
104.322 + unfolding max_in_chain_def by simp
104.323 +
104.324 +lemma is_lub_bin_chain:
104.325 + "x \<sqsubseteq> y \<Longrightarrow> range (\<lambda>i::nat. if i=0 then x else y) <<| y"
104.326 +apply (frule bin_chain)
104.327 +apply (drule bin_chainmax)
104.328 +apply (drule (1) lub_finch1)
104.329 +apply simp
104.330 +done
104.331 +
104.332 +text {* the maximal element in a chain is its lub *}
104.333 +
104.334 +lemma lub_chain_maxelem: "\<lbrakk>Y i = c; \<forall>i. Y i \<sqsubseteq> c\<rbrakk> \<Longrightarrow> lub (range Y) = c"
104.335 + by (blast dest: ub_rangeD intro: lub_eqI is_lubI ub_rangeI)
104.336 +
104.337 +end
104.338 +
104.339 +end
105.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
105.2 +++ b/src/HOL/HOLCF/Powerdomains.thy Sat Nov 27 16:08:10 2010 -0800
105.3 @@ -0,0 +1,51 @@
105.4 +(* Title: HOLCF/Powerdomains.thy
105.5 + Author: Brian Huffman
105.6 +*)
105.7 +
105.8 +header {* Powerdomains *}
105.9 +
105.10 +theory Powerdomains
105.11 +imports ConvexPD Domain
105.12 +begin
105.13 +
105.14 +lemma isodefl_upper:
105.15 + "isodefl d t \<Longrightarrow> isodefl (upper_map\<cdot>d) (upper_defl\<cdot>t)"
105.16 +apply (rule isodeflI)
105.17 +apply (simp add: cast_upper_defl cast_isodefl)
105.18 +apply (simp add: emb_upper_pd_def prj_upper_pd_def)
105.19 +apply (simp add: upper_map_map)
105.20 +done
105.21 +
105.22 +lemma isodefl_lower:
105.23 + "isodefl d t \<Longrightarrow> isodefl (lower_map\<cdot>d) (lower_defl\<cdot>t)"
105.24 +apply (rule isodeflI)
105.25 +apply (simp add: cast_lower_defl cast_isodefl)
105.26 +apply (simp add: emb_lower_pd_def prj_lower_pd_def)
105.27 +apply (simp add: lower_map_map)
105.28 +done
105.29 +
105.30 +lemma isodefl_convex:
105.31 + "isodefl d t \<Longrightarrow> isodefl (convex_map\<cdot>d) (convex_defl\<cdot>t)"
105.32 +apply (rule isodeflI)
105.33 +apply (simp add: cast_convex_defl cast_isodefl)
105.34 +apply (simp add: emb_convex_pd_def prj_convex_pd_def)
105.35 +apply (simp add: convex_map_map)
105.36 +done
105.37 +
105.38 +subsection {* Domain package setup for powerdomains *}
105.39 +
105.40 +lemmas [domain_defl_simps] = DEFL_upper DEFL_lower DEFL_convex
105.41 +lemmas [domain_map_ID] = upper_map_ID lower_map_ID convex_map_ID
105.42 +lemmas [domain_isodefl] = isodefl_upper isodefl_lower isodefl_convex
105.43 +
105.44 +lemmas [domain_deflation] =
105.45 + deflation_upper_map deflation_lower_map deflation_convex_map
105.46 +
105.47 +setup {*
105.48 + fold Domain_Take_Proofs.add_rec_type
105.49 + [(@{type_name "upper_pd"}, [true]),
105.50 + (@{type_name "lower_pd"}, [true]),
105.51 + (@{type_name "convex_pd"}, [true])]
105.52 +*}
105.53 +
105.54 +end
106.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
106.2 +++ b/src/HOL/HOLCF/Product_Cpo.thy Sat Nov 27 16:08:10 2010 -0800
106.3 @@ -0,0 +1,299 @@
106.4 +(* Title: HOLCF/Product_Cpo.thy
106.5 + Author: Franz Regensburger
106.6 +*)
106.7 +
106.8 +header {* The cpo of cartesian products *}
106.9 +
106.10 +theory Product_Cpo
106.11 +imports Adm
106.12 +begin
106.13 +
106.14 +default_sort cpo
106.15 +
106.16 +subsection {* Unit type is a pcpo *}
106.17 +
106.18 +instantiation unit :: discrete_cpo
106.19 +begin
106.20 +
106.21 +definition
106.22 + below_unit_def [simp]: "x \<sqsubseteq> (y::unit) \<longleftrightarrow> True"
106.23 +
106.24 +instance proof
106.25 +qed simp
106.26 +
106.27 +end
106.28 +
106.29 +instance unit :: pcpo
106.30 +by intro_classes simp
106.31 +
106.32 +
106.33 +subsection {* Product type is a partial order *}
106.34 +
106.35 +instantiation prod :: (below, below) below
106.36 +begin
106.37 +
106.38 +definition
106.39 + below_prod_def: "(op \<sqsubseteq>) \<equiv> \<lambda>p1 p2. (fst p1 \<sqsubseteq> fst p2 \<and> snd p1 \<sqsubseteq> snd p2)"
106.40 +
106.41 +instance ..
106.42 +end
106.43 +
106.44 +instance prod :: (po, po) po
106.45 +proof
106.46 + fix x :: "'a \<times> 'b"
106.47 + show "x \<sqsubseteq> x"
106.48 + unfolding below_prod_def by simp
106.49 +next
106.50 + fix x y :: "'a \<times> 'b"
106.51 + assume "x \<sqsubseteq> y" "y \<sqsubseteq> x" thus "x = y"
106.52 + unfolding below_prod_def Pair_fst_snd_eq
106.53 + by (fast intro: below_antisym)
106.54 +next
106.55 + fix x y z :: "'a \<times> 'b"
106.56 + assume "x \<sqsubseteq> y" "y \<sqsubseteq> z" thus "x \<sqsubseteq> z"
106.57 + unfolding below_prod_def
106.58 + by (fast intro: below_trans)
106.59 +qed
106.60 +
106.61 +subsection {* Monotonicity of \emph{Pair}, \emph{fst}, \emph{snd} *}
106.62 +
106.63 +lemma prod_belowI: "\<lbrakk>fst p \<sqsubseteq> fst q; snd p \<sqsubseteq> snd q\<rbrakk> \<Longrightarrow> p \<sqsubseteq> q"
106.64 +unfolding below_prod_def by simp
106.65 +
106.66 +lemma Pair_below_iff [simp]: "(a, b) \<sqsubseteq> (c, d) \<longleftrightarrow> a \<sqsubseteq> c \<and> b \<sqsubseteq> d"
106.67 +unfolding below_prod_def by simp
106.68 +
106.69 +text {* Pair @{text "(_,_)"} is monotone in both arguments *}
106.70 +
106.71 +lemma monofun_pair1: "monofun (\<lambda>x. (x, y))"
106.72 +by (simp add: monofun_def)
106.73 +
106.74 +lemma monofun_pair2: "monofun (\<lambda>y. (x, y))"
106.75 +by (simp add: monofun_def)
106.76 +
106.77 +lemma monofun_pair:
106.78 + "\<lbrakk>x1 \<sqsubseteq> x2; y1 \<sqsubseteq> y2\<rbrakk> \<Longrightarrow> (x1, y1) \<sqsubseteq> (x2, y2)"
106.79 +by simp
106.80 +
106.81 +lemma ch2ch_Pair [simp]:
106.82 + "chain X \<Longrightarrow> chain Y \<Longrightarrow> chain (\<lambda>i. (X i, Y i))"
106.83 +by (rule chainI, simp add: chainE)
106.84 +
106.85 +text {* @{term fst} and @{term snd} are monotone *}
106.86 +
106.87 +lemma fst_monofun: "x \<sqsubseteq> y \<Longrightarrow> fst x \<sqsubseteq> fst y"
106.88 +unfolding below_prod_def by simp
106.89 +
106.90 +lemma snd_monofun: "x \<sqsubseteq> y \<Longrightarrow> snd x \<sqsubseteq> snd y"
106.91 +unfolding below_prod_def by simp
106.92 +
106.93 +lemma monofun_fst: "monofun fst"
106.94 +by (simp add: monofun_def below_prod_def)
106.95 +
106.96 +lemma monofun_snd: "monofun snd"
106.97 +by (simp add: monofun_def below_prod_def)
106.98 +
106.99 +lemmas ch2ch_fst [simp] = ch2ch_monofun [OF monofun_fst]
106.100 +
106.101 +lemmas ch2ch_snd [simp] = ch2ch_monofun [OF monofun_snd]
106.102 +
106.103 +lemma prod_chain_cases:
106.104 + assumes "chain Y"
106.105 + obtains A B
106.106 + where "chain A" and "chain B" and "Y = (\<lambda>i. (A i, B i))"
106.107 +proof
106.108 + from `chain Y` show "chain (\<lambda>i. fst (Y i))" by (rule ch2ch_fst)
106.109 + from `chain Y` show "chain (\<lambda>i. snd (Y i))" by (rule ch2ch_snd)
106.110 + show "Y = (\<lambda>i. (fst (Y i), snd (Y i)))" by simp
106.111 +qed
106.112 +
106.113 +subsection {* Product type is a cpo *}
106.114 +
106.115 +lemma is_lub_Pair:
106.116 + "\<lbrakk>range A <<| x; range B <<| y\<rbrakk> \<Longrightarrow> range (\<lambda>i. (A i, B i)) <<| (x, y)"
106.117 +unfolding is_lub_def is_ub_def ball_simps below_prod_def by simp
106.118 +
106.119 +lemma lub_Pair:
106.120 + "\<lbrakk>chain (A::nat \<Rightarrow> 'a::cpo); chain (B::nat \<Rightarrow> 'b::cpo)\<rbrakk>
106.121 + \<Longrightarrow> (\<Squnion>i. (A i, B i)) = (\<Squnion>i. A i, \<Squnion>i. B i)"
106.122 +by (fast intro: lub_eqI is_lub_Pair elim: thelubE)
106.123 +
106.124 +lemma is_lub_prod:
106.125 + fixes S :: "nat \<Rightarrow> ('a::cpo \<times> 'b::cpo)"
106.126 + assumes S: "chain S"
106.127 + shows "range S <<| (\<Squnion>i. fst (S i), \<Squnion>i. snd (S i))"
106.128 +using S by (auto elim: prod_chain_cases simp add: is_lub_Pair cpo_lubI)
106.129 +
106.130 +lemma lub_prod:
106.131 + "chain (S::nat \<Rightarrow> 'a::cpo \<times> 'b::cpo)
106.132 + \<Longrightarrow> (\<Squnion>i. S i) = (\<Squnion>i. fst (S i), \<Squnion>i. snd (S i))"
106.133 +by (rule is_lub_prod [THEN lub_eqI])
106.134 +
106.135 +instance prod :: (cpo, cpo) cpo
106.136 +proof
106.137 + fix S :: "nat \<Rightarrow> ('a \<times> 'b)"
106.138 + assume "chain S"
106.139 + hence "range S <<| (\<Squnion>i. fst (S i), \<Squnion>i. snd (S i))"
106.140 + by (rule is_lub_prod)
106.141 + thus "\<exists>x. range S <<| x" ..
106.142 +qed
106.143 +
106.144 +instance prod :: (discrete_cpo, discrete_cpo) discrete_cpo
106.145 +proof
106.146 + fix x y :: "'a \<times> 'b"
106.147 + show "x \<sqsubseteq> y \<longleftrightarrow> x = y"
106.148 + unfolding below_prod_def Pair_fst_snd_eq
106.149 + by simp
106.150 +qed
106.151 +
106.152 +subsection {* Product type is pointed *}
106.153 +
106.154 +lemma minimal_prod: "(\<bottom>, \<bottom>) \<sqsubseteq> p"
106.155 +by (simp add: below_prod_def)
106.156 +
106.157 +instance prod :: (pcpo, pcpo) pcpo
106.158 +by intro_classes (fast intro: minimal_prod)
106.159 +
106.160 +lemma inst_prod_pcpo: "\<bottom> = (\<bottom>, \<bottom>)"
106.161 +by (rule minimal_prod [THEN UU_I, symmetric])
106.162 +
106.163 +lemma Pair_bottom_iff [simp]: "(x, y) = \<bottom> \<longleftrightarrow> x = \<bottom> \<and> y = \<bottom>"
106.164 +unfolding inst_prod_pcpo by simp
106.165 +
106.166 +lemma fst_strict [simp]: "fst \<bottom> = \<bottom>"
106.167 +unfolding inst_prod_pcpo by (rule fst_conv)
106.168 +
106.169 +lemma snd_strict [simp]: "snd \<bottom> = \<bottom>"
106.170 +unfolding inst_prod_pcpo by (rule snd_conv)
106.171 +
106.172 +lemma Pair_strict [simp]: "(\<bottom>, \<bottom>) = \<bottom>"
106.173 +by simp
106.174 +
106.175 +lemma split_strict [simp]: "split f \<bottom> = f \<bottom> \<bottom>"
106.176 +unfolding split_def by simp
106.177 +
106.178 +subsection {* Continuity of \emph{Pair}, \emph{fst}, \emph{snd} *}
106.179 +
106.180 +lemma cont_pair1: "cont (\<lambda>x. (x, y))"
106.181 +apply (rule contI)
106.182 +apply (rule is_lub_Pair)
106.183 +apply (erule cpo_lubI)
106.184 +apply (rule is_lub_const)
106.185 +done
106.186 +
106.187 +lemma cont_pair2: "cont (\<lambda>y. (x, y))"
106.188 +apply (rule contI)
106.189 +apply (rule is_lub_Pair)
106.190 +apply (rule is_lub_const)
106.191 +apply (erule cpo_lubI)
106.192 +done
106.193 +
106.194 +lemma cont_fst: "cont fst"
106.195 +apply (rule contI)
106.196 +apply (simp add: lub_prod)
106.197 +apply (erule cpo_lubI [OF ch2ch_fst])
106.198 +done
106.199 +
106.200 +lemma cont_snd: "cont snd"
106.201 +apply (rule contI)
106.202 +apply (simp add: lub_prod)
106.203 +apply (erule cpo_lubI [OF ch2ch_snd])
106.204 +done
106.205 +
106.206 +lemma cont2cont_Pair [simp, cont2cont]:
106.207 + assumes f: "cont (\<lambda>x. f x)"
106.208 + assumes g: "cont (\<lambda>x. g x)"
106.209 + shows "cont (\<lambda>x. (f x, g x))"
106.210 +apply (rule cont_apply [OF f cont_pair1])
106.211 +apply (rule cont_apply [OF g cont_pair2])
106.212 +apply (rule cont_const)
106.213 +done
106.214 +
106.215 +lemmas cont2cont_fst [simp, cont2cont] = cont_compose [OF cont_fst]
106.216 +
106.217 +lemmas cont2cont_snd [simp, cont2cont] = cont_compose [OF cont_snd]
106.218 +
106.219 +lemma cont2cont_prod_case:
106.220 + assumes f1: "\<And>a b. cont (\<lambda>x. f x a b)"
106.221 + assumes f2: "\<And>x b. cont (\<lambda>a. f x a b)"
106.222 + assumes f3: "\<And>x a. cont (\<lambda>b. f x a b)"
106.223 + assumes g: "cont (\<lambda>x. g x)"
106.224 + shows "cont (\<lambda>x. case g x of (a, b) \<Rightarrow> f x a b)"
106.225 +unfolding split_def
106.226 +apply (rule cont_apply [OF g])
106.227 +apply (rule cont_apply [OF cont_fst f2])
106.228 +apply (rule cont_apply [OF cont_snd f3])
106.229 +apply (rule cont_const)
106.230 +apply (rule f1)
106.231 +done
106.232 +
106.233 +lemma prod_contI:
106.234 + assumes f1: "\<And>y. cont (\<lambda>x. f (x, y))"
106.235 + assumes f2: "\<And>x. cont (\<lambda>y. f (x, y))"
106.236 + shows "cont f"
106.237 +proof -
106.238 + have "cont (\<lambda>(x, y). f (x, y))"
106.239 + by (intro cont2cont_prod_case f1 f2 cont2cont)
106.240 + thus "cont f"
106.241 + by (simp only: split_eta)
106.242 +qed
106.243 +
106.244 +lemma prod_cont_iff:
106.245 + "cont f \<longleftrightarrow> (\<forall>y. cont (\<lambda>x. f (x, y))) \<and> (\<forall>x. cont (\<lambda>y. f (x, y)))"
106.246 +apply safe
106.247 +apply (erule cont_compose [OF _ cont_pair1])
106.248 +apply (erule cont_compose [OF _ cont_pair2])
106.249 +apply (simp only: prod_contI)
106.250 +done
106.251 +
106.252 +lemma cont2cont_prod_case' [simp, cont2cont]:
106.253 + assumes f: "cont (\<lambda>p. f (fst p) (fst (snd p)) (snd (snd p)))"
106.254 + assumes g: "cont (\<lambda>x. g x)"
106.255 + shows "cont (\<lambda>x. prod_case (f x) (g x))"
106.256 +using assms by (simp add: cont2cont_prod_case prod_cont_iff)
106.257 +
106.258 +text {* The simple version (due to Joachim Breitner) is needed if
106.259 + either element type of the pair is not a cpo. *}
106.260 +
106.261 +lemma cont2cont_split_simple [simp, cont2cont]:
106.262 + assumes "\<And>a b. cont (\<lambda>x. f x a b)"
106.263 + shows "cont (\<lambda>x. case p of (a, b) \<Rightarrow> f x a b)"
106.264 +using assms by (cases p) auto
106.265 +
106.266 +text {* Admissibility of predicates on product types. *}
106.267 +
106.268 +lemma adm_prod_case [simp]:
106.269 + assumes "adm (\<lambda>x. P x (fst (f x)) (snd (f x)))"
106.270 + shows "adm (\<lambda>x. case f x of (a, b) \<Rightarrow> P x a b)"
106.271 +unfolding prod_case_beta using assms .
106.272 +
106.273 +subsection {* Compactness and chain-finiteness *}
106.274 +
106.275 +lemma fst_below_iff: "fst (x::'a \<times> 'b) \<sqsubseteq> y \<longleftrightarrow> x \<sqsubseteq> (y, snd x)"
106.276 +unfolding below_prod_def by simp
106.277 +
106.278 +lemma snd_below_iff: "snd (x::'a \<times> 'b) \<sqsubseteq> y \<longleftrightarrow> x \<sqsubseteq> (fst x, y)"
106.279 +unfolding below_prod_def by simp
106.280 +
106.281 +lemma compact_fst: "compact x \<Longrightarrow> compact (fst x)"
106.282 +by (rule compactI, simp add: fst_below_iff)
106.283 +
106.284 +lemma compact_snd: "compact x \<Longrightarrow> compact (snd x)"
106.285 +by (rule compactI, simp add: snd_below_iff)
106.286 +
106.287 +lemma compact_Pair: "\<lbrakk>compact x; compact y\<rbrakk> \<Longrightarrow> compact (x, y)"
106.288 +by (rule compactI, simp add: below_prod_def)
106.289 +
106.290 +lemma compact_Pair_iff [simp]: "compact (x, y) \<longleftrightarrow> compact x \<and> compact y"
106.291 +apply (safe intro!: compact_Pair)
106.292 +apply (drule compact_fst, simp)
106.293 +apply (drule compact_snd, simp)
106.294 +done
106.295 +
106.296 +instance prod :: (chfin, chfin) chfin
106.297 +apply intro_classes
106.298 +apply (erule compact_imp_max_in_chain)
106.299 +apply (case_tac "\<Squnion>i. Y i", simp)
106.300 +done
106.301 +
106.302 +end
107.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
107.2 +++ b/src/HOL/HOLCF/README.html Sat Nov 27 16:08:10 2010 -0800
107.3 @@ -0,0 +1,45 @@
107.4 +<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN" "http://www.w3.org/TR/html4/loose.dtd">
107.5 +
107.6 +<html>
107.7 +
107.8 +<head>
107.9 + <meta http-equiv="Content-Type" content="text/html; charset=iso-8859-1">
107.10 + <title>HOLCF/README</title>
107.11 +</head>
107.12 +
107.13 +<body>
107.14 +
107.15 +<h3>HOLCF: A higher-order version of LCF based on Isabelle/HOL</h3>
107.16 +
107.17 +HOLCF is the definitional extension of Church's Higher-Order Logic with
107.18 +Scott's Logic for Computable Functions that has been implemented in the
107.19 +theorem prover Isabelle. This results in a flexible setup for reasoning
107.20 +about functional programs. HOLCF supports standard domain theory (in particular
107.21 +fixpoint reasoning and recursive domain equations) but also coinductive
107.22 +arguments about lazy datatypes.
107.23 +
107.24 +<p>
107.25 +
107.26 +The most recent description of HOLCF is found here:
107.27 +
107.28 +<ul>
107.29 + <li><a href="/~nipkow/pubs/jfp99.html">HOLCF = HOL+LCF</a>
107.30 +</ul>
107.31 +
107.32 +A detailed description (in German) of the entire development can be found in:
107.33 +
107.34 +<ul>
107.35 + <li><a href="http://www4.informatik.tu-muenchen.de/publ/papers/Diss_Regensbu.pdf">HOLCF: eine konservative Erweiterung von HOL um LCF</a>, <br>
107.36 + Franz Regensburger.<br>
107.37 + Dissertation Technische Universität München.<br>
107.38 + Year: 1994.
107.39 +</ul>
107.40 +
107.41 +A short survey is available in:
107.42 +<ul>
107.43 + <li><a href="http://www4.informatik.tu-muenchen.de/publ/papers/Regensburger_HOLT1995.pdf">HOLCF: Higher Order Logic of Computable Functions</a><br>
107.44 +</ul>
107.45 +
107.46 +</body>
107.47 +
107.48 +</html>
108.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
108.2 +++ b/src/HOL/HOLCF/ROOT.ML Sat Nov 27 16:08:10 2010 -0800
108.3 @@ -0,0 +1,9 @@
108.4 +(* Title: HOLCF/ROOT.ML
108.5 + Author: Franz Regensburger
108.6 +
108.7 +HOLCF -- a semantic extension of HOL by the LCF logic.
108.8 +*)
108.9 +
108.10 +no_document use_thys ["Nat_Bijection", "Countable"];
108.11 +
108.12 +use_thys ["Plain_HOLCF", "Fixrec", "HOLCF"];
109.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
109.2 +++ b/src/HOL/HOLCF/Sfun.thy Sat Nov 27 16:08:10 2010 -0800
109.3 @@ -0,0 +1,62 @@
109.4 +(* Title: HOLCF/Sfun.thy
109.5 + Author: Brian Huffman
109.6 +*)
109.7 +
109.8 +header {* The Strict Function Type *}
109.9 +
109.10 +theory Sfun
109.11 +imports Cfun
109.12 +begin
109.13 +
109.14 +pcpodef (open) ('a, 'b) sfun (infixr "->!" 0)
109.15 + = "{f :: 'a \<rightarrow> 'b. f\<cdot>\<bottom> = \<bottom>}"
109.16 +by simp_all
109.17 +
109.18 +type_notation (xsymbols)
109.19 + sfun (infixr "\<rightarrow>!" 0)
109.20 +
109.21 +text {* TODO: Define nice syntax for abstraction, application. *}
109.22 +
109.23 +definition
109.24 + sfun_abs :: "('a \<rightarrow> 'b) \<rightarrow> ('a \<rightarrow>! 'b)"
109.25 +where
109.26 + "sfun_abs = (\<Lambda> f. Abs_sfun (strictify\<cdot>f))"
109.27 +
109.28 +definition
109.29 + sfun_rep :: "('a \<rightarrow>! 'b) \<rightarrow> 'a \<rightarrow> 'b"
109.30 +where
109.31 + "sfun_rep = (\<Lambda> f. Rep_sfun f)"
109.32 +
109.33 +lemma sfun_rep_beta: "sfun_rep\<cdot>f = Rep_sfun f"
109.34 + unfolding sfun_rep_def by (simp add: cont_Rep_sfun)
109.35 +
109.36 +lemma sfun_rep_strict1 [simp]: "sfun_rep\<cdot>\<bottom> = \<bottom>"
109.37 + unfolding sfun_rep_beta by (rule Rep_sfun_strict)
109.38 +
109.39 +lemma sfun_rep_strict2 [simp]: "sfun_rep\<cdot>f\<cdot>\<bottom> = \<bottom>"
109.40 + unfolding sfun_rep_beta by (rule Rep_sfun [simplified])
109.41 +
109.42 +lemma strictify_cancel: "f\<cdot>\<bottom> = \<bottom> \<Longrightarrow> strictify\<cdot>f = f"
109.43 + by (simp add: cfun_eq_iff strictify_conv_if)
109.44 +
109.45 +lemma sfun_abs_sfun_rep [simp]: "sfun_abs\<cdot>(sfun_rep\<cdot>f) = f"
109.46 + unfolding sfun_abs_def sfun_rep_def
109.47 + apply (simp add: cont_Abs_sfun cont_Rep_sfun)
109.48 + apply (simp add: Rep_sfun_inject [symmetric] Abs_sfun_inverse)
109.49 + apply (simp add: cfun_eq_iff strictify_conv_if)
109.50 + apply (simp add: Rep_sfun [simplified])
109.51 + done
109.52 +
109.53 +lemma sfun_rep_sfun_abs [simp]: "sfun_rep\<cdot>(sfun_abs\<cdot>f) = strictify\<cdot>f"
109.54 + unfolding sfun_abs_def sfun_rep_def
109.55 + apply (simp add: cont_Abs_sfun cont_Rep_sfun)
109.56 + apply (simp add: Abs_sfun_inverse)
109.57 + done
109.58 +
109.59 +lemma sfun_eq_iff: "f = g \<longleftrightarrow> sfun_rep\<cdot>f = sfun_rep\<cdot>g"
109.60 +by (simp add: sfun_rep_def cont_Rep_sfun Rep_sfun_inject)
109.61 +
109.62 +lemma sfun_below_iff: "f \<sqsubseteq> g \<longleftrightarrow> sfun_rep\<cdot>f \<sqsubseteq> sfun_rep\<cdot>g"
109.63 +by (simp add: sfun_rep_def cont_Rep_sfun below_sfun_def)
109.64 +
109.65 +end
110.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
110.2 +++ b/src/HOL/HOLCF/Sprod.thy Sat Nov 27 16:08:10 2010 -0800
110.3 @@ -0,0 +1,214 @@
110.4 +(* Title: HOLCF/Sprod.thy
110.5 + Author: Franz Regensburger
110.6 + Author: Brian Huffman
110.7 +*)
110.8 +
110.9 +header {* The type of strict products *}
110.10 +
110.11 +theory Sprod
110.12 +imports Cfun
110.13 +begin
110.14 +
110.15 +default_sort pcpo
110.16 +
110.17 +subsection {* Definition of strict product type *}
110.18 +
110.19 +pcpodef ('a, 'b) sprod (infixr "**" 20) =
110.20 + "{p::'a \<times> 'b. p = \<bottom> \<or> (fst p \<noteq> \<bottom> \<and> snd p \<noteq> \<bottom>)}"
110.21 +by simp_all
110.22 +
110.23 +instance sprod :: ("{chfin,pcpo}", "{chfin,pcpo}") chfin
110.24 +by (rule typedef_chfin [OF type_definition_sprod below_sprod_def])
110.25 +
110.26 +type_notation (xsymbols)
110.27 + sprod ("(_ \<otimes>/ _)" [21,20] 20)
110.28 +type_notation (HTML output)
110.29 + sprod ("(_ \<otimes>/ _)" [21,20] 20)
110.30 +
110.31 +subsection {* Definitions of constants *}
110.32 +
110.33 +definition
110.34 + sfst :: "('a ** 'b) \<rightarrow> 'a" where
110.35 + "sfst = (\<Lambda> p. fst (Rep_sprod p))"
110.36 +
110.37 +definition
110.38 + ssnd :: "('a ** 'b) \<rightarrow> 'b" where
110.39 + "ssnd = (\<Lambda> p. snd (Rep_sprod p))"
110.40 +
110.41 +definition
110.42 + spair :: "'a \<rightarrow> 'b \<rightarrow> ('a ** 'b)" where
110.43 + "spair = (\<Lambda> a b. Abs_sprod (seq\<cdot>b\<cdot>a, seq\<cdot>a\<cdot>b))"
110.44 +
110.45 +definition
110.46 + ssplit :: "('a \<rightarrow> 'b \<rightarrow> 'c) \<rightarrow> ('a ** 'b) \<rightarrow> 'c" where
110.47 + "ssplit = (\<Lambda> f p. seq\<cdot>p\<cdot>(f\<cdot>(sfst\<cdot>p)\<cdot>(ssnd\<cdot>p)))"
110.48 +
110.49 +syntax
110.50 + "_stuple" :: "['a, args] => 'a ** 'b" ("(1'(:_,/ _:'))")
110.51 +translations
110.52 + "(:x, y, z:)" == "(:x, (:y, z:):)"
110.53 + "(:x, y:)" == "CONST spair\<cdot>x\<cdot>y"
110.54 +
110.55 +translations
110.56 + "\<Lambda>(CONST spair\<cdot>x\<cdot>y). t" == "CONST ssplit\<cdot>(\<Lambda> x y. t)"
110.57 +
110.58 +subsection {* Case analysis *}
110.59 +
110.60 +lemma spair_sprod: "(seq\<cdot>b\<cdot>a, seq\<cdot>a\<cdot>b) \<in> sprod"
110.61 +by (simp add: sprod_def seq_conv_if)
110.62 +
110.63 +lemma Rep_sprod_spair: "Rep_sprod (:a, b:) = (seq\<cdot>b\<cdot>a, seq\<cdot>a\<cdot>b)"
110.64 +by (simp add: spair_def cont_Abs_sprod Abs_sprod_inverse spair_sprod)
110.65 +
110.66 +lemmas Rep_sprod_simps =
110.67 + Rep_sprod_inject [symmetric] below_sprod_def
110.68 + Pair_fst_snd_eq below_prod_def
110.69 + Rep_sprod_strict Rep_sprod_spair
110.70 +
110.71 +lemma sprodE [case_names bottom spair, cases type: sprod]:
110.72 + obtains "p = \<bottom>" | x y where "p = (:x, y:)" and "x \<noteq> \<bottom>" and "y \<noteq> \<bottom>"
110.73 +using Rep_sprod [of p] by (auto simp add: sprod_def Rep_sprod_simps)
110.74 +
110.75 +lemma sprod_induct [case_names bottom spair, induct type: sprod]:
110.76 + "\<lbrakk>P \<bottom>; \<And>x y. \<lbrakk>x \<noteq> \<bottom>; y \<noteq> \<bottom>\<rbrakk> \<Longrightarrow> P (:x, y:)\<rbrakk> \<Longrightarrow> P x"
110.77 +by (cases x, simp_all)
110.78 +
110.79 +subsection {* Properties of \emph{spair} *}
110.80 +
110.81 +lemma spair_strict1 [simp]: "(:\<bottom>, y:) = \<bottom>"
110.82 +by (simp add: Rep_sprod_simps)
110.83 +
110.84 +lemma spair_strict2 [simp]: "(:x, \<bottom>:) = \<bottom>"
110.85 +by (simp add: Rep_sprod_simps)
110.86 +
110.87 +lemma spair_bottom_iff [simp]: "((:x, y:) = \<bottom>) = (x = \<bottom> \<or> y = \<bottom>)"
110.88 +by (simp add: Rep_sprod_simps seq_conv_if)
110.89 +
110.90 +lemma spair_below_iff:
110.91 + "((:a, b:) \<sqsubseteq> (:c, d:)) = (a = \<bottom> \<or> b = \<bottom> \<or> (a \<sqsubseteq> c \<and> b \<sqsubseteq> d))"
110.92 +by (simp add: Rep_sprod_simps seq_conv_if)
110.93 +
110.94 +lemma spair_eq_iff:
110.95 + "((:a, b:) = (:c, d:)) =
110.96 + (a = c \<and> b = d \<or> (a = \<bottom> \<or> b = \<bottom>) \<and> (c = \<bottom> \<or> d = \<bottom>))"
110.97 +by (simp add: Rep_sprod_simps seq_conv_if)
110.98 +
110.99 +lemma spair_strict: "x = \<bottom> \<or> y = \<bottom> \<Longrightarrow> (:x, y:) = \<bottom>"
110.100 +by simp
110.101 +
110.102 +lemma spair_strict_rev: "(:x, y:) \<noteq> \<bottom> \<Longrightarrow> x \<noteq> \<bottom> \<and> y \<noteq> \<bottom>"
110.103 +by simp
110.104 +
110.105 +lemma spair_defined: "\<lbrakk>x \<noteq> \<bottom>; y \<noteq> \<bottom>\<rbrakk> \<Longrightarrow> (:x, y:) \<noteq> \<bottom>"
110.106 +by simp
110.107 +
110.108 +lemma spair_defined_rev: "(:x, y:) = \<bottom> \<Longrightarrow> x = \<bottom> \<or> y = \<bottom>"
110.109 +by simp
110.110 +
110.111 +lemma spair_below:
110.112 + "\<lbrakk>x \<noteq> \<bottom>; y \<noteq> \<bottom>\<rbrakk> \<Longrightarrow> (:x, y:) \<sqsubseteq> (:a, b:) = (x \<sqsubseteq> a \<and> y \<sqsubseteq> b)"
110.113 +by (simp add: spair_below_iff)
110.114 +
110.115 +lemma spair_eq:
110.116 + "\<lbrakk>x \<noteq> \<bottom>; y \<noteq> \<bottom>\<rbrakk> \<Longrightarrow> ((:x, y:) = (:a, b:)) = (x = a \<and> y = b)"
110.117 +by (simp add: spair_eq_iff)
110.118 +
110.119 +lemma spair_inject:
110.120 + "\<lbrakk>x \<noteq> \<bottom>; y \<noteq> \<bottom>; (:x, y:) = (:a, b:)\<rbrakk> \<Longrightarrow> x = a \<and> y = b"
110.121 +by (rule spair_eq [THEN iffD1])
110.122 +
110.123 +lemma inst_sprod_pcpo2: "UU = (:UU,UU:)"
110.124 +by simp
110.125 +
110.126 +lemma sprodE2: "(\<And>x y. p = (:x, y:) \<Longrightarrow> Q) \<Longrightarrow> Q"
110.127 +by (cases p, simp only: inst_sprod_pcpo2, simp)
110.128 +
110.129 +subsection {* Properties of \emph{sfst} and \emph{ssnd} *}
110.130 +
110.131 +lemma sfst_strict [simp]: "sfst\<cdot>\<bottom> = \<bottom>"
110.132 +by (simp add: sfst_def cont_Rep_sprod Rep_sprod_strict)
110.133 +
110.134 +lemma ssnd_strict [simp]: "ssnd\<cdot>\<bottom> = \<bottom>"
110.135 +by (simp add: ssnd_def cont_Rep_sprod Rep_sprod_strict)
110.136 +
110.137 +lemma sfst_spair [simp]: "y \<noteq> \<bottom> \<Longrightarrow> sfst\<cdot>(:x, y:) = x"
110.138 +by (simp add: sfst_def cont_Rep_sprod Rep_sprod_spair)
110.139 +
110.140 +lemma ssnd_spair [simp]: "x \<noteq> \<bottom> \<Longrightarrow> ssnd\<cdot>(:x, y:) = y"
110.141 +by (simp add: ssnd_def cont_Rep_sprod Rep_sprod_spair)
110.142 +
110.143 +lemma sfst_bottom_iff [simp]: "(sfst\<cdot>p = \<bottom>) = (p = \<bottom>)"
110.144 +by (cases p, simp_all)
110.145 +
110.146 +lemma ssnd_bottom_iff [simp]: "(ssnd\<cdot>p = \<bottom>) = (p = \<bottom>)"
110.147 +by (cases p, simp_all)
110.148 +
110.149 +lemma sfst_defined: "p \<noteq> \<bottom> \<Longrightarrow> sfst\<cdot>p \<noteq> \<bottom>"
110.150 +by simp
110.151 +
110.152 +lemma ssnd_defined: "p \<noteq> \<bottom> \<Longrightarrow> ssnd\<cdot>p \<noteq> \<bottom>"
110.153 +by simp
110.154 +
110.155 +lemma spair_sfst_ssnd: "(:sfst\<cdot>p, ssnd\<cdot>p:) = p"
110.156 +by (cases p, simp_all)
110.157 +
110.158 +lemma below_sprod: "(x \<sqsubseteq> y) = (sfst\<cdot>x \<sqsubseteq> sfst\<cdot>y \<and> ssnd\<cdot>x \<sqsubseteq> ssnd\<cdot>y)"
110.159 +by (simp add: Rep_sprod_simps sfst_def ssnd_def cont_Rep_sprod)
110.160 +
110.161 +lemma eq_sprod: "(x = y) = (sfst\<cdot>x = sfst\<cdot>y \<and> ssnd\<cdot>x = ssnd\<cdot>y)"
110.162 +by (auto simp add: po_eq_conv below_sprod)
110.163 +
110.164 +lemma sfst_below_iff: "sfst\<cdot>x \<sqsubseteq> y \<longleftrightarrow> x \<sqsubseteq> (:y, ssnd\<cdot>x:)"
110.165 +apply (cases "x = \<bottom>", simp, cases "y = \<bottom>", simp)
110.166 +apply (simp add: below_sprod)
110.167 +done
110.168 +
110.169 +lemma ssnd_below_iff: "ssnd\<cdot>x \<sqsubseteq> y \<longleftrightarrow> x \<sqsubseteq> (:sfst\<cdot>x, y:)"
110.170 +apply (cases "x = \<bottom>", simp, cases "y = \<bottom>", simp)
110.171 +apply (simp add: below_sprod)
110.172 +done
110.173 +
110.174 +subsection {* Compactness *}
110.175 +
110.176 +lemma compact_sfst: "compact x \<Longrightarrow> compact (sfst\<cdot>x)"
110.177 +by (rule compactI, simp add: sfst_below_iff)
110.178 +
110.179 +lemma compact_ssnd: "compact x \<Longrightarrow> compact (ssnd\<cdot>x)"
110.180 +by (rule compactI, simp add: ssnd_below_iff)
110.181 +
110.182 +lemma compact_spair: "\<lbrakk>compact x; compact y\<rbrakk> \<Longrightarrow> compact (:x, y:)"
110.183 +by (rule compact_sprod, simp add: Rep_sprod_spair seq_conv_if)
110.184 +
110.185 +lemma compact_spair_iff:
110.186 + "compact (:x, y:) = (x = \<bottom> \<or> y = \<bottom> \<or> (compact x \<and> compact y))"
110.187 +apply (safe elim!: compact_spair)
110.188 +apply (drule compact_sfst, simp)
110.189 +apply (drule compact_ssnd, simp)
110.190 +apply simp
110.191 +apply simp
110.192 +done
110.193 +
110.194 +subsection {* Properties of \emph{ssplit} *}
110.195 +
110.196 +lemma ssplit1 [simp]: "ssplit\<cdot>f\<cdot>\<bottom> = \<bottom>"
110.197 +by (simp add: ssplit_def)
110.198 +
110.199 +lemma ssplit2 [simp]: "\<lbrakk>x \<noteq> \<bottom>; y \<noteq> \<bottom>\<rbrakk> \<Longrightarrow> ssplit\<cdot>f\<cdot>(:x, y:) = f\<cdot>x\<cdot>y"
110.200 +by (simp add: ssplit_def)
110.201 +
110.202 +lemma ssplit3 [simp]: "ssplit\<cdot>spair\<cdot>z = z"
110.203 +by (cases z, simp_all)
110.204 +
110.205 +subsection {* Strict product preserves flatness *}
110.206 +
110.207 +instance sprod :: (flat, flat) flat
110.208 +proof
110.209 + fix x y :: "'a \<otimes> 'b"
110.210 + assume "x \<sqsubseteq> y" thus "x = \<bottom> \<or> x = y"
110.211 + apply (induct x, simp)
110.212 + apply (induct y, simp)
110.213 + apply (simp add: spair_below_iff flat_below_iff)
110.214 + done
110.215 +qed
110.216 +
110.217 +end
111.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
111.2 +++ b/src/HOL/HOLCF/Ssum.thy Sat Nov 27 16:08:10 2010 -0800
111.3 @@ -0,0 +1,198 @@
111.4 +(* Title: HOLCF/Ssum.thy
111.5 + Author: Franz Regensburger
111.6 + Author: Brian Huffman
111.7 +*)
111.8 +
111.9 +header {* The type of strict sums *}
111.10 +
111.11 +theory Ssum
111.12 +imports Tr
111.13 +begin
111.14 +
111.15 +default_sort pcpo
111.16 +
111.17 +subsection {* Definition of strict sum type *}
111.18 +
111.19 +pcpodef ('a, 'b) ssum (infixr "++" 10) =
111.20 + "{p :: tr \<times> ('a \<times> 'b). p = \<bottom> \<or>
111.21 + (fst p = TT \<and> fst (snd p) \<noteq> \<bottom> \<and> snd (snd p) = \<bottom>) \<or>
111.22 + (fst p = FF \<and> fst (snd p) = \<bottom> \<and> snd (snd p) \<noteq> \<bottom>) }"
111.23 +by simp_all
111.24 +
111.25 +instance ssum :: ("{chfin,pcpo}", "{chfin,pcpo}") chfin
111.26 +by (rule typedef_chfin [OF type_definition_ssum below_ssum_def])
111.27 +
111.28 +type_notation (xsymbols)
111.29 + ssum ("(_ \<oplus>/ _)" [21, 20] 20)
111.30 +type_notation (HTML output)
111.31 + ssum ("(_ \<oplus>/ _)" [21, 20] 20)
111.32 +
111.33 +
111.34 +subsection {* Definitions of constructors *}
111.35 +
111.36 +definition
111.37 + sinl :: "'a \<rightarrow> ('a ++ 'b)" where
111.38 + "sinl = (\<Lambda> a. Abs_ssum (seq\<cdot>a\<cdot>TT, a, \<bottom>))"
111.39 +
111.40 +definition
111.41 + sinr :: "'b \<rightarrow> ('a ++ 'b)" where
111.42 + "sinr = (\<Lambda> b. Abs_ssum (seq\<cdot>b\<cdot>FF, \<bottom>, b))"
111.43 +
111.44 +lemma sinl_ssum: "(seq\<cdot>a\<cdot>TT, a, \<bottom>) \<in> ssum"
111.45 +by (simp add: ssum_def seq_conv_if)
111.46 +
111.47 +lemma sinr_ssum: "(seq\<cdot>b\<cdot>FF, \<bottom>, b) \<in> ssum"
111.48 +by (simp add: ssum_def seq_conv_if)
111.49 +
111.50 +lemma Rep_ssum_sinl: "Rep_ssum (sinl\<cdot>a) = (seq\<cdot>a\<cdot>TT, a, \<bottom>)"
111.51 +by (simp add: sinl_def cont_Abs_ssum Abs_ssum_inverse sinl_ssum)
111.52 +
111.53 +lemma Rep_ssum_sinr: "Rep_ssum (sinr\<cdot>b) = (seq\<cdot>b\<cdot>FF, \<bottom>, b)"
111.54 +by (simp add: sinr_def cont_Abs_ssum Abs_ssum_inverse sinr_ssum)
111.55 +
111.56 +lemmas Rep_ssum_simps =
111.57 + Rep_ssum_inject [symmetric] below_ssum_def
111.58 + Pair_fst_snd_eq below_prod_def
111.59 + Rep_ssum_strict Rep_ssum_sinl Rep_ssum_sinr
111.60 +
111.61 +subsection {* Properties of \emph{sinl} and \emph{sinr} *}
111.62 +
111.63 +text {* Ordering *}
111.64 +
111.65 +lemma sinl_below [simp]: "(sinl\<cdot>x \<sqsubseteq> sinl\<cdot>y) = (x \<sqsubseteq> y)"
111.66 +by (simp add: Rep_ssum_simps seq_conv_if)
111.67 +
111.68 +lemma sinr_below [simp]: "(sinr\<cdot>x \<sqsubseteq> sinr\<cdot>y) = (x \<sqsubseteq> y)"
111.69 +by (simp add: Rep_ssum_simps seq_conv_if)
111.70 +
111.71 +lemma sinl_below_sinr [simp]: "(sinl\<cdot>x \<sqsubseteq> sinr\<cdot>y) = (x = \<bottom>)"
111.72 +by (simp add: Rep_ssum_simps seq_conv_if)
111.73 +
111.74 +lemma sinr_below_sinl [simp]: "(sinr\<cdot>x \<sqsubseteq> sinl\<cdot>y) = (x = \<bottom>)"
111.75 +by (simp add: Rep_ssum_simps seq_conv_if)
111.76 +
111.77 +text {* Equality *}
111.78 +
111.79 +lemma sinl_eq [simp]: "(sinl\<cdot>x = sinl\<cdot>y) = (x = y)"
111.80 +by (simp add: po_eq_conv)
111.81 +
111.82 +lemma sinr_eq [simp]: "(sinr\<cdot>x = sinr\<cdot>y) = (x = y)"
111.83 +by (simp add: po_eq_conv)
111.84 +
111.85 +lemma sinl_eq_sinr [simp]: "(sinl\<cdot>x = sinr\<cdot>y) = (x = \<bottom> \<and> y = \<bottom>)"
111.86 +by (subst po_eq_conv, simp)
111.87 +
111.88 +lemma sinr_eq_sinl [simp]: "(sinr\<cdot>x = sinl\<cdot>y) = (x = \<bottom> \<and> y = \<bottom>)"
111.89 +by (subst po_eq_conv, simp)
111.90 +
111.91 +lemma sinl_inject: "sinl\<cdot>x = sinl\<cdot>y \<Longrightarrow> x = y"
111.92 +by (rule sinl_eq [THEN iffD1])
111.93 +
111.94 +lemma sinr_inject: "sinr\<cdot>x = sinr\<cdot>y \<Longrightarrow> x = y"
111.95 +by (rule sinr_eq [THEN iffD1])
111.96 +
111.97 +text {* Strictness *}
111.98 +
111.99 +lemma sinl_strict [simp]: "sinl\<cdot>\<bottom> = \<bottom>"
111.100 +by (simp add: Rep_ssum_simps)
111.101 +
111.102 +lemma sinr_strict [simp]: "sinr\<cdot>\<bottom> = \<bottom>"
111.103 +by (simp add: Rep_ssum_simps)
111.104 +
111.105 +lemma sinl_bottom_iff [simp]: "(sinl\<cdot>x = \<bottom>) = (x = \<bottom>)"
111.106 +using sinl_eq [of "x" "\<bottom>"] by simp
111.107 +
111.108 +lemma sinr_bottom_iff [simp]: "(sinr\<cdot>x = \<bottom>) = (x = \<bottom>)"
111.109 +using sinr_eq [of "x" "\<bottom>"] by simp
111.110 +
111.111 +lemma sinl_defined: "x \<noteq> \<bottom> \<Longrightarrow> sinl\<cdot>x \<noteq> \<bottom>"
111.112 +by simp
111.113 +
111.114 +lemma sinr_defined: "x \<noteq> \<bottom> \<Longrightarrow> sinr\<cdot>x \<noteq> \<bottom>"
111.115 +by simp
111.116 +
111.117 +text {* Compactness *}
111.118 +
111.119 +lemma compact_sinl: "compact x \<Longrightarrow> compact (sinl\<cdot>x)"
111.120 +by (rule compact_ssum, simp add: Rep_ssum_sinl)
111.121 +
111.122 +lemma compact_sinr: "compact x \<Longrightarrow> compact (sinr\<cdot>x)"
111.123 +by (rule compact_ssum, simp add: Rep_ssum_sinr)
111.124 +
111.125 +lemma compact_sinlD: "compact (sinl\<cdot>x) \<Longrightarrow> compact x"
111.126 +unfolding compact_def
111.127 +by (drule adm_subst [OF cont_Rep_cfun2 [where f=sinl]], simp)
111.128 +
111.129 +lemma compact_sinrD: "compact (sinr\<cdot>x) \<Longrightarrow> compact x"
111.130 +unfolding compact_def
111.131 +by (drule adm_subst [OF cont_Rep_cfun2 [where f=sinr]], simp)
111.132 +
111.133 +lemma compact_sinl_iff [simp]: "compact (sinl\<cdot>x) = compact x"
111.134 +by (safe elim!: compact_sinl compact_sinlD)
111.135 +
111.136 +lemma compact_sinr_iff [simp]: "compact (sinr\<cdot>x) = compact x"
111.137 +by (safe elim!: compact_sinr compact_sinrD)
111.138 +
111.139 +subsection {* Case analysis *}
111.140 +
111.141 +lemma ssumE [case_names bottom sinl sinr, cases type: ssum]:
111.142 + obtains "p = \<bottom>"
111.143 + | x where "p = sinl\<cdot>x" and "x \<noteq> \<bottom>"
111.144 + | y where "p = sinr\<cdot>y" and "y \<noteq> \<bottom>"
111.145 +using Rep_ssum [of p] by (auto simp add: ssum_def Rep_ssum_simps)
111.146 +
111.147 +lemma ssum_induct [case_names bottom sinl sinr, induct type: ssum]:
111.148 + "\<lbrakk>P \<bottom>;
111.149 + \<And>x. x \<noteq> \<bottom> \<Longrightarrow> P (sinl\<cdot>x);
111.150 + \<And>y. y \<noteq> \<bottom> \<Longrightarrow> P (sinr\<cdot>y)\<rbrakk> \<Longrightarrow> P x"
111.151 +by (cases x, simp_all)
111.152 +
111.153 +lemma ssumE2 [case_names sinl sinr]:
111.154 + "\<lbrakk>\<And>x. p = sinl\<cdot>x \<Longrightarrow> Q; \<And>y. p = sinr\<cdot>y \<Longrightarrow> Q\<rbrakk> \<Longrightarrow> Q"
111.155 +by (cases p, simp only: sinl_strict [symmetric], simp, simp)
111.156 +
111.157 +lemma below_sinlD: "p \<sqsubseteq> sinl\<cdot>x \<Longrightarrow> \<exists>y. p = sinl\<cdot>y \<and> y \<sqsubseteq> x"
111.158 +by (cases p, rule_tac x="\<bottom>" in exI, simp_all)
111.159 +
111.160 +lemma below_sinrD: "p \<sqsubseteq> sinr\<cdot>x \<Longrightarrow> \<exists>y. p = sinr\<cdot>y \<and> y \<sqsubseteq> x"
111.161 +by (cases p, rule_tac x="\<bottom>" in exI, simp_all)
111.162 +
111.163 +subsection {* Case analysis combinator *}
111.164 +
111.165 +definition
111.166 + sscase :: "('a \<rightarrow> 'c) \<rightarrow> ('b \<rightarrow> 'c) \<rightarrow> ('a ++ 'b) \<rightarrow> 'c" where
111.167 + "sscase = (\<Lambda> f g s. (\<lambda>(t, x, y). If t then f\<cdot>x else g\<cdot>y) (Rep_ssum s))"
111.168 +
111.169 +translations
111.170 + "case s of XCONST sinl\<cdot>x \<Rightarrow> t1 | XCONST sinr\<cdot>y \<Rightarrow> t2" == "CONST sscase\<cdot>(\<Lambda> x. t1)\<cdot>(\<Lambda> y. t2)\<cdot>s"
111.171 +
111.172 +translations
111.173 + "\<Lambda>(XCONST sinl\<cdot>x). t" == "CONST sscase\<cdot>(\<Lambda> x. t)\<cdot>\<bottom>"
111.174 + "\<Lambda>(XCONST sinr\<cdot>y). t" == "CONST sscase\<cdot>\<bottom>\<cdot>(\<Lambda> y. t)"
111.175 +
111.176 +lemma beta_sscase:
111.177 + "sscase\<cdot>f\<cdot>g\<cdot>s = (\<lambda>(t, x, y). If t then f\<cdot>x else g\<cdot>y) (Rep_ssum s)"
111.178 +unfolding sscase_def by (simp add: cont_Rep_ssum [THEN cont_compose])
111.179 +
111.180 +lemma sscase1 [simp]: "sscase\<cdot>f\<cdot>g\<cdot>\<bottom> = \<bottom>"
111.181 +unfolding beta_sscase by (simp add: Rep_ssum_strict)
111.182 +
111.183 +lemma sscase2 [simp]: "x \<noteq> \<bottom> \<Longrightarrow> sscase\<cdot>f\<cdot>g\<cdot>(sinl\<cdot>x) = f\<cdot>x"
111.184 +unfolding beta_sscase by (simp add: Rep_ssum_sinl)
111.185 +
111.186 +lemma sscase3 [simp]: "y \<noteq> \<bottom> \<Longrightarrow> sscase\<cdot>f\<cdot>g\<cdot>(sinr\<cdot>y) = g\<cdot>y"
111.187 +unfolding beta_sscase by (simp add: Rep_ssum_sinr)
111.188 +
111.189 +lemma sscase4 [simp]: "sscase\<cdot>sinl\<cdot>sinr\<cdot>z = z"
111.190 +by (cases z, simp_all)
111.191 +
111.192 +subsection {* Strict sum preserves flatness *}
111.193 +
111.194 +instance ssum :: (flat, flat) flat
111.195 +apply (intro_classes, clarify)
111.196 +apply (case_tac x, simp)
111.197 +apply (case_tac y, simp_all add: flat_below_iff)
111.198 +apply (case_tac y, simp_all add: flat_below_iff)
111.199 +done
111.200 +
111.201 +end
112.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
112.2 +++ b/src/HOL/HOLCF/Tools/Domain/domain.ML Sat Nov 27 16:08:10 2010 -0800
112.3 @@ -0,0 +1,266 @@
112.4 +(* Title: HOLCF/Tools/Domain/domain.ML
112.5 + Author: David von Oheimb
112.6 + Author: Brian Huffman
112.7 +
112.8 +Theory extender for domain command, including theory syntax.
112.9 +*)
112.10 +
112.11 +signature DOMAIN =
112.12 +sig
112.13 + val add_domain_cmd:
112.14 + ((string * string option) list * binding * mixfix *
112.15 + (binding * (bool * binding option * string) list * mixfix) list) list
112.16 + -> theory -> theory
112.17 +
112.18 + val add_domain:
112.19 + ((string * sort) list * binding * mixfix *
112.20 + (binding * (bool * binding option * typ) list * mixfix) list) list
112.21 + -> theory -> theory
112.22 +
112.23 + val add_new_domain_cmd:
112.24 + ((string * string option) list * binding * mixfix *
112.25 + (binding * (bool * binding option * string) list * mixfix) list) list
112.26 + -> theory -> theory
112.27 +
112.28 + val add_new_domain:
112.29 + ((string * sort) list * binding * mixfix *
112.30 + (binding * (bool * binding option * typ) list * mixfix) list) list
112.31 + -> theory -> theory
112.32 +end;
112.33 +
112.34 +structure Domain :> DOMAIN =
112.35 +struct
112.36 +
112.37 +open HOLCF_Library;
112.38 +
112.39 +fun first (x,_,_) = x;
112.40 +fun second (_,x,_) = x;
112.41 +fun third (_,_,x) = x;
112.42 +
112.43 +(* ----- calls for building new thy and thms -------------------------------- *)
112.44 +
112.45 +type info =
112.46 + Domain_Take_Proofs.iso_info list * Domain_Take_Proofs.take_induct_info;
112.47 +
112.48 +fun add_arity ((b, sorts, mx), sort) thy : theory =
112.49 + thy
112.50 + |> Sign.add_types [(b, length sorts, mx)]
112.51 + |> AxClass.axiomatize_arity (Sign.full_name thy b, sorts, sort);
112.52 +
112.53 +fun gen_add_domain
112.54 + (prep_sort : theory -> 'a -> sort)
112.55 + (prep_typ : theory -> (string * sort) list -> 'b -> typ)
112.56 + (add_isos : (binding * mixfix * (typ * typ)) list -> theory -> info * theory)
112.57 + (arg_sort : bool -> sort)
112.58 + (raw_specs : ((string * 'a) list * binding * mixfix *
112.59 + (binding * (bool * binding option * 'b) list * mixfix) list) list)
112.60 + (thy : theory) =
112.61 + let
112.62 + val dtnvs : (binding * typ list * mixfix) list =
112.63 + let
112.64 + fun prep_tvar (a, s) = TFree (a, prep_sort thy s);
112.65 + in
112.66 + map (fn (vs, dbind, mx, _) =>
112.67 + (dbind, map prep_tvar vs, mx)) raw_specs
112.68 + end;
112.69 +
112.70 + fun thy_arity (dbind, tvars, mx) =
112.71 + ((dbind, map (snd o dest_TFree) tvars, mx), arg_sort false);
112.72 +
112.73 + (* this theory is used just for parsing and error checking *)
112.74 + val tmp_thy = thy
112.75 + |> Theory.copy
112.76 + |> fold (add_arity o thy_arity) dtnvs;
112.77 +
112.78 + val dbinds : binding list =
112.79 + map (fn (_,dbind,_,_) => dbind) raw_specs;
112.80 + val raw_rhss :
112.81 + (binding * (bool * binding option * 'b) list * mixfix) list list =
112.82 + map (fn (_,_,_,cons) => cons) raw_specs;
112.83 + val dtnvs' : (string * typ list) list =
112.84 + map (fn (dbind, vs, mx) => (Sign.full_name thy dbind, vs)) dtnvs;
112.85 +
112.86 + val all_cons = map (Binding.name_of o first) (flat raw_rhss);
112.87 + val test_dupl_cons =
112.88 + case duplicates (op =) all_cons of
112.89 + [] => false | dups => error ("Duplicate constructors: "
112.90 + ^ commas_quote dups);
112.91 + val all_sels =
112.92 + (map Binding.name_of o map_filter second o maps second) (flat raw_rhss);
112.93 + val test_dupl_sels =
112.94 + case duplicates (op =) all_sels of
112.95 + [] => false | dups => error("Duplicate selectors: "^commas_quote dups);
112.96 +
112.97 + fun test_dupl_tvars s =
112.98 + case duplicates (op =) (map(fst o dest_TFree)s) of
112.99 + [] => false | dups => error("Duplicate type arguments: "
112.100 + ^commas_quote dups);
112.101 + val test_dupl_tvars' = exists test_dupl_tvars (map snd dtnvs');
112.102 +
112.103 + val sorts : (string * sort) list =
112.104 + let val all_sorts = map (map dest_TFree o snd) dtnvs';
112.105 + in
112.106 + case distinct (eq_set (op =)) all_sorts of
112.107 + [sorts] => sorts
112.108 + | _ => error "Mutually recursive domains must have same type parameters"
112.109 + end;
112.110 +
112.111 + (* a lazy argument may have an unpointed type *)
112.112 + (* unless the argument has a selector function *)
112.113 + fun check_pcpo (lazy, sel, T) =
112.114 + let val sort = arg_sort (lazy andalso is_none sel) in
112.115 + if Sign.of_sort tmp_thy (T, sort) then ()
112.116 + else error ("Constructor argument type is not of sort " ^
112.117 + Syntax.string_of_sort_global tmp_thy sort ^ ": " ^
112.118 + Syntax.string_of_typ_global tmp_thy T)
112.119 + end;
112.120 +
112.121 + (* test for free type variables, illegal sort constraints on rhs,
112.122 + non-pcpo-types and invalid use of recursive type;
112.123 + replace sorts in type variables on rhs *)
112.124 + val rec_tab = Domain_Take_Proofs.get_rec_tab thy;
112.125 + fun check_rec rec_ok (T as TFree (v,_)) =
112.126 + if AList.defined (op =) sorts v then T
112.127 + else error ("Free type variable " ^ quote v ^ " on rhs.")
112.128 + | check_rec rec_ok (T as Type (s, Ts)) =
112.129 + (case AList.lookup (op =) dtnvs' s of
112.130 + NONE =>
112.131 + let val rec_ok' = rec_ok andalso Symtab.defined rec_tab s;
112.132 + in Type (s, map (check_rec rec_ok') Ts) end
112.133 + | SOME typevars =>
112.134 + if typevars <> Ts
112.135 + then error ("Recursion of type " ^
112.136 + quote (Syntax.string_of_typ_global tmp_thy T) ^
112.137 + " with different arguments")
112.138 + else if rec_ok then T
112.139 + else error ("Illegal indirect recursion of type " ^
112.140 + quote (Syntax.string_of_typ_global tmp_thy T)))
112.141 + | check_rec rec_ok (TVar _) = error "extender:check_rec";
112.142 +
112.143 + fun prep_arg (lazy, sel, raw_T) =
112.144 + let
112.145 + val T = prep_typ tmp_thy sorts raw_T;
112.146 + val _ = check_rec true T;
112.147 + val _ = check_pcpo (lazy, sel, T);
112.148 + in (lazy, sel, T) end;
112.149 + fun prep_con (b, args, mx) = (b, map prep_arg args, mx);
112.150 + fun prep_rhs cons = map prep_con cons;
112.151 + val rhss : (binding * (bool * binding option * typ) list * mixfix) list list =
112.152 + map prep_rhs raw_rhss;
112.153 +
112.154 + fun mk_arg_typ (lazy, dest_opt, T) = if lazy then mk_upT T else T;
112.155 + fun mk_con_typ (bind, args, mx) =
112.156 + if null args then oneT else foldr1 mk_sprodT (map mk_arg_typ args);
112.157 + fun mk_rhs_typ cons = foldr1 mk_ssumT (map mk_con_typ cons);
112.158 +
112.159 + val absTs : typ list = map Type dtnvs';
112.160 + val repTs : typ list = map mk_rhs_typ rhss;
112.161 +
112.162 + val iso_spec : (binding * mixfix * (typ * typ)) list =
112.163 + map (fn ((dbind, _, mx), eq) => (dbind, mx, eq))
112.164 + (dtnvs ~~ (absTs ~~ repTs));
112.165 +
112.166 + val ((iso_infos, take_info), thy) = add_isos iso_spec thy;
112.167 +
112.168 + val (constr_infos, thy) =
112.169 + thy
112.170 + |> fold_map (fn ((dbind, cons), info) =>
112.171 + Domain_Constructors.add_domain_constructors dbind cons info)
112.172 + (dbinds ~~ rhss ~~ iso_infos);
112.173 +
112.174 + val (take_rews, thy) =
112.175 + Domain_Induction.comp_theorems
112.176 + dbinds take_info constr_infos thy;
112.177 + in
112.178 + thy
112.179 + end;
112.180 +
112.181 +fun define_isos (spec : (binding * mixfix * (typ * typ)) list) =
112.182 + let
112.183 + fun prep (dbind, mx, (lhsT, rhsT)) =
112.184 + let val (dname, vs) = dest_Type lhsT;
112.185 + in (map (fst o dest_TFree) vs, dbind, mx, rhsT, NONE) end;
112.186 + in
112.187 + Domain_Isomorphism.domain_isomorphism (map prep spec)
112.188 + end;
112.189 +
112.190 +fun pcpo_arg lazy = if lazy then @{sort cpo} else @{sort pcpo};
112.191 +fun rep_arg lazy = if lazy then @{sort predomain} else @{sort "domain"};
112.192 +
112.193 +fun read_sort thy (SOME s) = Syntax.read_sort_global thy s
112.194 + | read_sort thy NONE = Sign.defaultS thy;
112.195 +
112.196 +(* Adapted from src/HOL/Tools/Datatype/datatype_data.ML *)
112.197 +fun read_typ thy sorts str =
112.198 + let
112.199 + val ctxt = ProofContext.init_global thy
112.200 + |> fold (Variable.declare_typ o TFree) sorts;
112.201 + in Syntax.read_typ ctxt str end;
112.202 +
112.203 +fun cert_typ sign sorts raw_T =
112.204 + let
112.205 + val T = Type.no_tvars (Sign.certify_typ sign raw_T)
112.206 + handle TYPE (msg, _, _) => error msg;
112.207 + val sorts' = Term.add_tfreesT T sorts;
112.208 + val _ =
112.209 + case duplicates (op =) (map fst sorts') of
112.210 + [] => ()
112.211 + | dups => error ("Inconsistent sort constraints for " ^ commas dups)
112.212 + in T end;
112.213 +
112.214 +val add_domain =
112.215 + gen_add_domain (K I) cert_typ Domain_Axioms.add_axioms pcpo_arg;
112.216 +
112.217 +val add_new_domain =
112.218 + gen_add_domain (K I) cert_typ define_isos rep_arg;
112.219 +
112.220 +val add_domain_cmd =
112.221 + gen_add_domain read_sort read_typ Domain_Axioms.add_axioms pcpo_arg;
112.222 +
112.223 +val add_new_domain_cmd =
112.224 + gen_add_domain read_sort read_typ define_isos rep_arg;
112.225 +
112.226 +
112.227 +(** outer syntax **)
112.228 +
112.229 +val _ = Keyword.keyword "lazy";
112.230 +val _ = Keyword.keyword "unsafe";
112.231 +
112.232 +val dest_decl : (bool * binding option * string) parser =
112.233 + Parse.$$$ "(" |-- Scan.optional (Parse.$$$ "lazy" >> K true) false --
112.234 + (Parse.binding >> SOME) -- (Parse.$$$ "::" |-- Parse.typ) --| Parse.$$$ ")" >> Parse.triple1
112.235 + || Parse.$$$ "(" |-- Parse.$$$ "lazy" |-- Parse.typ --| Parse.$$$ ")"
112.236 + >> (fn t => (true,NONE,t))
112.237 + || Parse.typ >> (fn t => (false,NONE,t));
112.238 +
112.239 +val cons_decl =
112.240 + Parse.binding -- Scan.repeat dest_decl -- Parse.opt_mixfix;
112.241 +
112.242 +val domain_decl =
112.243 + (Parse.type_args_constrained -- Parse.binding -- Parse.opt_mixfix) --
112.244 + (Parse.$$$ "=" |-- Parse.enum1 "|" cons_decl);
112.245 +
112.246 +val domains_decl =
112.247 + Scan.optional (Parse.$$$ "(" |-- (Parse.$$$ "unsafe" >> K true) --| Parse.$$$ ")") false --
112.248 + Parse.and_list1 domain_decl;
112.249 +
112.250 +fun mk_domain
112.251 + (unsafe : bool,
112.252 + doms : ((((string * string option) list * binding) * mixfix) *
112.253 + ((binding * (bool * binding option * string) list) * mixfix) list) list ) =
112.254 + let
112.255 + val specs : ((string * string option) list * binding * mixfix *
112.256 + (binding * (bool * binding option * string) list * mixfix) list) list =
112.257 + map (fn (((vs, t), mx), cons) =>
112.258 + (vs, t, mx, map (fn ((c, ds), mx) => (c, ds, mx)) cons)) doms;
112.259 + in
112.260 + if unsafe
112.261 + then add_domain_cmd specs
112.262 + else add_new_domain_cmd specs
112.263 + end;
112.264 +
112.265 +val _ =
112.266 + Outer_Syntax.command "domain" "define recursive domains (HOLCF)"
112.267 + Keyword.thy_decl (domains_decl >> (Toplevel.theory o mk_domain));
112.268 +
112.269 +end;
113.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
113.2 +++ b/src/HOL/HOLCF/Tools/Domain/domain_axioms.ML Sat Nov 27 16:08:10 2010 -0800
113.3 @@ -0,0 +1,138 @@
113.4 +(* Title: HOLCF/Tools/Domain/domain_axioms.ML
113.5 + Author: David von Oheimb
113.6 + Author: Brian Huffman
113.7 +
113.8 +Syntax generator for domain command.
113.9 +*)
113.10 +
113.11 +signature DOMAIN_AXIOMS =
113.12 +sig
113.13 + val axiomatize_isomorphism :
113.14 + binding * (typ * typ) ->
113.15 + theory -> Domain_Take_Proofs.iso_info * theory
113.16 +
113.17 + val axiomatize_lub_take :
113.18 + binding * term -> theory -> thm * theory
113.19 +
113.20 + val add_axioms :
113.21 + (binding * mixfix * (typ * typ)) list -> theory ->
113.22 + (Domain_Take_Proofs.iso_info list
113.23 + * Domain_Take_Proofs.take_induct_info) * theory
113.24 +end;
113.25 +
113.26 +
113.27 +structure Domain_Axioms : DOMAIN_AXIOMS =
113.28 +struct
113.29 +
113.30 +open HOLCF_Library;
113.31 +
113.32 +infixr 6 ->>;
113.33 +infix -->>;
113.34 +infix 9 `;
113.35 +
113.36 +fun axiomatize_isomorphism
113.37 + (dbind : binding, (lhsT, rhsT))
113.38 + (thy : theory)
113.39 + : Domain_Take_Proofs.iso_info * theory =
113.40 + let
113.41 + val abs_bind = Binding.suffix_name "_abs" dbind;
113.42 + val rep_bind = Binding.suffix_name "_rep" dbind;
113.43 +
113.44 + val (abs_const, thy) =
113.45 + Sign.declare_const ((abs_bind, rhsT ->> lhsT), NoSyn) thy;
113.46 + val (rep_const, thy) =
113.47 + Sign.declare_const ((rep_bind, lhsT ->> rhsT), NoSyn) thy;
113.48 +
113.49 + val x = Free ("x", lhsT);
113.50 + val y = Free ("y", rhsT);
113.51 +
113.52 + val abs_iso_eqn =
113.53 + Logic.all y (mk_trp (mk_eq (rep_const ` (abs_const ` y), y)));
113.54 + val rep_iso_eqn =
113.55 + Logic.all x (mk_trp (mk_eq (abs_const ` (rep_const ` x), x)));
113.56 +
113.57 + val abs_iso_bind = Binding.qualified true "abs_iso" dbind;
113.58 + val rep_iso_bind = Binding.qualified true "rep_iso" dbind;
113.59 +
113.60 + val (abs_iso_thm, thy) = Specification.axiom ((abs_iso_bind, []), abs_iso_eqn) thy;
113.61 + val (rep_iso_thm, thy) = Specification.axiom ((rep_iso_bind, []), rep_iso_eqn) thy;
113.62 +
113.63 + val result =
113.64 + {
113.65 + absT = lhsT,
113.66 + repT = rhsT,
113.67 + abs_const = abs_const,
113.68 + rep_const = rep_const,
113.69 + abs_inverse = Drule.export_without_context abs_iso_thm,
113.70 + rep_inverse = Drule.export_without_context rep_iso_thm
113.71 + };
113.72 + in
113.73 + (result, thy)
113.74 + end;
113.75 +
113.76 +fun axiomatize_lub_take
113.77 + (dbind : binding, take_const : term)
113.78 + (thy : theory)
113.79 + : thm * theory =
113.80 + let
113.81 + val i = Free ("i", natT);
113.82 + val T = (fst o dest_cfunT o range_type o fastype_of) take_const;
113.83 +
113.84 + val lub_take_eqn =
113.85 + mk_trp (mk_eq (mk_lub (lambda i (take_const $ i)), mk_ID T));
113.86 +
113.87 + val lub_take_bind = Binding.qualified true "lub_take" dbind;
113.88 +
113.89 + val (lub_take_thm, thy) = Specification.axiom ((lub_take_bind, []), lub_take_eqn) thy;
113.90 + in
113.91 + (lub_take_thm, thy)
113.92 + end;
113.93 +
113.94 +fun add_axioms
113.95 + (dom_eqns : (binding * mixfix * (typ * typ)) list)
113.96 + (thy : theory) =
113.97 + let
113.98 +
113.99 + val dbinds = map #1 dom_eqns;
113.100 +
113.101 + (* declare new types *)
113.102 + fun thy_type (dbind, mx, (lhsT, _)) =
113.103 + (dbind, (length o snd o dest_Type) lhsT, mx);
113.104 + val thy = Sign.add_types (map thy_type dom_eqns) thy;
113.105 +
113.106 + (* axiomatize type constructor arities *)
113.107 + fun thy_arity (_, _, (lhsT, _)) =
113.108 + let val (dname, tvars) = dest_Type lhsT;
113.109 + in (dname, map (snd o dest_TFree) tvars, @{sort pcpo}) end;
113.110 + val thy = fold (AxClass.axiomatize_arity o thy_arity) dom_eqns thy;
113.111 +
113.112 + (* declare and axiomatize abs/rep *)
113.113 + val (iso_infos, thy) =
113.114 + fold_map axiomatize_isomorphism
113.115 + (map (fn (dbind, _, eqn) => (dbind, eqn)) dom_eqns) thy;
113.116 +
113.117 + (* define take functions *)
113.118 + val (take_info, thy) =
113.119 + Domain_Take_Proofs.define_take_functions
113.120 + (dbinds ~~ iso_infos) thy;
113.121 +
113.122 + (* declare lub_take axioms *)
113.123 + val (lub_take_thms, thy) =
113.124 + fold_map axiomatize_lub_take
113.125 + (dbinds ~~ #take_consts take_info) thy;
113.126 +
113.127 + (* prove additional take theorems *)
113.128 + val (take_info2, thy) =
113.129 + Domain_Take_Proofs.add_lub_take_theorems
113.130 + (dbinds ~~ iso_infos) take_info lub_take_thms thy;
113.131 +
113.132 + (* define map functions *)
113.133 + val (map_info, thy) =
113.134 + Domain_Isomorphism.define_map_functions
113.135 + (dbinds ~~ iso_infos) thy;
113.136 +
113.137 + in
113.138 + ((iso_infos, take_info2), thy)
113.139 + end;
113.140 +
113.141 +end; (* struct *)
114.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
114.2 +++ b/src/HOL/HOLCF/Tools/Domain/domain_constructors.ML Sat Nov 27 16:08:10 2010 -0800
114.3 @@ -0,0 +1,975 @@
114.4 +(* Title: HOLCF/Tools/Domain/domain_constructors.ML
114.5 + Author: Brian Huffman
114.6 +
114.7 +Defines constructor functions for a given domain isomorphism
114.8 +and proves related theorems.
114.9 +*)
114.10 +
114.11 +signature DOMAIN_CONSTRUCTORS =
114.12 +sig
114.13 + type constr_info =
114.14 + {
114.15 + iso_info : Domain_Take_Proofs.iso_info,
114.16 + con_specs : (term * (bool * typ) list) list,
114.17 + con_betas : thm list,
114.18 + nchotomy : thm,
114.19 + exhaust : thm,
114.20 + compacts : thm list,
114.21 + con_rews : thm list,
114.22 + inverts : thm list,
114.23 + injects : thm list,
114.24 + dist_les : thm list,
114.25 + dist_eqs : thm list,
114.26 + cases : thm list,
114.27 + sel_rews : thm list,
114.28 + dis_rews : thm list,
114.29 + match_rews : thm list
114.30 + }
114.31 + val add_domain_constructors :
114.32 + binding
114.33 + -> (binding * (bool * binding option * typ) list * mixfix) list
114.34 + -> Domain_Take_Proofs.iso_info
114.35 + -> theory
114.36 + -> constr_info * theory;
114.37 +end;
114.38 +
114.39 +
114.40 +structure Domain_Constructors :> DOMAIN_CONSTRUCTORS =
114.41 +struct
114.42 +
114.43 +open HOLCF_Library;
114.44 +
114.45 +infixr 6 ->>;
114.46 +infix -->>;
114.47 +infix 9 `;
114.48 +
114.49 +type constr_info =
114.50 + {
114.51 + iso_info : Domain_Take_Proofs.iso_info,
114.52 + con_specs : (term * (bool * typ) list) list,
114.53 + con_betas : thm list,
114.54 + nchotomy : thm,
114.55 + exhaust : thm,
114.56 + compacts : thm list,
114.57 + con_rews : thm list,
114.58 + inverts : thm list,
114.59 + injects : thm list,
114.60 + dist_les : thm list,
114.61 + dist_eqs : thm list,
114.62 + cases : thm list,
114.63 + sel_rews : thm list,
114.64 + dis_rews : thm list,
114.65 + match_rews : thm list
114.66 + }
114.67 +
114.68 +(************************** miscellaneous functions ***************************)
114.69 +
114.70 +val simple_ss = HOL_basic_ss addsimps simp_thms;
114.71 +
114.72 +val beta_rules =
114.73 + @{thms beta_cfun cont_id cont_const cont2cont_APP cont2cont_LAM'} @
114.74 + @{thms cont2cont_fst cont2cont_snd cont2cont_Pair};
114.75 +
114.76 +val beta_ss = HOL_basic_ss addsimps (simp_thms @ beta_rules);
114.77 +
114.78 +fun define_consts
114.79 + (specs : (binding * term * mixfix) list)
114.80 + (thy : theory)
114.81 + : (term list * thm list) * theory =
114.82 + let
114.83 + fun mk_decl (b, t, mx) = (b, fastype_of t, mx);
114.84 + val decls = map mk_decl specs;
114.85 + val thy = Cont_Consts.add_consts decls thy;
114.86 + fun mk_const (b, T, mx) = Const (Sign.full_name thy b, T);
114.87 + val consts = map mk_const decls;
114.88 + fun mk_def c (b, t, mx) =
114.89 + (Binding.suffix_name "_def" b, Logic.mk_equals (c, t));
114.90 + val defs = map2 mk_def consts specs;
114.91 + val (def_thms, thy) =
114.92 + Global_Theory.add_defs false (map Thm.no_attributes defs) thy;
114.93 + in
114.94 + ((consts, def_thms), thy)
114.95 + end;
114.96 +
114.97 +fun prove
114.98 + (thy : theory)
114.99 + (defs : thm list)
114.100 + (goal : term)
114.101 + (tacs : {prems: thm list, context: Proof.context} -> tactic list)
114.102 + : thm =
114.103 + let
114.104 + fun tac {prems, context} =
114.105 + rewrite_goals_tac defs THEN
114.106 + EVERY (tacs {prems = map (rewrite_rule defs) prems, context = context})
114.107 + in
114.108 + Goal.prove_global thy [] [] goal tac
114.109 + end;
114.110 +
114.111 +fun get_vars_avoiding
114.112 + (taken : string list)
114.113 + (args : (bool * typ) list)
114.114 + : (term list * term list) =
114.115 + let
114.116 + val Ts = map snd args;
114.117 + val ns = Name.variant_list taken (Datatype_Prop.make_tnames Ts);
114.118 + val vs = map Free (ns ~~ Ts);
114.119 + val nonlazy = map snd (filter_out (fst o fst) (args ~~ vs));
114.120 + in
114.121 + (vs, nonlazy)
114.122 + end;
114.123 +
114.124 +fun get_vars args = get_vars_avoiding [] args;
114.125 +
114.126 +(************** generating beta reduction rules from definitions **************)
114.127 +
114.128 +local
114.129 + fun arglist (Const _ $ Abs (s, T, t)) =
114.130 + let
114.131 + val arg = Free (s, T);
114.132 + val (args, body) = arglist (subst_bound (arg, t));
114.133 + in (arg :: args, body) end
114.134 + | arglist t = ([], t);
114.135 +in
114.136 + fun beta_of_def thy def_thm =
114.137 + let
114.138 + val (con, lam) = Logic.dest_equals (concl_of def_thm);
114.139 + val (args, rhs) = arglist lam;
114.140 + val lhs = list_ccomb (con, args);
114.141 + val goal = mk_equals (lhs, rhs);
114.142 + val cs = ContProc.cont_thms lam;
114.143 + val betas = map (fn c => mk_meta_eq (c RS @{thm beta_cfun})) cs;
114.144 + in
114.145 + prove thy (def_thm::betas) goal (K [rtac reflexive_thm 1])
114.146 + end;
114.147 +end;
114.148 +
114.149 +(******************************************************************************)
114.150 +(************* definitions and theorems for constructor functions *************)
114.151 +(******************************************************************************)
114.152 +
114.153 +fun add_constructors
114.154 + (spec : (binding * (bool * typ) list * mixfix) list)
114.155 + (abs_const : term)
114.156 + (iso_locale : thm)
114.157 + (thy : theory)
114.158 + =
114.159 + let
114.160 +
114.161 + (* get theorems about rep and abs *)
114.162 + val abs_strict = iso_locale RS @{thm iso.abs_strict};
114.163 +
114.164 + (* get types of type isomorphism *)
114.165 + val (rhsT, lhsT) = dest_cfunT (fastype_of abs_const);
114.166 +
114.167 + fun vars_of args =
114.168 + let
114.169 + val Ts = map snd args;
114.170 + val ns = Datatype_Prop.make_tnames Ts;
114.171 + in
114.172 + map Free (ns ~~ Ts)
114.173 + end;
114.174 +
114.175 + (* define constructor functions *)
114.176 + val ((con_consts, con_defs), thy) =
114.177 + let
114.178 + fun one_arg (lazy, T) var = if lazy then mk_up var else var;
114.179 + fun one_con (_,args,_) = mk_stuple (map2 one_arg args (vars_of args));
114.180 + fun mk_abs t = abs_const ` t;
114.181 + val rhss = map mk_abs (mk_sinjects (map one_con spec));
114.182 + fun mk_def (bind, args, mx) rhs =
114.183 + (bind, big_lambdas (vars_of args) rhs, mx);
114.184 + in
114.185 + define_consts (map2 mk_def spec rhss) thy
114.186 + end;
114.187 +
114.188 + (* prove beta reduction rules for constructors *)
114.189 + val con_betas = map (beta_of_def thy) con_defs;
114.190 +
114.191 + (* replace bindings with terms in constructor spec *)
114.192 + val spec' : (term * (bool * typ) list) list =
114.193 + let fun one_con con (b, args, mx) = (con, args);
114.194 + in map2 one_con con_consts spec end;
114.195 +
114.196 + (* prove exhaustiveness of constructors *)
114.197 + local
114.198 + fun arg2typ n (true, T) = (n+1, mk_upT (TVar (("'a", n), @{sort cpo})))
114.199 + | arg2typ n (false, T) = (n+1, TVar (("'a", n), @{sort pcpo}));
114.200 + fun args2typ n [] = (n, oneT)
114.201 + | args2typ n [arg] = arg2typ n arg
114.202 + | args2typ n (arg::args) =
114.203 + let
114.204 + val (n1, t1) = arg2typ n arg;
114.205 + val (n2, t2) = args2typ n1 args
114.206 + in (n2, mk_sprodT (t1, t2)) end;
114.207 + fun cons2typ n [] = (n, oneT)
114.208 + | cons2typ n [con] = args2typ n (snd con)
114.209 + | cons2typ n (con::cons) =
114.210 + let
114.211 + val (n1, t1) = args2typ n (snd con);
114.212 + val (n2, t2) = cons2typ n1 cons
114.213 + in (n2, mk_ssumT (t1, t2)) end;
114.214 + val ct = ctyp_of thy (snd (cons2typ 1 spec'));
114.215 + val thm1 = instantiate' [SOME ct] [] @{thm exh_start};
114.216 + val thm2 = rewrite_rule (map mk_meta_eq @{thms ex_bottom_iffs}) thm1;
114.217 + val thm3 = rewrite_rule [mk_meta_eq @{thm conj_assoc}] thm2;
114.218 +
114.219 + val y = Free ("y", lhsT);
114.220 + fun one_con (con, args) =
114.221 + let
114.222 + val (vs, nonlazy) = get_vars_avoiding ["y"] args;
114.223 + val eqn = mk_eq (y, list_ccomb (con, vs));
114.224 + val conj = foldr1 mk_conj (eqn :: map mk_defined nonlazy);
114.225 + in Library.foldr mk_ex (vs, conj) end;
114.226 + val goal = mk_trp (foldr1 mk_disj (mk_undef y :: map one_con spec'));
114.227 + (* first rules replace "y = UU \/ P" with "rep$y = UU \/ P" *)
114.228 + val tacs = [
114.229 + rtac (iso_locale RS @{thm iso.casedist_rule}) 1,
114.230 + rewrite_goals_tac [mk_meta_eq (iso_locale RS @{thm iso.iso_swap})],
114.231 + rtac thm3 1];
114.232 + in
114.233 + val nchotomy = prove thy con_betas goal (K tacs);
114.234 + val exhaust =
114.235 + (nchotomy RS @{thm exh_casedist0})
114.236 + |> rewrite_rule @{thms exh_casedists}
114.237 + |> Drule.zero_var_indexes;
114.238 + end;
114.239 +
114.240 + (* prove compactness rules for constructors *)
114.241 + val compacts =
114.242 + let
114.243 + val rules = @{thms compact_sinl compact_sinr compact_spair
114.244 + compact_up compact_ONE};
114.245 + val tacs =
114.246 + [rtac (iso_locale RS @{thm iso.compact_abs}) 1,
114.247 + REPEAT (resolve_tac rules 1 ORELSE atac 1)];
114.248 + fun con_compact (con, args) =
114.249 + let
114.250 + val vs = vars_of args;
114.251 + val con_app = list_ccomb (con, vs);
114.252 + val concl = mk_trp (mk_compact con_app);
114.253 + val assms = map (mk_trp o mk_compact) vs;
114.254 + val goal = Logic.list_implies (assms, concl);
114.255 + in
114.256 + prove thy con_betas goal (K tacs)
114.257 + end;
114.258 + in
114.259 + map con_compact spec'
114.260 + end;
114.261 +
114.262 + (* prove strictness rules for constructors *)
114.263 + local
114.264 + fun con_strict (con, args) =
114.265 + let
114.266 + val rules = abs_strict :: @{thms con_strict_rules};
114.267 + val (vs, nonlazy) = get_vars args;
114.268 + fun one_strict v' =
114.269 + let
114.270 + val UU = mk_bottom (fastype_of v');
114.271 + val vs' = map (fn v => if v = v' then UU else v) vs;
114.272 + val goal = mk_trp (mk_undef (list_ccomb (con, vs')));
114.273 + val tacs = [simp_tac (HOL_basic_ss addsimps rules) 1];
114.274 + in prove thy con_betas goal (K tacs) end;
114.275 + in map one_strict nonlazy end;
114.276 +
114.277 + fun con_defin (con, args) =
114.278 + let
114.279 + fun iff_disj (t, []) = HOLogic.mk_not t
114.280 + | iff_disj (t, ts) = mk_eq (t, foldr1 HOLogic.mk_disj ts);
114.281 + val (vs, nonlazy) = get_vars args;
114.282 + val lhs = mk_undef (list_ccomb (con, vs));
114.283 + val rhss = map mk_undef nonlazy;
114.284 + val goal = mk_trp (iff_disj (lhs, rhss));
114.285 + val rule1 = iso_locale RS @{thm iso.abs_bottom_iff};
114.286 + val rules = rule1 :: @{thms con_bottom_iff_rules};
114.287 + val tacs = [simp_tac (HOL_ss addsimps rules) 1];
114.288 + in prove thy con_betas goal (K tacs) end;
114.289 + in
114.290 + val con_stricts = maps con_strict spec';
114.291 + val con_defins = map con_defin spec';
114.292 + val con_rews = con_stricts @ con_defins;
114.293 + end;
114.294 +
114.295 + (* prove injectiveness of constructors *)
114.296 + local
114.297 + fun pgterm rel (con, args) =
114.298 + let
114.299 + fun prime (Free (n, T)) = Free (n^"'", T)
114.300 + | prime t = t;
114.301 + val (xs, nonlazy) = get_vars args;
114.302 + val ys = map prime xs;
114.303 + val lhs = rel (list_ccomb (con, xs), list_ccomb (con, ys));
114.304 + val rhs = foldr1 mk_conj (ListPair.map rel (xs, ys));
114.305 + val concl = mk_trp (mk_eq (lhs, rhs));
114.306 + val zs = case args of [_] => [] | _ => nonlazy;
114.307 + val assms = map (mk_trp o mk_defined) zs;
114.308 + val goal = Logic.list_implies (assms, concl);
114.309 + in prove thy con_betas goal end;
114.310 + val cons' = filter (fn (_, args) => not (null args)) spec';
114.311 + in
114.312 + val inverts =
114.313 + let
114.314 + val abs_below = iso_locale RS @{thm iso.abs_below};
114.315 + val rules1 = abs_below :: @{thms sinl_below sinr_below spair_below up_below};
114.316 + val rules2 = @{thms up_defined spair_defined ONE_defined}
114.317 + val rules = rules1 @ rules2;
114.318 + val tacs = [asm_simp_tac (simple_ss addsimps rules) 1];
114.319 + in map (fn c => pgterm mk_below c (K tacs)) cons' end;
114.320 + val injects =
114.321 + let
114.322 + val abs_eq = iso_locale RS @{thm iso.abs_eq};
114.323 + val rules1 = abs_eq :: @{thms sinl_eq sinr_eq spair_eq up_eq};
114.324 + val rules2 = @{thms up_defined spair_defined ONE_defined}
114.325 + val rules = rules1 @ rules2;
114.326 + val tacs = [asm_simp_tac (simple_ss addsimps rules) 1];
114.327 + in map (fn c => pgterm mk_eq c (K tacs)) cons' end;
114.328 + end;
114.329 +
114.330 + (* prove distinctness of constructors *)
114.331 + local
114.332 + fun map_dist (f : 'a -> 'a -> 'b) (xs : 'a list) : 'b list =
114.333 + flat (map_index (fn (i, x) => map (f x) (nth_drop i xs)) xs);
114.334 + fun prime (Free (n, T)) = Free (n^"'", T)
114.335 + | prime t = t;
114.336 + fun iff_disj (t, []) = mk_not t
114.337 + | iff_disj (t, ts) = mk_eq (t, foldr1 mk_disj ts);
114.338 + fun iff_disj2 (t, [], us) = mk_not t
114.339 + | iff_disj2 (t, ts, []) = mk_not t
114.340 + | iff_disj2 (t, ts, us) =
114.341 + mk_eq (t, mk_conj (foldr1 mk_disj ts, foldr1 mk_disj us));
114.342 + fun dist_le (con1, args1) (con2, args2) =
114.343 + let
114.344 + val (vs1, zs1) = get_vars args1;
114.345 + val (vs2, zs2) = get_vars args2 |> pairself (map prime);
114.346 + val lhs = mk_below (list_ccomb (con1, vs1), list_ccomb (con2, vs2));
114.347 + val rhss = map mk_undef zs1;
114.348 + val goal = mk_trp (iff_disj (lhs, rhss));
114.349 + val rule1 = iso_locale RS @{thm iso.abs_below};
114.350 + val rules = rule1 :: @{thms con_below_iff_rules};
114.351 + val tacs = [simp_tac (HOL_ss addsimps rules) 1];
114.352 + in prove thy con_betas goal (K tacs) end;
114.353 + fun dist_eq (con1, args1) (con2, args2) =
114.354 + let
114.355 + val (vs1, zs1) = get_vars args1;
114.356 + val (vs2, zs2) = get_vars args2 |> pairself (map prime);
114.357 + val lhs = mk_eq (list_ccomb (con1, vs1), list_ccomb (con2, vs2));
114.358 + val rhss1 = map mk_undef zs1;
114.359 + val rhss2 = map mk_undef zs2;
114.360 + val goal = mk_trp (iff_disj2 (lhs, rhss1, rhss2));
114.361 + val rule1 = iso_locale RS @{thm iso.abs_eq};
114.362 + val rules = rule1 :: @{thms con_eq_iff_rules};
114.363 + val tacs = [simp_tac (HOL_ss addsimps rules) 1];
114.364 + in prove thy con_betas goal (K tacs) end;
114.365 + in
114.366 + val dist_les = map_dist dist_le spec';
114.367 + val dist_eqs = map_dist dist_eq spec';
114.368 + end;
114.369 +
114.370 + val result =
114.371 + {
114.372 + con_consts = con_consts,
114.373 + con_betas = con_betas,
114.374 + nchotomy = nchotomy,
114.375 + exhaust = exhaust,
114.376 + compacts = compacts,
114.377 + con_rews = con_rews,
114.378 + inverts = inverts,
114.379 + injects = injects,
114.380 + dist_les = dist_les,
114.381 + dist_eqs = dist_eqs
114.382 + };
114.383 + in
114.384 + (result, thy)
114.385 + end;
114.386 +
114.387 +(******************************************************************************)
114.388 +(**************** definition and theorems for case combinator *****************)
114.389 +(******************************************************************************)
114.390 +
114.391 +fun add_case_combinator
114.392 + (spec : (term * (bool * typ) list) list)
114.393 + (lhsT : typ)
114.394 + (dbind : binding)
114.395 + (con_betas : thm list)
114.396 + (exhaust : thm)
114.397 + (iso_locale : thm)
114.398 + (rep_const : term)
114.399 + (thy : theory)
114.400 + : ((typ -> term) * thm list) * theory =
114.401 + let
114.402 +
114.403 + (* prove rep/abs rules *)
114.404 + val rep_strict = iso_locale RS @{thm iso.rep_strict};
114.405 + val abs_inverse = iso_locale RS @{thm iso.abs_iso};
114.406 +
114.407 + (* calculate function arguments of case combinator *)
114.408 + val tns = map fst (Term.add_tfreesT lhsT []);
114.409 + val resultT = TFree (Name.variant tns "'t", @{sort pcpo});
114.410 + fun fTs T = map (fn (_, args) => map snd args -->> T) spec;
114.411 + val fns = Datatype_Prop.indexify_names (map (K "f") spec);
114.412 + val fs = map Free (fns ~~ fTs resultT);
114.413 + fun caseT T = fTs T -->> (lhsT ->> T);
114.414 +
114.415 + (* definition of case combinator *)
114.416 + local
114.417 + val case_bind = Binding.suffix_name "_case" dbind;
114.418 + fun lambda_arg (lazy, v) t =
114.419 + (if lazy then mk_fup else I) (big_lambda v t);
114.420 + fun lambda_args [] t = mk_one_case t
114.421 + | lambda_args (x::[]) t = lambda_arg x t
114.422 + | lambda_args (x::xs) t = mk_ssplit (lambda_arg x (lambda_args xs t));
114.423 + fun one_con f (_, args) =
114.424 + let
114.425 + val Ts = map snd args;
114.426 + val ns = Name.variant_list fns (Datatype_Prop.make_tnames Ts);
114.427 + val vs = map Free (ns ~~ Ts);
114.428 + in
114.429 + lambda_args (map fst args ~~ vs) (list_ccomb (f, vs))
114.430 + end;
114.431 + fun mk_sscases [t] = mk_strictify t
114.432 + | mk_sscases ts = foldr1 mk_sscase ts;
114.433 + val body = mk_sscases (map2 one_con fs spec);
114.434 + val rhs = big_lambdas fs (mk_cfcomp (body, rep_const));
114.435 + val ((case_consts, case_defs), thy) =
114.436 + define_consts [(case_bind, rhs, NoSyn)] thy;
114.437 + val case_name = Sign.full_name thy case_bind;
114.438 + in
114.439 + val case_def = hd case_defs;
114.440 + fun case_const T = Const (case_name, caseT T);
114.441 + val case_app = list_ccomb (case_const resultT, fs);
114.442 + val thy = thy;
114.443 + end;
114.444 +
114.445 + (* define syntax for case combinator *)
114.446 + (* TODO: re-implement case syntax using a parse translation *)
114.447 + local
114.448 + open Syntax
114.449 + fun syntax c = Syntax.mark_const (fst (dest_Const c));
114.450 + fun xconst c = Long_Name.base_name (fst (dest_Const c));
114.451 + fun c_ast authentic con =
114.452 + Constant (if authentic then syntax con else xconst con);
114.453 + fun showint n = string_of_int (n+1);
114.454 + fun expvar n = Variable ("e" ^ showint n);
114.455 + fun argvar n (m, _) = Variable ("a" ^ showint n ^ "_" ^ showint m);
114.456 + fun argvars n args = map_index (argvar n) args;
114.457 + fun app s (l, r) = mk_appl (Constant s) [l, r];
114.458 + val cabs = app "_cabs";
114.459 + val capp = app @{const_syntax Rep_cfun};
114.460 + val capps = Library.foldl capp
114.461 + fun con1 authentic n (con,args) =
114.462 + Library.foldl capp (c_ast authentic con, argvars n args);
114.463 + fun case1 authentic (n, c) =
114.464 + app "_case1" (con1 authentic n c, expvar n);
114.465 + fun arg1 (n, (con,args)) = List.foldr cabs (expvar n) (argvars n args);
114.466 + fun when1 n (m, c) =
114.467 + if n = m then arg1 (n, c) else (Constant @{const_syntax UU});
114.468 + val case_constant = Constant (syntax (case_const dummyT));
114.469 + fun case_trans authentic =
114.470 + ParsePrintRule
114.471 + (app "_case_syntax"
114.472 + (Variable "x",
114.473 + foldr1 (app "_case2") (map_index (case1 authentic) spec)),
114.474 + capp (capps (case_constant, map_index arg1 spec), Variable "x"));
114.475 + fun one_abscon_trans authentic (n, c) =
114.476 + ParsePrintRule
114.477 + (cabs (con1 authentic n c, expvar n),
114.478 + capps (case_constant, map_index (when1 n) spec));
114.479 + fun abscon_trans authentic =
114.480 + map_index (one_abscon_trans authentic) spec;
114.481 + val trans_rules : ast Syntax.trrule list =
114.482 + case_trans false :: case_trans true ::
114.483 + abscon_trans false @ abscon_trans true;
114.484 + in
114.485 + val thy = Sign.add_trrules_i trans_rules thy;
114.486 + end;
114.487 +
114.488 + (* prove beta reduction rule for case combinator *)
114.489 + val case_beta = beta_of_def thy case_def;
114.490 +
114.491 + (* prove strictness of case combinator *)
114.492 + val case_strict =
114.493 + let
114.494 + val defs = case_beta :: map mk_meta_eq [rep_strict, @{thm cfcomp2}];
114.495 + val goal = mk_trp (mk_strict case_app);
114.496 + val rules = @{thms sscase1 ssplit1 strictify1 one_case1};
114.497 + val tacs = [resolve_tac rules 1];
114.498 + in prove thy defs goal (K tacs) end;
114.499 +
114.500 + (* prove rewrites for case combinator *)
114.501 + local
114.502 + fun one_case (con, args) f =
114.503 + let
114.504 + val (vs, nonlazy) = get_vars args;
114.505 + val assms = map (mk_trp o mk_defined) nonlazy;
114.506 + val lhs = case_app ` list_ccomb (con, vs);
114.507 + val rhs = list_ccomb (f, vs);
114.508 + val concl = mk_trp (mk_eq (lhs, rhs));
114.509 + val goal = Logic.list_implies (assms, concl);
114.510 + val defs = case_beta :: con_betas;
114.511 + val rules1 = @{thms strictify2 sscase2 sscase3 ssplit2 fup2 ID1};
114.512 + val rules2 = @{thms con_bottom_iff_rules};
114.513 + val rules3 = @{thms cfcomp2 one_case2};
114.514 + val rules = abs_inverse :: rules1 @ rules2 @ rules3;
114.515 + val tacs = [asm_simp_tac (beta_ss addsimps rules) 1];
114.516 + in prove thy defs goal (K tacs) end;
114.517 + in
114.518 + val case_apps = map2 one_case spec fs;
114.519 + end
114.520 +
114.521 + in
114.522 + ((case_const, case_strict :: case_apps), thy)
114.523 + end
114.524 +
114.525 +(******************************************************************************)
114.526 +(************** definitions and theorems for selector functions ***************)
114.527 +(******************************************************************************)
114.528 +
114.529 +fun add_selectors
114.530 + (spec : (term * (bool * binding option * typ) list) list)
114.531 + (rep_const : term)
114.532 + (abs_inv : thm)
114.533 + (rep_strict : thm)
114.534 + (rep_bottom_iff : thm)
114.535 + (con_betas : thm list)
114.536 + (thy : theory)
114.537 + : thm list * theory =
114.538 + let
114.539 +
114.540 + (* define selector functions *)
114.541 + val ((sel_consts, sel_defs), thy) =
114.542 + let
114.543 + fun rangeT s = snd (dest_cfunT (fastype_of s));
114.544 + fun mk_outl s = mk_cfcomp (from_sinl (dest_ssumT (rangeT s)), s);
114.545 + fun mk_outr s = mk_cfcomp (from_sinr (dest_ssumT (rangeT s)), s);
114.546 + fun mk_sfst s = mk_cfcomp (sfst_const (dest_sprodT (rangeT s)), s);
114.547 + fun mk_ssnd s = mk_cfcomp (ssnd_const (dest_sprodT (rangeT s)), s);
114.548 + fun mk_down s = mk_cfcomp (from_up (dest_upT (rangeT s)), s);
114.549 +
114.550 + fun sels_of_arg s (lazy, NONE, T) = []
114.551 + | sels_of_arg s (lazy, SOME b, T) =
114.552 + [(b, if lazy then mk_down s else s, NoSyn)];
114.553 + fun sels_of_args s [] = []
114.554 + | sels_of_args s (v :: []) = sels_of_arg s v
114.555 + | sels_of_args s (v :: vs) =
114.556 + sels_of_arg (mk_sfst s) v @ sels_of_args (mk_ssnd s) vs;
114.557 + fun sels_of_cons s [] = []
114.558 + | sels_of_cons s ((con, args) :: []) = sels_of_args s args
114.559 + | sels_of_cons s ((con, args) :: cs) =
114.560 + sels_of_args (mk_outl s) args @ sels_of_cons (mk_outr s) cs;
114.561 + val sel_eqns : (binding * term * mixfix) list =
114.562 + sels_of_cons rep_const spec;
114.563 + in
114.564 + define_consts sel_eqns thy
114.565 + end
114.566 +
114.567 + (* replace bindings with terms in constructor spec *)
114.568 + val spec2 : (term * (bool * term option * typ) list) list =
114.569 + let
114.570 + fun prep_arg (lazy, NONE, T) sels = ((lazy, NONE, T), sels)
114.571 + | prep_arg (lazy, SOME _, T) sels =
114.572 + ((lazy, SOME (hd sels), T), tl sels);
114.573 + fun prep_con (con, args) sels =
114.574 + apfst (pair con) (fold_map prep_arg args sels);
114.575 + in
114.576 + fst (fold_map prep_con spec sel_consts)
114.577 + end;
114.578 +
114.579 + (* prove selector strictness rules *)
114.580 + val sel_stricts : thm list =
114.581 + let
114.582 + val rules = rep_strict :: @{thms sel_strict_rules};
114.583 + val tacs = [simp_tac (HOL_basic_ss addsimps rules) 1];
114.584 + fun sel_strict sel =
114.585 + let
114.586 + val goal = mk_trp (mk_strict sel);
114.587 + in
114.588 + prove thy sel_defs goal (K tacs)
114.589 + end
114.590 + in
114.591 + map sel_strict sel_consts
114.592 + end
114.593 +
114.594 + (* prove selector application rules *)
114.595 + val sel_apps : thm list =
114.596 + let
114.597 + val defs = con_betas @ sel_defs;
114.598 + val rules = abs_inv :: @{thms sel_app_rules};
114.599 + val tacs = [asm_simp_tac (simple_ss addsimps rules) 1];
114.600 + fun sel_apps_of (i, (con, args: (bool * term option * typ) list)) =
114.601 + let
114.602 + val Ts : typ list = map #3 args;
114.603 + val ns : string list = Datatype_Prop.make_tnames Ts;
114.604 + val vs : term list = map Free (ns ~~ Ts);
114.605 + val con_app : term = list_ccomb (con, vs);
114.606 + val vs' : (bool * term) list = map #1 args ~~ vs;
114.607 + fun one_same (n, sel, T) =
114.608 + let
114.609 + val xs = map snd (filter_out fst (nth_drop n vs'));
114.610 + val assms = map (mk_trp o mk_defined) xs;
114.611 + val concl = mk_trp (mk_eq (sel ` con_app, nth vs n));
114.612 + val goal = Logic.list_implies (assms, concl);
114.613 + in
114.614 + prove thy defs goal (K tacs)
114.615 + end;
114.616 + fun one_diff (n, sel, T) =
114.617 + let
114.618 + val goal = mk_trp (mk_eq (sel ` con_app, mk_bottom T));
114.619 + in
114.620 + prove thy defs goal (K tacs)
114.621 + end;
114.622 + fun one_con (j, (_, args')) : thm list =
114.623 + let
114.624 + fun prep (i, (lazy, NONE, T)) = NONE
114.625 + | prep (i, (lazy, SOME sel, T)) = SOME (i, sel, T);
114.626 + val sels : (int * term * typ) list =
114.627 + map_filter prep (map_index I args');
114.628 + in
114.629 + if i = j
114.630 + then map one_same sels
114.631 + else map one_diff sels
114.632 + end
114.633 + in
114.634 + flat (map_index one_con spec2)
114.635 + end
114.636 + in
114.637 + flat (map_index sel_apps_of spec2)
114.638 + end
114.639 +
114.640 + (* prove selector definedness rules *)
114.641 + val sel_defins : thm list =
114.642 + let
114.643 + val rules = rep_bottom_iff :: @{thms sel_bottom_iff_rules};
114.644 + val tacs = [simp_tac (HOL_basic_ss addsimps rules) 1];
114.645 + fun sel_defin sel =
114.646 + let
114.647 + val (T, U) = dest_cfunT (fastype_of sel);
114.648 + val x = Free ("x", T);
114.649 + val lhs = mk_eq (sel ` x, mk_bottom U);
114.650 + val rhs = mk_eq (x, mk_bottom T);
114.651 + val goal = mk_trp (mk_eq (lhs, rhs));
114.652 + in
114.653 + prove thy sel_defs goal (K tacs)
114.654 + end
114.655 + fun one_arg (false, SOME sel, T) = SOME (sel_defin sel)
114.656 + | one_arg _ = NONE;
114.657 + in
114.658 + case spec2 of
114.659 + [(con, args)] => map_filter one_arg args
114.660 + | _ => []
114.661 + end;
114.662 +
114.663 + in
114.664 + (sel_stricts @ sel_defins @ sel_apps, thy)
114.665 + end
114.666 +
114.667 +(******************************************************************************)
114.668 +(************ definitions and theorems for discriminator functions ************)
114.669 +(******************************************************************************)
114.670 +
114.671 +fun add_discriminators
114.672 + (bindings : binding list)
114.673 + (spec : (term * (bool * typ) list) list)
114.674 + (lhsT : typ)
114.675 + (exhaust : thm)
114.676 + (case_const : typ -> term)
114.677 + (case_rews : thm list)
114.678 + (thy : theory) =
114.679 + let
114.680 +
114.681 + fun vars_of args =
114.682 + let
114.683 + val Ts = map snd args;
114.684 + val ns = Datatype_Prop.make_tnames Ts;
114.685 + in
114.686 + map Free (ns ~~ Ts)
114.687 + end;
114.688 +
114.689 + (* define discriminator functions *)
114.690 + local
114.691 + fun dis_fun i (j, (con, args)) =
114.692 + let
114.693 + val (vs, nonlazy) = get_vars args;
114.694 + val tr = if i = j then @{term TT} else @{term FF};
114.695 + in
114.696 + big_lambdas vs tr
114.697 + end;
114.698 + fun dis_eqn (i, bind) : binding * term * mixfix =
114.699 + let
114.700 + val dis_bind = Binding.prefix_name "is_" bind;
114.701 + val rhs = list_ccomb (case_const trT, map_index (dis_fun i) spec);
114.702 + in
114.703 + (dis_bind, rhs, NoSyn)
114.704 + end;
114.705 + in
114.706 + val ((dis_consts, dis_defs), thy) =
114.707 + define_consts (map_index dis_eqn bindings) thy
114.708 + end;
114.709 +
114.710 + (* prove discriminator strictness rules *)
114.711 + local
114.712 + fun dis_strict dis =
114.713 + let val goal = mk_trp (mk_strict dis);
114.714 + in prove thy dis_defs goal (K [rtac (hd case_rews) 1]) end;
114.715 + in
114.716 + val dis_stricts = map dis_strict dis_consts;
114.717 + end;
114.718 +
114.719 + (* prove discriminator/constructor rules *)
114.720 + local
114.721 + fun dis_app (i, dis) (j, (con, args)) =
114.722 + let
114.723 + val (vs, nonlazy) = get_vars args;
114.724 + val lhs = dis ` list_ccomb (con, vs);
114.725 + val rhs = if i = j then @{term TT} else @{term FF};
114.726 + val assms = map (mk_trp o mk_defined) nonlazy;
114.727 + val concl = mk_trp (mk_eq (lhs, rhs));
114.728 + val goal = Logic.list_implies (assms, concl);
114.729 + val tacs = [asm_simp_tac (beta_ss addsimps case_rews) 1];
114.730 + in prove thy dis_defs goal (K tacs) end;
114.731 + fun one_dis (i, dis) =
114.732 + map_index (dis_app (i, dis)) spec;
114.733 + in
114.734 + val dis_apps = flat (map_index one_dis dis_consts);
114.735 + end;
114.736 +
114.737 + (* prove discriminator definedness rules *)
114.738 + local
114.739 + fun dis_defin dis =
114.740 + let
114.741 + val x = Free ("x", lhsT);
114.742 + val simps = dis_apps @ @{thms dist_eq_tr};
114.743 + val tacs =
114.744 + [rtac @{thm iffI} 1,
114.745 + asm_simp_tac (HOL_basic_ss addsimps dis_stricts) 2,
114.746 + rtac exhaust 1, atac 1,
114.747 + DETERM_UNTIL_SOLVED (CHANGED
114.748 + (asm_full_simp_tac (simple_ss addsimps simps) 1))];
114.749 + val goal = mk_trp (mk_eq (mk_undef (dis ` x), mk_undef x));
114.750 + in prove thy [] goal (K tacs) end;
114.751 + in
114.752 + val dis_defins = map dis_defin dis_consts;
114.753 + end;
114.754 +
114.755 + in
114.756 + (dis_stricts @ dis_defins @ dis_apps, thy)
114.757 + end;
114.758 +
114.759 +(******************************************************************************)
114.760 +(*************** definitions and theorems for match combinators ***************)
114.761 +(******************************************************************************)
114.762 +
114.763 +fun add_match_combinators
114.764 + (bindings : binding list)
114.765 + (spec : (term * (bool * typ) list) list)
114.766 + (lhsT : typ)
114.767 + (exhaust : thm)
114.768 + (case_const : typ -> term)
114.769 + (case_rews : thm list)
114.770 + (thy : theory) =
114.771 + let
114.772 +
114.773 + (* get a fresh type variable for the result type *)
114.774 + val resultT : typ =
114.775 + let
114.776 + val ts : string list = map fst (Term.add_tfreesT lhsT []);
114.777 + val t : string = Name.variant ts "'t";
114.778 + in TFree (t, @{sort pcpo}) end;
114.779 +
114.780 + (* define match combinators *)
114.781 + local
114.782 + val x = Free ("x", lhsT);
114.783 + fun k args = Free ("k", map snd args -->> mk_matchT resultT);
114.784 + val fail = mk_fail resultT;
114.785 + fun mat_fun i (j, (con, args)) =
114.786 + let
114.787 + val (vs, nonlazy) = get_vars_avoiding ["x","k"] args;
114.788 + in
114.789 + if i = j then k args else big_lambdas vs fail
114.790 + end;
114.791 + fun mat_eqn (i, (bind, (con, args))) : binding * term * mixfix =
114.792 + let
114.793 + val mat_bind = Binding.prefix_name "match_" bind;
114.794 + val funs = map_index (mat_fun i) spec
114.795 + val body = list_ccomb (case_const (mk_matchT resultT), funs);
114.796 + val rhs = big_lambda x (big_lambda (k args) (body ` x));
114.797 + in
114.798 + (mat_bind, rhs, NoSyn)
114.799 + end;
114.800 + in
114.801 + val ((match_consts, match_defs), thy) =
114.802 + define_consts (map_index mat_eqn (bindings ~~ spec)) thy
114.803 + end;
114.804 +
114.805 + (* register match combinators with fixrec package *)
114.806 + local
114.807 + val con_names = map (fst o dest_Const o fst) spec;
114.808 + val mat_names = map (fst o dest_Const) match_consts;
114.809 + in
114.810 + val thy = Fixrec.add_matchers (con_names ~~ mat_names) thy;
114.811 + end;
114.812 +
114.813 + (* prove strictness of match combinators *)
114.814 + local
114.815 + fun match_strict mat =
114.816 + let
114.817 + val (T, (U, V)) = apsnd dest_cfunT (dest_cfunT (fastype_of mat));
114.818 + val k = Free ("k", U);
114.819 + val goal = mk_trp (mk_eq (mat ` mk_bottom T ` k, mk_bottom V));
114.820 + val tacs = [asm_simp_tac (beta_ss addsimps case_rews) 1];
114.821 + in prove thy match_defs goal (K tacs) end;
114.822 + in
114.823 + val match_stricts = map match_strict match_consts;
114.824 + end;
114.825 +
114.826 + (* prove match/constructor rules *)
114.827 + local
114.828 + val fail = mk_fail resultT;
114.829 + fun match_app (i, mat) (j, (con, args)) =
114.830 + let
114.831 + val (vs, nonlazy) = get_vars_avoiding ["k"] args;
114.832 + val (_, (kT, _)) = apsnd dest_cfunT (dest_cfunT (fastype_of mat));
114.833 + val k = Free ("k", kT);
114.834 + val lhs = mat ` list_ccomb (con, vs) ` k;
114.835 + val rhs = if i = j then list_ccomb (k, vs) else fail;
114.836 + val assms = map (mk_trp o mk_defined) nonlazy;
114.837 + val concl = mk_trp (mk_eq (lhs, rhs));
114.838 + val goal = Logic.list_implies (assms, concl);
114.839 + val tacs = [asm_simp_tac (beta_ss addsimps case_rews) 1];
114.840 + in prove thy match_defs goal (K tacs) end;
114.841 + fun one_match (i, mat) =
114.842 + map_index (match_app (i, mat)) spec;
114.843 + in
114.844 + val match_apps = flat (map_index one_match match_consts);
114.845 + end;
114.846 +
114.847 + in
114.848 + (match_stricts @ match_apps, thy)
114.849 + end;
114.850 +
114.851 +(******************************************************************************)
114.852 +(******************************* main function ********************************)
114.853 +(******************************************************************************)
114.854 +
114.855 +fun add_domain_constructors
114.856 + (dbind : binding)
114.857 + (spec : (binding * (bool * binding option * typ) list * mixfix) list)
114.858 + (iso_info : Domain_Take_Proofs.iso_info)
114.859 + (thy : theory) =
114.860 + let
114.861 + val dname = Binding.name_of dbind;
114.862 + val _ = writeln ("Proving isomorphism properties of domain "^dname^" ...");
114.863 +
114.864 + val bindings = map #1 spec;
114.865 +
114.866 + (* retrieve facts about rep/abs *)
114.867 + val lhsT = #absT iso_info;
114.868 + val {rep_const, abs_const, ...} = iso_info;
114.869 + val abs_iso_thm = #abs_inverse iso_info;
114.870 + val rep_iso_thm = #rep_inverse iso_info;
114.871 + val iso_locale = @{thm iso.intro} OF [abs_iso_thm, rep_iso_thm];
114.872 + val rep_strict = iso_locale RS @{thm iso.rep_strict};
114.873 + val abs_strict = iso_locale RS @{thm iso.abs_strict};
114.874 + val rep_bottom_iff = iso_locale RS @{thm iso.rep_bottom_iff};
114.875 + val abs_bottom_iff = iso_locale RS @{thm iso.abs_bottom_iff};
114.876 + val iso_rews = [abs_iso_thm, rep_iso_thm, abs_strict, rep_strict];
114.877 +
114.878 + (* qualify constants and theorems with domain name *)
114.879 + val thy = Sign.add_path dname thy;
114.880 +
114.881 + (* define constructor functions *)
114.882 + val (con_result, thy) =
114.883 + let
114.884 + fun prep_arg (lazy, sel, T) = (lazy, T);
114.885 + fun prep_con (b, args, mx) = (b, map prep_arg args, mx);
114.886 + val con_spec = map prep_con spec;
114.887 + in
114.888 + add_constructors con_spec abs_const iso_locale thy
114.889 + end;
114.890 + val {con_consts, con_betas, nchotomy, exhaust, compacts, con_rews,
114.891 + inverts, injects, dist_les, dist_eqs} = con_result;
114.892 +
114.893 + (* prepare constructor spec *)
114.894 + val con_specs : (term * (bool * typ) list) list =
114.895 + let
114.896 + fun prep_arg (lazy, sel, T) = (lazy, T);
114.897 + fun prep_con c (b, args, mx) = (c, map prep_arg args);
114.898 + in
114.899 + map2 prep_con con_consts spec
114.900 + end;
114.901 +
114.902 + (* define case combinator *)
114.903 + val ((case_const : typ -> term, cases : thm list), thy) =
114.904 + add_case_combinator con_specs lhsT dbind
114.905 + con_betas exhaust iso_locale rep_const thy
114.906 +
114.907 + (* define and prove theorems for selector functions *)
114.908 + val (sel_thms : thm list, thy : theory) =
114.909 + let
114.910 + val sel_spec : (term * (bool * binding option * typ) list) list =
114.911 + map2 (fn con => fn (b, args, mx) => (con, args)) con_consts spec;
114.912 + in
114.913 + add_selectors sel_spec rep_const
114.914 + abs_iso_thm rep_strict rep_bottom_iff con_betas thy
114.915 + end;
114.916 +
114.917 + (* define and prove theorems for discriminator functions *)
114.918 + val (dis_thms : thm list, thy : theory) =
114.919 + add_discriminators bindings con_specs lhsT
114.920 + exhaust case_const cases thy;
114.921 +
114.922 + (* define and prove theorems for match combinators *)
114.923 + val (match_thms : thm list, thy : theory) =
114.924 + add_match_combinators bindings con_specs lhsT
114.925 + exhaust case_const cases thy;
114.926 +
114.927 + (* restore original signature path *)
114.928 + val thy = Sign.parent_path thy;
114.929 +
114.930 + (* bind theorem names in global theory *)
114.931 + val (_, thy) =
114.932 + let
114.933 + fun qualified name = Binding.qualified true name dbind;
114.934 + val names = "bottom" :: map (fn (b,_,_) => Binding.name_of b) spec;
114.935 + val dname = fst (dest_Type lhsT);
114.936 + val simp = Simplifier.simp_add;
114.937 + val case_names = Rule_Cases.case_names names;
114.938 + val cases_type = Induct.cases_type dname;
114.939 + in
114.940 + Global_Theory.add_thmss [
114.941 + ((qualified "iso_rews" , iso_rews ), [simp]),
114.942 + ((qualified "nchotomy" , [nchotomy] ), []),
114.943 + ((qualified "exhaust" , [exhaust] ), [case_names, cases_type]),
114.944 + ((qualified "case_rews" , cases ), [simp]),
114.945 + ((qualified "compacts" , compacts ), [simp]),
114.946 + ((qualified "con_rews" , con_rews ), [simp]),
114.947 + ((qualified "sel_rews" , sel_thms ), [simp]),
114.948 + ((qualified "dis_rews" , dis_thms ), [simp]),
114.949 + ((qualified "dist_les" , dist_les ), [simp]),
114.950 + ((qualified "dist_eqs" , dist_eqs ), [simp]),
114.951 + ((qualified "inverts" , inverts ), [simp]),
114.952 + ((qualified "injects" , injects ), [simp]),
114.953 + ((qualified "match_rews", match_thms ), [simp])] thy
114.954 + end;
114.955 +
114.956 + val result =
114.957 + {
114.958 + iso_info = iso_info,
114.959 + con_specs = con_specs,
114.960 + con_betas = con_betas,
114.961 + nchotomy = nchotomy,
114.962 + exhaust = exhaust,
114.963 + compacts = compacts,
114.964 + con_rews = con_rews,
114.965 + inverts = inverts,
114.966 + injects = injects,
114.967 + dist_les = dist_les,
114.968 + dist_eqs = dist_eqs,
114.969 + cases = cases,
114.970 + sel_rews = sel_thms,
114.971 + dis_rews = dis_thms,
114.972 + match_rews = match_thms
114.973 + };
114.974 + in
114.975 + (result, thy)
114.976 + end;
114.977 +
114.978 +end;
115.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
115.2 +++ b/src/HOL/HOLCF/Tools/Domain/domain_induction.ML Sat Nov 27 16:08:10 2010 -0800
115.3 @@ -0,0 +1,439 @@
115.4 +(* Title: HOLCF/Tools/Domain/domain_induction.ML
115.5 + Author: David von Oheimb
115.6 + Author: Brian Huffman
115.7 +
115.8 +Proofs of high-level (co)induction rules for domain command.
115.9 +*)
115.10 +
115.11 +signature DOMAIN_INDUCTION =
115.12 +sig
115.13 + val comp_theorems :
115.14 + binding list ->
115.15 + Domain_Take_Proofs.take_induct_info ->
115.16 + Domain_Constructors.constr_info list ->
115.17 + theory -> thm list * theory
115.18 +
115.19 + val quiet_mode: bool Unsynchronized.ref;
115.20 + val trace_domain: bool Unsynchronized.ref;
115.21 +end;
115.22 +
115.23 +structure Domain_Induction :> DOMAIN_INDUCTION =
115.24 +struct
115.25 +
115.26 +val quiet_mode = Unsynchronized.ref false;
115.27 +val trace_domain = Unsynchronized.ref false;
115.28 +
115.29 +fun message s = if !quiet_mode then () else writeln s;
115.30 +fun trace s = if !trace_domain then tracing s else ();
115.31 +
115.32 +open HOLCF_Library;
115.33 +
115.34 +(******************************************************************************)
115.35 +(***************************** proofs about take ******************************)
115.36 +(******************************************************************************)
115.37 +
115.38 +fun take_theorems
115.39 + (dbinds : binding list)
115.40 + (take_info : Domain_Take_Proofs.take_induct_info)
115.41 + (constr_infos : Domain_Constructors.constr_info list)
115.42 + (thy : theory) : thm list list * theory =
115.43 +let
115.44 + val {take_consts, take_Suc_thms, deflation_take_thms, ...} = take_info;
115.45 + val deflation_thms = Domain_Take_Proofs.get_deflation_thms thy;
115.46 +
115.47 + val n = Free ("n", @{typ nat});
115.48 + val n' = @{const Suc} $ n;
115.49 +
115.50 + local
115.51 + val newTs = map (#absT o #iso_info) constr_infos;
115.52 + val subs = newTs ~~ map (fn t => t $ n) take_consts;
115.53 + fun is_ID (Const (c, _)) = (c = @{const_name ID})
115.54 + | is_ID _ = false;
115.55 + in
115.56 + fun map_of_arg thy v T =
115.57 + let val m = Domain_Take_Proofs.map_of_typ thy subs T;
115.58 + in if is_ID m then v else mk_capply (m, v) end;
115.59 + end
115.60 +
115.61 + fun prove_take_apps
115.62 + ((dbind, take_const), constr_info) thy =
115.63 + let
115.64 + val {iso_info, con_specs, con_betas, ...} = constr_info;
115.65 + val {abs_inverse, ...} = iso_info;
115.66 + fun prove_take_app (con_const, args) =
115.67 + let
115.68 + val Ts = map snd args;
115.69 + val ns = Name.variant_list ["n"] (Datatype_Prop.make_tnames Ts);
115.70 + val vs = map Free (ns ~~ Ts);
115.71 + val lhs = mk_capply (take_const $ n', list_ccomb (con_const, vs));
115.72 + val rhs = list_ccomb (con_const, map2 (map_of_arg thy) vs Ts);
115.73 + val goal = mk_trp (mk_eq (lhs, rhs));
115.74 + val rules =
115.75 + [abs_inverse] @ con_betas @ @{thms take_con_rules}
115.76 + @ take_Suc_thms @ deflation_thms @ deflation_take_thms;
115.77 + val tac = simp_tac (HOL_basic_ss addsimps rules) 1;
115.78 + in
115.79 + Goal.prove_global thy [] [] goal (K tac)
115.80 + end;
115.81 + val take_apps = map prove_take_app con_specs;
115.82 + in
115.83 + yield_singleton Global_Theory.add_thmss
115.84 + ((Binding.qualified true "take_rews" dbind, take_apps),
115.85 + [Simplifier.simp_add]) thy
115.86 + end;
115.87 +in
115.88 + fold_map prove_take_apps
115.89 + (dbinds ~~ take_consts ~~ constr_infos) thy
115.90 +end;
115.91 +
115.92 +(******************************************************************************)
115.93 +(****************************** induction rules *******************************)
115.94 +(******************************************************************************)
115.95 +
115.96 +val case_UU_allI =
115.97 + @{lemma "(!!x. x ~= UU ==> P x) ==> P UU ==> ALL x. P x" by metis};
115.98 +
115.99 +fun prove_induction
115.100 + (comp_dbind : binding)
115.101 + (constr_infos : Domain_Constructors.constr_info list)
115.102 + (take_info : Domain_Take_Proofs.take_induct_info)
115.103 + (take_rews : thm list)
115.104 + (thy : theory) =
115.105 +let
115.106 + val comp_dname = Binding.name_of comp_dbind;
115.107 +
115.108 + val iso_infos = map #iso_info constr_infos;
115.109 + val exhausts = map #exhaust constr_infos;
115.110 + val con_rews = maps #con_rews constr_infos;
115.111 + val {take_consts, take_induct_thms, ...} = take_info;
115.112 +
115.113 + val newTs = map #absT iso_infos;
115.114 + val P_names = Datatype_Prop.indexify_names (map (K "P") newTs);
115.115 + val x_names = Datatype_Prop.indexify_names (map (K "x") newTs);
115.116 + val P_types = map (fn T => T --> HOLogic.boolT) newTs;
115.117 + val Ps = map Free (P_names ~~ P_types);
115.118 + val xs = map Free (x_names ~~ newTs);
115.119 + val n = Free ("n", HOLogic.natT);
115.120 +
115.121 + fun con_assm defined p (con, args) =
115.122 + let
115.123 + val Ts = map snd args;
115.124 + val ns = Name.variant_list P_names (Datatype_Prop.make_tnames Ts);
115.125 + val vs = map Free (ns ~~ Ts);
115.126 + val nonlazy = map snd (filter_out (fst o fst) (args ~~ vs));
115.127 + fun ind_hyp (v, T) t =
115.128 + case AList.lookup (op =) (newTs ~~ Ps) T of NONE => t
115.129 + | SOME p' => Logic.mk_implies (mk_trp (p' $ v), t);
115.130 + val t1 = mk_trp (p $ list_ccomb (con, vs));
115.131 + val t2 = fold_rev ind_hyp (vs ~~ Ts) t1;
115.132 + val t3 = Logic.list_implies (map (mk_trp o mk_defined) nonlazy, t2);
115.133 + in fold_rev Logic.all vs (if defined then t3 else t2) end;
115.134 + fun eq_assms ((p, T), cons) =
115.135 + mk_trp (p $ HOLCF_Library.mk_bottom T) :: map (con_assm true p) cons;
115.136 + val assms = maps eq_assms (Ps ~~ newTs ~~ map #con_specs constr_infos);
115.137 +
115.138 + val take_ss = HOL_ss addsimps (@{thm Rep_cfun_strict1} :: take_rews);
115.139 + fun quant_tac ctxt i = EVERY
115.140 + (map (fn name => res_inst_tac ctxt [(("x", 0), name)] spec i) x_names);
115.141 +
115.142 + (* FIXME: move this message to domain_take_proofs.ML *)
115.143 + val is_finite = #is_finite take_info;
115.144 + val _ = if is_finite
115.145 + then message ("Proving finiteness rule for domain "^comp_dname^" ...")
115.146 + else ();
115.147 +
115.148 + val _ = trace " Proving finite_ind...";
115.149 + val finite_ind =
115.150 + let
115.151 + val concls =
115.152 + map (fn ((P, t), x) => P $ mk_capply (t $ n, x))
115.153 + (Ps ~~ take_consts ~~ xs);
115.154 + val goal = mk_trp (foldr1 mk_conj concls);
115.155 +
115.156 + fun tacf {prems, context} =
115.157 + let
115.158 + (* Prove stronger prems, without definedness side conditions *)
115.159 + fun con_thm p (con, args) =
115.160 + let
115.161 + val subgoal = con_assm false p (con, args);
115.162 + val rules = prems @ con_rews @ simp_thms;
115.163 + val simplify = asm_simp_tac (HOL_basic_ss addsimps rules);
115.164 + fun arg_tac (lazy, _) =
115.165 + rtac (if lazy then allI else case_UU_allI) 1;
115.166 + val tacs =
115.167 + rewrite_goals_tac @{thms atomize_all atomize_imp} ::
115.168 + map arg_tac args @
115.169 + [REPEAT (rtac impI 1), ALLGOALS simplify];
115.170 + in
115.171 + Goal.prove context [] [] subgoal (K (EVERY tacs))
115.172 + end;
115.173 + fun eq_thms (p, cons) = map (con_thm p) cons;
115.174 + val conss = map #con_specs constr_infos;
115.175 + val prems' = maps eq_thms (Ps ~~ conss);
115.176 +
115.177 + val tacs1 = [
115.178 + quant_tac context 1,
115.179 + simp_tac HOL_ss 1,
115.180 + InductTacs.induct_tac context [[SOME "n"]] 1,
115.181 + simp_tac (take_ss addsimps prems) 1,
115.182 + TRY (safe_tac HOL_cs)];
115.183 + fun con_tac _ =
115.184 + asm_simp_tac take_ss 1 THEN
115.185 + (resolve_tac prems' THEN_ALL_NEW etac spec) 1;
115.186 + fun cases_tacs (cons, exhaust) =
115.187 + res_inst_tac context [(("y", 0), "x")] exhaust 1 ::
115.188 + asm_simp_tac (take_ss addsimps prems) 1 ::
115.189 + map con_tac cons;
115.190 + val tacs = tacs1 @ maps cases_tacs (conss ~~ exhausts)
115.191 + in
115.192 + EVERY (map DETERM tacs)
115.193 + end;
115.194 + in Goal.prove_global thy [] assms goal tacf end;
115.195 +
115.196 + val _ = trace " Proving ind...";
115.197 + val ind =
115.198 + let
115.199 + val concls = map (op $) (Ps ~~ xs);
115.200 + val goal = mk_trp (foldr1 mk_conj concls);
115.201 + val adms = if is_finite then [] else map (mk_trp o mk_adm) Ps;
115.202 + fun tacf {prems, context} =
115.203 + let
115.204 + fun finite_tac (take_induct, fin_ind) =
115.205 + rtac take_induct 1 THEN
115.206 + (if is_finite then all_tac else resolve_tac prems 1) THEN
115.207 + (rtac fin_ind THEN_ALL_NEW solve_tac prems) 1;
115.208 + val fin_inds = Project_Rule.projections context finite_ind;
115.209 + in
115.210 + TRY (safe_tac HOL_cs) THEN
115.211 + EVERY (map finite_tac (take_induct_thms ~~ fin_inds))
115.212 + end;
115.213 + in Goal.prove_global thy [] (adms @ assms) goal tacf end
115.214 +
115.215 + (* case names for induction rules *)
115.216 + val dnames = map (fst o dest_Type) newTs;
115.217 + val case_ns =
115.218 + let
115.219 + val adms =
115.220 + if is_finite then [] else
115.221 + if length dnames = 1 then ["adm"] else
115.222 + map (fn s => "adm_" ^ Long_Name.base_name s) dnames;
115.223 + val bottoms =
115.224 + if length dnames = 1 then ["bottom"] else
115.225 + map (fn s => "bottom_" ^ Long_Name.base_name s) dnames;
115.226 + fun one_eq bot constr_info =
115.227 + let fun name_of (c, args) = Long_Name.base_name (fst (dest_Const c));
115.228 + in bot :: map name_of (#con_specs constr_info) end;
115.229 + in adms @ flat (map2 one_eq bottoms constr_infos) end;
115.230 +
115.231 + val inducts = Project_Rule.projections (ProofContext.init_global thy) ind;
115.232 + fun ind_rule (dname, rule) =
115.233 + ((Binding.empty, rule),
115.234 + [Rule_Cases.case_names case_ns, Induct.induct_type dname]);
115.235 +
115.236 +in
115.237 + thy
115.238 + |> snd o Global_Theory.add_thms [
115.239 + ((Binding.qualified true "finite_induct" comp_dbind, finite_ind), []),
115.240 + ((Binding.qualified true "induct" comp_dbind, ind ), [])]
115.241 + |> (snd o Global_Theory.add_thms (map ind_rule (dnames ~~ inducts)))
115.242 +end; (* prove_induction *)
115.243 +
115.244 +(******************************************************************************)
115.245 +(************************ bisimulation and coinduction ************************)
115.246 +(******************************************************************************)
115.247 +
115.248 +fun prove_coinduction
115.249 + (comp_dbind : binding, dbinds : binding list)
115.250 + (constr_infos : Domain_Constructors.constr_info list)
115.251 + (take_info : Domain_Take_Proofs.take_induct_info)
115.252 + (take_rews : thm list list)
115.253 + (thy : theory) : theory =
115.254 +let
115.255 + val iso_infos = map #iso_info constr_infos;
115.256 + val newTs = map #absT iso_infos;
115.257 +
115.258 + val {take_consts, take_0_thms, take_lemma_thms, ...} = take_info;
115.259 +
115.260 + val R_names = Datatype_Prop.indexify_names (map (K "R") newTs);
115.261 + val R_types = map (fn T => T --> T --> boolT) newTs;
115.262 + val Rs = map Free (R_names ~~ R_types);
115.263 + val n = Free ("n", natT);
115.264 + val reserved = "x" :: "y" :: R_names;
115.265 +
115.266 + (* declare bisimulation predicate *)
115.267 + val bisim_bind = Binding.suffix_name "_bisim" comp_dbind;
115.268 + val bisim_type = R_types ---> boolT;
115.269 + val (bisim_const, thy) =
115.270 + Sign.declare_const ((bisim_bind, bisim_type), NoSyn) thy;
115.271 +
115.272 + (* define bisimulation predicate *)
115.273 + local
115.274 + fun one_con T (con, args) =
115.275 + let
115.276 + val Ts = map snd args;
115.277 + val ns1 = Name.variant_list reserved (Datatype_Prop.make_tnames Ts);
115.278 + val ns2 = map (fn n => n^"'") ns1;
115.279 + val vs1 = map Free (ns1 ~~ Ts);
115.280 + val vs2 = map Free (ns2 ~~ Ts);
115.281 + val eq1 = mk_eq (Free ("x", T), list_ccomb (con, vs1));
115.282 + val eq2 = mk_eq (Free ("y", T), list_ccomb (con, vs2));
115.283 + fun rel ((v1, v2), T) =
115.284 + case AList.lookup (op =) (newTs ~~ Rs) T of
115.285 + NONE => mk_eq (v1, v2) | SOME r => r $ v1 $ v2;
115.286 + val eqs = foldr1 mk_conj (map rel (vs1 ~~ vs2 ~~ Ts) @ [eq1, eq2]);
115.287 + in
115.288 + Library.foldr mk_ex (vs1 @ vs2, eqs)
115.289 + end;
115.290 + fun one_eq ((T, R), cons) =
115.291 + let
115.292 + val x = Free ("x", T);
115.293 + val y = Free ("y", T);
115.294 + val disj1 = mk_conj (mk_eq (x, mk_bottom T), mk_eq (y, mk_bottom T));
115.295 + val disjs = disj1 :: map (one_con T) cons;
115.296 + in
115.297 + mk_all (x, mk_all (y, mk_imp (R $ x $ y, foldr1 mk_disj disjs)))
115.298 + end;
115.299 + val conjs = map one_eq (newTs ~~ Rs ~~ map #con_specs constr_infos);
115.300 + val bisim_rhs = lambdas Rs (Library.foldr1 mk_conj conjs);
115.301 + val bisim_eqn = Logic.mk_equals (bisim_const, bisim_rhs);
115.302 + in
115.303 + val (bisim_def_thm, thy) = thy |>
115.304 + yield_singleton (Global_Theory.add_defs false)
115.305 + ((Binding.qualified true "bisim_def" comp_dbind, bisim_eqn), []);
115.306 + end (* local *)
115.307 +
115.308 + (* prove coinduction lemma *)
115.309 + val coind_lemma =
115.310 + let
115.311 + val assm = mk_trp (list_comb (bisim_const, Rs));
115.312 + fun one ((T, R), take_const) =
115.313 + let
115.314 + val x = Free ("x", T);
115.315 + val y = Free ("y", T);
115.316 + val lhs = mk_capply (take_const $ n, x);
115.317 + val rhs = mk_capply (take_const $ n, y);
115.318 + in
115.319 + mk_all (x, mk_all (y, mk_imp (R $ x $ y, mk_eq (lhs, rhs))))
115.320 + end;
115.321 + val goal =
115.322 + mk_trp (foldr1 mk_conj (map one (newTs ~~ Rs ~~ take_consts)));
115.323 + val rules = @{thm Rep_cfun_strict1} :: take_0_thms;
115.324 + fun tacf {prems, context} =
115.325 + let
115.326 + val prem' = rewrite_rule [bisim_def_thm] (hd prems);
115.327 + val prems' = Project_Rule.projections context prem';
115.328 + val dests = map (fn th => th RS spec RS spec RS mp) prems';
115.329 + fun one_tac (dest, rews) =
115.330 + dtac dest 1 THEN safe_tac HOL_cs THEN
115.331 + ALLGOALS (asm_simp_tac (HOL_basic_ss addsimps rews));
115.332 + in
115.333 + rtac @{thm nat.induct} 1 THEN
115.334 + simp_tac (HOL_ss addsimps rules) 1 THEN
115.335 + safe_tac HOL_cs THEN
115.336 + EVERY (map one_tac (dests ~~ take_rews))
115.337 + end
115.338 + in
115.339 + Goal.prove_global thy [] [assm] goal tacf
115.340 + end;
115.341 +
115.342 + (* prove individual coinduction rules *)
115.343 + fun prove_coind ((T, R), take_lemma) =
115.344 + let
115.345 + val x = Free ("x", T);
115.346 + val y = Free ("y", T);
115.347 + val assm1 = mk_trp (list_comb (bisim_const, Rs));
115.348 + val assm2 = mk_trp (R $ x $ y);
115.349 + val goal = mk_trp (mk_eq (x, y));
115.350 + fun tacf {prems, context} =
115.351 + let
115.352 + val rule = hd prems RS coind_lemma;
115.353 + in
115.354 + rtac take_lemma 1 THEN
115.355 + asm_simp_tac (HOL_basic_ss addsimps (rule :: prems)) 1
115.356 + end;
115.357 + in
115.358 + Goal.prove_global thy [] [assm1, assm2] goal tacf
115.359 + end;
115.360 + val coinds = map prove_coind (newTs ~~ Rs ~~ take_lemma_thms);
115.361 + val coind_binds = map (Binding.qualified true "coinduct") dbinds;
115.362 +
115.363 +in
115.364 + thy |> snd o Global_Theory.add_thms
115.365 + (map Thm.no_attributes (coind_binds ~~ coinds))
115.366 +end; (* let *)
115.367 +
115.368 +(******************************************************************************)
115.369 +(******************************* main function ********************************)
115.370 +(******************************************************************************)
115.371 +
115.372 +fun comp_theorems
115.373 + (dbinds : binding list)
115.374 + (take_info : Domain_Take_Proofs.take_induct_info)
115.375 + (constr_infos : Domain_Constructors.constr_info list)
115.376 + (thy : theory) =
115.377 +let
115.378 +
115.379 +val comp_dname = space_implode "_" (map Binding.name_of dbinds);
115.380 +val comp_dbind = Binding.name comp_dname;
115.381 +
115.382 +(* Test for emptiness *)
115.383 +(* FIXME: reimplement emptiness test
115.384 +local
115.385 + open Domain_Library;
115.386 + val dnames = map (fst o fst) eqs;
115.387 + val conss = map snd eqs;
115.388 + fun rec_to ns lazy_rec (n,cons) = forall (exists (fn arg =>
115.389 + is_rec arg andalso not (member (op =) ns (rec_of arg)) andalso
115.390 + ((rec_of arg = n andalso not (lazy_rec orelse is_lazy arg)) orelse
115.391 + rec_of arg <> n andalso rec_to (rec_of arg::ns)
115.392 + (lazy_rec orelse is_lazy arg) (n, (List.nth(conss,rec_of arg))))
115.393 + ) o snd) cons;
115.394 + fun warn (n,cons) =
115.395 + if rec_to [] false (n,cons)
115.396 + then (warning ("domain "^List.nth(dnames,n)^" is empty!"); true)
115.397 + else false;
115.398 +in
115.399 + val n__eqs = mapn (fn n => fn (_,cons) => (n,cons)) 0 eqs;
115.400 + val is_emptys = map warn n__eqs;
115.401 +end;
115.402 +*)
115.403 +
115.404 +(* Test for indirect recursion *)
115.405 +local
115.406 + val newTs = map (#absT o #iso_info) constr_infos;
115.407 + fun indirect_typ (Type (_, Ts)) =
115.408 + exists (fn T => member (op =) newTs T orelse indirect_typ T) Ts
115.409 + | indirect_typ _ = false;
115.410 + fun indirect_arg (_, T) = indirect_typ T;
115.411 + fun indirect_con (_, args) = exists indirect_arg args;
115.412 + fun indirect_eq cons = exists indirect_con cons;
115.413 +in
115.414 + val is_indirect = exists indirect_eq (map #con_specs constr_infos);
115.415 + val _ =
115.416 + if is_indirect
115.417 + then message "Indirect recursion detected, skipping proofs of (co)induction rules"
115.418 + else message ("Proving induction properties of domain "^comp_dname^" ...");
115.419 +end;
115.420 +
115.421 +(* theorems about take *)
115.422 +
115.423 +val (take_rewss, thy) =
115.424 + take_theorems dbinds take_info constr_infos thy;
115.425 +
115.426 +val {take_lemma_thms, take_0_thms, take_strict_thms, ...} = take_info;
115.427 +
115.428 +val take_rews = take_0_thms @ take_strict_thms @ flat take_rewss;
115.429 +
115.430 +(* prove induction rules, unless definition is indirect recursive *)
115.431 +val thy =
115.432 + if is_indirect then thy else
115.433 + prove_induction comp_dbind constr_infos take_info take_rews thy;
115.434 +
115.435 +val thy =
115.436 + if is_indirect then thy else
115.437 + prove_coinduction (comp_dbind, dbinds) constr_infos take_info take_rewss thy;
115.438 +
115.439 +in
115.440 + (take_rews, thy)
115.441 +end; (* let *)
115.442 +end; (* struct *)
116.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
116.2 +++ b/src/HOL/HOLCF/Tools/Domain/domain_isomorphism.ML Sat Nov 27 16:08:10 2010 -0800
116.3 @@ -0,0 +1,787 @@
116.4 +(* Title: HOLCF/Tools/Domain/domain_isomorphism.ML
116.5 + Author: Brian Huffman
116.6 +
116.7 +Defines new types satisfying the given domain equations.
116.8 +*)
116.9 +
116.10 +signature DOMAIN_ISOMORPHISM =
116.11 +sig
116.12 + val domain_isomorphism :
116.13 + (string list * binding * mixfix * typ
116.14 + * (binding * binding) option) list ->
116.15 + theory ->
116.16 + (Domain_Take_Proofs.iso_info list
116.17 + * Domain_Take_Proofs.take_induct_info) * theory
116.18 +
116.19 + val define_map_functions :
116.20 + (binding * Domain_Take_Proofs.iso_info) list ->
116.21 + theory ->
116.22 + {
116.23 + map_consts : term list,
116.24 + map_apply_thms : thm list,
116.25 + map_unfold_thms : thm list,
116.26 + deflation_map_thms : thm list
116.27 + }
116.28 + * theory
116.29 +
116.30 + val domain_isomorphism_cmd :
116.31 + (string list * binding * mixfix * string * (binding * binding) option) list
116.32 + -> theory -> theory
116.33 +
116.34 + val setup : theory -> theory
116.35 +end;
116.36 +
116.37 +structure Domain_Isomorphism : DOMAIN_ISOMORPHISM =
116.38 +struct
116.39 +
116.40 +val beta_rules =
116.41 + @{thms beta_cfun cont_id cont_const cont2cont_APP cont2cont_LAM'} @
116.42 + @{thms cont2cont_fst cont2cont_snd cont2cont_Pair cont2cont_prod_case'};
116.43 +
116.44 +val beta_ss = HOL_basic_ss addsimps (simp_thms @ beta_rules);
116.45 +
116.46 +val beta_tac = simp_tac beta_ss;
116.47 +
116.48 +fun is_cpo thy T = Sign.of_sort thy (T, @{sort cpo});
116.49 +
116.50 +(******************************************************************************)
116.51 +(******************************** theory data *********************************)
116.52 +(******************************************************************************)
116.53 +
116.54 +structure RepData = Named_Thms
116.55 +(
116.56 + val name = "domain_defl_simps"
116.57 + val description = "theorems like DEFL('a t) = t_defl$DEFL('a)"
116.58 +)
116.59 +
116.60 +structure IsodeflData = Named_Thms
116.61 +(
116.62 + val name = "domain_isodefl"
116.63 + val description = "theorems like isodefl d t ==> isodefl (foo_map$d) (foo_defl$t)"
116.64 +);
116.65 +
116.66 +val setup = RepData.setup #> IsodeflData.setup
116.67 +
116.68 +
116.69 +(******************************************************************************)
116.70 +(************************** building types and terms **************************)
116.71 +(******************************************************************************)
116.72 +
116.73 +open HOLCF_Library;
116.74 +
116.75 +infixr 6 ->>;
116.76 +infixr -->>;
116.77 +
116.78 +val udomT = @{typ udom};
116.79 +val deflT = @{typ "defl"};
116.80 +
116.81 +fun mk_DEFL T =
116.82 + Const (@{const_name defl}, Term.itselfT T --> deflT) $ Logic.mk_type T;
116.83 +
116.84 +fun dest_DEFL (Const (@{const_name defl}, _) $ t) = Logic.dest_type t
116.85 + | dest_DEFL t = raise TERM ("dest_DEFL", [t]);
116.86 +
116.87 +fun mk_LIFTDEFL T =
116.88 + Const (@{const_name liftdefl}, Term.itselfT T --> deflT) $ Logic.mk_type T;
116.89 +
116.90 +fun dest_LIFTDEFL (Const (@{const_name liftdefl}, _) $ t) = Logic.dest_type t
116.91 + | dest_LIFTDEFL t = raise TERM ("dest_LIFTDEFL", [t]);
116.92 +
116.93 +fun mk_u_defl t = mk_capply (@{const "u_defl"}, t);
116.94 +
116.95 +fun mk_u_map t =
116.96 + let
116.97 + val (T, U) = dest_cfunT (fastype_of t);
116.98 + val u_map_type = (T ->> U) ->> (mk_upT T ->> mk_upT U);
116.99 + val u_map_const = Const (@{const_name u_map}, u_map_type);
116.100 + in
116.101 + mk_capply (u_map_const, t)
116.102 + end;
116.103 +
116.104 +fun emb_const T = Const (@{const_name emb}, T ->> udomT);
116.105 +fun prj_const T = Const (@{const_name prj}, udomT ->> T);
116.106 +fun coerce_const (T, U) = mk_cfcomp (prj_const U, emb_const T);
116.107 +
116.108 +fun isodefl_const T =
116.109 + Const (@{const_name isodefl}, (T ->> T) --> deflT --> HOLogic.boolT);
116.110 +
116.111 +fun mk_deflation t =
116.112 + Const (@{const_name deflation}, Term.fastype_of t --> boolT) $ t;
116.113 +
116.114 +(* splits a cterm into the right and lefthand sides of equality *)
116.115 +fun dest_eqs t = HOLogic.dest_eq (HOLogic.dest_Trueprop t);
116.116 +
116.117 +fun mk_eqs (t, u) = HOLogic.mk_Trueprop (HOLogic.mk_eq (t, u));
116.118 +
116.119 +(******************************************************************************)
116.120 +(****************************** isomorphism info ******************************)
116.121 +(******************************************************************************)
116.122 +
116.123 +fun deflation_abs_rep (info : Domain_Take_Proofs.iso_info) : thm =
116.124 + let
116.125 + val abs_iso = #abs_inverse info;
116.126 + val rep_iso = #rep_inverse info;
116.127 + val thm = @{thm deflation_abs_rep} OF [abs_iso, rep_iso];
116.128 + in
116.129 + Drule.zero_var_indexes thm
116.130 + end
116.131 +
116.132 +(******************************************************************************)
116.133 +(*************** fixed-point definitions and unfolding theorems ***************)
116.134 +(******************************************************************************)
116.135 +
116.136 +fun mk_projs [] t = []
116.137 + | mk_projs (x::[]) t = [(x, t)]
116.138 + | mk_projs (x::xs) t = (x, mk_fst t) :: mk_projs xs (mk_snd t);
116.139 +
116.140 +fun add_fixdefs
116.141 + (spec : (binding * term) list)
116.142 + (thy : theory) : (thm list * thm list) * theory =
116.143 + let
116.144 + val binds = map fst spec;
116.145 + val (lhss, rhss) = ListPair.unzip (map (dest_eqs o snd) spec);
116.146 + val functional = lambda_tuple lhss (mk_tuple rhss);
116.147 + val fixpoint = mk_fix (mk_cabs functional);
116.148 +
116.149 + (* project components of fixpoint *)
116.150 + val projs = mk_projs lhss fixpoint;
116.151 +
116.152 + (* convert parameters to lambda abstractions *)
116.153 + fun mk_eqn (lhs, rhs) =
116.154 + case lhs of
116.155 + Const (@{const_name Rep_cfun}, _) $ f $ (x as Free _) =>
116.156 + mk_eqn (f, big_lambda x rhs)
116.157 + | f $ Const (@{const_name TYPE}, T) =>
116.158 + mk_eqn (f, Abs ("t", T, rhs))
116.159 + | Const _ => Logic.mk_equals (lhs, rhs)
116.160 + | _ => raise TERM ("lhs not of correct form", [lhs, rhs]);
116.161 + val eqns = map mk_eqn projs;
116.162 +
116.163 + (* register constant definitions *)
116.164 + val (fixdef_thms, thy) =
116.165 + (Global_Theory.add_defs false o map Thm.no_attributes)
116.166 + (map (Binding.suffix_name "_def") binds ~~ eqns) thy;
116.167 +
116.168 + (* prove applied version of definitions *)
116.169 + fun prove_proj (lhs, rhs) =
116.170 + let
116.171 + val tac = rewrite_goals_tac fixdef_thms THEN beta_tac 1;
116.172 + val goal = Logic.mk_equals (lhs, rhs);
116.173 + in Goal.prove_global thy [] [] goal (K tac) end;
116.174 + val proj_thms = map prove_proj projs;
116.175 +
116.176 + (* mk_tuple lhss == fixpoint *)
116.177 + fun pair_equalI (thm1, thm2) = @{thm Pair_equalI} OF [thm1, thm2];
116.178 + val tuple_fixdef_thm = foldr1 pair_equalI proj_thms;
116.179 +
116.180 + val cont_thm =
116.181 + Goal.prove_global thy [] [] (mk_trp (mk_cont functional))
116.182 + (K (beta_tac 1));
116.183 + val tuple_unfold_thm =
116.184 + (@{thm def_cont_fix_eq} OF [tuple_fixdef_thm, cont_thm])
116.185 + |> Local_Defs.unfold (ProofContext.init_global thy) @{thms split_conv};
116.186 +
116.187 + fun mk_unfold_thms [] thm = []
116.188 + | mk_unfold_thms (n::[]) thm = [(n, thm)]
116.189 + | mk_unfold_thms (n::ns) thm = let
116.190 + val thmL = thm RS @{thm Pair_eqD1};
116.191 + val thmR = thm RS @{thm Pair_eqD2};
116.192 + in (n, thmL) :: mk_unfold_thms ns thmR end;
116.193 + val unfold_binds = map (Binding.suffix_name "_unfold") binds;
116.194 +
116.195 + (* register unfold theorems *)
116.196 + val (unfold_thms, thy) =
116.197 + (Global_Theory.add_thms o map (Thm.no_attributes o apsnd Drule.zero_var_indexes))
116.198 + (mk_unfold_thms unfold_binds tuple_unfold_thm) thy;
116.199 + in
116.200 + ((proj_thms, unfold_thms), thy)
116.201 + end;
116.202 +
116.203 +
116.204 +(******************************************************************************)
116.205 +(****************** deflation combinators and map functions *******************)
116.206 +(******************************************************************************)
116.207 +
116.208 +fun defl_of_typ
116.209 + (thy : theory)
116.210 + (tab1 : (typ * term) list)
116.211 + (tab2 : (typ * term) list)
116.212 + (T : typ) : term =
116.213 + let
116.214 + val defl_simps = RepData.get (ProofContext.init_global thy);
116.215 + val rules = map (Thm.concl_of #> HOLogic.dest_Trueprop #> HOLogic.dest_eq) defl_simps;
116.216 + val rules' = map (apfst mk_DEFL) tab1 @ map (apfst mk_LIFTDEFL) tab2;
116.217 + fun proc1 t =
116.218 + (case dest_DEFL t of
116.219 + TFree (a, _) => SOME (Free ("d" ^ Library.unprefix "'" a, deflT))
116.220 + | _ => NONE) handle TERM _ => NONE;
116.221 + fun proc2 t =
116.222 + (case dest_LIFTDEFL t of
116.223 + TFree (a, _) => SOME (Free ("p" ^ Library.unprefix "'" a, deflT))
116.224 + | _ => NONE) handle TERM _ => NONE;
116.225 + in
116.226 + Pattern.rewrite_term thy (rules @ rules') [proc1, proc2] (mk_DEFL T)
116.227 + end;
116.228 +
116.229 +(******************************************************************************)
116.230 +(********************* declaring definitions and theorems *********************)
116.231 +(******************************************************************************)
116.232 +
116.233 +fun define_const
116.234 + (bind : binding, rhs : term)
116.235 + (thy : theory)
116.236 + : (term * thm) * theory =
116.237 + let
116.238 + val typ = Term.fastype_of rhs;
116.239 + val (const, thy) = Sign.declare_const ((bind, typ), NoSyn) thy;
116.240 + val eqn = Logic.mk_equals (const, rhs);
116.241 + val def = Thm.no_attributes (Binding.suffix_name "_def" bind, eqn);
116.242 + val (def_thm, thy) = yield_singleton (Global_Theory.add_defs false) def thy;
116.243 + in
116.244 + ((const, def_thm), thy)
116.245 + end;
116.246 +
116.247 +fun add_qualified_thm name (dbind, thm) =
116.248 + yield_singleton Global_Theory.add_thms
116.249 + ((Binding.qualified true name dbind, thm), []);
116.250 +
116.251 +(******************************************************************************)
116.252 +(*************************** defining map functions ***************************)
116.253 +(******************************************************************************)
116.254 +
116.255 +fun define_map_functions
116.256 + (spec : (binding * Domain_Take_Proofs.iso_info) list)
116.257 + (thy : theory) =
116.258 + let
116.259 +
116.260 + (* retrieve components of spec *)
116.261 + val dbinds = map fst spec;
116.262 + val iso_infos = map snd spec;
116.263 + val dom_eqns = map (fn x => (#absT x, #repT x)) iso_infos;
116.264 + val rep_abs_consts = map (fn x => (#rep_const x, #abs_const x)) iso_infos;
116.265 +
116.266 + fun mapT (T as Type (_, Ts)) =
116.267 + (map (fn T => T ->> T) (filter (is_cpo thy) Ts)) -->> (T ->> T)
116.268 + | mapT T = T ->> T;
116.269 +
116.270 + (* declare map functions *)
116.271 + fun declare_map_const (tbind, (lhsT, rhsT)) thy =
116.272 + let
116.273 + val map_type = mapT lhsT;
116.274 + val map_bind = Binding.suffix_name "_map" tbind;
116.275 + in
116.276 + Sign.declare_const ((map_bind, map_type), NoSyn) thy
116.277 + end;
116.278 + val (map_consts, thy) = thy |>
116.279 + fold_map declare_map_const (dbinds ~~ dom_eqns);
116.280 +
116.281 + (* defining equations for map functions *)
116.282 + local
116.283 + fun unprime a = Library.unprefix "'" a;
116.284 + fun mapvar T = Free (unprime (fst (dest_TFree T)), T ->> T);
116.285 + fun map_lhs (map_const, lhsT) =
116.286 + (lhsT, list_ccomb (map_const, map mapvar (filter (is_cpo thy) (snd (dest_Type lhsT)))));
116.287 + val tab1 = map map_lhs (map_consts ~~ map fst dom_eqns);
116.288 + val Ts = (snd o dest_Type o fst o hd) dom_eqns;
116.289 + val tab = (Ts ~~ map mapvar Ts) @ tab1;
116.290 + fun mk_map_spec (((rep_const, abs_const), map_const), (lhsT, rhsT)) =
116.291 + let
116.292 + val lhs = Domain_Take_Proofs.map_of_typ thy tab lhsT;
116.293 + val body = Domain_Take_Proofs.map_of_typ thy tab rhsT;
116.294 + val rhs = mk_cfcomp (abs_const, mk_cfcomp (body, rep_const));
116.295 + in mk_eqs (lhs, rhs) end;
116.296 + in
116.297 + val map_specs =
116.298 + map mk_map_spec (rep_abs_consts ~~ map_consts ~~ dom_eqns);
116.299 + end;
116.300 +
116.301 + (* register recursive definition of map functions *)
116.302 + val map_binds = map (Binding.suffix_name "_map") dbinds;
116.303 + val ((map_apply_thms, map_unfold_thms), thy) =
116.304 + add_fixdefs (map_binds ~~ map_specs) thy;
116.305 +
116.306 + (* prove deflation theorems for map functions *)
116.307 + val deflation_abs_rep_thms = map deflation_abs_rep iso_infos;
116.308 + val deflation_map_thm =
116.309 + let
116.310 + fun unprime a = Library.unprefix "'" a;
116.311 + fun mk_f T = Free (unprime (fst (dest_TFree T)), T ->> T);
116.312 + fun mk_assm T = mk_trp (mk_deflation (mk_f T));
116.313 + fun mk_goal (map_const, (lhsT, rhsT)) =
116.314 + let
116.315 + val (_, Ts) = dest_Type lhsT;
116.316 + val map_term = list_ccomb (map_const, map mk_f (filter (is_cpo thy) Ts));
116.317 + in mk_deflation map_term end;
116.318 + val assms = (map mk_assm o filter (is_cpo thy) o snd o dest_Type o fst o hd) dom_eqns;
116.319 + val goals = map mk_goal (map_consts ~~ dom_eqns);
116.320 + val goal = mk_trp (foldr1 HOLogic.mk_conj goals);
116.321 + val start_thms =
116.322 + @{thm split_def} :: map_apply_thms;
116.323 + val adm_rules =
116.324 + @{thms adm_conj adm_subst [OF _ adm_deflation]
116.325 + cont2cont_fst cont2cont_snd cont_id};
116.326 + val bottom_rules =
116.327 + @{thms fst_strict snd_strict deflation_UU simp_thms};
116.328 + val deflation_rules =
116.329 + @{thms conjI deflation_ID}
116.330 + @ deflation_abs_rep_thms
116.331 + @ Domain_Take_Proofs.get_deflation_thms thy;
116.332 + in
116.333 + Goal.prove_global thy [] assms goal (fn {prems, ...} =>
116.334 + EVERY
116.335 + [simp_tac (HOL_basic_ss addsimps start_thms) 1,
116.336 + rtac @{thm fix_ind} 1,
116.337 + REPEAT (resolve_tac adm_rules 1),
116.338 + simp_tac (HOL_basic_ss addsimps bottom_rules) 1,
116.339 + simp_tac beta_ss 1,
116.340 + simp_tac (HOL_basic_ss addsimps @{thms fst_conv snd_conv}) 1,
116.341 + REPEAT (etac @{thm conjE} 1),
116.342 + REPEAT (resolve_tac (deflation_rules @ prems) 1 ORELSE atac 1)])
116.343 + end;
116.344 + fun conjuncts [] thm = []
116.345 + | conjuncts (n::[]) thm = [(n, thm)]
116.346 + | conjuncts (n::ns) thm = let
116.347 + val thmL = thm RS @{thm conjunct1};
116.348 + val thmR = thm RS @{thm conjunct2};
116.349 + in (n, thmL):: conjuncts ns thmR end;
116.350 + val deflation_map_binds = dbinds |>
116.351 + map (Binding.prefix_name "deflation_" o Binding.suffix_name "_map");
116.352 + val (deflation_map_thms, thy) = thy |>
116.353 + (Global_Theory.add_thms o map (Thm.no_attributes o apsnd Drule.zero_var_indexes))
116.354 + (conjuncts deflation_map_binds deflation_map_thm);
116.355 +
116.356 + (* register indirect recursion in theory data *)
116.357 + local
116.358 + fun register_map (dname, args) =
116.359 + Domain_Take_Proofs.add_rec_type (dname, args);
116.360 + val dnames = map (fst o dest_Type o fst) dom_eqns;
116.361 + val map_names = map (fst o dest_Const) map_consts;
116.362 + fun args (T, _) = case T of Type (_, Ts) => map (is_cpo thy) Ts | _ => [];
116.363 + val argss = map args dom_eqns;
116.364 + in
116.365 + val thy =
116.366 + fold register_map (dnames ~~ argss) thy;
116.367 + end;
116.368 +
116.369 + (* register deflation theorems *)
116.370 + val thy = fold Domain_Take_Proofs.add_deflation_thm deflation_map_thms thy;
116.371 +
116.372 + val result =
116.373 + {
116.374 + map_consts = map_consts,
116.375 + map_apply_thms = map_apply_thms,
116.376 + map_unfold_thms = map_unfold_thms,
116.377 + deflation_map_thms = deflation_map_thms
116.378 + }
116.379 + in
116.380 + (result, thy)
116.381 + end;
116.382 +
116.383 +(******************************************************************************)
116.384 +(******************************* main function ********************************)
116.385 +(******************************************************************************)
116.386 +
116.387 +fun read_typ thy str sorts =
116.388 + let
116.389 + val ctxt = ProofContext.init_global thy
116.390 + |> fold (Variable.declare_typ o TFree) sorts;
116.391 + val T = Syntax.read_typ ctxt str;
116.392 + in (T, Term.add_tfreesT T sorts) end;
116.393 +
116.394 +fun cert_typ sign raw_T sorts =
116.395 + let
116.396 + val T = Type.no_tvars (Sign.certify_typ sign raw_T)
116.397 + handle TYPE (msg, _, _) => error msg;
116.398 + val sorts' = Term.add_tfreesT T sorts;
116.399 + val _ =
116.400 + case duplicates (op =) (map fst sorts') of
116.401 + [] => ()
116.402 + | dups => error ("Inconsistent sort constraints for " ^ commas dups)
116.403 + in (T, sorts') end;
116.404 +
116.405 +fun gen_domain_isomorphism
116.406 + (prep_typ: theory -> 'a -> (string * sort) list -> typ * (string * sort) list)
116.407 + (doms_raw: (string list * binding * mixfix * 'a * (binding * binding) option) list)
116.408 + (thy: theory)
116.409 + : (Domain_Take_Proofs.iso_info list
116.410 + * Domain_Take_Proofs.take_induct_info) * theory =
116.411 + let
116.412 + val _ = Theory.requires thy "Domain" "domain isomorphisms";
116.413 +
116.414 + (* this theory is used just for parsing *)
116.415 + val tmp_thy = thy |>
116.416 + Theory.copy |>
116.417 + Sign.add_types (map (fn (tvs, tbind, mx, _, morphs) =>
116.418 + (tbind, length tvs, mx)) doms_raw);
116.419 +
116.420 + fun prep_dom thy (vs, t, mx, typ_raw, morphs) sorts =
116.421 + let val (typ, sorts') = prep_typ thy typ_raw sorts
116.422 + in ((vs, t, mx, typ, morphs), sorts') end;
116.423 +
116.424 + val (doms : (string list * binding * mixfix * typ * (binding * binding) option) list,
116.425 + sorts : (string * sort) list) =
116.426 + fold_map (prep_dom tmp_thy) doms_raw [];
116.427 +
116.428 + (* lookup function for sorts of type variables *)
116.429 + fun the_sort v = the (AList.lookup (op =) sorts v);
116.430 +
116.431 + (* declare arities in temporary theory *)
116.432 + val tmp_thy =
116.433 + let
116.434 + fun arity (vs, tbind, mx, _, _) =
116.435 + (Sign.full_name thy tbind, map the_sort vs, @{sort "domain"});
116.436 + in
116.437 + fold AxClass.axiomatize_arity (map arity doms) tmp_thy
116.438 + end;
116.439 +
116.440 + (* check bifiniteness of right-hand sides *)
116.441 + fun check_rhs (vs, tbind, mx, rhs, morphs) =
116.442 + if Sign.of_sort tmp_thy (rhs, @{sort "domain"}) then ()
116.443 + else error ("Type not of sort domain: " ^
116.444 + quote (Syntax.string_of_typ_global tmp_thy rhs));
116.445 + val _ = map check_rhs doms;
116.446 +
116.447 + (* domain equations *)
116.448 + fun mk_dom_eqn (vs, tbind, mx, rhs, morphs) =
116.449 + let fun arg v = TFree (v, the_sort v);
116.450 + in (Type (Sign.full_name tmp_thy tbind, map arg vs), rhs) end;
116.451 + val dom_eqns = map mk_dom_eqn doms;
116.452 +
116.453 + (* check for valid type parameters *)
116.454 + val (tyvars, _, _, _, _) = hd doms;
116.455 + val new_doms = map (fn (tvs, tname, mx, _, _) =>
116.456 + let val full_tname = Sign.full_name tmp_thy tname
116.457 + in
116.458 + (case duplicates (op =) tvs of
116.459 + [] =>
116.460 + if eq_set (op =) (tyvars, tvs) then (full_tname, tvs)
116.461 + else error ("Mutually recursive domains must have same type parameters")
116.462 + | dups => error ("Duplicate parameter(s) for domain " ^ quote (Binding.str_of tname) ^
116.463 + " : " ^ commas dups))
116.464 + end) doms;
116.465 + val dbinds = map (fn (_, dbind, _, _, _) => dbind) doms;
116.466 + val morphs = map (fn (_, _, _, _, morphs) => morphs) doms;
116.467 +
116.468 + (* determine deflation combinator arguments *)
116.469 + val lhsTs : typ list = map fst dom_eqns;
116.470 + val defl_rec = Free ("t", mk_tupleT (map (K deflT) lhsTs));
116.471 + val defl_recs = mk_projs lhsTs defl_rec;
116.472 + val defl_recs' = map (apsnd mk_u_defl) defl_recs;
116.473 + fun defl_body (_, _, _, rhsT, _) =
116.474 + defl_of_typ tmp_thy defl_recs defl_recs' rhsT;
116.475 + val functional = Term.lambda defl_rec (mk_tuple (map defl_body doms));
116.476 +
116.477 + val tfrees = map fst (Term.add_tfrees functional []);
116.478 + val frees = map fst (Term.add_frees functional []);
116.479 + fun get_defl_flags (vs, _, _, _, _) =
116.480 + let
116.481 + fun argT v = TFree (v, the_sort v);
116.482 + fun mk_d v = "d" ^ Library.unprefix "'" v;
116.483 + fun mk_p v = "p" ^ Library.unprefix "'" v;
116.484 + val args = maps (fn v => [(mk_d v, mk_DEFL (argT v)), (mk_p v, mk_LIFTDEFL (argT v))]) vs;
116.485 + val typeTs = map argT (filter (member (op =) tfrees) vs);
116.486 + val defl_args = map snd (filter (member (op =) frees o fst) args);
116.487 + in
116.488 + (typeTs, defl_args)
116.489 + end;
116.490 + val defl_flagss = map get_defl_flags doms;
116.491 +
116.492 + (* declare deflation combinator constants *)
116.493 + fun declare_defl_const ((typeTs, defl_args), (_, tbind, _, _, _)) thy =
116.494 + let
116.495 + val defl_bind = Binding.suffix_name "_defl" tbind;
116.496 + val defl_type =
116.497 + map Term.itselfT typeTs ---> map (K deflT) defl_args -->> deflT;
116.498 + in
116.499 + Sign.declare_const ((defl_bind, defl_type), NoSyn) thy
116.500 + end;
116.501 + val (defl_consts, thy) =
116.502 + fold_map declare_defl_const (defl_flagss ~~ doms) thy;
116.503 +
116.504 + (* defining equations for type combinators *)
116.505 + fun mk_defl_term (defl_const, (typeTs, defl_args)) =
116.506 + let
116.507 + val type_args = map Logic.mk_type typeTs;
116.508 + in
116.509 + list_ccomb (list_comb (defl_const, type_args), defl_args)
116.510 + end;
116.511 + val defl_terms = map mk_defl_term (defl_consts ~~ defl_flagss);
116.512 + val defl_tab = map fst dom_eqns ~~ defl_terms;
116.513 + val defl_tab' = map fst dom_eqns ~~ map mk_u_defl defl_terms;
116.514 + fun mk_defl_spec (lhsT, rhsT) =
116.515 + mk_eqs (defl_of_typ tmp_thy defl_tab defl_tab' lhsT,
116.516 + defl_of_typ tmp_thy defl_tab defl_tab' rhsT);
116.517 + val defl_specs = map mk_defl_spec dom_eqns;
116.518 +
116.519 + (* register recursive definition of deflation combinators *)
116.520 + val defl_binds = map (Binding.suffix_name "_defl") dbinds;
116.521 + val ((defl_apply_thms, defl_unfold_thms), thy) =
116.522 + add_fixdefs (defl_binds ~~ defl_specs) thy;
116.523 +
116.524 + (* define types using deflation combinators *)
116.525 + fun make_repdef ((vs, tbind, mx, _, _), defl) thy =
116.526 + let
116.527 + val spec = (tbind, map (rpair dummyS) vs, mx);
116.528 + val ((_, _, _, {DEFL, liftemb_def, liftprj_def, ...}), thy) =
116.529 + Domaindef.add_domaindef false NONE spec defl NONE thy;
116.530 + (* declare domain_defl_simps rules *)
116.531 + val thy = Context.theory_map (RepData.add_thm DEFL) thy;
116.532 + in
116.533 + (DEFL, thy)
116.534 + end;
116.535 + val (DEFL_thms, thy) = fold_map make_repdef (doms ~~ defl_terms) thy;
116.536 +
116.537 + (* prove DEFL equations *)
116.538 + fun mk_DEFL_eq_thm (lhsT, rhsT) =
116.539 + let
116.540 + val goal = mk_eqs (mk_DEFL lhsT, mk_DEFL rhsT);
116.541 + val DEFL_simps = RepData.get (ProofContext.init_global thy);
116.542 + val tac =
116.543 + rewrite_goals_tac (map mk_meta_eq DEFL_simps)
116.544 + THEN TRY (resolve_tac defl_unfold_thms 1);
116.545 + in
116.546 + Goal.prove_global thy [] [] goal (K tac)
116.547 + end;
116.548 + val DEFL_eq_thms = map mk_DEFL_eq_thm dom_eqns;
116.549 +
116.550 + (* register DEFL equations *)
116.551 + val DEFL_eq_binds = map (Binding.prefix_name "DEFL_eq_") dbinds;
116.552 + val (_, thy) = thy |>
116.553 + (Global_Theory.add_thms o map Thm.no_attributes)
116.554 + (DEFL_eq_binds ~~ DEFL_eq_thms);
116.555 +
116.556 + (* define rep/abs functions *)
116.557 + fun mk_rep_abs ((tbind, morphs), (lhsT, rhsT)) thy =
116.558 + let
116.559 + val rep_bind = Binding.suffix_name "_rep" tbind;
116.560 + val abs_bind = Binding.suffix_name "_abs" tbind;
116.561 + val ((rep_const, rep_def), thy) =
116.562 + define_const (rep_bind, coerce_const (lhsT, rhsT)) thy;
116.563 + val ((abs_const, abs_def), thy) =
116.564 + define_const (abs_bind, coerce_const (rhsT, lhsT)) thy;
116.565 + in
116.566 + (((rep_const, abs_const), (rep_def, abs_def)), thy)
116.567 + end;
116.568 + val ((rep_abs_consts, rep_abs_defs), thy) = thy
116.569 + |> fold_map mk_rep_abs (dbinds ~~ morphs ~~ dom_eqns)
116.570 + |>> ListPair.unzip;
116.571 +
116.572 + (* prove isomorphism and isodefl rules *)
116.573 + fun mk_iso_thms ((tbind, DEFL_eq), (rep_def, abs_def)) thy =
116.574 + let
116.575 + fun make thm =
116.576 + Drule.zero_var_indexes (thm OF [DEFL_eq, abs_def, rep_def]);
116.577 + val rep_iso_thm = make @{thm domain_rep_iso};
116.578 + val abs_iso_thm = make @{thm domain_abs_iso};
116.579 + val isodefl_thm = make @{thm isodefl_abs_rep};
116.580 + val thy = thy
116.581 + |> snd o add_qualified_thm "rep_iso" (tbind, rep_iso_thm)
116.582 + |> snd o add_qualified_thm "abs_iso" (tbind, abs_iso_thm)
116.583 + |> snd o add_qualified_thm "isodefl_abs_rep" (tbind, isodefl_thm);
116.584 + in
116.585 + (((rep_iso_thm, abs_iso_thm), isodefl_thm), thy)
116.586 + end;
116.587 + val ((iso_thms, isodefl_abs_rep_thms), thy) =
116.588 + thy
116.589 + |> fold_map mk_iso_thms (dbinds ~~ DEFL_eq_thms ~~ rep_abs_defs)
116.590 + |>> ListPair.unzip;
116.591 +
116.592 + (* collect info about rep/abs *)
116.593 + val iso_infos : Domain_Take_Proofs.iso_info list =
116.594 + let
116.595 + fun mk_info (((lhsT, rhsT), (repC, absC)), (rep_iso, abs_iso)) =
116.596 + {
116.597 + repT = rhsT,
116.598 + absT = lhsT,
116.599 + rep_const = repC,
116.600 + abs_const = absC,
116.601 + rep_inverse = rep_iso,
116.602 + abs_inverse = abs_iso
116.603 + };
116.604 + in
116.605 + map mk_info (dom_eqns ~~ rep_abs_consts ~~ iso_thms)
116.606 + end
116.607 +
116.608 + (* definitions and proofs related to map functions *)
116.609 + val (map_info, thy) =
116.610 + define_map_functions (dbinds ~~ iso_infos) thy;
116.611 + val { map_consts, map_apply_thms, map_unfold_thms,
116.612 + deflation_map_thms } = map_info;
116.613 +
116.614 + (* prove isodefl rules for map functions *)
116.615 + val isodefl_thm =
116.616 + let
116.617 + fun unprime a = Library.unprefix "'" a;
116.618 + fun mk_d T = Free ("d" ^ unprime (fst (dest_TFree T)), deflT);
116.619 + fun mk_p T = Free ("p" ^ unprime (fst (dest_TFree T)), deflT);
116.620 + fun mk_f T = Free ("f" ^ unprime (fst (dest_TFree T)), T ->> T);
116.621 + fun mk_assm t =
116.622 + case try dest_LIFTDEFL t of
116.623 + SOME T => mk_trp (isodefl_const (mk_upT T) $ mk_u_map (mk_f T) $ mk_p T)
116.624 + | NONE =>
116.625 + let val T = dest_DEFL t
116.626 + in mk_trp (isodefl_const T $ mk_f T $ mk_d T) end;
116.627 + fun mk_goal (map_const, (T, rhsT)) =
116.628 + let
116.629 + val (_, Ts) = dest_Type T;
116.630 + val map_term = list_ccomb (map_const, map mk_f (filter (is_cpo thy) Ts));
116.631 + val defl_term = defl_of_typ thy (Ts ~~ map mk_d Ts) (Ts ~~ map mk_p Ts) T;
116.632 + in isodefl_const T $ map_term $ defl_term end;
116.633 + val assms = (map mk_assm o snd o hd) defl_flagss;
116.634 + val goals = map mk_goal (map_consts ~~ dom_eqns);
116.635 + val goal = mk_trp (foldr1 HOLogic.mk_conj goals);
116.636 + val start_thms =
116.637 + @{thm split_def} :: defl_apply_thms @ map_apply_thms;
116.638 + val adm_rules =
116.639 + @{thms adm_conj adm_isodefl cont2cont_fst cont2cont_snd cont_id};
116.640 + val bottom_rules =
116.641 + @{thms fst_strict snd_strict isodefl_bottom simp_thms};
116.642 + val map_ID_thms = Domain_Take_Proofs.get_map_ID_thms thy;
116.643 + val map_ID_simps = map (fn th => th RS sym) map_ID_thms;
116.644 + val isodefl_rules =
116.645 + @{thms conjI isodefl_ID_DEFL isodefl_LIFTDEFL}
116.646 + @ isodefl_abs_rep_thms
116.647 + @ IsodeflData.get (ProofContext.init_global thy);
116.648 + in
116.649 + Goal.prove_global thy [] assms goal (fn {prems, ...} =>
116.650 + EVERY
116.651 + [simp_tac (HOL_basic_ss addsimps start_thms) 1,
116.652 + (* FIXME: how reliable is unification here? *)
116.653 + (* Maybe I should instantiate the rule. *)
116.654 + rtac @{thm parallel_fix_ind} 1,
116.655 + REPEAT (resolve_tac adm_rules 1),
116.656 + simp_tac (HOL_basic_ss addsimps bottom_rules) 1,
116.657 + simp_tac beta_ss 1,
116.658 + simp_tac (HOL_basic_ss addsimps @{thms fst_conv snd_conv}) 1,
116.659 + simp_tac (HOL_basic_ss addsimps map_ID_simps) 1,
116.660 + REPEAT (etac @{thm conjE} 1),
116.661 + REPEAT (resolve_tac (isodefl_rules @ prems) 1 ORELSE atac 1)])
116.662 + end;
116.663 + val isodefl_binds = map (Binding.prefix_name "isodefl_") dbinds;
116.664 + fun conjuncts [] thm = []
116.665 + | conjuncts (n::[]) thm = [(n, thm)]
116.666 + | conjuncts (n::ns) thm = let
116.667 + val thmL = thm RS @{thm conjunct1};
116.668 + val thmR = thm RS @{thm conjunct2};
116.669 + in (n, thmL):: conjuncts ns thmR end;
116.670 + val (isodefl_thms, thy) = thy |>
116.671 + (Global_Theory.add_thms o map (Thm.no_attributes o apsnd Drule.zero_var_indexes))
116.672 + (conjuncts isodefl_binds isodefl_thm);
116.673 + val thy = fold (Context.theory_map o IsodeflData.add_thm) isodefl_thms thy;
116.674 +
116.675 + (* prove map_ID theorems *)
116.676 + fun prove_map_ID_thm
116.677 + (((map_const, (lhsT, _)), DEFL_thm), isodefl_thm) =
116.678 + let
116.679 + val Ts = snd (dest_Type lhsT);
116.680 + fun is_cpo T = Sign.of_sort thy (T, @{sort cpo});
116.681 + val lhs = list_ccomb (map_const, map mk_ID (filter is_cpo Ts));
116.682 + val goal = mk_eqs (lhs, mk_ID lhsT);
116.683 + val tac = EVERY
116.684 + [rtac @{thm isodefl_DEFL_imp_ID} 1,
116.685 + stac DEFL_thm 1,
116.686 + rtac isodefl_thm 1,
116.687 + REPEAT (resolve_tac @{thms isodefl_ID_DEFL isodefl_LIFTDEFL} 1)];
116.688 + in
116.689 + Goal.prove_global thy [] [] goal (K tac)
116.690 + end;
116.691 + val map_ID_binds = map (Binding.suffix_name "_map_ID") dbinds;
116.692 + val map_ID_thms =
116.693 + map prove_map_ID_thm
116.694 + (map_consts ~~ dom_eqns ~~ DEFL_thms ~~ isodefl_thms);
116.695 + val (_, thy) = thy |>
116.696 + (Global_Theory.add_thms o map (rpair [Domain_Take_Proofs.map_ID_add]))
116.697 + (map_ID_binds ~~ map_ID_thms);
116.698 +
116.699 + (* definitions and proofs related to take functions *)
116.700 + val (take_info, thy) =
116.701 + Domain_Take_Proofs.define_take_functions
116.702 + (dbinds ~~ iso_infos) thy;
116.703 + val { take_consts, chain_take_thms, take_0_thms, take_Suc_thms, ...} =
116.704 + take_info;
116.705 +
116.706 + (* least-upper-bound lemma for take functions *)
116.707 + val lub_take_lemma =
116.708 + let
116.709 + val lhs = mk_tuple (map mk_lub take_consts);
116.710 + fun is_cpo T = Sign.of_sort thy (T, @{sort cpo});
116.711 + fun mk_map_ID (map_const, (lhsT, rhsT)) =
116.712 + list_ccomb (map_const, map mk_ID (filter is_cpo (snd (dest_Type lhsT))));
116.713 + val rhs = mk_tuple (map mk_map_ID (map_consts ~~ dom_eqns));
116.714 + val goal = mk_trp (mk_eq (lhs, rhs));
116.715 + val map_ID_thms = Domain_Take_Proofs.get_map_ID_thms thy;
116.716 + val start_rules =
116.717 + @{thms lub_Pair [symmetric] ch2ch_Pair} @ chain_take_thms
116.718 + @ @{thms pair_collapse split_def}
116.719 + @ map_apply_thms @ map_ID_thms;
116.720 + val rules0 =
116.721 + @{thms iterate_0 Pair_strict} @ take_0_thms;
116.722 + val rules1 =
116.723 + @{thms iterate_Suc Pair_fst_snd_eq fst_conv snd_conv}
116.724 + @ take_Suc_thms;
116.725 + val tac =
116.726 + EVERY
116.727 + [simp_tac (HOL_basic_ss addsimps start_rules) 1,
116.728 + simp_tac (HOL_basic_ss addsimps @{thms fix_def2}) 1,
116.729 + rtac @{thm lub_eq} 1,
116.730 + rtac @{thm nat.induct} 1,
116.731 + simp_tac (HOL_basic_ss addsimps rules0) 1,
116.732 + asm_full_simp_tac (beta_ss addsimps rules1) 1];
116.733 + in
116.734 + Goal.prove_global thy [] [] goal (K tac)
116.735 + end;
116.736 +
116.737 + (* prove lub of take equals ID *)
116.738 + fun prove_lub_take (((dbind, take_const), map_ID_thm), (lhsT, rhsT)) thy =
116.739 + let
116.740 + val n = Free ("n", natT);
116.741 + val goal = mk_eqs (mk_lub (lambda n (take_const $ n)), mk_ID lhsT);
116.742 + val tac =
116.743 + EVERY
116.744 + [rtac @{thm trans} 1, rtac map_ID_thm 2,
116.745 + cut_facts_tac [lub_take_lemma] 1,
116.746 + REPEAT (etac @{thm Pair_inject} 1), atac 1];
116.747 + val lub_take_thm = Goal.prove_global thy [] [] goal (K tac);
116.748 + in
116.749 + add_qualified_thm "lub_take" (dbind, lub_take_thm) thy
116.750 + end;
116.751 + val (lub_take_thms, thy) =
116.752 + fold_map prove_lub_take
116.753 + (dbinds ~~ take_consts ~~ map_ID_thms ~~ dom_eqns) thy;
116.754 +
116.755 + (* prove additional take theorems *)
116.756 + val (take_info2, thy) =
116.757 + Domain_Take_Proofs.add_lub_take_theorems
116.758 + (dbinds ~~ iso_infos) take_info lub_take_thms thy;
116.759 + in
116.760 + ((iso_infos, take_info2), thy)
116.761 + end;
116.762 +
116.763 +val domain_isomorphism = gen_domain_isomorphism cert_typ;
116.764 +val domain_isomorphism_cmd = snd oo gen_domain_isomorphism read_typ;
116.765 +
116.766 +(******************************************************************************)
116.767 +(******************************** outer syntax ********************************)
116.768 +(******************************************************************************)
116.769 +
116.770 +local
116.771 +
116.772 +val parse_domain_iso :
116.773 + (string list * binding * mixfix * string * (binding * binding) option)
116.774 + parser =
116.775 + (Parse.type_args -- Parse.binding -- Parse.opt_mixfix -- (Parse.$$$ "=" |-- Parse.typ) --
116.776 + Scan.option (Parse.$$$ "morphisms" |-- Parse.!!! (Parse.binding -- Parse.binding)))
116.777 + >> (fn ((((vs, t), mx), rhs), morphs) => (vs, t, mx, rhs, morphs));
116.778 +
116.779 +val parse_domain_isos = Parse.and_list1 parse_domain_iso;
116.780 +
116.781 +in
116.782 +
116.783 +val _ =
116.784 + Outer_Syntax.command "domain_isomorphism" "define domain isomorphisms (HOLCF)"
116.785 + Keyword.thy_decl
116.786 + (parse_domain_isos >> (Toplevel.theory o domain_isomorphism_cmd));
116.787 +
116.788 +end;
116.789 +
116.790 +end;
117.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
117.2 +++ b/src/HOL/HOLCF/Tools/Domain/domain_take_proofs.ML Sat Nov 27 16:08:10 2010 -0800
117.3 @@ -0,0 +1,609 @@
117.4 +(* Title: HOLCF/Tools/Domain/domain_take_proofs.ML
117.5 + Author: Brian Huffman
117.6 +
117.7 +Defines take functions for the given domain equation
117.8 +and proves related theorems.
117.9 +*)
117.10 +
117.11 +signature DOMAIN_TAKE_PROOFS =
117.12 +sig
117.13 + type iso_info =
117.14 + {
117.15 + absT : typ,
117.16 + repT : typ,
117.17 + abs_const : term,
117.18 + rep_const : term,
117.19 + abs_inverse : thm,
117.20 + rep_inverse : thm
117.21 + }
117.22 + type take_info =
117.23 + {
117.24 + take_consts : term list,
117.25 + take_defs : thm list,
117.26 + chain_take_thms : thm list,
117.27 + take_0_thms : thm list,
117.28 + take_Suc_thms : thm list,
117.29 + deflation_take_thms : thm list,
117.30 + take_strict_thms : thm list,
117.31 + finite_consts : term list,
117.32 + finite_defs : thm list
117.33 + }
117.34 + type take_induct_info =
117.35 + {
117.36 + take_consts : term list,
117.37 + take_defs : thm list,
117.38 + chain_take_thms : thm list,
117.39 + take_0_thms : thm list,
117.40 + take_Suc_thms : thm list,
117.41 + deflation_take_thms : thm list,
117.42 + take_strict_thms : thm list,
117.43 + finite_consts : term list,
117.44 + finite_defs : thm list,
117.45 + lub_take_thms : thm list,
117.46 + reach_thms : thm list,
117.47 + take_lemma_thms : thm list,
117.48 + is_finite : bool,
117.49 + take_induct_thms : thm list
117.50 + }
117.51 + val define_take_functions :
117.52 + (binding * iso_info) list -> theory -> take_info * theory
117.53 +
117.54 + val add_lub_take_theorems :
117.55 + (binding * iso_info) list -> take_info -> thm list ->
117.56 + theory -> take_induct_info * theory
117.57 +
117.58 + val map_of_typ :
117.59 + theory -> (typ * term) list -> typ -> term
117.60 +
117.61 + val add_rec_type : (string * bool list) -> theory -> theory
117.62 + val get_rec_tab : theory -> (bool list) Symtab.table
117.63 + val add_deflation_thm : thm -> theory -> theory
117.64 + val get_deflation_thms : theory -> thm list
117.65 + val map_ID_add : attribute
117.66 + val get_map_ID_thms : theory -> thm list
117.67 + val setup : theory -> theory
117.68 +end;
117.69 +
117.70 +structure Domain_Take_Proofs : DOMAIN_TAKE_PROOFS =
117.71 +struct
117.72 +
117.73 +type iso_info =
117.74 + {
117.75 + absT : typ,
117.76 + repT : typ,
117.77 + abs_const : term,
117.78 + rep_const : term,
117.79 + abs_inverse : thm,
117.80 + rep_inverse : thm
117.81 + };
117.82 +
117.83 +type take_info =
117.84 + { take_consts : term list,
117.85 + take_defs : thm list,
117.86 + chain_take_thms : thm list,
117.87 + take_0_thms : thm list,
117.88 + take_Suc_thms : thm list,
117.89 + deflation_take_thms : thm list,
117.90 + take_strict_thms : thm list,
117.91 + finite_consts : term list,
117.92 + finite_defs : thm list
117.93 + };
117.94 +
117.95 +type take_induct_info =
117.96 + {
117.97 + take_consts : term list,
117.98 + take_defs : thm list,
117.99 + chain_take_thms : thm list,
117.100 + take_0_thms : thm list,
117.101 + take_Suc_thms : thm list,
117.102 + deflation_take_thms : thm list,
117.103 + take_strict_thms : thm list,
117.104 + finite_consts : term list,
117.105 + finite_defs : thm list,
117.106 + lub_take_thms : thm list,
117.107 + reach_thms : thm list,
117.108 + take_lemma_thms : thm list,
117.109 + is_finite : bool,
117.110 + take_induct_thms : thm list
117.111 + };
117.112 +
117.113 +val beta_rules =
117.114 + @{thms beta_cfun cont_id cont_const cont2cont_APP cont2cont_LAM'} @
117.115 + @{thms cont2cont_fst cont2cont_snd cont2cont_Pair};
117.116 +
117.117 +val beta_ss = HOL_basic_ss addsimps (simp_thms @ beta_rules);
117.118 +
117.119 +val beta_tac = simp_tac beta_ss;
117.120 +
117.121 +(******************************************************************************)
117.122 +(******************************** theory data *********************************)
117.123 +(******************************************************************************)
117.124 +
117.125 +structure Rec_Data = Theory_Data
117.126 +(
117.127 + (* list indicates which type arguments allow indirect recursion *)
117.128 + type T = (bool list) Symtab.table;
117.129 + val empty = Symtab.empty;
117.130 + val extend = I;
117.131 + fun merge data = Symtab.merge (K true) data;
117.132 +);
117.133 +
117.134 +structure DeflMapData = Named_Thms
117.135 +(
117.136 + val name = "domain_deflation"
117.137 + val description = "theorems like deflation a ==> deflation (foo_map$a)"
117.138 +);
117.139 +
117.140 +structure Map_Id_Data = Named_Thms
117.141 +(
117.142 + val name = "domain_map_ID"
117.143 + val description = "theorems like foo_map$ID = ID"
117.144 +);
117.145 +
117.146 +fun add_rec_type (tname, bs) =
117.147 + Rec_Data.map (Symtab.insert (K true) (tname, bs));
117.148 +
117.149 +fun add_deflation_thm thm =
117.150 + Context.theory_map (DeflMapData.add_thm thm);
117.151 +
117.152 +val get_rec_tab = Rec_Data.get;
117.153 +fun get_deflation_thms thy = DeflMapData.get (ProofContext.init_global thy);
117.154 +
117.155 +val map_ID_add = Map_Id_Data.add;
117.156 +val get_map_ID_thms = Map_Id_Data.get o ProofContext.init_global;
117.157 +
117.158 +val setup = DeflMapData.setup #> Map_Id_Data.setup;
117.159 +
117.160 +(******************************************************************************)
117.161 +(************************** building types and terms **************************)
117.162 +(******************************************************************************)
117.163 +
117.164 +open HOLCF_Library;
117.165 +
117.166 +infixr 6 ->>;
117.167 +infix -->>;
117.168 +infix 9 `;
117.169 +
117.170 +fun mapT (T as Type (_, Ts)) =
117.171 + (map (fn T => T ->> T) Ts) -->> (T ->> T)
117.172 + | mapT T = T ->> T;
117.173 +
117.174 +fun mk_deflation t =
117.175 + Const (@{const_name deflation}, Term.fastype_of t --> boolT) $ t;
117.176 +
117.177 +fun mk_eqs (t, u) = HOLogic.mk_Trueprop (HOLogic.mk_eq (t, u));
117.178 +
117.179 +(******************************************************************************)
117.180 +(****************************** isomorphism info ******************************)
117.181 +(******************************************************************************)
117.182 +
117.183 +fun deflation_abs_rep (info : iso_info) : thm =
117.184 + let
117.185 + val abs_iso = #abs_inverse info;
117.186 + val rep_iso = #rep_inverse info;
117.187 + val thm = @{thm deflation_abs_rep} OF [abs_iso, rep_iso];
117.188 + in
117.189 + Drule.zero_var_indexes thm
117.190 + end
117.191 +
117.192 +(******************************************************************************)
117.193 +(********************* building map functions over types **********************)
117.194 +(******************************************************************************)
117.195 +
117.196 +fun map_of_typ (thy : theory) (sub : (typ * term) list) (T : typ) : term =
117.197 + let
117.198 + val thms = get_map_ID_thms thy;
117.199 + val rules = map (Thm.concl_of #> HOLogic.dest_Trueprop #> HOLogic.dest_eq) thms;
117.200 + val rules' = map (apfst mk_ID) sub @ map swap rules;
117.201 + in
117.202 + mk_ID T
117.203 + |> Pattern.rewrite_term thy rules' []
117.204 + |> Pattern.rewrite_term thy rules []
117.205 + end;
117.206 +
117.207 +(******************************************************************************)
117.208 +(********************* declaring definitions and theorems *********************)
117.209 +(******************************************************************************)
117.210 +
117.211 +fun add_qualified_def name (dbind, eqn) =
117.212 + yield_singleton (Global_Theory.add_defs false)
117.213 + ((Binding.qualified true name dbind, eqn), []);
117.214 +
117.215 +fun add_qualified_thm name (dbind, thm) =
117.216 + yield_singleton Global_Theory.add_thms
117.217 + ((Binding.qualified true name dbind, thm), []);
117.218 +
117.219 +fun add_qualified_simp_thm name (dbind, thm) =
117.220 + yield_singleton Global_Theory.add_thms
117.221 + ((Binding.qualified true name dbind, thm), [Simplifier.simp_add]);
117.222 +
117.223 +(******************************************************************************)
117.224 +(************************** defining take functions ***************************)
117.225 +(******************************************************************************)
117.226 +
117.227 +fun define_take_functions
117.228 + (spec : (binding * iso_info) list)
117.229 + (thy : theory) =
117.230 + let
117.231 +
117.232 + (* retrieve components of spec *)
117.233 + val dbinds = map fst spec;
117.234 + val iso_infos = map snd spec;
117.235 + val dom_eqns = map (fn x => (#absT x, #repT x)) iso_infos;
117.236 + val rep_abs_consts = map (fn x => (#rep_const x, #abs_const x)) iso_infos;
117.237 +
117.238 + fun mk_projs [] t = []
117.239 + | mk_projs (x::[]) t = [(x, t)]
117.240 + | mk_projs (x::xs) t = (x, mk_fst t) :: mk_projs xs (mk_snd t);
117.241 +
117.242 + fun mk_cfcomp2 ((rep_const, abs_const), f) =
117.243 + mk_cfcomp (abs_const, mk_cfcomp (f, rep_const));
117.244 +
117.245 + (* define take functional *)
117.246 + val newTs : typ list = map fst dom_eqns;
117.247 + val copy_arg_type = mk_tupleT (map (fn T => T ->> T) newTs);
117.248 + val copy_arg = Free ("f", copy_arg_type);
117.249 + val copy_args = map snd (mk_projs dbinds copy_arg);
117.250 + fun one_copy_rhs (rep_abs, (lhsT, rhsT)) =
117.251 + let
117.252 + val body = map_of_typ thy (newTs ~~ copy_args) rhsT;
117.253 + in
117.254 + mk_cfcomp2 (rep_abs, body)
117.255 + end;
117.256 + val take_functional =
117.257 + big_lambda copy_arg
117.258 + (mk_tuple (map one_copy_rhs (rep_abs_consts ~~ dom_eqns)));
117.259 + val take_rhss =
117.260 + let
117.261 + val n = Free ("n", HOLogic.natT);
117.262 + val rhs = mk_iterate (n, take_functional);
117.263 + in
117.264 + map (lambda n o snd) (mk_projs dbinds rhs)
117.265 + end;
117.266 +
117.267 + (* define take constants *)
117.268 + fun define_take_const ((dbind, take_rhs), (lhsT, rhsT)) thy =
117.269 + let
117.270 + val take_type = HOLogic.natT --> lhsT ->> lhsT;
117.271 + val take_bind = Binding.suffix_name "_take" dbind;
117.272 + val (take_const, thy) =
117.273 + Sign.declare_const ((take_bind, take_type), NoSyn) thy;
117.274 + val take_eqn = Logic.mk_equals (take_const, take_rhs);
117.275 + val (take_def_thm, thy) =
117.276 + add_qualified_def "take_def" (dbind, take_eqn) thy;
117.277 + in ((take_const, take_def_thm), thy) end;
117.278 + val ((take_consts, take_defs), thy) = thy
117.279 + |> fold_map define_take_const (dbinds ~~ take_rhss ~~ dom_eqns)
117.280 + |>> ListPair.unzip;
117.281 +
117.282 + (* prove chain_take lemmas *)
117.283 + fun prove_chain_take (take_const, dbind) thy =
117.284 + let
117.285 + val goal = mk_trp (mk_chain take_const);
117.286 + val rules = take_defs @ @{thms chain_iterate ch2ch_fst ch2ch_snd};
117.287 + val tac = simp_tac (HOL_basic_ss addsimps rules) 1;
117.288 + val thm = Goal.prove_global thy [] [] goal (K tac);
117.289 + in
117.290 + add_qualified_simp_thm "chain_take" (dbind, thm) thy
117.291 + end;
117.292 + val (chain_take_thms, thy) =
117.293 + fold_map prove_chain_take (take_consts ~~ dbinds) thy;
117.294 +
117.295 + (* prove take_0 lemmas *)
117.296 + fun prove_take_0 ((take_const, dbind), (lhsT, rhsT)) thy =
117.297 + let
117.298 + val lhs = take_const $ @{term "0::nat"};
117.299 + val goal = mk_eqs (lhs, mk_bottom (lhsT ->> lhsT));
117.300 + val rules = take_defs @ @{thms iterate_0 fst_strict snd_strict};
117.301 + val tac = simp_tac (HOL_basic_ss addsimps rules) 1;
117.302 + val take_0_thm = Goal.prove_global thy [] [] goal (K tac);
117.303 + in
117.304 + add_qualified_simp_thm "take_0" (dbind, take_0_thm) thy
117.305 + end;
117.306 + val (take_0_thms, thy) =
117.307 + fold_map prove_take_0 (take_consts ~~ dbinds ~~ dom_eqns) thy;
117.308 +
117.309 + (* prove take_Suc lemmas *)
117.310 + val n = Free ("n", natT);
117.311 + val take_is = map (fn t => t $ n) take_consts;
117.312 + fun prove_take_Suc
117.313 + (((take_const, rep_abs), dbind), (lhsT, rhsT)) thy =
117.314 + let
117.315 + val lhs = take_const $ (@{term Suc} $ n);
117.316 + val body = map_of_typ thy (newTs ~~ take_is) rhsT;
117.317 + val rhs = mk_cfcomp2 (rep_abs, body);
117.318 + val goal = mk_eqs (lhs, rhs);
117.319 + val simps = @{thms iterate_Suc fst_conv snd_conv}
117.320 + val rules = take_defs @ simps;
117.321 + val tac = simp_tac (beta_ss addsimps rules) 1;
117.322 + val take_Suc_thm = Goal.prove_global thy [] [] goal (K tac);
117.323 + in
117.324 + add_qualified_thm "take_Suc" (dbind, take_Suc_thm) thy
117.325 + end;
117.326 + val (take_Suc_thms, thy) =
117.327 + fold_map prove_take_Suc
117.328 + (take_consts ~~ rep_abs_consts ~~ dbinds ~~ dom_eqns) thy;
117.329 +
117.330 + (* prove deflation theorems for take functions *)
117.331 + val deflation_abs_rep_thms = map deflation_abs_rep iso_infos;
117.332 + val deflation_take_thm =
117.333 + let
117.334 + val n = Free ("n", natT);
117.335 + fun mk_goal take_const = mk_deflation (take_const $ n);
117.336 + val goal = mk_trp (foldr1 mk_conj (map mk_goal take_consts));
117.337 + val adm_rules =
117.338 + @{thms adm_conj adm_subst [OF _ adm_deflation]
117.339 + cont2cont_fst cont2cont_snd cont_id};
117.340 + val bottom_rules =
117.341 + take_0_thms @ @{thms deflation_UU simp_thms};
117.342 + val deflation_rules =
117.343 + @{thms conjI deflation_ID}
117.344 + @ deflation_abs_rep_thms
117.345 + @ get_deflation_thms thy;
117.346 + in
117.347 + Goal.prove_global thy [] [] goal (fn _ =>
117.348 + EVERY
117.349 + [rtac @{thm nat.induct} 1,
117.350 + simp_tac (HOL_basic_ss addsimps bottom_rules) 1,
117.351 + asm_simp_tac (HOL_basic_ss addsimps take_Suc_thms) 1,
117.352 + REPEAT (etac @{thm conjE} 1
117.353 + ORELSE resolve_tac deflation_rules 1
117.354 + ORELSE atac 1)])
117.355 + end;
117.356 + fun conjuncts [] thm = []
117.357 + | conjuncts (n::[]) thm = [(n, thm)]
117.358 + | conjuncts (n::ns) thm = let
117.359 + val thmL = thm RS @{thm conjunct1};
117.360 + val thmR = thm RS @{thm conjunct2};
117.361 + in (n, thmL):: conjuncts ns thmR end;
117.362 + val (deflation_take_thms, thy) =
117.363 + fold_map (add_qualified_thm "deflation_take")
117.364 + (map (apsnd Drule.zero_var_indexes)
117.365 + (conjuncts dbinds deflation_take_thm)) thy;
117.366 +
117.367 + (* prove strictness of take functions *)
117.368 + fun prove_take_strict (deflation_take, dbind) thy =
117.369 + let
117.370 + val take_strict_thm =
117.371 + Drule.zero_var_indexes
117.372 + (@{thm deflation_strict} OF [deflation_take]);
117.373 + in
117.374 + add_qualified_simp_thm "take_strict" (dbind, take_strict_thm) thy
117.375 + end;
117.376 + val (take_strict_thms, thy) =
117.377 + fold_map prove_take_strict
117.378 + (deflation_take_thms ~~ dbinds) thy;
117.379 +
117.380 + (* prove take/take rules *)
117.381 + fun prove_take_take ((chain_take, deflation_take), dbind) thy =
117.382 + let
117.383 + val take_take_thm =
117.384 + Drule.zero_var_indexes
117.385 + (@{thm deflation_chain_min} OF [chain_take, deflation_take]);
117.386 + in
117.387 + add_qualified_thm "take_take" (dbind, take_take_thm) thy
117.388 + end;
117.389 + val (take_take_thms, thy) =
117.390 + fold_map prove_take_take
117.391 + (chain_take_thms ~~ deflation_take_thms ~~ dbinds) thy;
117.392 +
117.393 + (* prove take_below rules *)
117.394 + fun prove_take_below (deflation_take, dbind) thy =
117.395 + let
117.396 + val take_below_thm =
117.397 + Drule.zero_var_indexes
117.398 + (@{thm deflation.below} OF [deflation_take]);
117.399 + in
117.400 + add_qualified_thm "take_below" (dbind, take_below_thm) thy
117.401 + end;
117.402 + val (take_below_thms, thy) =
117.403 + fold_map prove_take_below
117.404 + (deflation_take_thms ~~ dbinds) thy;
117.405 +
117.406 + (* define finiteness predicates *)
117.407 + fun define_finite_const ((dbind, take_const), (lhsT, rhsT)) thy =
117.408 + let
117.409 + val finite_type = lhsT --> boolT;
117.410 + val finite_bind = Binding.suffix_name "_finite" dbind;
117.411 + val (finite_const, thy) =
117.412 + Sign.declare_const ((finite_bind, finite_type), NoSyn) thy;
117.413 + val x = Free ("x", lhsT);
117.414 + val n = Free ("n", natT);
117.415 + val finite_rhs =
117.416 + lambda x (HOLogic.exists_const natT $
117.417 + (lambda n (mk_eq (mk_capply (take_const $ n, x), x))));
117.418 + val finite_eqn = Logic.mk_equals (finite_const, finite_rhs);
117.419 + val (finite_def_thm, thy) =
117.420 + add_qualified_def "finite_def" (dbind, finite_eqn) thy;
117.421 + in ((finite_const, finite_def_thm), thy) end;
117.422 + val ((finite_consts, finite_defs), thy) = thy
117.423 + |> fold_map define_finite_const (dbinds ~~ take_consts ~~ dom_eqns)
117.424 + |>> ListPair.unzip;
117.425 +
117.426 + val result =
117.427 + {
117.428 + take_consts = take_consts,
117.429 + take_defs = take_defs,
117.430 + chain_take_thms = chain_take_thms,
117.431 + take_0_thms = take_0_thms,
117.432 + take_Suc_thms = take_Suc_thms,
117.433 + deflation_take_thms = deflation_take_thms,
117.434 + take_strict_thms = take_strict_thms,
117.435 + finite_consts = finite_consts,
117.436 + finite_defs = finite_defs
117.437 + };
117.438 +
117.439 + in
117.440 + (result, thy)
117.441 + end;
117.442 +
117.443 +fun prove_finite_take_induct
117.444 + (spec : (binding * iso_info) list)
117.445 + (take_info : take_info)
117.446 + (lub_take_thms : thm list)
117.447 + (thy : theory) =
117.448 + let
117.449 + val dbinds = map fst spec;
117.450 + val iso_infos = map snd spec;
117.451 + val absTs = map #absT iso_infos;
117.452 + val {take_consts, ...} = take_info;
117.453 + val {chain_take_thms, take_0_thms, take_Suc_thms, ...} = take_info;
117.454 + val {finite_consts, finite_defs, ...} = take_info;
117.455 +
117.456 + val decisive_lemma =
117.457 + let
117.458 + fun iso_locale (info : iso_info) =
117.459 + @{thm iso.intro} OF [#abs_inverse info, #rep_inverse info];
117.460 + val iso_locale_thms = map iso_locale iso_infos;
117.461 + val decisive_abs_rep_thms =
117.462 + map (fn x => @{thm decisive_abs_rep} OF [x]) iso_locale_thms;
117.463 + val n = Free ("n", @{typ nat});
117.464 + fun mk_decisive t =
117.465 + Const (@{const_name decisive}, fastype_of t --> boolT) $ t;
117.466 + fun f take_const = mk_decisive (take_const $ n);
117.467 + val goal = mk_trp (foldr1 mk_conj (map f take_consts));
117.468 + val rules0 = @{thm decisive_bottom} :: take_0_thms;
117.469 + val rules1 =
117.470 + take_Suc_thms @ decisive_abs_rep_thms
117.471 + @ @{thms decisive_ID decisive_ssum_map decisive_sprod_map};
117.472 + val tac = EVERY [
117.473 + rtac @{thm nat.induct} 1,
117.474 + simp_tac (HOL_ss addsimps rules0) 1,
117.475 + asm_simp_tac (HOL_ss addsimps rules1) 1];
117.476 + in Goal.prove_global thy [] [] goal (K tac) end;
117.477 + fun conjuncts 1 thm = [thm]
117.478 + | conjuncts n thm = let
117.479 + val thmL = thm RS @{thm conjunct1};
117.480 + val thmR = thm RS @{thm conjunct2};
117.481 + in thmL :: conjuncts (n-1) thmR end;
117.482 + val decisive_thms = conjuncts (length spec) decisive_lemma;
117.483 +
117.484 + fun prove_finite_thm (absT, finite_const) =
117.485 + let
117.486 + val goal = mk_trp (finite_const $ Free ("x", absT));
117.487 + val tac =
117.488 + EVERY [
117.489 + rewrite_goals_tac finite_defs,
117.490 + rtac @{thm lub_ID_finite} 1,
117.491 + resolve_tac chain_take_thms 1,
117.492 + resolve_tac lub_take_thms 1,
117.493 + resolve_tac decisive_thms 1];
117.494 + in
117.495 + Goal.prove_global thy [] [] goal (K tac)
117.496 + end;
117.497 + val finite_thms =
117.498 + map prove_finite_thm (absTs ~~ finite_consts);
117.499 +
117.500 + fun prove_take_induct ((ch_take, lub_take), decisive) =
117.501 + Drule.export_without_context
117.502 + (@{thm lub_ID_finite_take_induct} OF [ch_take, lub_take, decisive]);
117.503 + val take_induct_thms =
117.504 + map prove_take_induct
117.505 + (chain_take_thms ~~ lub_take_thms ~~ decisive_thms);
117.506 +
117.507 + val thy = thy
117.508 + |> fold (snd oo add_qualified_thm "finite")
117.509 + (dbinds ~~ finite_thms)
117.510 + |> fold (snd oo add_qualified_thm "take_induct")
117.511 + (dbinds ~~ take_induct_thms);
117.512 + in
117.513 + ((finite_thms, take_induct_thms), thy)
117.514 + end;
117.515 +
117.516 +fun add_lub_take_theorems
117.517 + (spec : (binding * iso_info) list)
117.518 + (take_info : take_info)
117.519 + (lub_take_thms : thm list)
117.520 + (thy : theory) =
117.521 + let
117.522 +
117.523 + (* retrieve components of spec *)
117.524 + val dbinds = map fst spec;
117.525 + val iso_infos = map snd spec;
117.526 + val absTs = map #absT iso_infos;
117.527 + val repTs = map #repT iso_infos;
117.528 + val {take_consts, take_0_thms, take_Suc_thms, ...} = take_info;
117.529 + val {chain_take_thms, deflation_take_thms, ...} = take_info;
117.530 +
117.531 + (* prove take lemmas *)
117.532 + fun prove_take_lemma ((chain_take, lub_take), dbind) thy =
117.533 + let
117.534 + val take_lemma =
117.535 + Drule.export_without_context
117.536 + (@{thm lub_ID_take_lemma} OF [chain_take, lub_take]);
117.537 + in
117.538 + add_qualified_thm "take_lemma" (dbind, take_lemma) thy
117.539 + end;
117.540 + val (take_lemma_thms, thy) =
117.541 + fold_map prove_take_lemma
117.542 + (chain_take_thms ~~ lub_take_thms ~~ dbinds) thy;
117.543 +
117.544 + (* prove reach lemmas *)
117.545 + fun prove_reach_lemma ((chain_take, lub_take), dbind) thy =
117.546 + let
117.547 + val thm =
117.548 + Drule.zero_var_indexes
117.549 + (@{thm lub_ID_reach} OF [chain_take, lub_take]);
117.550 + in
117.551 + add_qualified_thm "reach" (dbind, thm) thy
117.552 + end;
117.553 + val (reach_thms, thy) =
117.554 + fold_map prove_reach_lemma
117.555 + (chain_take_thms ~~ lub_take_thms ~~ dbinds) thy;
117.556 +
117.557 + (* test for finiteness of domain definitions *)
117.558 + local
117.559 + val types = [@{type_name ssum}, @{type_name sprod}];
117.560 + fun finite d T = if member (op =) absTs T then d else finite' d T
117.561 + and finite' d (Type (c, Ts)) =
117.562 + let val d' = d andalso member (op =) types c;
117.563 + in forall (finite d') Ts end
117.564 + | finite' d _ = true;
117.565 + in
117.566 + val is_finite = forall (finite true) repTs;
117.567 + end;
117.568 +
117.569 + val ((finite_thms, take_induct_thms), thy) =
117.570 + if is_finite
117.571 + then
117.572 + let
117.573 + val ((finites, take_inducts), thy) =
117.574 + prove_finite_take_induct spec take_info lub_take_thms thy;
117.575 + in
117.576 + ((SOME finites, take_inducts), thy)
117.577 + end
117.578 + else
117.579 + let
117.580 + fun prove_take_induct (chain_take, lub_take) =
117.581 + Drule.zero_var_indexes
117.582 + (@{thm lub_ID_take_induct} OF [chain_take, lub_take]);
117.583 + val take_inducts =
117.584 + map prove_take_induct (chain_take_thms ~~ lub_take_thms);
117.585 + val thy = fold (snd oo add_qualified_thm "take_induct")
117.586 + (dbinds ~~ take_inducts) thy;
117.587 + in
117.588 + ((NONE, take_inducts), thy)
117.589 + end;
117.590 +
117.591 + val result =
117.592 + {
117.593 + take_consts = #take_consts take_info,
117.594 + take_defs = #take_defs take_info,
117.595 + chain_take_thms = #chain_take_thms take_info,
117.596 + take_0_thms = #take_0_thms take_info,
117.597 + take_Suc_thms = #take_Suc_thms take_info,
117.598 + deflation_take_thms = #deflation_take_thms take_info,
117.599 + take_strict_thms = #take_strict_thms take_info,
117.600 + finite_consts = #finite_consts take_info,
117.601 + finite_defs = #finite_defs take_info,
117.602 + lub_take_thms = lub_take_thms,
117.603 + reach_thms = reach_thms,
117.604 + take_lemma_thms = take_lemma_thms,
117.605 + is_finite = is_finite,
117.606 + take_induct_thms = take_induct_thms
117.607 + };
117.608 + in
117.609 + (result, thy)
117.610 + end;
117.611 +
117.612 +end;
118.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
118.2 +++ b/src/HOL/HOLCF/Tools/cont_consts.ML Sat Nov 27 16:08:10 2010 -0800
118.3 @@ -0,0 +1,93 @@
118.4 +(* Title: HOLCF/Tools/cont_consts.ML
118.5 + Author: Tobias Mayr, David von Oheimb, and Markus Wenzel
118.6 +
118.7 +HOLCF version of consts: handle continuous function types in mixfix
118.8 +syntax.
118.9 +*)
118.10 +
118.11 +signature CONT_CONSTS =
118.12 +sig
118.13 + val add_consts: (binding * typ * mixfix) list -> theory -> theory
118.14 + val add_consts_cmd: (binding * string * mixfix) list -> theory -> theory
118.15 +end;
118.16 +
118.17 +structure Cont_Consts: CONT_CONSTS =
118.18 +struct
118.19 +
118.20 +
118.21 +(* misc utils *)
118.22 +
118.23 +fun change_arrow 0 T = T
118.24 + | change_arrow n (Type (_, [S, T])) = Type ("fun", [S, change_arrow (n - 1) T])
118.25 + | change_arrow _ T = raise TYPE ("cont_consts: change_arrow", [T], []);
118.26 +
118.27 +fun trans_rules name2 name1 n mx =
118.28 + let
118.29 + val vnames = Name.invents Name.context "a" n;
118.30 + val extra_parse_rule = Syntax.ParseRule (Constant name2, Constant name1);
118.31 + in
118.32 + [Syntax.ParsePrintRule
118.33 + (Syntax.mk_appl (Constant name2) (map Variable vnames),
118.34 + fold (fn a => fn t => Syntax.mk_appl (Constant @{const_syntax Rep_cfun}) [t, Variable a])
118.35 + vnames (Constant name1))] @
118.36 + (case mx of
118.37 + Infix _ => [extra_parse_rule]
118.38 + | Infixl _ => [extra_parse_rule]
118.39 + | Infixr _ => [extra_parse_rule]
118.40 + | _ => [])
118.41 + end;
118.42 +
118.43 +
118.44 +(* transforming infix/mixfix declarations of constants with type ...->...
118.45 + a declaration of such a constant is transformed to a normal declaration with
118.46 + an internal name, the same type, and nofix. Additionally, a purely syntactic
118.47 + declaration with the original name, type ...=>..., and the original mixfix
118.48 + is generated and connected to the other declaration via some translation.
118.49 +*)
118.50 +fun transform thy (c, T, mx) =
118.51 + let
118.52 + fun syntax b = Syntax.mark_const (Sign.full_bname thy b);
118.53 + val c1 = Binding.name_of c;
118.54 + val c2 = c1 ^ "_cont_syntax";
118.55 + val n = Syntax.mixfix_args mx;
118.56 + in
118.57 + ((c, T, NoSyn),
118.58 + (Binding.name c2, change_arrow n T, mx),
118.59 + trans_rules (syntax c2) (syntax c1) n mx)
118.60 + end;
118.61 +
118.62 +fun cfun_arity (Type (n, [_, T])) = if n = @{type_name cfun} then 1 + cfun_arity T else 0
118.63 + | cfun_arity _ = 0;
118.64 +
118.65 +fun is_contconst (_, _, NoSyn) = false
118.66 + | is_contconst (_, _, Binder _) = false (* FIXME ? *)
118.67 + | is_contconst (c, T, mx) =
118.68 + let
118.69 + val n = Syntax.mixfix_args mx handle ERROR msg =>
118.70 + cat_error msg ("in mixfix annotation for " ^ quote (Binding.str_of c));
118.71 + in cfun_arity T >= n end;
118.72 +
118.73 +
118.74 +(* add_consts *)
118.75 +
118.76 +local
118.77 +
118.78 +fun gen_add_consts prep_typ raw_decls thy =
118.79 + let
118.80 + val decls = map (fn (c, T, mx) => (c, prep_typ thy T, mx)) raw_decls;
118.81 + val (contconst_decls, normal_decls) = List.partition is_contconst decls;
118.82 + val transformed_decls = map (transform thy) contconst_decls;
118.83 + in
118.84 + thy
118.85 + |> Sign.add_consts_i (normal_decls @ map #1 transformed_decls @ map #2 transformed_decls)
118.86 + |> Sign.add_trrules_i (maps #3 transformed_decls)
118.87 + end;
118.88 +
118.89 +in
118.90 +
118.91 +val add_consts = gen_add_consts Sign.certify_typ;
118.92 +val add_consts_cmd = gen_add_consts Syntax.read_typ_global;
118.93 +
118.94 +end;
118.95 +
118.96 +end;
119.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
119.2 +++ b/src/HOL/HOLCF/Tools/cont_proc.ML Sat Nov 27 16:08:10 2010 -0800
119.3 @@ -0,0 +1,136 @@
119.4 +(* Title: HOLCF/Tools/cont_proc.ML
119.5 + Author: Brian Huffman
119.6 +*)
119.7 +
119.8 +signature CONT_PROC =
119.9 +sig
119.10 + val is_lcf_term: term -> bool
119.11 + val cont_thms: term -> thm list
119.12 + val all_cont_thms: term -> thm list
119.13 + val cont_tac: int -> tactic
119.14 + val cont_proc: theory -> simproc
119.15 + val setup: theory -> theory
119.16 +end;
119.17 +
119.18 +structure ContProc :> CONT_PROC =
119.19 +struct
119.20 +
119.21 +(** theory context references **)
119.22 +
119.23 +val cont_K = @{thm cont_const};
119.24 +val cont_I = @{thm cont_id};
119.25 +val cont_A = @{thm cont2cont_APP};
119.26 +val cont_L = @{thm cont2cont_LAM};
119.27 +val cont_R = @{thm cont_Rep_cfun2};
119.28 +
119.29 +(* checks whether a term contains no dangling bound variables *)
119.30 +fun is_closed_term t = not (Term.loose_bvar (t, 0));
119.31 +
119.32 +(* checks whether a term is written entirely in the LCF sublanguage *)
119.33 +fun is_lcf_term (Const (@{const_name Rep_cfun}, _) $ t $ u) =
119.34 + is_lcf_term t andalso is_lcf_term u
119.35 + | is_lcf_term (Const (@{const_name Abs_cfun}, _) $ Abs (_, _, t)) =
119.36 + is_lcf_term t
119.37 + | is_lcf_term (Const (@{const_name Abs_cfun}, _) $ t) =
119.38 + is_lcf_term (Term.incr_boundvars 1 t $ Bound 0)
119.39 + | is_lcf_term (Bound _) = true
119.40 + | is_lcf_term t = is_closed_term t;
119.41 +
119.42 +(*
119.43 + efficiently generates a cont thm for every LAM abstraction in a term,
119.44 + using forward proof and reusing common subgoals
119.45 +*)
119.46 +local
119.47 + fun var 0 = [SOME cont_I]
119.48 + | var n = NONE :: var (n-1);
119.49 +
119.50 + fun k NONE = cont_K
119.51 + | k (SOME x) = x;
119.52 +
119.53 + fun ap NONE NONE = NONE
119.54 + | ap x y = SOME (k y RS (k x RS cont_A));
119.55 +
119.56 + fun zip [] [] = []
119.57 + | zip [] (y::ys) = (ap NONE y ) :: zip [] ys
119.58 + | zip (x::xs) [] = (ap x NONE) :: zip xs []
119.59 + | zip (x::xs) (y::ys) = (ap x y ) :: zip xs ys
119.60 +
119.61 + fun lam [] = ([], cont_K)
119.62 + | lam (x::ys) =
119.63 + let
119.64 + (* should use "close_derivation" for thms that are used multiple times *)
119.65 + (* it seems to allow for sharing in explicit proof objects *)
119.66 + val x' = Thm.close_derivation (k x);
119.67 + val Lx = x' RS cont_L;
119.68 + in (map (fn y => SOME (k y RS Lx)) ys, x') end;
119.69 +
119.70 + (* first list: cont thm for each dangling bound variable *)
119.71 + (* second list: cont thm for each LAM in t *)
119.72 + (* if b = false, only return cont thm for outermost LAMs *)
119.73 + fun cont_thms1 b (Const (@{const_name Rep_cfun}, _) $ f $ t) =
119.74 + let
119.75 + val (cs1,ls1) = cont_thms1 b f;
119.76 + val (cs2,ls2) = cont_thms1 b t;
119.77 + in (zip cs1 cs2, if b then ls1 @ ls2 else []) end
119.78 + | cont_thms1 b (Const (@{const_name Abs_cfun}, _) $ Abs (_, _, t)) =
119.79 + let
119.80 + val (cs, ls) = cont_thms1 b t;
119.81 + val (cs', l) = lam cs;
119.82 + in (cs', l::ls) end
119.83 + | cont_thms1 b (Const (@{const_name Abs_cfun}, _) $ t) =
119.84 + let
119.85 + val t' = Term.incr_boundvars 1 t $ Bound 0;
119.86 + val (cs, ls) = cont_thms1 b t';
119.87 + val (cs', l) = lam cs;
119.88 + in (cs', l::ls) end
119.89 + | cont_thms1 _ (Bound n) = (var n, [])
119.90 + | cont_thms1 _ _ = ([], []);
119.91 +in
119.92 + (* precondition: is_lcf_term t = true *)
119.93 + fun cont_thms t = snd (cont_thms1 false t);
119.94 + fun all_cont_thms t = snd (cont_thms1 true t);
119.95 +end;
119.96 +
119.97 +(*
119.98 + Given the term "cont f", the procedure tries to construct the
119.99 + theorem "cont f == True". If this theorem cannot be completely
119.100 + solved by the introduction rules, then the procedure returns a
119.101 + conditional rewrite rule with the unsolved subgoals as premises.
119.102 +*)
119.103 +
119.104 +val cont_tac =
119.105 + let
119.106 + val rules = [cont_K, cont_I, cont_R, cont_A, cont_L];
119.107 +
119.108 + fun new_cont_tac f' i =
119.109 + case all_cont_thms f' of
119.110 + [] => no_tac
119.111 + | (c::cs) => rtac c i;
119.112 +
119.113 + fun cont_tac_of_term (Const (@{const_name cont}, _) $ f) =
119.114 + let
119.115 + val f' = Const (@{const_name Abs_cfun}, dummyT) $ f;
119.116 + in
119.117 + if is_lcf_term f'
119.118 + then new_cont_tac f'
119.119 + else REPEAT_ALL_NEW (resolve_tac rules)
119.120 + end
119.121 + | cont_tac_of_term _ = K no_tac;
119.122 + in
119.123 + SUBGOAL (fn (t, i) =>
119.124 + cont_tac_of_term (HOLogic.dest_Trueprop t) i)
119.125 + end;
119.126 +
119.127 +local
119.128 + fun solve_cont thy _ t =
119.129 + let
119.130 + val tr = instantiate' [] [SOME (cterm_of thy t)] Eq_TrueI;
119.131 + in Option.map fst (Seq.pull (cont_tac 1 tr)) end
119.132 +in
119.133 + fun cont_proc thy =
119.134 + Simplifier.simproc_global thy "cont_proc" ["cont f"] solve_cont;
119.135 +end;
119.136 +
119.137 +fun setup thy = Simplifier.map_simpset (fn ss => ss addsimprocs [cont_proc thy]) thy;
119.138 +
119.139 +end;
120.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
120.2 +++ b/src/HOL/HOLCF/Tools/cpodef.ML Sat Nov 27 16:08:10 2010 -0800
120.3 @@ -0,0 +1,383 @@
120.4 +(* Title: HOLCF/Tools/cpodef.ML
120.5 + Author: Brian Huffman
120.6 +
120.7 +Primitive domain definitions for HOLCF, similar to Gordon/HOL-style
120.8 +typedef (see also ~~/src/HOL/Tools/typedef.ML).
120.9 +*)
120.10 +
120.11 +signature CPODEF =
120.12 +sig
120.13 + type cpo_info =
120.14 + { below_def: thm, adm: thm, cont_Rep: thm, cont_Abs: thm,
120.15 + is_lub: thm, lub: thm, compact: thm }
120.16 + type pcpo_info =
120.17 + { Rep_strict: thm, Abs_strict: thm, Rep_bottom_iff: thm, Abs_bottom_iff: thm,
120.18 + Rep_defined: thm, Abs_defined: thm }
120.19 +
120.20 + val add_podef: bool -> binding option -> binding * (string * sort) list * mixfix ->
120.21 + term -> (binding * binding) option -> tactic -> theory ->
120.22 + (Typedef.info * thm) * theory
120.23 + val add_cpodef: bool -> binding option -> binding * (string * sort) list * mixfix ->
120.24 + term -> (binding * binding) option -> tactic * tactic -> theory ->
120.25 + (Typedef.info * cpo_info) * theory
120.26 + val add_pcpodef: bool -> binding option -> binding * (string * sort) list * mixfix ->
120.27 + term -> (binding * binding) option -> tactic * tactic -> theory ->
120.28 + (Typedef.info * cpo_info * pcpo_info) * theory
120.29 +
120.30 + val cpodef_proof: (bool * binding)
120.31 + * (binding * (string * sort) list * mixfix) * term
120.32 + * (binding * binding) option -> theory -> Proof.state
120.33 + val cpodef_proof_cmd: (bool * binding)
120.34 + * (binding * (string * string option) list * mixfix) * string
120.35 + * (binding * binding) option -> theory -> Proof.state
120.36 + val pcpodef_proof: (bool * binding)
120.37 + * (binding * (string * sort) list * mixfix) * term
120.38 + * (binding * binding) option -> theory -> Proof.state
120.39 + val pcpodef_proof_cmd: (bool * binding)
120.40 + * (binding * (string * string option) list * mixfix) * string
120.41 + * (binding * binding) option -> theory -> Proof.state
120.42 +end;
120.43 +
120.44 +structure Cpodef :> CPODEF =
120.45 +struct
120.46 +
120.47 +(** type definitions **)
120.48 +
120.49 +type cpo_info =
120.50 + { below_def: thm, adm: thm, cont_Rep: thm, cont_Abs: thm,
120.51 + is_lub: thm, lub: thm, compact: thm }
120.52 +
120.53 +type pcpo_info =
120.54 + { Rep_strict: thm, Abs_strict: thm, Rep_bottom_iff: thm, Abs_bottom_iff: thm,
120.55 + Rep_defined: thm, Abs_defined: thm }
120.56 +
120.57 +(* building terms *)
120.58 +
120.59 +fun adm_const T = Const (@{const_name adm}, (T --> HOLogic.boolT) --> HOLogic.boolT);
120.60 +fun mk_adm (x, T, P) = adm_const T $ absfree (x, T, P);
120.61 +
120.62 +fun below_const T = Const (@{const_name below}, T --> T --> HOLogic.boolT);
120.63 +
120.64 +(* manipulating theorems *)
120.65 +
120.66 +fun fold_adm_mem thm NONE = thm
120.67 + | fold_adm_mem thm (SOME set_def) =
120.68 + let val rule = @{lemma "A == B ==> adm (%x. x : B) ==> adm (%x. x : A)" by simp}
120.69 + in rule OF [set_def, thm] end;
120.70 +
120.71 +fun fold_UU_mem thm NONE = thm
120.72 + | fold_UU_mem thm (SOME set_def) =
120.73 + let val rule = @{lemma "A == B ==> UU : B ==> UU : A" by simp}
120.74 + in rule OF [set_def, thm] end;
120.75 +
120.76 +(* proving class instances *)
120.77 +
120.78 +fun prove_cpo
120.79 + (name: binding)
120.80 + (newT: typ)
120.81 + (Rep_name: binding, Abs_name: binding)
120.82 + (type_definition: thm) (* type_definition Rep Abs A *)
120.83 + (set_def: thm option) (* A == set *)
120.84 + (below_def: thm) (* op << == %x y. Rep x << Rep y *)
120.85 + (admissible: thm) (* adm (%x. x : set) *)
120.86 + (thy: theory)
120.87 + =
120.88 + let
120.89 + val admissible' = fold_adm_mem admissible set_def;
120.90 + val cpo_thms = map (Thm.transfer thy) [type_definition, below_def, admissible'];
120.91 + val (full_tname, Ts) = dest_Type newT;
120.92 + val lhs_sorts = map (snd o dest_TFree) Ts;
120.93 + val tac = Tactic.rtac (@{thm typedef_cpo} OF cpo_thms) 1;
120.94 + val thy = AxClass.prove_arity (full_tname, lhs_sorts, @{sort cpo}) tac thy;
120.95 + (* transfer thms so that they will know about the new cpo instance *)
120.96 + val cpo_thms' = map (Thm.transfer thy) cpo_thms;
120.97 + fun make thm = Drule.zero_var_indexes (thm OF cpo_thms');
120.98 + val cont_Rep = make @{thm typedef_cont_Rep};
120.99 + val cont_Abs = make @{thm typedef_cont_Abs};
120.100 + val is_lub = make @{thm typedef_is_lub};
120.101 + val lub = make @{thm typedef_lub};
120.102 + val compact = make @{thm typedef_compact};
120.103 + val (_, thy) =
120.104 + thy
120.105 + |> Sign.add_path (Binding.name_of name)
120.106 + |> Global_Theory.add_thms
120.107 + ([((Binding.prefix_name "adm_" name, admissible'), []),
120.108 + ((Binding.prefix_name "cont_" Rep_name, cont_Rep ), []),
120.109 + ((Binding.prefix_name "cont_" Abs_name, cont_Abs ), []),
120.110 + ((Binding.prefix_name "is_lub_" name, is_lub ), []),
120.111 + ((Binding.prefix_name "lub_" name, lub ), []),
120.112 + ((Binding.prefix_name "compact_" name, compact ), [])])
120.113 + ||> Sign.parent_path;
120.114 + val cpo_info : cpo_info =
120.115 + { below_def = below_def, adm = admissible', cont_Rep = cont_Rep,
120.116 + cont_Abs = cont_Abs, is_lub = is_lub, lub = lub, compact = compact };
120.117 + in
120.118 + (cpo_info, thy)
120.119 + end;
120.120 +
120.121 +fun prove_pcpo
120.122 + (name: binding)
120.123 + (newT: typ)
120.124 + (Rep_name: binding, Abs_name: binding)
120.125 + (type_definition: thm) (* type_definition Rep Abs A *)
120.126 + (set_def: thm option) (* A == set *)
120.127 + (below_def: thm) (* op << == %x y. Rep x << Rep y *)
120.128 + (UU_mem: thm) (* UU : set *)
120.129 + (thy: theory)
120.130 + =
120.131 + let
120.132 + val UU_mem' = fold_UU_mem UU_mem set_def;
120.133 + val pcpo_thms = map (Thm.transfer thy) [type_definition, below_def, UU_mem'];
120.134 + val (full_tname, Ts) = dest_Type newT;
120.135 + val lhs_sorts = map (snd o dest_TFree) Ts;
120.136 + val tac = Tactic.rtac (@{thm typedef_pcpo} OF pcpo_thms) 1;
120.137 + val thy = AxClass.prove_arity (full_tname, lhs_sorts, @{sort pcpo}) tac thy;
120.138 + val pcpo_thms' = map (Thm.transfer thy) pcpo_thms;
120.139 + fun make thm = Drule.zero_var_indexes (thm OF pcpo_thms');
120.140 + val Rep_strict = make @{thm typedef_Rep_strict};
120.141 + val Abs_strict = make @{thm typedef_Abs_strict};
120.142 + val Rep_bottom_iff = make @{thm typedef_Rep_bottom_iff};
120.143 + val Abs_bottom_iff = make @{thm typedef_Abs_bottom_iff};
120.144 + val Rep_defined = make @{thm typedef_Rep_defined};
120.145 + val Abs_defined = make @{thm typedef_Abs_defined};
120.146 + val (_, thy) =
120.147 + thy
120.148 + |> Sign.add_path (Binding.name_of name)
120.149 + |> Global_Theory.add_thms
120.150 + ([((Binding.suffix_name "_strict" Rep_name, Rep_strict), []),
120.151 + ((Binding.suffix_name "_strict" Abs_name, Abs_strict), []),
120.152 + ((Binding.suffix_name "_bottom_iff" Rep_name, Rep_bottom_iff), []),
120.153 + ((Binding.suffix_name "_bottom_iff" Abs_name, Abs_bottom_iff), []),
120.154 + ((Binding.suffix_name "_defined" Rep_name, Rep_defined), []),
120.155 + ((Binding.suffix_name "_defined" Abs_name, Abs_defined), [])])
120.156 + ||> Sign.parent_path;
120.157 + val pcpo_info =
120.158 + { Rep_strict = Rep_strict, Abs_strict = Abs_strict,
120.159 + Rep_bottom_iff = Rep_bottom_iff, Abs_bottom_iff = Abs_bottom_iff,
120.160 + Rep_defined = Rep_defined, Abs_defined = Abs_defined };
120.161 + in
120.162 + (pcpo_info, thy)
120.163 + end;
120.164 +
120.165 +(* prepare_cpodef *)
120.166 +
120.167 +fun declare_type_name a =
120.168 + Variable.declare_constraints (Logic.mk_type (TFree (a, dummyS)));
120.169 +
120.170 +fun prepare prep_term name (tname, raw_args, mx) raw_set opt_morphs thy =
120.171 + let
120.172 + val _ = Theory.requires thy "Cpodef" "cpodefs";
120.173 +
120.174 + (*rhs*)
120.175 + val tmp_ctxt =
120.176 + ProofContext.init_global thy
120.177 + |> fold (Variable.declare_typ o TFree) raw_args;
120.178 + val set = prep_term tmp_ctxt raw_set;
120.179 + val tmp_ctxt' = tmp_ctxt |> Variable.declare_term set;
120.180 +
120.181 + val setT = Term.fastype_of set;
120.182 + val oldT = HOLogic.dest_setT setT handle TYPE _ =>
120.183 + error ("Not a set type: " ^ quote (Syntax.string_of_typ tmp_ctxt setT));
120.184 +
120.185 + (*lhs*)
120.186 + val lhs_tfrees = map (ProofContext.check_tfree tmp_ctxt') raw_args;
120.187 + val full_tname = Sign.full_name thy tname;
120.188 + val newT = Type (full_tname, map TFree lhs_tfrees);
120.189 +
120.190 + val morphs = opt_morphs
120.191 + |> the_default (Binding.prefix_name "Rep_" name, Binding.prefix_name "Abs_" name);
120.192 + in
120.193 + (newT, oldT, set, morphs)
120.194 + end
120.195 +
120.196 +fun add_podef def opt_name typ set opt_morphs tac thy =
120.197 + let
120.198 + val name = the_default (#1 typ) opt_name;
120.199 + val ((full_tname, info as ({Rep_name, ...}, {type_definition, set_def, ...})), thy2) = thy
120.200 + |> Typedef.add_typedef_global def opt_name typ set opt_morphs tac;
120.201 + val oldT = #rep_type (#1 info);
120.202 + val newT = #abs_type (#1 info);
120.203 + val lhs_tfrees = map dest_TFree (snd (dest_Type newT));
120.204 +
120.205 + val RepC = Const (Rep_name, newT --> oldT);
120.206 + val below_eqn = Logic.mk_equals (below_const newT,
120.207 + Abs ("x", newT, Abs ("y", newT, below_const oldT $ (RepC $ Bound 1) $ (RepC $ Bound 0))));
120.208 + val lthy3 = thy2
120.209 + |> Class.instantiation ([full_tname], lhs_tfrees, @{sort po});
120.210 + val ((_, (_, below_ldef)), lthy4) = lthy3
120.211 + |> Specification.definition (NONE,
120.212 + ((Binding.prefix_name "below_" (Binding.suffix_name "_def" name), []), below_eqn));
120.213 + val ctxt_thy = ProofContext.init_global (ProofContext.theory_of lthy4);
120.214 + val below_def = singleton (ProofContext.export lthy4 ctxt_thy) below_ldef;
120.215 + val thy5 = lthy4
120.216 + |> Class.prove_instantiation_instance
120.217 + (K (Tactic.rtac (@{thm typedef_po} OF [type_definition, below_def]) 1))
120.218 + |> Local_Theory.exit_global;
120.219 + in ((info, below_def), thy5) end;
120.220 +
120.221 +fun prepare_cpodef
120.222 + (prep_term: Proof.context -> 'a -> term)
120.223 + (def: bool)
120.224 + (name: binding)
120.225 + (typ: binding * (string * sort) list * mixfix)
120.226 + (raw_set: 'a)
120.227 + (opt_morphs: (binding * binding) option)
120.228 + (thy: theory)
120.229 + : term * term * (thm -> thm -> theory -> (Typedef.info * cpo_info) * theory) =
120.230 + let
120.231 + val (newT, oldT, set, morphs as (Rep_name, Abs_name)) =
120.232 + prepare prep_term name typ raw_set opt_morphs thy;
120.233 +
120.234 + val goal_nonempty =
120.235 + HOLogic.mk_Trueprop (HOLogic.mk_exists ("x", oldT, HOLogic.mk_mem (Free ("x", oldT), set)));
120.236 + val goal_admissible =
120.237 + HOLogic.mk_Trueprop (mk_adm ("x", oldT, HOLogic.mk_mem (Free ("x", oldT), set)));
120.238 +
120.239 + fun cpodef_result nonempty admissible thy =
120.240 + let
120.241 + val ((info as (_, {type_definition, set_def, ...}), below_def), thy2) = thy
120.242 + |> add_podef def (SOME name) typ set opt_morphs (Tactic.rtac nonempty 1);
120.243 + val (cpo_info, thy3) = thy2
120.244 + |> prove_cpo name newT morphs type_definition set_def below_def admissible;
120.245 + in
120.246 + ((info, cpo_info), thy3)
120.247 + end;
120.248 + in
120.249 + (goal_nonempty, goal_admissible, cpodef_result)
120.250 + end
120.251 + handle ERROR msg =>
120.252 + cat_error msg ("The error(s) above occurred in cpodef " ^ quote (Binding.str_of name));
120.253 +
120.254 +fun prepare_pcpodef
120.255 + (prep_term: Proof.context -> 'a -> term)
120.256 + (def: bool)
120.257 + (name: binding)
120.258 + (typ: binding * (string * sort) list * mixfix)
120.259 + (raw_set: 'a)
120.260 + (opt_morphs: (binding * binding) option)
120.261 + (thy: theory)
120.262 + : term * term * (thm -> thm -> theory -> (Typedef.info * cpo_info * pcpo_info) * theory) =
120.263 + let
120.264 + val (newT, oldT, set, morphs as (Rep_name, Abs_name)) =
120.265 + prepare prep_term name typ raw_set opt_morphs thy;
120.266 +
120.267 + val goal_UU_mem =
120.268 + HOLogic.mk_Trueprop (HOLogic.mk_mem (Const (@{const_name UU}, oldT), set));
120.269 +
120.270 + val goal_admissible =
120.271 + HOLogic.mk_Trueprop (mk_adm ("x", oldT, HOLogic.mk_mem (Free ("x", oldT), set)));
120.272 +
120.273 + fun pcpodef_result UU_mem admissible thy =
120.274 + let
120.275 + val tac = Tactic.rtac exI 1 THEN Tactic.rtac UU_mem 1;
120.276 + val ((info as (_, {type_definition, set_def, ...}), below_def), thy2) = thy
120.277 + |> add_podef def (SOME name) typ set opt_morphs tac;
120.278 + val (cpo_info, thy3) = thy2
120.279 + |> prove_cpo name newT morphs type_definition set_def below_def admissible;
120.280 + val (pcpo_info, thy4) = thy3
120.281 + |> prove_pcpo name newT morphs type_definition set_def below_def UU_mem;
120.282 + in
120.283 + ((info, cpo_info, pcpo_info), thy4)
120.284 + end;
120.285 + in
120.286 + (goal_UU_mem, goal_admissible, pcpodef_result)
120.287 + end
120.288 + handle ERROR msg =>
120.289 + cat_error msg ("The error(s) above occurred in pcpodef " ^ quote (Binding.str_of name));
120.290 +
120.291 +
120.292 +(* tactic interface *)
120.293 +
120.294 +fun add_cpodef def opt_name typ set opt_morphs (tac1, tac2) thy =
120.295 + let
120.296 + val name = the_default (#1 typ) opt_name;
120.297 + val (goal1, goal2, cpodef_result) =
120.298 + prepare_cpodef Syntax.check_term def name typ set opt_morphs thy;
120.299 + val thm1 = Goal.prove_global thy [] [] goal1 (K tac1)
120.300 + handle ERROR msg => cat_error msg
120.301 + ("Failed to prove non-emptiness of " ^ quote (Syntax.string_of_term_global thy set));
120.302 + val thm2 = Goal.prove_global thy [] [] goal2 (K tac2)
120.303 + handle ERROR msg => cat_error msg
120.304 + ("Failed to prove admissibility of " ^ quote (Syntax.string_of_term_global thy set));
120.305 + in cpodef_result thm1 thm2 thy end;
120.306 +
120.307 +fun add_pcpodef def opt_name typ set opt_morphs (tac1, tac2) thy =
120.308 + let
120.309 + val name = the_default (#1 typ) opt_name;
120.310 + val (goal1, goal2, pcpodef_result) =
120.311 + prepare_pcpodef Syntax.check_term def name typ set opt_morphs thy;
120.312 + val thm1 = Goal.prove_global thy [] [] goal1 (K tac1)
120.313 + handle ERROR msg => cat_error msg
120.314 + ("Failed to prove non-emptiness of " ^ quote (Syntax.string_of_term_global thy set));
120.315 + val thm2 = Goal.prove_global thy [] [] goal2 (K tac2)
120.316 + handle ERROR msg => cat_error msg
120.317 + ("Failed to prove admissibility of " ^ quote (Syntax.string_of_term_global thy set));
120.318 + in pcpodef_result thm1 thm2 thy end;
120.319 +
120.320 +
120.321 +(* proof interface *)
120.322 +
120.323 +local
120.324 +
120.325 +fun gen_cpodef_proof prep_term prep_constraint
120.326 + ((def, name), (b, raw_args, mx), set, opt_morphs) thy =
120.327 + let
120.328 + val ctxt = ProofContext.init_global thy;
120.329 + val args = map (apsnd (prep_constraint ctxt)) raw_args;
120.330 + val (goal1, goal2, make_result) =
120.331 + prepare_cpodef prep_term def name (b, args, mx) set opt_morphs thy;
120.332 + fun after_qed [[th1, th2]] = ProofContext.background_theory (snd o make_result th1 th2)
120.333 + | after_qed _ = raise Fail "cpodef_proof";
120.334 + in Proof.theorem NONE after_qed [[(goal1, []), (goal2, [])]] ctxt end;
120.335 +
120.336 +fun gen_pcpodef_proof prep_term prep_constraint
120.337 + ((def, name), (b, raw_args, mx), set, opt_morphs) thy =
120.338 + let
120.339 + val ctxt = ProofContext.init_global thy;
120.340 + val args = map (apsnd (prep_constraint ctxt)) raw_args;
120.341 + val (goal1, goal2, make_result) =
120.342 + prepare_pcpodef prep_term def name (b, args, mx) set opt_morphs thy;
120.343 + fun after_qed [[th1, th2]] = ProofContext.background_theory (snd o make_result th1 th2)
120.344 + | after_qed _ = raise Fail "pcpodef_proof";
120.345 + in Proof.theorem NONE after_qed [[(goal1, []), (goal2, [])]] ctxt end;
120.346 +
120.347 +in
120.348 +
120.349 +fun cpodef_proof x = gen_cpodef_proof Syntax.check_term (K I) x;
120.350 +fun cpodef_proof_cmd x = gen_cpodef_proof Syntax.read_term Typedecl.read_constraint x;
120.351 +
120.352 +fun pcpodef_proof x = gen_pcpodef_proof Syntax.check_term (K I) x;
120.353 +fun pcpodef_proof_cmd x = gen_pcpodef_proof Syntax.read_term Typedecl.read_constraint x;
120.354 +
120.355 +end;
120.356 +
120.357 +
120.358 +
120.359 +(** outer syntax **)
120.360 +
120.361 +val typedef_proof_decl =
120.362 + Scan.optional (Parse.$$$ "(" |--
120.363 + ((Parse.$$$ "open" >> K false) -- Scan.option Parse.binding ||
120.364 + Parse.binding >> (fn s => (true, SOME s)))
120.365 + --| Parse.$$$ ")") (true, NONE) --
120.366 + (Parse.type_args_constrained -- Parse.binding) -- Parse.opt_mixfix --
120.367 + (Parse.$$$ "=" |-- Parse.term) --
120.368 + Scan.option (Parse.$$$ "morphisms" |-- Parse.!!! (Parse.binding -- Parse.binding));
120.369 +
120.370 +fun mk_pcpodef_proof pcpo ((((((def, opt_name), (args, t)), mx), A), morphs)) =
120.371 + (if pcpo then pcpodef_proof_cmd else cpodef_proof_cmd)
120.372 + ((def, the_default t opt_name), (t, args, mx), A, morphs);
120.373 +
120.374 +val _ =
120.375 + Outer_Syntax.command "pcpodef" "HOLCF type definition (requires admissibility proof)"
120.376 + Keyword.thy_goal
120.377 + (typedef_proof_decl >>
120.378 + (Toplevel.print oo (Toplevel.theory_to_proof o mk_pcpodef_proof true)));
120.379 +
120.380 +val _ =
120.381 + Outer_Syntax.command "cpodef" "HOLCF type definition (requires admissibility proof)"
120.382 + Keyword.thy_goal
120.383 + (typedef_proof_decl >>
120.384 + (Toplevel.print oo (Toplevel.theory_to_proof o mk_pcpodef_proof false)));
120.385 +
120.386 +end;
121.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
121.2 +++ b/src/HOL/HOLCF/Tools/domaindef.ML Sat Nov 27 16:08:10 2010 -0800
121.3 @@ -0,0 +1,236 @@
121.4 +(* Title: HOLCF/Tools/repdef.ML
121.5 + Author: Brian Huffman
121.6 +
121.7 +Defining representable domains using algebraic deflations.
121.8 +*)
121.9 +
121.10 +signature DOMAINDEF =
121.11 +sig
121.12 + type rep_info =
121.13 + {
121.14 + emb_def : thm,
121.15 + prj_def : thm,
121.16 + defl_def : thm,
121.17 + liftemb_def : thm,
121.18 + liftprj_def : thm,
121.19 + liftdefl_def : thm,
121.20 + DEFL : thm
121.21 + }
121.22 +
121.23 + val add_domaindef: bool -> binding option -> binding * (string * sort) list * mixfix ->
121.24 + term -> (binding * binding) option -> theory ->
121.25 + (Typedef.info * Cpodef.cpo_info * Cpodef.pcpo_info * rep_info) * theory
121.26 +
121.27 + val domaindef_cmd: (bool * binding) * (binding * (string * string option) list * mixfix) * string
121.28 + * (binding * binding) option -> theory -> theory
121.29 +end;
121.30 +
121.31 +structure Domaindef :> DOMAINDEF =
121.32 +struct
121.33 +
121.34 +open HOLCF_Library;
121.35 +
121.36 +infixr 6 ->>;
121.37 +infix -->>;
121.38 +
121.39 +(** type definitions **)
121.40 +
121.41 +type rep_info =
121.42 + {
121.43 + emb_def : thm,
121.44 + prj_def : thm,
121.45 + defl_def : thm,
121.46 + liftemb_def : thm,
121.47 + liftprj_def : thm,
121.48 + liftdefl_def : thm,
121.49 + DEFL : thm
121.50 + };
121.51 +
121.52 +(* building types and terms *)
121.53 +
121.54 +val udomT = @{typ udom};
121.55 +val deflT = @{typ defl};
121.56 +fun emb_const T = Const (@{const_name emb}, T ->> udomT);
121.57 +fun prj_const T = Const (@{const_name prj}, udomT ->> T);
121.58 +fun defl_const T = Const (@{const_name defl}, Term.itselfT T --> deflT);
121.59 +fun liftemb_const T = Const (@{const_name liftemb}, mk_upT T ->> udomT);
121.60 +fun liftprj_const T = Const (@{const_name liftprj}, udomT ->> mk_upT T);
121.61 +fun liftdefl_const T = Const (@{const_name liftdefl}, Term.itselfT T --> deflT);
121.62 +
121.63 +fun mk_u_map t =
121.64 + let
121.65 + val (T, U) = dest_cfunT (fastype_of t);
121.66 + val u_map_type = (T ->> U) ->> (mk_upT T ->> mk_upT U);
121.67 + val u_map_const = Const (@{const_name u_map}, u_map_type);
121.68 + in
121.69 + mk_capply (u_map_const, t)
121.70 + end;
121.71 +
121.72 +fun mk_cast (t, x) =
121.73 + capply_const (udomT, udomT)
121.74 + $ (capply_const (deflT, udomT ->> udomT) $ @{const cast} $ t)
121.75 + $ x;
121.76 +
121.77 +(* manipulating theorems *)
121.78 +
121.79 +(* proving class instances *)
121.80 +
121.81 +fun declare_type_name a =
121.82 + Variable.declare_constraints (Logic.mk_type (TFree (a, dummyS)));
121.83 +
121.84 +fun gen_add_domaindef
121.85 + (prep_term: Proof.context -> 'a -> term)
121.86 + (def: bool)
121.87 + (name: binding)
121.88 + (typ as (tname, raw_args, mx) : binding * (string * sort) list * mixfix)
121.89 + (raw_defl: 'a)
121.90 + (opt_morphs: (binding * binding) option)
121.91 + (thy: theory)
121.92 + : (Typedef.info * Cpodef.cpo_info * Cpodef.pcpo_info * rep_info) * theory =
121.93 + let
121.94 + val _ = Theory.requires thy "Domain" "domaindefs";
121.95 +
121.96 + (*rhs*)
121.97 + val tmp_ctxt =
121.98 + ProofContext.init_global thy
121.99 + |> fold (Variable.declare_typ o TFree) raw_args;
121.100 + val defl = prep_term tmp_ctxt raw_defl;
121.101 + val tmp_ctxt = tmp_ctxt |> Variable.declare_constraints defl;
121.102 +
121.103 + val deflT = Term.fastype_of defl;
121.104 + val _ = if deflT = @{typ "defl"} then ()
121.105 + else error ("Not type defl: " ^ quote (Syntax.string_of_typ tmp_ctxt deflT));
121.106 +
121.107 + (*lhs*)
121.108 + val lhs_tfrees = map (ProofContext.check_tfree tmp_ctxt) raw_args;
121.109 + val lhs_sorts = map snd lhs_tfrees;
121.110 + val full_tname = Sign.full_name thy tname;
121.111 + val newT = Type (full_tname, map TFree lhs_tfrees);
121.112 +
121.113 + (*morphisms*)
121.114 + val morphs = opt_morphs
121.115 + |> the_default (Binding.prefix_name "Rep_" name, Binding.prefix_name "Abs_" name);
121.116 +
121.117 + (*set*)
121.118 + val set = @{const defl_set} $ defl;
121.119 +
121.120 + (*pcpodef*)
121.121 + val tac1 = rtac @{thm defl_set_bottom} 1;
121.122 + val tac2 = rtac @{thm adm_defl_set} 1;
121.123 + val ((info, cpo_info, pcpo_info), thy) = thy
121.124 + |> Cpodef.add_pcpodef def (SOME name) typ set (SOME morphs) (tac1, tac2);
121.125 +
121.126 + (*definitions*)
121.127 + val Rep_const = Const (#Rep_name (#1 info), newT --> udomT);
121.128 + val Abs_const = Const (#Abs_name (#1 info), udomT --> newT);
121.129 + val emb_eqn = Logic.mk_equals (emb_const newT, cabs_const (newT, udomT) $ Rep_const);
121.130 + val prj_eqn = Logic.mk_equals (prj_const newT, cabs_const (udomT, newT) $
121.131 + Abs ("x", udomT, Abs_const $ mk_cast (defl, Bound 0)));
121.132 + val defl_eqn = Logic.mk_equals (defl_const newT,
121.133 + Abs ("x", Term.itselfT newT, defl));
121.134 + val liftemb_eqn =
121.135 + Logic.mk_equals (liftemb_const newT,
121.136 + mk_cfcomp (@{term "udom_emb u_approx"}, mk_u_map (emb_const newT)));
121.137 + val liftprj_eqn =
121.138 + Logic.mk_equals (liftprj_const newT,
121.139 + mk_cfcomp (mk_u_map (prj_const newT), @{term "udom_prj u_approx"}));
121.140 + val liftdefl_eqn =
121.141 + Logic.mk_equals (liftdefl_const newT,
121.142 + Abs ("t", Term.itselfT newT,
121.143 + mk_capply (@{const u_defl}, defl_const newT $ Logic.mk_type newT)));
121.144 +
121.145 + val name_def = Binding.suffix_name "_def" name;
121.146 + val emb_bind = (Binding.prefix_name "emb_" name_def, []);
121.147 + val prj_bind = (Binding.prefix_name "prj_" name_def, []);
121.148 + val defl_bind = (Binding.prefix_name "defl_" name_def, []);
121.149 + val liftemb_bind = (Binding.prefix_name "liftemb_" name_def, []);
121.150 + val liftprj_bind = (Binding.prefix_name "liftprj_" name_def, []);
121.151 + val liftdefl_bind = (Binding.prefix_name "liftdefl_" name_def, []);
121.152 +
121.153 + (*instantiate class rep*)
121.154 + val lthy = thy
121.155 + |> Class.instantiation ([full_tname], lhs_tfrees, @{sort liftdomain});
121.156 + val ((_, (_, emb_ldef)), lthy) =
121.157 + Specification.definition (NONE, (emb_bind, emb_eqn)) lthy;
121.158 + val ((_, (_, prj_ldef)), lthy) =
121.159 + Specification.definition (NONE, (prj_bind, prj_eqn)) lthy;
121.160 + val ((_, (_, defl_ldef)), lthy) =
121.161 + Specification.definition (NONE, (defl_bind, defl_eqn)) lthy;
121.162 + val ((_, (_, liftemb_ldef)), lthy) =
121.163 + Specification.definition (NONE, (liftemb_bind, liftemb_eqn)) lthy;
121.164 + val ((_, (_, liftprj_ldef)), lthy) =
121.165 + Specification.definition (NONE, (liftprj_bind, liftprj_eqn)) lthy;
121.166 + val ((_, (_, liftdefl_ldef)), lthy) =
121.167 + Specification.definition (NONE, (liftdefl_bind, liftdefl_eqn)) lthy;
121.168 + val ctxt_thy = ProofContext.init_global (ProofContext.theory_of lthy);
121.169 + val emb_def = singleton (ProofContext.export lthy ctxt_thy) emb_ldef;
121.170 + val prj_def = singleton (ProofContext.export lthy ctxt_thy) prj_ldef;
121.171 + val defl_def = singleton (ProofContext.export lthy ctxt_thy) defl_ldef;
121.172 + val liftemb_def = singleton (ProofContext.export lthy ctxt_thy) liftemb_ldef;
121.173 + val liftprj_def = singleton (ProofContext.export lthy ctxt_thy) liftprj_ldef;
121.174 + val liftdefl_def = singleton (ProofContext.export lthy ctxt_thy) liftdefl_ldef;
121.175 + val type_definition_thm =
121.176 + MetaSimplifier.rewrite_rule
121.177 + (the_list (#set_def (#2 info)))
121.178 + (#type_definition (#2 info));
121.179 + val typedef_thms =
121.180 + [type_definition_thm, #below_def cpo_info, emb_def, prj_def, defl_def,
121.181 + liftemb_def, liftprj_def, liftdefl_def];
121.182 + val thy = lthy
121.183 + |> Class.prove_instantiation_instance
121.184 + (K (Tactic.rtac (@{thm typedef_liftdomain_class} OF typedef_thms) 1))
121.185 + |> Local_Theory.exit_global;
121.186 +
121.187 + (*other theorems*)
121.188 + val defl_thm' = Thm.transfer thy defl_def;
121.189 + val (DEFL_thm, thy) = thy
121.190 + |> Sign.add_path (Binding.name_of name)
121.191 + |> Global_Theory.add_thm
121.192 + ((Binding.prefix_name "DEFL_" name,
121.193 + Drule.zero_var_indexes (@{thm typedef_DEFL} OF [defl_thm'])), [])
121.194 + ||> Sign.restore_naming thy;
121.195 +
121.196 + val rep_info =
121.197 + { emb_def = emb_def, prj_def = prj_def, defl_def = defl_def,
121.198 + liftemb_def = liftemb_def, liftprj_def = liftprj_def,
121.199 + liftdefl_def = liftdefl_def, DEFL = DEFL_thm };
121.200 + in
121.201 + ((info, cpo_info, pcpo_info, rep_info), thy)
121.202 + end
121.203 + handle ERROR msg =>
121.204 + cat_error msg ("The error(s) above occurred in domaindef " ^ quote (Binding.str_of name));
121.205 +
121.206 +fun add_domaindef def opt_name typ defl opt_morphs thy =
121.207 + let
121.208 + val name = the_default (#1 typ) opt_name;
121.209 + in
121.210 + gen_add_domaindef Syntax.check_term def name typ defl opt_morphs thy
121.211 + end;
121.212 +
121.213 +fun domaindef_cmd ((def, name), (b, raw_args, mx), A, morphs) thy =
121.214 + let
121.215 + val ctxt = ProofContext.init_global thy;
121.216 + val args = map (apsnd (Typedecl.read_constraint ctxt)) raw_args;
121.217 + in snd (gen_add_domaindef Syntax.read_term def name (b, args, mx) A morphs thy) end;
121.218 +
121.219 +
121.220 +(** outer syntax **)
121.221 +
121.222 +val domaindef_decl =
121.223 + Scan.optional (Parse.$$$ "(" |--
121.224 + ((Parse.$$$ "open" >> K false) -- Scan.option Parse.binding ||
121.225 + Parse.binding >> (fn s => (true, SOME s)))
121.226 + --| Parse.$$$ ")") (true, NONE) --
121.227 + (Parse.type_args_constrained -- Parse.binding) --
121.228 + Parse.opt_mixfix -- (Parse.$$$ "=" |-- Parse.term) --
121.229 + Scan.option (Parse.$$$ "morphisms" |-- Parse.!!! (Parse.binding -- Parse.binding));
121.230 +
121.231 +fun mk_domaindef ((((((def, opt_name), (args, t)), mx), A), morphs)) =
121.232 + domaindef_cmd ((def, the_default t opt_name), (t, args, mx), A, morphs);
121.233 +
121.234 +val _ =
121.235 + Outer_Syntax.command "domaindef" "HOLCF definition of domains from deflations" Keyword.thy_decl
121.236 + (domaindef_decl >>
121.237 + (Toplevel.print oo (Toplevel.theory o mk_domaindef)));
121.238 +
121.239 +end;
122.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
122.2 +++ b/src/HOL/HOLCF/Tools/fixrec.ML Sat Nov 27 16:08:10 2010 -0800
122.3 @@ -0,0 +1,417 @@
122.4 +(* Title: HOLCF/Tools/fixrec.ML
122.5 + Author: Amber Telfer and Brian Huffman
122.6 +
122.7 +Recursive function definition package for HOLCF.
122.8 +*)
122.9 +
122.10 +signature FIXREC =
122.11 +sig
122.12 + val add_fixrec: (binding * typ option * mixfix) list
122.13 + -> (bool * (Attrib.binding * term)) list -> local_theory -> local_theory
122.14 + val add_fixrec_cmd: (binding * string option * mixfix) list
122.15 + -> (bool * (Attrib.binding * string)) list -> local_theory -> local_theory
122.16 + val add_matchers: (string * string) list -> theory -> theory
122.17 + val fixrec_simp_tac: Proof.context -> int -> tactic
122.18 + val setup: theory -> theory
122.19 +end;
122.20 +
122.21 +structure Fixrec :> FIXREC =
122.22 +struct
122.23 +
122.24 +open HOLCF_Library;
122.25 +
122.26 +infixr 6 ->>;
122.27 +infix -->>;
122.28 +infix 9 `;
122.29 +
122.30 +val def_cont_fix_eq = @{thm def_cont_fix_eq};
122.31 +val def_cont_fix_ind = @{thm def_cont_fix_ind};
122.32 +
122.33 +fun fixrec_err s = error ("fixrec definition error:\n" ^ s);
122.34 +fun fixrec_eq_err thy s eq =
122.35 + fixrec_err (s ^ "\nin\n" ^ quote (Syntax.string_of_term_global thy eq));
122.36 +
122.37 +(*************************************************************************)
122.38 +(***************************** building types ****************************)
122.39 +(*************************************************************************)
122.40 +
122.41 +local
122.42 +
122.43 +fun binder_cfun (Type(@{type_name cfun},[T, U])) = T :: binder_cfun U
122.44 + | binder_cfun (Type(@{type_name "fun"},[T, U])) = T :: binder_cfun U
122.45 + | binder_cfun _ = [];
122.46 +
122.47 +fun body_cfun (Type(@{type_name cfun},[T, U])) = body_cfun U
122.48 + | body_cfun (Type(@{type_name "fun"},[T, U])) = body_cfun U
122.49 + | body_cfun T = T;
122.50 +
122.51 +fun strip_cfun T : typ list * typ =
122.52 + (binder_cfun T, body_cfun T);
122.53 +
122.54 +in
122.55 +
122.56 +fun matcherT (T, U) =
122.57 + body_cfun T ->> (binder_cfun T -->> U) ->> U;
122.58 +
122.59 +end
122.60 +
122.61 +(*************************************************************************)
122.62 +(***************************** building terms ****************************)
122.63 +(*************************************************************************)
122.64 +
122.65 +val mk_trp = HOLogic.mk_Trueprop;
122.66 +
122.67 +(* splits a cterm into the right and lefthand sides of equality *)
122.68 +fun dest_eqs t = HOLogic.dest_eq (HOLogic.dest_Trueprop t);
122.69 +
122.70 +(* similar to Thm.head_of, but for continuous application *)
122.71 +fun chead_of (Const(@{const_name Rep_cfun},_)$f$t) = chead_of f
122.72 + | chead_of u = u;
122.73 +
122.74 +infix 0 ==; val (op ==) = Logic.mk_equals;
122.75 +infix 1 ===; val (op ===) = HOLogic.mk_eq;
122.76 +
122.77 +fun mk_mplus (t, u) =
122.78 + let val mT = Term.fastype_of t
122.79 + in Const(@{const_name Fixrec.mplus}, mT ->> mT ->> mT) ` t ` u end;
122.80 +
122.81 +fun mk_run t =
122.82 + let
122.83 + val mT = Term.fastype_of t
122.84 + val T = dest_matchT mT
122.85 + val run = Const(@{const_name Fixrec.run}, mT ->> T)
122.86 + in
122.87 + case t of
122.88 + Const(@{const_name Rep_cfun}, _) $
122.89 + Const(@{const_name Fixrec.succeed}, _) $ u => u
122.90 + | _ => run ` t
122.91 + end;
122.92 +
122.93 +
122.94 +(*************************************************************************)
122.95 +(************* fixed-point definitions and unfolding theorems ************)
122.96 +(*************************************************************************)
122.97 +
122.98 +structure FixrecUnfoldData = Generic_Data
122.99 +(
122.100 + type T = thm Symtab.table;
122.101 + val empty = Symtab.empty;
122.102 + val extend = I;
122.103 + fun merge data : T = Symtab.merge (K true) data;
122.104 +);
122.105 +
122.106 +local
122.107 +
122.108 +fun name_of (Const (n, T)) = n
122.109 + | name_of (Free (n, T)) = n
122.110 + | name_of t = raise TERM ("Fixrec.add_unfold: lhs not a constant", [t]);
122.111 +
122.112 +val lhs_name =
122.113 + name_of o head_of o fst o HOLogic.dest_eq o HOLogic.dest_Trueprop o prop_of;
122.114 +
122.115 +in
122.116 +
122.117 +val add_unfold : attribute =
122.118 + Thm.declaration_attribute
122.119 + (fn th => FixrecUnfoldData.map (Symtab.insert (K true) (lhs_name th, th)));
122.120 +
122.121 +end
122.122 +
122.123 +fun add_fixdefs
122.124 + (fixes : ((binding * typ) * mixfix) list)
122.125 + (spec : (Attrib.binding * term) list)
122.126 + (lthy : local_theory) =
122.127 + let
122.128 + val thy = ProofContext.theory_of lthy;
122.129 + val names = map (Binding.name_of o fst o fst) fixes;
122.130 + val all_names = space_implode "_" names;
122.131 + val (lhss, rhss) = ListPair.unzip (map (dest_eqs o snd) spec);
122.132 + val functional = lambda_tuple lhss (mk_tuple rhss);
122.133 + val fixpoint = mk_fix (mk_cabs functional);
122.134 +
122.135 + val cont_thm =
122.136 + let
122.137 + val prop = mk_trp (mk_cont functional);
122.138 + fun err _ = error (
122.139 + "Continuity proof failed; please check that cont2cont rules\n" ^
122.140 + "or simp rules are configured for all non-HOLCF constants.\n" ^
122.141 + "The error occurred for the goal statement:\n" ^
122.142 + Syntax.string_of_term lthy prop);
122.143 + val rules = Cont2ContData.get lthy;
122.144 + val fast_tac = SOLVED' (REPEAT_ALL_NEW (match_tac rules));
122.145 + val slow_tac = SOLVED' (simp_tac (simpset_of lthy));
122.146 + val tac = fast_tac 1 ORELSE slow_tac 1 ORELSE err;
122.147 + in
122.148 + Goal.prove lthy [] [] prop (K tac)
122.149 + end;
122.150 +
122.151 + fun one_def (l as Free(n,_)) r =
122.152 + let val b = Long_Name.base_name n
122.153 + in ((Binding.name (b^"_def"), []), r) end
122.154 + | one_def _ _ = fixrec_err "fixdefs: lhs not of correct form";
122.155 + fun defs [] _ = []
122.156 + | defs (l::[]) r = [one_def l r]
122.157 + | defs (l::ls) r = one_def l (mk_fst r) :: defs ls (mk_snd r);
122.158 + val fixdefs = defs lhss fixpoint;
122.159 + val (fixdef_thms : (term * (string * thm)) list, lthy) = lthy
122.160 + |> fold_map Local_Theory.define (map (apfst fst) fixes ~~ fixdefs);
122.161 + fun pair_equalI (thm1, thm2) = @{thm Pair_equalI} OF [thm1, thm2];
122.162 + val tuple_fixdef_thm = foldr1 pair_equalI (map (snd o snd) fixdef_thms);
122.163 + val P = Var (("P", 0), map Term.fastype_of lhss ---> HOLogic.boolT);
122.164 + val predicate = lambda_tuple lhss (list_comb (P, lhss));
122.165 + val tuple_induct_thm = (def_cont_fix_ind OF [tuple_fixdef_thm, cont_thm])
122.166 + |> Drule.instantiate' [] [SOME (Thm.cterm_of thy predicate)]
122.167 + |> Local_Defs.unfold lthy @{thms split_paired_all split_conv split_strict};
122.168 + val tuple_unfold_thm = (def_cont_fix_eq OF [tuple_fixdef_thm, cont_thm])
122.169 + |> Local_Defs.unfold lthy @{thms split_conv};
122.170 + fun unfolds [] thm = []
122.171 + | unfolds (n::[]) thm = [(n, thm)]
122.172 + | unfolds (n::ns) thm = let
122.173 + val thmL = thm RS @{thm Pair_eqD1};
122.174 + val thmR = thm RS @{thm Pair_eqD2};
122.175 + in (n, thmL) :: unfolds ns thmR end;
122.176 + val unfold_thms = unfolds names tuple_unfold_thm;
122.177 + val induct_note : Attrib.binding * Thm.thm list =
122.178 + let
122.179 + val thm_name = Binding.qualify true all_names (Binding.name "induct");
122.180 + in
122.181 + ((thm_name, []), [tuple_induct_thm])
122.182 + end;
122.183 + fun unfold_note (name, thm) : Attrib.binding * Thm.thm list =
122.184 + let
122.185 + val thm_name = Binding.qualify true name (Binding.name "unfold");
122.186 + val src = Attrib.internal (K add_unfold);
122.187 + in
122.188 + ((thm_name, [src]), [thm])
122.189 + end;
122.190 + val (thmss, lthy) = lthy
122.191 + |> fold_map Local_Theory.note (induct_note :: map unfold_note unfold_thms);
122.192 + in
122.193 + (lthy, names, fixdef_thms, map snd unfold_thms)
122.194 + end;
122.195 +
122.196 +(*************************************************************************)
122.197 +(*********** monadic notation and pattern matching compilation ***********)
122.198 +(*************************************************************************)
122.199 +
122.200 +structure FixrecMatchData = Theory_Data
122.201 +(
122.202 + type T = string Symtab.table;
122.203 + val empty = Symtab.empty;
122.204 + val extend = I;
122.205 + fun merge data = Symtab.merge (K true) data;
122.206 +);
122.207 +
122.208 +(* associate match functions with pattern constants *)
122.209 +fun add_matchers ms = FixrecMatchData.map (fold Symtab.update ms);
122.210 +
122.211 +fun taken_names (t : term) : bstring list =
122.212 + let
122.213 + fun taken (Const(a,_), bs) = insert (op =) (Long_Name.base_name a) bs
122.214 + | taken (Free(a,_) , bs) = insert (op =) a bs
122.215 + | taken (f $ u , bs) = taken (f, taken (u, bs))
122.216 + | taken (Abs(a,_,t), bs) = taken (t, insert (op =) a bs)
122.217 + | taken (_ , bs) = bs;
122.218 + in
122.219 + taken (t, [])
122.220 + end;
122.221 +
122.222 +(* builds a monadic term for matching a pattern *)
122.223 +(* returns (rhs, free variable, used varnames) *)
122.224 +fun compile_pat match_name pat rhs taken =
122.225 + let
122.226 + fun comp_pat p rhs taken =
122.227 + if is_Free p then (rhs, p, taken)
122.228 + else comp_con (fastype_of p) p rhs [] taken
122.229 + (* compiles a monadic term for a constructor pattern *)
122.230 + and comp_con T p rhs vs taken =
122.231 + case p of
122.232 + Const(@{const_name Rep_cfun},_) $ f $ x =>
122.233 + let val (rhs', v, taken') = comp_pat x rhs taken
122.234 + in comp_con T f rhs' (v::vs) taken' end
122.235 + | f $ x =>
122.236 + let val (rhs', v, taken') = comp_pat x rhs taken
122.237 + in comp_con T f rhs' (v::vs) taken' end
122.238 + | Const (c, cT) =>
122.239 + let
122.240 + val n = Name.variant taken "v"
122.241 + val v = Free(n, T)
122.242 + val m = Const(match_name c, matcherT (cT, fastype_of rhs))
122.243 + val k = big_lambdas vs rhs
122.244 + in
122.245 + (m`v`k, v, n::taken)
122.246 + end
122.247 + | _ => raise TERM ("fixrec: invalid pattern ", [p])
122.248 + in
122.249 + comp_pat pat rhs taken
122.250 + end;
122.251 +
122.252 +(* builds a monadic term for matching a function definition pattern *)
122.253 +(* returns (constant, (vars, matcher)) *)
122.254 +fun compile_lhs match_name pat rhs vs taken =
122.255 + case pat of
122.256 + Const(@{const_name Rep_cfun}, _) $ f $ x =>
122.257 + let val (rhs', v, taken') = compile_pat match_name x rhs taken;
122.258 + in compile_lhs match_name f rhs' (v::vs) taken' end
122.259 + | Free(_,_) => (pat, (vs, rhs))
122.260 + | Const(_,_) => (pat, (vs, rhs))
122.261 + | _ => fixrec_err ("invalid function pattern: "
122.262 + ^ ML_Syntax.print_term pat);
122.263 +
122.264 +fun strip_alls t =
122.265 + if Logic.is_all t then strip_alls (snd (Logic.dest_all t)) else t;
122.266 +
122.267 +fun compile_eq match_name eq =
122.268 + let
122.269 + val (lhs,rhs) = dest_eqs (Logic.strip_imp_concl (strip_alls eq));
122.270 + in
122.271 + compile_lhs match_name lhs (mk_succeed rhs) [] (taken_names eq)
122.272 + end;
122.273 +
122.274 +(* this is the pattern-matching compiler function *)
122.275 +fun compile_eqs match_name eqs =
122.276 + let
122.277 + val (consts, matchers) =
122.278 + ListPair.unzip (map (compile_eq match_name) eqs);
122.279 + val const =
122.280 + case distinct (op =) consts of
122.281 + [n] => n
122.282 + | _ => fixrec_err "all equations in block must define the same function";
122.283 + val vars =
122.284 + case distinct (op = o pairself length) (map fst matchers) of
122.285 + [vars] => vars
122.286 + | _ => fixrec_err "all equations in block must have the same arity";
122.287 + (* rename so all matchers use same free variables *)
122.288 + fun rename (vs, t) = Term.subst_free (filter_out (op =) (vs ~~ vars)) t;
122.289 + val rhs = big_lambdas vars (mk_run (foldr1 mk_mplus (map rename matchers)));
122.290 + in
122.291 + mk_trp (const === rhs)
122.292 + end;
122.293 +
122.294 +(*************************************************************************)
122.295 +(********************** Proving associated theorems **********************)
122.296 +(*************************************************************************)
122.297 +
122.298 +fun eta_tac i = CONVERSION Thm.eta_conversion i;
122.299 +
122.300 +fun fixrec_simp_tac ctxt =
122.301 + let
122.302 + val tab = FixrecUnfoldData.get (Context.Proof ctxt);
122.303 + val ss = Simplifier.simpset_of ctxt;
122.304 + fun concl t =
122.305 + if Logic.is_all t then concl (snd (Logic.dest_all t))
122.306 + else HOLogic.dest_Trueprop (Logic.strip_imp_concl t);
122.307 + fun tac (t, i) =
122.308 + let
122.309 + val (c, T) =
122.310 + (dest_Const o head_of o chead_of o fst o HOLogic.dest_eq o concl) t;
122.311 + val unfold_thm = the (Symtab.lookup tab c);
122.312 + val rule = unfold_thm RS @{thm ssubst_lhs};
122.313 + in
122.314 + CHANGED (rtac rule i THEN eta_tac i THEN asm_simp_tac ss i)
122.315 + end
122.316 + in
122.317 + SUBGOAL (fn ti => the_default no_tac (try tac ti))
122.318 + end;
122.319 +
122.320 +(* proves a block of pattern matching equations as theorems, using unfold *)
122.321 +fun make_simps ctxt (unfold_thm, eqns : (Attrib.binding * term) list) =
122.322 + let
122.323 + val ss = Simplifier.simpset_of ctxt;
122.324 + val rule = unfold_thm RS @{thm ssubst_lhs};
122.325 + val tac = rtac rule 1 THEN eta_tac 1 THEN asm_simp_tac ss 1;
122.326 + fun prove_term t = Goal.prove ctxt [] [] t (K tac);
122.327 + fun prove_eqn (bind, eqn_t) = (bind, prove_term eqn_t);
122.328 + in
122.329 + map prove_eqn eqns
122.330 + end;
122.331 +
122.332 +(*************************************************************************)
122.333 +(************************* Main fixrec function **************************)
122.334 +(*************************************************************************)
122.335 +
122.336 +local
122.337 +(* code adapted from HOL/Tools/primrec.ML *)
122.338 +
122.339 +fun gen_fixrec
122.340 + prep_spec
122.341 + (raw_fixes : (binding * 'a option * mixfix) list)
122.342 + (raw_spec' : (bool * (Attrib.binding * 'b)) list)
122.343 + (lthy : local_theory) =
122.344 + let
122.345 + val (skips, raw_spec) = ListPair.unzip raw_spec';
122.346 + val (fixes : ((binding * typ) * mixfix) list,
122.347 + spec : (Attrib.binding * term) list) =
122.348 + fst (prep_spec raw_fixes raw_spec lthy);
122.349 + val chead_of_spec =
122.350 + chead_of o fst o dest_eqs o Logic.strip_imp_concl o strip_alls o snd;
122.351 + fun name_of (Free (n, _)) = n
122.352 + | name_of t = fixrec_err ("unknown term");
122.353 + val all_names = map (name_of o chead_of_spec) spec;
122.354 + val names = distinct (op =) all_names;
122.355 + fun block_of_name n =
122.356 + map_filter
122.357 + (fn (m,eq) => if m = n then SOME eq else NONE)
122.358 + (all_names ~~ (spec ~~ skips));
122.359 + val blocks = map block_of_name names;
122.360 +
122.361 + val matcher_tab = FixrecMatchData.get (ProofContext.theory_of lthy);
122.362 + fun match_name c =
122.363 + case Symtab.lookup matcher_tab c of SOME m => m
122.364 + | NONE => fixrec_err ("unknown pattern constructor: " ^ c);
122.365 +
122.366 + val matches = map (compile_eqs match_name) (map (map (snd o fst)) blocks);
122.367 + val spec' = map (pair Attrib.empty_binding) matches;
122.368 + val (lthy, cnames, fixdef_thms, unfold_thms) =
122.369 + add_fixdefs fixes spec' lthy;
122.370 +
122.371 + val blocks' = map (map fst o filter_out snd) blocks;
122.372 + val simps : (Attrib.binding * thm) list list =
122.373 + map (make_simps lthy) (unfold_thms ~~ blocks');
122.374 + fun mk_bind n : Attrib.binding =
122.375 + (Binding.qualify true n (Binding.name "simps"),
122.376 + [Attrib.internal (K Simplifier.simp_add)]);
122.377 + val simps1 : (Attrib.binding * thm list) list =
122.378 + map (fn (n,xs) => (mk_bind n, map snd xs)) (names ~~ simps);
122.379 + val simps2 : (Attrib.binding * thm list) list =
122.380 + map (apsnd (fn thm => [thm])) (flat simps);
122.381 + val (_, lthy) = lthy
122.382 + |> fold_map Local_Theory.note (simps1 @ simps2);
122.383 + in
122.384 + lthy
122.385 + end;
122.386 +
122.387 +in
122.388 +
122.389 +val add_fixrec = gen_fixrec Specification.check_spec;
122.390 +val add_fixrec_cmd = gen_fixrec Specification.read_spec;
122.391 +
122.392 +end; (* local *)
122.393 +
122.394 +
122.395 +(*************************************************************************)
122.396 +(******************************** Parsers ********************************)
122.397 +(*************************************************************************)
122.398 +
122.399 +val opt_thm_name' : (bool * Attrib.binding) parser =
122.400 + Parse.$$$ "(" -- Parse.$$$ "unchecked" -- Parse.$$$ ")" >> K (true, Attrib.empty_binding)
122.401 + || Parse_Spec.opt_thm_name ":" >> pair false;
122.402 +
122.403 +val spec' : (bool * (Attrib.binding * string)) parser =
122.404 + opt_thm_name' -- Parse.prop >> (fn ((a, b), c) => (a, (b, c)));
122.405 +
122.406 +val alt_specs' : (bool * (Attrib.binding * string)) list parser =
122.407 + let val unexpected = Scan.ahead (Parse.name || Parse.$$$ "[" || Parse.$$$ "(");
122.408 + in Parse.enum1 "|" (spec' --| Scan.option (unexpected -- Parse.!!! (Parse.$$$ "|"))) end;
122.409 +
122.410 +val _ =
122.411 + Outer_Syntax.local_theory "fixrec" "define recursive functions (HOLCF)" Keyword.thy_decl
122.412 + (Parse.fixes -- (Parse.where_ |-- Parse.!!! alt_specs')
122.413 + >> (fn (fixes, specs) => add_fixrec_cmd fixes specs));
122.414 +
122.415 +val setup =
122.416 + Method.setup @{binding fixrec_simp}
122.417 + (Scan.succeed (SIMPLE_METHOD' o fixrec_simp_tac))
122.418 + "pattern prover for fixrec constants";
122.419 +
122.420 +end;
123.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
123.2 +++ b/src/HOL/HOLCF/Tools/holcf_library.ML Sat Nov 27 16:08:10 2010 -0800
123.3 @@ -0,0 +1,289 @@
123.4 +(* Title: HOLCF/Tools/holcf_library.ML
123.5 + Author: Brian Huffman
123.6 +
123.7 +Functions for constructing HOLCF types and terms.
123.8 +*)
123.9 +
123.10 +structure HOLCF_Library =
123.11 +struct
123.12 +
123.13 +infixr 6 ->>;
123.14 +infixr -->>;
123.15 +infix 9 `;
123.16 +
123.17 +(*** Operations from Isabelle/HOL ***)
123.18 +
123.19 +val boolT = HOLogic.boolT;
123.20 +val natT = HOLogic.natT;
123.21 +
123.22 +val mk_equals = Logic.mk_equals;
123.23 +val mk_eq = HOLogic.mk_eq;
123.24 +val mk_trp = HOLogic.mk_Trueprop;
123.25 +val mk_fst = HOLogic.mk_fst;
123.26 +val mk_snd = HOLogic.mk_snd;
123.27 +val mk_not = HOLogic.mk_not;
123.28 +val mk_conj = HOLogic.mk_conj;
123.29 +val mk_disj = HOLogic.mk_disj;
123.30 +val mk_imp = HOLogic.mk_imp;
123.31 +
123.32 +fun mk_ex (x, t) = HOLogic.exists_const (fastype_of x) $ Term.lambda x t;
123.33 +fun mk_all (x, t) = HOLogic.all_const (fastype_of x) $ Term.lambda x t;
123.34 +
123.35 +
123.36 +(*** Basic HOLCF concepts ***)
123.37 +
123.38 +fun mk_bottom T = Const (@{const_name UU}, T);
123.39 +
123.40 +fun below_const T = Const (@{const_name below}, [T, T] ---> boolT);
123.41 +fun mk_below (t, u) = below_const (fastype_of t) $ t $ u;
123.42 +
123.43 +fun mk_undef t = mk_eq (t, mk_bottom (fastype_of t));
123.44 +
123.45 +fun mk_defined t = mk_not (mk_undef t);
123.46 +
123.47 +fun mk_adm t =
123.48 + Const (@{const_name adm}, fastype_of t --> boolT) $ t;
123.49 +
123.50 +fun mk_compact t =
123.51 + Const (@{const_name compact}, fastype_of t --> boolT) $ t;
123.52 +
123.53 +fun mk_cont t =
123.54 + Const (@{const_name cont}, fastype_of t --> boolT) $ t;
123.55 +
123.56 +fun mk_chain t =
123.57 + Const (@{const_name chain}, Term.fastype_of t --> boolT) $ t;
123.58 +
123.59 +fun mk_lub t =
123.60 + let
123.61 + val T = Term.range_type (Term.fastype_of t);
123.62 + val lub_const = Const (@{const_name lub}, (T --> boolT) --> T);
123.63 + val UNIV_const = @{term "UNIV :: nat set"};
123.64 + val image_type = (natT --> T) --> (natT --> boolT) --> T --> boolT;
123.65 + val image_const = Const (@{const_name image}, image_type);
123.66 + in
123.67 + lub_const $ (image_const $ t $ UNIV_const)
123.68 + end;
123.69 +
123.70 +
123.71 +(*** Continuous function space ***)
123.72 +
123.73 +fun mk_cfunT (T, U) = Type(@{type_name cfun}, [T, U]);
123.74 +
123.75 +val (op ->>) = mk_cfunT;
123.76 +val (op -->>) = Library.foldr mk_cfunT;
123.77 +
123.78 +fun dest_cfunT (Type(@{type_name cfun}, [T, U])) = (T, U)
123.79 + | dest_cfunT T = raise TYPE ("dest_cfunT", [T], []);
123.80 +
123.81 +fun capply_const (S, T) =
123.82 + Const(@{const_name Rep_cfun}, (S ->> T) --> (S --> T));
123.83 +
123.84 +fun cabs_const (S, T) =
123.85 + Const(@{const_name Abs_cfun}, (S --> T) --> (S ->> T));
123.86 +
123.87 +fun mk_cabs t =
123.88 + let val T = fastype_of t
123.89 + in cabs_const (Term.domain_type T, Term.range_type T) $ t end
123.90 +
123.91 +(* builds the expression (% v1 v2 .. vn. rhs) *)
123.92 +fun lambdas [] rhs = rhs
123.93 + | lambdas (v::vs) rhs = Term.lambda v (lambdas vs rhs);
123.94 +
123.95 +(* builds the expression (LAM v. rhs) *)
123.96 +fun big_lambda v rhs =
123.97 + cabs_const (fastype_of v, fastype_of rhs) $ Term.lambda v rhs;
123.98 +
123.99 +(* builds the expression (LAM v1 v2 .. vn. rhs) *)
123.100 +fun big_lambdas [] rhs = rhs
123.101 + | big_lambdas (v::vs) rhs = big_lambda v (big_lambdas vs rhs);
123.102 +
123.103 +fun mk_capply (t, u) =
123.104 + let val (S, T) =
123.105 + case fastype_of t of
123.106 + Type(@{type_name cfun}, [S, T]) => (S, T)
123.107 + | _ => raise TERM ("mk_capply " ^ ML_Syntax.print_list ML_Syntax.print_term [t, u], [t, u]);
123.108 + in capply_const (S, T) $ t $ u end;
123.109 +
123.110 +val (op `) = mk_capply;
123.111 +
123.112 +val list_ccomb : term * term list -> term = Library.foldl mk_capply;
123.113 +
123.114 +fun mk_ID T = Const (@{const_name ID}, T ->> T);
123.115 +
123.116 +fun cfcomp_const (T, U, V) =
123.117 + Const (@{const_name cfcomp}, (U ->> V) ->> (T ->> U) ->> (T ->> V));
123.118 +
123.119 +fun mk_cfcomp (f, g) =
123.120 + let
123.121 + val (U, V) = dest_cfunT (fastype_of f);
123.122 + val (T, U') = dest_cfunT (fastype_of g);
123.123 + in
123.124 + if U = U'
123.125 + then mk_capply (mk_capply (cfcomp_const (T, U, V), f), g)
123.126 + else raise TYPE ("mk_cfcomp", [U, U'], [f, g])
123.127 + end;
123.128 +
123.129 +fun strictify_const T = Const (@{const_name strictify}, T ->> T);
123.130 +fun mk_strictify t = strictify_const (fastype_of t) ` t;
123.131 +
123.132 +fun mk_strict t =
123.133 + let val (T, U) = dest_cfunT (fastype_of t);
123.134 + in mk_eq (t ` mk_bottom T, mk_bottom U) end;
123.135 +
123.136 +
123.137 +(*** Product type ***)
123.138 +
123.139 +val mk_prodT = HOLogic.mk_prodT
123.140 +
123.141 +fun mk_tupleT [] = HOLogic.unitT
123.142 + | mk_tupleT [T] = T
123.143 + | mk_tupleT (T :: Ts) = mk_prodT (T, mk_tupleT Ts);
123.144 +
123.145 +(* builds the expression (v1,v2,..,vn) *)
123.146 +fun mk_tuple [] = HOLogic.unit
123.147 + | mk_tuple (t::[]) = t
123.148 + | mk_tuple (t::ts) = HOLogic.mk_prod (t, mk_tuple ts);
123.149 +
123.150 +(* builds the expression (%(v1,v2,..,vn). rhs) *)
123.151 +fun lambda_tuple [] rhs = Term.lambda (Free("unit", HOLogic.unitT)) rhs
123.152 + | lambda_tuple (v::[]) rhs = Term.lambda v rhs
123.153 + | lambda_tuple (v::vs) rhs =
123.154 + HOLogic.mk_split (Term.lambda v (lambda_tuple vs rhs));
123.155 +
123.156 +
123.157 +(*** Lifted cpo type ***)
123.158 +
123.159 +fun mk_upT T = Type(@{type_name "u"}, [T]);
123.160 +
123.161 +fun dest_upT (Type(@{type_name "u"}, [T])) = T
123.162 + | dest_upT T = raise TYPE ("dest_upT", [T], []);
123.163 +
123.164 +fun up_const T = Const(@{const_name up}, T ->> mk_upT T);
123.165 +
123.166 +fun mk_up t = up_const (fastype_of t) ` t;
123.167 +
123.168 +fun fup_const (T, U) =
123.169 + Const(@{const_name fup}, (T ->> U) ->> mk_upT T ->> U);
123.170 +
123.171 +fun mk_fup t = fup_const (dest_cfunT (fastype_of t)) ` t;
123.172 +
123.173 +fun from_up T = fup_const (T, T) ` mk_ID T;
123.174 +
123.175 +
123.176 +(*** Lifted unit type ***)
123.177 +
123.178 +val oneT = @{typ "one"};
123.179 +
123.180 +fun one_case_const T = Const (@{const_name one_case}, T ->> oneT ->> T);
123.181 +fun mk_one_case t = one_case_const (fastype_of t) ` t;
123.182 +
123.183 +
123.184 +(*** Strict product type ***)
123.185 +
123.186 +fun mk_sprodT (T, U) = Type(@{type_name sprod}, [T, U]);
123.187 +
123.188 +fun dest_sprodT (Type(@{type_name sprod}, [T, U])) = (T, U)
123.189 + | dest_sprodT T = raise TYPE ("dest_sprodT", [T], []);
123.190 +
123.191 +fun spair_const (T, U) =
123.192 + Const(@{const_name spair}, T ->> U ->> mk_sprodT (T, U));
123.193 +
123.194 +(* builds the expression (:t, u:) *)
123.195 +fun mk_spair (t, u) =
123.196 + spair_const (fastype_of t, fastype_of u) ` t ` u;
123.197 +
123.198 +(* builds the expression (:t1,t2,..,tn:) *)
123.199 +fun mk_stuple [] = @{term "ONE"}
123.200 + | mk_stuple (t::[]) = t
123.201 + | mk_stuple (t::ts) = mk_spair (t, mk_stuple ts);
123.202 +
123.203 +fun sfst_const (T, U) =
123.204 + Const(@{const_name sfst}, mk_sprodT (T, U) ->> T);
123.205 +
123.206 +fun ssnd_const (T, U) =
123.207 + Const(@{const_name ssnd}, mk_sprodT (T, U) ->> U);
123.208 +
123.209 +fun ssplit_const (T, U, V) =
123.210 + Const (@{const_name ssplit}, (T ->> U ->> V) ->> mk_sprodT (T, U) ->> V);
123.211 +
123.212 +fun mk_ssplit t =
123.213 + let val (T, (U, V)) = apsnd dest_cfunT (dest_cfunT (fastype_of t));
123.214 + in ssplit_const (T, U, V) ` t end;
123.215 +
123.216 +
123.217 +(*** Strict sum type ***)
123.218 +
123.219 +fun mk_ssumT (T, U) = Type(@{type_name ssum}, [T, U]);
123.220 +
123.221 +fun dest_ssumT (Type(@{type_name ssum}, [T, U])) = (T, U)
123.222 + | dest_ssumT T = raise TYPE ("dest_ssumT", [T], []);
123.223 +
123.224 +fun sinl_const (T, U) = Const(@{const_name sinl}, T ->> mk_ssumT (T, U));
123.225 +fun sinr_const (T, U) = Const(@{const_name sinr}, U ->> mk_ssumT (T, U));
123.226 +
123.227 +(* builds the list [sinl(t1), sinl(sinr(t2)), ... sinr(...sinr(tn))] *)
123.228 +fun mk_sinjects ts =
123.229 + let
123.230 + val Ts = map fastype_of ts;
123.231 + fun combine (t, T) (us, U) =
123.232 + let
123.233 + val v = sinl_const (T, U) ` t;
123.234 + val vs = map (fn u => sinr_const (T, U) ` u) us;
123.235 + in
123.236 + (v::vs, mk_ssumT (T, U))
123.237 + end
123.238 + fun inj [] = raise Fail "mk_sinjects: empty list"
123.239 + | inj ((t, T)::[]) = ([t], T)
123.240 + | inj ((t, T)::ts) = combine (t, T) (inj ts);
123.241 + in
123.242 + fst (inj (ts ~~ Ts))
123.243 + end;
123.244 +
123.245 +fun sscase_const (T, U, V) =
123.246 + Const(@{const_name sscase},
123.247 + (T ->> V) ->> (U ->> V) ->> mk_ssumT (T, U) ->> V);
123.248 +
123.249 +fun mk_sscase (t, u) =
123.250 + let val (T, V) = dest_cfunT (fastype_of t);
123.251 + val (U, V) = dest_cfunT (fastype_of u);
123.252 + in sscase_const (T, U, V) ` t ` u end;
123.253 +
123.254 +fun from_sinl (T, U) =
123.255 + sscase_const (T, U, T) ` mk_ID T ` mk_bottom (U ->> T);
123.256 +
123.257 +fun from_sinr (T, U) =
123.258 + sscase_const (T, U, U) ` mk_bottom (T ->> U) ` mk_ID U;
123.259 +
123.260 +
123.261 +(*** pattern match monad type ***)
123.262 +
123.263 +fun mk_matchT T = Type (@{type_name "match"}, [T]);
123.264 +
123.265 +fun dest_matchT (Type(@{type_name "match"}, [T])) = T
123.266 + | dest_matchT T = raise TYPE ("dest_matchT", [T], []);
123.267 +
123.268 +fun mk_fail T = Const (@{const_name "Fixrec.fail"}, mk_matchT T);
123.269 +
123.270 +fun succeed_const T = Const (@{const_name "Fixrec.succeed"}, T ->> mk_matchT T);
123.271 +fun mk_succeed t = succeed_const (fastype_of t) ` t;
123.272 +
123.273 +
123.274 +(*** lifted boolean type ***)
123.275 +
123.276 +val trT = @{typ "tr"};
123.277 +
123.278 +
123.279 +(*** theory of fixed points ***)
123.280 +
123.281 +fun mk_fix t =
123.282 + let val (T, _) = dest_cfunT (fastype_of t)
123.283 + in mk_capply (Const(@{const_name fix}, (T ->> T) ->> T), t) end;
123.284 +
123.285 +fun iterate_const T =
123.286 + Const (@{const_name iterate}, natT --> (T ->> T) ->> (T ->> T));
123.287 +
123.288 +fun mk_iterate (n, f) =
123.289 + let val (T, _) = dest_cfunT (Term.fastype_of f);
123.290 + in (iterate_const T $ n) ` f ` mk_bottom T end;
123.291 +
123.292 +end;
124.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
124.2 +++ b/src/HOL/HOLCF/Tr.thy Sat Nov 27 16:08:10 2010 -0800
124.3 @@ -0,0 +1,199 @@
124.4 +(* Title: HOLCF/Tr.thy
124.5 + Author: Franz Regensburger
124.6 +*)
124.7 +
124.8 +header {* The type of lifted booleans *}
124.9 +
124.10 +theory Tr
124.11 +imports Lift
124.12 +begin
124.13 +
124.14 +subsection {* Type definition and constructors *}
124.15 +
124.16 +types
124.17 + tr = "bool lift"
124.18 +
124.19 +translations
124.20 + (type) "tr" <= (type) "bool lift"
124.21 +
124.22 +definition
124.23 + TT :: "tr" where
124.24 + "TT = Def True"
124.25 +
124.26 +definition
124.27 + FF :: "tr" where
124.28 + "FF = Def False"
124.29 +
124.30 +text {* Exhaustion and Elimination for type @{typ tr} *}
124.31 +
124.32 +lemma Exh_tr: "t = \<bottom> \<or> t = TT \<or> t = FF"
124.33 +unfolding FF_def TT_def by (induct t) auto
124.34 +
124.35 +lemma trE [case_names bottom TT FF]:
124.36 + "\<lbrakk>p = \<bottom> \<Longrightarrow> Q; p = TT \<Longrightarrow> Q; p = FF \<Longrightarrow> Q\<rbrakk> \<Longrightarrow> Q"
124.37 +unfolding FF_def TT_def by (induct p) auto
124.38 +
124.39 +lemma tr_induct [case_names bottom TT FF]:
124.40 + "\<lbrakk>P \<bottom>; P TT; P FF\<rbrakk> \<Longrightarrow> P x"
124.41 +by (cases x rule: trE) simp_all
124.42 +
124.43 +text {* distinctness for type @{typ tr} *}
124.44 +
124.45 +lemma dist_below_tr [simp]:
124.46 + "\<not> TT \<sqsubseteq> \<bottom>" "\<not> FF \<sqsubseteq> \<bottom>" "\<not> TT \<sqsubseteq> FF" "\<not> FF \<sqsubseteq> TT"
124.47 +unfolding TT_def FF_def by simp_all
124.48 +
124.49 +lemma dist_eq_tr [simp]:
124.50 + "TT \<noteq> \<bottom>" "FF \<noteq> \<bottom>" "TT \<noteq> FF" "\<bottom> \<noteq> TT" "\<bottom> \<noteq> FF" "FF \<noteq> TT"
124.51 +unfolding TT_def FF_def by simp_all
124.52 +
124.53 +lemma TT_below_iff [simp]: "TT \<sqsubseteq> x \<longleftrightarrow> x = TT"
124.54 +by (induct x rule: tr_induct) simp_all
124.55 +
124.56 +lemma FF_below_iff [simp]: "FF \<sqsubseteq> x \<longleftrightarrow> x = FF"
124.57 +by (induct x rule: tr_induct) simp_all
124.58 +
124.59 +lemma not_below_TT_iff [simp]: "\<not> (x \<sqsubseteq> TT) \<longleftrightarrow> x = FF"
124.60 +by (induct x rule: tr_induct) simp_all
124.61 +
124.62 +lemma not_below_FF_iff [simp]: "\<not> (x \<sqsubseteq> FF) \<longleftrightarrow> x = TT"
124.63 +by (induct x rule: tr_induct) simp_all
124.64 +
124.65 +
124.66 +subsection {* Case analysis *}
124.67 +
124.68 +default_sort pcpo
124.69 +
124.70 +definition tr_case :: "'a \<rightarrow> 'a \<rightarrow> tr \<rightarrow> 'a" where
124.71 + "tr_case = (\<Lambda> t e (Def b). if b then t else e)"
124.72 +
124.73 +abbreviation
124.74 + cifte_syn :: "[tr, 'c, 'c] \<Rightarrow> 'c" ("(If (_)/ then (_)/ else (_))" [0, 0, 60] 60)
124.75 +where
124.76 + "If b then e1 else e2 == tr_case\<cdot>e1\<cdot>e2\<cdot>b"
124.77 +
124.78 +translations
124.79 + "\<Lambda> (XCONST TT). t" == "CONST tr_case\<cdot>t\<cdot>\<bottom>"
124.80 + "\<Lambda> (XCONST FF). t" == "CONST tr_case\<cdot>\<bottom>\<cdot>t"
124.81 +
124.82 +lemma ifte_thms [simp]:
124.83 + "If \<bottom> then e1 else e2 = \<bottom>"
124.84 + "If FF then e1 else e2 = e2"
124.85 + "If TT then e1 else e2 = e1"
124.86 +by (simp_all add: tr_case_def TT_def FF_def)
124.87 +
124.88 +
124.89 +subsection {* Boolean connectives *}
124.90 +
124.91 +definition
124.92 + trand :: "tr \<rightarrow> tr \<rightarrow> tr" where
124.93 + andalso_def: "trand = (\<Lambda> x y. If x then y else FF)"
124.94 +abbreviation
124.95 + andalso_syn :: "tr \<Rightarrow> tr \<Rightarrow> tr" ("_ andalso _" [36,35] 35) where
124.96 + "x andalso y == trand\<cdot>x\<cdot>y"
124.97 +
124.98 +definition
124.99 + tror :: "tr \<rightarrow> tr \<rightarrow> tr" where
124.100 + orelse_def: "tror = (\<Lambda> x y. If x then TT else y)"
124.101 +abbreviation
124.102 + orelse_syn :: "tr \<Rightarrow> tr \<Rightarrow> tr" ("_ orelse _" [31,30] 30) where
124.103 + "x orelse y == tror\<cdot>x\<cdot>y"
124.104 +
124.105 +definition
124.106 + neg :: "tr \<rightarrow> tr" where
124.107 + "neg = flift2 Not"
124.108 +
124.109 +definition
124.110 + If2 :: "[tr, 'c, 'c] \<Rightarrow> 'c" where
124.111 + "If2 Q x y = (If Q then x else y)"
124.112 +
124.113 +text {* tactic for tr-thms with case split *}
124.114 +
124.115 +lemmas tr_defs = andalso_def orelse_def neg_def tr_case_def TT_def FF_def
124.116 +
124.117 +text {* lemmas about andalso, orelse, neg and if *}
124.118 +
124.119 +lemma andalso_thms [simp]:
124.120 + "(TT andalso y) = y"
124.121 + "(FF andalso y) = FF"
124.122 + "(\<bottom> andalso y) = \<bottom>"
124.123 + "(y andalso TT) = y"
124.124 + "(y andalso y) = y"
124.125 +apply (unfold andalso_def, simp_all)
124.126 +apply (cases y rule: trE, simp_all)
124.127 +apply (cases y rule: trE, simp_all)
124.128 +done
124.129 +
124.130 +lemma orelse_thms [simp]:
124.131 + "(TT orelse y) = TT"
124.132 + "(FF orelse y) = y"
124.133 + "(\<bottom> orelse y) = \<bottom>"
124.134 + "(y orelse FF) = y"
124.135 + "(y orelse y) = y"
124.136 +apply (unfold orelse_def, simp_all)
124.137 +apply (cases y rule: trE, simp_all)
124.138 +apply (cases y rule: trE, simp_all)
124.139 +done
124.140 +
124.141 +lemma neg_thms [simp]:
124.142 + "neg\<cdot>TT = FF"
124.143 + "neg\<cdot>FF = TT"
124.144 + "neg\<cdot>\<bottom> = \<bottom>"
124.145 +by (simp_all add: neg_def TT_def FF_def)
124.146 +
124.147 +text {* split-tac for If via If2 because the constant has to be a constant *}
124.148 +
124.149 +lemma split_If2:
124.150 + "P (If2 Q x y) = ((Q = \<bottom> \<longrightarrow> P \<bottom>) \<and> (Q = TT \<longrightarrow> P x) \<and> (Q = FF \<longrightarrow> P y))"
124.151 +apply (unfold If2_def)
124.152 +apply (rule_tac p = "Q" in trE)
124.153 +apply (simp_all)
124.154 +done
124.155 +
124.156 +ML {*
124.157 +val split_If_tac =
124.158 + simp_tac (HOL_basic_ss addsimps [@{thm If2_def} RS sym])
124.159 + THEN' (split_tac [@{thm split_If2}])
124.160 +*}
124.161 +
124.162 +subsection "Rewriting of HOLCF operations to HOL functions"
124.163 +
124.164 +lemma andalso_or:
124.165 + "t \<noteq> \<bottom> \<Longrightarrow> ((t andalso s) = FF) = (t = FF \<or> s = FF)"
124.166 +apply (rule_tac p = "t" in trE)
124.167 +apply simp_all
124.168 +done
124.169 +
124.170 +lemma andalso_and:
124.171 + "t \<noteq> \<bottom> \<Longrightarrow> ((t andalso s) \<noteq> FF) = (t \<noteq> FF \<and> s \<noteq> FF)"
124.172 +apply (rule_tac p = "t" in trE)
124.173 +apply simp_all
124.174 +done
124.175 +
124.176 +lemma Def_bool1 [simp]: "(Def x \<noteq> FF) = x"
124.177 +by (simp add: FF_def)
124.178 +
124.179 +lemma Def_bool2 [simp]: "(Def x = FF) = (\<not> x)"
124.180 +by (simp add: FF_def)
124.181 +
124.182 +lemma Def_bool3 [simp]: "(Def x = TT) = x"
124.183 +by (simp add: TT_def)
124.184 +
124.185 +lemma Def_bool4 [simp]: "(Def x \<noteq> TT) = (\<not> x)"
124.186 +by (simp add: TT_def)
124.187 +
124.188 +lemma If_and_if:
124.189 + "(If Def P then A else B) = (if P then A else B)"
124.190 +apply (rule_tac p = "Def P" in trE)
124.191 +apply (auto simp add: TT_def[symmetric] FF_def[symmetric])
124.192 +done
124.193 +
124.194 +subsection {* Compactness *}
124.195 +
124.196 +lemma compact_TT: "compact TT"
124.197 +by (rule compact_chfin)
124.198 +
124.199 +lemma compact_FF: "compact FF"
124.200 +by (rule compact_chfin)
124.201 +
124.202 +end
125.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
125.2 +++ b/src/HOL/HOLCF/Tutorial/Domain_ex.thy Sat Nov 27 16:08:10 2010 -0800
125.3 @@ -0,0 +1,201 @@
125.4 +(* Title: HOLCF/ex/Domain_ex.thy
125.5 + Author: Brian Huffman
125.6 +*)
125.7 +
125.8 +header {* Domain package examples *}
125.9 +
125.10 +theory Domain_ex
125.11 +imports HOLCF
125.12 +begin
125.13 +
125.14 +text {* Domain constructors are strict by default. *}
125.15 +
125.16 +domain d1 = d1a | d1b "d1" "d1"
125.17 +
125.18 +lemma "d1b\<cdot>\<bottom>\<cdot>y = \<bottom>" by simp
125.19 +
125.20 +text {* Constructors can be made lazy using the @{text "lazy"} keyword. *}
125.21 +
125.22 +domain d2 = d2a | d2b (lazy "d2")
125.23 +
125.24 +lemma "d2b\<cdot>x \<noteq> \<bottom>" by simp
125.25 +
125.26 +text {* Strict and lazy arguments may be mixed arbitrarily. *}
125.27 +
125.28 +domain d3 = d3a | d3b (lazy "d2") "d2"
125.29 +
125.30 +lemma "P (d3b\<cdot>x\<cdot>y = \<bottom>) \<longleftrightarrow> P (y = \<bottom>)" by simp
125.31 +
125.32 +text {* Selectors can be used with strict or lazy constructor arguments. *}
125.33 +
125.34 +domain d4 = d4a | d4b (lazy d4b_left :: "d2") (d4b_right :: "d2")
125.35 +
125.36 +lemma "y \<noteq> \<bottom> \<Longrightarrow> d4b_left\<cdot>(d4b\<cdot>x\<cdot>y) = x" by simp
125.37 +
125.38 +text {* Mixfix declarations can be given for data constructors. *}
125.39 +
125.40 +domain d5 = d5a | d5b (lazy "d5") "d5" (infixl ":#:" 70)
125.41 +
125.42 +lemma "d5a \<noteq> x :#: y :#: z" by simp
125.43 +
125.44 +text {* Mixfix declarations can also be given for type constructors. *}
125.45 +
125.46 +domain ('a, 'b) lazypair (infixl ":*:" 25) =
125.47 + lpair (lazy lfst :: 'a) (lazy lsnd :: 'b) (infixl ":*:" 75)
125.48 +
125.49 +lemma "\<forall>p::('a :*: 'b). p \<sqsubseteq> lfst\<cdot>p :*: lsnd\<cdot>p"
125.50 +by (rule allI, case_tac p, simp_all)
125.51 +
125.52 +text {* Non-recursive constructor arguments can have arbitrary types. *}
125.53 +
125.54 +domain ('a, 'b) d6 = d6 "int lift" "'a \<oplus> 'b u" (lazy "('a :*: 'b) \<times> ('b \<rightarrow> 'a)")
125.55 +
125.56 +text {*
125.57 + Indirect recusion is allowed for sums, products, lifting, and the
125.58 + continuous function space. However, the domain package does not
125.59 + generate an induction rule in terms of the constructors.
125.60 +*}
125.61 +
125.62 +domain 'a d7 = d7a "'a d7 \<oplus> int lift" | d7b "'a \<otimes> 'a d7" | d7c (lazy "'a d7 \<rightarrow> 'a")
125.63 + -- "Indirect recursion detected, skipping proofs of (co)induction rules"
125.64 +
125.65 +text {* Note that @{text d7.induct} is absent. *}
125.66 +
125.67 +text {*
125.68 + Indirect recursion is also allowed using previously-defined datatypes.
125.69 +*}
125.70 +
125.71 +domain 'a slist = SNil | SCons 'a "'a slist"
125.72 +
125.73 +domain 'a stree = STip | SBranch "'a stree slist"
125.74 +
125.75 +text {* Mutually-recursive datatypes can be defined using the @{text "and"} keyword. *}
125.76 +
125.77 +domain d8 = d8a | d8b "d9" and d9 = d9a | d9b (lazy "d8")
125.78 +
125.79 +text {* Non-regular recursion is not allowed. *}
125.80 +(*
125.81 +domain ('a, 'b) altlist = ANil | ACons 'a "('b, 'a) altlist"
125.82 + -- "illegal direct recursion with different arguments"
125.83 +domain 'a nest = Nest1 'a | Nest2 "'a nest nest"
125.84 + -- "illegal direct recursion with different arguments"
125.85 +*)
125.86 +
125.87 +text {*
125.88 + Mutually-recursive datatypes must have all the same type arguments,
125.89 + not necessarily in the same order.
125.90 +*}
125.91 +
125.92 +domain ('a, 'b) list1 = Nil1 | Cons1 'a "('b, 'a) list2"
125.93 + and ('b, 'a) list2 = Nil2 | Cons2 'b "('a, 'b) list1"
125.94 +
125.95 +text {* Induction rules for flat datatypes have no admissibility side-condition. *}
125.96 +
125.97 +domain 'a flattree = Tip | Branch "'a flattree" "'a flattree"
125.98 +
125.99 +lemma "\<lbrakk>P \<bottom>; P Tip; \<And>x y. \<lbrakk>x \<noteq> \<bottom>; y \<noteq> \<bottom>; P x; P y\<rbrakk> \<Longrightarrow> P (Branch\<cdot>x\<cdot>y)\<rbrakk> \<Longrightarrow> P x"
125.100 +by (rule flattree.induct) -- "no admissibility requirement"
125.101 +
125.102 +text {* Trivial datatypes will produce a warning message. *}
125.103 +
125.104 +domain triv = Triv triv triv
125.105 + -- "domain @{text Domain_ex.triv} is empty!"
125.106 +
125.107 +lemma "(x::triv) = \<bottom>" by (induct x, simp_all)
125.108 +
125.109 +text {* Lazy constructor arguments may have unpointed types. *}
125.110 +
125.111 +domain natlist = nnil | ncons (lazy "nat discr") natlist
125.112 +
125.113 +text {* Class constraints may be given for type parameters on the LHS. *}
125.114 +
125.115 +domain ('a::predomain) box = Box (lazy 'a)
125.116 +
125.117 +domain ('a::countable) stream = snil | scons (lazy "'a discr") "'a stream"
125.118 +
125.119 +
125.120 +subsection {* Generated constants and theorems *}
125.121 +
125.122 +domain 'a tree = Leaf (lazy 'a) | Node (left :: "'a tree") (right :: "'a tree")
125.123 +
125.124 +lemmas tree_abs_bottom_iff =
125.125 + iso.abs_bottom_iff [OF iso.intro [OF tree.abs_iso tree.rep_iso]]
125.126 +
125.127 +text {* Rules about ismorphism *}
125.128 +term tree_rep
125.129 +term tree_abs
125.130 +thm tree.rep_iso
125.131 +thm tree.abs_iso
125.132 +thm tree.iso_rews
125.133 +
125.134 +text {* Rules about constructors *}
125.135 +term Leaf
125.136 +term Node
125.137 +thm Leaf_def Node_def
125.138 +thm tree.nchotomy
125.139 +thm tree.exhaust
125.140 +thm tree.compacts
125.141 +thm tree.con_rews
125.142 +thm tree.dist_les
125.143 +thm tree.dist_eqs
125.144 +thm tree.inverts
125.145 +thm tree.injects
125.146 +
125.147 +text {* Rules about case combinator *}
125.148 +term tree_case
125.149 +thm tree.tree_case_def
125.150 +thm tree.case_rews
125.151 +
125.152 +text {* Rules about selectors *}
125.153 +term left
125.154 +term right
125.155 +thm tree.sel_rews
125.156 +
125.157 +text {* Rules about discriminators *}
125.158 +term is_Leaf
125.159 +term is_Node
125.160 +thm tree.dis_rews
125.161 +
125.162 +text {* Rules about monadic pattern match combinators *}
125.163 +term match_Leaf
125.164 +term match_Node
125.165 +thm tree.match_rews
125.166 +
125.167 +text {* Rules about take function *}
125.168 +term tree_take
125.169 +thm tree.take_def
125.170 +thm tree.take_0
125.171 +thm tree.take_Suc
125.172 +thm tree.take_rews
125.173 +thm tree.chain_take
125.174 +thm tree.take_take
125.175 +thm tree.deflation_take
125.176 +thm tree.take_below
125.177 +thm tree.take_lemma
125.178 +thm tree.lub_take
125.179 +thm tree.reach
125.180 +thm tree.finite_induct
125.181 +
125.182 +text {* Rules about finiteness predicate *}
125.183 +term tree_finite
125.184 +thm tree.finite_def
125.185 +thm tree.finite (* only generated for flat datatypes *)
125.186 +
125.187 +text {* Rules about bisimulation predicate *}
125.188 +term tree_bisim
125.189 +thm tree.bisim_def
125.190 +thm tree.coinduct
125.191 +
125.192 +text {* Induction rule *}
125.193 +thm tree.induct
125.194 +
125.195 +
125.196 +subsection {* Known bugs *}
125.197 +
125.198 +text {* Declaring a mixfix with spaces causes some strange parse errors. *}
125.199 +(*
125.200 +domain xx = xx ("x y")
125.201 + -- "Inner syntax error: unexpected end of input"
125.202 +*)
125.203 +
125.204 +end
126.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
126.2 +++ b/src/HOL/HOLCF/Tutorial/Fixrec_ex.thy Sat Nov 27 16:08:10 2010 -0800
126.3 @@ -0,0 +1,245 @@
126.4 +(* Title: HOLCF/ex/Fixrec_ex.thy
126.5 + Author: Brian Huffman
126.6 +*)
126.7 +
126.8 +header {* Fixrec package examples *}
126.9 +
126.10 +theory Fixrec_ex
126.11 +imports HOLCF
126.12 +begin
126.13 +
126.14 +subsection {* Basic @{text fixrec} examples *}
126.15 +
126.16 +text {*
126.17 + Fixrec patterns can mention any constructor defined by the domain
126.18 + package, as well as any of the following built-in constructors:
126.19 + Pair, spair, sinl, sinr, up, ONE, TT, FF.
126.20 +*}
126.21 +
126.22 +text {* Typical usage is with lazy constructors. *}
126.23 +
126.24 +fixrec down :: "'a u \<rightarrow> 'a"
126.25 +where "down\<cdot>(up\<cdot>x) = x"
126.26 +
126.27 +text {* With strict constructors, rewrite rules may require side conditions. *}
126.28 +
126.29 +fixrec from_sinl :: "'a \<oplus> 'b \<rightarrow> 'a"
126.30 +where "x \<noteq> \<bottom> \<Longrightarrow> from_sinl\<cdot>(sinl\<cdot>x) = x"
126.31 +
126.32 +text {* Lifting can turn a strict constructor into a lazy one. *}
126.33 +
126.34 +fixrec from_sinl_up :: "'a u \<oplus> 'b \<rightarrow> 'a"
126.35 +where "from_sinl_up\<cdot>(sinl\<cdot>(up\<cdot>x)) = x"
126.36 +
126.37 +text {* Fixrec also works with the HOL pair constructor. *}
126.38 +
126.39 +fixrec down2 :: "'a u \<times> 'b u \<rightarrow> 'a \<times> 'b"
126.40 +where "down2\<cdot>(up\<cdot>x, up\<cdot>y) = (x, y)"
126.41 +
126.42 +
126.43 +subsection {* Examples using @{text fixrec_simp} *}
126.44 +
126.45 +text {* A type of lazy lists. *}
126.46 +
126.47 +domain 'a llist = lNil | lCons (lazy 'a) (lazy "'a llist")
126.48 +
126.49 +text {* A zip function for lazy lists. *}
126.50 +
126.51 +text {* Notice that the patterns are not exhaustive. *}
126.52 +
126.53 +fixrec
126.54 + lzip :: "'a llist \<rightarrow> 'b llist \<rightarrow> ('a \<times> 'b) llist"
126.55 +where
126.56 + "lzip\<cdot>(lCons\<cdot>x\<cdot>xs)\<cdot>(lCons\<cdot>y\<cdot>ys) = lCons\<cdot>(x, y)\<cdot>(lzip\<cdot>xs\<cdot>ys)"
126.57 +| "lzip\<cdot>lNil\<cdot>lNil = lNil"
126.58 +
126.59 +text {* @{text fixrec_simp} is useful for producing strictness theorems. *}
126.60 +text {* Note that pattern matching is done in left-to-right order. *}
126.61 +
126.62 +lemma lzip_stricts [simp]:
126.63 + "lzip\<cdot>\<bottom>\<cdot>ys = \<bottom>"
126.64 + "lzip\<cdot>lNil\<cdot>\<bottom> = \<bottom>"
126.65 + "lzip\<cdot>(lCons\<cdot>x\<cdot>xs)\<cdot>\<bottom> = \<bottom>"
126.66 +by fixrec_simp+
126.67 +
126.68 +text {* @{text fixrec_simp} can also produce rules for missing cases. *}
126.69 +
126.70 +lemma lzip_undefs [simp]:
126.71 + "lzip\<cdot>lNil\<cdot>(lCons\<cdot>y\<cdot>ys) = \<bottom>"
126.72 + "lzip\<cdot>(lCons\<cdot>x\<cdot>xs)\<cdot>lNil = \<bottom>"
126.73 +by fixrec_simp+
126.74 +
126.75 +
126.76 +subsection {* Pattern matching with bottoms *}
126.77 +
126.78 +text {*
126.79 + As an alternative to using @{text fixrec_simp}, it is also possible
126.80 + to use bottom as a constructor pattern. When using a bottom
126.81 + pattern, the right-hand-side must also be bottom; otherwise, @{text
126.82 + fixrec} will not be able to prove the equation.
126.83 +*}
126.84 +
126.85 +fixrec
126.86 + from_sinr_up :: "'a \<oplus> 'b\<^sub>\<bottom> \<rightarrow> 'b"
126.87 +where
126.88 + "from_sinr_up\<cdot>\<bottom> = \<bottom>"
126.89 +| "from_sinr_up\<cdot>(sinr\<cdot>(up\<cdot>x)) = x"
126.90 +
126.91 +text {*
126.92 + If the function is already strict in that argument, then the bottom
126.93 + pattern does not change the meaning of the function. For example,
126.94 + in the definition of @{term from_sinr_up}, the first equation is
126.95 + actually redundant, and could have been proven separately by
126.96 + @{text fixrec_simp}.
126.97 +*}
126.98 +
126.99 +text {*
126.100 + A bottom pattern can also be used to make a function strict in a
126.101 + certain argument, similar to a bang-pattern in Haskell.
126.102 +*}
126.103 +
126.104 +fixrec
126.105 + seq :: "'a \<rightarrow> 'b \<rightarrow> 'b"
126.106 +where
126.107 + "seq\<cdot>\<bottom>\<cdot>y = \<bottom>"
126.108 +| "x \<noteq> \<bottom> \<Longrightarrow> seq\<cdot>x\<cdot>y = y"
126.109 +
126.110 +
126.111 +subsection {* Skipping proofs of rewrite rules *}
126.112 +
126.113 +text {* Another zip function for lazy lists. *}
126.114 +
126.115 +text {*
126.116 + Notice that this version has overlapping patterns.
126.117 + The second equation cannot be proved as a theorem
126.118 + because it only applies when the first pattern fails.
126.119 +*}
126.120 +
126.121 +fixrec
126.122 + lzip2 :: "'a llist \<rightarrow> 'b llist \<rightarrow> ('a \<times> 'b) llist"
126.123 +where
126.124 + "lzip2\<cdot>(lCons\<cdot>x\<cdot>xs)\<cdot>(lCons\<cdot>y\<cdot>ys) = lCons\<cdot>(x, y)\<cdot>(lzip2\<cdot>xs\<cdot>ys)"
126.125 +| (unchecked) "lzip2\<cdot>xs\<cdot>ys = lNil"
126.126 +
126.127 +text {*
126.128 + Usually fixrec tries to prove all equations as theorems.
126.129 + The "unchecked" option overrides this behavior, so fixrec
126.130 + does not attempt to prove that particular equation.
126.131 +*}
126.132 +
126.133 +text {* Simp rules can be generated later using @{text fixrec_simp}. *}
126.134 +
126.135 +lemma lzip2_simps [simp]:
126.136 + "lzip2\<cdot>(lCons\<cdot>x\<cdot>xs)\<cdot>lNil = lNil"
126.137 + "lzip2\<cdot>lNil\<cdot>(lCons\<cdot>y\<cdot>ys) = lNil"
126.138 + "lzip2\<cdot>lNil\<cdot>lNil = lNil"
126.139 +by fixrec_simp+
126.140 +
126.141 +lemma lzip2_stricts [simp]:
126.142 + "lzip2\<cdot>\<bottom>\<cdot>ys = \<bottom>"
126.143 + "lzip2\<cdot>(lCons\<cdot>x\<cdot>xs)\<cdot>\<bottom> = \<bottom>"
126.144 +by fixrec_simp+
126.145 +
126.146 +
126.147 +subsection {* Mutual recursion with @{text fixrec} *}
126.148 +
126.149 +text {* Tree and forest types. *}
126.150 +
126.151 +domain 'a tree = Leaf (lazy 'a) | Branch (lazy "'a forest")
126.152 +and 'a forest = Empty | Trees (lazy "'a tree") "'a forest"
126.153 +
126.154 +text {*
126.155 + To define mutually recursive functions, give multiple type signatures
126.156 + separated by the keyword @{text "and"}.
126.157 +*}
126.158 +
126.159 +fixrec
126.160 + map_tree :: "('a \<rightarrow> 'b) \<rightarrow> ('a tree \<rightarrow> 'b tree)"
126.161 +and
126.162 + map_forest :: "('a \<rightarrow> 'b) \<rightarrow> ('a forest \<rightarrow> 'b forest)"
126.163 +where
126.164 + "map_tree\<cdot>f\<cdot>(Leaf\<cdot>x) = Leaf\<cdot>(f\<cdot>x)"
126.165 +| "map_tree\<cdot>f\<cdot>(Branch\<cdot>ts) = Branch\<cdot>(map_forest\<cdot>f\<cdot>ts)"
126.166 +| "map_forest\<cdot>f\<cdot>Empty = Empty"
126.167 +| "ts \<noteq> \<bottom> \<Longrightarrow>
126.168 + map_forest\<cdot>f\<cdot>(Trees\<cdot>t\<cdot>ts) = Trees\<cdot>(map_tree\<cdot>f\<cdot>t)\<cdot>(map_forest\<cdot>f\<cdot>ts)"
126.169 +
126.170 +lemma map_tree_strict [simp]: "map_tree\<cdot>f\<cdot>\<bottom> = \<bottom>"
126.171 +by fixrec_simp
126.172 +
126.173 +lemma map_forest_strict [simp]: "map_forest\<cdot>f\<cdot>\<bottom> = \<bottom>"
126.174 +by fixrec_simp
126.175 +
126.176 +(*
126.177 + Theorems generated:
126.178 + @{text map_tree_def} @{thm map_tree_def}
126.179 + @{text map_forest_def} @{thm map_forest_def}
126.180 + @{text map_tree.unfold} @{thm map_tree.unfold}
126.181 + @{text map_forest.unfold} @{thm map_forest.unfold}
126.182 + @{text map_tree.simps} @{thm map_tree.simps}
126.183 + @{text map_forest.simps} @{thm map_forest.simps}
126.184 + @{text map_tree_map_forest.induct} @{thm map_tree_map_forest.induct}
126.185 +*)
126.186 +
126.187 +
126.188 +subsection {* Looping simp rules *}
126.189 +
126.190 +text {*
126.191 + The defining equations of a fixrec definition are declared as simp
126.192 + rules by default. In some cases, especially for constants with no
126.193 + arguments or functions with variable patterns, the defining
126.194 + equations may cause the simplifier to loop. In these cases it will
126.195 + be necessary to use a @{text "[simp del]"} declaration.
126.196 +*}
126.197 +
126.198 +fixrec
126.199 + repeat :: "'a \<rightarrow> 'a llist"
126.200 +where
126.201 + [simp del]: "repeat\<cdot>x = lCons\<cdot>x\<cdot>(repeat\<cdot>x)"
126.202 +
126.203 +text {*
126.204 + We can derive other non-looping simp rules for @{const repeat} by
126.205 + using the @{text subst} method with the @{text repeat.simps} rule.
126.206 +*}
126.207 +
126.208 +lemma repeat_simps [simp]:
126.209 + "repeat\<cdot>x \<noteq> \<bottom>"
126.210 + "repeat\<cdot>x \<noteq> lNil"
126.211 + "repeat\<cdot>x = lCons\<cdot>y\<cdot>ys \<longleftrightarrow> x = y \<and> repeat\<cdot>x = ys"
126.212 +by (subst repeat.simps, simp)+
126.213 +
126.214 +lemma llist_case_repeat [simp]:
126.215 + "llist_case\<cdot>z\<cdot>f\<cdot>(repeat\<cdot>x) = f\<cdot>x\<cdot>(repeat\<cdot>x)"
126.216 +by (subst repeat.simps, simp)
126.217 +
126.218 +text {*
126.219 + For mutually-recursive constants, looping might only occur if all
126.220 + equations are in the simpset at the same time. In such cases it may
126.221 + only be necessary to declare @{text "[simp del]"} on one equation.
126.222 +*}
126.223 +
126.224 +fixrec
126.225 + inf_tree :: "'a tree" and inf_forest :: "'a forest"
126.226 +where
126.227 + [simp del]: "inf_tree = Branch\<cdot>inf_forest"
126.228 +| "inf_forest = Trees\<cdot>inf_tree\<cdot>(Trees\<cdot>inf_tree\<cdot>Empty)"
126.229 +
126.230 +
126.231 +subsection {* Using @{text fixrec} inside locales *}
126.232 +
126.233 +locale test =
126.234 + fixes foo :: "'a \<rightarrow> 'a"
126.235 + assumes foo_strict: "foo\<cdot>\<bottom> = \<bottom>"
126.236 +begin
126.237 +
126.238 +fixrec
126.239 + bar :: "'a u \<rightarrow> 'a"
126.240 +where
126.241 + "bar\<cdot>(up\<cdot>x) = foo\<cdot>x"
126.242 +
126.243 +lemma bar_strict: "bar\<cdot>\<bottom> = \<bottom>"
126.244 +by fixrec_simp
126.245 +
126.246 +end
126.247 +
126.248 +end
127.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
127.2 +++ b/src/HOL/HOLCF/Tutorial/New_Domain.thy Sat Nov 27 16:08:10 2010 -0800
127.3 @@ -0,0 +1,90 @@
127.4 +(* Title: HOLCF/ex/New_Domain.thy
127.5 + Author: Brian Huffman
127.6 +*)
127.7 +
127.8 +header {* Definitional domain package *}
127.9 +
127.10 +theory New_Domain
127.11 +imports HOLCF
127.12 +begin
127.13 +
127.14 +text {*
127.15 + UPDATE: The definitional back-end is now the default mode of the domain
127.16 + package. This file should be merged with @{text Domain_ex.thy}.
127.17 +*}
127.18 +
127.19 +text {*
127.20 + Provided that @{text domain} is the default sort, the @{text new_domain}
127.21 + package should work with any type definition supported by the old
127.22 + domain package.
127.23 +*}
127.24 +
127.25 +domain 'a llist = LNil | LCons (lazy 'a) (lazy "'a llist")
127.26 +
127.27 +text {*
127.28 + The difference is that the new domain package is completely
127.29 + definitional, and does not generate any axioms. The following type
127.30 + and constant definitions are not produced by the old domain package.
127.31 +*}
127.32 +
127.33 +thm type_definition_llist
127.34 +thm llist_abs_def llist_rep_def
127.35 +
127.36 +text {*
127.37 + The new domain package also adds support for indirect recursion with
127.38 + user-defined datatypes. This definition of a tree datatype uses
127.39 + indirect recursion through the lazy list type constructor.
127.40 +*}
127.41 +
127.42 +domain 'a ltree = Leaf (lazy 'a) | Branch (lazy "'a ltree llist")
127.43 +
127.44 +text {*
127.45 + For indirect-recursive definitions, the domain package is not able to
127.46 + generate a high-level induction rule. (It produces a warning
127.47 + message instead.) The low-level reach lemma (now proved as a
127.48 + theorem, no longer generated as an axiom) can be used to derive
127.49 + other induction rules.
127.50 +*}
127.51 +
127.52 +thm ltree.reach
127.53 +
127.54 +text {*
127.55 + The definition of the take function uses map functions associated with
127.56 + each type constructor involved in the definition. A map function
127.57 + for the lazy list type has been generated by the new domain package.
127.58 +*}
127.59 +
127.60 +thm ltree.take_rews
127.61 +thm llist_map_def
127.62 +
127.63 +lemma ltree_induct:
127.64 + fixes P :: "'a ltree \<Rightarrow> bool"
127.65 + assumes adm: "adm P"
127.66 + assumes bot: "P \<bottom>"
127.67 + assumes Leaf: "\<And>x. P (Leaf\<cdot>x)"
127.68 + assumes Branch: "\<And>f l. \<forall>x. P (f\<cdot>x) \<Longrightarrow> P (Branch\<cdot>(llist_map\<cdot>f\<cdot>l))"
127.69 + shows "P x"
127.70 +proof -
127.71 + have "P (\<Squnion>i. ltree_take i\<cdot>x)"
127.72 + using adm
127.73 + proof (rule admD)
127.74 + fix i
127.75 + show "P (ltree_take i\<cdot>x)"
127.76 + proof (induct i arbitrary: x)
127.77 + case (0 x)
127.78 + show "P (ltree_take 0\<cdot>x)" by (simp add: bot)
127.79 + next
127.80 + case (Suc n x)
127.81 + show "P (ltree_take (Suc n)\<cdot>x)"
127.82 + apply (cases x)
127.83 + apply (simp add: bot)
127.84 + apply (simp add: Leaf)
127.85 + apply (simp add: Branch Suc)
127.86 + done
127.87 + qed
127.88 + qed (simp add: ltree.chain_take)
127.89 + thus ?thesis
127.90 + by (simp add: ltree.reach)
127.91 +qed
127.92 +
127.93 +end
128.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
128.2 +++ b/src/HOL/HOLCF/Tutorial/ROOT.ML Sat Nov 27 16:08:10 2010 -0800
128.3 @@ -0,0 +1,1 @@
128.4 +use_thys ["Domain_ex", "Fixrec_ex", "New_Domain"];
129.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
129.2 +++ b/src/HOL/HOLCF/Tutorial/document/root.tex Sat Nov 27 16:08:10 2010 -0800
129.3 @@ -0,0 +1,29 @@
129.4 +
129.5 +% HOLCF/document/root.tex
129.6 +
129.7 +\documentclass[11pt,a4paper]{article}
129.8 +\usepackage{graphicx,isabelle,isabellesym,latexsym}
129.9 +\usepackage[only,bigsqcap]{stmaryrd}
129.10 +\usepackage[latin1]{inputenc}
129.11 +\usepackage{pdfsetup}
129.12 +
129.13 +\urlstyle{rm}
129.14 +%\isabellestyle{it}
129.15 +\pagestyle{myheadings}
129.16 +
129.17 +\begin{document}
129.18 +
129.19 +\title{Isabelle/HOLCF Tutorial}
129.20 +\maketitle
129.21 +
129.22 +\tableofcontents
129.23 +
129.24 +%\newpage
129.25 +
129.26 +%\renewcommand{\isamarkupheader}[1]%
129.27 +%{\section{\isabellecontext: #1}\markright{THEORY~``\isabellecontext''}}
129.28 +
129.29 +\parindent 0pt\parskip 0.5ex
129.30 +\input{session}
129.31 +
129.32 +\end{document}
130.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
130.2 +++ b/src/HOL/HOLCF/Universal.thy Sat Nov 27 16:08:10 2010 -0800
130.3 @@ -0,0 +1,1014 @@
130.4 +(* Title: HOLCF/Universal.thy
130.5 + Author: Brian Huffman
130.6 +*)
130.7 +
130.8 +header {* A universal bifinite domain *}
130.9 +
130.10 +theory Universal
130.11 +imports Completion Deflation Nat_Bijection
130.12 +begin
130.13 +
130.14 +subsection {* Basis for universal domain *}
130.15 +
130.16 +subsubsection {* Basis datatype *}
130.17 +
130.18 +types ubasis = nat
130.19 +
130.20 +definition
130.21 + node :: "nat \<Rightarrow> ubasis \<Rightarrow> ubasis set \<Rightarrow> ubasis"
130.22 +where
130.23 + "node i a S = Suc (prod_encode (i, prod_encode (a, set_encode S)))"
130.24 +
130.25 +lemma node_not_0 [simp]: "node i a S \<noteq> 0"
130.26 +unfolding node_def by simp
130.27 +
130.28 +lemma node_gt_0 [simp]: "0 < node i a S"
130.29 +unfolding node_def by simp
130.30 +
130.31 +lemma node_inject [simp]:
130.32 + "\<lbrakk>finite S; finite T\<rbrakk>
130.33 + \<Longrightarrow> node i a S = node j b T \<longleftrightarrow> i = j \<and> a = b \<and> S = T"
130.34 +unfolding node_def by (simp add: prod_encode_eq set_encode_eq)
130.35 +
130.36 +lemma node_gt0: "i < node i a S"
130.37 +unfolding node_def less_Suc_eq_le
130.38 +by (rule le_prod_encode_1)
130.39 +
130.40 +lemma node_gt1: "a < node i a S"
130.41 +unfolding node_def less_Suc_eq_le
130.42 +by (rule order_trans [OF le_prod_encode_1 le_prod_encode_2])
130.43 +
130.44 +lemma nat_less_power2: "n < 2^n"
130.45 +by (induct n) simp_all
130.46 +
130.47 +lemma node_gt2: "\<lbrakk>finite S; b \<in> S\<rbrakk> \<Longrightarrow> b < node i a S"
130.48 +unfolding node_def less_Suc_eq_le set_encode_def
130.49 +apply (rule order_trans [OF _ le_prod_encode_2])
130.50 +apply (rule order_trans [OF _ le_prod_encode_2])
130.51 +apply (rule order_trans [where y="setsum (op ^ 2) {b}"])
130.52 +apply (simp add: nat_less_power2 [THEN order_less_imp_le])
130.53 +apply (erule setsum_mono2, simp, simp)
130.54 +done
130.55 +
130.56 +lemma eq_prod_encode_pairI:
130.57 + "\<lbrakk>fst (prod_decode x) = a; snd (prod_decode x) = b\<rbrakk> \<Longrightarrow> x = prod_encode (a, b)"
130.58 +by (erule subst, erule subst, simp)
130.59 +
130.60 +lemma node_cases:
130.61 + assumes 1: "x = 0 \<Longrightarrow> P"
130.62 + assumes 2: "\<And>i a S. \<lbrakk>finite S; x = node i a S\<rbrakk> \<Longrightarrow> P"
130.63 + shows "P"
130.64 + apply (cases x)
130.65 + apply (erule 1)
130.66 + apply (rule 2)
130.67 + apply (rule finite_set_decode)
130.68 + apply (simp add: node_def)
130.69 + apply (rule eq_prod_encode_pairI [OF refl])
130.70 + apply (rule eq_prod_encode_pairI [OF refl refl])
130.71 +done
130.72 +
130.73 +lemma node_induct:
130.74 + assumes 1: "P 0"
130.75 + assumes 2: "\<And>i a S. \<lbrakk>P a; finite S; \<forall>b\<in>S. P b\<rbrakk> \<Longrightarrow> P (node i a S)"
130.76 + shows "P x"
130.77 + apply (induct x rule: nat_less_induct)
130.78 + apply (case_tac n rule: node_cases)
130.79 + apply (simp add: 1)
130.80 + apply (simp add: 2 node_gt1 node_gt2)
130.81 +done
130.82 +
130.83 +subsubsection {* Basis ordering *}
130.84 +
130.85 +inductive
130.86 + ubasis_le :: "nat \<Rightarrow> nat \<Rightarrow> bool"
130.87 +where
130.88 + ubasis_le_refl: "ubasis_le a a"
130.89 +| ubasis_le_trans:
130.90 + "\<lbrakk>ubasis_le a b; ubasis_le b c\<rbrakk> \<Longrightarrow> ubasis_le a c"
130.91 +| ubasis_le_lower:
130.92 + "finite S \<Longrightarrow> ubasis_le a (node i a S)"
130.93 +| ubasis_le_upper:
130.94 + "\<lbrakk>finite S; b \<in> S; ubasis_le a b\<rbrakk> \<Longrightarrow> ubasis_le (node i a S) b"
130.95 +
130.96 +lemma ubasis_le_minimal: "ubasis_le 0 x"
130.97 +apply (induct x rule: node_induct)
130.98 +apply (rule ubasis_le_refl)
130.99 +apply (erule ubasis_le_trans)
130.100 +apply (erule ubasis_le_lower)
130.101 +done
130.102 +
130.103 +interpretation udom: preorder ubasis_le
130.104 +apply default
130.105 +apply (rule ubasis_le_refl)
130.106 +apply (erule (1) ubasis_le_trans)
130.107 +done
130.108 +
130.109 +subsubsection {* Generic take function *}
130.110 +
130.111 +function
130.112 + ubasis_until :: "(ubasis \<Rightarrow> bool) \<Rightarrow> ubasis \<Rightarrow> ubasis"
130.113 +where
130.114 + "ubasis_until P 0 = 0"
130.115 +| "finite S \<Longrightarrow> ubasis_until P (node i a S) =
130.116 + (if P (node i a S) then node i a S else ubasis_until P a)"
130.117 + apply clarify
130.118 + apply (rule_tac x=b in node_cases)
130.119 + apply simp
130.120 + apply simp
130.121 + apply fast
130.122 + apply simp
130.123 + apply simp
130.124 + apply simp
130.125 +done
130.126 +
130.127 +termination ubasis_until
130.128 +apply (relation "measure snd")
130.129 +apply (rule wf_measure)
130.130 +apply (simp add: node_gt1)
130.131 +done
130.132 +
130.133 +lemma ubasis_until: "P 0 \<Longrightarrow> P (ubasis_until P x)"
130.134 +by (induct x rule: node_induct) simp_all
130.135 +
130.136 +lemma ubasis_until': "0 < ubasis_until P x \<Longrightarrow> P (ubasis_until P x)"
130.137 +by (induct x rule: node_induct) auto
130.138 +
130.139 +lemma ubasis_until_same: "P x \<Longrightarrow> ubasis_until P x = x"
130.140 +by (induct x rule: node_induct) simp_all
130.141 +
130.142 +lemma ubasis_until_idem:
130.143 + "P 0 \<Longrightarrow> ubasis_until P (ubasis_until P x) = ubasis_until P x"
130.144 +by (rule ubasis_until_same [OF ubasis_until])
130.145 +
130.146 +lemma ubasis_until_0:
130.147 + "\<forall>x. x \<noteq> 0 \<longrightarrow> \<not> P x \<Longrightarrow> ubasis_until P x = 0"
130.148 +by (induct x rule: node_induct) simp_all
130.149 +
130.150 +lemma ubasis_until_less: "ubasis_le (ubasis_until P x) x"
130.151 +apply (induct x rule: node_induct)
130.152 +apply (simp add: ubasis_le_refl)
130.153 +apply (simp add: ubasis_le_refl)
130.154 +apply (rule impI)
130.155 +apply (erule ubasis_le_trans)
130.156 +apply (erule ubasis_le_lower)
130.157 +done
130.158 +
130.159 +lemma ubasis_until_chain:
130.160 + assumes PQ: "\<And>x. P x \<Longrightarrow> Q x"
130.161 + shows "ubasis_le (ubasis_until P x) (ubasis_until Q x)"
130.162 +apply (induct x rule: node_induct)
130.163 +apply (simp add: ubasis_le_refl)
130.164 +apply (simp add: ubasis_le_refl)
130.165 +apply (simp add: PQ)
130.166 +apply clarify
130.167 +apply (rule ubasis_le_trans)
130.168 +apply (rule ubasis_until_less)
130.169 +apply (erule ubasis_le_lower)
130.170 +done
130.171 +
130.172 +lemma ubasis_until_mono:
130.173 + assumes "\<And>i a S b. \<lbrakk>finite S; P (node i a S); b \<in> S; ubasis_le a b\<rbrakk> \<Longrightarrow> P b"
130.174 + shows "ubasis_le a b \<Longrightarrow> ubasis_le (ubasis_until P a) (ubasis_until P b)"
130.175 +proof (induct set: ubasis_le)
130.176 + case (ubasis_le_refl a) show ?case by (rule ubasis_le.ubasis_le_refl)
130.177 +next
130.178 + case (ubasis_le_trans a b c) thus ?case by - (rule ubasis_le.ubasis_le_trans)
130.179 +next
130.180 + case (ubasis_le_lower S a i) thus ?case
130.181 + apply (clarsimp simp add: ubasis_le_refl)
130.182 + apply (rule ubasis_le_trans [OF ubasis_until_less])
130.183 + apply (erule ubasis_le.ubasis_le_lower)
130.184 + done
130.185 +next
130.186 + case (ubasis_le_upper S b a i) thus ?case
130.187 + apply clarsimp
130.188 + apply (subst ubasis_until_same)
130.189 + apply (erule (3) prems)
130.190 + apply (erule (2) ubasis_le.ubasis_le_upper)
130.191 + done
130.192 +qed
130.193 +
130.194 +lemma finite_range_ubasis_until:
130.195 + "finite {x. P x} \<Longrightarrow> finite (range (ubasis_until P))"
130.196 +apply (rule finite_subset [where B="insert 0 {x. P x}"])
130.197 +apply (clarsimp simp add: ubasis_until')
130.198 +apply simp
130.199 +done
130.200 +
130.201 +
130.202 +subsection {* Defining the universal domain by ideal completion *}
130.203 +
130.204 +typedef (open) udom = "{S. udom.ideal S}"
130.205 +by (fast intro: udom.ideal_principal)
130.206 +
130.207 +instantiation udom :: below
130.208 +begin
130.209 +
130.210 +definition
130.211 + "x \<sqsubseteq> y \<longleftrightarrow> Rep_udom x \<subseteq> Rep_udom y"
130.212 +
130.213 +instance ..
130.214 +end
130.215 +
130.216 +instance udom :: po
130.217 +using type_definition_udom below_udom_def
130.218 +by (rule udom.typedef_ideal_po)
130.219 +
130.220 +instance udom :: cpo
130.221 +using type_definition_udom below_udom_def
130.222 +by (rule udom.typedef_ideal_cpo)
130.223 +
130.224 +definition
130.225 + udom_principal :: "nat \<Rightarrow> udom" where
130.226 + "udom_principal t = Abs_udom {u. ubasis_le u t}"
130.227 +
130.228 +lemma ubasis_countable: "\<exists>f::ubasis \<Rightarrow> nat. inj f"
130.229 +by (rule exI, rule inj_on_id)
130.230 +
130.231 +interpretation udom:
130.232 + ideal_completion ubasis_le udom_principal Rep_udom
130.233 +using type_definition_udom below_udom_def
130.234 +using udom_principal_def ubasis_countable
130.235 +by (rule udom.typedef_ideal_completion)
130.236 +
130.237 +text {* Universal domain is pointed *}
130.238 +
130.239 +lemma udom_minimal: "udom_principal 0 \<sqsubseteq> x"
130.240 +apply (induct x rule: udom.principal_induct)
130.241 +apply (simp, simp add: ubasis_le_minimal)
130.242 +done
130.243 +
130.244 +instance udom :: pcpo
130.245 +by intro_classes (fast intro: udom_minimal)
130.246 +
130.247 +lemma inst_udom_pcpo: "\<bottom> = udom_principal 0"
130.248 +by (rule udom_minimal [THEN UU_I, symmetric])
130.249 +
130.250 +
130.251 +subsection {* Compact bases of domains *}
130.252 +
130.253 +typedef (open) 'a compact_basis = "{x::'a::pcpo. compact x}"
130.254 +by auto
130.255 +
130.256 +lemma compact_Rep_compact_basis: "compact (Rep_compact_basis a)"
130.257 +by (rule Rep_compact_basis [unfolded mem_Collect_eq])
130.258 +
130.259 +instantiation compact_basis :: (pcpo) below
130.260 +begin
130.261 +
130.262 +definition
130.263 + compact_le_def:
130.264 + "(op \<sqsubseteq>) \<equiv> (\<lambda>x y. Rep_compact_basis x \<sqsubseteq> Rep_compact_basis y)"
130.265 +
130.266 +instance ..
130.267 +end
130.268 +
130.269 +instance compact_basis :: (pcpo) po
130.270 +using type_definition_compact_basis compact_le_def
130.271 +by (rule typedef_po)
130.272 +
130.273 +definition
130.274 + approximants :: "'a \<Rightarrow> 'a compact_basis set" where
130.275 + "approximants = (\<lambda>x. {a. Rep_compact_basis a \<sqsubseteq> x})"
130.276 +
130.277 +definition
130.278 + compact_bot :: "'a::pcpo compact_basis" where
130.279 + "compact_bot = Abs_compact_basis \<bottom>"
130.280 +
130.281 +lemma Rep_compact_bot [simp]: "Rep_compact_basis compact_bot = \<bottom>"
130.282 +unfolding compact_bot_def by (simp add: Abs_compact_basis_inverse)
130.283 +
130.284 +lemma compact_bot_minimal [simp]: "compact_bot \<sqsubseteq> a"
130.285 +unfolding compact_le_def Rep_compact_bot by simp
130.286 +
130.287 +
130.288 +subsection {* Universality of \emph{udom} *}
130.289 +
130.290 +text {* We use a locale to parameterize the construction over a chain
130.291 +of approx functions on the type to be embedded. *}
130.292 +
130.293 +locale approx_chain =
130.294 + fixes approx :: "nat \<Rightarrow> 'a::pcpo \<rightarrow> 'a"
130.295 + assumes chain_approx [simp]: "chain (\<lambda>i. approx i)"
130.296 + assumes lub_approx [simp]: "(\<Squnion>i. approx i) = ID"
130.297 + assumes finite_deflation_approx: "\<And>i. finite_deflation (approx i)"
130.298 +begin
130.299 +
130.300 +subsubsection {* Choosing a maximal element from a finite set *}
130.301 +
130.302 +lemma finite_has_maximal:
130.303 + fixes A :: "'a compact_basis set"
130.304 + shows "\<lbrakk>finite A; A \<noteq> {}\<rbrakk> \<Longrightarrow> \<exists>x\<in>A. \<forall>y\<in>A. x \<sqsubseteq> y \<longrightarrow> x = y"
130.305 +proof (induct rule: finite_ne_induct)
130.306 + case (singleton x)
130.307 + show ?case by simp
130.308 +next
130.309 + case (insert a A)
130.310 + from `\<exists>x\<in>A. \<forall>y\<in>A. x \<sqsubseteq> y \<longrightarrow> x = y`
130.311 + obtain x where x: "x \<in> A"
130.312 + and x_eq: "\<And>y. \<lbrakk>y \<in> A; x \<sqsubseteq> y\<rbrakk> \<Longrightarrow> x = y" by fast
130.313 + show ?case
130.314 + proof (intro bexI ballI impI)
130.315 + fix y
130.316 + assume "y \<in> insert a A" and "(if x \<sqsubseteq> a then a else x) \<sqsubseteq> y"
130.317 + thus "(if x \<sqsubseteq> a then a else x) = y"
130.318 + apply auto
130.319 + apply (frule (1) below_trans)
130.320 + apply (frule (1) x_eq)
130.321 + apply (rule below_antisym, assumption)
130.322 + apply simp
130.323 + apply (erule (1) x_eq)
130.324 + done
130.325 + next
130.326 + show "(if x \<sqsubseteq> a then a else x) \<in> insert a A"
130.327 + by (simp add: x)
130.328 + qed
130.329 +qed
130.330 +
130.331 +definition
130.332 + choose :: "'a compact_basis set \<Rightarrow> 'a compact_basis"
130.333 +where
130.334 + "choose A = (SOME x. x \<in> {x\<in>A. \<forall>y\<in>A. x \<sqsubseteq> y \<longrightarrow> x = y})"
130.335 +
130.336 +lemma choose_lemma:
130.337 + "\<lbrakk>finite A; A \<noteq> {}\<rbrakk> \<Longrightarrow> choose A \<in> {x\<in>A. \<forall>y\<in>A. x \<sqsubseteq> y \<longrightarrow> x = y}"
130.338 +unfolding choose_def
130.339 +apply (rule someI_ex)
130.340 +apply (frule (1) finite_has_maximal, fast)
130.341 +done
130.342 +
130.343 +lemma maximal_choose:
130.344 + "\<lbrakk>finite A; y \<in> A; choose A \<sqsubseteq> y\<rbrakk> \<Longrightarrow> choose A = y"
130.345 +apply (cases "A = {}", simp)
130.346 +apply (frule (1) choose_lemma, simp)
130.347 +done
130.348 +
130.349 +lemma choose_in: "\<lbrakk>finite A; A \<noteq> {}\<rbrakk> \<Longrightarrow> choose A \<in> A"
130.350 +by (frule (1) choose_lemma, simp)
130.351 +
130.352 +function
130.353 + choose_pos :: "'a compact_basis set \<Rightarrow> 'a compact_basis \<Rightarrow> nat"
130.354 +where
130.355 + "choose_pos A x =
130.356 + (if finite A \<and> x \<in> A \<and> x \<noteq> choose A
130.357 + then Suc (choose_pos (A - {choose A}) x) else 0)"
130.358 +by auto
130.359 +
130.360 +termination choose_pos
130.361 +apply (relation "measure (card \<circ> fst)", simp)
130.362 +apply clarsimp
130.363 +apply (rule card_Diff1_less)
130.364 +apply assumption
130.365 +apply (erule choose_in)
130.366 +apply clarsimp
130.367 +done
130.368 +
130.369 +declare choose_pos.simps [simp del]
130.370 +
130.371 +lemma choose_pos_choose: "finite A \<Longrightarrow> choose_pos A (choose A) = 0"
130.372 +by (simp add: choose_pos.simps)
130.373 +
130.374 +lemma inj_on_choose_pos [OF refl]:
130.375 + "\<lbrakk>card A = n; finite A\<rbrakk> \<Longrightarrow> inj_on (choose_pos A) A"
130.376 + apply (induct n arbitrary: A)
130.377 + apply simp
130.378 + apply (case_tac "A = {}", simp)
130.379 + apply (frule (1) choose_in)
130.380 + apply (rule inj_onI)
130.381 + apply (drule_tac x="A - {choose A}" in meta_spec, simp)
130.382 + apply (simp add: choose_pos.simps)
130.383 + apply (simp split: split_if_asm)
130.384 + apply (erule (1) inj_onD, simp, simp)
130.385 +done
130.386 +
130.387 +lemma choose_pos_bounded [OF refl]:
130.388 + "\<lbrakk>card A = n; finite A; x \<in> A\<rbrakk> \<Longrightarrow> choose_pos A x < n"
130.389 +apply (induct n arbitrary: A)
130.390 +apply simp
130.391 + apply (case_tac "A = {}", simp)
130.392 + apply (frule (1) choose_in)
130.393 +apply (subst choose_pos.simps)
130.394 +apply simp
130.395 +done
130.396 +
130.397 +lemma choose_pos_lessD:
130.398 + "\<lbrakk>choose_pos A x < choose_pos A y; finite A; x \<in> A; y \<in> A\<rbrakk> \<Longrightarrow> \<not> x \<sqsubseteq> y"
130.399 + apply (induct A x arbitrary: y rule: choose_pos.induct)
130.400 + apply simp
130.401 + apply (case_tac "x = choose A")
130.402 + apply simp
130.403 + apply (rule notI)
130.404 + apply (frule (2) maximal_choose)
130.405 + apply simp
130.406 + apply (case_tac "y = choose A")
130.407 + apply (simp add: choose_pos_choose)
130.408 + apply (drule_tac x=y in meta_spec)
130.409 + apply simp
130.410 + apply (erule meta_mp)
130.411 + apply (simp add: choose_pos.simps)
130.412 +done
130.413 +
130.414 +subsubsection {* Properties of approx function *}
130.415 +
130.416 +lemma deflation_approx: "deflation (approx i)"
130.417 +using finite_deflation_approx by (rule finite_deflation_imp_deflation)
130.418 +
130.419 +lemma approx_idem: "approx i\<cdot>(approx i\<cdot>x) = approx i\<cdot>x"
130.420 +using deflation_approx by (rule deflation.idem)
130.421 +
130.422 +lemma approx_below: "approx i\<cdot>x \<sqsubseteq> x"
130.423 +using deflation_approx by (rule deflation.below)
130.424 +
130.425 +lemma finite_range_approx: "finite (range (\<lambda>x. approx i\<cdot>x))"
130.426 +apply (rule finite_deflation.finite_range)
130.427 +apply (rule finite_deflation_approx)
130.428 +done
130.429 +
130.430 +lemma compact_approx: "compact (approx n\<cdot>x)"
130.431 +apply (rule finite_deflation.compact)
130.432 +apply (rule finite_deflation_approx)
130.433 +done
130.434 +
130.435 +lemma compact_eq_approx: "compact x \<Longrightarrow> \<exists>i. approx i\<cdot>x = x"
130.436 +by (rule admD2, simp_all)
130.437 +
130.438 +subsubsection {* Compact basis take function *}
130.439 +
130.440 +primrec
130.441 + cb_take :: "nat \<Rightarrow> 'a compact_basis \<Rightarrow> 'a compact_basis" where
130.442 + "cb_take 0 = (\<lambda>x. compact_bot)"
130.443 +| "cb_take (Suc n) = (\<lambda>a. Abs_compact_basis (approx n\<cdot>(Rep_compact_basis a)))"
130.444 +
130.445 +declare cb_take.simps [simp del]
130.446 +
130.447 +lemma cb_take_zero [simp]: "cb_take 0 a = compact_bot"
130.448 +by (simp only: cb_take.simps)
130.449 +
130.450 +lemma Rep_cb_take:
130.451 + "Rep_compact_basis (cb_take (Suc n) a) = approx n\<cdot>(Rep_compact_basis a)"
130.452 +by (simp add: Abs_compact_basis_inverse cb_take.simps(2) compact_approx)
130.453 +
130.454 +lemmas approx_Rep_compact_basis = Rep_cb_take [symmetric]
130.455 +
130.456 +lemma cb_take_covers: "\<exists>n. cb_take n x = x"
130.457 +apply (subgoal_tac "\<exists>n. cb_take (Suc n) x = x", fast)
130.458 +apply (simp add: Rep_compact_basis_inject [symmetric])
130.459 +apply (simp add: Rep_cb_take)
130.460 +apply (rule compact_eq_approx)
130.461 +apply (rule compact_Rep_compact_basis)
130.462 +done
130.463 +
130.464 +lemma cb_take_less: "cb_take n x \<sqsubseteq> x"
130.465 +unfolding compact_le_def
130.466 +by (cases n, simp, simp add: Rep_cb_take approx_below)
130.467 +
130.468 +lemma cb_take_idem: "cb_take n (cb_take n x) = cb_take n x"
130.469 +unfolding Rep_compact_basis_inject [symmetric]
130.470 +by (cases n, simp, simp add: Rep_cb_take approx_idem)
130.471 +
130.472 +lemma cb_take_mono: "x \<sqsubseteq> y \<Longrightarrow> cb_take n x \<sqsubseteq> cb_take n y"
130.473 +unfolding compact_le_def
130.474 +by (cases n, simp, simp add: Rep_cb_take monofun_cfun_arg)
130.475 +
130.476 +lemma cb_take_chain_le: "m \<le> n \<Longrightarrow> cb_take m x \<sqsubseteq> cb_take n x"
130.477 +unfolding compact_le_def
130.478 +apply (cases m, simp, cases n, simp)
130.479 +apply (simp add: Rep_cb_take, rule chain_mono, simp, simp)
130.480 +done
130.481 +
130.482 +lemma finite_range_cb_take: "finite (range (cb_take n))"
130.483 +apply (cases n)
130.484 +apply (subgoal_tac "range (cb_take 0) = {compact_bot}", simp, force)
130.485 +apply (rule finite_imageD [where f="Rep_compact_basis"])
130.486 +apply (rule finite_subset [where B="range (\<lambda>x. approx (n - 1)\<cdot>x)"])
130.487 +apply (clarsimp simp add: Rep_cb_take)
130.488 +apply (rule finite_range_approx)
130.489 +apply (rule inj_onI, simp add: Rep_compact_basis_inject)
130.490 +done
130.491 +
130.492 +subsubsection {* Rank of basis elements *}
130.493 +
130.494 +definition
130.495 + rank :: "'a compact_basis \<Rightarrow> nat"
130.496 +where
130.497 + "rank x = (LEAST n. cb_take n x = x)"
130.498 +
130.499 +lemma compact_approx_rank: "cb_take (rank x) x = x"
130.500 +unfolding rank_def
130.501 +apply (rule LeastI_ex)
130.502 +apply (rule cb_take_covers)
130.503 +done
130.504 +
130.505 +lemma rank_leD: "rank x \<le> n \<Longrightarrow> cb_take n x = x"
130.506 +apply (rule below_antisym [OF cb_take_less])
130.507 +apply (subst compact_approx_rank [symmetric])
130.508 +apply (erule cb_take_chain_le)
130.509 +done
130.510 +
130.511 +lemma rank_leI: "cb_take n x = x \<Longrightarrow> rank x \<le> n"
130.512 +unfolding rank_def by (rule Least_le)
130.513 +
130.514 +lemma rank_le_iff: "rank x \<le> n \<longleftrightarrow> cb_take n x = x"
130.515 +by (rule iffI [OF rank_leD rank_leI])
130.516 +
130.517 +lemma rank_compact_bot [simp]: "rank compact_bot = 0"
130.518 +using rank_leI [of 0 compact_bot] by simp
130.519 +
130.520 +lemma rank_eq_0_iff [simp]: "rank x = 0 \<longleftrightarrow> x = compact_bot"
130.521 +using rank_le_iff [of x 0] by auto
130.522 +
130.523 +definition
130.524 + rank_le :: "'a compact_basis \<Rightarrow> 'a compact_basis set"
130.525 +where
130.526 + "rank_le x = {y. rank y \<le> rank x}"
130.527 +
130.528 +definition
130.529 + rank_lt :: "'a compact_basis \<Rightarrow> 'a compact_basis set"
130.530 +where
130.531 + "rank_lt x = {y. rank y < rank x}"
130.532 +
130.533 +definition
130.534 + rank_eq :: "'a compact_basis \<Rightarrow> 'a compact_basis set"
130.535 +where
130.536 + "rank_eq x = {y. rank y = rank x}"
130.537 +
130.538 +lemma rank_eq_cong: "rank x = rank y \<Longrightarrow> rank_eq x = rank_eq y"
130.539 +unfolding rank_eq_def by simp
130.540 +
130.541 +lemma rank_lt_cong: "rank x = rank y \<Longrightarrow> rank_lt x = rank_lt y"
130.542 +unfolding rank_lt_def by simp
130.543 +
130.544 +lemma rank_eq_subset: "rank_eq x \<subseteq> rank_le x"
130.545 +unfolding rank_eq_def rank_le_def by auto
130.546 +
130.547 +lemma rank_lt_subset: "rank_lt x \<subseteq> rank_le x"
130.548 +unfolding rank_lt_def rank_le_def by auto
130.549 +
130.550 +lemma finite_rank_le: "finite (rank_le x)"
130.551 +unfolding rank_le_def
130.552 +apply (rule finite_subset [where B="range (cb_take (rank x))"])
130.553 +apply clarify
130.554 +apply (rule range_eqI)
130.555 +apply (erule rank_leD [symmetric])
130.556 +apply (rule finite_range_cb_take)
130.557 +done
130.558 +
130.559 +lemma finite_rank_eq: "finite (rank_eq x)"
130.560 +by (rule finite_subset [OF rank_eq_subset finite_rank_le])
130.561 +
130.562 +lemma finite_rank_lt: "finite (rank_lt x)"
130.563 +by (rule finite_subset [OF rank_lt_subset finite_rank_le])
130.564 +
130.565 +lemma rank_lt_Int_rank_eq: "rank_lt x \<inter> rank_eq x = {}"
130.566 +unfolding rank_lt_def rank_eq_def rank_le_def by auto
130.567 +
130.568 +lemma rank_lt_Un_rank_eq: "rank_lt x \<union> rank_eq x = rank_le x"
130.569 +unfolding rank_lt_def rank_eq_def rank_le_def by auto
130.570 +
130.571 +subsubsection {* Sequencing basis elements *}
130.572 +
130.573 +definition
130.574 + place :: "'a compact_basis \<Rightarrow> nat"
130.575 +where
130.576 + "place x = card (rank_lt x) + choose_pos (rank_eq x) x"
130.577 +
130.578 +lemma place_bounded: "place x < card (rank_le x)"
130.579 +unfolding place_def
130.580 + apply (rule ord_less_eq_trans)
130.581 + apply (rule add_strict_left_mono)
130.582 + apply (rule choose_pos_bounded)
130.583 + apply (rule finite_rank_eq)
130.584 + apply (simp add: rank_eq_def)
130.585 + apply (subst card_Un_disjoint [symmetric])
130.586 + apply (rule finite_rank_lt)
130.587 + apply (rule finite_rank_eq)
130.588 + apply (rule rank_lt_Int_rank_eq)
130.589 + apply (simp add: rank_lt_Un_rank_eq)
130.590 +done
130.591 +
130.592 +lemma place_ge: "card (rank_lt x) \<le> place x"
130.593 +unfolding place_def by simp
130.594 +
130.595 +lemma place_rank_mono:
130.596 + fixes x y :: "'a compact_basis"
130.597 + shows "rank x < rank y \<Longrightarrow> place x < place y"
130.598 +apply (rule less_le_trans [OF place_bounded])
130.599 +apply (rule order_trans [OF _ place_ge])
130.600 +apply (rule card_mono)
130.601 +apply (rule finite_rank_lt)
130.602 +apply (simp add: rank_le_def rank_lt_def subset_eq)
130.603 +done
130.604 +
130.605 +lemma place_eqD: "place x = place y \<Longrightarrow> x = y"
130.606 + apply (rule linorder_cases [where x="rank x" and y="rank y"])
130.607 + apply (drule place_rank_mono, simp)
130.608 + apply (simp add: place_def)
130.609 + apply (rule inj_on_choose_pos [where A="rank_eq x", THEN inj_onD])
130.610 + apply (rule finite_rank_eq)
130.611 + apply (simp cong: rank_lt_cong rank_eq_cong)
130.612 + apply (simp add: rank_eq_def)
130.613 + apply (simp add: rank_eq_def)
130.614 + apply (drule place_rank_mono, simp)
130.615 +done
130.616 +
130.617 +lemma inj_place: "inj place"
130.618 +by (rule inj_onI, erule place_eqD)
130.619 +
130.620 +subsubsection {* Embedding and projection on basis elements *}
130.621 +
130.622 +definition
130.623 + sub :: "'a compact_basis \<Rightarrow> 'a compact_basis"
130.624 +where
130.625 + "sub x = (case rank x of 0 \<Rightarrow> compact_bot | Suc k \<Rightarrow> cb_take k x)"
130.626 +
130.627 +lemma rank_sub_less: "x \<noteq> compact_bot \<Longrightarrow> rank (sub x) < rank x"
130.628 +unfolding sub_def
130.629 +apply (cases "rank x", simp)
130.630 +apply (simp add: less_Suc_eq_le)
130.631 +apply (rule rank_leI)
130.632 +apply (rule cb_take_idem)
130.633 +done
130.634 +
130.635 +lemma place_sub_less: "x \<noteq> compact_bot \<Longrightarrow> place (sub x) < place x"
130.636 +apply (rule place_rank_mono)
130.637 +apply (erule rank_sub_less)
130.638 +done
130.639 +
130.640 +lemma sub_below: "sub x \<sqsubseteq> x"
130.641 +unfolding sub_def by (cases "rank x", simp_all add: cb_take_less)
130.642 +
130.643 +lemma rank_less_imp_below_sub: "\<lbrakk>x \<sqsubseteq> y; rank x < rank y\<rbrakk> \<Longrightarrow> x \<sqsubseteq> sub y"
130.644 +unfolding sub_def
130.645 +apply (cases "rank y", simp)
130.646 +apply (simp add: less_Suc_eq_le)
130.647 +apply (subgoal_tac "cb_take nat x \<sqsubseteq> cb_take nat y")
130.648 +apply (simp add: rank_leD)
130.649 +apply (erule cb_take_mono)
130.650 +done
130.651 +
130.652 +function
130.653 + basis_emb :: "'a compact_basis \<Rightarrow> ubasis"
130.654 +where
130.655 + "basis_emb x = (if x = compact_bot then 0 else
130.656 + node (place x) (basis_emb (sub x))
130.657 + (basis_emb ` {y. place y < place x \<and> x \<sqsubseteq> y}))"
130.658 +by auto
130.659 +
130.660 +termination basis_emb
130.661 +apply (relation "measure place", simp)
130.662 +apply (simp add: place_sub_less)
130.663 +apply simp
130.664 +done
130.665 +
130.666 +declare basis_emb.simps [simp del]
130.667 +
130.668 +lemma basis_emb_compact_bot [simp]: "basis_emb compact_bot = 0"
130.669 +by (simp add: basis_emb.simps)
130.670 +
130.671 +lemma fin1: "finite {y. place y < place x \<and> x \<sqsubseteq> y}"
130.672 +apply (subst Collect_conj_eq)
130.673 +apply (rule finite_Int)
130.674 +apply (rule disjI1)
130.675 +apply (subgoal_tac "finite (place -` {n. n < place x})", simp)
130.676 +apply (rule finite_vimageI [OF _ inj_place])
130.677 +apply (simp add: lessThan_def [symmetric])
130.678 +done
130.679 +
130.680 +lemma fin2: "finite (basis_emb ` {y. place y < place x \<and> x \<sqsubseteq> y})"
130.681 +by (rule finite_imageI [OF fin1])
130.682 +
130.683 +lemma rank_place_mono:
130.684 + "\<lbrakk>place x < place y; x \<sqsubseteq> y\<rbrakk> \<Longrightarrow> rank x < rank y"
130.685 +apply (rule linorder_cases, assumption)
130.686 +apply (simp add: place_def cong: rank_lt_cong rank_eq_cong)
130.687 +apply (drule choose_pos_lessD)
130.688 +apply (rule finite_rank_eq)
130.689 +apply (simp add: rank_eq_def)
130.690 +apply (simp add: rank_eq_def)
130.691 +apply simp
130.692 +apply (drule place_rank_mono, simp)
130.693 +done
130.694 +
130.695 +lemma basis_emb_mono:
130.696 + "x \<sqsubseteq> y \<Longrightarrow> ubasis_le (basis_emb x) (basis_emb y)"
130.697 +proof (induct "max (place x) (place y)" arbitrary: x y rule: less_induct)
130.698 + case less
130.699 + show ?case proof (rule linorder_cases)
130.700 + assume "place x < place y"
130.701 + then have "rank x < rank y"
130.702 + using `x \<sqsubseteq> y` by (rule rank_place_mono)
130.703 + with `place x < place y` show ?case
130.704 + apply (case_tac "y = compact_bot", simp)
130.705 + apply (simp add: basis_emb.simps [of y])
130.706 + apply (rule ubasis_le_trans [OF _ ubasis_le_lower [OF fin2]])
130.707 + apply (rule less)
130.708 + apply (simp add: less_max_iff_disj)
130.709 + apply (erule place_sub_less)
130.710 + apply (erule rank_less_imp_below_sub [OF `x \<sqsubseteq> y`])
130.711 + done
130.712 + next
130.713 + assume "place x = place y"
130.714 + hence "x = y" by (rule place_eqD)
130.715 + thus ?case by (simp add: ubasis_le_refl)
130.716 + next
130.717 + assume "place x > place y"
130.718 + with `x \<sqsubseteq> y` show ?case
130.719 + apply (case_tac "x = compact_bot", simp add: ubasis_le_minimal)
130.720 + apply (simp add: basis_emb.simps [of x])
130.721 + apply (rule ubasis_le_upper [OF fin2], simp)
130.722 + apply (rule less)
130.723 + apply (simp add: less_max_iff_disj)
130.724 + apply (erule place_sub_less)
130.725 + apply (erule rev_below_trans)
130.726 + apply (rule sub_below)
130.727 + done
130.728 + qed
130.729 +qed
130.730 +
130.731 +lemma inj_basis_emb: "inj basis_emb"
130.732 + apply (rule inj_onI)
130.733 + apply (case_tac "x = compact_bot")
130.734 + apply (case_tac [!] "y = compact_bot")
130.735 + apply simp
130.736 + apply (simp add: basis_emb.simps)
130.737 + apply (simp add: basis_emb.simps)
130.738 + apply (simp add: basis_emb.simps)
130.739 + apply (simp add: fin2 inj_eq [OF inj_place])
130.740 +done
130.741 +
130.742 +definition
130.743 + basis_prj :: "ubasis \<Rightarrow> 'a compact_basis"
130.744 +where
130.745 + "basis_prj x = inv basis_emb
130.746 + (ubasis_until (\<lambda>x. x \<in> range (basis_emb :: 'a compact_basis \<Rightarrow> ubasis)) x)"
130.747 +
130.748 +lemma basis_prj_basis_emb: "\<And>x. basis_prj (basis_emb x) = x"
130.749 +unfolding basis_prj_def
130.750 + apply (subst ubasis_until_same)
130.751 + apply (rule rangeI)
130.752 + apply (rule inv_f_f)
130.753 + apply (rule inj_basis_emb)
130.754 +done
130.755 +
130.756 +lemma basis_prj_node:
130.757 + "\<lbrakk>finite S; node i a S \<notin> range (basis_emb :: 'a compact_basis \<Rightarrow> nat)\<rbrakk>
130.758 + \<Longrightarrow> basis_prj (node i a S) = (basis_prj a :: 'a compact_basis)"
130.759 +unfolding basis_prj_def by simp
130.760 +
130.761 +lemma basis_prj_0: "basis_prj 0 = compact_bot"
130.762 +apply (subst basis_emb_compact_bot [symmetric])
130.763 +apply (rule basis_prj_basis_emb)
130.764 +done
130.765 +
130.766 +lemma node_eq_basis_emb_iff:
130.767 + "finite S \<Longrightarrow> node i a S = basis_emb x \<longleftrightarrow>
130.768 + x \<noteq> compact_bot \<and> i = place x \<and> a = basis_emb (sub x) \<and>
130.769 + S = basis_emb ` {y. place y < place x \<and> x \<sqsubseteq> y}"
130.770 +apply (cases "x = compact_bot", simp)
130.771 +apply (simp add: basis_emb.simps [of x])
130.772 +apply (simp add: fin2)
130.773 +done
130.774 +
130.775 +lemma basis_prj_mono: "ubasis_le a b \<Longrightarrow> basis_prj a \<sqsubseteq> basis_prj b"
130.776 +proof (induct a b rule: ubasis_le.induct)
130.777 + case (ubasis_le_refl a) show ?case by (rule below_refl)
130.778 +next
130.779 + case (ubasis_le_trans a b c) thus ?case by - (rule below_trans)
130.780 +next
130.781 + case (ubasis_le_lower S a i) thus ?case
130.782 + apply (cases "node i a S \<in> range (basis_emb :: 'a compact_basis \<Rightarrow> nat)")
130.783 + apply (erule rangeE, rename_tac x)
130.784 + apply (simp add: basis_prj_basis_emb)
130.785 + apply (simp add: node_eq_basis_emb_iff)
130.786 + apply (simp add: basis_prj_basis_emb)
130.787 + apply (rule sub_below)
130.788 + apply (simp add: basis_prj_node)
130.789 + done
130.790 +next
130.791 + case (ubasis_le_upper S b a i) thus ?case
130.792 + apply (cases "node i a S \<in> range (basis_emb :: 'a compact_basis \<Rightarrow> nat)")
130.793 + apply (erule rangeE, rename_tac x)
130.794 + apply (simp add: basis_prj_basis_emb)
130.795 + apply (clarsimp simp add: node_eq_basis_emb_iff)
130.796 + apply (simp add: basis_prj_basis_emb)
130.797 + apply (simp add: basis_prj_node)
130.798 + done
130.799 +qed
130.800 +
130.801 +lemma basis_emb_prj_less: "ubasis_le (basis_emb (basis_prj x)) x"
130.802 +unfolding basis_prj_def
130.803 + apply (subst f_inv_into_f [where f=basis_emb])
130.804 + apply (rule ubasis_until)
130.805 + apply (rule range_eqI [where x=compact_bot])
130.806 + apply simp
130.807 + apply (rule ubasis_until_less)
130.808 +done
130.809 +
130.810 +end
130.811 +
130.812 +sublocale approx_chain \<subseteq> compact_basis!:
130.813 + ideal_completion below Rep_compact_basis
130.814 + "approximants :: 'a \<Rightarrow> 'a compact_basis set"
130.815 +proof
130.816 + fix w :: "'a"
130.817 + show "below.ideal (approximants w)"
130.818 + proof (rule below.idealI)
130.819 + show "\<exists>x. x \<in> approximants w"
130.820 + unfolding approximants_def
130.821 + apply (rule_tac x="Abs_compact_basis (approx 0\<cdot>w)" in exI)
130.822 + apply (simp add: Abs_compact_basis_inverse approx_below compact_approx)
130.823 + done
130.824 + next
130.825 + fix x y :: "'a compact_basis"
130.826 + assume "x \<in> approximants w" "y \<in> approximants w"
130.827 + thus "\<exists>z \<in> approximants w. x \<sqsubseteq> z \<and> y \<sqsubseteq> z"
130.828 + unfolding approximants_def
130.829 + apply simp
130.830 + apply (cut_tac a=x in compact_Rep_compact_basis)
130.831 + apply (cut_tac a=y in compact_Rep_compact_basis)
130.832 + apply (drule compact_eq_approx)
130.833 + apply (drule compact_eq_approx)
130.834 + apply (clarify, rename_tac i j)
130.835 + apply (rule_tac x="Abs_compact_basis (approx (max i j)\<cdot>w)" in exI)
130.836 + apply (simp add: compact_le_def)
130.837 + apply (simp add: Abs_compact_basis_inverse approx_below compact_approx)
130.838 + apply (erule subst, erule subst)
130.839 + apply (simp add: monofun_cfun chain_mono [OF chain_approx])
130.840 + done
130.841 + next
130.842 + fix x y :: "'a compact_basis"
130.843 + assume "x \<sqsubseteq> y" "y \<in> approximants w" thus "x \<in> approximants w"
130.844 + unfolding approximants_def
130.845 + apply simp
130.846 + apply (simp add: compact_le_def)
130.847 + apply (erule (1) below_trans)
130.848 + done
130.849 + qed
130.850 +next
130.851 + fix Y :: "nat \<Rightarrow> 'a"
130.852 + assume Y: "chain Y"
130.853 + show "approximants (\<Squnion>i. Y i) = (\<Union>i. approximants (Y i))"
130.854 + unfolding approximants_def
130.855 + apply safe
130.856 + apply (simp add: compactD2 [OF compact_Rep_compact_basis Y])
130.857 + apply (erule below_lub [OF Y])
130.858 + done
130.859 +next
130.860 + fix a :: "'a compact_basis"
130.861 + show "approximants (Rep_compact_basis a) = {b. b \<sqsubseteq> a}"
130.862 + unfolding approximants_def compact_le_def ..
130.863 +next
130.864 + fix x y :: "'a"
130.865 + assume "approximants x \<subseteq> approximants y" thus "x \<sqsubseteq> y"
130.866 + apply (subgoal_tac "(\<Squnion>i. approx i\<cdot>x) \<sqsubseteq> y")
130.867 + apply (simp add: lub_distribs)
130.868 + apply (rule admD, simp, simp)
130.869 + apply (drule_tac c="Abs_compact_basis (approx i\<cdot>x)" in subsetD)
130.870 + apply (simp add: approximants_def Abs_compact_basis_inverse
130.871 + approx_below compact_approx)
130.872 + apply (simp add: approximants_def Abs_compact_basis_inverse compact_approx)
130.873 + done
130.874 +next
130.875 + show "\<exists>f::'a compact_basis \<Rightarrow> nat. inj f"
130.876 + by (rule exI, rule inj_place)
130.877 +qed
130.878 +
130.879 +subsubsection {* EP-pair from any bifinite domain into \emph{udom} *}
130.880 +
130.881 +context approx_chain begin
130.882 +
130.883 +definition
130.884 + udom_emb :: "'a \<rightarrow> udom"
130.885 +where
130.886 + "udom_emb = compact_basis.basis_fun (\<lambda>x. udom_principal (basis_emb x))"
130.887 +
130.888 +definition
130.889 + udom_prj :: "udom \<rightarrow> 'a"
130.890 +where
130.891 + "udom_prj = udom.basis_fun (\<lambda>x. Rep_compact_basis (basis_prj x))"
130.892 +
130.893 +lemma udom_emb_principal:
130.894 + "udom_emb\<cdot>(Rep_compact_basis x) = udom_principal (basis_emb x)"
130.895 +unfolding udom_emb_def
130.896 +apply (rule compact_basis.basis_fun_principal)
130.897 +apply (rule udom.principal_mono)
130.898 +apply (erule basis_emb_mono)
130.899 +done
130.900 +
130.901 +lemma udom_prj_principal:
130.902 + "udom_prj\<cdot>(udom_principal x) = Rep_compact_basis (basis_prj x)"
130.903 +unfolding udom_prj_def
130.904 +apply (rule udom.basis_fun_principal)
130.905 +apply (rule compact_basis.principal_mono)
130.906 +apply (erule basis_prj_mono)
130.907 +done
130.908 +
130.909 +lemma ep_pair_udom: "ep_pair udom_emb udom_prj"
130.910 + apply default
130.911 + apply (rule compact_basis.principal_induct, simp)
130.912 + apply (simp add: udom_emb_principal udom_prj_principal)
130.913 + apply (simp add: basis_prj_basis_emb)
130.914 + apply (rule udom.principal_induct, simp)
130.915 + apply (simp add: udom_emb_principal udom_prj_principal)
130.916 + apply (rule basis_emb_prj_less)
130.917 +done
130.918 +
130.919 +end
130.920 +
130.921 +abbreviation "udom_emb \<equiv> approx_chain.udom_emb"
130.922 +abbreviation "udom_prj \<equiv> approx_chain.udom_prj"
130.923 +
130.924 +lemmas ep_pair_udom = approx_chain.ep_pair_udom
130.925 +
130.926 +subsection {* Chain of approx functions for type \emph{udom} *}
130.927 +
130.928 +definition
130.929 + udom_approx :: "nat \<Rightarrow> udom \<rightarrow> udom"
130.930 +where
130.931 + "udom_approx i =
130.932 + udom.basis_fun (\<lambda>x. udom_principal (ubasis_until (\<lambda>y. y \<le> i) x))"
130.933 +
130.934 +lemma udom_approx_mono:
130.935 + "ubasis_le a b \<Longrightarrow>
130.936 + udom_principal (ubasis_until (\<lambda>y. y \<le> i) a) \<sqsubseteq>
130.937 + udom_principal (ubasis_until (\<lambda>y. y \<le> i) b)"
130.938 +apply (rule udom.principal_mono)
130.939 +apply (rule ubasis_until_mono)
130.940 +apply (frule (2) order_less_le_trans [OF node_gt2])
130.941 +apply (erule order_less_imp_le)
130.942 +apply assumption
130.943 +done
130.944 +
130.945 +lemma adm_mem_finite: "\<lbrakk>cont f; finite S\<rbrakk> \<Longrightarrow> adm (\<lambda>x. f x \<in> S)"
130.946 +by (erule adm_subst, induct set: finite, simp_all)
130.947 +
130.948 +lemma udom_approx_principal:
130.949 + "udom_approx i\<cdot>(udom_principal x) =
130.950 + udom_principal (ubasis_until (\<lambda>y. y \<le> i) x)"
130.951 +unfolding udom_approx_def
130.952 +apply (rule udom.basis_fun_principal)
130.953 +apply (erule udom_approx_mono)
130.954 +done
130.955 +
130.956 +lemma finite_deflation_udom_approx: "finite_deflation (udom_approx i)"
130.957 +proof
130.958 + fix x show "udom_approx i\<cdot>(udom_approx i\<cdot>x) = udom_approx i\<cdot>x"
130.959 + by (induct x rule: udom.principal_induct, simp)
130.960 + (simp add: udom_approx_principal ubasis_until_idem)
130.961 +next
130.962 + fix x show "udom_approx i\<cdot>x \<sqsubseteq> x"
130.963 + by (induct x rule: udom.principal_induct, simp)
130.964 + (simp add: udom_approx_principal ubasis_until_less)
130.965 +next
130.966 + have *: "finite (range (\<lambda>x. udom_principal (ubasis_until (\<lambda>y. y \<le> i) x)))"
130.967 + apply (subst range_composition [where f=udom_principal])
130.968 + apply (simp add: finite_range_ubasis_until)
130.969 + done
130.970 + show "finite {x. udom_approx i\<cdot>x = x}"
130.971 + apply (rule finite_range_imp_finite_fixes)
130.972 + apply (rule rev_finite_subset [OF *])
130.973 + apply (clarsimp, rename_tac x)
130.974 + apply (induct_tac x rule: udom.principal_induct)
130.975 + apply (simp add: adm_mem_finite *)
130.976 + apply (simp add: udom_approx_principal)
130.977 + done
130.978 +qed
130.979 +
130.980 +interpretation udom_approx: finite_deflation "udom_approx i"
130.981 +by (rule finite_deflation_udom_approx)
130.982 +
130.983 +lemma chain_udom_approx [simp]: "chain (\<lambda>i. udom_approx i)"
130.984 +unfolding udom_approx_def
130.985 +apply (rule chainI)
130.986 +apply (rule udom.basis_fun_mono)
130.987 +apply (erule udom_approx_mono)
130.988 +apply (erule udom_approx_mono)
130.989 +apply (rule udom.principal_mono)
130.990 +apply (rule ubasis_until_chain, simp)
130.991 +done
130.992 +
130.993 +lemma lub_udom_approx [simp]: "(\<Squnion>i. udom_approx i) = ID"
130.994 +apply (rule cfun_eqI, simp add: contlub_cfun_fun)
130.995 +apply (rule below_antisym)
130.996 +apply (rule lub_below)
130.997 +apply (simp)
130.998 +apply (rule udom_approx.below)
130.999 +apply (rule_tac x=x in udom.principal_induct)
130.1000 +apply (simp add: lub_distribs)
130.1001 +apply (rule_tac i=a in below_lub)
130.1002 +apply simp
130.1003 +apply (simp add: udom_approx_principal)
130.1004 +apply (simp add: ubasis_until_same ubasis_le_refl)
130.1005 +done
130.1006 +
130.1007 +lemma udom_approx: "approx_chain udom_approx"
130.1008 +proof
130.1009 + show "chain (\<lambda>i. udom_approx i)"
130.1010 + by (rule chain_udom_approx)
130.1011 + show "(\<Squnion>i. udom_approx i) = ID"
130.1012 + by (rule lub_udom_approx)
130.1013 +qed
130.1014 +
130.1015 +hide_const (open) node
130.1016 +
130.1017 +end
131.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
131.2 +++ b/src/HOL/HOLCF/Up.thy Sat Nov 27 16:08:10 2010 -0800
131.3 @@ -0,0 +1,263 @@
131.4 +(* Title: HOLCF/Up.thy
131.5 + Author: Franz Regensburger
131.6 + Author: Brian Huffman
131.7 +*)
131.8 +
131.9 +header {* The type of lifted values *}
131.10 +
131.11 +theory Up
131.12 +imports Cfun
131.13 +begin
131.14 +
131.15 +default_sort cpo
131.16 +
131.17 +subsection {* Definition of new type for lifting *}
131.18 +
131.19 +datatype 'a u = Ibottom | Iup 'a
131.20 +
131.21 +type_notation (xsymbols)
131.22 + u ("(_\<^sub>\<bottom>)" [1000] 999)
131.23 +
131.24 +primrec Ifup :: "('a \<rightarrow> 'b::pcpo) \<Rightarrow> 'a u \<Rightarrow> 'b" where
131.25 + "Ifup f Ibottom = \<bottom>"
131.26 + | "Ifup f (Iup x) = f\<cdot>x"
131.27 +
131.28 +subsection {* Ordering on lifted cpo *}
131.29 +
131.30 +instantiation u :: (cpo) below
131.31 +begin
131.32 +
131.33 +definition
131.34 + below_up_def:
131.35 + "(op \<sqsubseteq>) \<equiv> (\<lambda>x y. case x of Ibottom \<Rightarrow> True | Iup a \<Rightarrow>
131.36 + (case y of Ibottom \<Rightarrow> False | Iup b \<Rightarrow> a \<sqsubseteq> b))"
131.37 +
131.38 +instance ..
131.39 +end
131.40 +
131.41 +lemma minimal_up [iff]: "Ibottom \<sqsubseteq> z"
131.42 +by (simp add: below_up_def)
131.43 +
131.44 +lemma not_Iup_below [iff]: "\<not> Iup x \<sqsubseteq> Ibottom"
131.45 +by (simp add: below_up_def)
131.46 +
131.47 +lemma Iup_below [iff]: "(Iup x \<sqsubseteq> Iup y) = (x \<sqsubseteq> y)"
131.48 +by (simp add: below_up_def)
131.49 +
131.50 +subsection {* Lifted cpo is a partial order *}
131.51 +
131.52 +instance u :: (cpo) po
131.53 +proof
131.54 + fix x :: "'a u"
131.55 + show "x \<sqsubseteq> x"
131.56 + unfolding below_up_def by (simp split: u.split)
131.57 +next
131.58 + fix x y :: "'a u"
131.59 + assume "x \<sqsubseteq> y" "y \<sqsubseteq> x" thus "x = y"
131.60 + unfolding below_up_def
131.61 + by (auto split: u.split_asm intro: below_antisym)
131.62 +next
131.63 + fix x y z :: "'a u"
131.64 + assume "x \<sqsubseteq> y" "y \<sqsubseteq> z" thus "x \<sqsubseteq> z"
131.65 + unfolding below_up_def
131.66 + by (auto split: u.split_asm intro: below_trans)
131.67 +qed
131.68 +
131.69 +subsection {* Lifted cpo is a cpo *}
131.70 +
131.71 +lemma is_lub_Iup:
131.72 + "range S <<| x \<Longrightarrow> range (\<lambda>i. Iup (S i)) <<| Iup x"
131.73 +unfolding is_lub_def is_ub_def ball_simps
131.74 +by (auto simp add: below_up_def split: u.split)
131.75 +
131.76 +lemma up_chain_lemma:
131.77 + assumes Y: "chain Y" obtains "\<forall>i. Y i = Ibottom"
131.78 + | A k where "\<forall>i. Iup (A i) = Y (i + k)" and "chain A" and "range Y <<| Iup (\<Squnion>i. A i)"
131.79 +proof (cases "\<exists>k. Y k \<noteq> Ibottom")
131.80 + case True
131.81 + then obtain k where k: "Y k \<noteq> Ibottom" ..
131.82 + def A \<equiv> "\<lambda>i. THE a. Iup a = Y (i + k)"
131.83 + have Iup_A: "\<forall>i. Iup (A i) = Y (i + k)"
131.84 + proof
131.85 + fix i :: nat
131.86 + from Y le_add2 have "Y k \<sqsubseteq> Y (i + k)" by (rule chain_mono)
131.87 + with k have "Y (i + k) \<noteq> Ibottom" by (cases "Y k", auto)
131.88 + thus "Iup (A i) = Y (i + k)"
131.89 + by (cases "Y (i + k)", simp_all add: A_def)
131.90 + qed
131.91 + from Y have chain_A: "chain A"
131.92 + unfolding chain_def Iup_below [symmetric]
131.93 + by (simp add: Iup_A)
131.94 + hence "range A <<| (\<Squnion>i. A i)"
131.95 + by (rule cpo_lubI)
131.96 + hence "range (\<lambda>i. Iup (A i)) <<| Iup (\<Squnion>i. A i)"
131.97 + by (rule is_lub_Iup)
131.98 + hence "range (\<lambda>i. Y (i + k)) <<| Iup (\<Squnion>i. A i)"
131.99 + by (simp only: Iup_A)
131.100 + hence "range (\<lambda>i. Y i) <<| Iup (\<Squnion>i. A i)"
131.101 + by (simp only: is_lub_range_shift [OF Y])
131.102 + with Iup_A chain_A show ?thesis ..
131.103 +next
131.104 + case False
131.105 + then have "\<forall>i. Y i = Ibottom" by simp
131.106 + then show ?thesis ..
131.107 +qed
131.108 +
131.109 +instance u :: (cpo) cpo
131.110 +proof
131.111 + fix S :: "nat \<Rightarrow> 'a u"
131.112 + assume S: "chain S"
131.113 + thus "\<exists>x. range (\<lambda>i. S i) <<| x"
131.114 + proof (rule up_chain_lemma)
131.115 + assume "\<forall>i. S i = Ibottom"
131.116 + hence "range (\<lambda>i. S i) <<| Ibottom"
131.117 + by (simp add: is_lub_const)
131.118 + thus ?thesis ..
131.119 + next
131.120 + fix A :: "nat \<Rightarrow> 'a"
131.121 + assume "range S <<| Iup (\<Squnion>i. A i)"
131.122 + thus ?thesis ..
131.123 + qed
131.124 +qed
131.125 +
131.126 +subsection {* Lifted cpo is pointed *}
131.127 +
131.128 +instance u :: (cpo) pcpo
131.129 +by intro_classes fast
131.130 +
131.131 +text {* for compatibility with old HOLCF-Version *}
131.132 +lemma inst_up_pcpo: "\<bottom> = Ibottom"
131.133 +by (rule minimal_up [THEN UU_I, symmetric])
131.134 +
131.135 +subsection {* Continuity of \emph{Iup} and \emph{Ifup} *}
131.136 +
131.137 +text {* continuity for @{term Iup} *}
131.138 +
131.139 +lemma cont_Iup: "cont Iup"
131.140 +apply (rule contI)
131.141 +apply (rule is_lub_Iup)
131.142 +apply (erule cpo_lubI)
131.143 +done
131.144 +
131.145 +text {* continuity for @{term Ifup} *}
131.146 +
131.147 +lemma cont_Ifup1: "cont (\<lambda>f. Ifup f x)"
131.148 +by (induct x, simp_all)
131.149 +
131.150 +lemma monofun_Ifup2: "monofun (\<lambda>x. Ifup f x)"
131.151 +apply (rule monofunI)
131.152 +apply (case_tac x, simp)
131.153 +apply (case_tac y, simp)
131.154 +apply (simp add: monofun_cfun_arg)
131.155 +done
131.156 +
131.157 +lemma cont_Ifup2: "cont (\<lambda>x. Ifup f x)"
131.158 +proof (rule contI2)
131.159 + fix Y assume Y: "chain Y" and Y': "chain (\<lambda>i. Ifup f (Y i))"
131.160 + from Y show "Ifup f (\<Squnion>i. Y i) \<sqsubseteq> (\<Squnion>i. Ifup f (Y i))"
131.161 + proof (rule up_chain_lemma)
131.162 + fix A and k
131.163 + assume A: "\<forall>i. Iup (A i) = Y (i + k)"
131.164 + assume "chain A" and "range Y <<| Iup (\<Squnion>i. A i)"
131.165 + hence "Ifup f (\<Squnion>i. Y i) = (\<Squnion>i. Ifup f (Iup (A i)))"
131.166 + by (simp add: lub_eqI contlub_cfun_arg)
131.167 + also have "\<dots> = (\<Squnion>i. Ifup f (Y (i + k)))"
131.168 + by (simp add: A)
131.169 + also have "\<dots> = (\<Squnion>i. Ifup f (Y i))"
131.170 + using Y' by (rule lub_range_shift)
131.171 + finally show ?thesis by simp
131.172 + qed simp
131.173 +qed (rule monofun_Ifup2)
131.174 +
131.175 +subsection {* Continuous versions of constants *}
131.176 +
131.177 +definition
131.178 + up :: "'a \<rightarrow> 'a u" where
131.179 + "up = (\<Lambda> x. Iup x)"
131.180 +
131.181 +definition
131.182 + fup :: "('a \<rightarrow> 'b::pcpo) \<rightarrow> 'a u \<rightarrow> 'b" where
131.183 + "fup = (\<Lambda> f p. Ifup f p)"
131.184 +
131.185 +translations
131.186 + "case l of XCONST up\<cdot>x \<Rightarrow> t" == "CONST fup\<cdot>(\<Lambda> x. t)\<cdot>l"
131.187 + "\<Lambda>(XCONST up\<cdot>x). t" == "CONST fup\<cdot>(\<Lambda> x. t)"
131.188 +
131.189 +text {* continuous versions of lemmas for @{typ "('a)u"} *}
131.190 +
131.191 +lemma Exh_Up: "z = \<bottom> \<or> (\<exists>x. z = up\<cdot>x)"
131.192 +apply (induct z)
131.193 +apply (simp add: inst_up_pcpo)
131.194 +apply (simp add: up_def cont_Iup)
131.195 +done
131.196 +
131.197 +lemma up_eq [simp]: "(up\<cdot>x = up\<cdot>y) = (x = y)"
131.198 +by (simp add: up_def cont_Iup)
131.199 +
131.200 +lemma up_inject: "up\<cdot>x = up\<cdot>y \<Longrightarrow> x = y"
131.201 +by simp
131.202 +
131.203 +lemma up_defined [simp]: "up\<cdot>x \<noteq> \<bottom>"
131.204 +by (simp add: up_def cont_Iup inst_up_pcpo)
131.205 +
131.206 +lemma not_up_less_UU: "\<not> up\<cdot>x \<sqsubseteq> \<bottom>"
131.207 +by simp (* FIXME: remove? *)
131.208 +
131.209 +lemma up_below [simp]: "up\<cdot>x \<sqsubseteq> up\<cdot>y \<longleftrightarrow> x \<sqsubseteq> y"
131.210 +by (simp add: up_def cont_Iup)
131.211 +
131.212 +lemma upE [case_names bottom up, cases type: u]:
131.213 + "\<lbrakk>p = \<bottom> \<Longrightarrow> Q; \<And>x. p = up\<cdot>x \<Longrightarrow> Q\<rbrakk> \<Longrightarrow> Q"
131.214 +apply (cases p)
131.215 +apply (simp add: inst_up_pcpo)
131.216 +apply (simp add: up_def cont_Iup)
131.217 +done
131.218 +
131.219 +lemma up_induct [case_names bottom up, induct type: u]:
131.220 + "\<lbrakk>P \<bottom>; \<And>x. P (up\<cdot>x)\<rbrakk> \<Longrightarrow> P x"
131.221 +by (cases x, simp_all)
131.222 +
131.223 +text {* lifting preserves chain-finiteness *}
131.224 +
131.225 +lemma up_chain_cases:
131.226 + assumes Y: "chain Y" obtains "\<forall>i. Y i = \<bottom>"
131.227 + | A k where "\<forall>i. up\<cdot>(A i) = Y (i + k)" and "chain A" and "(\<Squnion>i. Y i) = up\<cdot>(\<Squnion>i. A i)"
131.228 +apply (rule up_chain_lemma [OF Y])
131.229 +apply (simp_all add: inst_up_pcpo up_def cont_Iup lub_eqI)
131.230 +done
131.231 +
131.232 +lemma compact_up: "compact x \<Longrightarrow> compact (up\<cdot>x)"
131.233 +apply (rule compactI2)
131.234 +apply (erule up_chain_cases)
131.235 +apply simp
131.236 +apply (drule (1) compactD2, simp)
131.237 +apply (erule exE)
131.238 +apply (drule_tac f="up" and x="x" in monofun_cfun_arg)
131.239 +apply (simp, erule exI)
131.240 +done
131.241 +
131.242 +lemma compact_upD: "compact (up\<cdot>x) \<Longrightarrow> compact x"
131.243 +unfolding compact_def
131.244 +by (drule adm_subst [OF cont_Rep_cfun2 [where f=up]], simp)
131.245 +
131.246 +lemma compact_up_iff [simp]: "compact (up\<cdot>x) = compact x"
131.247 +by (safe elim!: compact_up compact_upD)
131.248 +
131.249 +instance u :: (chfin) chfin
131.250 +apply intro_classes
131.251 +apply (erule compact_imp_max_in_chain)
131.252 +apply (rule_tac p="\<Squnion>i. Y i" in upE, simp_all)
131.253 +done
131.254 +
131.255 +text {* properties of fup *}
131.256 +
131.257 +lemma fup1 [simp]: "fup\<cdot>f\<cdot>\<bottom> = \<bottom>"
131.258 +by (simp add: fup_def cont_Ifup1 cont_Ifup2 inst_up_pcpo cont2cont_LAM)
131.259 +
131.260 +lemma fup2 [simp]: "fup\<cdot>f\<cdot>(up\<cdot>x) = f\<cdot>x"
131.261 +by (simp add: up_def fup_def cont_Iup cont_Ifup1 cont_Ifup2 cont2cont_LAM)
131.262 +
131.263 +lemma fup3 [simp]: "fup\<cdot>up\<cdot>x = x"
131.264 +by (cases x, simp_all)
131.265 +
131.266 +end
132.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
132.2 +++ b/src/HOL/HOLCF/UpperPD.thy Sat Nov 27 16:08:10 2010 -0800
132.3 @@ -0,0 +1,529 @@
132.4 +(* Title: HOLCF/UpperPD.thy
132.5 + Author: Brian Huffman
132.6 +*)
132.7 +
132.8 +header {* Upper powerdomain *}
132.9 +
132.10 +theory UpperPD
132.11 +imports CompactBasis
132.12 +begin
132.13 +
132.14 +subsection {* Basis preorder *}
132.15 +
132.16 +definition
132.17 + upper_le :: "'a pd_basis \<Rightarrow> 'a pd_basis \<Rightarrow> bool" (infix "\<le>\<sharp>" 50) where
132.18 + "upper_le = (\<lambda>u v. \<forall>y\<in>Rep_pd_basis v. \<exists>x\<in>Rep_pd_basis u. x \<sqsubseteq> y)"
132.19 +
132.20 +lemma upper_le_refl [simp]: "t \<le>\<sharp> t"
132.21 +unfolding upper_le_def by fast
132.22 +
132.23 +lemma upper_le_trans: "\<lbrakk>t \<le>\<sharp> u; u \<le>\<sharp> v\<rbrakk> \<Longrightarrow> t \<le>\<sharp> v"
132.24 +unfolding upper_le_def
132.25 +apply (rule ballI)
132.26 +apply (drule (1) bspec, erule bexE)
132.27 +apply (drule (1) bspec, erule bexE)
132.28 +apply (erule rev_bexI)
132.29 +apply (erule (1) below_trans)
132.30 +done
132.31 +
132.32 +interpretation upper_le: preorder upper_le
132.33 +by (rule preorder.intro, rule upper_le_refl, rule upper_le_trans)
132.34 +
132.35 +lemma upper_le_minimal [simp]: "PDUnit compact_bot \<le>\<sharp> t"
132.36 +unfolding upper_le_def Rep_PDUnit by simp
132.37 +
132.38 +lemma PDUnit_upper_mono: "x \<sqsubseteq> y \<Longrightarrow> PDUnit x \<le>\<sharp> PDUnit y"
132.39 +unfolding upper_le_def Rep_PDUnit by simp
132.40 +
132.41 +lemma PDPlus_upper_mono: "\<lbrakk>s \<le>\<sharp> t; u \<le>\<sharp> v\<rbrakk> \<Longrightarrow> PDPlus s u \<le>\<sharp> PDPlus t v"
132.42 +unfolding upper_le_def Rep_PDPlus by fast
132.43 +
132.44 +lemma PDPlus_upper_le: "PDPlus t u \<le>\<sharp> t"
132.45 +unfolding upper_le_def Rep_PDPlus by fast
132.46 +
132.47 +lemma upper_le_PDUnit_PDUnit_iff [simp]:
132.48 + "(PDUnit a \<le>\<sharp> PDUnit b) = (a \<sqsubseteq> b)"
132.49 +unfolding upper_le_def Rep_PDUnit by fast
132.50 +
132.51 +lemma upper_le_PDPlus_PDUnit_iff:
132.52 + "(PDPlus t u \<le>\<sharp> PDUnit a) = (t \<le>\<sharp> PDUnit a \<or> u \<le>\<sharp> PDUnit a)"
132.53 +unfolding upper_le_def Rep_PDPlus Rep_PDUnit by fast
132.54 +
132.55 +lemma upper_le_PDPlus_iff: "(t \<le>\<sharp> PDPlus u v) = (t \<le>\<sharp> u \<and> t \<le>\<sharp> v)"
132.56 +unfolding upper_le_def Rep_PDPlus by fast
132.57 +
132.58 +lemma upper_le_induct [induct set: upper_le]:
132.59 + assumes le: "t \<le>\<sharp> u"
132.60 + assumes 1: "\<And>a b. a \<sqsubseteq> b \<Longrightarrow> P (PDUnit a) (PDUnit b)"
132.61 + assumes 2: "\<And>t u a. P t (PDUnit a) \<Longrightarrow> P (PDPlus t u) (PDUnit a)"
132.62 + assumes 3: "\<And>t u v. \<lbrakk>P t u; P t v\<rbrakk> \<Longrightarrow> P t (PDPlus u v)"
132.63 + shows "P t u"
132.64 +using le apply (induct u arbitrary: t rule: pd_basis_induct)
132.65 +apply (erule rev_mp)
132.66 +apply (induct_tac t rule: pd_basis_induct)
132.67 +apply (simp add: 1)
132.68 +apply (simp add: upper_le_PDPlus_PDUnit_iff)
132.69 +apply (simp add: 2)
132.70 +apply (subst PDPlus_commute)
132.71 +apply (simp add: 2)
132.72 +apply (simp add: upper_le_PDPlus_iff 3)
132.73 +done
132.74 +
132.75 +
132.76 +subsection {* Type definition *}
132.77 +
132.78 +typedef (open) 'a upper_pd =
132.79 + "{S::'a pd_basis set. upper_le.ideal S}"
132.80 +by (fast intro: upper_le.ideal_principal)
132.81 +
132.82 +instantiation upper_pd :: ("domain") below
132.83 +begin
132.84 +
132.85 +definition
132.86 + "x \<sqsubseteq> y \<longleftrightarrow> Rep_upper_pd x \<subseteq> Rep_upper_pd y"
132.87 +
132.88 +instance ..
132.89 +end
132.90 +
132.91 +instance upper_pd :: ("domain") po
132.92 +using type_definition_upper_pd below_upper_pd_def
132.93 +by (rule upper_le.typedef_ideal_po)
132.94 +
132.95 +instance upper_pd :: ("domain") cpo
132.96 +using type_definition_upper_pd below_upper_pd_def
132.97 +by (rule upper_le.typedef_ideal_cpo)
132.98 +
132.99 +definition
132.100 + upper_principal :: "'a pd_basis \<Rightarrow> 'a upper_pd" where
132.101 + "upper_principal t = Abs_upper_pd {u. u \<le>\<sharp> t}"
132.102 +
132.103 +interpretation upper_pd:
132.104 + ideal_completion upper_le upper_principal Rep_upper_pd
132.105 +using type_definition_upper_pd below_upper_pd_def
132.106 +using upper_principal_def pd_basis_countable
132.107 +by (rule upper_le.typedef_ideal_completion)
132.108 +
132.109 +text {* Upper powerdomain is pointed *}
132.110 +
132.111 +lemma upper_pd_minimal: "upper_principal (PDUnit compact_bot) \<sqsubseteq> ys"
132.112 +by (induct ys rule: upper_pd.principal_induct, simp, simp)
132.113 +
132.114 +instance upper_pd :: ("domain") pcpo
132.115 +by intro_classes (fast intro: upper_pd_minimal)
132.116 +
132.117 +lemma inst_upper_pd_pcpo: "\<bottom> = upper_principal (PDUnit compact_bot)"
132.118 +by (rule upper_pd_minimal [THEN UU_I, symmetric])
132.119 +
132.120 +
132.121 +subsection {* Monadic unit and plus *}
132.122 +
132.123 +definition
132.124 + upper_unit :: "'a \<rightarrow> 'a upper_pd" where
132.125 + "upper_unit = compact_basis.basis_fun (\<lambda>a. upper_principal (PDUnit a))"
132.126 +
132.127 +definition
132.128 + upper_plus :: "'a upper_pd \<rightarrow> 'a upper_pd \<rightarrow> 'a upper_pd" where
132.129 + "upper_plus = upper_pd.basis_fun (\<lambda>t. upper_pd.basis_fun (\<lambda>u.
132.130 + upper_principal (PDPlus t u)))"
132.131 +
132.132 +abbreviation
132.133 + upper_add :: "'a upper_pd \<Rightarrow> 'a upper_pd \<Rightarrow> 'a upper_pd"
132.134 + (infixl "+\<sharp>" 65) where
132.135 + "xs +\<sharp> ys == upper_plus\<cdot>xs\<cdot>ys"
132.136 +
132.137 +syntax
132.138 + "_upper_pd" :: "args \<Rightarrow> 'a upper_pd" ("{_}\<sharp>")
132.139 +
132.140 +translations
132.141 + "{x,xs}\<sharp>" == "{x}\<sharp> +\<sharp> {xs}\<sharp>"
132.142 + "{x}\<sharp>" == "CONST upper_unit\<cdot>x"
132.143 +
132.144 +lemma upper_unit_Rep_compact_basis [simp]:
132.145 + "{Rep_compact_basis a}\<sharp> = upper_principal (PDUnit a)"
132.146 +unfolding upper_unit_def
132.147 +by (simp add: compact_basis.basis_fun_principal PDUnit_upper_mono)
132.148 +
132.149 +lemma upper_plus_principal [simp]:
132.150 + "upper_principal t +\<sharp> upper_principal u = upper_principal (PDPlus t u)"
132.151 +unfolding upper_plus_def
132.152 +by (simp add: upper_pd.basis_fun_principal
132.153 + upper_pd.basis_fun_mono PDPlus_upper_mono)
132.154 +
132.155 +interpretation upper_add: semilattice upper_add proof
132.156 + fix xs ys zs :: "'a upper_pd"
132.157 + show "(xs +\<sharp> ys) +\<sharp> zs = xs +\<sharp> (ys +\<sharp> zs)"
132.158 + apply (induct xs ys arbitrary: zs rule: upper_pd.principal_induct2, simp, simp)
132.159 + apply (rule_tac x=zs in upper_pd.principal_induct, simp)
132.160 + apply (simp add: PDPlus_assoc)
132.161 + done
132.162 + show "xs +\<sharp> ys = ys +\<sharp> xs"
132.163 + apply (induct xs ys rule: upper_pd.principal_induct2, simp, simp)
132.164 + apply (simp add: PDPlus_commute)
132.165 + done
132.166 + show "xs +\<sharp> xs = xs"
132.167 + apply (induct xs rule: upper_pd.principal_induct, simp)
132.168 + apply (simp add: PDPlus_absorb)
132.169 + done
132.170 +qed
132.171 +
132.172 +lemmas upper_plus_assoc = upper_add.assoc
132.173 +lemmas upper_plus_commute = upper_add.commute
132.174 +lemmas upper_plus_absorb = upper_add.idem
132.175 +lemmas upper_plus_left_commute = upper_add.left_commute
132.176 +lemmas upper_plus_left_absorb = upper_add.left_idem
132.177 +
132.178 +text {* Useful for @{text "simp add: upper_plus_ac"} *}
132.179 +lemmas upper_plus_ac =
132.180 + upper_plus_assoc upper_plus_commute upper_plus_left_commute
132.181 +
132.182 +text {* Useful for @{text "simp only: upper_plus_aci"} *}
132.183 +lemmas upper_plus_aci =
132.184 + upper_plus_ac upper_plus_absorb upper_plus_left_absorb
132.185 +
132.186 +lemma upper_plus_below1: "xs +\<sharp> ys \<sqsubseteq> xs"
132.187 +apply (induct xs ys rule: upper_pd.principal_induct2, simp, simp)
132.188 +apply (simp add: PDPlus_upper_le)
132.189 +done
132.190 +
132.191 +lemma upper_plus_below2: "xs +\<sharp> ys \<sqsubseteq> ys"
132.192 +by (subst upper_plus_commute, rule upper_plus_below1)
132.193 +
132.194 +lemma upper_plus_greatest: "\<lbrakk>xs \<sqsubseteq> ys; xs \<sqsubseteq> zs\<rbrakk> \<Longrightarrow> xs \<sqsubseteq> ys +\<sharp> zs"
132.195 +apply (subst upper_plus_absorb [of xs, symmetric])
132.196 +apply (erule (1) monofun_cfun [OF monofun_cfun_arg])
132.197 +done
132.198 +
132.199 +lemma upper_below_plus_iff [simp]:
132.200 + "xs \<sqsubseteq> ys +\<sharp> zs \<longleftrightarrow> xs \<sqsubseteq> ys \<and> xs \<sqsubseteq> zs"
132.201 +apply safe
132.202 +apply (erule below_trans [OF _ upper_plus_below1])
132.203 +apply (erule below_trans [OF _ upper_plus_below2])
132.204 +apply (erule (1) upper_plus_greatest)
132.205 +done
132.206 +
132.207 +lemma upper_plus_below_unit_iff [simp]:
132.208 + "xs +\<sharp> ys \<sqsubseteq> {z}\<sharp> \<longleftrightarrow> xs \<sqsubseteq> {z}\<sharp> \<or> ys \<sqsubseteq> {z}\<sharp>"
132.209 +apply (induct xs rule: upper_pd.principal_induct, simp)
132.210 +apply (induct ys rule: upper_pd.principal_induct, simp)
132.211 +apply (induct z rule: compact_basis.principal_induct, simp)
132.212 +apply (simp add: upper_le_PDPlus_PDUnit_iff)
132.213 +done
132.214 +
132.215 +lemma upper_unit_below_iff [simp]: "{x}\<sharp> \<sqsubseteq> {y}\<sharp> \<longleftrightarrow> x \<sqsubseteq> y"
132.216 +apply (induct x rule: compact_basis.principal_induct, simp)
132.217 +apply (induct y rule: compact_basis.principal_induct, simp)
132.218 +apply simp
132.219 +done
132.220 +
132.221 +lemmas upper_pd_below_simps =
132.222 + upper_unit_below_iff
132.223 + upper_below_plus_iff
132.224 + upper_plus_below_unit_iff
132.225 +
132.226 +lemma upper_unit_eq_iff [simp]: "{x}\<sharp> = {y}\<sharp> \<longleftrightarrow> x = y"
132.227 +unfolding po_eq_conv by simp
132.228 +
132.229 +lemma upper_unit_strict [simp]: "{\<bottom>}\<sharp> = \<bottom>"
132.230 +using upper_unit_Rep_compact_basis [of compact_bot]
132.231 +by (simp add: inst_upper_pd_pcpo)
132.232 +
132.233 +lemma upper_plus_strict1 [simp]: "\<bottom> +\<sharp> ys = \<bottom>"
132.234 +by (rule UU_I, rule upper_plus_below1)
132.235 +
132.236 +lemma upper_plus_strict2 [simp]: "xs +\<sharp> \<bottom> = \<bottom>"
132.237 +by (rule UU_I, rule upper_plus_below2)
132.238 +
132.239 +lemma upper_unit_bottom_iff [simp]: "{x}\<sharp> = \<bottom> \<longleftrightarrow> x = \<bottom>"
132.240 +unfolding upper_unit_strict [symmetric] by (rule upper_unit_eq_iff)
132.241 +
132.242 +lemma upper_plus_bottom_iff [simp]:
132.243 + "xs +\<sharp> ys = \<bottom> \<longleftrightarrow> xs = \<bottom> \<or> ys = \<bottom>"
132.244 +apply (rule iffI)
132.245 +apply (erule rev_mp)
132.246 +apply (rule upper_pd.principal_induct2 [where x=xs and y=ys], simp, simp)
132.247 +apply (simp add: inst_upper_pd_pcpo upper_pd.principal_eq_iff
132.248 + upper_le_PDPlus_PDUnit_iff)
132.249 +apply auto
132.250 +done
132.251 +
132.252 +lemma compact_upper_unit: "compact x \<Longrightarrow> compact {x}\<sharp>"
132.253 +by (auto dest!: compact_basis.compact_imp_principal)
132.254 +
132.255 +lemma compact_upper_unit_iff [simp]: "compact {x}\<sharp> \<longleftrightarrow> compact x"
132.256 +apply (safe elim!: compact_upper_unit)
132.257 +apply (simp only: compact_def upper_unit_below_iff [symmetric])
132.258 +apply (erule adm_subst [OF cont_Rep_cfun2])
132.259 +done
132.260 +
132.261 +lemma compact_upper_plus [simp]:
132.262 + "\<lbrakk>compact xs; compact ys\<rbrakk> \<Longrightarrow> compact (xs +\<sharp> ys)"
132.263 +by (auto dest!: upper_pd.compact_imp_principal)
132.264 +
132.265 +
132.266 +subsection {* Induction rules *}
132.267 +
132.268 +lemma upper_pd_induct1:
132.269 + assumes P: "adm P"
132.270 + assumes unit: "\<And>x. P {x}\<sharp>"
132.271 + assumes insert: "\<And>x ys. \<lbrakk>P {x}\<sharp>; P ys\<rbrakk> \<Longrightarrow> P ({x}\<sharp> +\<sharp> ys)"
132.272 + shows "P (xs::'a upper_pd)"
132.273 +apply (induct xs rule: upper_pd.principal_induct, rule P)
132.274 +apply (induct_tac a rule: pd_basis_induct1)
132.275 +apply (simp only: upper_unit_Rep_compact_basis [symmetric])
132.276 +apply (rule unit)
132.277 +apply (simp only: upper_unit_Rep_compact_basis [symmetric]
132.278 + upper_plus_principal [symmetric])
132.279 +apply (erule insert [OF unit])
132.280 +done
132.281 +
132.282 +lemma upper_pd_induct
132.283 + [case_names adm upper_unit upper_plus, induct type: upper_pd]:
132.284 + assumes P: "adm P"
132.285 + assumes unit: "\<And>x. P {x}\<sharp>"
132.286 + assumes plus: "\<And>xs ys. \<lbrakk>P xs; P ys\<rbrakk> \<Longrightarrow> P (xs +\<sharp> ys)"
132.287 + shows "P (xs::'a upper_pd)"
132.288 +apply (induct xs rule: upper_pd.principal_induct, rule P)
132.289 +apply (induct_tac a rule: pd_basis_induct)
132.290 +apply (simp only: upper_unit_Rep_compact_basis [symmetric] unit)
132.291 +apply (simp only: upper_plus_principal [symmetric] plus)
132.292 +done
132.293 +
132.294 +
132.295 +subsection {* Monadic bind *}
132.296 +
132.297 +definition
132.298 + upper_bind_basis ::
132.299 + "'a pd_basis \<Rightarrow> ('a \<rightarrow> 'b upper_pd) \<rightarrow> 'b upper_pd" where
132.300 + "upper_bind_basis = fold_pd
132.301 + (\<lambda>a. \<Lambda> f. f\<cdot>(Rep_compact_basis a))
132.302 + (\<lambda>x y. \<Lambda> f. x\<cdot>f +\<sharp> y\<cdot>f)"
132.303 +
132.304 +lemma ACI_upper_bind:
132.305 + "class.ab_semigroup_idem_mult (\<lambda>x y. \<Lambda> f. x\<cdot>f +\<sharp> y\<cdot>f)"
132.306 +apply unfold_locales
132.307 +apply (simp add: upper_plus_assoc)
132.308 +apply (simp add: upper_plus_commute)
132.309 +apply (simp add: eta_cfun)
132.310 +done
132.311 +
132.312 +lemma upper_bind_basis_simps [simp]:
132.313 + "upper_bind_basis (PDUnit a) =
132.314 + (\<Lambda> f. f\<cdot>(Rep_compact_basis a))"
132.315 + "upper_bind_basis (PDPlus t u) =
132.316 + (\<Lambda> f. upper_bind_basis t\<cdot>f +\<sharp> upper_bind_basis u\<cdot>f)"
132.317 +unfolding upper_bind_basis_def
132.318 +apply -
132.319 +apply (rule fold_pd_PDUnit [OF ACI_upper_bind])
132.320 +apply (rule fold_pd_PDPlus [OF ACI_upper_bind])
132.321 +done
132.322 +
132.323 +lemma upper_bind_basis_mono:
132.324 + "t \<le>\<sharp> u \<Longrightarrow> upper_bind_basis t \<sqsubseteq> upper_bind_basis u"
132.325 +unfolding cfun_below_iff
132.326 +apply (erule upper_le_induct, safe)
132.327 +apply (simp add: monofun_cfun)
132.328 +apply (simp add: below_trans [OF upper_plus_below1])
132.329 +apply simp
132.330 +done
132.331 +
132.332 +definition
132.333 + upper_bind :: "'a upper_pd \<rightarrow> ('a \<rightarrow> 'b upper_pd) \<rightarrow> 'b upper_pd" where
132.334 + "upper_bind = upper_pd.basis_fun upper_bind_basis"
132.335 +
132.336 +lemma upper_bind_principal [simp]:
132.337 + "upper_bind\<cdot>(upper_principal t) = upper_bind_basis t"
132.338 +unfolding upper_bind_def
132.339 +apply (rule upper_pd.basis_fun_principal)
132.340 +apply (erule upper_bind_basis_mono)
132.341 +done
132.342 +
132.343 +lemma upper_bind_unit [simp]:
132.344 + "upper_bind\<cdot>{x}\<sharp>\<cdot>f = f\<cdot>x"
132.345 +by (induct x rule: compact_basis.principal_induct, simp, simp)
132.346 +
132.347 +lemma upper_bind_plus [simp]:
132.348 + "upper_bind\<cdot>(xs +\<sharp> ys)\<cdot>f = upper_bind\<cdot>xs\<cdot>f +\<sharp> upper_bind\<cdot>ys\<cdot>f"
132.349 +by (induct xs ys rule: upper_pd.principal_induct2, simp, simp, simp)
132.350 +
132.351 +lemma upper_bind_strict [simp]: "upper_bind\<cdot>\<bottom>\<cdot>f = f\<cdot>\<bottom>"
132.352 +unfolding upper_unit_strict [symmetric] by (rule upper_bind_unit)
132.353 +
132.354 +lemma upper_bind_bind:
132.355 + "upper_bind\<cdot>(upper_bind\<cdot>xs\<cdot>f)\<cdot>g = upper_bind\<cdot>xs\<cdot>(\<Lambda> x. upper_bind\<cdot>(f\<cdot>x)\<cdot>g)"
132.356 +by (induct xs, simp_all)
132.357 +
132.358 +
132.359 +subsection {* Map *}
132.360 +
132.361 +definition
132.362 + upper_map :: "('a \<rightarrow> 'b) \<rightarrow> 'a upper_pd \<rightarrow> 'b upper_pd" where
132.363 + "upper_map = (\<Lambda> f xs. upper_bind\<cdot>xs\<cdot>(\<Lambda> x. {f\<cdot>x}\<sharp>))"
132.364 +
132.365 +lemma upper_map_unit [simp]:
132.366 + "upper_map\<cdot>f\<cdot>{x}\<sharp> = {f\<cdot>x}\<sharp>"
132.367 +unfolding upper_map_def by simp
132.368 +
132.369 +lemma upper_map_plus [simp]:
132.370 + "upper_map\<cdot>f\<cdot>(xs +\<sharp> ys) = upper_map\<cdot>f\<cdot>xs +\<sharp> upper_map\<cdot>f\<cdot>ys"
132.371 +unfolding upper_map_def by simp
132.372 +
132.373 +lemma upper_map_bottom [simp]: "upper_map\<cdot>f\<cdot>\<bottom> = {f\<cdot>\<bottom>}\<sharp>"
132.374 +unfolding upper_map_def by simp
132.375 +
132.376 +lemma upper_map_ident: "upper_map\<cdot>(\<Lambda> x. x)\<cdot>xs = xs"
132.377 +by (induct xs rule: upper_pd_induct, simp_all)
132.378 +
132.379 +lemma upper_map_ID: "upper_map\<cdot>ID = ID"
132.380 +by (simp add: cfun_eq_iff ID_def upper_map_ident)
132.381 +
132.382 +lemma upper_map_map:
132.383 + "upper_map\<cdot>f\<cdot>(upper_map\<cdot>g\<cdot>xs) = upper_map\<cdot>(\<Lambda> x. f\<cdot>(g\<cdot>x))\<cdot>xs"
132.384 +by (induct xs rule: upper_pd_induct, simp_all)
132.385 +
132.386 +lemma ep_pair_upper_map: "ep_pair e p \<Longrightarrow> ep_pair (upper_map\<cdot>e) (upper_map\<cdot>p)"
132.387 +apply default
132.388 +apply (induct_tac x rule: upper_pd_induct, simp_all add: ep_pair.e_inverse)
132.389 +apply (induct_tac y rule: upper_pd_induct)
132.390 +apply (simp_all add: ep_pair.e_p_below monofun_cfun del: upper_below_plus_iff)
132.391 +done
132.392 +
132.393 +lemma deflation_upper_map: "deflation d \<Longrightarrow> deflation (upper_map\<cdot>d)"
132.394 +apply default
132.395 +apply (induct_tac x rule: upper_pd_induct, simp_all add: deflation.idem)
132.396 +apply (induct_tac x rule: upper_pd_induct)
132.397 +apply (simp_all add: deflation.below monofun_cfun del: upper_below_plus_iff)
132.398 +done
132.399 +
132.400 +(* FIXME: long proof! *)
132.401 +lemma finite_deflation_upper_map:
132.402 + assumes "finite_deflation d" shows "finite_deflation (upper_map\<cdot>d)"
132.403 +proof (rule finite_deflation_intro)
132.404 + interpret d: finite_deflation d by fact
132.405 + have "deflation d" by fact
132.406 + thus "deflation (upper_map\<cdot>d)" by (rule deflation_upper_map)
132.407 + have "finite (range (\<lambda>x. d\<cdot>x))" by (rule d.finite_range)
132.408 + hence "finite (Rep_compact_basis -` range (\<lambda>x. d\<cdot>x))"
132.409 + by (rule finite_vimageI, simp add: inj_on_def Rep_compact_basis_inject)
132.410 + hence "finite (Pow (Rep_compact_basis -` range (\<lambda>x. d\<cdot>x)))" by simp
132.411 + hence "finite (Rep_pd_basis -` (Pow (Rep_compact_basis -` range (\<lambda>x. d\<cdot>x))))"
132.412 + by (rule finite_vimageI, simp add: inj_on_def Rep_pd_basis_inject)
132.413 + hence *: "finite (upper_principal ` Rep_pd_basis -` (Pow (Rep_compact_basis -` range (\<lambda>x. d\<cdot>x))))" by simp
132.414 + hence "finite (range (\<lambda>xs. upper_map\<cdot>d\<cdot>xs))"
132.415 + apply (rule rev_finite_subset)
132.416 + apply clarsimp
132.417 + apply (induct_tac xs rule: upper_pd.principal_induct)
132.418 + apply (simp add: adm_mem_finite *)
132.419 + apply (rename_tac t, induct_tac t rule: pd_basis_induct)
132.420 + apply (simp only: upper_unit_Rep_compact_basis [symmetric] upper_map_unit)
132.421 + apply simp
132.422 + apply (subgoal_tac "\<exists>b. d\<cdot>(Rep_compact_basis a) = Rep_compact_basis b")
132.423 + apply clarsimp
132.424 + apply (rule imageI)
132.425 + apply (rule vimageI2)
132.426 + apply (simp add: Rep_PDUnit)
132.427 + apply (rule range_eqI)
132.428 + apply (erule sym)
132.429 + apply (rule exI)
132.430 + apply (rule Abs_compact_basis_inverse [symmetric])
132.431 + apply (simp add: d.compact)
132.432 + apply (simp only: upper_plus_principal [symmetric] upper_map_plus)
132.433 + apply clarsimp
132.434 + apply (rule imageI)
132.435 + apply (rule vimageI2)
132.436 + apply (simp add: Rep_PDPlus)
132.437 + done
132.438 + thus "finite {xs. upper_map\<cdot>d\<cdot>xs = xs}"
132.439 + by (rule finite_range_imp_finite_fixes)
132.440 +qed
132.441 +
132.442 +subsection {* Upper powerdomain is a domain *}
132.443 +
132.444 +definition
132.445 + upper_approx :: "nat \<Rightarrow> udom upper_pd \<rightarrow> udom upper_pd"
132.446 +where
132.447 + "upper_approx = (\<lambda>i. upper_map\<cdot>(udom_approx i))"
132.448 +
132.449 +lemma upper_approx: "approx_chain upper_approx"
132.450 +using upper_map_ID finite_deflation_upper_map
132.451 +unfolding upper_approx_def by (rule approx_chain_lemma1)
132.452 +
132.453 +definition upper_defl :: "defl \<rightarrow> defl"
132.454 +where "upper_defl = defl_fun1 upper_approx upper_map"
132.455 +
132.456 +lemma cast_upper_defl:
132.457 + "cast\<cdot>(upper_defl\<cdot>A) =
132.458 + udom_emb upper_approx oo upper_map\<cdot>(cast\<cdot>A) oo udom_prj upper_approx"
132.459 +using upper_approx finite_deflation_upper_map
132.460 +unfolding upper_defl_def by (rule cast_defl_fun1)
132.461 +
132.462 +instantiation upper_pd :: ("domain") liftdomain
132.463 +begin
132.464 +
132.465 +definition
132.466 + "emb = udom_emb upper_approx oo upper_map\<cdot>emb"
132.467 +
132.468 +definition
132.469 + "prj = upper_map\<cdot>prj oo udom_prj upper_approx"
132.470 +
132.471 +definition
132.472 + "defl (t::'a upper_pd itself) = upper_defl\<cdot>DEFL('a)"
132.473 +
132.474 +definition
132.475 + "(liftemb :: 'a upper_pd u \<rightarrow> udom) = udom_emb u_approx oo u_map\<cdot>emb"
132.476 +
132.477 +definition
132.478 + "(liftprj :: udom \<rightarrow> 'a upper_pd u) = u_map\<cdot>prj oo udom_prj u_approx"
132.479 +
132.480 +definition
132.481 + "liftdefl (t::'a upper_pd itself) = u_defl\<cdot>DEFL('a upper_pd)"
132.482 +
132.483 +instance
132.484 +using liftemb_upper_pd_def liftprj_upper_pd_def liftdefl_upper_pd_def
132.485 +proof (rule liftdomain_class_intro)
132.486 + show "ep_pair emb (prj :: udom \<rightarrow> 'a upper_pd)"
132.487 + unfolding emb_upper_pd_def prj_upper_pd_def
132.488 + using ep_pair_udom [OF upper_approx]
132.489 + by (intro ep_pair_comp ep_pair_upper_map ep_pair_emb_prj)
132.490 +next
132.491 + show "cast\<cdot>DEFL('a upper_pd) = emb oo (prj :: udom \<rightarrow> 'a upper_pd)"
132.492 + unfolding emb_upper_pd_def prj_upper_pd_def defl_upper_pd_def cast_upper_defl
132.493 + by (simp add: cast_DEFL oo_def cfun_eq_iff upper_map_map)
132.494 +qed
132.495 +
132.496 +end
132.497 +
132.498 +lemma DEFL_upper: "DEFL('a upper_pd) = upper_defl\<cdot>DEFL('a)"
132.499 +by (rule defl_upper_pd_def)
132.500 +
132.501 +
132.502 +subsection {* Join *}
132.503 +
132.504 +definition
132.505 + upper_join :: "'a upper_pd upper_pd \<rightarrow> 'a upper_pd" where
132.506 + "upper_join = (\<Lambda> xss. upper_bind\<cdot>xss\<cdot>(\<Lambda> xs. xs))"
132.507 +
132.508 +lemma upper_join_unit [simp]:
132.509 + "upper_join\<cdot>{xs}\<sharp> = xs"
132.510 +unfolding upper_join_def by simp
132.511 +
132.512 +lemma upper_join_plus [simp]:
132.513 + "upper_join\<cdot>(xss +\<sharp> yss) = upper_join\<cdot>xss +\<sharp> upper_join\<cdot>yss"
132.514 +unfolding upper_join_def by simp
132.515 +
132.516 +lemma upper_join_bottom [simp]: "upper_join\<cdot>\<bottom> = \<bottom>"
132.517 +unfolding upper_join_def by simp
132.518 +
132.519 +lemma upper_join_map_unit:
132.520 + "upper_join\<cdot>(upper_map\<cdot>upper_unit\<cdot>xs) = xs"
132.521 +by (induct xs rule: upper_pd_induct, simp_all)
132.522 +
132.523 +lemma upper_join_map_join:
132.524 + "upper_join\<cdot>(upper_map\<cdot>upper_join\<cdot>xsss) = upper_join\<cdot>(upper_join\<cdot>xsss)"
132.525 +by (induct xsss rule: upper_pd_induct, simp_all)
132.526 +
132.527 +lemma upper_join_map_map:
132.528 + "upper_join\<cdot>(upper_map\<cdot>(upper_map\<cdot>f)\<cdot>xss) =
132.529 + upper_map\<cdot>f\<cdot>(upper_join\<cdot>xss)"
132.530 +by (induct xss rule: upper_pd_induct, simp_all)
132.531 +
132.532 +end
133.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
133.2 +++ b/src/HOL/HOLCF/document/root.tex Sat Nov 27 16:08:10 2010 -0800
133.3 @@ -0,0 +1,35 @@
133.4 +
133.5 +% HOLCF/document/root.tex
133.6 +
133.7 +\documentclass[11pt,a4paper]{article}
133.8 +\usepackage{graphicx,isabelle,isabellesym,latexsym}
133.9 +\usepackage[only,bigsqcap]{stmaryrd}
133.10 +\usepackage[latin1]{inputenc}
133.11 +\usepackage{pdfsetup}
133.12 +
133.13 +\urlstyle{rm}
133.14 +\isabellestyle{it}
133.15 +\pagestyle{myheadings}
133.16 +\newcommand{\isasymas}{\textsf{as}}
133.17 +\newcommand{\isasymlazy}{\isamath{\sim}}
133.18 +
133.19 +\begin{document}
133.20 +
133.21 +\title{Isabelle/HOLCF --- Higher-Order Logic of Computable Functions}
133.22 +\maketitle
133.23 +
133.24 +\tableofcontents
133.25 +
133.26 +\begin{center}
133.27 + \includegraphics[scale=0.45]{session_graph}
133.28 +\end{center}
133.29 +
133.30 +\newpage
133.31 +
133.32 +\renewcommand{\isamarkupheader}[1]%
133.33 +{\section{\isabellecontext: #1}\markright{THEORY~``\isabellecontext''}}
133.34 +
133.35 +\parindent 0pt\parskip 0.5ex
133.36 +\input{session}
133.37 +
133.38 +\end{document}
134.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
134.2 +++ b/src/HOL/HOLCF/ex/Dagstuhl.thy Sat Nov 27 16:08:10 2010 -0800
134.3 @@ -0,0 +1,92 @@
134.4 +theory Dagstuhl
134.5 +imports Stream
134.6 +begin
134.7 +
134.8 +axiomatization
134.9 + y :: "'a"
134.10 +
134.11 +definition
134.12 + YS :: "'a stream" where
134.13 + "YS = fix$(LAM x. y && x)"
134.14 +
134.15 +definition
134.16 + YYS :: "'a stream" where
134.17 + "YYS = fix$(LAM z. y && y && z)"
134.18 +
134.19 +lemma YS_def2: "YS = y && YS"
134.20 + apply (rule trans)
134.21 + apply (rule fix_eq2)
134.22 + apply (rule YS_def [THEN eq_reflection])
134.23 + apply (rule beta_cfun)
134.24 + apply simp
134.25 + done
134.26 +
134.27 +lemma YYS_def2: "YYS = y && y && YYS"
134.28 + apply (rule trans)
134.29 + apply (rule fix_eq2)
134.30 + apply (rule YYS_def [THEN eq_reflection])
134.31 + apply (rule beta_cfun)
134.32 + apply simp
134.33 + done
134.34 +
134.35 +
134.36 +lemma lemma3: "YYS << y && YYS"
134.37 + apply (rule YYS_def [THEN eq_reflection, THEN def_fix_ind])
134.38 + apply simp_all
134.39 + apply (rule monofun_cfun_arg)
134.40 + apply (rule monofun_cfun_arg)
134.41 + apply assumption
134.42 + done
134.43 +
134.44 +lemma lemma4: "y && YYS << YYS"
134.45 + apply (subst YYS_def2)
134.46 + back
134.47 + apply (rule monofun_cfun_arg)
134.48 + apply (rule lemma3)
134.49 + done
134.50 +
134.51 +lemma lemma5: "y && YYS = YYS"
134.52 + apply (rule below_antisym)
134.53 + apply (rule lemma4)
134.54 + apply (rule lemma3)
134.55 + done
134.56 +
134.57 +lemma wir_moel: "YS = YYS"
134.58 + apply (rule stream.take_lemma)
134.59 + apply (induct_tac n)
134.60 + apply (simp (no_asm))
134.61 + apply (subst YS_def2)
134.62 + apply (subst YYS_def2)
134.63 + apply simp
134.64 + apply (rule lemma5 [symmetric, THEN subst])
134.65 + apply (rule refl)
134.66 + done
134.67 +
134.68 +(* ------------------------------------------------------------------------ *)
134.69 +(* Zweite L"osung: Bernhard Möller *)
134.70 +(* statt Beweis von wir_moel "uber take_lemma beidseitige Inclusion *)
134.71 +(* verwendet lemma5 *)
134.72 +(* ------------------------------------------------------------------------ *)
134.73 +
134.74 +lemma lemma6: "YYS << YS"
134.75 + apply (unfold YYS_def)
134.76 + apply (rule fix_least)
134.77 + apply (subst beta_cfun)
134.78 + apply simp
134.79 + apply (simp add: YS_def2 [symmetric])
134.80 + done
134.81 +
134.82 +lemma lemma7: "YS << YYS"
134.83 + apply (rule YS_def [THEN eq_reflection, THEN def_fix_ind])
134.84 + apply simp_all
134.85 + apply (subst lemma5 [symmetric])
134.86 + apply (erule monofun_cfun_arg)
134.87 + done
134.88 +
134.89 +lemma wir_moel': "YS = YYS"
134.90 + apply (rule below_antisym)
134.91 + apply (rule lemma7)
134.92 + apply (rule lemma6)
134.93 + done
134.94 +
134.95 +end
135.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
135.2 +++ b/src/HOL/HOLCF/ex/Dnat.thy Sat Nov 27 16:08:10 2010 -0800
135.3 @@ -0,0 +1,72 @@
135.4 +(* Title: HOLCF/Dnat.thy
135.5 + Author: Franz Regensburger
135.6 +
135.7 +Theory for the domain of natural numbers dnat = one ++ dnat
135.8 +*)
135.9 +
135.10 +theory Dnat
135.11 +imports HOLCF
135.12 +begin
135.13 +
135.14 +domain dnat = dzero | dsucc (dpred :: dnat)
135.15 +
135.16 +definition
135.17 + iterator :: "dnat -> ('a -> 'a) -> 'a -> 'a" where
135.18 + "iterator = fix $ (LAM h n f x.
135.19 + case n of dzero => x
135.20 + | dsucc $ m => f $ (h $ m $ f $ x))"
135.21 +
135.22 +text {*
135.23 + \medskip Expand fixed point properties.
135.24 +*}
135.25 +
135.26 +lemma iterator_def2:
135.27 + "iterator = (LAM n f x. case n of dzero => x | dsucc$m => f$(iterator$m$f$x))"
135.28 + apply (rule trans)
135.29 + apply (rule fix_eq2)
135.30 + apply (rule iterator_def [THEN eq_reflection])
135.31 + apply (rule beta_cfun)
135.32 + apply simp
135.33 + done
135.34 +
135.35 +text {* \medskip Recursive properties. *}
135.36 +
135.37 +lemma iterator1: "iterator $ UU $ f $ x = UU"
135.38 + apply (subst iterator_def2)
135.39 + apply simp
135.40 + done
135.41 +
135.42 +lemma iterator2: "iterator $ dzero $ f $ x = x"
135.43 + apply (subst iterator_def2)
135.44 + apply simp
135.45 + done
135.46 +
135.47 +lemma iterator3: "n ~= UU ==> iterator $ (dsucc $ n) $ f $ x = f $ (iterator $ n $ f $ x)"
135.48 + apply (rule trans)
135.49 + apply (subst iterator_def2)
135.50 + apply simp
135.51 + apply (rule refl)
135.52 + done
135.53 +
135.54 +lemmas iterator_rews = iterator1 iterator2 iterator3
135.55 +
135.56 +lemma dnat_flat: "ALL x y::dnat. x<<y --> x=UU | x=y"
135.57 + apply (rule allI)
135.58 + apply (induct_tac x)
135.59 + apply fast
135.60 + apply (rule allI)
135.61 + apply (case_tac y)
135.62 + apply simp
135.63 + apply simp
135.64 + apply simp
135.65 + apply (rule allI)
135.66 + apply (case_tac y)
135.67 + apply (fast intro!: UU_I)
135.68 + apply (thin_tac "ALL y. dnat << y --> dnat = UU | dnat = y")
135.69 + apply simp
135.70 + apply (simp (no_asm_simp))
135.71 + apply (drule_tac x="dnata" in spec)
135.72 + apply simp
135.73 + done
135.74 +
135.75 +end
136.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
136.2 +++ b/src/HOL/HOLCF/ex/Domain_Proofs.thy Sat Nov 27 16:08:10 2010 -0800
136.3 @@ -0,0 +1,501 @@
136.4 +(* Title: HOLCF/ex/Domain_Proofs.thy
136.5 + Author: Brian Huffman
136.6 +*)
136.7 +
136.8 +header {* Internal domain package proofs done manually *}
136.9 +
136.10 +theory Domain_Proofs
136.11 +imports HOLCF
136.12 +begin
136.13 +
136.14 +(*
136.15 +
136.16 +The definitions and proofs below are for the following recursive
136.17 +datatypes:
136.18 +
136.19 +domain 'a foo = Foo1 | Foo2 (lazy 'a) (lazy "'a bar")
136.20 + and 'a bar = Bar (lazy "'a baz \<rightarrow> tr")
136.21 + and 'a baz = Baz (lazy "'a foo convex_pd \<rightarrow> tr")
136.22 +
136.23 +TODO: add another type parameter that is strict,
136.24 +to show the different handling of LIFTDEFL vs. DEFL.
136.25 +
136.26 +*)
136.27 +
136.28 +(********************************************************************)
136.29 +
136.30 +subsection {* Step 1: Define the new type combinators *}
136.31 +
136.32 +text {* Start with the one-step non-recursive version *}
136.33 +
136.34 +definition
136.35 + foo_bar_baz_deflF ::
136.36 + "defl \<rightarrow> defl \<times> defl \<times> defl \<rightarrow> defl \<times> defl \<times> defl"
136.37 +where
136.38 + "foo_bar_baz_deflF = (\<Lambda> a. Abs_cfun (\<lambda>(t1, t2, t3).
136.39 + ( ssum_defl\<cdot>DEFL(one)\<cdot>(sprod_defl\<cdot>a\<cdot>(u_defl\<cdot>t2))
136.40 + , u_defl\<cdot>(sfun_defl\<cdot>(u_defl\<cdot>t3)\<cdot>DEFL(tr))
136.41 + , u_defl\<cdot>(sfun_defl\<cdot>(u_defl\<cdot>(convex_defl\<cdot>t1))\<cdot>DEFL(tr)))))"
136.42 +
136.43 +lemma foo_bar_baz_deflF_beta:
136.44 + "foo_bar_baz_deflF\<cdot>a\<cdot>t =
136.45 + ( ssum_defl\<cdot>DEFL(one)\<cdot>(sprod_defl\<cdot>a\<cdot>(u_defl\<cdot>(fst (snd t))))
136.46 + , u_defl\<cdot>(sfun_defl\<cdot>(u_defl\<cdot>(snd (snd t)))\<cdot>DEFL(tr))
136.47 + , u_defl\<cdot>(sfun_defl\<cdot>(u_defl\<cdot>(convex_defl\<cdot>(fst t)))\<cdot>DEFL(tr)))"
136.48 +unfolding foo_bar_baz_deflF_def
136.49 +by (simp add: split_def)
136.50 +
136.51 +text {* Individual type combinators are projected from the fixed point. *}
136.52 +
136.53 +definition foo_defl :: "defl \<rightarrow> defl"
136.54 +where "foo_defl = (\<Lambda> a. fst (fix\<cdot>(foo_bar_baz_deflF\<cdot>a)))"
136.55 +
136.56 +definition bar_defl :: "defl \<rightarrow> defl"
136.57 +where "bar_defl = (\<Lambda> a. fst (snd (fix\<cdot>(foo_bar_baz_deflF\<cdot>a))))"
136.58 +
136.59 +definition baz_defl :: "defl \<rightarrow> defl"
136.60 +where "baz_defl = (\<Lambda> a. snd (snd (fix\<cdot>(foo_bar_baz_deflF\<cdot>a))))"
136.61 +
136.62 +lemma defl_apply_thms:
136.63 + "foo_defl\<cdot>a = fst (fix\<cdot>(foo_bar_baz_deflF\<cdot>a))"
136.64 + "bar_defl\<cdot>a = fst (snd (fix\<cdot>(foo_bar_baz_deflF\<cdot>a)))"
136.65 + "baz_defl\<cdot>a = snd (snd (fix\<cdot>(foo_bar_baz_deflF\<cdot>a)))"
136.66 +unfolding foo_defl_def bar_defl_def baz_defl_def by simp_all
136.67 +
136.68 +text {* Unfold rules for each combinator. *}
136.69 +
136.70 +lemma foo_defl_unfold:
136.71 + "foo_defl\<cdot>a = ssum_defl\<cdot>DEFL(one)\<cdot>(sprod_defl\<cdot>a\<cdot>(u_defl\<cdot>(bar_defl\<cdot>a)))"
136.72 +unfolding defl_apply_thms by (subst fix_eq, simp add: foo_bar_baz_deflF_beta)
136.73 +
136.74 +lemma bar_defl_unfold: "bar_defl\<cdot>a = u_defl\<cdot>(sfun_defl\<cdot>(u_defl\<cdot>(baz_defl\<cdot>a))\<cdot>DEFL(tr))"
136.75 +unfolding defl_apply_thms by (subst fix_eq, simp add: foo_bar_baz_deflF_beta)
136.76 +
136.77 +lemma baz_defl_unfold: "baz_defl\<cdot>a = u_defl\<cdot>(sfun_defl\<cdot>(u_defl\<cdot>(convex_defl\<cdot>(foo_defl\<cdot>a)))\<cdot>DEFL(tr))"
136.78 +unfolding defl_apply_thms by (subst fix_eq, simp add: foo_bar_baz_deflF_beta)
136.79 +
136.80 +text "The automation for the previous steps will be quite similar to
136.81 +how the fixrec package works."
136.82 +
136.83 +(********************************************************************)
136.84 +
136.85 +subsection {* Step 2: Define types, prove class instances *}
136.86 +
136.87 +text {* Use @{text pcpodef} with the appropriate type combinator. *}
136.88 +
136.89 +pcpodef (open) 'a foo = "defl_set (foo_defl\<cdot>LIFTDEFL('a))"
136.90 +by (rule defl_set_bottom, rule adm_defl_set)
136.91 +
136.92 +pcpodef (open) 'a bar = "defl_set (bar_defl\<cdot>LIFTDEFL('a))"
136.93 +by (rule defl_set_bottom, rule adm_defl_set)
136.94 +
136.95 +pcpodef (open) 'a baz = "defl_set (baz_defl\<cdot>LIFTDEFL('a))"
136.96 +by (rule defl_set_bottom, rule adm_defl_set)
136.97 +
136.98 +text {* Prove rep instance using lemma @{text typedef_rep_class}. *}
136.99 +
136.100 +instantiation foo :: ("domain") liftdomain
136.101 +begin
136.102 +
136.103 +definition emb_foo :: "'a foo \<rightarrow> udom"
136.104 +where "emb_foo \<equiv> (\<Lambda> x. Rep_foo x)"
136.105 +
136.106 +definition prj_foo :: "udom \<rightarrow> 'a foo"
136.107 +where "prj_foo \<equiv> (\<Lambda> y. Abs_foo (cast\<cdot>(foo_defl\<cdot>LIFTDEFL('a))\<cdot>y))"
136.108 +
136.109 +definition defl_foo :: "'a foo itself \<Rightarrow> defl"
136.110 +where "defl_foo \<equiv> \<lambda>a. foo_defl\<cdot>LIFTDEFL('a)"
136.111 +
136.112 +definition
136.113 + "(liftemb :: 'a foo u \<rightarrow> udom) \<equiv> udom_emb u_approx oo u_map\<cdot>emb"
136.114 +
136.115 +definition
136.116 + "(liftprj :: udom \<rightarrow> 'a foo u) \<equiv> u_map\<cdot>prj oo udom_prj u_approx"
136.117 +
136.118 +definition
136.119 + "liftdefl \<equiv> \<lambda>(t::'a foo itself). u_defl\<cdot>DEFL('a foo)"
136.120 +
136.121 +instance
136.122 +apply (rule typedef_liftdomain_class)
136.123 +apply (rule type_definition_foo)
136.124 +apply (rule below_foo_def)
136.125 +apply (rule emb_foo_def)
136.126 +apply (rule prj_foo_def)
136.127 +apply (rule defl_foo_def)
136.128 +apply (rule liftemb_foo_def)
136.129 +apply (rule liftprj_foo_def)
136.130 +apply (rule liftdefl_foo_def)
136.131 +done
136.132 +
136.133 +end
136.134 +
136.135 +instantiation bar :: ("domain") liftdomain
136.136 +begin
136.137 +
136.138 +definition emb_bar :: "'a bar \<rightarrow> udom"
136.139 +where "emb_bar \<equiv> (\<Lambda> x. Rep_bar x)"
136.140 +
136.141 +definition prj_bar :: "udom \<rightarrow> 'a bar"
136.142 +where "prj_bar \<equiv> (\<Lambda> y. Abs_bar (cast\<cdot>(bar_defl\<cdot>LIFTDEFL('a))\<cdot>y))"
136.143 +
136.144 +definition defl_bar :: "'a bar itself \<Rightarrow> defl"
136.145 +where "defl_bar \<equiv> \<lambda>a. bar_defl\<cdot>LIFTDEFL('a)"
136.146 +
136.147 +definition
136.148 + "(liftemb :: 'a bar u \<rightarrow> udom) \<equiv> udom_emb u_approx oo u_map\<cdot>emb"
136.149 +
136.150 +definition
136.151 + "(liftprj :: udom \<rightarrow> 'a bar u) \<equiv> u_map\<cdot>prj oo udom_prj u_approx"
136.152 +
136.153 +definition
136.154 + "liftdefl \<equiv> \<lambda>(t::'a bar itself). u_defl\<cdot>DEFL('a bar)"
136.155 +
136.156 +instance
136.157 +apply (rule typedef_liftdomain_class)
136.158 +apply (rule type_definition_bar)
136.159 +apply (rule below_bar_def)
136.160 +apply (rule emb_bar_def)
136.161 +apply (rule prj_bar_def)
136.162 +apply (rule defl_bar_def)
136.163 +apply (rule liftemb_bar_def)
136.164 +apply (rule liftprj_bar_def)
136.165 +apply (rule liftdefl_bar_def)
136.166 +done
136.167 +
136.168 +end
136.169 +
136.170 +instantiation baz :: ("domain") liftdomain
136.171 +begin
136.172 +
136.173 +definition emb_baz :: "'a baz \<rightarrow> udom"
136.174 +where "emb_baz \<equiv> (\<Lambda> x. Rep_baz x)"
136.175 +
136.176 +definition prj_baz :: "udom \<rightarrow> 'a baz"
136.177 +where "prj_baz \<equiv> (\<Lambda> y. Abs_baz (cast\<cdot>(baz_defl\<cdot>LIFTDEFL('a))\<cdot>y))"
136.178 +
136.179 +definition defl_baz :: "'a baz itself \<Rightarrow> defl"
136.180 +where "defl_baz \<equiv> \<lambda>a. baz_defl\<cdot>LIFTDEFL('a)"
136.181 +
136.182 +definition
136.183 + "(liftemb :: 'a baz u \<rightarrow> udom) \<equiv> udom_emb u_approx oo u_map\<cdot>emb"
136.184 +
136.185 +definition
136.186 + "(liftprj :: udom \<rightarrow> 'a baz u) \<equiv> u_map\<cdot>prj oo udom_prj u_approx"
136.187 +
136.188 +definition
136.189 + "liftdefl \<equiv> \<lambda>(t::'a baz itself). u_defl\<cdot>DEFL('a baz)"
136.190 +
136.191 +instance
136.192 +apply (rule typedef_liftdomain_class)
136.193 +apply (rule type_definition_baz)
136.194 +apply (rule below_baz_def)
136.195 +apply (rule emb_baz_def)
136.196 +apply (rule prj_baz_def)
136.197 +apply (rule defl_baz_def)
136.198 +apply (rule liftemb_baz_def)
136.199 +apply (rule liftprj_baz_def)
136.200 +apply (rule liftdefl_baz_def)
136.201 +done
136.202 +
136.203 +end
136.204 +
136.205 +text {* Prove DEFL rules using lemma @{text typedef_DEFL}. *}
136.206 +
136.207 +lemma DEFL_foo: "DEFL('a foo) = foo_defl\<cdot>LIFTDEFL('a)"
136.208 +apply (rule typedef_DEFL)
136.209 +apply (rule defl_foo_def)
136.210 +done
136.211 +
136.212 +lemma DEFL_bar: "DEFL('a bar) = bar_defl\<cdot>LIFTDEFL('a)"
136.213 +apply (rule typedef_DEFL)
136.214 +apply (rule defl_bar_def)
136.215 +done
136.216 +
136.217 +lemma DEFL_baz: "DEFL('a baz) = baz_defl\<cdot>LIFTDEFL('a)"
136.218 +apply (rule typedef_DEFL)
136.219 +apply (rule defl_baz_def)
136.220 +done
136.221 +
136.222 +text {* Prove DEFL equations using type combinator unfold lemmas. *}
136.223 +
136.224 +lemma DEFL_foo': "DEFL('a foo) = DEFL(one \<oplus> 'a\<^sub>\<bottom> \<otimes> ('a bar)\<^sub>\<bottom>)"
136.225 +unfolding DEFL_foo DEFL_bar DEFL_baz domain_defl_simps
136.226 +by (rule foo_defl_unfold)
136.227 +
136.228 +lemma DEFL_bar': "DEFL('a bar) = DEFL(('a baz \<rightarrow> tr)\<^sub>\<bottom>)"
136.229 +unfolding DEFL_foo DEFL_bar DEFL_baz domain_defl_simps
136.230 +by (rule bar_defl_unfold)
136.231 +
136.232 +lemma DEFL_baz': "DEFL('a baz) = DEFL(('a foo convex_pd \<rightarrow> tr)\<^sub>\<bottom>)"
136.233 +unfolding DEFL_foo DEFL_bar DEFL_baz domain_defl_simps
136.234 +by (rule baz_defl_unfold)
136.235 +
136.236 +(********************************************************************)
136.237 +
136.238 +subsection {* Step 3: Define rep and abs functions *}
136.239 +
136.240 +text {* Define them all using @{text prj} and @{text emb}! *}
136.241 +
136.242 +definition foo_rep :: "'a foo \<rightarrow> one \<oplus> ('a\<^sub>\<bottom> \<otimes> ('a bar)\<^sub>\<bottom>)"
136.243 +where "foo_rep \<equiv> prj oo emb"
136.244 +
136.245 +definition foo_abs :: "one \<oplus> ('a\<^sub>\<bottom> \<otimes> ('a bar)\<^sub>\<bottom>) \<rightarrow> 'a foo"
136.246 +where "foo_abs \<equiv> prj oo emb"
136.247 +
136.248 +definition bar_rep :: "'a bar \<rightarrow> ('a baz \<rightarrow> tr)\<^sub>\<bottom>"
136.249 +where "bar_rep \<equiv> prj oo emb"
136.250 +
136.251 +definition bar_abs :: "('a baz \<rightarrow> tr)\<^sub>\<bottom> \<rightarrow> 'a bar"
136.252 +where "bar_abs \<equiv> prj oo emb"
136.253 +
136.254 +definition baz_rep :: "'a baz \<rightarrow> ('a foo convex_pd \<rightarrow> tr)\<^sub>\<bottom>"
136.255 +where "baz_rep \<equiv> prj oo emb"
136.256 +
136.257 +definition baz_abs :: "('a foo convex_pd \<rightarrow> tr)\<^sub>\<bottom> \<rightarrow> 'a baz"
136.258 +where "baz_abs \<equiv> prj oo emb"
136.259 +
136.260 +text {* Prove isomorphism rules. *}
136.261 +
136.262 +lemma foo_abs_iso: "foo_rep\<cdot>(foo_abs\<cdot>x) = x"
136.263 +by (rule domain_abs_iso [OF DEFL_foo' foo_abs_def foo_rep_def])
136.264 +
136.265 +lemma foo_rep_iso: "foo_abs\<cdot>(foo_rep\<cdot>x) = x"
136.266 +by (rule domain_rep_iso [OF DEFL_foo' foo_abs_def foo_rep_def])
136.267 +
136.268 +lemma bar_abs_iso: "bar_rep\<cdot>(bar_abs\<cdot>x) = x"
136.269 +by (rule domain_abs_iso [OF DEFL_bar' bar_abs_def bar_rep_def])
136.270 +
136.271 +lemma bar_rep_iso: "bar_abs\<cdot>(bar_rep\<cdot>x) = x"
136.272 +by (rule domain_rep_iso [OF DEFL_bar' bar_abs_def bar_rep_def])
136.273 +
136.274 +lemma baz_abs_iso: "baz_rep\<cdot>(baz_abs\<cdot>x) = x"
136.275 +by (rule domain_abs_iso [OF DEFL_baz' baz_abs_def baz_rep_def])
136.276 +
136.277 +lemma baz_rep_iso: "baz_abs\<cdot>(baz_rep\<cdot>x) = x"
136.278 +by (rule domain_rep_iso [OF DEFL_baz' baz_abs_def baz_rep_def])
136.279 +
136.280 +text {* Prove isodefl rules using @{text isodefl_coerce}. *}
136.281 +
136.282 +lemma isodefl_foo_abs:
136.283 + "isodefl d t \<Longrightarrow> isodefl (foo_abs oo d oo foo_rep) t"
136.284 +by (rule isodefl_abs_rep [OF DEFL_foo' foo_abs_def foo_rep_def])
136.285 +
136.286 +lemma isodefl_bar_abs:
136.287 + "isodefl d t \<Longrightarrow> isodefl (bar_abs oo d oo bar_rep) t"
136.288 +by (rule isodefl_abs_rep [OF DEFL_bar' bar_abs_def bar_rep_def])
136.289 +
136.290 +lemma isodefl_baz_abs:
136.291 + "isodefl d t \<Longrightarrow> isodefl (baz_abs oo d oo baz_rep) t"
136.292 +by (rule isodefl_abs_rep [OF DEFL_baz' baz_abs_def baz_rep_def])
136.293 +
136.294 +(********************************************************************)
136.295 +
136.296 +subsection {* Step 4: Define map functions, prove isodefl property *}
136.297 +
136.298 +text {* Start with the one-step non-recursive version. *}
136.299 +
136.300 +text {* Note that the type of the map function depends on which
136.301 +variables are used in positive and negative positions. *}
136.302 +
136.303 +definition
136.304 + foo_bar_baz_mapF ::
136.305 + "('a \<rightarrow> 'b) \<rightarrow>
136.306 + ('a foo \<rightarrow> 'b foo) \<times> ('a bar \<rightarrow> 'b bar) \<times> ('b baz \<rightarrow> 'a baz) \<rightarrow>
136.307 + ('a foo \<rightarrow> 'b foo) \<times> ('a bar \<rightarrow> 'b bar) \<times> ('b baz \<rightarrow> 'a baz)"
136.308 +where
136.309 + "foo_bar_baz_mapF = (\<Lambda> f. Abs_cfun (\<lambda>(d1, d2, d3).
136.310 + (
136.311 + foo_abs oo
136.312 + ssum_map\<cdot>ID\<cdot>(sprod_map\<cdot>(u_map\<cdot>f)\<cdot>(u_map\<cdot>d2))
136.313 + oo foo_rep
136.314 + ,
136.315 + bar_abs oo u_map\<cdot>(cfun_map\<cdot>d3\<cdot>ID) oo bar_rep
136.316 + ,
136.317 + baz_abs oo u_map\<cdot>(cfun_map\<cdot>(convex_map\<cdot>d1)\<cdot>ID) oo baz_rep
136.318 + )))"
136.319 +
136.320 +lemma foo_bar_baz_mapF_beta:
136.321 + "foo_bar_baz_mapF\<cdot>f\<cdot>d =
136.322 + (
136.323 + foo_abs oo
136.324 + ssum_map\<cdot>ID\<cdot>(sprod_map\<cdot>(u_map\<cdot>f)\<cdot>(u_map\<cdot>(fst (snd d))))
136.325 + oo foo_rep
136.326 + ,
136.327 + bar_abs oo u_map\<cdot>(cfun_map\<cdot>(snd (snd d))\<cdot>ID) oo bar_rep
136.328 + ,
136.329 + baz_abs oo u_map\<cdot>(cfun_map\<cdot>(convex_map\<cdot>(fst d))\<cdot>ID) oo baz_rep
136.330 + )"
136.331 +unfolding foo_bar_baz_mapF_def
136.332 +by (simp add: split_def)
136.333 +
136.334 +text {* Individual map functions are projected from the fixed point. *}
136.335 +
136.336 +definition foo_map :: "('a \<rightarrow> 'b) \<rightarrow> ('a foo \<rightarrow> 'b foo)"
136.337 +where "foo_map = (\<Lambda> f. fst (fix\<cdot>(foo_bar_baz_mapF\<cdot>f)))"
136.338 +
136.339 +definition bar_map :: "('a \<rightarrow> 'b) \<rightarrow> ('a bar \<rightarrow> 'b bar)"
136.340 +where "bar_map = (\<Lambda> f. fst (snd (fix\<cdot>(foo_bar_baz_mapF\<cdot>f))))"
136.341 +
136.342 +definition baz_map :: "('a \<rightarrow> 'b) \<rightarrow> ('b baz \<rightarrow> 'a baz)"
136.343 +where "baz_map = (\<Lambda> f. snd (snd (fix\<cdot>(foo_bar_baz_mapF\<cdot>f))))"
136.344 +
136.345 +lemma map_apply_thms:
136.346 + "foo_map\<cdot>f = fst (fix\<cdot>(foo_bar_baz_mapF\<cdot>f))"
136.347 + "bar_map\<cdot>f = fst (snd (fix\<cdot>(foo_bar_baz_mapF\<cdot>f)))"
136.348 + "baz_map\<cdot>f = snd (snd (fix\<cdot>(foo_bar_baz_mapF\<cdot>f)))"
136.349 +unfolding foo_map_def bar_map_def baz_map_def by simp_all
136.350 +
136.351 +text {* Prove isodefl rules for all map functions simultaneously. *}
136.352 +
136.353 +lemma isodefl_foo_bar_baz:
136.354 + assumes isodefl_d: "isodefl (u_map\<cdot>d) t"
136.355 + shows
136.356 + "isodefl (foo_map\<cdot>d) (foo_defl\<cdot>t) \<and>
136.357 + isodefl (bar_map\<cdot>d) (bar_defl\<cdot>t) \<and>
136.358 + isodefl (baz_map\<cdot>d) (baz_defl\<cdot>t)"
136.359 +unfolding map_apply_thms defl_apply_thms
136.360 + apply (rule parallel_fix_ind)
136.361 + apply (intro adm_conj adm_isodefl cont2cont_fst cont2cont_snd cont_id)
136.362 + apply (simp only: fst_strict snd_strict isodefl_bottom simp_thms)
136.363 + apply (simp only: foo_bar_baz_mapF_beta
136.364 + foo_bar_baz_deflF_beta
136.365 + fst_conv snd_conv)
136.366 + apply (elim conjE)
136.367 + apply (intro
136.368 + conjI
136.369 + isodefl_foo_abs
136.370 + isodefl_bar_abs
136.371 + isodefl_baz_abs
136.372 + domain_isodefl
136.373 + isodefl_ID_DEFL isodefl_LIFTDEFL
136.374 + isodefl_d
136.375 + )
136.376 + apply assumption+
136.377 +done
136.378 +
136.379 +lemmas isodefl_foo = isodefl_foo_bar_baz [THEN conjunct1]
136.380 +lemmas isodefl_bar = isodefl_foo_bar_baz [THEN conjunct2, THEN conjunct1]
136.381 +lemmas isodefl_baz = isodefl_foo_bar_baz [THEN conjunct2, THEN conjunct2]
136.382 +
136.383 +text {* Prove map ID lemmas, using isodefl_DEFL_imp_ID *}
136.384 +
136.385 +lemma foo_map_ID: "foo_map\<cdot>ID = ID"
136.386 +apply (rule isodefl_DEFL_imp_ID)
136.387 +apply (subst DEFL_foo)
136.388 +apply (rule isodefl_foo)
136.389 +apply (rule isodefl_LIFTDEFL)
136.390 +done
136.391 +
136.392 +lemma bar_map_ID: "bar_map\<cdot>ID = ID"
136.393 +apply (rule isodefl_DEFL_imp_ID)
136.394 +apply (subst DEFL_bar)
136.395 +apply (rule isodefl_bar)
136.396 +apply (rule isodefl_LIFTDEFL)
136.397 +done
136.398 +
136.399 +lemma baz_map_ID: "baz_map\<cdot>ID = ID"
136.400 +apply (rule isodefl_DEFL_imp_ID)
136.401 +apply (subst DEFL_baz)
136.402 +apply (rule isodefl_baz)
136.403 +apply (rule isodefl_LIFTDEFL)
136.404 +done
136.405 +
136.406 +(********************************************************************)
136.407 +
136.408 +subsection {* Step 5: Define take functions, prove lub-take lemmas *}
136.409 +
136.410 +definition
136.411 + foo_bar_baz_takeF ::
136.412 + "('a foo \<rightarrow> 'a foo) \<times> ('a bar \<rightarrow> 'a bar) \<times> ('a baz \<rightarrow> 'a baz) \<rightarrow>
136.413 + ('a foo \<rightarrow> 'a foo) \<times> ('a bar \<rightarrow> 'a bar) \<times> ('a baz \<rightarrow> 'a baz)"
136.414 +where
136.415 + "foo_bar_baz_takeF = (\<Lambda> p.
136.416 + ( foo_abs oo
136.417 + ssum_map\<cdot>ID\<cdot>(sprod_map\<cdot>(u_map\<cdot>ID)\<cdot>(u_map\<cdot>(fst (snd p))))
136.418 + oo foo_rep
136.419 + , bar_abs oo
136.420 + u_map\<cdot>(cfun_map\<cdot>(snd (snd p))\<cdot>ID) oo bar_rep
136.421 + , baz_abs oo
136.422 + u_map\<cdot>(cfun_map\<cdot>(convex_map\<cdot>(fst p))\<cdot>ID) oo baz_rep
136.423 + ))"
136.424 +
136.425 +lemma foo_bar_baz_takeF_beta:
136.426 + "foo_bar_baz_takeF\<cdot>p =
136.427 + ( foo_abs oo
136.428 + ssum_map\<cdot>ID\<cdot>(sprod_map\<cdot>(u_map\<cdot>ID)\<cdot>(u_map\<cdot>(fst (snd p))))
136.429 + oo foo_rep
136.430 + , bar_abs oo
136.431 + u_map\<cdot>(cfun_map\<cdot>(snd (snd p))\<cdot>ID) oo bar_rep
136.432 + , baz_abs oo
136.433 + u_map\<cdot>(cfun_map\<cdot>(convex_map\<cdot>(fst p))\<cdot>ID) oo baz_rep
136.434 + )"
136.435 +unfolding foo_bar_baz_takeF_def by (rule beta_cfun, simp)
136.436 +
136.437 +definition
136.438 + foo_take :: "nat \<Rightarrow> 'a foo \<rightarrow> 'a foo"
136.439 +where
136.440 + "foo_take = (\<lambda>n. fst (iterate n\<cdot>foo_bar_baz_takeF\<cdot>\<bottom>))"
136.441 +
136.442 +definition
136.443 + bar_take :: "nat \<Rightarrow> 'a bar \<rightarrow> 'a bar"
136.444 +where
136.445 + "bar_take = (\<lambda>n. fst (snd (iterate n\<cdot>foo_bar_baz_takeF\<cdot>\<bottom>)))"
136.446 +
136.447 +definition
136.448 + baz_take :: "nat \<Rightarrow> 'a baz \<rightarrow> 'a baz"
136.449 +where
136.450 + "baz_take = (\<lambda>n. snd (snd (iterate n\<cdot>foo_bar_baz_takeF\<cdot>\<bottom>)))"
136.451 +
136.452 +lemma chain_take_thms: "chain foo_take" "chain bar_take" "chain baz_take"
136.453 +unfolding foo_take_def bar_take_def baz_take_def
136.454 +by (intro ch2ch_fst ch2ch_snd chain_iterate)+
136.455 +
136.456 +lemma take_0_thms: "foo_take 0 = \<bottom>" "bar_take 0 = \<bottom>" "baz_take 0 = \<bottom>"
136.457 +unfolding foo_take_def bar_take_def baz_take_def
136.458 +by (simp only: iterate_0 fst_strict snd_strict)+
136.459 +
136.460 +lemma take_Suc_thms:
136.461 + "foo_take (Suc n) =
136.462 + foo_abs oo ssum_map\<cdot>ID\<cdot>(sprod_map\<cdot>(u_map\<cdot>ID)\<cdot>(u_map\<cdot>(bar_take n))) oo foo_rep"
136.463 + "bar_take (Suc n) =
136.464 + bar_abs oo u_map\<cdot>(cfun_map\<cdot>(baz_take n)\<cdot>ID) oo bar_rep"
136.465 + "baz_take (Suc n) =
136.466 + baz_abs oo u_map\<cdot>(cfun_map\<cdot>(convex_map\<cdot>(foo_take n))\<cdot>ID) oo baz_rep"
136.467 +unfolding foo_take_def bar_take_def baz_take_def
136.468 +by (simp only: iterate_Suc foo_bar_baz_takeF_beta fst_conv snd_conv)+
136.469 +
136.470 +lemma lub_take_lemma:
136.471 + "(\<Squnion>n. foo_take n, \<Squnion>n. bar_take n, \<Squnion>n. baz_take n)
136.472 + = (foo_map\<cdot>(ID::'a \<rightarrow> 'a), bar_map\<cdot>(ID::'a \<rightarrow> 'a), baz_map\<cdot>(ID::'a \<rightarrow> 'a))"
136.473 +apply (simp only: lub_Pair [symmetric] ch2ch_Pair chain_take_thms)
136.474 +apply (simp only: map_apply_thms pair_collapse)
136.475 +apply (simp only: fix_def2)
136.476 +apply (rule lub_eq)
136.477 +apply (rule nat.induct)
136.478 +apply (simp only: iterate_0 Pair_strict take_0_thms)
136.479 +apply (simp only: iterate_Suc Pair_fst_snd_eq fst_conv snd_conv
136.480 + foo_bar_baz_mapF_beta take_Suc_thms simp_thms)
136.481 +done
136.482 +
136.483 +lemma lub_foo_take: "(\<Squnion>n. foo_take n) = ID"
136.484 +apply (rule trans [OF _ foo_map_ID])
136.485 +using lub_take_lemma
136.486 +apply (elim Pair_inject)
136.487 +apply assumption
136.488 +done
136.489 +
136.490 +lemma lub_bar_take: "(\<Squnion>n. bar_take n) = ID"
136.491 +apply (rule trans [OF _ bar_map_ID])
136.492 +using lub_take_lemma
136.493 +apply (elim Pair_inject)
136.494 +apply assumption
136.495 +done
136.496 +
136.497 +lemma lub_baz_take: "(\<Squnion>n. baz_take n) = ID"
136.498 +apply (rule trans [OF _ baz_map_ID])
136.499 +using lub_take_lemma
136.500 +apply (elim Pair_inject)
136.501 +apply assumption
136.502 +done
136.503 +
136.504 +end
137.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
137.2 +++ b/src/HOL/HOLCF/ex/Fix2.thy Sat Nov 27 16:08:10 2010 -0800
137.3 @@ -0,0 +1,32 @@
137.4 +(* Title: HOLCF/ex/Fix2.thy
137.5 + Author: Franz Regensburger
137.6 +
137.7 +Show that fix is the unique least fixed-point operator.
137.8 +From axioms gix1_def,gix2_def it follows that fix = gix
137.9 +*)
137.10 +
137.11 +theory Fix2
137.12 +imports HOLCF
137.13 +begin
137.14 +
137.15 +axiomatization
137.16 + gix :: "('a->'a)->'a" where
137.17 + gix1_def: "F$(gix$F) = gix$F" and
137.18 + gix2_def: "F$y=y ==> gix$F << y"
137.19 +
137.20 +
137.21 +lemma lemma1: "fix = gix"
137.22 +apply (rule cfun_eqI)
137.23 +apply (rule below_antisym)
137.24 +apply (rule fix_least)
137.25 +apply (rule gix1_def)
137.26 +apply (rule gix2_def)
137.27 +apply (rule fix_eq [symmetric])
137.28 +done
137.29 +
137.30 +lemma lemma2: "gix$F=lub(range(%i. iterate i$F$UU))"
137.31 +apply (rule lemma1 [THEN subst])
137.32 +apply (rule fix_def2)
137.33 +done
137.34 +
137.35 +end
138.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
138.2 +++ b/src/HOL/HOLCF/ex/Focus_ex.thy Sat Nov 27 16:08:10 2010 -0800
138.3 @@ -0,0 +1,258 @@
138.4 +(* Specification of the following loop back device
138.5 +
138.6 +
138.7 + g
138.8 + --------------------
138.9 + | ------- |
138.10 + x | | | | y
138.11 + ------|---->| |------| ----->
138.12 + | z | f | z |
138.13 + | -->| |--- |
138.14 + | | | | | |
138.15 + | | ------- | |
138.16 + | | | |
138.17 + | <-------------- |
138.18 + | |
138.19 + --------------------
138.20 +
138.21 +
138.22 +First step: Notation in Agent Network Description Language (ANDL)
138.23 +-----------------------------------------------------------------
138.24 +
138.25 +agent f
138.26 + input channel i1:'b i2: ('b,'c) tc
138.27 + output channel o1:'c o2: ('b,'c) tc
138.28 +is
138.29 + Rf(i1,i2,o1,o2) (left open in the example)
138.30 +end f
138.31 +
138.32 +agent g
138.33 + input channel x:'b
138.34 + output channel y:'c
138.35 +is network
138.36 + (y,z) = f$(x,z)
138.37 +end network
138.38 +end g
138.39 +
138.40 +
138.41 +Remark: the type of the feedback depends at most on the types of the input and
138.42 + output of g. (No type miracles inside g)
138.43 +
138.44 +Second step: Translation of ANDL specification to HOLCF Specification
138.45 +---------------------------------------------------------------------
138.46 +
138.47 +Specification of agent f ist translated to predicate is_f
138.48 +
138.49 +is_f :: ('b stream * ('b,'c) tc stream ->
138.50 + 'c stream * ('b,'c) tc stream) => bool
138.51 +
138.52 +is_f f = !i1 i2 o1 o2.
138.53 + f$(i1,i2) = (o1,o2) --> Rf(i1,i2,o1,o2)
138.54 +
138.55 +Specification of agent g is translated to predicate is_g which uses
138.56 +predicate is_net_g
138.57 +
138.58 +is_net_g :: ('b stream * ('b,'c) tc stream -> 'c stream * ('b,'c) tc stream) =>
138.59 + 'b stream => 'c stream => bool
138.60 +
138.61 +is_net_g f x y =
138.62 + ? z. (y,z) = f$(x,z) &
138.63 + !oy hz. (oy,hz) = f$(x,hz) --> z << hz
138.64 +
138.65 +
138.66 +is_g :: ('b stream -> 'c stream) => bool
138.67 +
138.68 +is_g g = ? f. is_f f & (!x y. g$x = y --> is_net_g f x y
138.69 +
138.70 +Third step: (show conservativity)
138.71 +-----------
138.72 +
138.73 +Suppose we have a model for the theory TH1 which contains the axiom
138.74 +
138.75 + ? f. is_f f
138.76 +
138.77 +In this case there is also a model for the theory TH2 that enriches TH1 by
138.78 +axiom
138.79 +
138.80 + ? g. is_g g
138.81 +
138.82 +The result is proved by showing that there is a definitional extension
138.83 +that extends TH1 by a definition of g.
138.84 +
138.85 +
138.86 +We define:
138.87 +
138.88 +def_g g =
138.89 + (? f. is_f f &
138.90 + g = (LAM x. fst (f$(x,fix$(LAM k. snd (f$(x,k)))))) )
138.91 +
138.92 +Now we prove:
138.93 +
138.94 + (? f. is_f f ) --> (? g. is_g g)
138.95 +
138.96 +using the theorems
138.97 +
138.98 +loopback_eq) def_g = is_g (real work)
138.99 +
138.100 +L1) (? f. is_f f ) --> (? g. def_g g) (trivial)
138.101 +
138.102 +*)
138.103 +
138.104 +theory Focus_ex
138.105 +imports Stream
138.106 +begin
138.107 +
138.108 +typedecl ('a, 'b) tc
138.109 +arities tc:: (pcpo, pcpo) pcpo
138.110 +
138.111 +axiomatization
138.112 + Rf :: "('b stream * ('b,'c) tc stream * 'c stream * ('b,'c) tc stream) => bool"
138.113 +
138.114 +definition
138.115 + is_f :: "('b stream * ('b,'c) tc stream -> 'c stream * ('b,'c) tc stream) => bool" where
138.116 + "is_f f = (!i1 i2 o1 o2. f$(i1,i2) = (o1,o2) --> Rf(i1,i2,o1,o2))"
138.117 +
138.118 +definition
138.119 + is_net_g :: "('b stream *('b,'c) tc stream -> 'c stream * ('b,'c) tc stream) =>
138.120 + 'b stream => 'c stream => bool" where
138.121 + "is_net_g f x y == (? z.
138.122 + (y,z) = f$(x,z) &
138.123 + (!oy hz. (oy,hz) = f$(x,hz) --> z << hz))"
138.124 +
138.125 +definition
138.126 + is_g :: "('b stream -> 'c stream) => bool" where
138.127 + "is_g g == (? f. is_f f & (!x y. g$x = y --> is_net_g f x y))"
138.128 +
138.129 +definition
138.130 + def_g :: "('b stream -> 'c stream) => bool" where
138.131 + "def_g g == (? f. is_f f & g = (LAM x. fst (f$(x,fix$(LAM k. snd (f$(x,k)))))))"
138.132 +
138.133 +
138.134 +(* first some logical trading *)
138.135 +
138.136 +lemma lemma1:
138.137 +"is_g(g) =
138.138 + (? f. is_f(f) & (!x.(? z. (g$x,z) = f$(x,z) &
138.139 + (! w y. (y,w) = f$(x,w) --> z << w))))"
138.140 +apply (simp add: is_g_def is_net_g_def)
138.141 +apply fast
138.142 +done
138.143 +
138.144 +lemma lemma2:
138.145 +"(? f. is_f(f) & (!x. (? z. (g$x,z) = f$(x,z) &
138.146 + (!w y. (y,w) = f$(x,w) --> z << w))))
138.147 + =
138.148 + (? f. is_f(f) & (!x. ? z.
138.149 + g$x = fst (f$(x,z)) &
138.150 + z = snd (f$(x,z)) &
138.151 + (! w y. (y,w) = f$(x,w) --> z << w)))"
138.152 +apply (rule iffI)
138.153 +apply (erule exE)
138.154 +apply (rule_tac x = "f" in exI)
138.155 +apply (erule conjE)+
138.156 +apply (erule conjI)
138.157 +apply (intro strip)
138.158 +apply (erule allE)
138.159 +apply (erule exE)
138.160 +apply (rule_tac x = "z" in exI)
138.161 +apply (erule conjE)+
138.162 +apply (rule conjI)
138.163 +apply (rule_tac [2] conjI)
138.164 +prefer 3 apply (assumption)
138.165 +apply (drule sym)
138.166 +apply (simp)
138.167 +apply (drule sym)
138.168 +apply (simp)
138.169 +apply (erule exE)
138.170 +apply (rule_tac x = "f" in exI)
138.171 +apply (erule conjE)+
138.172 +apply (erule conjI)
138.173 +apply (intro strip)
138.174 +apply (erule allE)
138.175 +apply (erule exE)
138.176 +apply (rule_tac x = "z" in exI)
138.177 +apply (erule conjE)+
138.178 +apply (rule conjI)
138.179 +prefer 2 apply (assumption)
138.180 +apply (rule prod_eqI)
138.181 +apply simp
138.182 +apply simp
138.183 +done
138.184 +
138.185 +lemma lemma3: "def_g(g) --> is_g(g)"
138.186 +apply (tactic {* simp_tac (HOL_ss addsimps [@{thm def_g_def}, @{thm lemma1}, @{thm lemma2}]) 1 *})
138.187 +apply (rule impI)
138.188 +apply (erule exE)
138.189 +apply (rule_tac x = "f" in exI)
138.190 +apply (erule conjE)+
138.191 +apply (erule conjI)
138.192 +apply (intro strip)
138.193 +apply (rule_tac x = "fix$ (LAM k. snd (f$(x,k)))" in exI)
138.194 +apply (rule conjI)
138.195 + apply (simp)
138.196 + apply (rule prod_eqI, simp, simp)
138.197 + apply (rule trans)
138.198 + apply (rule fix_eq)
138.199 + apply (simp (no_asm))
138.200 +apply (intro strip)
138.201 +apply (rule fix_least)
138.202 +apply (simp (no_asm))
138.203 +apply (erule exE)
138.204 +apply (drule sym)
138.205 +back
138.206 +apply simp
138.207 +done
138.208 +
138.209 +lemma lemma4: "is_g(g) --> def_g(g)"
138.210 +apply (tactic {* simp_tac (HOL_ss delsimps (@{thms HOL.ex_simps} @ @{thms HOL.all_simps})
138.211 + addsimps [@{thm lemma1}, @{thm lemma2}, @{thm def_g_def}]) 1 *})
138.212 +apply (rule impI)
138.213 +apply (erule exE)
138.214 +apply (rule_tac x = "f" in exI)
138.215 +apply (erule conjE)+
138.216 +apply (erule conjI)
138.217 +apply (rule cfun_eqI)
138.218 +apply (erule_tac x = "x" in allE)
138.219 +apply (erule exE)
138.220 +apply (erule conjE)+
138.221 +apply (subgoal_tac "fix$ (LAM k. snd (f$(x, k))) = z")
138.222 + apply simp
138.223 +apply (subgoal_tac "! w y. f$(x, w) = (y, w) --> z << w")
138.224 +apply (rule fix_eqI)
138.225 +apply simp
138.226 +apply (subgoal_tac "f$(x, za) = (fst (f$(x,za)) ,za)")
138.227 +apply fast
138.228 +apply (rule prod_eqI, simp, simp)
138.229 +apply (intro strip)
138.230 +apply (erule allE)+
138.231 +apply (erule mp)
138.232 +apply (erule sym)
138.233 +done
138.234 +
138.235 +(* now we assemble the result *)
138.236 +
138.237 +lemma loopback_eq: "def_g = is_g"
138.238 +apply (rule ext)
138.239 +apply (rule iffI)
138.240 +apply (erule lemma3 [THEN mp])
138.241 +apply (erule lemma4 [THEN mp])
138.242 +done
138.243 +
138.244 +lemma L2:
138.245 +"(? f.
138.246 + is_f(f::'b stream * ('b,'c) tc stream -> 'c stream * ('b,'c) tc stream))
138.247 + -->
138.248 + (? g. def_g(g::'b stream -> 'c stream ))"
138.249 +apply (simp add: def_g_def)
138.250 +done
138.251 +
138.252 +theorem conservative_loopback:
138.253 +"(? f.
138.254 + is_f(f::'b stream * ('b,'c) tc stream -> 'c stream * ('b,'c) tc stream))
138.255 + -->
138.256 + (? g. is_g(g::'b stream -> 'c stream ))"
138.257 +apply (rule loopback_eq [THEN subst])
138.258 +apply (rule L2)
138.259 +done
138.260 +
138.261 +end
139.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
139.2 +++ b/src/HOL/HOLCF/ex/Hoare.thy Sat Nov 27 16:08:10 2010 -0800
139.3 @@ -0,0 +1,425 @@
139.4 +(* Title: HOLCF/ex/hoare.thy
139.5 + Author: Franz Regensburger
139.6 +
139.7 +Theory for an example by C.A.R. Hoare
139.8 +
139.9 +p x = if b1 x
139.10 + then p (g x)
139.11 + else x fi
139.12 +
139.13 +q x = if b1 x orelse b2 x
139.14 + then q (g x)
139.15 + else x fi
139.16 +
139.17 +Prove: for all b1 b2 g .
139.18 + q o p = q
139.19 +
139.20 +In order to get a nice notation we fix the functions b1,b2 and g in the
139.21 +signature of this example
139.22 +
139.23 +*)
139.24 +
139.25 +theory Hoare
139.26 +imports HOLCF
139.27 +begin
139.28 +
139.29 +axiomatization
139.30 + b1 :: "'a -> tr" and
139.31 + b2 :: "'a -> tr" and
139.32 + g :: "'a -> 'a"
139.33 +
139.34 +definition
139.35 + p :: "'a -> 'a" where
139.36 + "p = fix$(LAM f. LAM x. If b1$x then f$(g$x) else x)"
139.37 +
139.38 +definition
139.39 + q :: "'a -> 'a" where
139.40 + "q = fix$(LAM f. LAM x. If b1$x orelse b2$x then f$(g$x) else x)"
139.41 +
139.42 +
139.43 +(* --------- pure HOLCF logic, some little lemmas ------ *)
139.44 +
139.45 +lemma hoare_lemma2: "b~=TT ==> b=FF | b=UU"
139.46 +apply (rule Exh_tr [THEN disjE])
139.47 +apply blast+
139.48 +done
139.49 +
139.50 +lemma hoare_lemma3: " (ALL k. b1$(iterate k$g$x) = TT) | (EX k. b1$(iterate k$g$x)~=TT)"
139.51 +apply blast
139.52 +done
139.53 +
139.54 +lemma hoare_lemma4: "(EX k. b1$(iterate k$g$x) ~= TT) ==>
139.55 + EX k. b1$(iterate k$g$x) = FF | b1$(iterate k$g$x) = UU"
139.56 +apply (erule exE)
139.57 +apply (rule exI)
139.58 +apply (rule hoare_lemma2)
139.59 +apply assumption
139.60 +done
139.61 +
139.62 +lemma hoare_lemma5: "[|(EX k. b1$(iterate k$g$x) ~= TT);
139.63 + k=Least(%n. b1$(iterate n$g$x) ~= TT)|] ==>
139.64 + b1$(iterate k$g$x)=FF | b1$(iterate k$g$x)=UU"
139.65 +apply hypsubst
139.66 +apply (rule hoare_lemma2)
139.67 +apply (erule exE)
139.68 +apply (erule LeastI)
139.69 +done
139.70 +
139.71 +lemma hoare_lemma6: "b=UU ==> b~=TT"
139.72 +apply hypsubst
139.73 +apply (rule dist_eq_tr)
139.74 +done
139.75 +
139.76 +lemma hoare_lemma7: "b=FF ==> b~=TT"
139.77 +apply hypsubst
139.78 +apply (rule dist_eq_tr)
139.79 +done
139.80 +
139.81 +lemma hoare_lemma8: "[|(EX k. b1$(iterate k$g$x) ~= TT);
139.82 + k=Least(%n. b1$(iterate n$g$x) ~= TT)|] ==>
139.83 + ALL m. m < k --> b1$(iterate m$g$x)=TT"
139.84 +apply hypsubst
139.85 +apply (erule exE)
139.86 +apply (intro strip)
139.87 +apply (rule_tac p = "b1$ (iterate m$g$x) " in trE)
139.88 +prefer 2 apply (assumption)
139.89 +apply (rule le_less_trans [THEN less_irrefl [THEN notE]])
139.90 +prefer 2 apply (assumption)
139.91 +apply (rule Least_le)
139.92 +apply (erule hoare_lemma6)
139.93 +apply (rule le_less_trans [THEN less_irrefl [THEN notE]])
139.94 +prefer 2 apply (assumption)
139.95 +apply (rule Least_le)
139.96 +apply (erule hoare_lemma7)
139.97 +done
139.98 +
139.99 +
139.100 +lemma hoare_lemma28: "f$(y::'a)=(UU::tr) ==> f$UU = UU"
139.101 +by (rule strictI)
139.102 +
139.103 +
139.104 +(* ----- access to definitions ----- *)
139.105 +
139.106 +lemma p_def3: "p$x = If b1$x then p$(g$x) else x"
139.107 +apply (rule trans)
139.108 +apply (rule p_def [THEN eq_reflection, THEN fix_eq3])
139.109 +apply simp
139.110 +done
139.111 +
139.112 +lemma q_def3: "q$x = If b1$x orelse b2$x then q$(g$x) else x"
139.113 +apply (rule trans)
139.114 +apply (rule q_def [THEN eq_reflection, THEN fix_eq3])
139.115 +apply simp
139.116 +done
139.117 +
139.118 +(** --------- proofs about iterations of p and q ---------- **)
139.119 +
139.120 +lemma hoare_lemma9: "(ALL m. m< Suc k --> b1$(iterate m$g$x)=TT) -->
139.121 + p$(iterate k$g$x)=p$x"
139.122 +apply (induct_tac k)
139.123 +apply (simp (no_asm))
139.124 +apply (simp (no_asm))
139.125 +apply (intro strip)
139.126 +apply (rule_tac s = "p$ (iterate n$g$x) " in trans)
139.127 +apply (rule trans)
139.128 +apply (rule_tac [2] p_def3 [symmetric])
139.129 +apply (rule_tac s = "TT" and t = "b1$ (iterate n$g$x) " in ssubst)
139.130 +apply (rule mp)
139.131 +apply (erule spec)
139.132 +apply (simp (no_asm) add: less_Suc_eq)
139.133 +apply simp
139.134 +apply (erule mp)
139.135 +apply (intro strip)
139.136 +apply (rule mp)
139.137 +apply (erule spec)
139.138 +apply (erule less_trans)
139.139 +apply simp
139.140 +done
139.141 +
139.142 +lemma hoare_lemma24: "(ALL m. m< Suc k --> b1$(iterate m$g$x)=TT) -->
139.143 + q$(iterate k$g$x)=q$x"
139.144 +apply (induct_tac k)
139.145 +apply (simp (no_asm))
139.146 +apply (simp (no_asm) add: less_Suc_eq)
139.147 +apply (intro strip)
139.148 +apply (rule_tac s = "q$ (iterate n$g$x) " in trans)
139.149 +apply (rule trans)
139.150 +apply (rule_tac [2] q_def3 [symmetric])
139.151 +apply (rule_tac s = "TT" and t = "b1$ (iterate n$g$x) " in ssubst)
139.152 +apply blast
139.153 +apply simp
139.154 +apply (erule mp)
139.155 +apply (intro strip)
139.156 +apply (fast dest!: less_Suc_eq [THEN iffD1])
139.157 +done
139.158 +
139.159 +(* -------- results about p for case (EX k. b1$(iterate k$g$x)~=TT) ------- *)
139.160 +
139.161 +thm hoare_lemma8 [THEN hoare_lemma9 [THEN mp], standard]
139.162 +
139.163 +lemma hoare_lemma10:
139.164 + "EX k. b1$(iterate k$g$x) ~= TT
139.165 + ==> Suc k = (LEAST n. b1$(iterate n$g$x) ~= TT) ==> p$(iterate k$g$x) = p$x"
139.166 + by (rule hoare_lemma8 [THEN hoare_lemma9 [THEN mp]])
139.167 +
139.168 +lemma hoare_lemma11: "(EX n. b1$(iterate n$g$x) ~= TT) ==>
139.169 + k=(LEAST n. b1$(iterate n$g$x) ~= TT) & b1$(iterate k$g$x)=FF
139.170 + --> p$x = iterate k$g$x"
139.171 +apply (case_tac "k")
139.172 +apply hypsubst
139.173 +apply (simp (no_asm))
139.174 +apply (intro strip)
139.175 +apply (erule conjE)
139.176 +apply (rule trans)
139.177 +apply (rule p_def3)
139.178 +apply simp
139.179 +apply hypsubst
139.180 +apply (intro strip)
139.181 +apply (erule conjE)
139.182 +apply (rule trans)
139.183 +apply (erule hoare_lemma10 [symmetric])
139.184 +apply assumption
139.185 +apply (rule trans)
139.186 +apply (rule p_def3)
139.187 +apply (rule_tac s = "TT" and t = "b1$ (iterate nat$g$x) " in ssubst)
139.188 +apply (rule hoare_lemma8 [THEN spec, THEN mp])
139.189 +apply assumption
139.190 +apply assumption
139.191 +apply (simp (no_asm))
139.192 +apply (simp (no_asm))
139.193 +apply (rule trans)
139.194 +apply (rule p_def3)
139.195 +apply (simp (no_asm) del: iterate_Suc add: iterate_Suc [symmetric])
139.196 +apply (erule_tac s = "FF" in ssubst)
139.197 +apply simp
139.198 +done
139.199 +
139.200 +lemma hoare_lemma12: "(EX n. b1$(iterate n$g$x) ~= TT) ==>
139.201 + k=Least(%n. b1$(iterate n$g$x)~=TT) & b1$(iterate k$g$x)=UU
139.202 + --> p$x = UU"
139.203 +apply (case_tac "k")
139.204 +apply hypsubst
139.205 +apply (simp (no_asm))
139.206 +apply (intro strip)
139.207 +apply (erule conjE)
139.208 +apply (rule trans)
139.209 +apply (rule p_def3)
139.210 +apply simp
139.211 +apply hypsubst
139.212 +apply (simp (no_asm))
139.213 +apply (intro strip)
139.214 +apply (erule conjE)
139.215 +apply (rule trans)
139.216 +apply (rule hoare_lemma10 [symmetric])
139.217 +apply assumption
139.218 +apply assumption
139.219 +apply (rule trans)
139.220 +apply (rule p_def3)
139.221 +apply (rule_tac s = "TT" and t = "b1$ (iterate nat$g$x) " in ssubst)
139.222 +apply (rule hoare_lemma8 [THEN spec, THEN mp])
139.223 +apply assumption
139.224 +apply assumption
139.225 +apply (simp (no_asm))
139.226 +apply (simp)
139.227 +apply (rule trans)
139.228 +apply (rule p_def3)
139.229 +apply simp
139.230 +done
139.231 +
139.232 +(* -------- results about p for case (ALL k. b1$(iterate k$g$x)=TT) ------- *)
139.233 +
139.234 +lemma fernpass_lemma: "(ALL k. b1$(iterate k$g$x)=TT) ==> ALL k. p$(iterate k$g$x) = UU"
139.235 +apply (rule p_def [THEN eq_reflection, THEN def_fix_ind])
139.236 +apply simp
139.237 +apply simp
139.238 +apply (simp (no_asm))
139.239 +apply (rule allI)
139.240 +apply (rule_tac s = "TT" and t = "b1$ (iterate k$g$x) " in ssubst)
139.241 +apply (erule spec)
139.242 +apply (simp)
139.243 +apply (rule iterate_Suc [THEN subst])
139.244 +apply (erule spec)
139.245 +done
139.246 +
139.247 +lemma hoare_lemma16: "(ALL k. b1$(iterate k$g$x)=TT) ==> p$x = UU"
139.248 +apply (rule_tac F1 = "g" and t = "x" in iterate_0 [THEN subst])
139.249 +apply (erule fernpass_lemma [THEN spec])
139.250 +done
139.251 +
139.252 +(* -------- results about q for case (ALL k. b1$(iterate k$g$x)=TT) ------- *)
139.253 +
139.254 +lemma hoare_lemma17: "(ALL k. b1$(iterate k$g$x)=TT) ==> ALL k. q$(iterate k$g$x) = UU"
139.255 +apply (rule q_def [THEN eq_reflection, THEN def_fix_ind])
139.256 +apply simp
139.257 +apply simp
139.258 +apply (rule allI)
139.259 +apply (simp (no_asm))
139.260 +apply (rule_tac s = "TT" and t = "b1$ (iterate k$g$x) " in ssubst)
139.261 +apply (erule spec)
139.262 +apply (simp)
139.263 +apply (rule iterate_Suc [THEN subst])
139.264 +apply (erule spec)
139.265 +done
139.266 +
139.267 +lemma hoare_lemma18: "(ALL k. b1$(iterate k$g$x)=TT) ==> q$x = UU"
139.268 +apply (rule_tac F1 = "g" and t = "x" in iterate_0 [THEN subst])
139.269 +apply (erule hoare_lemma17 [THEN spec])
139.270 +done
139.271 +
139.272 +lemma hoare_lemma19:
139.273 + "(ALL k. (b1::'a->tr)$(iterate k$g$x)=TT) ==> b1$(UU::'a) = UU | (ALL y. b1$(y::'a)=TT)"
139.274 +apply (rule flat_codom)
139.275 +apply (rule_tac t = "x1" in iterate_0 [THEN subst])
139.276 +apply (erule spec)
139.277 +done
139.278 +
139.279 +lemma hoare_lemma20: "(ALL y. b1$(y::'a)=TT) ==> ALL k. q$(iterate k$g$(x::'a)) = UU"
139.280 +apply (rule q_def [THEN eq_reflection, THEN def_fix_ind])
139.281 +apply simp
139.282 +apply simp
139.283 +apply (rule allI)
139.284 +apply (simp (no_asm))
139.285 +apply (rule_tac s = "TT" and t = "b1$ (iterate k$g$ (x::'a))" in ssubst)
139.286 +apply (erule spec)
139.287 +apply (simp)
139.288 +apply (rule iterate_Suc [THEN subst])
139.289 +apply (erule spec)
139.290 +done
139.291 +
139.292 +lemma hoare_lemma21: "(ALL y. b1$(y::'a)=TT) ==> q$(x::'a) = UU"
139.293 +apply (rule_tac F1 = "g" and t = "x" in iterate_0 [THEN subst])
139.294 +apply (erule hoare_lemma20 [THEN spec])
139.295 +done
139.296 +
139.297 +lemma hoare_lemma22: "b1$(UU::'a)=UU ==> q$(UU::'a) = UU"
139.298 +apply (subst q_def3)
139.299 +apply simp
139.300 +done
139.301 +
139.302 +(* -------- results about q for case (EX k. b1$(iterate k$g$x) ~= TT) ------- *)
139.303 +
139.304 +lemma hoare_lemma25: "EX k. b1$(iterate k$g$x) ~= TT
139.305 + ==> Suc k = (LEAST n. b1$(iterate n$g$x) ~= TT) ==> q$(iterate k$g$x) = q$x"
139.306 + by (rule hoare_lemma8 [THEN hoare_lemma24 [THEN mp]])
139.307 +
139.308 +lemma hoare_lemma26: "(EX n. b1$(iterate n$g$x)~=TT) ==>
139.309 + k=Least(%n. b1$(iterate n$g$x) ~= TT) & b1$(iterate k$g$x) =FF
139.310 + --> q$x = q$(iterate k$g$x)"
139.311 +apply (case_tac "k")
139.312 +apply hypsubst
139.313 +apply (intro strip)
139.314 +apply (simp (no_asm))
139.315 +apply hypsubst
139.316 +apply (intro strip)
139.317 +apply (erule conjE)
139.318 +apply (rule trans)
139.319 +apply (rule hoare_lemma25 [symmetric])
139.320 +apply assumption
139.321 +apply assumption
139.322 +apply (rule trans)
139.323 +apply (rule q_def3)
139.324 +apply (rule_tac s = "TT" and t = "b1$ (iterate nat$g$x) " in ssubst)
139.325 +apply (rule hoare_lemma8 [THEN spec, THEN mp])
139.326 +apply assumption
139.327 +apply assumption
139.328 +apply (simp (no_asm))
139.329 +apply (simp (no_asm))
139.330 +done
139.331 +
139.332 +
139.333 +lemma hoare_lemma27: "(EX n. b1$(iterate n$g$x) ~= TT) ==>
139.334 + k=Least(%n. b1$(iterate n$g$x)~=TT) & b1$(iterate k$g$x)=UU
139.335 + --> q$x = UU"
139.336 +apply (case_tac "k")
139.337 +apply hypsubst
139.338 +apply (simp (no_asm))
139.339 +apply (intro strip)
139.340 +apply (erule conjE)
139.341 +apply (subst q_def3)
139.342 +apply (simp)
139.343 +apply hypsubst
139.344 +apply (simp (no_asm))
139.345 +apply (intro strip)
139.346 +apply (erule conjE)
139.347 +apply (rule trans)
139.348 +apply (rule hoare_lemma25 [symmetric])
139.349 +apply assumption
139.350 +apply assumption
139.351 +apply (rule trans)
139.352 +apply (rule q_def3)
139.353 +apply (rule_tac s = "TT" and t = "b1$ (iterate nat$g$x) " in ssubst)
139.354 +apply (rule hoare_lemma8 [THEN spec, THEN mp])
139.355 +apply assumption
139.356 +apply assumption
139.357 +apply (simp (no_asm))
139.358 +apply (simp)
139.359 +apply (rule trans)
139.360 +apply (rule q_def3)
139.361 +apply (simp)
139.362 +done
139.363 +
139.364 +(* ------- (ALL k. b1$(iterate k$g$x)=TT) ==> q o p = q ----- *)
139.365 +
139.366 +lemma hoare_lemma23: "(ALL k. b1$(iterate k$g$x)=TT) ==> q$(p$x) = q$x"
139.367 +apply (subst hoare_lemma16)
139.368 +apply assumption
139.369 +apply (rule hoare_lemma19 [THEN disjE])
139.370 +apply assumption
139.371 +apply (simplesubst hoare_lemma18)
139.372 +apply assumption
139.373 +apply (simplesubst hoare_lemma22)
139.374 +apply assumption
139.375 +apply (rule refl)
139.376 +apply (simplesubst hoare_lemma21)
139.377 +apply assumption
139.378 +apply (simplesubst hoare_lemma21)
139.379 +apply assumption
139.380 +apply (rule refl)
139.381 +done
139.382 +
139.383 +(* ------------ EX k. b1~(iterate k$g$x) ~= TT ==> q o p = q ----- *)
139.384 +
139.385 +lemma hoare_lemma29: "EX k. b1$(iterate k$g$x) ~= TT ==> q$(p$x) = q$x"
139.386 +apply (rule hoare_lemma5 [THEN disjE])
139.387 +apply assumption
139.388 +apply (rule refl)
139.389 +apply (subst hoare_lemma11 [THEN mp])
139.390 +apply assumption
139.391 +apply (rule conjI)
139.392 +apply (rule refl)
139.393 +apply assumption
139.394 +apply (rule hoare_lemma26 [THEN mp, THEN subst])
139.395 +apply assumption
139.396 +apply (rule conjI)
139.397 +apply (rule refl)
139.398 +apply assumption
139.399 +apply (rule refl)
139.400 +apply (subst hoare_lemma12 [THEN mp])
139.401 +apply assumption
139.402 +apply (rule conjI)
139.403 +apply (rule refl)
139.404 +apply assumption
139.405 +apply (subst hoare_lemma22)
139.406 +apply (subst hoare_lemma28)
139.407 +apply assumption
139.408 +apply (rule refl)
139.409 +apply (rule sym)
139.410 +apply (subst hoare_lemma27 [THEN mp])
139.411 +apply assumption
139.412 +apply (rule conjI)
139.413 +apply (rule refl)
139.414 +apply assumption
139.415 +apply (rule refl)
139.416 +done
139.417 +
139.418 +(* ------ the main proof q o p = q ------ *)
139.419 +
139.420 +theorem hoare_main: "q oo p = q"
139.421 +apply (rule cfun_eqI)
139.422 +apply (subst cfcomp2)
139.423 +apply (rule hoare_lemma3 [THEN disjE])
139.424 +apply (erule hoare_lemma23)
139.425 +apply (erule hoare_lemma29)
139.426 +done
139.427 +
139.428 +end
140.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
140.2 +++ b/src/HOL/HOLCF/ex/Letrec.thy Sat Nov 27 16:08:10 2010 -0800
140.3 @@ -0,0 +1,37 @@
140.4 +(* Title: HOLCF/ex/Letrec.thy
140.5 + Author: Brian Huffman
140.6 +*)
140.7 +
140.8 +header {* Recursive let bindings *}
140.9 +
140.10 +theory Letrec
140.11 +imports HOLCF
140.12 +begin
140.13 +
140.14 +default_sort pcpo
140.15 +
140.16 +definition
140.17 + CLetrec :: "('a \<rightarrow> 'a \<times> 'b) \<rightarrow> 'b" where
140.18 + "CLetrec = (\<Lambda> F. snd (F\<cdot>(\<mu> x. fst (F\<cdot>x))))"
140.19 +
140.20 +nonterminals
140.21 + recbinds recbindt recbind
140.22 +
140.23 +syntax
140.24 + "_recbind" :: "['a, 'a] \<Rightarrow> recbind" ("(2_ =/ _)" 10)
140.25 + "" :: "recbind \<Rightarrow> recbindt" ("_")
140.26 + "_recbindt" :: "[recbind, recbindt] \<Rightarrow> recbindt" ("_,/ _")
140.27 + "" :: "recbindt \<Rightarrow> recbinds" ("_")
140.28 + "_recbinds" :: "[recbindt, recbinds] \<Rightarrow> recbinds" ("_;/ _")
140.29 + "_Letrec" :: "[recbinds, 'a] \<Rightarrow> 'a" ("(Letrec (_)/ in (_))" 10)
140.30 +
140.31 +translations
140.32 + (recbindt) "x = a, (y,ys) = (b,bs)" == (recbindt) "(x,y,ys) = (a,b,bs)"
140.33 + (recbindt) "x = a, y = b" == (recbindt) "(x,y) = (a,b)"
140.34 +
140.35 +translations
140.36 + "_Letrec (_recbinds b bs) e" == "_Letrec b (_Letrec bs e)"
140.37 + "Letrec xs = a in (e,es)" == "CONST CLetrec\<cdot>(\<Lambda> xs. (a,e,es))"
140.38 + "Letrec xs = a in e" == "CONST CLetrec\<cdot>(\<Lambda> xs. (a,e))"
140.39 +
140.40 +end
141.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
141.2 +++ b/src/HOL/HOLCF/ex/Loop.thy Sat Nov 27 16:08:10 2010 -0800
141.3 @@ -0,0 +1,200 @@
141.4 +(* Title: HOLCF/ex/Loop.thy
141.5 + Author: Franz Regensburger
141.6 +*)
141.7 +
141.8 +header {* Theory for a loop primitive like while *}
141.9 +
141.10 +theory Loop
141.11 +imports HOLCF
141.12 +begin
141.13 +
141.14 +definition
141.15 + step :: "('a -> tr)->('a -> 'a)->'a->'a" where
141.16 + "step = (LAM b g x. If b$x then g$x else x)"
141.17 +
141.18 +definition
141.19 + while :: "('a -> tr)->('a -> 'a)->'a->'a" where
141.20 + "while = (LAM b g. fix$(LAM f x. If b$x then f$(g$x) else x))"
141.21 +
141.22 +(* ------------------------------------------------------------------------- *)
141.23 +(* access to definitions *)
141.24 +(* ------------------------------------------------------------------------- *)
141.25 +
141.26 +
141.27 +lemma step_def2: "step$b$g$x = If b$x then g$x else x"
141.28 +apply (unfold step_def)
141.29 +apply simp
141.30 +done
141.31 +
141.32 +lemma while_def2: "while$b$g = fix$(LAM f x. If b$x then f$(g$x) else x)"
141.33 +apply (unfold while_def)
141.34 +apply simp
141.35 +done
141.36 +
141.37 +
141.38 +(* ------------------------------------------------------------------------- *)
141.39 +(* rekursive properties of while *)
141.40 +(* ------------------------------------------------------------------------- *)
141.41 +
141.42 +lemma while_unfold: "while$b$g$x = If b$x then while$b$g$(g$x) else x"
141.43 +apply (rule trans)
141.44 +apply (rule while_def2 [THEN fix_eq5])
141.45 +apply simp
141.46 +done
141.47 +
141.48 +lemma while_unfold2: "ALL x. while$b$g$x = while$b$g$(iterate k$(step$b$g)$x)"
141.49 +apply (induct_tac k)
141.50 +apply simp
141.51 +apply (rule allI)
141.52 +apply (rule trans)
141.53 +apply (rule while_unfold)
141.54 +apply (subst iterate_Suc2)
141.55 +apply (rule trans)
141.56 +apply (erule_tac [2] spec)
141.57 +apply (subst step_def2)
141.58 +apply (rule_tac p = "b$x" in trE)
141.59 +apply simp
141.60 +apply (subst while_unfold)
141.61 +apply (rule_tac s = "UU" and t = "b$UU" in ssubst)
141.62 +apply (erule strictI)
141.63 +apply simp
141.64 +apply simp
141.65 +apply simp
141.66 +apply (subst while_unfold)
141.67 +apply simp
141.68 +done
141.69 +
141.70 +lemma while_unfold3: "while$b$g$x = while$b$g$(step$b$g$x)"
141.71 +apply (rule_tac s = "while$b$g$ (iterate (Suc 0) $ (step$b$g) $x) " in trans)
141.72 +apply (rule while_unfold2 [THEN spec])
141.73 +apply simp
141.74 +done
141.75 +
141.76 +
141.77 +(* ------------------------------------------------------------------------- *)
141.78 +(* properties of while and iterations *)
141.79 +(* ------------------------------------------------------------------------- *)
141.80 +
141.81 +lemma loop_lemma1: "[| EX y. b$y=FF; iterate k$(step$b$g)$x = UU |]
141.82 + ==>iterate(Suc k)$(step$b$g)$x=UU"
141.83 +apply (simp (no_asm))
141.84 +apply (rule trans)
141.85 +apply (rule step_def2)
141.86 +apply simp
141.87 +apply (erule exE)
141.88 +apply (erule flat_codom [THEN disjE])
141.89 +apply simp_all
141.90 +done
141.91 +
141.92 +lemma loop_lemma2: "[|EX y. b$y=FF;iterate (Suc k)$(step$b$g)$x ~=UU |]==>
141.93 + iterate k$(step$b$g)$x ~=UU"
141.94 +apply (blast intro: loop_lemma1)
141.95 +done
141.96 +
141.97 +lemma loop_lemma3 [rule_format (no_asm)]:
141.98 + "[| ALL x. INV x & b$x=TT & g$x~=UU --> INV (g$x);
141.99 + EX y. b$y=FF; INV x |]
141.100 + ==> iterate k$(step$b$g)$x ~=UU --> INV (iterate k$(step$b$g)$x)"
141.101 +apply (induct_tac "k")
141.102 +apply (simp (no_asm_simp))
141.103 +apply (intro strip)
141.104 +apply (simp (no_asm) add: step_def2)
141.105 +apply (rule_tac p = "b$ (iterate n$ (step$b$g) $x) " in trE)
141.106 +apply (erule notE)
141.107 +apply (simp add: step_def2)
141.108 +apply (simp (no_asm_simp))
141.109 +apply (rule mp)
141.110 +apply (erule spec)
141.111 +apply (simp (no_asm_simp) del: iterate_Suc add: loop_lemma2)
141.112 +apply (rule_tac s = "iterate (Suc n) $ (step$b$g) $x"
141.113 + and t = "g$ (iterate n$ (step$b$g) $x) " in ssubst)
141.114 +prefer 2 apply (assumption)
141.115 +apply (simp add: step_def2)
141.116 +apply (drule (1) loop_lemma2, simp)
141.117 +done
141.118 +
141.119 +lemma loop_lemma4 [rule_format]:
141.120 + "ALL x. b$(iterate k$(step$b$g)$x)=FF --> while$b$g$x= iterate k$(step$b$g)$x"
141.121 +apply (induct_tac k)
141.122 +apply (simp (no_asm))
141.123 +apply (intro strip)
141.124 +apply (simplesubst while_unfold)
141.125 +apply simp
141.126 +apply (rule allI)
141.127 +apply (simplesubst iterate_Suc2)
141.128 +apply (intro strip)
141.129 +apply (rule trans)
141.130 +apply (rule while_unfold3)
141.131 +apply simp
141.132 +done
141.133 +
141.134 +lemma loop_lemma5 [rule_format (no_asm)]:
141.135 + "ALL k. b$(iterate k$(step$b$g)$x) ~= FF ==>
141.136 + ALL m. while$b$g$(iterate m$(step$b$g)$x)=UU"
141.137 +apply (simplesubst while_def2)
141.138 +apply (rule fix_ind)
141.139 +apply simp
141.140 +apply simp
141.141 +apply (rule allI)
141.142 +apply (simp (no_asm))
141.143 +apply (rule_tac p = "b$ (iterate m$ (step$b$g) $x) " in trE)
141.144 +apply (simp (no_asm_simp))
141.145 +apply (simp (no_asm_simp))
141.146 +apply (rule_tac s = "xa$ (iterate (Suc m) $ (step$b$g) $x) " in trans)
141.147 +apply (erule_tac [2] spec)
141.148 +apply (rule cfun_arg_cong)
141.149 +apply (rule trans)
141.150 +apply (rule_tac [2] iterate_Suc [symmetric])
141.151 +apply (simp add: step_def2)
141.152 +apply blast
141.153 +done
141.154 +
141.155 +lemma loop_lemma6: "ALL k. b$(iterate k$(step$b$g)$x) ~= FF ==> while$b$g$x=UU"
141.156 +apply (rule_tac t = "x" in iterate_0 [THEN subst])
141.157 +apply (erule loop_lemma5)
141.158 +done
141.159 +
141.160 +lemma loop_lemma7: "while$b$g$x ~= UU ==> EX k. b$(iterate k$(step$b$g)$x) = FF"
141.161 +apply (blast intro: loop_lemma6)
141.162 +done
141.163 +
141.164 +
141.165 +(* ------------------------------------------------------------------------- *)
141.166 +(* an invariant rule for loops *)
141.167 +(* ------------------------------------------------------------------------- *)
141.168 +
141.169 +lemma loop_inv2:
141.170 +"[| (ALL y. INV y & b$y=TT & g$y ~= UU --> INV (g$y));
141.171 + (ALL y. INV y & b$y=FF --> Q y);
141.172 + INV x; while$b$g$x~=UU |] ==> Q (while$b$g$x)"
141.173 +apply (rule_tac P = "%k. b$ (iterate k$ (step$b$g) $x) =FF" in exE)
141.174 +apply (erule loop_lemma7)
141.175 +apply (simplesubst loop_lemma4)
141.176 +apply assumption
141.177 +apply (drule spec, erule mp)
141.178 +apply (rule conjI)
141.179 +prefer 2 apply (assumption)
141.180 +apply (rule loop_lemma3)
141.181 +apply assumption
141.182 +apply (blast intro: loop_lemma6)
141.183 +apply assumption
141.184 +apply (rotate_tac -1)
141.185 +apply (simp add: loop_lemma4)
141.186 +done
141.187 +
141.188 +lemma loop_inv:
141.189 + assumes premP: "P(x)"
141.190 + and premI: "!!y. P y ==> INV y"
141.191 + and premTT: "!!y. [| INV y; b$y=TT; g$y~=UU|] ==> INV (g$y)"
141.192 + and premFF: "!!y. [| INV y; b$y=FF|] ==> Q y"
141.193 + and premW: "while$b$g$x ~= UU"
141.194 + shows "Q (while$b$g$x)"
141.195 +apply (rule loop_inv2)
141.196 +apply (rule_tac [3] premP [THEN premI])
141.197 +apply (rule_tac [3] premW)
141.198 +apply (blast intro: premTT)
141.199 +apply (blast intro: premFF)
141.200 +done
141.201 +
141.202 +end
141.203 +
142.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
142.2 +++ b/src/HOL/HOLCF/ex/Pattern_Match.thy Sat Nov 27 16:08:10 2010 -0800
142.3 @@ -0,0 +1,609 @@
142.4 +(* Title: HOLCF/ex/Pattern_Match.thy
142.5 + Author: Brian Huffman
142.6 +*)
142.7 +
142.8 +header {* An experimental pattern-matching notation *}
142.9 +
142.10 +theory Pattern_Match
142.11 +imports HOLCF
142.12 +begin
142.13 +
142.14 +default_sort pcpo
142.15 +
142.16 +text {* FIXME: Find a proper way to un-hide constants. *}
142.17 +
142.18 +abbreviation fail :: "'a match"
142.19 +where "fail \<equiv> Fixrec.fail"
142.20 +
142.21 +abbreviation succeed :: "'a \<rightarrow> 'a match"
142.22 +where "succeed \<equiv> Fixrec.succeed"
142.23 +
142.24 +abbreviation run :: "'a match \<rightarrow> 'a"
142.25 +where "run \<equiv> Fixrec.run"
142.26 +
142.27 +subsection {* Fatbar combinator *}
142.28 +
142.29 +definition
142.30 + fatbar :: "('a \<rightarrow> 'b match) \<rightarrow> ('a \<rightarrow> 'b match) \<rightarrow> ('a \<rightarrow> 'b match)" where
142.31 + "fatbar = (\<Lambda> a b x. a\<cdot>x +++ b\<cdot>x)"
142.32 +
142.33 +abbreviation
142.34 + fatbar_syn :: "['a \<rightarrow> 'b match, 'a \<rightarrow> 'b match] \<Rightarrow> 'a \<rightarrow> 'b match" (infixr "\<parallel>" 60) where
142.35 + "m1 \<parallel> m2 == fatbar\<cdot>m1\<cdot>m2"
142.36 +
142.37 +lemma fatbar1: "m\<cdot>x = \<bottom> \<Longrightarrow> (m \<parallel> ms)\<cdot>x = \<bottom>"
142.38 +by (simp add: fatbar_def)
142.39 +
142.40 +lemma fatbar2: "m\<cdot>x = fail \<Longrightarrow> (m \<parallel> ms)\<cdot>x = ms\<cdot>x"
142.41 +by (simp add: fatbar_def)
142.42 +
142.43 +lemma fatbar3: "m\<cdot>x = succeed\<cdot>y \<Longrightarrow> (m \<parallel> ms)\<cdot>x = succeed\<cdot>y"
142.44 +by (simp add: fatbar_def)
142.45 +
142.46 +lemmas fatbar_simps = fatbar1 fatbar2 fatbar3
142.47 +
142.48 +lemma run_fatbar1: "m\<cdot>x = \<bottom> \<Longrightarrow> run\<cdot>((m \<parallel> ms)\<cdot>x) = \<bottom>"
142.49 +by (simp add: fatbar_def)
142.50 +
142.51 +lemma run_fatbar2: "m\<cdot>x = fail \<Longrightarrow> run\<cdot>((m \<parallel> ms)\<cdot>x) = run\<cdot>(ms\<cdot>x)"
142.52 +by (simp add: fatbar_def)
142.53 +
142.54 +lemma run_fatbar3: "m\<cdot>x = succeed\<cdot>y \<Longrightarrow> run\<cdot>((m \<parallel> ms)\<cdot>x) = y"
142.55 +by (simp add: fatbar_def)
142.56 +
142.57 +lemmas run_fatbar_simps [simp] = run_fatbar1 run_fatbar2 run_fatbar3
142.58 +
142.59 +subsection {* Bind operator for match monad *}
142.60 +
142.61 +definition match_bind :: "'a match \<rightarrow> ('a \<rightarrow> 'b match) \<rightarrow> 'b match" where
142.62 + "match_bind = (\<Lambda> m k. sscase\<cdot>(\<Lambda> _. fail)\<cdot>(fup\<cdot>k)\<cdot>(Rep_match m))"
142.63 +
142.64 +lemma match_bind_simps [simp]:
142.65 + "match_bind\<cdot>\<bottom>\<cdot>k = \<bottom>"
142.66 + "match_bind\<cdot>fail\<cdot>k = fail"
142.67 + "match_bind\<cdot>(succeed\<cdot>x)\<cdot>k = k\<cdot>x"
142.68 +unfolding match_bind_def fail_def succeed_def
142.69 +by (simp_all add: cont2cont_Rep_match cont_Abs_match
142.70 + Rep_match_strict Abs_match_inverse)
142.71 +
142.72 +subsection {* Case branch combinator *}
142.73 +
142.74 +definition
142.75 + branch :: "('a \<rightarrow> 'b match) \<Rightarrow> ('b \<rightarrow> 'c) \<rightarrow> ('a \<rightarrow> 'c match)" where
142.76 + "branch p \<equiv> \<Lambda> r x. match_bind\<cdot>(p\<cdot>x)\<cdot>(\<Lambda> y. succeed\<cdot>(r\<cdot>y))"
142.77 +
142.78 +lemma branch_simps:
142.79 + "p\<cdot>x = \<bottom> \<Longrightarrow> branch p\<cdot>r\<cdot>x = \<bottom>"
142.80 + "p\<cdot>x = fail \<Longrightarrow> branch p\<cdot>r\<cdot>x = fail"
142.81 + "p\<cdot>x = succeed\<cdot>y \<Longrightarrow> branch p\<cdot>r\<cdot>x = succeed\<cdot>(r\<cdot>y)"
142.82 +by (simp_all add: branch_def)
142.83 +
142.84 +lemma branch_succeed [simp]: "branch succeed\<cdot>r\<cdot>x = succeed\<cdot>(r\<cdot>x)"
142.85 +by (simp add: branch_def)
142.86 +
142.87 +subsection {* Cases operator *}
142.88 +
142.89 +definition
142.90 + cases :: "'a match \<rightarrow> 'a::pcpo" where
142.91 + "cases = Fixrec.run"
142.92 +
142.93 +text {* rewrite rules for cases *}
142.94 +
142.95 +lemma cases_strict [simp]: "cases\<cdot>\<bottom> = \<bottom>"
142.96 +by (simp add: cases_def)
142.97 +
142.98 +lemma cases_fail [simp]: "cases\<cdot>fail = \<bottom>"
142.99 +by (simp add: cases_def)
142.100 +
142.101 +lemma cases_succeed [simp]: "cases\<cdot>(succeed\<cdot>x) = x"
142.102 +by (simp add: cases_def)
142.103 +
142.104 +subsection {* Case syntax *}
142.105 +
142.106 +nonterminals
142.107 + Case_syn Cases_syn
142.108 +
142.109 +syntax
142.110 + "_Case_syntax":: "['a, Cases_syn] => 'b" ("(Case _ of/ _)" 10)
142.111 + "_Case1" :: "['a, 'b] => Case_syn" ("(2_ =>/ _)" 10)
142.112 + "" :: "Case_syn => Cases_syn" ("_")
142.113 + "_Case2" :: "[Case_syn, Cases_syn] => Cases_syn" ("_/ | _")
142.114 +
142.115 +syntax (xsymbols)
142.116 + "_Case1" :: "['a, 'b] => Case_syn" ("(2_ \<Rightarrow>/ _)" 10)
142.117 +
142.118 +translations
142.119 + "_Case_syntax x ms" == "CONST cases\<cdot>(ms\<cdot>x)"
142.120 + "_Case2 m ms" == "m \<parallel> ms"
142.121 +
142.122 +text {* Parsing Case expressions *}
142.123 +
142.124 +syntax
142.125 + "_pat" :: "'a"
142.126 + "_variable" :: "'a"
142.127 + "_noargs" :: "'a"
142.128 +
142.129 +translations
142.130 + "_Case1 p r" => "CONST branch (_pat p)\<cdot>(_variable p r)"
142.131 + "_variable (_args x y) r" => "CONST csplit\<cdot>(_variable x (_variable y r))"
142.132 + "_variable _noargs r" => "CONST unit_when\<cdot>r"
142.133 +
142.134 +parse_translation {*
142.135 +(* rewrite (_pat x) => (succeed) *)
142.136 +(* rewrite (_variable x t) => (Abs_cfun (%x. t)) *)
142.137 + [(@{syntax_const "_pat"}, fn _ => Syntax.const @{const_syntax Fixrec.succeed}),
142.138 + mk_binder_tr (@{syntax_const "_variable"}, @{const_syntax Abs_cfun})];
142.139 +*}
142.140 +
142.141 +text {* Printing Case expressions *}
142.142 +
142.143 +syntax
142.144 + "_match" :: "'a"
142.145 +
142.146 +print_translation {*
142.147 + let
142.148 + fun dest_LAM (Const (@{const_syntax Rep_cfun},_) $ Const (@{const_syntax unit_when},_) $ t) =
142.149 + (Syntax.const @{syntax_const "_noargs"}, t)
142.150 + | dest_LAM (Const (@{const_syntax Rep_cfun},_) $ Const (@{const_syntax csplit},_) $ t) =
142.151 + let
142.152 + val (v1, t1) = dest_LAM t;
142.153 + val (v2, t2) = dest_LAM t1;
142.154 + in (Syntax.const @{syntax_const "_args"} $ v1 $ v2, t2) end
142.155 + | dest_LAM (Const (@{const_syntax Abs_cfun},_) $ t) =
142.156 + let
142.157 + val abs =
142.158 + case t of Abs abs => abs
142.159 + | _ => ("x", dummyT, incr_boundvars 1 t $ Bound 0);
142.160 + val (x, t') = atomic_abs_tr' abs;
142.161 + in (Syntax.const @{syntax_const "_variable"} $ x, t') end
142.162 + | dest_LAM _ = raise Match; (* too few vars: abort translation *)
142.163 +
142.164 + fun Case1_tr' [Const(@{const_syntax branch},_) $ p, r] =
142.165 + let val (v, t) = dest_LAM r in
142.166 + Syntax.const @{syntax_const "_Case1"} $
142.167 + (Syntax.const @{syntax_const "_match"} $ p $ v) $ t
142.168 + end;
142.169 +
142.170 + in [(@{const_syntax Rep_cfun}, Case1_tr')] end;
142.171 +*}
142.172 +
142.173 +translations
142.174 + "x" <= "_match (CONST succeed) (_variable x)"
142.175 +
142.176 +
142.177 +subsection {* Pattern combinators for data constructors *}
142.178 +
142.179 +types ('a, 'b) pat = "'a \<rightarrow> 'b match"
142.180 +
142.181 +definition
142.182 + cpair_pat :: "('a, 'c) pat \<Rightarrow> ('b, 'd) pat \<Rightarrow> ('a \<times> 'b, 'c \<times> 'd) pat" where
142.183 + "cpair_pat p1 p2 = (\<Lambda>(x, y).
142.184 + match_bind\<cdot>(p1\<cdot>x)\<cdot>(\<Lambda> a. match_bind\<cdot>(p2\<cdot>y)\<cdot>(\<Lambda> b. succeed\<cdot>(a, b))))"
142.185 +
142.186 +definition
142.187 + spair_pat ::
142.188 + "('a, 'c) pat \<Rightarrow> ('b, 'd) pat \<Rightarrow> ('a::pcpo \<otimes> 'b::pcpo, 'c \<times> 'd) pat" where
142.189 + "spair_pat p1 p2 = (\<Lambda>(:x, y:). cpair_pat p1 p2\<cdot>(x, y))"
142.190 +
142.191 +definition
142.192 + sinl_pat :: "('a, 'c) pat \<Rightarrow> ('a::pcpo \<oplus> 'b::pcpo, 'c) pat" where
142.193 + "sinl_pat p = sscase\<cdot>p\<cdot>(\<Lambda> x. fail)"
142.194 +
142.195 +definition
142.196 + sinr_pat :: "('b, 'c) pat \<Rightarrow> ('a::pcpo \<oplus> 'b::pcpo, 'c) pat" where
142.197 + "sinr_pat p = sscase\<cdot>(\<Lambda> x. fail)\<cdot>p"
142.198 +
142.199 +definition
142.200 + up_pat :: "('a, 'b) pat \<Rightarrow> ('a u, 'b) pat" where
142.201 + "up_pat p = fup\<cdot>p"
142.202 +
142.203 +definition
142.204 + TT_pat :: "(tr, unit) pat" where
142.205 + "TT_pat = (\<Lambda> b. If b then succeed\<cdot>() else fail)"
142.206 +
142.207 +definition
142.208 + FF_pat :: "(tr, unit) pat" where
142.209 + "FF_pat = (\<Lambda> b. If b then fail else succeed\<cdot>())"
142.210 +
142.211 +definition
142.212 + ONE_pat :: "(one, unit) pat" where
142.213 + "ONE_pat = (\<Lambda> ONE. succeed\<cdot>())"
142.214 +
142.215 +text {* Parse translations (patterns) *}
142.216 +translations
142.217 + "_pat (XCONST Pair x y)" => "CONST cpair_pat (_pat x) (_pat y)"
142.218 + "_pat (XCONST spair\<cdot>x\<cdot>y)" => "CONST spair_pat (_pat x) (_pat y)"
142.219 + "_pat (XCONST sinl\<cdot>x)" => "CONST sinl_pat (_pat x)"
142.220 + "_pat (XCONST sinr\<cdot>x)" => "CONST sinr_pat (_pat x)"
142.221 + "_pat (XCONST up\<cdot>x)" => "CONST up_pat (_pat x)"
142.222 + "_pat (XCONST TT)" => "CONST TT_pat"
142.223 + "_pat (XCONST FF)" => "CONST FF_pat"
142.224 + "_pat (XCONST ONE)" => "CONST ONE_pat"
142.225 +
142.226 +text {* CONST version is also needed for constructors with special syntax *}
142.227 +translations
142.228 + "_pat (CONST Pair x y)" => "CONST cpair_pat (_pat x) (_pat y)"
142.229 + "_pat (CONST spair\<cdot>x\<cdot>y)" => "CONST spair_pat (_pat x) (_pat y)"
142.230 +
142.231 +text {* Parse translations (variables) *}
142.232 +translations
142.233 + "_variable (XCONST Pair x y) r" => "_variable (_args x y) r"
142.234 + "_variable (XCONST spair\<cdot>x\<cdot>y) r" => "_variable (_args x y) r"
142.235 + "_variable (XCONST sinl\<cdot>x) r" => "_variable x r"
142.236 + "_variable (XCONST sinr\<cdot>x) r" => "_variable x r"
142.237 + "_variable (XCONST up\<cdot>x) r" => "_variable x r"
142.238 + "_variable (XCONST TT) r" => "_variable _noargs r"
142.239 + "_variable (XCONST FF) r" => "_variable _noargs r"
142.240 + "_variable (XCONST ONE) r" => "_variable _noargs r"
142.241 +
142.242 +translations
142.243 + "_variable (CONST Pair x y) r" => "_variable (_args x y) r"
142.244 + "_variable (CONST spair\<cdot>x\<cdot>y) r" => "_variable (_args x y) r"
142.245 +
142.246 +text {* Print translations *}
142.247 +translations
142.248 + "CONST Pair (_match p1 v1) (_match p2 v2)"
142.249 + <= "_match (CONST cpair_pat p1 p2) (_args v1 v2)"
142.250 + "CONST spair\<cdot>(_match p1 v1)\<cdot>(_match p2 v2)"
142.251 + <= "_match (CONST spair_pat p1 p2) (_args v1 v2)"
142.252 + "CONST sinl\<cdot>(_match p1 v1)" <= "_match (CONST sinl_pat p1) v1"
142.253 + "CONST sinr\<cdot>(_match p1 v1)" <= "_match (CONST sinr_pat p1) v1"
142.254 + "CONST up\<cdot>(_match p1 v1)" <= "_match (CONST up_pat p1) v1"
142.255 + "CONST TT" <= "_match (CONST TT_pat) _noargs"
142.256 + "CONST FF" <= "_match (CONST FF_pat) _noargs"
142.257 + "CONST ONE" <= "_match (CONST ONE_pat) _noargs"
142.258 +
142.259 +lemma cpair_pat1:
142.260 + "branch p\<cdot>r\<cdot>x = \<bottom> \<Longrightarrow> branch (cpair_pat p q)\<cdot>(csplit\<cdot>r)\<cdot>(x, y) = \<bottom>"
142.261 +apply (simp add: branch_def cpair_pat_def)
142.262 +apply (cases "p\<cdot>x", simp_all)
142.263 +done
142.264 +
142.265 +lemma cpair_pat2:
142.266 + "branch p\<cdot>r\<cdot>x = fail \<Longrightarrow> branch (cpair_pat p q)\<cdot>(csplit\<cdot>r)\<cdot>(x, y) = fail"
142.267 +apply (simp add: branch_def cpair_pat_def)
142.268 +apply (cases "p\<cdot>x", simp_all)
142.269 +done
142.270 +
142.271 +lemma cpair_pat3:
142.272 + "branch p\<cdot>r\<cdot>x = succeed\<cdot>s \<Longrightarrow>
142.273 + branch (cpair_pat p q)\<cdot>(csplit\<cdot>r)\<cdot>(x, y) = branch q\<cdot>s\<cdot>y"
142.274 +apply (simp add: branch_def cpair_pat_def)
142.275 +apply (cases "p\<cdot>x", simp_all)
142.276 +apply (cases "q\<cdot>y", simp_all)
142.277 +done
142.278 +
142.279 +lemmas cpair_pat [simp] =
142.280 + cpair_pat1 cpair_pat2 cpair_pat3
142.281 +
142.282 +lemma spair_pat [simp]:
142.283 + "branch (spair_pat p1 p2)\<cdot>r\<cdot>\<bottom> = \<bottom>"
142.284 + "\<lbrakk>x \<noteq> \<bottom>; y \<noteq> \<bottom>\<rbrakk>
142.285 + \<Longrightarrow> branch (spair_pat p1 p2)\<cdot>r\<cdot>(:x, y:) =
142.286 + branch (cpair_pat p1 p2)\<cdot>r\<cdot>(x, y)"
142.287 +by (simp_all add: branch_def spair_pat_def)
142.288 +
142.289 +lemma sinl_pat [simp]:
142.290 + "branch (sinl_pat p)\<cdot>r\<cdot>\<bottom> = \<bottom>"
142.291 + "x \<noteq> \<bottom> \<Longrightarrow> branch (sinl_pat p)\<cdot>r\<cdot>(sinl\<cdot>x) = branch p\<cdot>r\<cdot>x"
142.292 + "y \<noteq> \<bottom> \<Longrightarrow> branch (sinl_pat p)\<cdot>r\<cdot>(sinr\<cdot>y) = fail"
142.293 +by (simp_all add: branch_def sinl_pat_def)
142.294 +
142.295 +lemma sinr_pat [simp]:
142.296 + "branch (sinr_pat p)\<cdot>r\<cdot>\<bottom> = \<bottom>"
142.297 + "x \<noteq> \<bottom> \<Longrightarrow> branch (sinr_pat p)\<cdot>r\<cdot>(sinl\<cdot>x) = fail"
142.298 + "y \<noteq> \<bottom> \<Longrightarrow> branch (sinr_pat p)\<cdot>r\<cdot>(sinr\<cdot>y) = branch p\<cdot>r\<cdot>y"
142.299 +by (simp_all add: branch_def sinr_pat_def)
142.300 +
142.301 +lemma up_pat [simp]:
142.302 + "branch (up_pat p)\<cdot>r\<cdot>\<bottom> = \<bottom>"
142.303 + "branch (up_pat p)\<cdot>r\<cdot>(up\<cdot>x) = branch p\<cdot>r\<cdot>x"
142.304 +by (simp_all add: branch_def up_pat_def)
142.305 +
142.306 +lemma TT_pat [simp]:
142.307 + "branch TT_pat\<cdot>(unit_when\<cdot>r)\<cdot>\<bottom> = \<bottom>"
142.308 + "branch TT_pat\<cdot>(unit_when\<cdot>r)\<cdot>TT = succeed\<cdot>r"
142.309 + "branch TT_pat\<cdot>(unit_when\<cdot>r)\<cdot>FF = fail"
142.310 +by (simp_all add: branch_def TT_pat_def)
142.311 +
142.312 +lemma FF_pat [simp]:
142.313 + "branch FF_pat\<cdot>(unit_when\<cdot>r)\<cdot>\<bottom> = \<bottom>"
142.314 + "branch FF_pat\<cdot>(unit_when\<cdot>r)\<cdot>TT = fail"
142.315 + "branch FF_pat\<cdot>(unit_when\<cdot>r)\<cdot>FF = succeed\<cdot>r"
142.316 +by (simp_all add: branch_def FF_pat_def)
142.317 +
142.318 +lemma ONE_pat [simp]:
142.319 + "branch ONE_pat\<cdot>(unit_when\<cdot>r)\<cdot>\<bottom> = \<bottom>"
142.320 + "branch ONE_pat\<cdot>(unit_when\<cdot>r)\<cdot>ONE = succeed\<cdot>r"
142.321 +by (simp_all add: branch_def ONE_pat_def)
142.322 +
142.323 +
142.324 +subsection {* Wildcards, as-patterns, and lazy patterns *}
142.325 +
142.326 +definition
142.327 + wild_pat :: "'a \<rightarrow> unit match" where
142.328 + "wild_pat = (\<Lambda> x. succeed\<cdot>())"
142.329 +
142.330 +definition
142.331 + as_pat :: "('a \<rightarrow> 'b match) \<Rightarrow> 'a \<rightarrow> ('a \<times> 'b) match" where
142.332 + "as_pat p = (\<Lambda> x. match_bind\<cdot>(p\<cdot>x)\<cdot>(\<Lambda> a. succeed\<cdot>(x, a)))"
142.333 +
142.334 +definition
142.335 + lazy_pat :: "('a \<rightarrow> 'b::pcpo match) \<Rightarrow> ('a \<rightarrow> 'b match)" where
142.336 + "lazy_pat p = (\<Lambda> x. succeed\<cdot>(cases\<cdot>(p\<cdot>x)))"
142.337 +
142.338 +text {* Parse translations (patterns) *}
142.339 +translations
142.340 + "_pat _" => "CONST wild_pat"
142.341 +
142.342 +text {* Parse translations (variables) *}
142.343 +translations
142.344 + "_variable _ r" => "_variable _noargs r"
142.345 +
142.346 +text {* Print translations *}
142.347 +translations
142.348 + "_" <= "_match (CONST wild_pat) _noargs"
142.349 +
142.350 +lemma wild_pat [simp]: "branch wild_pat\<cdot>(unit_when\<cdot>r)\<cdot>x = succeed\<cdot>r"
142.351 +by (simp add: branch_def wild_pat_def)
142.352 +
142.353 +lemma as_pat [simp]:
142.354 + "branch (as_pat p)\<cdot>(csplit\<cdot>r)\<cdot>x = branch p\<cdot>(r\<cdot>x)\<cdot>x"
142.355 +apply (simp add: branch_def as_pat_def)
142.356 +apply (cases "p\<cdot>x", simp_all)
142.357 +done
142.358 +
142.359 +lemma lazy_pat [simp]:
142.360 + "branch p\<cdot>r\<cdot>x = \<bottom> \<Longrightarrow> branch (lazy_pat p)\<cdot>r\<cdot>x = succeed\<cdot>(r\<cdot>\<bottom>)"
142.361 + "branch p\<cdot>r\<cdot>x = fail \<Longrightarrow> branch (lazy_pat p)\<cdot>r\<cdot>x = succeed\<cdot>(r\<cdot>\<bottom>)"
142.362 + "branch p\<cdot>r\<cdot>x = succeed\<cdot>s \<Longrightarrow> branch (lazy_pat p)\<cdot>r\<cdot>x = succeed\<cdot>s"
142.363 +apply (simp_all add: branch_def lazy_pat_def)
142.364 +apply (cases "p\<cdot>x", simp_all)+
142.365 +done
142.366 +
142.367 +subsection {* Examples *}
142.368 +
142.369 +term "Case t of (:up\<cdot>(sinl\<cdot>x), sinr\<cdot>y:) \<Rightarrow> (x, y)"
142.370 +
142.371 +term "\<Lambda> t. Case t of up\<cdot>(sinl\<cdot>a) \<Rightarrow> a | up\<cdot>(sinr\<cdot>b) \<Rightarrow> b"
142.372 +
142.373 +term "\<Lambda> t. Case t of (:up\<cdot>(sinl\<cdot>_), sinr\<cdot>x:) \<Rightarrow> x"
142.374 +
142.375 +subsection {* ML code for generating definitions *}
142.376 +
142.377 +ML {*
142.378 +local open HOLCF_Library in
142.379 +
142.380 +infixr 6 ->>;
142.381 +infix 9 ` ;
142.382 +
142.383 +val beta_rules =
142.384 + @{thms beta_cfun cont_id cont_const cont2cont_APP cont2cont_LAM'} @
142.385 + @{thms cont2cont_fst cont2cont_snd cont2cont_Pair};
142.386 +
142.387 +val beta_ss = HOL_basic_ss addsimps (simp_thms @ beta_rules);
142.388 +
142.389 +fun define_consts
142.390 + (specs : (binding * term * mixfix) list)
142.391 + (thy : theory)
142.392 + : (term list * thm list) * theory =
142.393 + let
142.394 + fun mk_decl (b, t, mx) = (b, fastype_of t, mx);
142.395 + val decls = map mk_decl specs;
142.396 + val thy = Cont_Consts.add_consts decls thy;
142.397 + fun mk_const (b, T, mx) = Const (Sign.full_name thy b, T);
142.398 + val consts = map mk_const decls;
142.399 + fun mk_def c (b, t, mx) =
142.400 + (Binding.suffix_name "_def" b, Logic.mk_equals (c, t));
142.401 + val defs = map2 mk_def consts specs;
142.402 + val (def_thms, thy) =
142.403 + Global_Theory.add_defs false (map Thm.no_attributes defs) thy;
142.404 + in
142.405 + ((consts, def_thms), thy)
142.406 + end;
142.407 +
142.408 +fun prove
142.409 + (thy : theory)
142.410 + (defs : thm list)
142.411 + (goal : term)
142.412 + (tacs : {prems: thm list, context: Proof.context} -> tactic list)
142.413 + : thm =
142.414 + let
142.415 + fun tac {prems, context} =
142.416 + rewrite_goals_tac defs THEN
142.417 + EVERY (tacs {prems = map (rewrite_rule defs) prems, context = context})
142.418 + in
142.419 + Goal.prove_global thy [] [] goal tac
142.420 + end;
142.421 +
142.422 +fun get_vars_avoiding
142.423 + (taken : string list)
142.424 + (args : (bool * typ) list)
142.425 + : (term list * term list) =
142.426 + let
142.427 + val Ts = map snd args;
142.428 + val ns = Name.variant_list taken (Datatype_Prop.make_tnames Ts);
142.429 + val vs = map Free (ns ~~ Ts);
142.430 + val nonlazy = map snd (filter_out (fst o fst) (args ~~ vs));
142.431 + in
142.432 + (vs, nonlazy)
142.433 + end;
142.434 +
142.435 +(******************************************************************************)
142.436 +(************** definitions and theorems for pattern combinators **************)
142.437 +(******************************************************************************)
142.438 +
142.439 +fun add_pattern_combinators
142.440 + (bindings : binding list)
142.441 + (spec : (term * (bool * typ) list) list)
142.442 + (lhsT : typ)
142.443 + (exhaust : thm)
142.444 + (case_const : typ -> term)
142.445 + (case_rews : thm list)
142.446 + (thy : theory) =
142.447 + let
142.448 +
142.449 + (* utility functions *)
142.450 + fun mk_pair_pat (p1, p2) =
142.451 + let
142.452 + val T1 = fastype_of p1;
142.453 + val T2 = fastype_of p2;
142.454 + val (U1, V1) = apsnd dest_matchT (dest_cfunT T1);
142.455 + val (U2, V2) = apsnd dest_matchT (dest_cfunT T2);
142.456 + val pat_typ = [T1, T2] --->
142.457 + (mk_prodT (U1, U2) ->> mk_matchT (mk_prodT (V1, V2)));
142.458 + val pat_const = Const (@{const_name cpair_pat}, pat_typ);
142.459 + in
142.460 + pat_const $ p1 $ p2
142.461 + end;
142.462 + fun mk_tuple_pat [] = succeed_const HOLogic.unitT
142.463 + | mk_tuple_pat ps = foldr1 mk_pair_pat ps;
142.464 + fun branch_const (T,U,V) =
142.465 + Const (@{const_name branch},
142.466 + (T ->> mk_matchT U) --> (U ->> V) ->> T ->> mk_matchT V);
142.467 +
142.468 + (* define pattern combinators *)
142.469 + local
142.470 + val tns = map (fst o dest_TFree) (snd (dest_Type lhsT));
142.471 +
142.472 + fun pat_eqn (i, (bind, (con, args))) : binding * term * mixfix =
142.473 + let
142.474 + val pat_bind = Binding.suffix_name "_pat" bind;
142.475 + val Ts = map snd args;
142.476 + val Vs =
142.477 + (map (K "'t") args)
142.478 + |> Datatype_Prop.indexify_names
142.479 + |> Name.variant_list tns
142.480 + |> map (fn t => TFree (t, @{sort pcpo}));
142.481 + val patNs = Datatype_Prop.indexify_names (map (K "pat") args);
142.482 + val patTs = map2 (fn T => fn V => T ->> mk_matchT V) Ts Vs;
142.483 + val pats = map Free (patNs ~~ patTs);
142.484 + val fail = mk_fail (mk_tupleT Vs);
142.485 + val (vs, nonlazy) = get_vars_avoiding patNs args;
142.486 + val rhs = big_lambdas vs (mk_tuple_pat pats ` mk_tuple vs);
142.487 + fun one_fun (j, (_, args')) =
142.488 + let
142.489 + val (vs', nonlazy) = get_vars_avoiding patNs args';
142.490 + in if i = j then rhs else big_lambdas vs' fail end;
142.491 + val funs = map_index one_fun spec;
142.492 + val body = list_ccomb (case_const (mk_matchT (mk_tupleT Vs)), funs);
142.493 + in
142.494 + (pat_bind, lambdas pats body, NoSyn)
142.495 + end;
142.496 + in
142.497 + val ((pat_consts, pat_defs), thy) =
142.498 + define_consts (map_index pat_eqn (bindings ~~ spec)) thy
142.499 + end;
142.500 +
142.501 + (* syntax translations for pattern combinators *)
142.502 + local
142.503 + open Syntax
142.504 + fun syntax c = Syntax.mark_const (fst (dest_Const c));
142.505 + fun app s (l, r) = Syntax.mk_appl (Constant s) [l, r];
142.506 + val capp = app @{const_syntax Rep_cfun};
142.507 + val capps = Library.foldl capp
142.508 +
142.509 + fun app_var x = Syntax.mk_appl (Constant "_variable") [x, Variable "rhs"];
142.510 + fun app_pat x = Syntax.mk_appl (Constant "_pat") [x];
142.511 + fun args_list [] = Constant "_noargs"
142.512 + | args_list xs = foldr1 (app "_args") xs;
142.513 + fun one_case_trans (pat, (con, args)) =
142.514 + let
142.515 + val cname = Constant (syntax con);
142.516 + val pname = Constant (syntax pat);
142.517 + val ns = 1 upto length args;
142.518 + val xs = map (fn n => Variable ("x"^(string_of_int n))) ns;
142.519 + val ps = map (fn n => Variable ("p"^(string_of_int n))) ns;
142.520 + val vs = map (fn n => Variable ("v"^(string_of_int n))) ns;
142.521 + in
142.522 + [ParseRule (app_pat (capps (cname, xs)),
142.523 + mk_appl pname (map app_pat xs)),
142.524 + ParseRule (app_var (capps (cname, xs)),
142.525 + app_var (args_list xs)),
142.526 + PrintRule (capps (cname, ListPair.map (app "_match") (ps,vs)),
142.527 + app "_match" (mk_appl pname ps, args_list vs))]
142.528 + end;
142.529 + val trans_rules : Syntax.ast Syntax.trrule list =
142.530 + maps one_case_trans (pat_consts ~~ spec);
142.531 + in
142.532 + val thy = Sign.add_trrules_i trans_rules thy;
142.533 + end;
142.534 +
142.535 + (* prove strictness and reduction rules of pattern combinators *)
142.536 + local
142.537 + val tns = map (fst o dest_TFree) (snd (dest_Type lhsT));
142.538 + val rn = Name.variant tns "'r";
142.539 + val R = TFree (rn, @{sort pcpo});
142.540 + fun pat_lhs (pat, args) =
142.541 + let
142.542 + val Ts = map snd args;
142.543 + val Vs =
142.544 + (map (K "'t") args)
142.545 + |> Datatype_Prop.indexify_names
142.546 + |> Name.variant_list (rn::tns)
142.547 + |> map (fn t => TFree (t, @{sort pcpo}));
142.548 + val patNs = Datatype_Prop.indexify_names (map (K "pat") args);
142.549 + val patTs = map2 (fn T => fn V => T ->> mk_matchT V) Ts Vs;
142.550 + val pats = map Free (patNs ~~ patTs);
142.551 + val k = Free ("rhs", mk_tupleT Vs ->> R);
142.552 + val branch1 = branch_const (lhsT, mk_tupleT Vs, R);
142.553 + val fun1 = (branch1 $ list_comb (pat, pats)) ` k;
142.554 + val branch2 = branch_const (mk_tupleT Ts, mk_tupleT Vs, R);
142.555 + val fun2 = (branch2 $ mk_tuple_pat pats) ` k;
142.556 + val taken = "rhs" :: patNs;
142.557 + in (fun1, fun2, taken) end;
142.558 + fun pat_strict (pat, (con, args)) =
142.559 + let
142.560 + val (fun1, fun2, taken) = pat_lhs (pat, args);
142.561 + val defs = @{thm branch_def} :: pat_defs;
142.562 + val goal = mk_trp (mk_strict fun1);
142.563 + val rules = @{thms match_bind_simps} @ case_rews;
142.564 + val tacs = [simp_tac (beta_ss addsimps rules) 1];
142.565 + in prove thy defs goal (K tacs) end;
142.566 + fun pat_apps (i, (pat, (con, args))) =
142.567 + let
142.568 + val (fun1, fun2, taken) = pat_lhs (pat, args);
142.569 + fun pat_app (j, (con', args')) =
142.570 + let
142.571 + val (vs, nonlazy) = get_vars_avoiding taken args';
142.572 + val con_app = list_ccomb (con', vs);
142.573 + val assms = map (mk_trp o mk_defined) nonlazy;
142.574 + val rhs = if i = j then fun2 ` mk_tuple vs else mk_fail R;
142.575 + val concl = mk_trp (mk_eq (fun1 ` con_app, rhs));
142.576 + val goal = Logic.list_implies (assms, concl);
142.577 + val defs = @{thm branch_def} :: pat_defs;
142.578 + val rules = @{thms match_bind_simps} @ case_rews;
142.579 + val tacs = [asm_simp_tac (beta_ss addsimps rules) 1];
142.580 + in prove thy defs goal (K tacs) end;
142.581 + in map_index pat_app spec end;
142.582 + in
142.583 + val pat_stricts = map pat_strict (pat_consts ~~ spec);
142.584 + val pat_apps = flat (map_index pat_apps (pat_consts ~~ spec));
142.585 + end;
142.586 +
142.587 + in
142.588 + (pat_stricts @ pat_apps, thy)
142.589 + end
142.590 +
142.591 +end
142.592 +*}
142.593 +
142.594 +(*
142.595 +Cut from HOLCF/Tools/domain_constructors.ML
142.596 +in function add_domain_constructors:
142.597 +
142.598 + ( * define and prove theorems for pattern combinators * )
142.599 + val (pat_thms : thm list, thy : theory) =
142.600 + let
142.601 + val bindings = map #1 spec;
142.602 + fun prep_arg (lazy, sel, T) = (lazy, T);
142.603 + fun prep_con c (b, args, mx) = (c, map prep_arg args);
142.604 + val pat_spec = map2 prep_con con_consts spec;
142.605 + in
142.606 + add_pattern_combinators bindings pat_spec lhsT
142.607 + exhaust case_const cases thy
142.608 + end
142.609 +
142.610 +*)
142.611 +
142.612 +end
143.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
143.2 +++ b/src/HOL/HOLCF/ex/Powerdomain_ex.thy Sat Nov 27 16:08:10 2010 -0800
143.3 @@ -0,0 +1,113 @@
143.4 +(* Title: HOLCF/ex/Powerdomain_ex.thy
143.5 + Author: Brian Huffman
143.6 +*)
143.7 +
143.8 +header {* Powerdomain examples *}
143.9 +
143.10 +theory Powerdomain_ex
143.11 +imports HOLCF
143.12 +begin
143.13 +
143.14 +subsection {* Monadic sorting example *}
143.15 +
143.16 +domain ordering = LT | EQ | GT
143.17 +
143.18 +definition
143.19 + compare :: "int lift \<rightarrow> int lift \<rightarrow> ordering" where
143.20 + "compare = (FLIFT x y. if x < y then LT else if x = y then EQ else GT)"
143.21 +
143.22 +definition
143.23 + is_le :: "int lift \<rightarrow> int lift \<rightarrow> tr" where
143.24 + "is_le = (\<Lambda> x y. case compare\<cdot>x\<cdot>y of LT \<Rightarrow> TT | EQ \<Rightarrow> TT | GT \<Rightarrow> FF)"
143.25 +
143.26 +definition
143.27 + is_less :: "int lift \<rightarrow> int lift \<rightarrow> tr" where
143.28 + "is_less = (\<Lambda> x y. case compare\<cdot>x\<cdot>y of LT \<Rightarrow> TT | EQ \<Rightarrow> FF | GT \<Rightarrow> FF)"
143.29 +
143.30 +definition
143.31 + r1 :: "(int lift \<times> 'a) \<rightarrow> (int lift \<times> 'a) \<rightarrow> tr convex_pd" where
143.32 + "r1 = (\<Lambda> (x,_) (y,_). case compare\<cdot>x\<cdot>y of
143.33 + LT \<Rightarrow> {TT}\<natural> |
143.34 + EQ \<Rightarrow> {TT, FF}\<natural> |
143.35 + GT \<Rightarrow> {FF}\<natural>)"
143.36 +
143.37 +definition
143.38 + r2 :: "(int lift \<times> 'a) \<rightarrow> (int lift \<times> 'a) \<rightarrow> tr convex_pd" where
143.39 + "r2 = (\<Lambda> (x,_) (y,_). {is_le\<cdot>x\<cdot>y, is_less\<cdot>x\<cdot>y}\<natural>)"
143.40 +
143.41 +lemma r1_r2: "r1\<cdot>(x,a)\<cdot>(y,b) = (r2\<cdot>(x,a)\<cdot>(y,b) :: tr convex_pd)"
143.42 +apply (simp add: r1_def r2_def)
143.43 +apply (simp add: is_le_def is_less_def)
143.44 +apply (cases "compare\<cdot>x\<cdot>y")
143.45 +apply simp_all
143.46 +done
143.47 +
143.48 +
143.49 +subsection {* Picking a leaf from a tree *}
143.50 +
143.51 +domain 'a tree =
143.52 + Node (lazy "'a tree") (lazy "'a tree") |
143.53 + Leaf (lazy "'a")
143.54 +
143.55 +fixrec
143.56 + mirror :: "'a tree \<rightarrow> 'a tree"
143.57 +where
143.58 + mirror_Leaf: "mirror\<cdot>(Leaf\<cdot>a) = Leaf\<cdot>a"
143.59 +| mirror_Node: "mirror\<cdot>(Node\<cdot>l\<cdot>r) = Node\<cdot>(mirror\<cdot>r)\<cdot>(mirror\<cdot>l)"
143.60 +
143.61 +lemma mirror_strict [simp]: "mirror\<cdot>\<bottom> = \<bottom>"
143.62 +by fixrec_simp
143.63 +
143.64 +fixrec
143.65 + pick :: "'a tree \<rightarrow> 'a convex_pd"
143.66 +where
143.67 + pick_Leaf: "pick\<cdot>(Leaf\<cdot>a) = {a}\<natural>"
143.68 +| pick_Node: "pick\<cdot>(Node\<cdot>l\<cdot>r) = pick\<cdot>l +\<natural> pick\<cdot>r"
143.69 +
143.70 +lemma pick_strict [simp]: "pick\<cdot>\<bottom> = \<bottom>"
143.71 +by fixrec_simp
143.72 +
143.73 +lemma pick_mirror: "pick\<cdot>(mirror\<cdot>t) = pick\<cdot>t"
143.74 +by (induct t) (simp_all add: convex_plus_ac)
143.75 +
143.76 +fixrec tree1 :: "int lift tree"
143.77 +where "tree1 = Node\<cdot>(Node\<cdot>(Leaf\<cdot>(Def 1))\<cdot>(Leaf\<cdot>(Def 2)))
143.78 + \<cdot>(Node\<cdot>(Leaf\<cdot>(Def 3))\<cdot>(Leaf\<cdot>(Def 4)))"
143.79 +
143.80 +fixrec tree2 :: "int lift tree"
143.81 +where "tree2 = Node\<cdot>(Node\<cdot>(Leaf\<cdot>(Def 1))\<cdot>(Leaf\<cdot>(Def 2)))
143.82 + \<cdot>(Node\<cdot>\<bottom>\<cdot>(Leaf\<cdot>(Def 4)))"
143.83 +
143.84 +fixrec tree3 :: "int lift tree"
143.85 +where "tree3 = Node\<cdot>(Node\<cdot>(Leaf\<cdot>(Def 1))\<cdot>tree3)
143.86 + \<cdot>(Node\<cdot>(Leaf\<cdot>(Def 3))\<cdot>(Leaf\<cdot>(Def 4)))"
143.87 +
143.88 +declare tree1.simps tree2.simps tree3.simps [simp del]
143.89 +
143.90 +lemma pick_tree1:
143.91 + "pick\<cdot>tree1 = {Def 1, Def 2, Def 3, Def 4}\<natural>"
143.92 +apply (subst tree1.simps)
143.93 +apply simp
143.94 +apply (simp add: convex_plus_ac)
143.95 +done
143.96 +
143.97 +lemma pick_tree2:
143.98 + "pick\<cdot>tree2 = {Def 1, Def 2, \<bottom>, Def 4}\<natural>"
143.99 +apply (subst tree2.simps)
143.100 +apply simp
143.101 +apply (simp add: convex_plus_ac)
143.102 +done
143.103 +
143.104 +lemma pick_tree3:
143.105 + "pick\<cdot>tree3 = {Def 1, \<bottom>, Def 3, Def 4}\<natural>"
143.106 +apply (subst tree3.simps)
143.107 +apply simp
143.108 +apply (induct rule: tree3.induct)
143.109 +apply simp
143.110 +apply simp
143.111 +apply (simp add: convex_plus_ac)
143.112 +apply simp
143.113 +apply (simp add: convex_plus_ac)
143.114 +done
143.115 +
143.116 +end
144.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
144.2 +++ b/src/HOL/HOLCF/ex/ROOT.ML Sat Nov 27 16:08:10 2010 -0800
144.3 @@ -0,0 +1,9 @@
144.4 +(* Title: HOLCF/ex/ROOT.ML
144.5 +
144.6 +Misc HOLCF examples.
144.7 +*)
144.8 +
144.9 +use_thys ["Dnat", "Dagstuhl", "Focus_ex", "Fix2", "Hoare",
144.10 + "Loop", "Powerdomain_ex", "Domain_Proofs",
144.11 + "Letrec",
144.12 + "Pattern_Match"];
145.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
145.2 +++ b/src/HOL/HOLCF/ex/hoare.txt Sat Nov 27 16:08:10 2010 -0800
145.3 @@ -0,0 +1,97 @@
145.4 +Proves about loops and tail-recursive functions
145.5 +===============================================
145.6 +
145.7 +Problem A
145.8 +
145.9 +P = while B1 do S od
145.10 +Q = while B1 or B2 do S od
145.11 +
145.12 +Prove P;Q = Q (provided B1, B2 have no side effects)
145.13 +
145.14 +------
145.15 +
145.16 +Looking at the denotational semantics of while, we get
145.17 +
145.18 +Problem B
145.19 +
145.20 +[|B1|]:State->Bool
145.21 +[|B2|]:State->Bool
145.22 +[|S |]:State->State
145.23 +f :State->State
145.24 +
145.25 +p = fix LAM f.LAM x. if [| B1 |] x then f([| S |] x) else x fi
145.26 +q = fix LAM f.LAM x. if [| B1 |] x orelse [|b2 |] x then f([| S |] x) else x fi
145.27 +
145.28 +Prove q o p = q rsp. ALL x.q(p(x))=q(x)
145.29 +
145.30 +Remark: 1. Bool is the three-valued domain {UU,FF,TT} since tests B1 and B2 may
145.31 + not terminate.
145.32 + 2. orelse is the sequential or like in ML
145.33 +
145.34 +----------
145.35 +
145.36 +If we abstract over the structure of stores we get
145.37 +
145.38 +Problem C
145.39 +
145.40 +b1:'a -> Bool
145.41 +b2:'a -> Bool
145.42 +g :'a ->'a
145.43 +h :'a ->'a
145.44 +
145.45 +p = fix LAM h.LAM x. if b1(x) then h(g(x)) else x fi
145.46 +q = fix LAM h.LAM x. if b1(x) orelse b2(x) then h(g(x)) else x fi
145.47 +
145.48 +where g is an abstraction of [| S |]
145.49 +
145.50 +Prove q o p = q
145.51 +
145.52 +Remark: there are no restrictions wrt. definedness or strictness for any of
145.53 + the involved functions.
145.54 +
145.55 +----------
145.56 +
145.57 +In a functional programming language the problem reads as follows:
145.58 +
145.59 +p(x) = if b1(x)
145.60 + then p(g(x))
145.61 + else x fi
145.62 +
145.63 +q(x) = if b1(x) orelse b2(x)
145.64 + then q(g(x))
145.65 + else x fi
145.66 +
145.67 +
145.68 +Prove: q o p = q
145.69 +
145.70 +
145.71 +-------------
145.72 +
145.73 +In you like to test the problem in ML (bad guy) you have to introduce
145.74 +formal parameters for b1,b2 and g.
145.75 +
145.76 +fun p b1 g x = if b1(x)
145.77 + then p b1 g (g(x))
145.78 + else x;
145.79 +
145.80 +
145.81 +fun q b1 b2 g x = if b1(x) orelse b2(x)
145.82 + then q b1 b2 g (g(x))
145.83 + else x;
145.84 +
145.85 +Prove: for all b1 b2 g .
145.86 + (q b1 b2 g) o (p b1 g) = (q b1 b2 g)
145.87 +
145.88 +===========
145.89 +
145.90 +It took 4 person-days to formulate and prove the problem C in the
145.91 +Isabelle logic HOLCF. The formalisation was done by conservative extension and
145.92 +all proof principles where derived from pure HOLCF.
145.93 +
145.94 +
145.95 +
145.96 +
145.97 +
145.98 +
145.99 +
145.100 +
146.1 --- a/src/HOL/IsaMakefile Sat Nov 27 14:34:54 2010 -0800
146.2 +++ b/src/HOL/IsaMakefile Sat Nov 27 16:08:10 2010 -0800
146.3 @@ -20,6 +20,8 @@
146.4 HOL-Proofs \
146.5 HOL-Word \
146.6 HOL4 \
146.7 + HOLCF \
146.8 + IOA \
146.9 TLA \
146.10 HOL-Base \
146.11 HOL-Main \
146.12 @@ -35,9 +37,18 @@
146.13 HOL-Hahn_Banach \
146.14 HOL-Hoare \
146.15 HOL-Hoare_Parallel \
146.16 + HOLCF-FOCUS \
146.17 + HOLCF-IMP \
146.18 + HOLCF-Library \
146.19 + HOLCF-Tutorial \
146.20 + HOLCF-ex \
146.21 HOL-IMP \
146.22 HOL-IMPP \
146.23 HOL-IOA \
146.24 + IOA-ABP \
146.25 + IOA-NTP \
146.26 + IOA-Storage \
146.27 + IOA-ex \
146.28 HOL-Imperative_HOL \
146.29 HOL-Import \
146.30 HOL-Induct \
146.31 @@ -1381,6 +1392,222 @@
146.32 @$(ISABELLE_TOOL) usedir $(OUT)/HOL Predicate_Compile_Examples
146.33
146.34
146.35 +## HOLCF
146.36 +
146.37 +HOLCF: HOL $(OUT)/HOLCF
146.38 +
146.39 +$(OUT)/HOLCF: $(OUT)/HOL \
146.40 + HOLCF/ROOT.ML \
146.41 + HOLCF/Adm.thy \
146.42 + HOLCF/Algebraic.thy \
146.43 + HOLCF/Bifinite.thy \
146.44 + HOLCF/Cfun.thy \
146.45 + HOLCF/CompactBasis.thy \
146.46 + HOLCF/Completion.thy \
146.47 + HOLCF/Cont.thy \
146.48 + HOLCF/ConvexPD.thy \
146.49 + HOLCF/Cpodef.thy \
146.50 + HOLCF/Cprod.thy \
146.51 + HOLCF/Discrete.thy \
146.52 + HOLCF/Deflation.thy \
146.53 + HOLCF/Domain.thy \
146.54 + HOLCF/Domain_Aux.thy \
146.55 + HOLCF/Fixrec.thy \
146.56 + HOLCF/Fix.thy \
146.57 + HOLCF/Fun_Cpo.thy \
146.58 + HOLCF/HOLCF.thy \
146.59 + HOLCF/Lift.thy \
146.60 + HOLCF/LowerPD.thy \
146.61 + HOLCF/Map_Functions.thy \
146.62 + HOLCF/One.thy \
146.63 + HOLCF/Pcpo.thy \
146.64 + HOLCF/Plain_HOLCF.thy \
146.65 + HOLCF/Porder.thy \
146.66 + HOLCF/Powerdomains.thy \
146.67 + HOLCF/Product_Cpo.thy \
146.68 + HOLCF/Sfun.thy \
146.69 + HOLCF/Sprod.thy \
146.70 + HOLCF/Ssum.thy \
146.71 + HOLCF/Tr.thy \
146.72 + HOLCF/Universal.thy \
146.73 + HOLCF/UpperPD.thy \
146.74 + HOLCF/Up.thy \
146.75 + HOLCF/Tools/cont_consts.ML \
146.76 + HOLCF/Tools/cont_proc.ML \
146.77 + HOLCF/Tools/holcf_library.ML \
146.78 + HOLCF/Tools/Domain/domain.ML \
146.79 + HOLCF/Tools/Domain/domain_axioms.ML \
146.80 + HOLCF/Tools/Domain/domain_constructors.ML \
146.81 + HOLCF/Tools/Domain/domain_induction.ML \
146.82 + HOLCF/Tools/Domain/domain_isomorphism.ML \
146.83 + HOLCF/Tools/Domain/domain_take_proofs.ML \
146.84 + HOLCF/Tools/cpodef.ML \
146.85 + HOLCF/Tools/domaindef.ML \
146.86 + HOLCF/Tools/fixrec.ML \
146.87 + HOLCF/document/root.tex
146.88 + @cd HOLCF; $(ISABELLE_TOOL) usedir -b -g true $(OUT)/HOL HOLCF
146.89 +
146.90 +
146.91 +## HOLCF-Tutorial
146.92 +
146.93 +HOLCF-Tutorial: HOLCF $(LOG)/HOLCF-Tutorial.gz
146.94 +
146.95 +$(LOG)/HOLCF-Tutorial.gz: $(OUT)/HOLCF \
146.96 + HOLCF/Tutorial/Domain_ex.thy \
146.97 + HOLCF/Tutorial/Fixrec_ex.thy \
146.98 + HOLCF/Tutorial/New_Domain.thy \
146.99 + HOLCF/Tutorial/document/root.tex \
146.100 + HOLCF/Tutorial/ROOT.ML
146.101 + @$(ISABELLE_TOOL) usedir $(OUT)/HOLCF Tutorial
146.102 +
146.103 +
146.104 +## HOLCF-Library
146.105 +
146.106 +HOLCF-Library: HOLCF $(LOG)/HOLCF-Library.gz
146.107 +
146.108 +$(LOG)/HOLCF-Library.gz: $(OUT)/HOLCF \
146.109 + HOLCF/Library/Defl_Bifinite.thy \
146.110 + HOLCF/Library/List_Cpo.thy \
146.111 + HOLCF/Library/Stream.thy \
146.112 + HOLCF/Library/Sum_Cpo.thy \
146.113 + HOLCF/Library/HOLCF_Library.thy \
146.114 + HOLCF/Library/ROOT.ML
146.115 + @$(ISABELLE_TOOL) usedir $(OUT)/HOLCF Library
146.116 +
146.117 +
146.118 +## HOLCF-IMP
146.119 +
146.120 +HOLCF-IMP: HOLCF $(LOG)/HOLCF-IMP.gz
146.121 +
146.122 +$(LOG)/HOLCF-IMP.gz: $(OUT)/HOLCF IMP/HoareEx.thy \
146.123 + HOLCF/IMP/Denotational.thy IMP/ROOT.ML IMP/document/root.tex
146.124 + @$(ISABELLE_TOOL) usedir $(OUT)/HOLCF IMP
146.125 +
146.126 +
146.127 +## HOLCF-ex
146.128 +
146.129 +HOLCF-ex: HOLCF $(LOG)/HOLCF-ex.gz
146.130 +
146.131 +$(LOG)/HOLCF-ex.gz: $(OUT)/HOLCF \
146.132 + HOLCF/../HOL/Library/Nat_Infinity.thy \
146.133 + HOLCF/ex/Dagstuhl.thy \
146.134 + HOLCF/ex/Dnat.thy \
146.135 + HOLCF/ex/Domain_Proofs.thy \
146.136 + HOLCF/ex/Fix2.thy \
146.137 + HOLCF/ex/Focus_ex.thy \
146.138 + HOLCF/ex/Hoare.thy \
146.139 + HOLCF/ex/Letrec.thy \
146.140 + HOLCF/ex/Loop.thy \
146.141 + HOLCF/ex/Pattern_Match.thy \
146.142 + HOLCF/ex/Powerdomain_ex.thy \
146.143 + HOLCF/ex/ROOT.ML
146.144 + @$(ISABELLE_TOOL) usedir $(OUT)/HOLCF ex
146.145 +
146.146 +
146.147 +## HOLCF-FOCUS
146.148 +
146.149 +HOLCF-FOCUS: HOLCF $(LOG)/HOLCF-FOCUS.gz
146.150 +
146.151 +$(LOG)/HOLCF-FOCUS.gz: $(OUT)/HOLCF \
146.152 + HOLCF/Library/Stream.thy \
146.153 + HOLCF/FOCUS/Fstreams.thy \
146.154 + HOLCF/FOCUS/Fstream.thy FOCUS/FOCUS.thy \
146.155 + HOLCF/FOCUS/Stream_adm.thy ../HOL/Library/Continuity.thy \
146.156 + HOLCF/FOCUS/Buffer.thy FOCUS/Buffer_adm.thy
146.157 + @$(ISABELLE_TOOL) usedir $(OUT)/HOLCF FOCUS
146.158 +
146.159 +## IOA
146.160 +
146.161 +IOA: HOLCF $(OUT)/IOA
146.162 +
146.163 +$(OUT)/IOA: $(OUT)/HOLCF \
146.164 + HOLCF/IOA/ROOT.ML \
146.165 + HOLCF/IOA/meta_theory/Traces.thy \
146.166 + HOLCF/IOA/meta_theory/Asig.thy \
146.167 + HOLCF/IOA/meta_theory/CompoScheds.thy \
146.168 + HOLCF/IOA/meta_theory/CompoTraces.thy \
146.169 + HOLCF/IOA/meta_theory/Seq.thy \
146.170 + HOLCF/IOA/meta_theory/RefCorrectness.thy \
146.171 + HOLCF/IOA/meta_theory/Automata.thy \
146.172 + HOLCF/IOA/meta_theory/ShortExecutions.thy \
146.173 + HOLCF/IOA/meta_theory/IOA.thy \
146.174 + HOLCF/IOA/meta_theory/Sequence.thy \
146.175 + HOLCF/IOA/meta_theory/CompoExecs.thy \
146.176 + HOLCF/IOA/meta_theory/RefMappings.thy \
146.177 + HOLCF/IOA/meta_theory/Compositionality.thy \
146.178 + HOLCF/IOA/meta_theory/TL.thy \
146.179 + HOLCF/IOA/meta_theory/TLS.thy \
146.180 + HOLCF/IOA/meta_theory/LiveIOA.thy \
146.181 + HOLCF/IOA/meta_theory/Pred.thy \
146.182 + HOLCF/IOA/meta_theory/Abstraction.thy \
146.183 + HOLCF/IOA/meta_theory/Simulations.thy \
146.184 + HOLCF/IOA/meta_theory/SimCorrectness.thy
146.185 + @cd HOLCF/IOA; $(ISABELLE_TOOL) usedir -b $(OUT)/HOLCF IOA
146.186 +
146.187 +## IOA-ABP
146.188 +
146.189 +IOA-ABP: IOA $(LOG)/IOA-ABP.gz
146.190 +
146.191 +$(LOG)/IOA-ABP.gz: $(OUT)/IOA \
146.192 + HOLCF/IOA/ABP/Abschannel.thy \
146.193 + HOLCF/IOA/ABP/Abschannel_finite.thy \
146.194 + HOLCF/IOA/ABP/Action.thy \
146.195 + HOLCF/IOA/ABP/Check.ML \
146.196 + HOLCF/IOA/ABP/Correctness.thy \
146.197 + HOLCF/IOA/ABP/Env.thy \
146.198 + HOLCF/IOA/ABP/Impl.thy \
146.199 + HOLCF/IOA/ABP/Impl_finite.thy \
146.200 + HOLCF/IOA/ABP/Lemmas.thy \
146.201 + HOLCF/IOA/ABP/Packet.thy \
146.202 + HOLCF/IOA/ABP/ROOT.ML \
146.203 + HOLCF/IOA/ABP/Receiver.thy \
146.204 + HOLCF/IOA/ABP/Sender.thy \
146.205 + HOLCF/IOA/ABP/Spec.thy
146.206 + @cd HOLCF/IOA; $(ISABELLE_TOOL) usedir $(OUT)/IOA ABP
146.207 +
146.208 +## IOA-NTP
146.209 +
146.210 +IOA-NTP: IOA $(LOG)/IOA-NTP.gz
146.211 +
146.212 +$(LOG)/IOA-NTP.gz: $(OUT)/IOA \
146.213 + HOLCF/IOA/NTP/Abschannel.thy \
146.214 + HOLCF/IOA/NTP/Action.thy \
146.215 + HOLCF/IOA/NTP/Correctness.thy \
146.216 + HOLCF/IOA/NTP/Impl.thy \
146.217 + HOLCF/IOA/NTP/Lemmas.thy \
146.218 + HOLCF/IOA/NTP/Multiset.thy \
146.219 + HOLCF/IOA/NTP/Packet.thy \
146.220 + HOLCF/IOA/NTP/ROOT.ML \
146.221 + HOLCF/IOA/NTP/Receiver.thy \
146.222 + HOLCF/IOA/NTP/Sender.thy \
146.223 + HOLCF/IOA/NTP/Spec.thy
146.224 + @cd HOLCF/IOA; $(ISABELLE_TOOL) usedir $(OUT)/IOA NTP
146.225 +
146.226 +
146.227 +## IOA-Storage
146.228 +
146.229 +IOA-Storage: IOA $(LOG)/IOA-Storage.gz
146.230 +
146.231 +$(LOG)/IOA-Storage.gz: $(OUT)/IOA \
146.232 + HOLCF/IOA/Storage/Action.thy \
146.233 + HOLCF/IOA/Storage/Correctness.thy \
146.234 + HOLCF/IOA/Storage/Impl.thy \
146.235 + HOLCF/IOA/Storage/ROOT.ML \
146.236 + HOLCF/IOA/Storage/Spec.thy
146.237 + @cd HOLCF/IOA; $(ISABELLE_TOOL) usedir $(OUT)/IOA Storage
146.238 +
146.239 +
146.240 +## IOA-ex
146.241 +
146.242 +IOA-ex: IOA $(LOG)/IOA-ex.gz
146.243 +
146.244 +$(LOG)/IOA-ex.gz: $(OUT)/IOA \
146.245 + HOLCF/IOA/ex/ROOT.ML \
146.246 + HOLCF/IOA/ex/TrivEx.thy \
146.247 + HOLCF/IOA/ex/TrivEx2.thy
146.248 + @cd HOLCF/IOA; $(ISABELLE_TOOL) usedir $(OUT)/IOA ex
146.249 +
146.250 +
146.251 ## clean
146.252
146.253 clean:
146.254 @@ -1419,4 +1646,9 @@
146.255 $(OUT)/HOL-Main $(OUT)/HOL-Multivariate_Analysis \
146.256 $(OUT)/HOL-NSA $(OUT)/HOL-Nominal $(OUT)/HOL-Plain \
146.257 $(OUT)/HOL-Probability $(OUT)/HOL-Proofs \
146.258 - $(OUT)/HOL-Word $(OUT)/HOL4 $(OUT)/TLA
146.259 + $(OUT)/HOL-Word $(OUT)/HOL4 $(OUT)/TLA \
146.260 + $(OUT)/HOLCF $(LOG)/HOLCF.gz $(LOG)/HOLCF-IMP.gz \
146.261 + $(LOG)/HOLCF-ex.gz $(LOG)/HOLCF-FOCUS.gz $(OUT)/IOA \
146.262 + $(LOG)/IOA.gz $(LOG)/IOA-ABP.gz $(LOG)/IOA-NTP.gz \
146.263 + $(LOG)/IOA-Storage.gz $(LOG)/HOLCF-Library.gz \
146.264 + $(LOG)/IOA-ex.gz $(LOG)/HOLCF-Tutorial.gz
147.1 --- a/src/HOLCF/Adm.thy Sat Nov 27 14:34:54 2010 -0800
147.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
147.3 @@ -1,193 +0,0 @@
147.4 -(* Title: HOLCF/Adm.thy
147.5 - Author: Franz Regensburger and Brian Huffman
147.6 -*)
147.7 -
147.8 -header {* Admissibility and compactness *}
147.9 -
147.10 -theory Adm
147.11 -imports Cont
147.12 -begin
147.13 -
147.14 -default_sort cpo
147.15 -
147.16 -subsection {* Definitions *}
147.17 -
147.18 -definition
147.19 - adm :: "('a::cpo \<Rightarrow> bool) \<Rightarrow> bool" where
147.20 - "adm P = (\<forall>Y. chain Y \<longrightarrow> (\<forall>i. P (Y i)) \<longrightarrow> P (\<Squnion>i. Y i))"
147.21 -
147.22 -lemma admI:
147.23 - "(\<And>Y. \<lbrakk>chain Y; \<forall>i. P (Y i)\<rbrakk> \<Longrightarrow> P (\<Squnion>i. Y i)) \<Longrightarrow> adm P"
147.24 -unfolding adm_def by fast
147.25 -
147.26 -lemma admD: "\<lbrakk>adm P; chain Y; \<And>i. P (Y i)\<rbrakk> \<Longrightarrow> P (\<Squnion>i. Y i)"
147.27 -unfolding adm_def by fast
147.28 -
147.29 -lemma admD2: "\<lbrakk>adm (\<lambda>x. \<not> P x); chain Y; P (\<Squnion>i. Y i)\<rbrakk> \<Longrightarrow> \<exists>i. P (Y i)"
147.30 -unfolding adm_def by fast
147.31 -
147.32 -lemma triv_admI: "\<forall>x. P x \<Longrightarrow> adm P"
147.33 -by (rule admI, erule spec)
147.34 -
147.35 -subsection {* Admissibility on chain-finite types *}
147.36 -
147.37 -text {* For chain-finite (easy) types every formula is admissible. *}
147.38 -
147.39 -lemma adm_chfin [simp]: "adm (P::'a::chfin \<Rightarrow> bool)"
147.40 -by (rule admI, frule chfin, auto simp add: maxinch_is_thelub)
147.41 -
147.42 -subsection {* Admissibility of special formulae and propagation *}
147.43 -
147.44 -lemma adm_const [simp]: "adm (\<lambda>x. t)"
147.45 -by (rule admI, simp)
147.46 -
147.47 -lemma adm_conj [simp]:
147.48 - "\<lbrakk>adm (\<lambda>x. P x); adm (\<lambda>x. Q x)\<rbrakk> \<Longrightarrow> adm (\<lambda>x. P x \<and> Q x)"
147.49 -by (fast intro: admI elim: admD)
147.50 -
147.51 -lemma adm_all [simp]:
147.52 - "(\<And>y. adm (\<lambda>x. P x y)) \<Longrightarrow> adm (\<lambda>x. \<forall>y. P x y)"
147.53 -by (fast intro: admI elim: admD)
147.54 -
147.55 -lemma adm_ball [simp]:
147.56 - "(\<And>y. y \<in> A \<Longrightarrow> adm (\<lambda>x. P x y)) \<Longrightarrow> adm (\<lambda>x. \<forall>y\<in>A. P x y)"
147.57 -by (fast intro: admI elim: admD)
147.58 -
147.59 -text {* Admissibility for disjunction is hard to prove. It requires 2 lemmas. *}
147.60 -
147.61 -lemma adm_disj_lemma1:
147.62 - assumes adm: "adm P"
147.63 - assumes chain: "chain Y"
147.64 - assumes P: "\<forall>i. \<exists>j\<ge>i. P (Y j)"
147.65 - shows "P (\<Squnion>i. Y i)"
147.66 -proof -
147.67 - def f \<equiv> "\<lambda>i. LEAST j. i \<le> j \<and> P (Y j)"
147.68 - have chain': "chain (\<lambda>i. Y (f i))"
147.69 - unfolding f_def
147.70 - apply (rule chainI)
147.71 - apply (rule chain_mono [OF chain])
147.72 - apply (rule Least_le)
147.73 - apply (rule LeastI2_ex)
147.74 - apply (simp_all add: P)
147.75 - done
147.76 - have f1: "\<And>i. i \<le> f i" and f2: "\<And>i. P (Y (f i))"
147.77 - using LeastI_ex [OF P [rule_format]] by (simp_all add: f_def)
147.78 - have lub_eq: "(\<Squnion>i. Y i) = (\<Squnion>i. Y (f i))"
147.79 - apply (rule below_antisym)
147.80 - apply (rule lub_mono [OF chain chain'])
147.81 - apply (rule chain_mono [OF chain f1])
147.82 - apply (rule lub_range_mono [OF _ chain chain'])
147.83 - apply clarsimp
147.84 - done
147.85 - show "P (\<Squnion>i. Y i)"
147.86 - unfolding lub_eq using adm chain' f2 by (rule admD)
147.87 -qed
147.88 -
147.89 -lemma adm_disj_lemma2:
147.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)"
147.91 -apply (erule contrapos_pp)
147.92 -apply (clarsimp, rename_tac a b)
147.93 -apply (rule_tac x="max a b" in exI)
147.94 -apply simp
147.95 -done
147.96 -
147.97 -lemma adm_disj [simp]:
147.98 - "\<lbrakk>adm (\<lambda>x. P x); adm (\<lambda>x. Q x)\<rbrakk> \<Longrightarrow> adm (\<lambda>x. P x \<or> Q x)"
147.99 -apply (rule admI)
147.100 -apply (erule adm_disj_lemma2 [THEN disjE])
147.101 -apply (erule (2) adm_disj_lemma1 [THEN disjI1])
147.102 -apply (erule (2) adm_disj_lemma1 [THEN disjI2])
147.103 -done
147.104 -
147.105 -lemma adm_imp [simp]:
147.106 - "\<lbrakk>adm (\<lambda>x. \<not> P x); adm (\<lambda>x. Q x)\<rbrakk> \<Longrightarrow> adm (\<lambda>x. P x \<longrightarrow> Q x)"
147.107 -by (subst imp_conv_disj, rule adm_disj)
147.108 -
147.109 -lemma adm_iff [simp]:
147.110 - "\<lbrakk>adm (\<lambda>x. P x \<longrightarrow> Q x); adm (\<lambda>x. Q x \<longrightarrow> P x)\<rbrakk>
147.111 - \<Longrightarrow> adm (\<lambda>x. P x = Q x)"
147.112 -by (subst iff_conv_conj_imp, rule adm_conj)
147.113 -
147.114 -text {* admissibility and continuity *}
147.115 -
147.116 -lemma adm_below [simp]:
147.117 - "\<lbrakk>cont (\<lambda>x. u x); cont (\<lambda>x. v x)\<rbrakk> \<Longrightarrow> adm (\<lambda>x. u x \<sqsubseteq> v x)"
147.118 -by (simp add: adm_def cont2contlubE lub_mono ch2ch_cont)
147.119 -
147.120 -lemma adm_eq [simp]:
147.121 - "\<lbrakk>cont (\<lambda>x. u x); cont (\<lambda>x. v x)\<rbrakk> \<Longrightarrow> adm (\<lambda>x. u x = v x)"
147.122 -by (simp add: po_eq_conv)
147.123 -
147.124 -lemma adm_subst: "\<lbrakk>cont (\<lambda>x. t x); adm P\<rbrakk> \<Longrightarrow> adm (\<lambda>x. P (t x))"
147.125 -by (simp add: adm_def cont2contlubE ch2ch_cont)
147.126 -
147.127 -lemma adm_not_below [simp]: "cont (\<lambda>x. t x) \<Longrightarrow> adm (\<lambda>x. \<not> t x \<sqsubseteq> u)"
147.128 -by (rule admI, simp add: cont2contlubE ch2ch_cont lub_below_iff)
147.129 -
147.130 -subsection {* Compactness *}
147.131 -
147.132 -definition
147.133 - compact :: "'a::cpo \<Rightarrow> bool" where
147.134 - "compact k = adm (\<lambda>x. \<not> k \<sqsubseteq> x)"
147.135 -
147.136 -lemma compactI: "adm (\<lambda>x. \<not> k \<sqsubseteq> x) \<Longrightarrow> compact k"
147.137 -unfolding compact_def .
147.138 -
147.139 -lemma compactD: "compact k \<Longrightarrow> adm (\<lambda>x. \<not> k \<sqsubseteq> x)"
147.140 -unfolding compact_def .
147.141 -
147.142 -lemma compactI2:
147.143 - "(\<And>Y. \<lbrakk>chain Y; x \<sqsubseteq> (\<Squnion>i. Y i)\<rbrakk> \<Longrightarrow> \<exists>i. x \<sqsubseteq> Y i) \<Longrightarrow> compact x"
147.144 -unfolding compact_def adm_def by fast
147.145 -
147.146 -lemma compactD2:
147.147 - "\<lbrakk>compact x; chain Y; x \<sqsubseteq> (\<Squnion>i. Y i)\<rbrakk> \<Longrightarrow> \<exists>i. x \<sqsubseteq> Y i"
147.148 -unfolding compact_def adm_def by fast
147.149 -
147.150 -lemma compact_below_lub_iff:
147.151 - "\<lbrakk>compact x; chain Y\<rbrakk> \<Longrightarrow> x \<sqsubseteq> (\<Squnion>i. Y i) \<longleftrightarrow> (\<exists>i. x \<sqsubseteq> Y i)"
147.152 -by (fast intro: compactD2 elim: below_lub)
147.153 -
147.154 -lemma compact_chfin [simp]: "compact (x::'a::chfin)"
147.155 -by (rule compactI [OF adm_chfin])
147.156 -
147.157 -lemma compact_imp_max_in_chain:
147.158 - "\<lbrakk>chain Y; compact (\<Squnion>i. Y i)\<rbrakk> \<Longrightarrow> \<exists>i. max_in_chain i Y"
147.159 -apply (drule (1) compactD2, simp)
147.160 -apply (erule exE, rule_tac x=i in exI)
147.161 -apply (rule max_in_chainI)
147.162 -apply (rule below_antisym)
147.163 -apply (erule (1) chain_mono)
147.164 -apply (erule (1) below_trans [OF is_ub_thelub])
147.165 -done
147.166 -
147.167 -text {* admissibility and compactness *}
147.168 -
147.169 -lemma adm_compact_not_below [simp]:
147.170 - "\<lbrakk>compact k; cont (\<lambda>x. t x)\<rbrakk> \<Longrightarrow> adm (\<lambda>x. \<not> k \<sqsubseteq> t x)"
147.171 -unfolding compact_def by (rule adm_subst)
147.172 -
147.173 -lemma adm_neq_compact [simp]:
147.174 - "\<lbrakk>compact k; cont (\<lambda>x. t x)\<rbrakk> \<Longrightarrow> adm (\<lambda>x. t x \<noteq> k)"
147.175 -by (simp add: po_eq_conv)
147.176 -
147.177 -lemma adm_compact_neq [simp]:
147.178 - "\<lbrakk>compact k; cont (\<lambda>x. t x)\<rbrakk> \<Longrightarrow> adm (\<lambda>x. k \<noteq> t x)"
147.179 -by (simp add: po_eq_conv)
147.180 -
147.181 -lemma compact_UU [simp, intro]: "compact \<bottom>"
147.182 -by (rule compactI, simp)
147.183 -
147.184 -text {* Any upward-closed predicate is admissible. *}
147.185 -
147.186 -lemma adm_upward:
147.187 - assumes P: "\<And>x y. \<lbrakk>P x; x \<sqsubseteq> y\<rbrakk> \<Longrightarrow> P y"
147.188 - shows "adm P"
147.189 -by (rule admI, drule spec, erule P, erule is_ub_thelub)
147.190 -
147.191 -lemmas adm_lemmas =
147.192 - adm_const adm_conj adm_all adm_ball adm_disj adm_imp adm_iff
147.193 - adm_below adm_eq adm_not_below
147.194 - adm_compact_not_below adm_compact_neq adm_neq_compact
147.195 -
147.196 -end
148.1 --- a/src/HOLCF/Algebraic.thy Sat Nov 27 14:34:54 2010 -0800
148.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
148.3 @@ -1,214 +0,0 @@
148.4 -(* Title: HOLCF/Algebraic.thy
148.5 - Author: Brian Huffman
148.6 -*)
148.7 -
148.8 -header {* Algebraic deflations *}
148.9 -
148.10 -theory Algebraic
148.11 -imports Universal Map_Functions
148.12 -begin
148.13 -
148.14 -subsection {* Type constructor for finite deflations *}
148.15 -
148.16 -typedef (open) fin_defl = "{d::udom \<rightarrow> udom. finite_deflation d}"
148.17 -by (fast intro: finite_deflation_UU)
148.18 -
148.19 -instantiation fin_defl :: below
148.20 -begin
148.21 -
148.22 -definition below_fin_defl_def:
148.23 - "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep_fin_defl x \<sqsubseteq> Rep_fin_defl y"
148.24 -
148.25 -instance ..
148.26 -end
148.27 -
148.28 -instance fin_defl :: po
148.29 -using type_definition_fin_defl below_fin_defl_def
148.30 -by (rule typedef_po)
148.31 -
148.32 -lemma finite_deflation_Rep_fin_defl: "finite_deflation (Rep_fin_defl d)"
148.33 -using Rep_fin_defl by simp
148.34 -
148.35 -lemma deflation_Rep_fin_defl: "deflation (Rep_fin_defl d)"
148.36 -using finite_deflation_Rep_fin_defl
148.37 -by (rule finite_deflation_imp_deflation)
148.38 -
148.39 -interpretation Rep_fin_defl: finite_deflation "Rep_fin_defl d"
148.40 -by (rule finite_deflation_Rep_fin_defl)
148.41 -
148.42 -lemma fin_defl_belowI:
148.43 - "(\<And>x. Rep_fin_defl a\<cdot>x = x \<Longrightarrow> Rep_fin_defl b\<cdot>x = x) \<Longrightarrow> a \<sqsubseteq> b"
148.44 -unfolding below_fin_defl_def
148.45 -by (rule Rep_fin_defl.belowI)
148.46 -
148.47 -lemma fin_defl_belowD:
148.48 - "\<lbrakk>a \<sqsubseteq> b; Rep_fin_defl a\<cdot>x = x\<rbrakk> \<Longrightarrow> Rep_fin_defl b\<cdot>x = x"
148.49 -unfolding below_fin_defl_def
148.50 -by (rule Rep_fin_defl.belowD)
148.51 -
148.52 -lemma fin_defl_eqI:
148.53 - "(\<And>x. Rep_fin_defl a\<cdot>x = x \<longleftrightarrow> Rep_fin_defl b\<cdot>x = x) \<Longrightarrow> a = b"
148.54 -apply (rule below_antisym)
148.55 -apply (rule fin_defl_belowI, simp)
148.56 -apply (rule fin_defl_belowI, simp)
148.57 -done
148.58 -
148.59 -lemma Rep_fin_defl_mono: "a \<sqsubseteq> b \<Longrightarrow> Rep_fin_defl a \<sqsubseteq> Rep_fin_defl b"
148.60 -unfolding below_fin_defl_def .
148.61 -
148.62 -lemma Abs_fin_defl_mono:
148.63 - "\<lbrakk>finite_deflation a; finite_deflation b; a \<sqsubseteq> b\<rbrakk>
148.64 - \<Longrightarrow> Abs_fin_defl a \<sqsubseteq> Abs_fin_defl b"
148.65 -unfolding below_fin_defl_def
148.66 -by (simp add: Abs_fin_defl_inverse)
148.67 -
148.68 -lemma (in finite_deflation) compact_belowI:
148.69 - assumes "\<And>x. compact x \<Longrightarrow> d\<cdot>x = x \<Longrightarrow> f\<cdot>x = x" shows "d \<sqsubseteq> f"
148.70 -by (rule belowI, rule assms, erule subst, rule compact)
148.71 -
148.72 -lemma compact_Rep_fin_defl [simp]: "compact (Rep_fin_defl a)"
148.73 -using finite_deflation_Rep_fin_defl
148.74 -by (rule finite_deflation_imp_compact)
148.75 -
148.76 -subsection {* Defining algebraic deflations by ideal completion *}
148.77 -
148.78 -typedef (open) defl = "{S::fin_defl set. below.ideal S}"
148.79 -by (fast intro: below.ideal_principal)
148.80 -
148.81 -instantiation defl :: below
148.82 -begin
148.83 -
148.84 -definition
148.85 - "x \<sqsubseteq> y \<longleftrightarrow> Rep_defl x \<subseteq> Rep_defl y"
148.86 -
148.87 -instance ..
148.88 -end
148.89 -
148.90 -instance defl :: po
148.91 -using type_definition_defl below_defl_def
148.92 -by (rule below.typedef_ideal_po)
148.93 -
148.94 -instance defl :: cpo
148.95 -using type_definition_defl below_defl_def
148.96 -by (rule below.typedef_ideal_cpo)
148.97 -
148.98 -definition
148.99 - defl_principal :: "fin_defl \<Rightarrow> defl" where
148.100 - "defl_principal t = Abs_defl {u. u \<sqsubseteq> t}"
148.101 -
148.102 -lemma fin_defl_countable: "\<exists>f::fin_defl \<Rightarrow> nat. inj f"
148.103 -proof
148.104 - have *: "\<And>d. finite (approx_chain.place udom_approx `
148.105 - Rep_compact_basis -` {x. Rep_fin_defl d\<cdot>x = x})"
148.106 - apply (rule finite_imageI)
148.107 - apply (rule finite_vimageI)
148.108 - apply (rule Rep_fin_defl.finite_fixes)
148.109 - apply (simp add: inj_on_def Rep_compact_basis_inject)
148.110 - done
148.111 - have range_eq: "range Rep_compact_basis = {x. compact x}"
148.112 - using type_definition_compact_basis by (rule type_definition.Rep_range)
148.113 - show "inj (\<lambda>d. set_encode
148.114 - (approx_chain.place udom_approx ` Rep_compact_basis -` {x. Rep_fin_defl d\<cdot>x = x}))"
148.115 - apply (rule inj_onI)
148.116 - apply (simp only: set_encode_eq *)
148.117 - apply (simp only: inj_image_eq_iff approx_chain.inj_place [OF udom_approx])
148.118 - apply (drule_tac f="image Rep_compact_basis" in arg_cong)
148.119 - apply (simp del: vimage_Collect_eq add: range_eq set_eq_iff)
148.120 - apply (rule Rep_fin_defl_inject [THEN iffD1])
148.121 - apply (rule below_antisym)
148.122 - apply (rule Rep_fin_defl.compact_belowI, rename_tac z)
148.123 - apply (drule_tac x=z in spec, simp)
148.124 - apply (rule Rep_fin_defl.compact_belowI, rename_tac z)
148.125 - apply (drule_tac x=z in spec, simp)
148.126 - done
148.127 -qed
148.128 -
148.129 -interpretation defl: ideal_completion below defl_principal Rep_defl
148.130 -using type_definition_defl below_defl_def
148.131 -using defl_principal_def fin_defl_countable
148.132 -by (rule below.typedef_ideal_completion)
148.133 -
148.134 -text {* Algebraic deflations are pointed *}
148.135 -
148.136 -lemma defl_minimal: "defl_principal (Abs_fin_defl \<bottom>) \<sqsubseteq> x"
148.137 -apply (induct x rule: defl.principal_induct, simp)
148.138 -apply (rule defl.principal_mono)
148.139 -apply (simp add: below_fin_defl_def)
148.140 -apply (simp add: Abs_fin_defl_inverse finite_deflation_UU)
148.141 -done
148.142 -
148.143 -instance defl :: pcpo
148.144 -by intro_classes (fast intro: defl_minimal)
148.145 -
148.146 -lemma inst_defl_pcpo: "\<bottom> = defl_principal (Abs_fin_defl \<bottom>)"
148.147 -by (rule defl_minimal [THEN UU_I, symmetric])
148.148 -
148.149 -subsection {* Applying algebraic deflations *}
148.150 -
148.151 -definition
148.152 - cast :: "defl \<rightarrow> udom \<rightarrow> udom"
148.153 -where
148.154 - "cast = defl.basis_fun Rep_fin_defl"
148.155 -
148.156 -lemma cast_defl_principal:
148.157 - "cast\<cdot>(defl_principal a) = Rep_fin_defl a"
148.158 -unfolding cast_def
148.159 -apply (rule defl.basis_fun_principal)
148.160 -apply (simp only: below_fin_defl_def)
148.161 -done
148.162 -
148.163 -lemma deflation_cast: "deflation (cast\<cdot>d)"
148.164 -apply (induct d rule: defl.principal_induct)
148.165 -apply (rule adm_subst [OF _ adm_deflation], simp)
148.166 -apply (simp add: cast_defl_principal)
148.167 -apply (rule finite_deflation_imp_deflation)
148.168 -apply (rule finite_deflation_Rep_fin_defl)
148.169 -done
148.170 -
148.171 -lemma finite_deflation_cast:
148.172 - "compact d \<Longrightarrow> finite_deflation (cast\<cdot>d)"
148.173 -apply (drule defl.compact_imp_principal, clarify)
148.174 -apply (simp add: cast_defl_principal)
148.175 -apply (rule finite_deflation_Rep_fin_defl)
148.176 -done
148.177 -
148.178 -interpretation cast: deflation "cast\<cdot>d"
148.179 -by (rule deflation_cast)
148.180 -
148.181 -declare cast.idem [simp]
148.182 -
148.183 -lemma compact_cast [simp]: "compact d \<Longrightarrow> compact (cast\<cdot>d)"
148.184 -apply (rule finite_deflation_imp_compact)
148.185 -apply (erule finite_deflation_cast)
148.186 -done
148.187 -
148.188 -lemma cast_below_cast: "cast\<cdot>A \<sqsubseteq> cast\<cdot>B \<longleftrightarrow> A \<sqsubseteq> B"
148.189 -apply (induct A rule: defl.principal_induct, simp)
148.190 -apply (induct B rule: defl.principal_induct, simp)
148.191 -apply (simp add: cast_defl_principal below_fin_defl_def)
148.192 -done
148.193 -
148.194 -lemma compact_cast_iff: "compact (cast\<cdot>d) \<longleftrightarrow> compact d"
148.195 -apply (rule iffI)
148.196 -apply (simp only: compact_def cast_below_cast [symmetric])
148.197 -apply (erule adm_subst [OF cont_Rep_cfun2])
148.198 -apply (erule compact_cast)
148.199 -done
148.200 -
148.201 -lemma cast_below_imp_below: "cast\<cdot>A \<sqsubseteq> cast\<cdot>B \<Longrightarrow> A \<sqsubseteq> B"
148.202 -by (simp only: cast_below_cast)
148.203 -
148.204 -lemma cast_eq_imp_eq: "cast\<cdot>A = cast\<cdot>B \<Longrightarrow> A = B"
148.205 -by (simp add: below_antisym cast_below_imp_below)
148.206 -
148.207 -lemma cast_strict1 [simp]: "cast\<cdot>\<bottom> = \<bottom>"
148.208 -apply (subst inst_defl_pcpo)
148.209 -apply (subst cast_defl_principal)
148.210 -apply (rule Abs_fin_defl_inverse)
148.211 -apply (simp add: finite_deflation_UU)
148.212 -done
148.213 -
148.214 -lemma cast_strict2 [simp]: "cast\<cdot>A\<cdot>\<bottom> = \<bottom>"
148.215 -by (rule cast.below [THEN UU_I])
148.216 -
148.217 -end
149.1 --- a/src/HOLCF/Bifinite.thy Sat Nov 27 14:34:54 2010 -0800
149.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
149.3 @@ -1,800 +0,0 @@
149.4 -(* Title: HOLCF/Bifinite.thy
149.5 - Author: Brian Huffman
149.6 -*)
149.7 -
149.8 -header {* Bifinite domains *}
149.9 -
149.10 -theory Bifinite
149.11 -imports Algebraic Map_Functions Countable
149.12 -begin
149.13 -
149.14 -subsection {* Class of bifinite domains *}
149.15 -
149.16 -text {*
149.17 - We define a ``domain'' as a pcpo that is isomorphic to some
149.18 - algebraic deflation over the universal domain; this is equivalent
149.19 - to being omega-bifinite.
149.20 -
149.21 - A predomain is a cpo that, when lifted, becomes a domain.
149.22 -*}
149.23 -
149.24 -class predomain = cpo +
149.25 - fixes liftdefl :: "('a::cpo) itself \<Rightarrow> defl"
149.26 - fixes liftemb :: "'a\<^sub>\<bottom> \<rightarrow> udom"
149.27 - fixes liftprj :: "udom \<rightarrow> 'a\<^sub>\<bottom>"
149.28 - assumes predomain_ep: "ep_pair liftemb liftprj"
149.29 - assumes cast_liftdefl: "cast\<cdot>(liftdefl TYPE('a::cpo)) = liftemb oo liftprj"
149.30 -
149.31 -syntax "_LIFTDEFL" :: "type \<Rightarrow> logic" ("(1LIFTDEFL/(1'(_')))")
149.32 -translations "LIFTDEFL('t)" \<rightleftharpoons> "CONST liftdefl TYPE('t)"
149.33 -
149.34 -class "domain" = predomain + pcpo +
149.35 - fixes emb :: "'a::cpo \<rightarrow> udom"
149.36 - fixes prj :: "udom \<rightarrow> 'a::cpo"
149.37 - fixes defl :: "'a itself \<Rightarrow> defl"
149.38 - assumes ep_pair_emb_prj: "ep_pair emb prj"
149.39 - assumes cast_DEFL: "cast\<cdot>(defl TYPE('a)) = emb oo prj"
149.40 -
149.41 -syntax "_DEFL" :: "type \<Rightarrow> defl" ("(1DEFL/(1'(_')))")
149.42 -translations "DEFL('t)" \<rightleftharpoons> "CONST defl TYPE('t)"
149.43 -
149.44 -interpretation "domain": pcpo_ep_pair emb prj
149.45 - unfolding pcpo_ep_pair_def
149.46 - by (rule ep_pair_emb_prj)
149.47 -
149.48 -lemmas emb_inverse = domain.e_inverse
149.49 -lemmas emb_prj_below = domain.e_p_below
149.50 -lemmas emb_eq_iff = domain.e_eq_iff
149.51 -lemmas emb_strict = domain.e_strict
149.52 -lemmas prj_strict = domain.p_strict
149.53 -
149.54 -subsection {* Domains have a countable compact basis *}
149.55 -
149.56 -text {*
149.57 - Eventually it should be possible to generalize this to an unpointed
149.58 - variant of the domain class.
149.59 -*}
149.60 -
149.61 -interpretation compact_basis:
149.62 - ideal_completion below Rep_compact_basis "approximants::'a::domain \<Rightarrow> _"
149.63 -proof -
149.64 - obtain Y where Y: "\<forall>i. Y i \<sqsubseteq> Y (Suc i)"
149.65 - and DEFL: "DEFL('a) = (\<Squnion>i. defl_principal (Y i))"
149.66 - by (rule defl.obtain_principal_chain)
149.67 - def approx \<equiv> "\<lambda>i. (prj oo cast\<cdot>(defl_principal (Y i)) oo emb) :: 'a \<rightarrow> 'a"
149.68 - interpret defl_approx: approx_chain approx
149.69 - proof (rule approx_chain.intro)
149.70 - show "chain (\<lambda>i. approx i)"
149.71 - unfolding approx_def by (simp add: Y)
149.72 - show "(\<Squnion>i. approx i) = ID"
149.73 - unfolding approx_def
149.74 - by (simp add: lub_distribs Y DEFL [symmetric] cast_DEFL cfun_eq_iff)
149.75 - show "\<And>i. finite_deflation (approx i)"
149.76 - unfolding approx_def
149.77 - apply (rule domain.finite_deflation_p_d_e)
149.78 - apply (rule finite_deflation_cast)
149.79 - apply (rule defl.compact_principal)
149.80 - apply (rule below_trans [OF monofun_cfun_fun])
149.81 - apply (rule is_ub_thelub, simp add: Y)
149.82 - apply (simp add: lub_distribs Y DEFL [symmetric] cast_DEFL)
149.83 - done
149.84 - qed
149.85 - (* FIXME: why does show ?thesis fail here? *)
149.86 - show "ideal_completion below Rep_compact_basis (approximants::'a \<Rightarrow> _)" ..
149.87 -qed
149.88 -
149.89 -subsection {* Chains of approx functions *}
149.90 -
149.91 -definition u_approx :: "nat \<Rightarrow> udom\<^sub>\<bottom> \<rightarrow> udom\<^sub>\<bottom>"
149.92 - where "u_approx = (\<lambda>i. u_map\<cdot>(udom_approx i))"
149.93 -
149.94 -definition sfun_approx :: "nat \<Rightarrow> (udom \<rightarrow>! udom) \<rightarrow> (udom \<rightarrow>! udom)"
149.95 - where "sfun_approx = (\<lambda>i. sfun_map\<cdot>(udom_approx i)\<cdot>(udom_approx i))"
149.96 -
149.97 -definition prod_approx :: "nat \<Rightarrow> udom \<times> udom \<rightarrow> udom \<times> udom"
149.98 - where "prod_approx = (\<lambda>i. cprod_map\<cdot>(udom_approx i)\<cdot>(udom_approx i))"
149.99 -
149.100 -definition sprod_approx :: "nat \<Rightarrow> udom \<otimes> udom \<rightarrow> udom \<otimes> udom"
149.101 - where "sprod_approx = (\<lambda>i. sprod_map\<cdot>(udom_approx i)\<cdot>(udom_approx i))"
149.102 -
149.103 -definition ssum_approx :: "nat \<Rightarrow> udom \<oplus> udom \<rightarrow> udom \<oplus> udom"
149.104 - where "ssum_approx = (\<lambda>i. ssum_map\<cdot>(udom_approx i)\<cdot>(udom_approx i))"
149.105 -
149.106 -lemma approx_chain_lemma1:
149.107 - assumes "m\<cdot>ID = ID"
149.108 - assumes "\<And>d. finite_deflation d \<Longrightarrow> finite_deflation (m\<cdot>d)"
149.109 - shows "approx_chain (\<lambda>i. m\<cdot>(udom_approx i))"
149.110 -by (rule approx_chain.intro)
149.111 - (simp_all add: lub_distribs finite_deflation_udom_approx assms)
149.112 -
149.113 -lemma approx_chain_lemma2:
149.114 - assumes "m\<cdot>ID\<cdot>ID = ID"
149.115 - assumes "\<And>a b. \<lbrakk>finite_deflation a; finite_deflation b\<rbrakk>
149.116 - \<Longrightarrow> finite_deflation (m\<cdot>a\<cdot>b)"
149.117 - shows "approx_chain (\<lambda>i. m\<cdot>(udom_approx i)\<cdot>(udom_approx i))"
149.118 -by (rule approx_chain.intro)
149.119 - (simp_all add: lub_distribs finite_deflation_udom_approx assms)
149.120 -
149.121 -lemma u_approx: "approx_chain u_approx"
149.122 -using u_map_ID finite_deflation_u_map
149.123 -unfolding u_approx_def by (rule approx_chain_lemma1)
149.124 -
149.125 -lemma sfun_approx: "approx_chain sfun_approx"
149.126 -using sfun_map_ID finite_deflation_sfun_map
149.127 -unfolding sfun_approx_def by (rule approx_chain_lemma2)
149.128 -
149.129 -lemma prod_approx: "approx_chain prod_approx"
149.130 -using cprod_map_ID finite_deflation_cprod_map
149.131 -unfolding prod_approx_def by (rule approx_chain_lemma2)
149.132 -
149.133 -lemma sprod_approx: "approx_chain sprod_approx"
149.134 -using sprod_map_ID finite_deflation_sprod_map
149.135 -unfolding sprod_approx_def by (rule approx_chain_lemma2)
149.136 -
149.137 -lemma ssum_approx: "approx_chain ssum_approx"
149.138 -using ssum_map_ID finite_deflation_ssum_map
149.139 -unfolding ssum_approx_def by (rule approx_chain_lemma2)
149.140 -
149.141 -subsection {* Type combinators *}
149.142 -
149.143 -definition
149.144 - defl_fun1 ::
149.145 - "(nat \<Rightarrow> 'a \<rightarrow> 'a) \<Rightarrow> ((udom \<rightarrow> udom) \<rightarrow> ('a \<rightarrow> 'a)) \<Rightarrow> (defl \<rightarrow> defl)"
149.146 -where
149.147 - "defl_fun1 approx f =
149.148 - defl.basis_fun (\<lambda>a.
149.149 - defl_principal (Abs_fin_defl
149.150 - (udom_emb approx oo f\<cdot>(Rep_fin_defl a) oo udom_prj approx)))"
149.151 -
149.152 -definition
149.153 - defl_fun2 ::
149.154 - "(nat \<Rightarrow> 'a \<rightarrow> 'a) \<Rightarrow> ((udom \<rightarrow> udom) \<rightarrow> (udom \<rightarrow> udom) \<rightarrow> ('a \<rightarrow> 'a))
149.155 - \<Rightarrow> (defl \<rightarrow> defl \<rightarrow> defl)"
149.156 -where
149.157 - "defl_fun2 approx f =
149.158 - defl.basis_fun (\<lambda>a.
149.159 - defl.basis_fun (\<lambda>b.
149.160 - defl_principal (Abs_fin_defl
149.161 - (udom_emb approx oo
149.162 - f\<cdot>(Rep_fin_defl a)\<cdot>(Rep_fin_defl b) oo udom_prj approx))))"
149.163 -
149.164 -lemma cast_defl_fun1:
149.165 - assumes approx: "approx_chain approx"
149.166 - assumes f: "\<And>a. finite_deflation a \<Longrightarrow> finite_deflation (f\<cdot>a)"
149.167 - shows "cast\<cdot>(defl_fun1 approx f\<cdot>A) = udom_emb approx oo f\<cdot>(cast\<cdot>A) oo udom_prj approx"
149.168 -proof -
149.169 - have 1: "\<And>a. finite_deflation
149.170 - (udom_emb approx oo f\<cdot>(Rep_fin_defl a) oo udom_prj approx)"
149.171 - apply (rule ep_pair.finite_deflation_e_d_p)
149.172 - apply (rule approx_chain.ep_pair_udom [OF approx])
149.173 - apply (rule f, rule finite_deflation_Rep_fin_defl)
149.174 - done
149.175 - show ?thesis
149.176 - by (induct A rule: defl.principal_induct, simp)
149.177 - (simp only: defl_fun1_def
149.178 - defl.basis_fun_principal
149.179 - defl.basis_fun_mono
149.180 - defl.principal_mono
149.181 - Abs_fin_defl_mono [OF 1 1]
149.182 - monofun_cfun below_refl
149.183 - Rep_fin_defl_mono
149.184 - cast_defl_principal
149.185 - Abs_fin_defl_inverse [unfolded mem_Collect_eq, OF 1])
149.186 -qed
149.187 -
149.188 -lemma cast_defl_fun2:
149.189 - assumes approx: "approx_chain approx"
149.190 - assumes f: "\<And>a b. finite_deflation a \<Longrightarrow> finite_deflation b \<Longrightarrow>
149.191 - finite_deflation (f\<cdot>a\<cdot>b)"
149.192 - shows "cast\<cdot>(defl_fun2 approx f\<cdot>A\<cdot>B) =
149.193 - udom_emb approx oo f\<cdot>(cast\<cdot>A)\<cdot>(cast\<cdot>B) oo udom_prj approx"
149.194 -proof -
149.195 - have 1: "\<And>a b. finite_deflation (udom_emb approx oo
149.196 - f\<cdot>(Rep_fin_defl a)\<cdot>(Rep_fin_defl b) oo udom_prj approx)"
149.197 - apply (rule ep_pair.finite_deflation_e_d_p)
149.198 - apply (rule ep_pair_udom [OF approx])
149.199 - apply (rule f, (rule finite_deflation_Rep_fin_defl)+)
149.200 - done
149.201 - show ?thesis
149.202 - by (induct A B rule: defl.principal_induct2, simp, simp)
149.203 - (simp only: defl_fun2_def
149.204 - defl.basis_fun_principal
149.205 - defl.basis_fun_mono
149.206 - defl.principal_mono
149.207 - Abs_fin_defl_mono [OF 1 1]
149.208 - monofun_cfun below_refl
149.209 - Rep_fin_defl_mono
149.210 - cast_defl_principal
149.211 - Abs_fin_defl_inverse [unfolded mem_Collect_eq, OF 1])
149.212 -qed
149.213 -
149.214 -definition u_defl :: "defl \<rightarrow> defl"
149.215 - where "u_defl = defl_fun1 u_approx u_map"
149.216 -
149.217 -definition sfun_defl :: "defl \<rightarrow> defl \<rightarrow> defl"
149.218 - where "sfun_defl = defl_fun2 sfun_approx sfun_map"
149.219 -
149.220 -definition prod_defl :: "defl \<rightarrow> defl \<rightarrow> defl"
149.221 - where "prod_defl = defl_fun2 prod_approx cprod_map"
149.222 -
149.223 -definition sprod_defl :: "defl \<rightarrow> defl \<rightarrow> defl"
149.224 - where "sprod_defl = defl_fun2 sprod_approx sprod_map"
149.225 -
149.226 -definition ssum_defl :: "defl \<rightarrow> defl \<rightarrow> defl"
149.227 -where "ssum_defl = defl_fun2 ssum_approx ssum_map"
149.228 -
149.229 -lemma cast_u_defl:
149.230 - "cast\<cdot>(u_defl\<cdot>A) =
149.231 - udom_emb u_approx oo u_map\<cdot>(cast\<cdot>A) oo udom_prj u_approx"
149.232 -using u_approx finite_deflation_u_map
149.233 -unfolding u_defl_def by (rule cast_defl_fun1)
149.234 -
149.235 -lemma cast_sfun_defl:
149.236 - "cast\<cdot>(sfun_defl\<cdot>A\<cdot>B) =
149.237 - udom_emb sfun_approx oo sfun_map\<cdot>(cast\<cdot>A)\<cdot>(cast\<cdot>B) oo udom_prj sfun_approx"
149.238 -using sfun_approx finite_deflation_sfun_map
149.239 -unfolding sfun_defl_def by (rule cast_defl_fun2)
149.240 -
149.241 -lemma cast_prod_defl:
149.242 - "cast\<cdot>(prod_defl\<cdot>A\<cdot>B) = udom_emb prod_approx oo
149.243 - cprod_map\<cdot>(cast\<cdot>A)\<cdot>(cast\<cdot>B) oo udom_prj prod_approx"
149.244 -using prod_approx finite_deflation_cprod_map
149.245 -unfolding prod_defl_def by (rule cast_defl_fun2)
149.246 -
149.247 -lemma cast_sprod_defl:
149.248 - "cast\<cdot>(sprod_defl\<cdot>A\<cdot>B) =
149.249 - udom_emb sprod_approx oo
149.250 - sprod_map\<cdot>(cast\<cdot>A)\<cdot>(cast\<cdot>B) oo
149.251 - udom_prj sprod_approx"
149.252 -using sprod_approx finite_deflation_sprod_map
149.253 -unfolding sprod_defl_def by (rule cast_defl_fun2)
149.254 -
149.255 -lemma cast_ssum_defl:
149.256 - "cast\<cdot>(ssum_defl\<cdot>A\<cdot>B) =
149.257 - udom_emb ssum_approx oo ssum_map\<cdot>(cast\<cdot>A)\<cdot>(cast\<cdot>B) oo udom_prj ssum_approx"
149.258 -using ssum_approx finite_deflation_ssum_map
149.259 -unfolding ssum_defl_def by (rule cast_defl_fun2)
149.260 -
149.261 -subsection {* Lemma for proving domain instances *}
149.262 -
149.263 -text {*
149.264 - A class of domains where @{const liftemb}, @{const liftprj},
149.265 - and @{const liftdefl} are all defined in the standard way.
149.266 -*}
149.267 -
149.268 -class liftdomain = "domain" +
149.269 - assumes liftemb_eq: "liftemb = udom_emb u_approx oo u_map\<cdot>emb"
149.270 - assumes liftprj_eq: "liftprj = u_map\<cdot>prj oo udom_prj u_approx"
149.271 - assumes liftdefl_eq: "liftdefl TYPE('a::cpo) = u_defl\<cdot>DEFL('a)"
149.272 -
149.273 -text {* Temporarily relax type constraints. *}
149.274 -
149.275 -setup {*
149.276 - fold Sign.add_const_constraint
149.277 - [ (@{const_name defl}, SOME @{typ "'a::pcpo itself \<Rightarrow> defl"})
149.278 - , (@{const_name emb}, SOME @{typ "'a::pcpo \<rightarrow> udom"})
149.279 - , (@{const_name prj}, SOME @{typ "udom \<rightarrow> 'a::pcpo"})
149.280 - , (@{const_name liftdefl}, SOME @{typ "'a::pcpo itself \<Rightarrow> defl"})
149.281 - , (@{const_name liftemb}, SOME @{typ "'a::pcpo u \<rightarrow> udom"})
149.282 - , (@{const_name liftprj}, SOME @{typ "udom \<rightarrow> 'a::pcpo u"}) ]
149.283 -*}
149.284 -
149.285 -lemma liftdomain_class_intro:
149.286 - assumes liftemb: "(liftemb :: 'a u \<rightarrow> udom) = udom_emb u_approx oo u_map\<cdot>emb"
149.287 - assumes liftprj: "(liftprj :: udom \<rightarrow> 'a u) = u_map\<cdot>prj oo udom_prj u_approx"
149.288 - assumes liftdefl: "liftdefl TYPE('a) = u_defl\<cdot>DEFL('a)"
149.289 - assumes ep_pair: "ep_pair emb (prj :: udom \<rightarrow> 'a)"
149.290 - assumes cast_defl: "cast\<cdot>DEFL('a) = emb oo (prj :: udom \<rightarrow> 'a)"
149.291 - shows "OFCLASS('a, liftdomain_class)"
149.292 -proof
149.293 - show "ep_pair liftemb (liftprj :: udom \<rightarrow> 'a u)"
149.294 - unfolding liftemb liftprj
149.295 - by (intro ep_pair_comp ep_pair_u_map ep_pair ep_pair_udom u_approx)
149.296 - show "cast\<cdot>LIFTDEFL('a) = liftemb oo (liftprj :: udom \<rightarrow> 'a u)"
149.297 - unfolding liftemb liftprj liftdefl
149.298 - by (simp add: cfcomp1 cast_u_defl cast_defl u_map_map)
149.299 -next
149.300 -qed fact+
149.301 -
149.302 -text {* Restore original type constraints. *}
149.303 -
149.304 -setup {*
149.305 - fold Sign.add_const_constraint
149.306 - [ (@{const_name defl}, SOME @{typ "'a::domain itself \<Rightarrow> defl"})
149.307 - , (@{const_name emb}, SOME @{typ "'a::domain \<rightarrow> udom"})
149.308 - , (@{const_name prj}, SOME @{typ "udom \<rightarrow> 'a::domain"})
149.309 - , (@{const_name liftdefl}, SOME @{typ "'a::predomain itself \<Rightarrow> defl"})
149.310 - , (@{const_name liftemb}, SOME @{typ "'a::predomain u \<rightarrow> udom"})
149.311 - , (@{const_name liftprj}, SOME @{typ "udom \<rightarrow> 'a::predomain u"}) ]
149.312 -*}
149.313 -
149.314 -subsection {* Class instance proofs *}
149.315 -
149.316 -subsubsection {* Universal domain *}
149.317 -
149.318 -instantiation udom :: liftdomain
149.319 -begin
149.320 -
149.321 -definition [simp]:
149.322 - "emb = (ID :: udom \<rightarrow> udom)"
149.323 -
149.324 -definition [simp]:
149.325 - "prj = (ID :: udom \<rightarrow> udom)"
149.326 -
149.327 -definition
149.328 - "defl (t::udom itself) = (\<Squnion>i. defl_principal (Abs_fin_defl (udom_approx i)))"
149.329 -
149.330 -definition
149.331 - "(liftemb :: udom u \<rightarrow> udom) = udom_emb u_approx oo u_map\<cdot>emb"
149.332 -
149.333 -definition
149.334 - "(liftprj :: udom \<rightarrow> udom u) = u_map\<cdot>prj oo udom_prj u_approx"
149.335 -
149.336 -definition
149.337 - "liftdefl (t::udom itself) = u_defl\<cdot>DEFL(udom)"
149.338 -
149.339 -instance
149.340 -using liftemb_udom_def liftprj_udom_def liftdefl_udom_def
149.341 -proof (rule liftdomain_class_intro)
149.342 - show "ep_pair emb (prj :: udom \<rightarrow> udom)"
149.343 - by (simp add: ep_pair.intro)
149.344 - show "cast\<cdot>DEFL(udom) = emb oo (prj :: udom \<rightarrow> udom)"
149.345 - unfolding defl_udom_def
149.346 - apply (subst contlub_cfun_arg)
149.347 - apply (rule chainI)
149.348 - apply (rule defl.principal_mono)
149.349 - apply (simp add: below_fin_defl_def)
149.350 - apply (simp add: Abs_fin_defl_inverse finite_deflation_udom_approx)
149.351 - apply (rule chainE)
149.352 - apply (rule chain_udom_approx)
149.353 - apply (subst cast_defl_principal)
149.354 - apply (simp add: Abs_fin_defl_inverse finite_deflation_udom_approx)
149.355 - done
149.356 -qed
149.357 -
149.358 -end
149.359 -
149.360 -subsubsection {* Lifted cpo *}
149.361 -
149.362 -instantiation u :: (predomain) liftdomain
149.363 -begin
149.364 -
149.365 -definition
149.366 - "emb = liftemb"
149.367 -
149.368 -definition
149.369 - "prj = liftprj"
149.370 -
149.371 -definition
149.372 - "defl (t::'a u itself) = LIFTDEFL('a)"
149.373 -
149.374 -definition
149.375 - "(liftemb :: 'a u u \<rightarrow> udom) = udom_emb u_approx oo u_map\<cdot>emb"
149.376 -
149.377 -definition
149.378 - "(liftprj :: udom \<rightarrow> 'a u u) = u_map\<cdot>prj oo udom_prj u_approx"
149.379 -
149.380 -definition
149.381 - "liftdefl (t::'a u itself) = u_defl\<cdot>DEFL('a u)"
149.382 -
149.383 -instance
149.384 -using liftemb_u_def liftprj_u_def liftdefl_u_def
149.385 -proof (rule liftdomain_class_intro)
149.386 - show "ep_pair emb (prj :: udom \<rightarrow> 'a u)"
149.387 - unfolding emb_u_def prj_u_def
149.388 - by (rule predomain_ep)
149.389 - show "cast\<cdot>DEFL('a u) = emb oo (prj :: udom \<rightarrow> 'a u)"
149.390 - unfolding emb_u_def prj_u_def defl_u_def
149.391 - by (rule cast_liftdefl)
149.392 -qed
149.393 -
149.394 -end
149.395 -
149.396 -lemma DEFL_u: "DEFL('a::predomain u) = LIFTDEFL('a)"
149.397 -by (rule defl_u_def)
149.398 -
149.399 -subsubsection {* Strict function space *}
149.400 -
149.401 -instantiation sfun :: ("domain", "domain") liftdomain
149.402 -begin
149.403 -
149.404 -definition
149.405 - "emb = udom_emb sfun_approx oo sfun_map\<cdot>prj\<cdot>emb"
149.406 -
149.407 -definition
149.408 - "prj = sfun_map\<cdot>emb\<cdot>prj oo udom_prj sfun_approx"
149.409 -
149.410 -definition
149.411 - "defl (t::('a \<rightarrow>! 'b) itself) = sfun_defl\<cdot>DEFL('a)\<cdot>DEFL('b)"
149.412 -
149.413 -definition
149.414 - "(liftemb :: ('a \<rightarrow>! 'b) u \<rightarrow> udom) = udom_emb u_approx oo u_map\<cdot>emb"
149.415 -
149.416 -definition
149.417 - "(liftprj :: udom \<rightarrow> ('a \<rightarrow>! 'b) u) = u_map\<cdot>prj oo udom_prj u_approx"
149.418 -
149.419 -definition
149.420 - "liftdefl (t::('a \<rightarrow>! 'b) itself) = u_defl\<cdot>DEFL('a \<rightarrow>! 'b)"
149.421 -
149.422 -instance
149.423 -using liftemb_sfun_def liftprj_sfun_def liftdefl_sfun_def
149.424 -proof (rule liftdomain_class_intro)
149.425 - show "ep_pair emb (prj :: udom \<rightarrow> 'a \<rightarrow>! 'b)"
149.426 - unfolding emb_sfun_def prj_sfun_def
149.427 - using ep_pair_udom [OF sfun_approx]
149.428 - by (intro ep_pair_comp ep_pair_sfun_map ep_pair_emb_prj)
149.429 - show "cast\<cdot>DEFL('a \<rightarrow>! 'b) = emb oo (prj :: udom \<rightarrow> 'a \<rightarrow>! 'b)"
149.430 - unfolding emb_sfun_def prj_sfun_def defl_sfun_def cast_sfun_defl
149.431 - by (simp add: cast_DEFL oo_def sfun_eq_iff sfun_map_map)
149.432 -qed
149.433 -
149.434 -end
149.435 -
149.436 -lemma DEFL_sfun:
149.437 - "DEFL('a::domain \<rightarrow>! 'b::domain) = sfun_defl\<cdot>DEFL('a)\<cdot>DEFL('b)"
149.438 -by (rule defl_sfun_def)
149.439 -
149.440 -subsubsection {* Continuous function space *}
149.441 -
149.442 -text {*
149.443 - Types @{typ "'a \<rightarrow> 'b"} and @{typ "'a u \<rightarrow>! 'b"} are isomorphic.
149.444 -*}
149.445 -
149.446 -definition
149.447 - "encode_cfun = (\<Lambda> f. sfun_abs\<cdot>(fup\<cdot>f))"
149.448 -
149.449 -definition
149.450 - "decode_cfun = (\<Lambda> g x. sfun_rep\<cdot>g\<cdot>(up\<cdot>x))"
149.451 -
149.452 -lemma decode_encode_cfun [simp]: "decode_cfun\<cdot>(encode_cfun\<cdot>x) = x"
149.453 -unfolding encode_cfun_def decode_cfun_def
149.454 -by (simp add: eta_cfun)
149.455 -
149.456 -lemma encode_decode_cfun [simp]: "encode_cfun\<cdot>(decode_cfun\<cdot>y) = y"
149.457 -unfolding encode_cfun_def decode_cfun_def
149.458 -apply (simp add: sfun_eq_iff strictify_cancel)
149.459 -apply (rule cfun_eqI, case_tac x, simp_all)
149.460 -done
149.461 -
149.462 -instantiation cfun :: (predomain, "domain") liftdomain
149.463 -begin
149.464 -
149.465 -definition
149.466 - "emb = (udom_emb sfun_approx oo sfun_map\<cdot>prj\<cdot>emb) oo encode_cfun"
149.467 -
149.468 -definition
149.469 - "prj = decode_cfun oo (sfun_map\<cdot>emb\<cdot>prj oo udom_prj sfun_approx)"
149.470 -
149.471 -definition
149.472 - "defl (t::('a \<rightarrow> 'b) itself) = sfun_defl\<cdot>DEFL('a u)\<cdot>DEFL('b)"
149.473 -
149.474 -definition
149.475 - "(liftemb :: ('a \<rightarrow> 'b) u \<rightarrow> udom) = udom_emb u_approx oo u_map\<cdot>emb"
149.476 -
149.477 -definition
149.478 - "(liftprj :: udom \<rightarrow> ('a \<rightarrow> 'b) u) = u_map\<cdot>prj oo udom_prj u_approx"
149.479 -
149.480 -definition
149.481 - "liftdefl (t::('a \<rightarrow> 'b) itself) = u_defl\<cdot>DEFL('a \<rightarrow> 'b)"
149.482 -
149.483 -instance
149.484 -using liftemb_cfun_def liftprj_cfun_def liftdefl_cfun_def
149.485 -proof (rule liftdomain_class_intro)
149.486 - have "ep_pair encode_cfun decode_cfun"
149.487 - by (rule ep_pair.intro, simp_all)
149.488 - thus "ep_pair emb (prj :: udom \<rightarrow> 'a \<rightarrow> 'b)"
149.489 - unfolding emb_cfun_def prj_cfun_def
149.490 - apply (rule ep_pair_comp)
149.491 - apply (rule ep_pair_comp)
149.492 - apply (intro ep_pair_sfun_map ep_pair_emb_prj)
149.493 - apply (rule ep_pair_udom [OF sfun_approx])
149.494 - done
149.495 - show "cast\<cdot>DEFL('a \<rightarrow> 'b) = emb oo (prj :: udom \<rightarrow> 'a \<rightarrow> 'b)"
149.496 - unfolding emb_cfun_def prj_cfun_def defl_cfun_def cast_sfun_defl
149.497 - by (simp add: cast_DEFL oo_def cfun_eq_iff sfun_map_map)
149.498 -qed
149.499 -
149.500 -end
149.501 -
149.502 -lemma DEFL_cfun:
149.503 - "DEFL('a::predomain \<rightarrow> 'b::domain) = sfun_defl\<cdot>DEFL('a u)\<cdot>DEFL('b)"
149.504 -by (rule defl_cfun_def)
149.505 -
149.506 -subsubsection {* Cartesian product *}
149.507 -
149.508 -text {*
149.509 - Types @{typ "('a * 'b) u"} and @{typ "'a u \<otimes> 'b u"} are isomorphic.
149.510 -*}
149.511 -
149.512 -definition
149.513 - "encode_prod_u = (\<Lambda>(up\<cdot>(x, y)). (:up\<cdot>x, up\<cdot>y:))"
149.514 -
149.515 -definition
149.516 - "decode_prod_u = (\<Lambda>(:up\<cdot>x, up\<cdot>y:). up\<cdot>(x, y))"
149.517 -
149.518 -lemma decode_encode_prod_u [simp]: "decode_prod_u\<cdot>(encode_prod_u\<cdot>x) = x"
149.519 -unfolding encode_prod_u_def decode_prod_u_def
149.520 -by (case_tac x, simp, rename_tac y, case_tac y, simp)
149.521 -
149.522 -lemma encode_decode_prod_u [simp]: "encode_prod_u\<cdot>(decode_prod_u\<cdot>y) = y"
149.523 -unfolding encode_prod_u_def decode_prod_u_def
149.524 -apply (case_tac y, simp, rename_tac a b)
149.525 -apply (case_tac a, simp, case_tac b, simp, simp)
149.526 -done
149.527 -
149.528 -instantiation prod :: (predomain, predomain) predomain
149.529 -begin
149.530 -
149.531 -definition
149.532 - "liftemb =
149.533 - (udom_emb sprod_approx oo sprod_map\<cdot>emb\<cdot>emb) oo encode_prod_u"
149.534 -
149.535 -definition
149.536 - "liftprj =
149.537 - decode_prod_u oo (sprod_map\<cdot>prj\<cdot>prj oo udom_prj sprod_approx)"
149.538 -
149.539 -definition
149.540 - "liftdefl (t::('a \<times> 'b) itself) = sprod_defl\<cdot>DEFL('a u)\<cdot>DEFL('b u)"
149.541 -
149.542 -instance proof
149.543 - have "ep_pair encode_prod_u decode_prod_u"
149.544 - by (rule ep_pair.intro, simp_all)
149.545 - thus "ep_pair liftemb (liftprj :: udom \<rightarrow> ('a \<times> 'b) u)"
149.546 - unfolding liftemb_prod_def liftprj_prod_def
149.547 - apply (rule ep_pair_comp)
149.548 - apply (rule ep_pair_comp)
149.549 - apply (intro ep_pair_sprod_map ep_pair_emb_prj)
149.550 - apply (rule ep_pair_udom [OF sprod_approx])
149.551 - done
149.552 - show "cast\<cdot>LIFTDEFL('a \<times> 'b) = liftemb oo (liftprj :: udom \<rightarrow> ('a \<times> 'b) u)"
149.553 - unfolding liftemb_prod_def liftprj_prod_def liftdefl_prod_def
149.554 - by (simp add: cast_sprod_defl cast_DEFL cfcomp1 sprod_map_map)
149.555 -qed
149.556 -
149.557 -end
149.558 -
149.559 -instantiation prod :: ("domain", "domain") "domain"
149.560 -begin
149.561 -
149.562 -definition
149.563 - "emb = udom_emb prod_approx oo cprod_map\<cdot>emb\<cdot>emb"
149.564 -
149.565 -definition
149.566 - "prj = cprod_map\<cdot>prj\<cdot>prj oo udom_prj prod_approx"
149.567 -
149.568 -definition
149.569 - "defl (t::('a \<times> 'b) itself) = prod_defl\<cdot>DEFL('a)\<cdot>DEFL('b)"
149.570 -
149.571 -instance proof
149.572 - show "ep_pair emb (prj :: udom \<rightarrow> 'a \<times> 'b)"
149.573 - unfolding emb_prod_def prj_prod_def
149.574 - using ep_pair_udom [OF prod_approx]
149.575 - by (intro ep_pair_comp ep_pair_cprod_map ep_pair_emb_prj)
149.576 -next
149.577 - show "cast\<cdot>DEFL('a \<times> 'b) = emb oo (prj :: udom \<rightarrow> 'a \<times> 'b)"
149.578 - unfolding emb_prod_def prj_prod_def defl_prod_def cast_prod_defl
149.579 - by (simp add: cast_DEFL oo_def cfun_eq_iff cprod_map_map)
149.580 -qed
149.581 -
149.582 -end
149.583 -
149.584 -lemma DEFL_prod:
149.585 - "DEFL('a::domain \<times> 'b::domain) = prod_defl\<cdot>DEFL('a)\<cdot>DEFL('b)"
149.586 -by (rule defl_prod_def)
149.587 -
149.588 -lemma LIFTDEFL_prod:
149.589 - "LIFTDEFL('a::predomain \<times> 'b::predomain) = sprod_defl\<cdot>DEFL('a u)\<cdot>DEFL('b u)"
149.590 -by (rule liftdefl_prod_def)
149.591 -
149.592 -subsubsection {* Strict product *}
149.593 -
149.594 -instantiation sprod :: ("domain", "domain") liftdomain
149.595 -begin
149.596 -
149.597 -definition
149.598 - "emb = udom_emb sprod_approx oo sprod_map\<cdot>emb\<cdot>emb"
149.599 -
149.600 -definition
149.601 - "prj = sprod_map\<cdot>prj\<cdot>prj oo udom_prj sprod_approx"
149.602 -
149.603 -definition
149.604 - "defl (t::('a \<otimes> 'b) itself) = sprod_defl\<cdot>DEFL('a)\<cdot>DEFL('b)"
149.605 -
149.606 -definition
149.607 - "(liftemb :: ('a \<otimes> 'b) u \<rightarrow> udom) = udom_emb u_approx oo u_map\<cdot>emb"
149.608 -
149.609 -definition
149.610 - "(liftprj :: udom \<rightarrow> ('a \<otimes> 'b) u) = u_map\<cdot>prj oo udom_prj u_approx"
149.611 -
149.612 -definition
149.613 - "liftdefl (t::('a \<otimes> 'b) itself) = u_defl\<cdot>DEFL('a \<otimes> 'b)"
149.614 -
149.615 -instance
149.616 -using liftemb_sprod_def liftprj_sprod_def liftdefl_sprod_def
149.617 -proof (rule liftdomain_class_intro)
149.618 - show "ep_pair emb (prj :: udom \<rightarrow> 'a \<otimes> 'b)"
149.619 - unfolding emb_sprod_def prj_sprod_def
149.620 - using ep_pair_udom [OF sprod_approx]
149.621 - by (intro ep_pair_comp ep_pair_sprod_map ep_pair_emb_prj)
149.622 -next
149.623 - show "cast\<cdot>DEFL('a \<otimes> 'b) = emb oo (prj :: udom \<rightarrow> 'a \<otimes> 'b)"
149.624 - unfolding emb_sprod_def prj_sprod_def defl_sprod_def cast_sprod_defl
149.625 - by (simp add: cast_DEFL oo_def cfun_eq_iff sprod_map_map)
149.626 -qed
149.627 -
149.628 -end
149.629 -
149.630 -lemma DEFL_sprod:
149.631 - "DEFL('a::domain \<otimes> 'b::domain) = sprod_defl\<cdot>DEFL('a)\<cdot>DEFL('b)"
149.632 -by (rule defl_sprod_def)
149.633 -
149.634 -subsubsection {* Discrete cpo *}
149.635 -
149.636 -definition discr_approx :: "nat \<Rightarrow> 'a::countable discr u \<rightarrow> 'a discr u"
149.637 - where "discr_approx = (\<lambda>i. \<Lambda>(up\<cdot>x). if to_nat (undiscr x) < i then up\<cdot>x else \<bottom>)"
149.638 -
149.639 -lemma chain_discr_approx [simp]: "chain discr_approx"
149.640 -unfolding discr_approx_def
149.641 -by (rule chainI, simp add: monofun_cfun monofun_LAM)
149.642 -
149.643 -lemma lub_discr_approx [simp]: "(\<Squnion>i. discr_approx i) = ID"
149.644 -apply (rule cfun_eqI)
149.645 -apply (simp add: contlub_cfun_fun)
149.646 -apply (simp add: discr_approx_def)
149.647 -apply (case_tac x, simp)
149.648 -apply (rule lub_eqI)
149.649 -apply (rule is_lubI)
149.650 -apply (rule ub_rangeI, simp)
149.651 -apply (drule ub_rangeD)
149.652 -apply (erule rev_below_trans)
149.653 -apply simp
149.654 -apply (rule lessI)
149.655 -done
149.656 -
149.657 -lemma inj_on_undiscr [simp]: "inj_on undiscr A"
149.658 -using Discr_undiscr by (rule inj_on_inverseI)
149.659 -
149.660 -lemma finite_deflation_discr_approx: "finite_deflation (discr_approx i)"
149.661 -proof
149.662 - fix x :: "'a discr u"
149.663 - show "discr_approx i\<cdot>x \<sqsubseteq> x"
149.664 - unfolding discr_approx_def
149.665 - by (cases x, simp, simp)
149.666 - show "discr_approx i\<cdot>(discr_approx i\<cdot>x) = discr_approx i\<cdot>x"
149.667 - unfolding discr_approx_def
149.668 - by (cases x, simp, simp)
149.669 - show "finite {x::'a discr u. discr_approx i\<cdot>x = x}"
149.670 - proof (rule finite_subset)
149.671 - let ?S = "insert (\<bottom>::'a discr u) ((\<lambda>x. up\<cdot>x) ` undiscr -` to_nat -` {..<i})"
149.672 - show "{x::'a discr u. discr_approx i\<cdot>x = x} \<subseteq> ?S"
149.673 - unfolding discr_approx_def
149.674 - by (rule subsetI, case_tac x, simp, simp split: split_if_asm)
149.675 - show "finite ?S"
149.676 - by (simp add: finite_vimageI)
149.677 - qed
149.678 -qed
149.679 -
149.680 -lemma discr_approx: "approx_chain discr_approx"
149.681 -using chain_discr_approx lub_discr_approx finite_deflation_discr_approx
149.682 -by (rule approx_chain.intro)
149.683 -
149.684 -instantiation discr :: (countable) predomain
149.685 -begin
149.686 -
149.687 -definition
149.688 - "liftemb = udom_emb discr_approx"
149.689 -
149.690 -definition
149.691 - "liftprj = udom_prj discr_approx"
149.692 -
149.693 -definition
149.694 - "liftdefl (t::'a discr itself) =
149.695 - (\<Squnion>i. defl_principal (Abs_fin_defl (liftemb oo discr_approx i oo liftprj)))"
149.696 -
149.697 -instance proof
149.698 - show "ep_pair liftemb (liftprj :: udom \<rightarrow> 'a discr u)"
149.699 - unfolding liftemb_discr_def liftprj_discr_def
149.700 - by (rule ep_pair_udom [OF discr_approx])
149.701 - show "cast\<cdot>LIFTDEFL('a discr) = liftemb oo (liftprj :: udom \<rightarrow> 'a discr u)"
149.702 - unfolding liftemb_discr_def liftprj_discr_def liftdefl_discr_def
149.703 - apply (subst contlub_cfun_arg)
149.704 - apply (rule chainI)
149.705 - apply (rule defl.principal_mono)
149.706 - apply (simp add: below_fin_defl_def)
149.707 - apply (simp add: Abs_fin_defl_inverse
149.708 - ep_pair.finite_deflation_e_d_p [OF ep_pair_udom [OF discr_approx]]
149.709 - approx_chain.finite_deflation_approx [OF discr_approx])
149.710 - apply (intro monofun_cfun below_refl)
149.711 - apply (rule chainE)
149.712 - apply (rule chain_discr_approx)
149.713 - apply (subst cast_defl_principal)
149.714 - apply (simp add: Abs_fin_defl_inverse
149.715 - ep_pair.finite_deflation_e_d_p [OF ep_pair_udom [OF discr_approx]]
149.716 - approx_chain.finite_deflation_approx [OF discr_approx])
149.717 - apply (simp add: lub_distribs)
149.718 - done
149.719 -qed
149.720 -
149.721 -end
149.722 -
149.723 -subsubsection {* Strict sum *}
149.724 -
149.725 -instantiation ssum :: ("domain", "domain") liftdomain
149.726 -begin
149.727 -
149.728 -definition
149.729 - "emb = udom_emb ssum_approx oo ssum_map\<cdot>emb\<cdot>emb"
149.730 -
149.731 -definition
149.732 - "prj = ssum_map\<cdot>prj\<cdot>prj oo udom_prj ssum_approx"
149.733 -
149.734 -definition
149.735 - "defl (t::('a \<oplus> 'b) itself) = ssum_defl\<cdot>DEFL('a)\<cdot>DEFL('b)"
149.736 -
149.737 -definition
149.738 - "(liftemb :: ('a \<oplus> 'b) u \<rightarrow> udom) = udom_emb u_approx oo u_map\<cdot>emb"
149.739 -
149.740 -definition
149.741 - "(liftprj :: udom \<rightarrow> ('a \<oplus> 'b) u) = u_map\<cdot>prj oo udom_prj u_approx"
149.742 -
149.743 -definition
149.744 - "liftdefl (t::('a \<oplus> 'b) itself) = u_defl\<cdot>DEFL('a \<oplus> 'b)"
149.745 -
149.746 -instance
149.747 -using liftemb_ssum_def liftprj_ssum_def liftdefl_ssum_def
149.748 -proof (rule liftdomain_class_intro)
149.749 - show "ep_pair emb (prj :: udom \<rightarrow> 'a \<oplus> 'b)"
149.750 - unfolding emb_ssum_def prj_ssum_def
149.751 - using ep_pair_udom [OF ssum_approx]
149.752 - by (intro ep_pair_comp ep_pair_ssum_map ep_pair_emb_prj)
149.753 - show "cast\<cdot>DEFL('a \<oplus> 'b) = emb oo (prj :: udom \<rightarrow> 'a \<oplus> 'b)"
149.754 - unfolding emb_ssum_def prj_ssum_def defl_ssum_def cast_ssum_defl
149.755 - by (simp add: cast_DEFL oo_def cfun_eq_iff ssum_map_map)
149.756 -qed
149.757 -
149.758 -end
149.759 -
149.760 -lemma DEFL_ssum:
149.761 - "DEFL('a::domain \<oplus> 'b::domain) = ssum_defl\<cdot>DEFL('a)\<cdot>DEFL('b)"
149.762 -by (rule defl_ssum_def)
149.763 -
149.764 -subsubsection {* Lifted HOL type *}
149.765 -
149.766 -instantiation lift :: (countable) liftdomain
149.767 -begin
149.768 -
149.769 -definition
149.770 - "emb = emb oo (\<Lambda> x. Rep_lift x)"
149.771 -
149.772 -definition
149.773 - "prj = (\<Lambda> y. Abs_lift y) oo prj"
149.774 -
149.775 -definition
149.776 - "defl (t::'a lift itself) = DEFL('a discr u)"
149.777 -
149.778 -definition
149.779 - "(liftemb :: 'a lift u \<rightarrow> udom) = udom_emb u_approx oo u_map\<cdot>emb"
149.780 -
149.781 -definition
149.782 - "(liftprj :: udom \<rightarrow> 'a lift u) = u_map\<cdot>prj oo udom_prj u_approx"
149.783 -
149.784 -definition
149.785 - "liftdefl (t::'a lift itself) = u_defl\<cdot>DEFL('a lift)"
149.786 -
149.787 -instance
149.788 -using liftemb_lift_def liftprj_lift_def liftdefl_lift_def
149.789 -proof (rule liftdomain_class_intro)
149.790 - note [simp] = cont_Rep_lift cont_Abs_lift Rep_lift_inverse Abs_lift_inverse
149.791 - have "ep_pair (\<Lambda>(x::'a lift). Rep_lift x) (\<Lambda> y. Abs_lift y)"
149.792 - by (simp add: ep_pair_def)
149.793 - thus "ep_pair emb (prj :: udom \<rightarrow> 'a lift)"
149.794 - unfolding emb_lift_def prj_lift_def
149.795 - using ep_pair_emb_prj by (rule ep_pair_comp)
149.796 - show "cast\<cdot>DEFL('a lift) = emb oo (prj :: udom \<rightarrow> 'a lift)"
149.797 - unfolding emb_lift_def prj_lift_def defl_lift_def cast_DEFL
149.798 - by (simp add: cfcomp1)
149.799 -qed
149.800 -
149.801 -end
149.802 -
149.803 -end
150.1 --- a/src/HOLCF/Cfun.thy Sat Nov 27 14:34:54 2010 -0800
150.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
150.3 @@ -1,543 +0,0 @@
150.4 -(* Title: HOLCF/Cfun.thy
150.5 - Author: Franz Regensburger
150.6 - Author: Brian Huffman
150.7 -*)
150.8 -
150.9 -header {* The type of continuous functions *}
150.10 -
150.11 -theory Cfun
150.12 -imports Cpodef Fun_Cpo Product_Cpo
150.13 -begin
150.14 -
150.15 -default_sort cpo
150.16 -
150.17 -subsection {* Definition of continuous function type *}
150.18 -
150.19 -cpodef ('a, 'b) cfun (infixr "->" 0) = "{f::'a => 'b. cont f}"
150.20 -by (auto intro: cont_const adm_cont)
150.21 -
150.22 -type_notation (xsymbols)
150.23 - cfun ("(_ \<rightarrow>/ _)" [1, 0] 0)
150.24 -
150.25 -notation
150.26 - Rep_cfun ("(_$/_)" [999,1000] 999)
150.27 -
150.28 -notation (xsymbols)
150.29 - Rep_cfun ("(_\<cdot>/_)" [999,1000] 999)
150.30 -
150.31 -notation (HTML output)
150.32 - Rep_cfun ("(_\<cdot>/_)" [999,1000] 999)
150.33 -
150.34 -subsection {* Syntax for continuous lambda abstraction *}
150.35 -
150.36 -syntax "_cabs" :: "'a"
150.37 -
150.38 -parse_translation {*
150.39 -(* rewrite (_cabs x t) => (Abs_cfun (%x. t)) *)
150.40 - [mk_binder_tr (@{syntax_const "_cabs"}, @{const_syntax Abs_cfun})];
150.41 -*}
150.42 -
150.43 -text {* To avoid eta-contraction of body: *}
150.44 -typed_print_translation {*
150.45 - let
150.46 - fun cabs_tr' _ _ [Abs abs] = let
150.47 - val (x,t) = atomic_abs_tr' abs
150.48 - in Syntax.const @{syntax_const "_cabs"} $ x $ t end
150.49 -
150.50 - | cabs_tr' _ T [t] = let
150.51 - val xT = domain_type (domain_type T);
150.52 - val abs' = ("x",xT,(incr_boundvars 1 t)$Bound 0);
150.53 - val (x,t') = atomic_abs_tr' abs';
150.54 - in Syntax.const @{syntax_const "_cabs"} $ x $ t' end;
150.55 -
150.56 - in [(@{const_syntax Abs_cfun}, cabs_tr')] end;
150.57 -*}
150.58 -
150.59 -text {* Syntax for nested abstractions *}
150.60 -
150.61 -syntax
150.62 - "_Lambda" :: "[cargs, 'a] \<Rightarrow> logic" ("(3LAM _./ _)" [1000, 10] 10)
150.63 -
150.64 -syntax (xsymbols)
150.65 - "_Lambda" :: "[cargs, 'a] \<Rightarrow> logic" ("(3\<Lambda> _./ _)" [1000, 10] 10)
150.66 -
150.67 -parse_ast_translation {*
150.68 -(* rewrite (LAM x y z. t) => (_cabs x (_cabs y (_cabs z t))) *)
150.69 -(* cf. Syntax.lambda_ast_tr from src/Pure/Syntax/syn_trans.ML *)
150.70 - let
150.71 - fun Lambda_ast_tr [pats, body] =
150.72 - Syntax.fold_ast_p @{syntax_const "_cabs"}
150.73 - (Syntax.unfold_ast @{syntax_const "_cargs"} pats, body)
150.74 - | Lambda_ast_tr asts = raise Syntax.AST ("Lambda_ast_tr", asts);
150.75 - in [(@{syntax_const "_Lambda"}, Lambda_ast_tr)] end;
150.76 -*}
150.77 -
150.78 -print_ast_translation {*
150.79 -(* rewrite (_cabs x (_cabs y (_cabs z t))) => (LAM x y z. t) *)
150.80 -(* cf. Syntax.abs_ast_tr' from src/Pure/Syntax/syn_trans.ML *)
150.81 - let
150.82 - fun cabs_ast_tr' asts =
150.83 - (case Syntax.unfold_ast_p @{syntax_const "_cabs"}
150.84 - (Syntax.Appl (Syntax.Constant @{syntax_const "_cabs"} :: asts)) of
150.85 - ([], _) => raise Syntax.AST ("cabs_ast_tr'", asts)
150.86 - | (xs, body) => Syntax.Appl
150.87 - [Syntax.Constant @{syntax_const "_Lambda"},
150.88 - Syntax.fold_ast @{syntax_const "_cargs"} xs, body]);
150.89 - in [(@{syntax_const "_cabs"}, cabs_ast_tr')] end
150.90 -*}
150.91 -
150.92 -text {* Dummy patterns for continuous abstraction *}
150.93 -translations
150.94 - "\<Lambda> _. t" => "CONST Abs_cfun (\<lambda> _. t)"
150.95 -
150.96 -subsection {* Continuous function space is pointed *}
150.97 -
150.98 -lemma UU_cfun: "\<bottom> \<in> cfun"
150.99 -by (simp add: cfun_def inst_fun_pcpo)
150.100 -
150.101 -instance cfun :: (cpo, discrete_cpo) discrete_cpo
150.102 -by intro_classes (simp add: below_cfun_def Rep_cfun_inject)
150.103 -
150.104 -instance cfun :: (cpo, pcpo) pcpo
150.105 -by (rule typedef_pcpo [OF type_definition_cfun below_cfun_def UU_cfun])
150.106 -
150.107 -lemmas Rep_cfun_strict =
150.108 - typedef_Rep_strict [OF type_definition_cfun below_cfun_def UU_cfun]
150.109 -
150.110 -lemmas Abs_cfun_strict =
150.111 - typedef_Abs_strict [OF type_definition_cfun below_cfun_def UU_cfun]
150.112 -
150.113 -text {* function application is strict in its first argument *}
150.114 -
150.115 -lemma Rep_cfun_strict1 [simp]: "\<bottom>\<cdot>x = \<bottom>"
150.116 -by (simp add: Rep_cfun_strict)
150.117 -
150.118 -lemma LAM_strict [simp]: "(\<Lambda> x. \<bottom>) = \<bottom>"
150.119 -by (simp add: inst_fun_pcpo [symmetric] Abs_cfun_strict)
150.120 -
150.121 -text {* for compatibility with old HOLCF-Version *}
150.122 -lemma inst_cfun_pcpo: "\<bottom> = (\<Lambda> x. \<bottom>)"
150.123 -by simp
150.124 -
150.125 -subsection {* Basic properties of continuous functions *}
150.126 -
150.127 -text {* Beta-equality for continuous functions *}
150.128 -
150.129 -lemma Abs_cfun_inverse2: "cont f \<Longrightarrow> Rep_cfun (Abs_cfun f) = f"
150.130 -by (simp add: Abs_cfun_inverse cfun_def)
150.131 -
150.132 -lemma beta_cfun: "cont f \<Longrightarrow> (\<Lambda> x. f x)\<cdot>u = f u"
150.133 -by (simp add: Abs_cfun_inverse2)
150.134 -
150.135 -text {* Beta-reduction simproc *}
150.136 -
150.137 -text {*
150.138 - Given the term @{term "(\<Lambda> x. f x)\<cdot>y"}, the procedure tries to
150.139 - construct the theorem @{term "(\<Lambda> x. f x)\<cdot>y == f y"}. If this
150.140 - theorem cannot be completely solved by the cont2cont rules, then
150.141 - the procedure returns the ordinary conditional @{text beta_cfun}
150.142 - rule.
150.143 -
150.144 - The simproc does not solve any more goals that would be solved by
150.145 - using @{text beta_cfun} as a simp rule. The advantage of the
150.146 - simproc is that it can avoid deeply-nested calls to the simplifier
150.147 - that would otherwise be caused by large continuity side conditions.
150.148 -*}
150.149 -
150.150 -simproc_setup beta_cfun_proc ("Abs_cfun f\<cdot>x") = {*
150.151 - fn phi => fn ss => fn ct =>
150.152 - let
150.153 - val dest = Thm.dest_comb;
150.154 - val (f, x) = (apfst (snd o dest o snd o dest) o dest) ct;
150.155 - val [T, U] = Thm.dest_ctyp (ctyp_of_term f);
150.156 - val tr = instantiate' [SOME T, SOME U] [SOME f, SOME x]
150.157 - (mk_meta_eq @{thm beta_cfun});
150.158 - val rules = Cont2ContData.get (Simplifier.the_context ss);
150.159 - val tac = SOLVED' (REPEAT_ALL_NEW (match_tac rules));
150.160 - in SOME (perhaps (SINGLE (tac 1)) tr) end
150.161 -*}
150.162 -
150.163 -text {* Eta-equality for continuous functions *}
150.164 -
150.165 -lemma eta_cfun: "(\<Lambda> x. f\<cdot>x) = f"
150.166 -by (rule Rep_cfun_inverse)
150.167 -
150.168 -text {* Extensionality for continuous functions *}
150.169 -
150.170 -lemma cfun_eq_iff: "f = g \<longleftrightarrow> (\<forall>x. f\<cdot>x = g\<cdot>x)"
150.171 -by (simp add: Rep_cfun_inject [symmetric] fun_eq_iff)
150.172 -
150.173 -lemma cfun_eqI: "(\<And>x. f\<cdot>x = g\<cdot>x) \<Longrightarrow> f = g"
150.174 -by (simp add: cfun_eq_iff)
150.175 -
150.176 -text {* Extensionality wrt. ordering for continuous functions *}
150.177 -
150.178 -lemma cfun_below_iff: "f \<sqsubseteq> g \<longleftrightarrow> (\<forall>x. f\<cdot>x \<sqsubseteq> g\<cdot>x)"
150.179 -by (simp add: below_cfun_def fun_below_iff)
150.180 -
150.181 -lemma cfun_belowI: "(\<And>x. f\<cdot>x \<sqsubseteq> g\<cdot>x) \<Longrightarrow> f \<sqsubseteq> g"
150.182 -by (simp add: cfun_below_iff)
150.183 -
150.184 -text {* Congruence for continuous function application *}
150.185 -
150.186 -lemma cfun_cong: "\<lbrakk>f = g; x = y\<rbrakk> \<Longrightarrow> f\<cdot>x = g\<cdot>y"
150.187 -by simp
150.188 -
150.189 -lemma cfun_fun_cong: "f = g \<Longrightarrow> f\<cdot>x = g\<cdot>x"
150.190 -by simp
150.191 -
150.192 -lemma cfun_arg_cong: "x = y \<Longrightarrow> f\<cdot>x = f\<cdot>y"
150.193 -by simp
150.194 -
150.195 -subsection {* Continuity of application *}
150.196 -
150.197 -lemma cont_Rep_cfun1: "cont (\<lambda>f. f\<cdot>x)"
150.198 -by (rule cont_Rep_cfun [THEN cont2cont_fun])
150.199 -
150.200 -lemma cont_Rep_cfun2: "cont (\<lambda>x. f\<cdot>x)"
150.201 -apply (cut_tac x=f in Rep_cfun)
150.202 -apply (simp add: cfun_def)
150.203 -done
150.204 -
150.205 -lemmas monofun_Rep_cfun = cont_Rep_cfun [THEN cont2mono]
150.206 -
150.207 -lemmas monofun_Rep_cfun1 = cont_Rep_cfun1 [THEN cont2mono, standard]
150.208 -lemmas monofun_Rep_cfun2 = cont_Rep_cfun2 [THEN cont2mono, standard]
150.209 -
150.210 -text {* contlub, cont properties of @{term Rep_cfun} in each argument *}
150.211 -
150.212 -lemma contlub_cfun_arg: "chain Y \<Longrightarrow> f\<cdot>(\<Squnion>i. Y i) = (\<Squnion>i. f\<cdot>(Y i))"
150.213 -by (rule cont_Rep_cfun2 [THEN cont2contlubE])
150.214 -
150.215 -lemma contlub_cfun_fun: "chain F \<Longrightarrow> (\<Squnion>i. F i)\<cdot>x = (\<Squnion>i. F i\<cdot>x)"
150.216 -by (rule cont_Rep_cfun1 [THEN cont2contlubE])
150.217 -
150.218 -text {* monotonicity of application *}
150.219 -
150.220 -lemma monofun_cfun_fun: "f \<sqsubseteq> g \<Longrightarrow> f\<cdot>x \<sqsubseteq> g\<cdot>x"
150.221 -by (simp add: cfun_below_iff)
150.222 -
150.223 -lemma monofun_cfun_arg: "x \<sqsubseteq> y \<Longrightarrow> f\<cdot>x \<sqsubseteq> f\<cdot>y"
150.224 -by (rule monofun_Rep_cfun2 [THEN monofunE])
150.225 -
150.226 -lemma monofun_cfun: "\<lbrakk>f \<sqsubseteq> g; x \<sqsubseteq> y\<rbrakk> \<Longrightarrow> f\<cdot>x \<sqsubseteq> g\<cdot>y"
150.227 -by (rule below_trans [OF monofun_cfun_fun monofun_cfun_arg])
150.228 -
150.229 -text {* ch2ch - rules for the type @{typ "'a -> 'b"} *}
150.230 -
150.231 -lemma chain_monofun: "chain Y \<Longrightarrow> chain (\<lambda>i. f\<cdot>(Y i))"
150.232 -by (erule monofun_Rep_cfun2 [THEN ch2ch_monofun])
150.233 -
150.234 -lemma ch2ch_Rep_cfunR: "chain Y \<Longrightarrow> chain (\<lambda>i. f\<cdot>(Y i))"
150.235 -by (rule monofun_Rep_cfun2 [THEN ch2ch_monofun])
150.236 -
150.237 -lemma ch2ch_Rep_cfunL: "chain F \<Longrightarrow> chain (\<lambda>i. (F i)\<cdot>x)"
150.238 -by (rule monofun_Rep_cfun1 [THEN ch2ch_monofun])
150.239 -
150.240 -lemma ch2ch_Rep_cfun [simp]:
150.241 - "\<lbrakk>chain F; chain Y\<rbrakk> \<Longrightarrow> chain (\<lambda>i. (F i)\<cdot>(Y i))"
150.242 -by (simp add: chain_def monofun_cfun)
150.243 -
150.244 -lemma ch2ch_LAM [simp]:
150.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)"
150.246 -by (simp add: chain_def cfun_below_iff)
150.247 -
150.248 -text {* contlub, cont properties of @{term Rep_cfun} in both arguments *}
150.249 -
150.250 -lemma contlub_cfun:
150.251 - "\<lbrakk>chain F; chain Y\<rbrakk> \<Longrightarrow> (\<Squnion>i. F i)\<cdot>(\<Squnion>i. Y i) = (\<Squnion>i. F i\<cdot>(Y i))"
150.252 -by (simp add: contlub_cfun_fun contlub_cfun_arg diag_lub)
150.253 -
150.254 -lemma cont_cfun:
150.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)"
150.256 -apply (rule thelubE)
150.257 -apply (simp only: ch2ch_Rep_cfun)
150.258 -apply (simp only: contlub_cfun)
150.259 -done
150.260 -
150.261 -lemma contlub_LAM:
150.262 - "\<lbrakk>\<And>x. chain (\<lambda>i. F i x); \<And>i. cont (\<lambda>x. F i x)\<rbrakk>
150.263 - \<Longrightarrow> (\<Lambda> x. \<Squnion>i. F i x) = (\<Squnion>i. \<Lambda> x. F i x)"
150.264 -apply (simp add: lub_cfun)
150.265 -apply (simp add: Abs_cfun_inverse2)
150.266 -apply (simp add: thelub_fun ch2ch_lambda)
150.267 -done
150.268 -
150.269 -lemmas lub_distribs =
150.270 - contlub_cfun [symmetric]
150.271 - contlub_LAM [symmetric]
150.272 -
150.273 -text {* strictness *}
150.274 -
150.275 -lemma strictI: "f\<cdot>x = \<bottom> \<Longrightarrow> f\<cdot>\<bottom> = \<bottom>"
150.276 -apply (rule UU_I)
150.277 -apply (erule subst)
150.278 -apply (rule minimal [THEN monofun_cfun_arg])
150.279 -done
150.280 -
150.281 -text {* type @{typ "'a -> 'b"} is chain complete *}
150.282 -
150.283 -lemma lub_cfun: "chain F \<Longrightarrow> range F <<| (\<Lambda> x. \<Squnion>i. F i\<cdot>x)"
150.284 -by (simp only: contlub_cfun_fun [symmetric] eta_cfun thelubE)
150.285 -
150.286 -lemma thelub_cfun: "chain F \<Longrightarrow> (\<Squnion>i. F i) = (\<Lambda> x. \<Squnion>i. F i\<cdot>x)"
150.287 -by (rule lub_cfun [THEN lub_eqI])
150.288 -
150.289 -subsection {* Continuity simplification procedure *}
150.290 -
150.291 -text {* cont2cont lemma for @{term Rep_cfun} *}
150.292 -
150.293 -lemma cont2cont_APP [simp, cont2cont]:
150.294 - assumes f: "cont (\<lambda>x. f x)"
150.295 - assumes t: "cont (\<lambda>x. t x)"
150.296 - shows "cont (\<lambda>x. (f x)\<cdot>(t x))"
150.297 -proof -
150.298 - have 1: "\<And>y. cont (\<lambda>x. (f x)\<cdot>y)"
150.299 - using cont_Rep_cfun1 f by (rule cont_compose)
150.300 - show "cont (\<lambda>x. (f x)\<cdot>(t x))"
150.301 - using t cont_Rep_cfun2 1 by (rule cont_apply)
150.302 -qed
150.303 -
150.304 -text {*
150.305 - Two specific lemmas for the combination of LCF and HOL terms.
150.306 - These lemmas are needed in theories that use types like @{typ "'a \<rightarrow> 'b \<Rightarrow> 'c"}.
150.307 -*}
150.308 -
150.309 -lemma cont_APP_app [simp]: "\<lbrakk>cont f; cont g\<rbrakk> \<Longrightarrow> cont (\<lambda>x. ((f x)\<cdot>(g x)) s)"
150.310 -by (rule cont2cont_APP [THEN cont2cont_fun])
150.311 -
150.312 -lemma cont_APP_app_app [simp]: "\<lbrakk>cont f; cont g\<rbrakk> \<Longrightarrow> cont (\<lambda>x. ((f x)\<cdot>(g x)) s t)"
150.313 -by (rule cont_APP_app [THEN cont2cont_fun])
150.314 -
150.315 -
150.316 -text {* cont2mono Lemma for @{term "%x. LAM y. c1(x)(y)"} *}
150.317 -
150.318 -lemma cont2mono_LAM:
150.319 - "\<lbrakk>\<And>x. cont (\<lambda>y. f x y); \<And>y. monofun (\<lambda>x. f x y)\<rbrakk>
150.320 - \<Longrightarrow> monofun (\<lambda>x. \<Lambda> y. f x y)"
150.321 - unfolding monofun_def cfun_below_iff by simp
150.322 -
150.323 -text {* cont2cont Lemma for @{term "%x. LAM y. f x y"} *}
150.324 -
150.325 -text {*
150.326 - Not suitable as a cont2cont rule, because on nested lambdas
150.327 - it causes exponential blow-up in the number of subgoals.
150.328 -*}
150.329 -
150.330 -lemma cont2cont_LAM:
150.331 - assumes f1: "\<And>x. cont (\<lambda>y. f x y)"
150.332 - assumes f2: "\<And>y. cont (\<lambda>x. f x y)"
150.333 - shows "cont (\<lambda>x. \<Lambda> y. f x y)"
150.334 -proof (rule cont_Abs_cfun)
150.335 - fix x
150.336 - from f1 show "f x \<in> cfun" by (simp add: cfun_def)
150.337 - from f2 show "cont f" by (rule cont2cont_lambda)
150.338 -qed
150.339 -
150.340 -text {*
150.341 - This version does work as a cont2cont rule, since it
150.342 - has only a single subgoal.
150.343 -*}
150.344 -
150.345 -lemma cont2cont_LAM' [simp, cont2cont]:
150.346 - fixes f :: "'a::cpo \<Rightarrow> 'b::cpo \<Rightarrow> 'c::cpo"
150.347 - assumes f: "cont (\<lambda>p. f (fst p) (snd p))"
150.348 - shows "cont (\<lambda>x. \<Lambda> y. f x y)"
150.349 -using assms by (simp add: cont2cont_LAM prod_cont_iff)
150.350 -
150.351 -lemma cont2cont_LAM_discrete [simp, cont2cont]:
150.352 - "(\<And>y::'a::discrete_cpo. cont (\<lambda>x. f x y)) \<Longrightarrow> cont (\<lambda>x. \<Lambda> y. f x y)"
150.353 -by (simp add: cont2cont_LAM)
150.354 -
150.355 -subsection {* Miscellaneous *}
150.356 -
150.357 -text {* Monotonicity of @{term Abs_cfun} *}
150.358 -
150.359 -lemma monofun_LAM:
150.360 - "\<lbrakk>cont f; cont g; \<And>x. f x \<sqsubseteq> g x\<rbrakk> \<Longrightarrow> (\<Lambda> x. f x) \<sqsubseteq> (\<Lambda> x. g x)"
150.361 -by (simp add: cfun_below_iff)
150.362 -
150.363 -text {* some lemmata for functions with flat/chfin domain/range types *}
150.364 -
150.365 -lemma chfin_Rep_cfunR: "chain (Y::nat => 'a::cpo->'b::chfin)
150.366 - ==> !s. ? n. (LUB i. Y i)$s = Y n$s"
150.367 -apply (rule allI)
150.368 -apply (subst contlub_cfun_fun)
150.369 -apply assumption
150.370 -apply (fast intro!: lub_eqI chfin lub_finch2 chfin2finch ch2ch_Rep_cfunL)
150.371 -done
150.372 -
150.373 -lemma adm_chfindom: "adm (\<lambda>(u::'a::cpo \<rightarrow> 'b::chfin). P(u\<cdot>s))"
150.374 -by (rule adm_subst, simp, rule adm_chfin)
150.375 -
150.376 -subsection {* Continuous injection-retraction pairs *}
150.377 -
150.378 -text {* Continuous retractions are strict. *}
150.379 -
150.380 -lemma retraction_strict:
150.381 - "\<forall>x. f\<cdot>(g\<cdot>x) = x \<Longrightarrow> f\<cdot>\<bottom> = \<bottom>"
150.382 -apply (rule UU_I)
150.383 -apply (drule_tac x="\<bottom>" in spec)
150.384 -apply (erule subst)
150.385 -apply (rule monofun_cfun_arg)
150.386 -apply (rule minimal)
150.387 -done
150.388 -
150.389 -lemma injection_eq:
150.390 - "\<forall>x. f\<cdot>(g\<cdot>x) = x \<Longrightarrow> (g\<cdot>x = g\<cdot>y) = (x = y)"
150.391 -apply (rule iffI)
150.392 -apply (drule_tac f=f in cfun_arg_cong)
150.393 -apply simp
150.394 -apply simp
150.395 -done
150.396 -
150.397 -lemma injection_below:
150.398 - "\<forall>x. f\<cdot>(g\<cdot>x) = x \<Longrightarrow> (g\<cdot>x \<sqsubseteq> g\<cdot>y) = (x \<sqsubseteq> y)"
150.399 -apply (rule iffI)
150.400 -apply (drule_tac f=f in monofun_cfun_arg)
150.401 -apply simp
150.402 -apply (erule monofun_cfun_arg)
150.403 -done
150.404 -
150.405 -lemma injection_defined_rev:
150.406 - "\<lbrakk>\<forall>x. f\<cdot>(g\<cdot>x) = x; g\<cdot>z = \<bottom>\<rbrakk> \<Longrightarrow> z = \<bottom>"
150.407 -apply (drule_tac f=f in cfun_arg_cong)
150.408 -apply (simp add: retraction_strict)
150.409 -done
150.410 -
150.411 -lemma injection_defined:
150.412 - "\<lbrakk>\<forall>x. f\<cdot>(g\<cdot>x) = x; z \<noteq> \<bottom>\<rbrakk> \<Longrightarrow> g\<cdot>z \<noteq> \<bottom>"
150.413 -by (erule contrapos_nn, rule injection_defined_rev)
150.414 -
150.415 -text {* a result about functions with flat codomain *}
150.416 -
150.417 -lemma flat_eqI: "\<lbrakk>(x::'a::flat) \<sqsubseteq> y; x \<noteq> \<bottom>\<rbrakk> \<Longrightarrow> x = y"
150.418 -by (drule ax_flat, simp)
150.419 -
150.420 -lemma flat_codom:
150.421 - "f\<cdot>x = (c::'b::flat) \<Longrightarrow> f\<cdot>\<bottom> = \<bottom> \<or> (\<forall>z. f\<cdot>z = c)"
150.422 -apply (case_tac "f\<cdot>x = \<bottom>")
150.423 -apply (rule disjI1)
150.424 -apply (rule UU_I)
150.425 -apply (erule_tac t="\<bottom>" in subst)
150.426 -apply (rule minimal [THEN monofun_cfun_arg])
150.427 -apply clarify
150.428 -apply (rule_tac a = "f\<cdot>\<bottom>" in refl [THEN box_equals])
150.429 -apply (erule minimal [THEN monofun_cfun_arg, THEN flat_eqI])
150.430 -apply (erule minimal [THEN monofun_cfun_arg, THEN flat_eqI])
150.431 -done
150.432 -
150.433 -subsection {* Identity and composition *}
150.434 -
150.435 -definition
150.436 - ID :: "'a \<rightarrow> 'a" where
150.437 - "ID = (\<Lambda> x. x)"
150.438 -
150.439 -definition
150.440 - cfcomp :: "('b \<rightarrow> 'c) \<rightarrow> ('a \<rightarrow> 'b) \<rightarrow> 'a \<rightarrow> 'c" where
150.441 - oo_def: "cfcomp = (\<Lambda> f g x. f\<cdot>(g\<cdot>x))"
150.442 -
150.443 -abbreviation
150.444 - cfcomp_syn :: "['b \<rightarrow> 'c, 'a \<rightarrow> 'b] \<Rightarrow> 'a \<rightarrow> 'c" (infixr "oo" 100) where
150.445 - "f oo g == cfcomp\<cdot>f\<cdot>g"
150.446 -
150.447 -lemma ID1 [simp]: "ID\<cdot>x = x"
150.448 -by (simp add: ID_def)
150.449 -
150.450 -lemma cfcomp1: "(f oo g) = (\<Lambda> x. f\<cdot>(g\<cdot>x))"
150.451 -by (simp add: oo_def)
150.452 -
150.453 -lemma cfcomp2 [simp]: "(f oo g)\<cdot>x = f\<cdot>(g\<cdot>x)"
150.454 -by (simp add: cfcomp1)
150.455 -
150.456 -lemma cfcomp_LAM: "cont g \<Longrightarrow> f oo (\<Lambda> x. g x) = (\<Lambda> x. f\<cdot>(g x))"
150.457 -by (simp add: cfcomp1)
150.458 -
150.459 -lemma cfcomp_strict [simp]: "\<bottom> oo f = \<bottom>"
150.460 -by (simp add: cfun_eq_iff)
150.461 -
150.462 -text {*
150.463 - Show that interpretation of (pcpo,@{text "_->_"}) is a category.
150.464 - The class of objects is interpretation of syntactical class pcpo.
150.465 - The class of arrows between objects @{typ 'a} and @{typ 'b} is interpret. of @{typ "'a -> 'b"}.
150.466 - The identity arrow is interpretation of @{term ID}.
150.467 - The composition of f and g is interpretation of @{text "oo"}.
150.468 -*}
150.469 -
150.470 -lemma ID2 [simp]: "f oo ID = f"
150.471 -by (rule cfun_eqI, simp)
150.472 -
150.473 -lemma ID3 [simp]: "ID oo f = f"
150.474 -by (rule cfun_eqI, simp)
150.475 -
150.476 -lemma assoc_oo: "f oo (g oo h) = (f oo g) oo h"
150.477 -by (rule cfun_eqI, simp)
150.478 -
150.479 -subsection {* Strictified functions *}
150.480 -
150.481 -default_sort pcpo
150.482 -
150.483 -definition
150.484 - seq :: "'a \<rightarrow> 'b \<rightarrow> 'b" where
150.485 - "seq = (\<Lambda> x. if x = \<bottom> then \<bottom> else ID)"
150.486 -
150.487 -lemma cont_seq: "cont (\<lambda>x. if x = \<bottom> then \<bottom> else y)"
150.488 -unfolding cont_def is_lub_def is_ub_def ball_simps
150.489 -by (simp add: lub_eq_bottom_iff)
150.490 -
150.491 -lemma seq_conv_if: "seq\<cdot>x = (if x = \<bottom> then \<bottom> else ID)"
150.492 -unfolding seq_def by (simp add: cont_seq)
150.493 -
150.494 -lemma seq1 [simp]: "seq\<cdot>\<bottom> = \<bottom>"
150.495 -by (simp add: seq_conv_if)
150.496 -
150.497 -lemma seq2 [simp]: "x \<noteq> \<bottom> \<Longrightarrow> seq\<cdot>x = ID"
150.498 -by (simp add: seq_conv_if)
150.499 -
150.500 -lemma seq3 [simp]: "seq\<cdot>x\<cdot>\<bottom> = \<bottom>"
150.501 -by (simp add: seq_conv_if)
150.502 -
150.503 -definition
150.504 - strictify :: "('a \<rightarrow> 'b) \<rightarrow> 'a \<rightarrow> 'b" where
150.505 - "strictify = (\<Lambda> f x. seq\<cdot>x\<cdot>(f\<cdot>x))"
150.506 -
150.507 -lemma strictify_conv_if: "strictify\<cdot>f\<cdot>x = (if x = \<bottom> then \<bottom> else f\<cdot>x)"
150.508 -unfolding strictify_def by simp
150.509 -
150.510 -lemma strictify1 [simp]: "strictify\<cdot>f\<cdot>\<bottom> = \<bottom>"
150.511 -by (simp add: strictify_conv_if)
150.512 -
150.513 -lemma strictify2 [simp]: "x \<noteq> \<bottom> \<Longrightarrow> strictify\<cdot>f\<cdot>x = f\<cdot>x"
150.514 -by (simp add: strictify_conv_if)
150.515 -
150.516 -subsection {* Continuity of let-bindings *}
150.517 -
150.518 -lemma cont2cont_Let:
150.519 - assumes f: "cont (\<lambda>x. f x)"
150.520 - assumes g1: "\<And>y. cont (\<lambda>x. g x y)"
150.521 - assumes g2: "\<And>x. cont (\<lambda>y. g x y)"
150.522 - shows "cont (\<lambda>x. let y = f x in g x y)"
150.523 -unfolding Let_def using f g2 g1 by (rule cont_apply)
150.524 -
150.525 -lemma cont2cont_Let' [simp, cont2cont]:
150.526 - assumes f: "cont (\<lambda>x. f x)"
150.527 - assumes g: "cont (\<lambda>p. g (fst p) (snd p))"
150.528 - shows "cont (\<lambda>x. let y = f x in g x y)"
150.529 -using f
150.530 -proof (rule cont2cont_Let)
150.531 - fix x show "cont (\<lambda>y. g x y)"
150.532 - using g by (simp add: prod_cont_iff)
150.533 -next
150.534 - fix y show "cont (\<lambda>x. g x y)"
150.535 - using g by (simp add: prod_cont_iff)
150.536 -qed
150.537 -
150.538 -text {* The simple version (suggested by Joachim Breitner) is needed if
150.539 - the type of the defined term is not a cpo. *}
150.540 -
150.541 -lemma cont2cont_Let_simple [simp, cont2cont]:
150.542 - assumes "\<And>y. cont (\<lambda>x. g x y)"
150.543 - shows "cont (\<lambda>x. let y = t in g x y)"
150.544 -unfolding Let_def using assms .
150.545 -
150.546 -end
151.1 --- a/src/HOLCF/CompactBasis.thy Sat Nov 27 14:34:54 2010 -0800
151.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
151.3 @@ -1,111 +0,0 @@
151.4 -(* Title: HOLCF/CompactBasis.thy
151.5 - Author: Brian Huffman
151.6 -*)
151.7 -
151.8 -header {* A compact basis for powerdomains *}
151.9 -
151.10 -theory CompactBasis
151.11 -imports Bifinite
151.12 -begin
151.13 -
151.14 -default_sort "domain"
151.15 -
151.16 -subsection {* A compact basis for powerdomains *}
151.17 -
151.18 -typedef 'a pd_basis =
151.19 - "{S::'a compact_basis set. finite S \<and> S \<noteq> {}}"
151.20 -by (rule_tac x="{arbitrary}" in exI, simp)
151.21 -
151.22 -lemma finite_Rep_pd_basis [simp]: "finite (Rep_pd_basis u)"
151.23 -by (insert Rep_pd_basis [of u, unfolded pd_basis_def]) simp
151.24 -
151.25 -lemma Rep_pd_basis_nonempty [simp]: "Rep_pd_basis u \<noteq> {}"
151.26 -by (insert Rep_pd_basis [of u, unfolded pd_basis_def]) simp
151.27 -
151.28 -text {* The powerdomain basis type is countable. *}
151.29 -
151.30 -lemma pd_basis_countable: "\<exists>f::'a pd_basis \<Rightarrow> nat. inj f"
151.31 -proof -
151.32 - obtain g :: "'a compact_basis \<Rightarrow> nat" where "inj g"
151.33 - using compact_basis.countable ..
151.34 - hence image_g_eq: "\<And>A B. g ` A = g ` B \<longleftrightarrow> A = B"
151.35 - by (rule inj_image_eq_iff)
151.36 - have "inj (\<lambda>t. set_encode (g ` Rep_pd_basis t))"
151.37 - by (simp add: inj_on_def set_encode_eq image_g_eq Rep_pd_basis_inject)
151.38 - thus ?thesis by - (rule exI)
151.39 - (* FIXME: why doesn't ".." or "by (rule exI)" work? *)
151.40 -qed
151.41 -
151.42 -subsection {* Unit and plus constructors *}
151.43 -
151.44 -definition
151.45 - PDUnit :: "'a compact_basis \<Rightarrow> 'a pd_basis" where
151.46 - "PDUnit = (\<lambda>x. Abs_pd_basis {x})"
151.47 -
151.48 -definition
151.49 - PDPlus :: "'a pd_basis \<Rightarrow> 'a pd_basis \<Rightarrow> 'a pd_basis" where
151.50 - "PDPlus t u = Abs_pd_basis (Rep_pd_basis t \<union> Rep_pd_basis u)"
151.51 -
151.52 -lemma Rep_PDUnit:
151.53 - "Rep_pd_basis (PDUnit x) = {x}"
151.54 -unfolding PDUnit_def by (rule Abs_pd_basis_inverse) (simp add: pd_basis_def)
151.55 -
151.56 -lemma Rep_PDPlus:
151.57 - "Rep_pd_basis (PDPlus u v) = Rep_pd_basis u \<union> Rep_pd_basis v"
151.58 -unfolding PDPlus_def by (rule Abs_pd_basis_inverse) (simp add: pd_basis_def)
151.59 -
151.60 -lemma PDUnit_inject [simp]: "(PDUnit a = PDUnit b) = (a = b)"
151.61 -unfolding Rep_pd_basis_inject [symmetric] Rep_PDUnit by simp
151.62 -
151.63 -lemma PDPlus_assoc: "PDPlus (PDPlus t u) v = PDPlus t (PDPlus u v)"
151.64 -unfolding Rep_pd_basis_inject [symmetric] Rep_PDPlus by (rule Un_assoc)
151.65 -
151.66 -lemma PDPlus_commute: "PDPlus t u = PDPlus u t"
151.67 -unfolding Rep_pd_basis_inject [symmetric] Rep_PDPlus by (rule Un_commute)
151.68 -
151.69 -lemma PDPlus_absorb: "PDPlus t t = t"
151.70 -unfolding Rep_pd_basis_inject [symmetric] Rep_PDPlus by (rule Un_absorb)
151.71 -
151.72 -lemma pd_basis_induct1:
151.73 - assumes PDUnit: "\<And>a. P (PDUnit a)"
151.74 - assumes PDPlus: "\<And>a t. P t \<Longrightarrow> P (PDPlus (PDUnit a) t)"
151.75 - shows "P x"
151.76 -apply (induct x, unfold pd_basis_def, clarify)
151.77 -apply (erule (1) finite_ne_induct)
151.78 -apply (cut_tac a=x in PDUnit)
151.79 -apply (simp add: PDUnit_def)
151.80 -apply (drule_tac a=x in PDPlus)
151.81 -apply (simp add: PDUnit_def PDPlus_def
151.82 - Abs_pd_basis_inverse [unfolded pd_basis_def])
151.83 -done
151.84 -
151.85 -lemma pd_basis_induct:
151.86 - assumes PDUnit: "\<And>a. P (PDUnit a)"
151.87 - assumes PDPlus: "\<And>t u. \<lbrakk>P t; P u\<rbrakk> \<Longrightarrow> P (PDPlus t u)"
151.88 - shows "P x"
151.89 -apply (induct x rule: pd_basis_induct1)
151.90 -apply (rule PDUnit, erule PDPlus [OF PDUnit])
151.91 -done
151.92 -
151.93 -subsection {* Fold operator *}
151.94 -
151.95 -definition
151.96 - fold_pd ::
151.97 - "('a compact_basis \<Rightarrow> 'b::type) \<Rightarrow> ('b \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> 'a pd_basis \<Rightarrow> 'b"
151.98 - where "fold_pd g f t = fold1 f (g ` Rep_pd_basis t)"
151.99 -
151.100 -lemma fold_pd_PDUnit:
151.101 - assumes "class.ab_semigroup_idem_mult f"
151.102 - shows "fold_pd g f (PDUnit x) = g x"
151.103 -unfolding fold_pd_def Rep_PDUnit by simp
151.104 -
151.105 -lemma fold_pd_PDPlus:
151.106 - assumes "class.ab_semigroup_idem_mult f"
151.107 - shows "fold_pd g f (PDPlus t u) = f (fold_pd g f t) (fold_pd g f u)"
151.108 -proof -
151.109 - interpret ab_semigroup_idem_mult f by fact
151.110 - show ?thesis unfolding fold_pd_def Rep_PDPlus
151.111 - by (simp add: image_Un fold1_Un2)
151.112 -qed
151.113 -
151.114 -end
152.1 --- a/src/HOLCF/Completion.thy Sat Nov 27 14:34:54 2010 -0800
152.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
152.3 @@ -1,433 +0,0 @@
152.4 -(* Title: HOLCF/Completion.thy
152.5 - Author: Brian Huffman
152.6 -*)
152.7 -
152.8 -header {* Defining algebraic domains by ideal completion *}
152.9 -
152.10 -theory Completion
152.11 -imports Plain_HOLCF
152.12 -begin
152.13 -
152.14 -subsection {* Ideals over a preorder *}
152.15 -
152.16 -locale preorder =
152.17 - fixes r :: "'a::type \<Rightarrow> 'a \<Rightarrow> bool" (infix "\<preceq>" 50)
152.18 - assumes r_refl: "x \<preceq> x"
152.19 - assumes r_trans: "\<lbrakk>x \<preceq> y; y \<preceq> z\<rbrakk> \<Longrightarrow> x \<preceq> z"
152.20 -begin
152.21 -
152.22 -definition
152.23 - ideal :: "'a set \<Rightarrow> bool" where
152.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>
152.25 - (\<forall>x y. x \<preceq> y \<longrightarrow> y \<in> A \<longrightarrow> x \<in> A))"
152.26 -
152.27 -lemma idealI:
152.28 - assumes "\<exists>x. x \<in> A"
152.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"
152.30 - assumes "\<And>x y. \<lbrakk>x \<preceq> y; y \<in> A\<rbrakk> \<Longrightarrow> x \<in> A"
152.31 - shows "ideal A"
152.32 -unfolding ideal_def using prems by fast
152.33 -
152.34 -lemma idealD1:
152.35 - "ideal A \<Longrightarrow> \<exists>x. x \<in> A"
152.36 -unfolding ideal_def by fast
152.37 -
152.38 -lemma idealD2:
152.39 - "\<lbrakk>ideal A; x \<in> A; y \<in> A\<rbrakk> \<Longrightarrow> \<exists>z\<in>A. x \<preceq> z \<and> y \<preceq> z"
152.40 -unfolding ideal_def by fast
152.41 -
152.42 -lemma idealD3:
152.43 - "\<lbrakk>ideal A; x \<preceq> y; y \<in> A\<rbrakk> \<Longrightarrow> x \<in> A"
152.44 -unfolding ideal_def by fast
152.45 -
152.46 -lemma ideal_principal: "ideal {x. x \<preceq> z}"
152.47 -apply (rule idealI)
152.48 -apply (rule_tac x=z in exI)
152.49 -apply (fast intro: r_refl)
152.50 -apply (rule_tac x=z in bexI, fast)
152.51 -apply (fast intro: r_refl)
152.52 -apply (fast intro: r_trans)
152.53 -done
152.54 -
152.55 -lemma ex_ideal: "\<exists>A. ideal A"
152.56 -by (rule exI, rule ideal_principal)
152.57 -
152.58 -lemma lub_image_principal:
152.59 - assumes f: "\<And>x y. x \<preceq> y \<Longrightarrow> f x \<sqsubseteq> f y"
152.60 - shows "(\<Squnion>x\<in>{x. x \<preceq> y}. f x) = f y"
152.61 -apply (rule lub_eqI)
152.62 -apply (rule is_lub_maximal)
152.63 -apply (rule ub_imageI)
152.64 -apply (simp add: f)
152.65 -apply (rule imageI)
152.66 -apply (simp add: r_refl)
152.67 -done
152.68 -
152.69 -text {* The set of ideals is a cpo *}
152.70 -
152.71 -lemma ideal_UN:
152.72 - fixes A :: "nat \<Rightarrow> 'a set"
152.73 - assumes ideal_A: "\<And>i. ideal (A i)"
152.74 - assumes chain_A: "\<And>i j. i \<le> j \<Longrightarrow> A i \<subseteq> A j"
152.75 - shows "ideal (\<Union>i. A i)"
152.76 - apply (rule idealI)
152.77 - apply (cut_tac idealD1 [OF ideal_A], fast)
152.78 - apply (clarify, rename_tac i j)
152.79 - apply (drule subsetD [OF chain_A [OF le_maxI1]])
152.80 - apply (drule subsetD [OF chain_A [OF le_maxI2]])
152.81 - apply (drule (1) idealD2 [OF ideal_A])
152.82 - apply blast
152.83 - apply clarify
152.84 - apply (drule (1) idealD3 [OF ideal_A])
152.85 - apply fast
152.86 -done
152.87 -
152.88 -lemma typedef_ideal_po:
152.89 - fixes Abs :: "'a set \<Rightarrow> 'b::below"
152.90 - assumes type: "type_definition Rep Abs {S. ideal S}"
152.91 - assumes below: "\<And>x y. x \<sqsubseteq> y \<longleftrightarrow> Rep x \<subseteq> Rep y"
152.92 - shows "OFCLASS('b, po_class)"
152.93 - apply (intro_classes, unfold below)
152.94 - apply (rule subset_refl)
152.95 - apply (erule (1) subset_trans)
152.96 - apply (rule type_definition.Rep_inject [OF type, THEN iffD1])
152.97 - apply (erule (1) subset_antisym)
152.98 -done
152.99 -
152.100 -lemma
152.101 - fixes Abs :: "'a set \<Rightarrow> 'b::po"
152.102 - assumes type: "type_definition Rep Abs {S. ideal S}"
152.103 - assumes below: "\<And>x y. x \<sqsubseteq> y \<longleftrightarrow> Rep x \<subseteq> Rep y"
152.104 - assumes S: "chain S"
152.105 - shows typedef_ideal_lub: "range S <<| Abs (\<Union>i. Rep (S i))"
152.106 - and typedef_ideal_rep_lub: "Rep (\<Squnion>i. S i) = (\<Union>i. Rep (S i))"
152.107 -proof -
152.108 - have 1: "ideal (\<Union>i. Rep (S i))"
152.109 - apply (rule ideal_UN)
152.110 - apply (rule type_definition.Rep [OF type, unfolded mem_Collect_eq])
152.111 - apply (subst below [symmetric])
152.112 - apply (erule chain_mono [OF S])
152.113 - done
152.114 - hence 2: "Rep (Abs (\<Union>i. Rep (S i))) = (\<Union>i. Rep (S i))"
152.115 - by (simp add: type_definition.Abs_inverse [OF type])
152.116 - show 3: "range S <<| Abs (\<Union>i. Rep (S i))"
152.117 - apply (rule is_lubI)
152.118 - apply (rule is_ubI)
152.119 - apply (simp add: below 2, fast)
152.120 - apply (simp add: below 2 is_ub_def, fast)
152.121 - done
152.122 - hence 4: "(\<Squnion>i. S i) = Abs (\<Union>i. Rep (S i))"
152.123 - by (rule lub_eqI)
152.124 - show 5: "Rep (\<Squnion>i. S i) = (\<Union>i. Rep (S i))"
152.125 - by (simp add: 4 2)
152.126 -qed
152.127 -
152.128 -lemma typedef_ideal_cpo:
152.129 - fixes Abs :: "'a set \<Rightarrow> 'b::po"
152.130 - assumes type: "type_definition Rep Abs {S. ideal S}"
152.131 - assumes below: "\<And>x y. x \<sqsubseteq> y \<longleftrightarrow> Rep x \<subseteq> Rep y"
152.132 - shows "OFCLASS('b, cpo_class)"
152.133 -by (default, rule exI, erule typedef_ideal_lub [OF type below])
152.134 -
152.135 -end
152.136 -
152.137 -interpretation below: preorder "below :: 'a::po \<Rightarrow> 'a \<Rightarrow> bool"
152.138 -apply unfold_locales
152.139 -apply (rule below_refl)
152.140 -apply (erule (1) below_trans)
152.141 -done
152.142 -
152.143 -subsection {* Lemmas about least upper bounds *}
152.144 -
152.145 -lemma is_ub_thelub_ex: "\<lbrakk>\<exists>u. S <<| u; x \<in> S\<rbrakk> \<Longrightarrow> x \<sqsubseteq> lub S"
152.146 -apply (erule exE, drule is_lub_lub)
152.147 -apply (drule is_lubD1)
152.148 -apply (erule (1) is_ubD)
152.149 -done
152.150 -
152.151 -lemma is_lub_thelub_ex: "\<lbrakk>\<exists>u. S <<| u; S <| x\<rbrakk> \<Longrightarrow> lub S \<sqsubseteq> x"
152.152 -by (erule exE, drule is_lub_lub, erule is_lubD2)
152.153 -
152.154 -subsection {* Locale for ideal completion *}
152.155 -
152.156 -locale ideal_completion = preorder +
152.157 - fixes principal :: "'a::type \<Rightarrow> 'b::cpo"
152.158 - fixes rep :: "'b::cpo \<Rightarrow> 'a::type set"
152.159 - assumes ideal_rep: "\<And>x. ideal (rep x)"
152.160 - assumes rep_lub: "\<And>Y. chain Y \<Longrightarrow> rep (\<Squnion>i. Y i) = (\<Union>i. rep (Y i))"
152.161 - assumes rep_principal: "\<And>a. rep (principal a) = {b. b \<preceq> a}"
152.162 - assumes subset_repD: "\<And>x y. rep x \<subseteq> rep y \<Longrightarrow> x \<sqsubseteq> y"
152.163 - assumes countable: "\<exists>f::'a \<Rightarrow> nat. inj f"
152.164 -begin
152.165 -
152.166 -lemma rep_mono: "x \<sqsubseteq> y \<Longrightarrow> rep x \<subseteq> rep y"
152.167 -apply (frule bin_chain)
152.168 -apply (drule rep_lub)
152.169 -apply (simp only: lub_eqI [OF is_lub_bin_chain])
152.170 -apply (rule subsetI, rule UN_I [where a=0], simp_all)
152.171 -done
152.172 -
152.173 -lemma below_def: "x \<sqsubseteq> y \<longleftrightarrow> rep x \<subseteq> rep y"
152.174 -by (rule iffI [OF rep_mono subset_repD])
152.175 -
152.176 -lemma rep_eq: "rep x = {a. principal a \<sqsubseteq> x}"
152.177 -unfolding below_def rep_principal
152.178 -apply safe
152.179 -apply (erule (1) idealD3 [OF ideal_rep])
152.180 -apply (erule subsetD, simp add: r_refl)
152.181 -done
152.182 -
152.183 -lemma mem_rep_iff_principal_below: "a \<in> rep x \<longleftrightarrow> principal a \<sqsubseteq> x"
152.184 -by (simp add: rep_eq)
152.185 -
152.186 -lemma principal_below_iff_mem_rep: "principal a \<sqsubseteq> x \<longleftrightarrow> a \<in> rep x"
152.187 -by (simp add: rep_eq)
152.188 -
152.189 -lemma principal_below_iff [simp]: "principal a \<sqsubseteq> principal b \<longleftrightarrow> a \<preceq> b"
152.190 -by (simp add: principal_below_iff_mem_rep rep_principal)
152.191 -
152.192 -lemma principal_eq_iff: "principal a = principal b \<longleftrightarrow> a \<preceq> b \<and> b \<preceq> a"
152.193 -unfolding po_eq_conv [where 'a='b] principal_below_iff ..
152.194 -
152.195 -lemma eq_iff: "x = y \<longleftrightarrow> rep x = rep y"
152.196 -unfolding po_eq_conv below_def by auto
152.197 -
152.198 -lemma repD: "a \<in> rep x \<Longrightarrow> principal a \<sqsubseteq> x"
152.199 -by (simp add: rep_eq)
152.200 -
152.201 -lemma principal_mono: "a \<preceq> b \<Longrightarrow> principal a \<sqsubseteq> principal b"
152.202 -by (simp only: principal_below_iff)
152.203 -
152.204 -lemma ch2ch_principal [simp]:
152.205 - "\<forall>i. Y i \<preceq> Y (Suc i) \<Longrightarrow> chain (\<lambda>i. principal (Y i))"
152.206 -by (simp add: chainI principal_mono)
152.207 -
152.208 -lemma lub_principal_rep: "principal ` rep x <<| x"
152.209 -apply (rule is_lubI)
152.210 -apply (rule ub_imageI)
152.211 -apply (erule repD)
152.212 -apply (subst below_def)
152.213 -apply (rule subsetI)
152.214 -apply (drule (1) ub_imageD)
152.215 -apply (simp add: rep_eq)
152.216 -done
152.217 -
152.218 -subsubsection {* Principal ideals approximate all elements *}
152.219 -
152.220 -lemma compact_principal [simp]: "compact (principal a)"
152.221 -by (rule compactI2, simp add: principal_below_iff_mem_rep rep_lub)
152.222 -
152.223 -text {* Construct a chain whose lub is the same as a given ideal *}
152.224 -
152.225 -lemma obtain_principal_chain:
152.226 - obtains Y where "\<forall>i. Y i \<preceq> Y (Suc i)" and "x = (\<Squnion>i. principal (Y i))"
152.227 -proof -
152.228 - obtain count :: "'a \<Rightarrow> nat" where inj: "inj count"
152.229 - using countable ..
152.230 - def enum \<equiv> "\<lambda>i. THE a. count a = i"
152.231 - have enum_count [simp]: "\<And>x. enum (count x) = x"
152.232 - unfolding enum_def by (simp add: inj_eq [OF inj])
152.233 - def a \<equiv> "LEAST i. enum i \<in> rep x"
152.234 - def b \<equiv> "\<lambda>i. LEAST j. enum j \<in> rep x \<and> \<not> enum j \<preceq> enum i"
152.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"
152.236 - def P \<equiv> "\<lambda>i. \<exists>j. enum j \<in> rep x \<and> \<not> enum j \<preceq> enum i"
152.237 - def X \<equiv> "nat_rec a (\<lambda>n i. if P i then c i (b i) else i)"
152.238 - have X_0: "X 0 = a" unfolding X_def by simp
152.239 - have X_Suc: "\<And>n. X (Suc n) = (if P (X n) then c (X n) (b (X n)) else X n)"
152.240 - unfolding X_def by simp
152.241 - have a_mem: "enum a \<in> rep x"
152.242 - unfolding a_def
152.243 - apply (rule LeastI_ex)
152.244 - apply (cut_tac ideal_rep [of x])
152.245 - apply (drule idealD1)
152.246 - apply (clarify, rename_tac a)
152.247 - apply (rule_tac x="count a" in exI, simp)
152.248 - done
152.249 - have b: "\<And>i. P i \<Longrightarrow> enum i \<in> rep x
152.250 - \<Longrightarrow> enum (b i) \<in> rep x \<and> \<not> enum (b i) \<preceq> enum i"
152.251 - unfolding P_def b_def by (erule LeastI2_ex, simp)
152.252 - have c: "\<And>i j. enum i \<in> rep x \<Longrightarrow> enum j \<in> rep x
152.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)"
152.254 - unfolding c_def
152.255 - apply (drule (1) idealD2 [OF ideal_rep], clarify)
152.256 - apply (rule_tac a="count z" in LeastI2, simp, simp)
152.257 - done
152.258 - have X_mem: "\<And>n. enum (X n) \<in> rep x"
152.259 - apply (induct_tac n)
152.260 - apply (simp add: X_0 a_mem)
152.261 - apply (clarsimp simp add: X_Suc, rename_tac n)
152.262 - apply (simp add: b c)
152.263 - done
152.264 - have X_chain: "\<And>n. enum (X n) \<preceq> enum (X (Suc n))"
152.265 - apply (clarsimp simp add: X_Suc r_refl)
152.266 - apply (simp add: b c X_mem)
152.267 - done
152.268 - have less_b: "\<And>n i. n < b i \<Longrightarrow> enum n \<in> rep x \<Longrightarrow> enum n \<preceq> enum i"
152.269 - unfolding b_def by (drule not_less_Least, simp)
152.270 - have X_covers: "\<And>n. \<forall>k\<le>n. enum k \<in> rep x \<longrightarrow> enum k \<preceq> enum (X n)"
152.271 - apply (induct_tac n)
152.272 - apply (clarsimp simp add: X_0 a_def)
152.273 - apply (drule_tac k=0 in Least_le, simp add: r_refl)
152.274 - apply (clarsimp, rename_tac n k)
152.275 - apply (erule le_SucE)
152.276 - apply (rule r_trans [OF _ X_chain], simp)
152.277 - apply (case_tac "P (X n)", simp add: X_Suc)
152.278 - apply (rule_tac x="b (X n)" and y="Suc n" in linorder_cases)
152.279 - apply (simp only: less_Suc_eq_le)
152.280 - apply (drule spec, drule (1) mp, simp add: b X_mem)
152.281 - apply (simp add: c X_mem)
152.282 - apply (drule (1) less_b)
152.283 - apply (erule r_trans)
152.284 - apply (simp add: b c X_mem)
152.285 - apply (simp add: X_Suc)
152.286 - apply (simp add: P_def)
152.287 - done
152.288 - have 1: "\<forall>i. enum (X i) \<preceq> enum (X (Suc i))"
152.289 - by (simp add: X_chain)
152.290 - have 2: "x = (\<Squnion>n. principal (enum (X n)))"
152.291 - apply (simp add: eq_iff rep_lub 1 rep_principal)
152.292 - apply (auto, rename_tac a)
152.293 - apply (subgoal_tac "\<exists>i. a = enum i", erule exE)
152.294 - apply (rule_tac x=i in exI, simp add: X_covers)
152.295 - apply (rule_tac x="count a" in exI, simp)
152.296 - apply (erule idealD3 [OF ideal_rep])
152.297 - apply (rule X_mem)
152.298 - done
152.299 - from 1 2 show ?thesis ..
152.300 -qed
152.301 -
152.302 -lemma principal_induct:
152.303 - assumes adm: "adm P"
152.304 - assumes P: "\<And>a. P (principal a)"
152.305 - shows "P x"
152.306 -apply (rule obtain_principal_chain [of x])
152.307 -apply (simp add: admD [OF adm] P)
152.308 -done
152.309 -
152.310 -lemma principal_induct2:
152.311 - "\<lbrakk>\<And>y. adm (\<lambda>x. P x y); \<And>x. adm (\<lambda>y. P x y);
152.312 - \<And>a b. P (principal a) (principal b)\<rbrakk> \<Longrightarrow> P x y"
152.313 -apply (rule_tac x=y in spec)
152.314 -apply (rule_tac x=x in principal_induct, simp)
152.315 -apply (rule allI, rename_tac y)
152.316 -apply (rule_tac x=y in principal_induct, simp)
152.317 -apply simp
152.318 -done
152.319 -
152.320 -lemma compact_imp_principal: "compact x \<Longrightarrow> \<exists>a. x = principal a"
152.321 -apply (rule obtain_principal_chain [of x])
152.322 -apply (drule adm_compact_neq [OF _ cont_id])
152.323 -apply (subgoal_tac "chain (\<lambda>i. principal (Y i))")
152.324 -apply (drule (2) admD2, fast, simp)
152.325 -done
152.326 -
152.327 -lemma obtain_compact_chain:
152.328 - obtains Y :: "nat \<Rightarrow> 'b"
152.329 - where "chain Y" and "\<forall>i. compact (Y i)" and "x = (\<Squnion>i. Y i)"
152.330 -apply (rule obtain_principal_chain [of x])
152.331 -apply (rule_tac Y="\<lambda>i. principal (Y i)" in that, simp_all)
152.332 -done
152.333 -
152.334 -subsection {* Defining functions in terms of basis elements *}
152.335 -
152.336 -definition
152.337 - basis_fun :: "('a::type \<Rightarrow> 'c::cpo) \<Rightarrow> 'b \<rightarrow> 'c" where
152.338 - "basis_fun = (\<lambda>f. (\<Lambda> x. lub (f ` rep x)))"
152.339 -
152.340 -lemma basis_fun_lemma:
152.341 - fixes f :: "'a::type \<Rightarrow> 'c::cpo"
152.342 - assumes f_mono: "\<And>a b. a \<preceq> b \<Longrightarrow> f a \<sqsubseteq> f b"
152.343 - shows "\<exists>u. f ` rep x <<| u"
152.344 -proof -
152.345 - obtain Y where Y: "\<forall>i. Y i \<preceq> Y (Suc i)"
152.346 - and x: "x = (\<Squnion>i. principal (Y i))"
152.347 - by (rule obtain_principal_chain [of x])
152.348 - have chain: "chain (\<lambda>i. f (Y i))"
152.349 - by (rule chainI, simp add: f_mono Y)
152.350 - have rep_x: "rep x = (\<Union>n. {a. a \<preceq> Y n})"
152.351 - by (simp add: x rep_lub Y rep_principal)
152.352 - have "f ` rep x <<| (\<Squnion>n. f (Y n))"
152.353 - apply (rule is_lubI)
152.354 - apply (rule ub_imageI, rename_tac a)
152.355 - apply (clarsimp simp add: rep_x)
152.356 - apply (drule f_mono)
152.357 - apply (erule below_lub [OF chain])
152.358 - apply (rule lub_below [OF chain])
152.359 - apply (drule_tac x="Y n" in ub_imageD)
152.360 - apply (simp add: rep_x, fast intro: r_refl)
152.361 - apply assumption
152.362 - done
152.363 - thus ?thesis ..
152.364 -qed
152.365 -
152.366 -lemma basis_fun_beta:
152.367 - fixes f :: "'a::type \<Rightarrow> 'c::cpo"
152.368 - assumes f_mono: "\<And>a b. a \<preceq> b \<Longrightarrow> f a \<sqsubseteq> f b"
152.369 - shows "basis_fun f\<cdot>x = lub (f ` rep x)"
152.370 -unfolding basis_fun_def
152.371 -proof (rule beta_cfun)
152.372 - have lub: "\<And>x. \<exists>u. f ` rep x <<| u"
152.373 - using f_mono by (rule basis_fun_lemma)
152.374 - show cont: "cont (\<lambda>x. lub (f ` rep x))"
152.375 - apply (rule contI2)
152.376 - apply (rule monofunI)
152.377 - apply (rule is_lub_thelub_ex [OF lub ub_imageI])
152.378 - apply (rule is_ub_thelub_ex [OF lub imageI])
152.379 - apply (erule (1) subsetD [OF rep_mono])
152.380 - apply (rule is_lub_thelub_ex [OF lub ub_imageI])
152.381 - apply (simp add: rep_lub, clarify)
152.382 - apply (erule rev_below_trans [OF is_ub_thelub])
152.383 - apply (erule is_ub_thelub_ex [OF lub imageI])
152.384 - done
152.385 -qed
152.386 -
152.387 -lemma basis_fun_principal:
152.388 - fixes f :: "'a::type \<Rightarrow> 'c::cpo"
152.389 - assumes f_mono: "\<And>a b. a \<preceq> b \<Longrightarrow> f a \<sqsubseteq> f b"
152.390 - shows "basis_fun f\<cdot>(principal a) = f a"
152.391 -apply (subst basis_fun_beta, erule f_mono)
152.392 -apply (subst rep_principal)
152.393 -apply (rule lub_image_principal, erule f_mono)
152.394 -done
152.395 -
152.396 -lemma basis_fun_mono:
152.397 - assumes f_mono: "\<And>a b. a \<preceq> b \<Longrightarrow> f a \<sqsubseteq> f b"
152.398 - assumes g_mono: "\<And>a b. a \<preceq> b \<Longrightarrow> g a \<sqsubseteq> g b"
152.399 - assumes below: "\<And>a. f a \<sqsubseteq> g a"
152.400 - shows "basis_fun f \<sqsubseteq> basis_fun g"
152.401 - apply (rule cfun_belowI)
152.402 - apply (simp only: basis_fun_beta f_mono g_mono)
152.403 - apply (rule is_lub_thelub_ex)
152.404 - apply (rule basis_fun_lemma, erule f_mono)
152.405 - apply (rule ub_imageI, rename_tac a)
152.406 - apply (rule below_trans [OF below])
152.407 - apply (rule is_ub_thelub_ex)
152.408 - apply (rule basis_fun_lemma, erule g_mono)
152.409 - apply (erule imageI)
152.410 -done
152.411 -
152.412 -end
152.413 -
152.414 -lemma (in preorder) typedef_ideal_completion:
152.415 - fixes Abs :: "'a set \<Rightarrow> 'b::cpo"
152.416 - assumes type: "type_definition Rep Abs {S. ideal S}"
152.417 - assumes below: "\<And>x y. x \<sqsubseteq> y \<longleftrightarrow> Rep x \<subseteq> Rep y"
152.418 - assumes principal: "\<And>a. principal a = Abs {b. b \<preceq> a}"
152.419 - assumes countable: "\<exists>f::'a \<Rightarrow> nat. inj f"
152.420 - shows "ideal_completion r principal Rep"
152.421 -proof
152.422 - interpret type_definition Rep Abs "{S. ideal S}" by fact
152.423 - fix a b :: 'a and x y :: 'b and Y :: "nat \<Rightarrow> 'b"
152.424 - show "ideal (Rep x)"
152.425 - using Rep [of x] by simp
152.426 - show "chain Y \<Longrightarrow> Rep (\<Squnion>i. Y i) = (\<Union>i. Rep (Y i))"
152.427 - using type below by (rule typedef_ideal_rep_lub)
152.428 - show "Rep (principal a) = {b. b \<preceq> a}"
152.429 - by (simp add: principal Abs_inverse ideal_principal)
152.430 - show "Rep x \<subseteq> Rep y \<Longrightarrow> x \<sqsubseteq> y"
152.431 - by (simp only: below)
152.432 - show "\<exists>f::'a \<Rightarrow> nat. inj f"
152.433 - by (rule countable)
152.434 -qed
152.435 -
152.436 -end
153.1 --- a/src/HOLCF/Cont.thy Sat Nov 27 14:34:54 2010 -0800
153.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
153.3 @@ -1,239 +0,0 @@
153.4 -(* Title: HOLCF/Cont.thy
153.5 - Author: Franz Regensburger
153.6 - Author: Brian Huffman
153.7 -*)
153.8 -
153.9 -header {* Continuity and monotonicity *}
153.10 -
153.11 -theory Cont
153.12 -imports Pcpo
153.13 -begin
153.14 -
153.15 -text {*
153.16 - Now we change the default class! Form now on all untyped type variables are
153.17 - of default class po
153.18 -*}
153.19 -
153.20 -default_sort po
153.21 -
153.22 -subsection {* Definitions *}
153.23 -
153.24 -definition
153.25 - monofun :: "('a \<Rightarrow> 'b) \<Rightarrow> bool" -- "monotonicity" where
153.26 - "monofun f = (\<forall>x y. x \<sqsubseteq> y \<longrightarrow> f x \<sqsubseteq> f y)"
153.27 -
153.28 -definition
153.29 - cont :: "('a::cpo \<Rightarrow> 'b::cpo) \<Rightarrow> bool"
153.30 -where
153.31 - "cont f = (\<forall>Y. chain Y \<longrightarrow> range (\<lambda>i. f (Y i)) <<| f (\<Squnion>i. Y i))"
153.32 -
153.33 -lemma contI:
153.34 - "\<lbrakk>\<And>Y. chain Y \<Longrightarrow> range (\<lambda>i. f (Y i)) <<| f (\<Squnion>i. Y i)\<rbrakk> \<Longrightarrow> cont f"
153.35 -by (simp add: cont_def)
153.36 -
153.37 -lemma contE:
153.38 - "\<lbrakk>cont f; chain Y\<rbrakk> \<Longrightarrow> range (\<lambda>i. f (Y i)) <<| f (\<Squnion>i. Y i)"
153.39 -by (simp add: cont_def)
153.40 -
153.41 -lemma monofunI:
153.42 - "\<lbrakk>\<And>x y. x \<sqsubseteq> y \<Longrightarrow> f x \<sqsubseteq> f y\<rbrakk> \<Longrightarrow> monofun f"
153.43 -by (simp add: monofun_def)
153.44 -
153.45 -lemma monofunE:
153.46 - "\<lbrakk>monofun f; x \<sqsubseteq> y\<rbrakk> \<Longrightarrow> f x \<sqsubseteq> f y"
153.47 -by (simp add: monofun_def)
153.48 -
153.49 -
153.50 -subsection {* Equivalence of alternate definition *}
153.51 -
153.52 -text {* monotone functions map chains to chains *}
153.53 -
153.54 -lemma ch2ch_monofun: "\<lbrakk>monofun f; chain Y\<rbrakk> \<Longrightarrow> chain (\<lambda>i. f (Y i))"
153.55 -apply (rule chainI)
153.56 -apply (erule monofunE)
153.57 -apply (erule chainE)
153.58 -done
153.59 -
153.60 -text {* monotone functions map upper bound to upper bounds *}
153.61 -
153.62 -lemma ub2ub_monofun:
153.63 - "\<lbrakk>monofun f; range Y <| u\<rbrakk> \<Longrightarrow> range (\<lambda>i. f (Y i)) <| f u"
153.64 -apply (rule ub_rangeI)
153.65 -apply (erule monofunE)
153.66 -apply (erule ub_rangeD)
153.67 -done
153.68 -
153.69 -text {* a lemma about binary chains *}
153.70 -
153.71 -lemma binchain_cont:
153.72 - "\<lbrakk>cont f; x \<sqsubseteq> y\<rbrakk> \<Longrightarrow> range (\<lambda>i::nat. f (if i = 0 then x else y)) <<| f y"
153.73 -apply (subgoal_tac "f (\<Squnion>i::nat. if i = 0 then x else y) = f y")
153.74 -apply (erule subst)
153.75 -apply (erule contE)
153.76 -apply (erule bin_chain)
153.77 -apply (rule_tac f=f in arg_cong)
153.78 -apply (erule is_lub_bin_chain [THEN lub_eqI])
153.79 -done
153.80 -
153.81 -text {* continuity implies monotonicity *}
153.82 -
153.83 -lemma cont2mono: "cont f \<Longrightarrow> monofun f"
153.84 -apply (rule monofunI)
153.85 -apply (drule (1) binchain_cont)
153.86 -apply (drule_tac i=0 in is_lub_rangeD1)
153.87 -apply simp
153.88 -done
153.89 -
153.90 -lemmas cont2monofunE = cont2mono [THEN monofunE]
153.91 -
153.92 -lemmas ch2ch_cont = cont2mono [THEN ch2ch_monofun]
153.93 -
153.94 -text {* continuity implies preservation of lubs *}
153.95 -
153.96 -lemma cont2contlubE:
153.97 - "\<lbrakk>cont f; chain Y\<rbrakk> \<Longrightarrow> f (\<Squnion> i. Y i) = (\<Squnion> i. f (Y i))"
153.98 -apply (rule lub_eqI [symmetric])
153.99 -apply (erule (1) contE)
153.100 -done
153.101 -
153.102 -lemma contI2:
153.103 - fixes f :: "'a::cpo \<Rightarrow> 'b::cpo"
153.104 - assumes mono: "monofun f"
153.105 - assumes below: "\<And>Y. \<lbrakk>chain Y; chain (\<lambda>i. f (Y i))\<rbrakk>
153.106 - \<Longrightarrow> f (\<Squnion>i. Y i) \<sqsubseteq> (\<Squnion>i. f (Y i))"
153.107 - shows "cont f"
153.108 -proof (rule contI)
153.109 - fix Y :: "nat \<Rightarrow> 'a"
153.110 - assume Y: "chain Y"
153.111 - with mono have fY: "chain (\<lambda>i. f (Y i))"
153.112 - by (rule ch2ch_monofun)
153.113 - have "(\<Squnion>i. f (Y i)) = f (\<Squnion>i. Y i)"
153.114 - apply (rule below_antisym)
153.115 - apply (rule lub_below [OF fY])
153.116 - apply (rule monofunE [OF mono])
153.117 - apply (rule is_ub_thelub [OF Y])
153.118 - apply (rule below [OF Y fY])
153.119 - done
153.120 - with fY show "range (\<lambda>i. f (Y i)) <<| f (\<Squnion>i. Y i)"
153.121 - by (rule thelubE)
153.122 -qed
153.123 -
153.124 -subsection {* Collection of continuity rules *}
153.125 -
153.126 -ML {*
153.127 -structure Cont2ContData = Named_Thms
153.128 -(
153.129 - val name = "cont2cont"
153.130 - val description = "continuity intro rule"
153.131 -)
153.132 -*}
153.133 -
153.134 -setup Cont2ContData.setup
153.135 -
153.136 -subsection {* Continuity of basic functions *}
153.137 -
153.138 -text {* The identity function is continuous *}
153.139 -
153.140 -lemma cont_id [simp, cont2cont]: "cont (\<lambda>x. x)"
153.141 -apply (rule contI)
153.142 -apply (erule cpo_lubI)
153.143 -done
153.144 -
153.145 -text {* constant functions are continuous *}
153.146 -
153.147 -lemma cont_const [simp, cont2cont]: "cont (\<lambda>x. c)"
153.148 - using is_lub_const by (rule contI)
153.149 -
153.150 -text {* application of functions is continuous *}
153.151 -
153.152 -lemma cont_apply:
153.153 - fixes f :: "'a::cpo \<Rightarrow> 'b::cpo \<Rightarrow> 'c::cpo" and t :: "'a \<Rightarrow> 'b"
153.154 - assumes 1: "cont (\<lambda>x. t x)"
153.155 - assumes 2: "\<And>x. cont (\<lambda>y. f x y)"
153.156 - assumes 3: "\<And>y. cont (\<lambda>x. f x y)"
153.157 - shows "cont (\<lambda>x. (f x) (t x))"
153.158 -proof (rule contI2 [OF monofunI])
153.159 - fix x y :: "'a" assume "x \<sqsubseteq> y"
153.160 - then show "f x (t x) \<sqsubseteq> f y (t y)"
153.161 - by (auto intro: cont2monofunE [OF 1]
153.162 - cont2monofunE [OF 2]
153.163 - cont2monofunE [OF 3]
153.164 - below_trans)
153.165 -next
153.166 - fix Y :: "nat \<Rightarrow> 'a" assume "chain Y"
153.167 - then show "f (\<Squnion>i. Y i) (t (\<Squnion>i. Y i)) \<sqsubseteq> (\<Squnion>i. f (Y i) (t (Y i)))"
153.168 - by (simp only: cont2contlubE [OF 1] ch2ch_cont [OF 1]
153.169 - cont2contlubE [OF 2] ch2ch_cont [OF 2]
153.170 - cont2contlubE [OF 3] ch2ch_cont [OF 3]
153.171 - diag_lub below_refl)
153.172 -qed
153.173 -
153.174 -lemma cont_compose:
153.175 - "\<lbrakk>cont c; cont (\<lambda>x. f x)\<rbrakk> \<Longrightarrow> cont (\<lambda>x. c (f x))"
153.176 -by (rule cont_apply [OF _ _ cont_const])
153.177 -
153.178 -text {* Least upper bounds preserve continuity *}
153.179 -
153.180 -lemma cont2cont_lub [simp]:
153.181 - assumes chain: "\<And>x. chain (\<lambda>i. F i x)" and cont: "\<And>i. cont (\<lambda>x. F i x)"
153.182 - shows "cont (\<lambda>x. \<Squnion>i. F i x)"
153.183 -apply (rule contI2)
153.184 -apply (simp add: monofunI cont2monofunE [OF cont] lub_mono chain)
153.185 -apply (simp add: cont2contlubE [OF cont])
153.186 -apply (simp add: diag_lub ch2ch_cont [OF cont] chain)
153.187 -done
153.188 -
153.189 -text {* if-then-else is continuous *}
153.190 -
153.191 -lemma cont_if [simp, cont2cont]:
153.192 - "\<lbrakk>cont f; cont g\<rbrakk> \<Longrightarrow> cont (\<lambda>x. if b then f x else g x)"
153.193 -by (induct b) simp_all
153.194 -
153.195 -subsection {* Finite chains and flat pcpos *}
153.196 -
153.197 -text {* Monotone functions map finite chains to finite chains. *}
153.198 -
153.199 -lemma monofun_finch2finch:
153.200 - "\<lbrakk>monofun f; finite_chain Y\<rbrakk> \<Longrightarrow> finite_chain (\<lambda>n. f (Y n))"
153.201 -apply (unfold finite_chain_def)
153.202 -apply (simp add: ch2ch_monofun)
153.203 -apply (force simp add: max_in_chain_def)
153.204 -done
153.205 -
153.206 -text {* The same holds for continuous functions. *}
153.207 -
153.208 -lemma cont_finch2finch:
153.209 - "\<lbrakk>cont f; finite_chain Y\<rbrakk> \<Longrightarrow> finite_chain (\<lambda>n. f (Y n))"
153.210 -by (rule cont2mono [THEN monofun_finch2finch])
153.211 -
153.212 -text {* All monotone functions with chain-finite domain are continuous. *}
153.213 -
153.214 -lemma chfindom_monofun2cont: "monofun f \<Longrightarrow> cont (f::'a::chfin \<Rightarrow> 'b::cpo)"
153.215 -apply (erule contI2)
153.216 -apply (frule chfin2finch)
153.217 -apply (clarsimp simp add: finite_chain_def)
153.218 -apply (subgoal_tac "max_in_chain i (\<lambda>i. f (Y i))")
153.219 -apply (simp add: maxinch_is_thelub ch2ch_monofun)
153.220 -apply (force simp add: max_in_chain_def)
153.221 -done
153.222 -
153.223 -text {* All strict functions with flat domain are continuous. *}
153.224 -
153.225 -lemma flatdom_strict2mono: "f \<bottom> = \<bottom> \<Longrightarrow> monofun (f::'a::flat \<Rightarrow> 'b::pcpo)"
153.226 -apply (rule monofunI)
153.227 -apply (drule ax_flat)
153.228 -apply auto
153.229 -done
153.230 -
153.231 -lemma flatdom_strict2cont: "f \<bottom> = \<bottom> \<Longrightarrow> cont (f::'a::flat \<Rightarrow> 'b::pcpo)"
153.232 -by (rule flatdom_strict2mono [THEN chfindom_monofun2cont])
153.233 -
153.234 -text {* All functions with discrete domain are continuous. *}
153.235 -
153.236 -lemma cont_discrete_cpo [simp, cont2cont]: "cont (f::'a::discrete_cpo \<Rightarrow> 'b::cpo)"
153.237 -apply (rule contI)
153.238 -apply (drule discrete_chain_const, clarify)
153.239 -apply (simp add: is_lub_const)
153.240 -done
153.241 -
153.242 -end
154.1 --- a/src/HOLCF/ConvexPD.thy Sat Nov 27 14:34:54 2010 -0800
154.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
154.3 @@ -1,651 +0,0 @@
154.4 -(* Title: HOLCF/ConvexPD.thy
154.5 - Author: Brian Huffman
154.6 -*)
154.7 -
154.8 -header {* Convex powerdomain *}
154.9 -
154.10 -theory ConvexPD
154.11 -imports UpperPD LowerPD
154.12 -begin
154.13 -
154.14 -subsection {* Basis preorder *}
154.15 -
154.16 -definition
154.17 - convex_le :: "'a pd_basis \<Rightarrow> 'a pd_basis \<Rightarrow> bool" (infix "\<le>\<natural>" 50) where
154.18 - "convex_le = (\<lambda>u v. u \<le>\<sharp> v \<and> u \<le>\<flat> v)"
154.19 -
154.20 -lemma convex_le_refl [simp]: "t \<le>\<natural> t"
154.21 -unfolding convex_le_def by (fast intro: upper_le_refl lower_le_refl)
154.22 -
154.23 -lemma convex_le_trans: "\<lbrakk>t \<le>\<natural> u; u \<le>\<natural> v\<rbrakk> \<Longrightarrow> t \<le>\<natural> v"
154.24 -unfolding convex_le_def by (fast intro: upper_le_trans lower_le_trans)
154.25 -
154.26 -interpretation convex_le: preorder convex_le
154.27 -by (rule preorder.intro, rule convex_le_refl, rule convex_le_trans)
154.28 -
154.29 -lemma upper_le_minimal [simp]: "PDUnit compact_bot \<le>\<natural> t"
154.30 -unfolding convex_le_def Rep_PDUnit by simp
154.31 -
154.32 -lemma PDUnit_convex_mono: "x \<sqsubseteq> y \<Longrightarrow> PDUnit x \<le>\<natural> PDUnit y"
154.33 -unfolding convex_le_def by (fast intro: PDUnit_upper_mono PDUnit_lower_mono)
154.34 -
154.35 -lemma PDPlus_convex_mono: "\<lbrakk>s \<le>\<natural> t; u \<le>\<natural> v\<rbrakk> \<Longrightarrow> PDPlus s u \<le>\<natural> PDPlus t v"
154.36 -unfolding convex_le_def by (fast intro: PDPlus_upper_mono PDPlus_lower_mono)
154.37 -
154.38 -lemma convex_le_PDUnit_PDUnit_iff [simp]:
154.39 - "(PDUnit a \<le>\<natural> PDUnit b) = (a \<sqsubseteq> b)"
154.40 -unfolding convex_le_def upper_le_def lower_le_def Rep_PDUnit by fast
154.41 -
154.42 -lemma convex_le_PDUnit_lemma1:
154.43 - "(PDUnit a \<le>\<natural> t) = (\<forall>b\<in>Rep_pd_basis t. a \<sqsubseteq> b)"
154.44 -unfolding convex_le_def upper_le_def lower_le_def Rep_PDUnit
154.45 -using Rep_pd_basis_nonempty [of t, folded ex_in_conv] by fast
154.46 -
154.47 -lemma convex_le_PDUnit_PDPlus_iff [simp]:
154.48 - "(PDUnit a \<le>\<natural> PDPlus t u) = (PDUnit a \<le>\<natural> t \<and> PDUnit a \<le>\<natural> u)"
154.49 -unfolding convex_le_PDUnit_lemma1 Rep_PDPlus by fast
154.50 -
154.51 -lemma convex_le_PDUnit_lemma2:
154.52 - "(t \<le>\<natural> PDUnit b) = (\<forall>a\<in>Rep_pd_basis t. a \<sqsubseteq> b)"
154.53 -unfolding convex_le_def upper_le_def lower_le_def Rep_PDUnit
154.54 -using Rep_pd_basis_nonempty [of t, folded ex_in_conv] by fast
154.55 -
154.56 -lemma convex_le_PDPlus_PDUnit_iff [simp]:
154.57 - "(PDPlus t u \<le>\<natural> PDUnit a) = (t \<le>\<natural> PDUnit a \<and> u \<le>\<natural> PDUnit a)"
154.58 -unfolding convex_le_PDUnit_lemma2 Rep_PDPlus by fast
154.59 -
154.60 -lemma convex_le_PDPlus_lemma:
154.61 - assumes z: "PDPlus t u \<le>\<natural> z"
154.62 - shows "\<exists>v w. z = PDPlus v w \<and> t \<le>\<natural> v \<and> u \<le>\<natural> w"
154.63 -proof (intro exI conjI)
154.64 - let ?A = "{b\<in>Rep_pd_basis z. \<exists>a\<in>Rep_pd_basis t. a \<sqsubseteq> b}"
154.65 - let ?B = "{b\<in>Rep_pd_basis z. \<exists>a\<in>Rep_pd_basis u. a \<sqsubseteq> b}"
154.66 - let ?v = "Abs_pd_basis ?A"
154.67 - let ?w = "Abs_pd_basis ?B"
154.68 - have Rep_v: "Rep_pd_basis ?v = ?A"
154.69 - apply (rule Abs_pd_basis_inverse)
154.70 - apply (rule Rep_pd_basis_nonempty [of t, folded ex_in_conv, THEN exE])
154.71 - apply (cut_tac z, simp only: convex_le_def lower_le_def, clarify)
154.72 - apply (drule_tac x=x in bspec, simp add: Rep_PDPlus, erule bexE)
154.73 - apply (simp add: pd_basis_def)
154.74 - apply fast
154.75 - done
154.76 - have Rep_w: "Rep_pd_basis ?w = ?B"
154.77 - apply (rule Abs_pd_basis_inverse)
154.78 - apply (rule Rep_pd_basis_nonempty [of u, folded ex_in_conv, THEN exE])
154.79 - apply (cut_tac z, simp only: convex_le_def lower_le_def, clarify)
154.80 - apply (drule_tac x=x in bspec, simp add: Rep_PDPlus, erule bexE)
154.81 - apply (simp add: pd_basis_def)
154.82 - apply fast
154.83 - done
154.84 - show "z = PDPlus ?v ?w"
154.85 - apply (insert z)
154.86 - apply (simp add: convex_le_def, erule conjE)
154.87 - apply (simp add: Rep_pd_basis_inject [symmetric] Rep_PDPlus)
154.88 - apply (simp add: Rep_v Rep_w)
154.89 - apply (rule equalityI)
154.90 - apply (rule subsetI)
154.91 - apply (simp only: upper_le_def)
154.92 - apply (drule (1) bspec, erule bexE)
154.93 - apply (simp add: Rep_PDPlus)
154.94 - apply fast
154.95 - apply fast
154.96 - done
154.97 - show "t \<le>\<natural> ?v" "u \<le>\<natural> ?w"
154.98 - apply (insert z)
154.99 - apply (simp_all add: convex_le_def upper_le_def lower_le_def Rep_PDPlus Rep_v Rep_w)
154.100 - apply fast+
154.101 - done
154.102 -qed
154.103 -
154.104 -lemma convex_le_induct [induct set: convex_le]:
154.105 - assumes le: "t \<le>\<natural> u"
154.106 - assumes 2: "\<And>t u v. \<lbrakk>P t u; P u v\<rbrakk> \<Longrightarrow> P t v"
154.107 - assumes 3: "\<And>a b. a \<sqsubseteq> b \<Longrightarrow> P (PDUnit a) (PDUnit b)"
154.108 - assumes 4: "\<And>t u v w. \<lbrakk>P t v; P u w\<rbrakk> \<Longrightarrow> P (PDPlus t u) (PDPlus v w)"
154.109 - shows "P t u"
154.110 -using le apply (induct t arbitrary: u rule: pd_basis_induct)
154.111 -apply (erule rev_mp)
154.112 -apply (induct_tac u rule: pd_basis_induct1)
154.113 -apply (simp add: 3)
154.114 -apply (simp, clarify, rename_tac a b t)
154.115 -apply (subgoal_tac "P (PDPlus (PDUnit a) (PDUnit a)) (PDPlus (PDUnit b) t)")
154.116 -apply (simp add: PDPlus_absorb)
154.117 -apply (erule (1) 4 [OF 3])
154.118 -apply (drule convex_le_PDPlus_lemma, clarify)
154.119 -apply (simp add: 4)
154.120 -done
154.121 -
154.122 -
154.123 -subsection {* Type definition *}
154.124 -
154.125 -typedef (open) 'a convex_pd =
154.126 - "{S::'a pd_basis set. convex_le.ideal S}"
154.127 -by (fast intro: convex_le.ideal_principal)
154.128 -
154.129 -instantiation convex_pd :: ("domain") below
154.130 -begin
154.131 -
154.132 -definition
154.133 - "x \<sqsubseteq> y \<longleftrightarrow> Rep_convex_pd x \<subseteq> Rep_convex_pd y"
154.134 -
154.135 -instance ..
154.136 -end
154.137 -
154.138 -instance convex_pd :: ("domain") po
154.139 -using type_definition_convex_pd below_convex_pd_def
154.140 -by (rule convex_le.typedef_ideal_po)
154.141 -
154.142 -instance convex_pd :: ("domain") cpo
154.143 -using type_definition_convex_pd below_convex_pd_def
154.144 -by (rule convex_le.typedef_ideal_cpo)
154.145 -
154.146 -definition
154.147 - convex_principal :: "'a pd_basis \<Rightarrow> 'a convex_pd" where
154.148 - "convex_principal t = Abs_convex_pd {u. u \<le>\<natural> t}"
154.149 -
154.150 -interpretation convex_pd:
154.151 - ideal_completion convex_le convex_principal Rep_convex_pd
154.152 -using type_definition_convex_pd below_convex_pd_def
154.153 -using convex_principal_def pd_basis_countable
154.154 -by (rule convex_le.typedef_ideal_completion)
154.155 -
154.156 -text {* Convex powerdomain is pointed *}
154.157 -
154.158 -lemma convex_pd_minimal: "convex_principal (PDUnit compact_bot) \<sqsubseteq> ys"
154.159 -by (induct ys rule: convex_pd.principal_induct, simp, simp)
154.160 -
154.161 -instance convex_pd :: ("domain") pcpo
154.162 -by intro_classes (fast intro: convex_pd_minimal)
154.163 -
154.164 -lemma inst_convex_pd_pcpo: "\<bottom> = convex_principal (PDUnit compact_bot)"
154.165 -by (rule convex_pd_minimal [THEN UU_I, symmetric])
154.166 -
154.167 -
154.168 -subsection {* Monadic unit and plus *}
154.169 -
154.170 -definition
154.171 - convex_unit :: "'a \<rightarrow> 'a convex_pd" where
154.172 - "convex_unit = compact_basis.basis_fun (\<lambda>a. convex_principal (PDUnit a))"
154.173 -
154.174 -definition
154.175 - convex_plus :: "'a convex_pd \<rightarrow> 'a convex_pd \<rightarrow> 'a convex_pd" where
154.176 - "convex_plus = convex_pd.basis_fun (\<lambda>t. convex_pd.basis_fun (\<lambda>u.
154.177 - convex_principal (PDPlus t u)))"
154.178 -
154.179 -abbreviation
154.180 - convex_add :: "'a convex_pd \<Rightarrow> 'a convex_pd \<Rightarrow> 'a convex_pd"
154.181 - (infixl "+\<natural>" 65) where
154.182 - "xs +\<natural> ys == convex_plus\<cdot>xs\<cdot>ys"
154.183 -
154.184 -syntax
154.185 - "_convex_pd" :: "args \<Rightarrow> 'a convex_pd" ("{_}\<natural>")
154.186 -
154.187 -translations
154.188 - "{x,xs}\<natural>" == "{x}\<natural> +\<natural> {xs}\<natural>"
154.189 - "{x}\<natural>" == "CONST convex_unit\<cdot>x"
154.190 -
154.191 -lemma convex_unit_Rep_compact_basis [simp]:
154.192 - "{Rep_compact_basis a}\<natural> = convex_principal (PDUnit a)"
154.193 -unfolding convex_unit_def
154.194 -by (simp add: compact_basis.basis_fun_principal PDUnit_convex_mono)
154.195 -
154.196 -lemma convex_plus_principal [simp]:
154.197 - "convex_principal t +\<natural> convex_principal u = convex_principal (PDPlus t u)"
154.198 -unfolding convex_plus_def
154.199 -by (simp add: convex_pd.basis_fun_principal
154.200 - convex_pd.basis_fun_mono PDPlus_convex_mono)
154.201 -
154.202 -interpretation convex_add: semilattice convex_add proof
154.203 - fix xs ys zs :: "'a convex_pd"
154.204 - show "(xs +\<natural> ys) +\<natural> zs = xs +\<natural> (ys +\<natural> zs)"
154.205 - apply (induct xs ys arbitrary: zs rule: convex_pd.principal_induct2, simp, simp)
154.206 - apply (rule_tac x=zs in convex_pd.principal_induct, simp)
154.207 - apply (simp add: PDPlus_assoc)
154.208 - done
154.209 - show "xs +\<natural> ys = ys +\<natural> xs"
154.210 - apply (induct xs ys rule: convex_pd.principal_induct2, simp, simp)
154.211 - apply (simp add: PDPlus_commute)
154.212 - done
154.213 - show "xs +\<natural> xs = xs"
154.214 - apply (induct xs rule: convex_pd.principal_induct, simp)
154.215 - apply (simp add: PDPlus_absorb)
154.216 - done
154.217 -qed
154.218 -
154.219 -lemmas convex_plus_assoc = convex_add.assoc
154.220 -lemmas convex_plus_commute = convex_add.commute
154.221 -lemmas convex_plus_absorb = convex_add.idem
154.222 -lemmas convex_plus_left_commute = convex_add.left_commute
154.223 -lemmas convex_plus_left_absorb = convex_add.left_idem
154.224 -
154.225 -text {* Useful for @{text "simp add: convex_plus_ac"} *}
154.226 -lemmas convex_plus_ac =
154.227 - convex_plus_assoc convex_plus_commute convex_plus_left_commute
154.228 -
154.229 -text {* Useful for @{text "simp only: convex_plus_aci"} *}
154.230 -lemmas convex_plus_aci =
154.231 - convex_plus_ac convex_plus_absorb convex_plus_left_absorb
154.232 -
154.233 -lemma convex_unit_below_plus_iff [simp]:
154.234 - "{x}\<natural> \<sqsubseteq> ys +\<natural> zs \<longleftrightarrow> {x}\<natural> \<sqsubseteq> ys \<and> {x}\<natural> \<sqsubseteq> zs"
154.235 -apply (induct x rule: compact_basis.principal_induct, simp)
154.236 -apply (induct ys rule: convex_pd.principal_induct, simp)
154.237 -apply (induct zs rule: convex_pd.principal_induct, simp)
154.238 -apply simp
154.239 -done
154.240 -
154.241 -lemma convex_plus_below_unit_iff [simp]:
154.242 - "xs +\<natural> ys \<sqsubseteq> {z}\<natural> \<longleftrightarrow> xs \<sqsubseteq> {z}\<natural> \<and> ys \<sqsubseteq> {z}\<natural>"
154.243 -apply (induct xs rule: convex_pd.principal_induct, simp)
154.244 -apply (induct ys rule: convex_pd.principal_induct, simp)
154.245 -apply (induct z rule: compact_basis.principal_induct, simp)
154.246 -apply simp
154.247 -done
154.248 -
154.249 -lemma convex_unit_below_iff [simp]: "{x}\<natural> \<sqsubseteq> {y}\<natural> \<longleftrightarrow> x \<sqsubseteq> y"
154.250 -apply (induct x rule: compact_basis.principal_induct, simp)
154.251 -apply (induct y rule: compact_basis.principal_induct, simp)
154.252 -apply simp
154.253 -done
154.254 -
154.255 -lemma convex_unit_eq_iff [simp]: "{x}\<natural> = {y}\<natural> \<longleftrightarrow> x = y"
154.256 -unfolding po_eq_conv by simp
154.257 -
154.258 -lemma convex_unit_strict [simp]: "{\<bottom>}\<natural> = \<bottom>"
154.259 -using convex_unit_Rep_compact_basis [of compact_bot]
154.260 -by (simp add: inst_convex_pd_pcpo)
154.261 -
154.262 -lemma convex_unit_bottom_iff [simp]: "{x}\<natural> = \<bottom> \<longleftrightarrow> x = \<bottom>"
154.263 -unfolding convex_unit_strict [symmetric] by (rule convex_unit_eq_iff)
154.264 -
154.265 -lemma compact_convex_unit: "compact x \<Longrightarrow> compact {x}\<natural>"
154.266 -by (auto dest!: compact_basis.compact_imp_principal)
154.267 -
154.268 -lemma compact_convex_unit_iff [simp]: "compact {x}\<natural> \<longleftrightarrow> compact x"
154.269 -apply (safe elim!: compact_convex_unit)
154.270 -apply (simp only: compact_def convex_unit_below_iff [symmetric])
154.271 -apply (erule adm_subst [OF cont_Rep_cfun2])
154.272 -done
154.273 -
154.274 -lemma compact_convex_plus [simp]:
154.275 - "\<lbrakk>compact xs; compact ys\<rbrakk> \<Longrightarrow> compact (xs +\<natural> ys)"
154.276 -by (auto dest!: convex_pd.compact_imp_principal)
154.277 -
154.278 -
154.279 -subsection {* Induction rules *}
154.280 -
154.281 -lemma convex_pd_induct1:
154.282 - assumes P: "adm P"
154.283 - assumes unit: "\<And>x. P {x}\<natural>"
154.284 - assumes insert: "\<And>x ys. \<lbrakk>P {x}\<natural>; P ys\<rbrakk> \<Longrightarrow> P ({x}\<natural> +\<natural> ys)"
154.285 - shows "P (xs::'a convex_pd)"
154.286 -apply (induct xs rule: convex_pd.principal_induct, rule P)
154.287 -apply (induct_tac a rule: pd_basis_induct1)
154.288 -apply (simp only: convex_unit_Rep_compact_basis [symmetric])
154.289 -apply (rule unit)
154.290 -apply (simp only: convex_unit_Rep_compact_basis [symmetric]
154.291 - convex_plus_principal [symmetric])
154.292 -apply (erule insert [OF unit])
154.293 -done
154.294 -
154.295 -lemma convex_pd_induct
154.296 - [case_names adm convex_unit convex_plus, induct type: convex_pd]:
154.297 - assumes P: "adm P"
154.298 - assumes unit: "\<And>x. P {x}\<natural>"
154.299 - assumes plus: "\<And>xs ys. \<lbrakk>P xs; P ys\<rbrakk> \<Longrightarrow> P (xs +\<natural> ys)"
154.300 - shows "P (xs::'a convex_pd)"
154.301 -apply (induct xs rule: convex_pd.principal_induct, rule P)
154.302 -apply (induct_tac a rule: pd_basis_induct)
154.303 -apply (simp only: convex_unit_Rep_compact_basis [symmetric] unit)
154.304 -apply (simp only: convex_plus_principal [symmetric] plus)
154.305 -done
154.306 -
154.307 -
154.308 -subsection {* Monadic bind *}
154.309 -
154.310 -definition
154.311 - convex_bind_basis ::
154.312 - "'a pd_basis \<Rightarrow> ('a \<rightarrow> 'b convex_pd) \<rightarrow> 'b convex_pd" where
154.313 - "convex_bind_basis = fold_pd
154.314 - (\<lambda>a. \<Lambda> f. f\<cdot>(Rep_compact_basis a))
154.315 - (\<lambda>x y. \<Lambda> f. x\<cdot>f +\<natural> y\<cdot>f)"
154.316 -
154.317 -lemma ACI_convex_bind:
154.318 - "class.ab_semigroup_idem_mult (\<lambda>x y. \<Lambda> f. x\<cdot>f +\<natural> y\<cdot>f)"
154.319 -apply unfold_locales
154.320 -apply (simp add: convex_plus_assoc)
154.321 -apply (simp add: convex_plus_commute)
154.322 -apply (simp add: eta_cfun)
154.323 -done
154.324 -
154.325 -lemma convex_bind_basis_simps [simp]:
154.326 - "convex_bind_basis (PDUnit a) =
154.327 - (\<Lambda> f. f\<cdot>(Rep_compact_basis a))"
154.328 - "convex_bind_basis (PDPlus t u) =
154.329 - (\<Lambda> f. convex_bind_basis t\<cdot>f +\<natural> convex_bind_basis u\<cdot>f)"
154.330 -unfolding convex_bind_basis_def
154.331 -apply -
154.332 -apply (rule fold_pd_PDUnit [OF ACI_convex_bind])
154.333 -apply (rule fold_pd_PDPlus [OF ACI_convex_bind])
154.334 -done
154.335 -
154.336 -lemma convex_bind_basis_mono:
154.337 - "t \<le>\<natural> u \<Longrightarrow> convex_bind_basis t \<sqsubseteq> convex_bind_basis u"
154.338 -apply (erule convex_le_induct)
154.339 -apply (erule (1) below_trans)
154.340 -apply (simp add: monofun_LAM monofun_cfun)
154.341 -apply (simp add: monofun_LAM monofun_cfun)
154.342 -done
154.343 -
154.344 -definition
154.345 - convex_bind :: "'a convex_pd \<rightarrow> ('a \<rightarrow> 'b convex_pd) \<rightarrow> 'b convex_pd" where
154.346 - "convex_bind = convex_pd.basis_fun convex_bind_basis"
154.347 -
154.348 -lemma convex_bind_principal [simp]:
154.349 - "convex_bind\<cdot>(convex_principal t) = convex_bind_basis t"
154.350 -unfolding convex_bind_def
154.351 -apply (rule convex_pd.basis_fun_principal)
154.352 -apply (erule convex_bind_basis_mono)
154.353 -done
154.354 -
154.355 -lemma convex_bind_unit [simp]:
154.356 - "convex_bind\<cdot>{x}\<natural>\<cdot>f = f\<cdot>x"
154.357 -by (induct x rule: compact_basis.principal_induct, simp, simp)
154.358 -
154.359 -lemma convex_bind_plus [simp]:
154.360 - "convex_bind\<cdot>(xs +\<natural> ys)\<cdot>f = convex_bind\<cdot>xs\<cdot>f +\<natural> convex_bind\<cdot>ys\<cdot>f"
154.361 -by (induct xs ys rule: convex_pd.principal_induct2, simp, simp, simp)
154.362 -
154.363 -lemma convex_bind_strict [simp]: "convex_bind\<cdot>\<bottom>\<cdot>f = f\<cdot>\<bottom>"
154.364 -unfolding convex_unit_strict [symmetric] by (rule convex_bind_unit)
154.365 -
154.366 -lemma convex_bind_bind:
154.367 - "convex_bind\<cdot>(convex_bind\<cdot>xs\<cdot>f)\<cdot>g =
154.368 - convex_bind\<cdot>xs\<cdot>(\<Lambda> x. convex_bind\<cdot>(f\<cdot>x)\<cdot>g)"
154.369 -by (induct xs, simp_all)
154.370 -
154.371 -
154.372 -subsection {* Map *}
154.373 -
154.374 -definition
154.375 - convex_map :: "('a \<rightarrow> 'b) \<rightarrow> 'a convex_pd \<rightarrow> 'b convex_pd" where
154.376 - "convex_map = (\<Lambda> f xs. convex_bind\<cdot>xs\<cdot>(\<Lambda> x. {f\<cdot>x}\<natural>))"
154.377 -
154.378 -lemma convex_map_unit [simp]:
154.379 - "convex_map\<cdot>f\<cdot>{x}\<natural> = {f\<cdot>x}\<natural>"
154.380 -unfolding convex_map_def by simp
154.381 -
154.382 -lemma convex_map_plus [simp]:
154.383 - "convex_map\<cdot>f\<cdot>(xs +\<natural> ys) = convex_map\<cdot>f\<cdot>xs +\<natural> convex_map\<cdot>f\<cdot>ys"
154.384 -unfolding convex_map_def by simp
154.385 -
154.386 -lemma convex_map_bottom [simp]: "convex_map\<cdot>f\<cdot>\<bottom> = {f\<cdot>\<bottom>}\<natural>"
154.387 -unfolding convex_map_def by simp
154.388 -
154.389 -lemma convex_map_ident: "convex_map\<cdot>(\<Lambda> x. x)\<cdot>xs = xs"
154.390 -by (induct xs rule: convex_pd_induct, simp_all)
154.391 -
154.392 -lemma convex_map_ID: "convex_map\<cdot>ID = ID"
154.393 -by (simp add: cfun_eq_iff ID_def convex_map_ident)
154.394 -
154.395 -lemma convex_map_map:
154.396 - "convex_map\<cdot>f\<cdot>(convex_map\<cdot>g\<cdot>xs) = convex_map\<cdot>(\<Lambda> x. f\<cdot>(g\<cdot>x))\<cdot>xs"
154.397 -by (induct xs rule: convex_pd_induct, simp_all)
154.398 -
154.399 -lemma ep_pair_convex_map: "ep_pair e p \<Longrightarrow> ep_pair (convex_map\<cdot>e) (convex_map\<cdot>p)"
154.400 -apply default
154.401 -apply (induct_tac x rule: convex_pd_induct, simp_all add: ep_pair.e_inverse)
154.402 -apply (induct_tac y rule: convex_pd_induct)
154.403 -apply (simp_all add: ep_pair.e_p_below monofun_cfun)
154.404 -done
154.405 -
154.406 -lemma deflation_convex_map: "deflation d \<Longrightarrow> deflation (convex_map\<cdot>d)"
154.407 -apply default
154.408 -apply (induct_tac x rule: convex_pd_induct, simp_all add: deflation.idem)
154.409 -apply (induct_tac x rule: convex_pd_induct)
154.410 -apply (simp_all add: deflation.below monofun_cfun)
154.411 -done
154.412 -
154.413 -(* FIXME: long proof! *)
154.414 -lemma finite_deflation_convex_map:
154.415 - assumes "finite_deflation d" shows "finite_deflation (convex_map\<cdot>d)"
154.416 -proof (rule finite_deflation_intro)
154.417 - interpret d: finite_deflation d by fact
154.418 - have "deflation d" by fact
154.419 - thus "deflation (convex_map\<cdot>d)" by (rule deflation_convex_map)
154.420 - have "finite (range (\<lambda>x. d\<cdot>x))" by (rule d.finite_range)
154.421 - hence "finite (Rep_compact_basis -` range (\<lambda>x. d\<cdot>x))"
154.422 - by (rule finite_vimageI, simp add: inj_on_def Rep_compact_basis_inject)
154.423 - hence "finite (Pow (Rep_compact_basis -` range (\<lambda>x. d\<cdot>x)))" by simp
154.424 - hence "finite (Rep_pd_basis -` (Pow (Rep_compact_basis -` range (\<lambda>x. d\<cdot>x))))"
154.425 - by (rule finite_vimageI, simp add: inj_on_def Rep_pd_basis_inject)
154.426 - hence *: "finite (convex_principal ` Rep_pd_basis -` (Pow (Rep_compact_basis -` range (\<lambda>x. d\<cdot>x))))" by simp
154.427 - hence "finite (range (\<lambda>xs. convex_map\<cdot>d\<cdot>xs))"
154.428 - apply (rule rev_finite_subset)
154.429 - apply clarsimp
154.430 - apply (induct_tac xs rule: convex_pd.principal_induct)
154.431 - apply (simp add: adm_mem_finite *)
154.432 - apply (rename_tac t, induct_tac t rule: pd_basis_induct)
154.433 - apply (simp only: convex_unit_Rep_compact_basis [symmetric] convex_map_unit)
154.434 - apply simp
154.435 - apply (subgoal_tac "\<exists>b. d\<cdot>(Rep_compact_basis a) = Rep_compact_basis b")
154.436 - apply clarsimp
154.437 - apply (rule imageI)
154.438 - apply (rule vimageI2)
154.439 - apply (simp add: Rep_PDUnit)
154.440 - apply (rule range_eqI)
154.441 - apply (erule sym)
154.442 - apply (rule exI)
154.443 - apply (rule Abs_compact_basis_inverse [symmetric])
154.444 - apply (simp add: d.compact)
154.445 - apply (simp only: convex_plus_principal [symmetric] convex_map_plus)
154.446 - apply clarsimp
154.447 - apply (rule imageI)
154.448 - apply (rule vimageI2)
154.449 - apply (simp add: Rep_PDPlus)
154.450 - done
154.451 - thus "finite {xs. convex_map\<cdot>d\<cdot>xs = xs}"
154.452 - by (rule finite_range_imp_finite_fixes)
154.453 -qed
154.454 -
154.455 -subsection {* Convex powerdomain is a domain *}
154.456 -
154.457 -definition
154.458 - convex_approx :: "nat \<Rightarrow> udom convex_pd \<rightarrow> udom convex_pd"
154.459 -where
154.460 - "convex_approx = (\<lambda>i. convex_map\<cdot>(udom_approx i))"
154.461 -
154.462 -lemma convex_approx: "approx_chain convex_approx"
154.463 -using convex_map_ID finite_deflation_convex_map
154.464 -unfolding convex_approx_def by (rule approx_chain_lemma1)
154.465 -
154.466 -definition convex_defl :: "defl \<rightarrow> defl"
154.467 -where "convex_defl = defl_fun1 convex_approx convex_map"
154.468 -
154.469 -lemma cast_convex_defl:
154.470 - "cast\<cdot>(convex_defl\<cdot>A) =
154.471 - udom_emb convex_approx oo convex_map\<cdot>(cast\<cdot>A) oo udom_prj convex_approx"
154.472 -using convex_approx finite_deflation_convex_map
154.473 -unfolding convex_defl_def by (rule cast_defl_fun1)
154.474 -
154.475 -instantiation convex_pd :: ("domain") liftdomain
154.476 -begin
154.477 -
154.478 -definition
154.479 - "emb = udom_emb convex_approx oo convex_map\<cdot>emb"
154.480 -
154.481 -definition
154.482 - "prj = convex_map\<cdot>prj oo udom_prj convex_approx"
154.483 -
154.484 -definition
154.485 - "defl (t::'a convex_pd itself) = convex_defl\<cdot>DEFL('a)"
154.486 -
154.487 -definition
154.488 - "(liftemb :: 'a convex_pd u \<rightarrow> udom) = udom_emb u_approx oo u_map\<cdot>emb"
154.489 -
154.490 -definition
154.491 - "(liftprj :: udom \<rightarrow> 'a convex_pd u) = u_map\<cdot>prj oo udom_prj u_approx"
154.492 -
154.493 -definition
154.494 - "liftdefl (t::'a convex_pd itself) = u_defl\<cdot>DEFL('a convex_pd)"
154.495 -
154.496 -instance
154.497 -using liftemb_convex_pd_def liftprj_convex_pd_def liftdefl_convex_pd_def
154.498 -proof (rule liftdomain_class_intro)
154.499 - show "ep_pair emb (prj :: udom \<rightarrow> 'a convex_pd)"
154.500 - unfolding emb_convex_pd_def prj_convex_pd_def
154.501 - using ep_pair_udom [OF convex_approx]
154.502 - by (intro ep_pair_comp ep_pair_convex_map ep_pair_emb_prj)
154.503 -next
154.504 - show "cast\<cdot>DEFL('a convex_pd) = emb oo (prj :: udom \<rightarrow> 'a convex_pd)"
154.505 - unfolding emb_convex_pd_def prj_convex_pd_def defl_convex_pd_def cast_convex_defl
154.506 - by (simp add: cast_DEFL oo_def cfun_eq_iff convex_map_map)
154.507 -qed
154.508 -
154.509 -end
154.510 -
154.511 -text {* DEFL of type constructor = type combinator *}
154.512 -
154.513 -lemma DEFL_convex: "DEFL('a convex_pd) = convex_defl\<cdot>DEFL('a)"
154.514 -by (rule defl_convex_pd_def)
154.515 -
154.516 -
154.517 -subsection {* Join *}
154.518 -
154.519 -definition
154.520 - convex_join :: "'a convex_pd convex_pd \<rightarrow> 'a convex_pd" where
154.521 - "convex_join = (\<Lambda> xss. convex_bind\<cdot>xss\<cdot>(\<Lambda> xs. xs))"
154.522 -
154.523 -lemma convex_join_unit [simp]:
154.524 - "convex_join\<cdot>{xs}\<natural> = xs"
154.525 -unfolding convex_join_def by simp
154.526 -
154.527 -lemma convex_join_plus [simp]:
154.528 - "convex_join\<cdot>(xss +\<natural> yss) = convex_join\<cdot>xss +\<natural> convex_join\<cdot>yss"
154.529 -unfolding convex_join_def by simp
154.530 -
154.531 -lemma convex_join_bottom [simp]: "convex_join\<cdot>\<bottom> = \<bottom>"
154.532 -unfolding convex_join_def by simp
154.533 -
154.534 -lemma convex_join_map_unit:
154.535 - "convex_join\<cdot>(convex_map\<cdot>convex_unit\<cdot>xs) = xs"
154.536 -by (induct xs rule: convex_pd_induct, simp_all)
154.537 -
154.538 -lemma convex_join_map_join:
154.539 - "convex_join\<cdot>(convex_map\<cdot>convex_join\<cdot>xsss) = convex_join\<cdot>(convex_join\<cdot>xsss)"
154.540 -by (induct xsss rule: convex_pd_induct, simp_all)
154.541 -
154.542 -lemma convex_join_map_map:
154.543 - "convex_join\<cdot>(convex_map\<cdot>(convex_map\<cdot>f)\<cdot>xss) =
154.544 - convex_map\<cdot>f\<cdot>(convex_join\<cdot>xss)"
154.545 -by (induct xss rule: convex_pd_induct, simp_all)
154.546 -
154.547 -
154.548 -subsection {* Conversions to other powerdomains *}
154.549 -
154.550 -text {* Convex to upper *}
154.551 -
154.552 -lemma convex_le_imp_upper_le: "t \<le>\<natural> u \<Longrightarrow> t \<le>\<sharp> u"
154.553 -unfolding convex_le_def by simp
154.554 -
154.555 -definition
154.556 - convex_to_upper :: "'a convex_pd \<rightarrow> 'a upper_pd" where
154.557 - "convex_to_upper = convex_pd.basis_fun upper_principal"
154.558 -
154.559 -lemma convex_to_upper_principal [simp]:
154.560 - "convex_to_upper\<cdot>(convex_principal t) = upper_principal t"
154.561 -unfolding convex_to_upper_def
154.562 -apply (rule convex_pd.basis_fun_principal)
154.563 -apply (rule upper_pd.principal_mono)
154.564 -apply (erule convex_le_imp_upper_le)
154.565 -done
154.566 -
154.567 -lemma convex_to_upper_unit [simp]:
154.568 - "convex_to_upper\<cdot>{x}\<natural> = {x}\<sharp>"
154.569 -by (induct x rule: compact_basis.principal_induct, simp, simp)
154.570 -
154.571 -lemma convex_to_upper_plus [simp]:
154.572 - "convex_to_upper\<cdot>(xs +\<natural> ys) = convex_to_upper\<cdot>xs +\<sharp> convex_to_upper\<cdot>ys"
154.573 -by (induct xs ys rule: convex_pd.principal_induct2, simp, simp, simp)
154.574 -
154.575 -lemma convex_to_upper_bind [simp]:
154.576 - "convex_to_upper\<cdot>(convex_bind\<cdot>xs\<cdot>f) =
154.577 - upper_bind\<cdot>(convex_to_upper\<cdot>xs)\<cdot>(convex_to_upper oo f)"
154.578 -by (induct xs rule: convex_pd_induct, simp, simp, simp)
154.579 -
154.580 -lemma convex_to_upper_map [simp]:
154.581 - "convex_to_upper\<cdot>(convex_map\<cdot>f\<cdot>xs) = upper_map\<cdot>f\<cdot>(convex_to_upper\<cdot>xs)"
154.582 -by (simp add: convex_map_def upper_map_def cfcomp_LAM)
154.583 -
154.584 -lemma convex_to_upper_join [simp]:
154.585 - "convex_to_upper\<cdot>(convex_join\<cdot>xss) =
154.586 - upper_bind\<cdot>(convex_to_upper\<cdot>xss)\<cdot>convex_to_upper"
154.587 -by (simp add: convex_join_def upper_join_def cfcomp_LAM eta_cfun)
154.588 -
154.589 -text {* Convex to lower *}
154.590 -
154.591 -lemma convex_le_imp_lower_le: "t \<le>\<natural> u \<Longrightarrow> t \<le>\<flat> u"
154.592 -unfolding convex_le_def by simp
154.593 -
154.594 -definition
154.595 - convex_to_lower :: "'a convex_pd \<rightarrow> 'a lower_pd" where
154.596 - "convex_to_lower = convex_pd.basis_fun lower_principal"
154.597 -
154.598 -lemma convex_to_lower_principal [simp]:
154.599 - "convex_to_lower\<cdot>(convex_principal t) = lower_principal t"
154.600 -unfolding convex_to_lower_def
154.601 -apply (rule convex_pd.basis_fun_principal)
154.602 -apply (rule lower_pd.principal_mono)
154.603 -apply (erule convex_le_imp_lower_le)
154.604 -done
154.605 -
154.606 -lemma convex_to_lower_unit [simp]:
154.607 - "convex_to_lower\<cdot>{x}\<natural> = {x}\<flat>"
154.608 -by (induct x rule: compact_basis.principal_induct, simp, simp)
154.609 -
154.610 -lemma convex_to_lower_plus [simp]:
154.611 - "convex_to_lower\<cdot>(xs +\<natural> ys) = convex_to_lower\<cdot>xs +\<flat> convex_to_lower\<cdot>ys"
154.612 -by (induct xs ys rule: convex_pd.principal_induct2, simp, simp, simp)
154.613 -
154.614 -lemma convex_to_lower_bind [simp]:
154.615 - "convex_to_lower\<cdot>(convex_bind\<cdot>xs\<cdot>f) =
154.616 - lower_bind\<cdot>(convex_to_lower\<cdot>xs)\<cdot>(convex_to_lower oo f)"
154.617 -by (induct xs rule: convex_pd_induct, simp, simp, simp)
154.618 -
154.619 -lemma convex_to_lower_map [simp]:
154.620 - "convex_to_lower\<cdot>(convex_map\<cdot>f\<cdot>xs) = lower_map\<cdot>f\<cdot>(convex_to_lower\<cdot>xs)"
154.621 -by (simp add: convex_map_def lower_map_def cfcomp_LAM)
154.622 -
154.623 -lemma convex_to_lower_join [simp]:
154.624 - "convex_to_lower\<cdot>(convex_join\<cdot>xss) =
154.625 - lower_bind\<cdot>(convex_to_lower\<cdot>xss)\<cdot>convex_to_lower"
154.626 -by (simp add: convex_join_def lower_join_def cfcomp_LAM eta_cfun)
154.627 -
154.628 -text {* Ordering property *}
154.629 -
154.630 -lemma convex_pd_below_iff:
154.631 - "(xs \<sqsubseteq> ys) =
154.632 - (convex_to_upper\<cdot>xs \<sqsubseteq> convex_to_upper\<cdot>ys \<and>
154.633 - convex_to_lower\<cdot>xs \<sqsubseteq> convex_to_lower\<cdot>ys)"
154.634 -apply (induct xs rule: convex_pd.principal_induct, simp)
154.635 -apply (induct ys rule: convex_pd.principal_induct, simp)
154.636 -apply (simp add: convex_le_def)
154.637 -done
154.638 -
154.639 -lemmas convex_plus_below_plus_iff =
154.640 - convex_pd_below_iff [where xs="xs +\<natural> ys" and ys="zs +\<natural> ws", standard]
154.641 -
154.642 -lemmas convex_pd_below_simps =
154.643 - convex_unit_below_plus_iff
154.644 - convex_plus_below_unit_iff
154.645 - convex_plus_below_plus_iff
154.646 - convex_unit_below_iff
154.647 - convex_to_upper_unit
154.648 - convex_to_upper_plus
154.649 - convex_to_lower_unit
154.650 - convex_to_lower_plus
154.651 - upper_pd_below_simps
154.652 - lower_pd_below_simps
154.653 -
154.654 -end
155.1 --- a/src/HOLCF/Cpodef.thy Sat Nov 27 14:34:54 2010 -0800
155.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
155.3 @@ -1,285 +0,0 @@
155.4 -(* Title: HOLCF/Pcpodef.thy
155.5 - Author: Brian Huffman
155.6 -*)
155.7 -
155.8 -header {* Subtypes of pcpos *}
155.9 -
155.10 -theory Cpodef
155.11 -imports Adm
155.12 -uses ("Tools/cpodef.ML")
155.13 -begin
155.14 -
155.15 -subsection {* Proving a subtype is a partial order *}
155.16 -
155.17 -text {*
155.18 - A subtype of a partial order is itself a partial order,
155.19 - if the ordering is defined in the standard way.
155.20 -*}
155.21 -
155.22 -setup {* Sign.add_const_constraint (@{const_name Porder.below}, NONE) *}
155.23 -
155.24 -theorem typedef_po:
155.25 - fixes Abs :: "'a::po \<Rightarrow> 'b::type"
155.26 - assumes type: "type_definition Rep Abs A"
155.27 - and below: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
155.28 - shows "OFCLASS('b, po_class)"
155.29 - apply (intro_classes, unfold below)
155.30 - apply (rule below_refl)
155.31 - apply (erule (1) below_trans)
155.32 - apply (rule type_definition.Rep_inject [OF type, THEN iffD1])
155.33 - apply (erule (1) below_antisym)
155.34 -done
155.35 -
155.36 -setup {* Sign.add_const_constraint (@{const_name Porder.below},
155.37 - SOME @{typ "'a::below \<Rightarrow> 'a::below \<Rightarrow> bool"}) *}
155.38 -
155.39 -subsection {* Proving a subtype is finite *}
155.40 -
155.41 -lemma typedef_finite_UNIV:
155.42 - fixes Abs :: "'a::type \<Rightarrow> 'b::type"
155.43 - assumes type: "type_definition Rep Abs A"
155.44 - shows "finite A \<Longrightarrow> finite (UNIV :: 'b set)"
155.45 -proof -
155.46 - assume "finite A"
155.47 - hence "finite (Abs ` A)" by (rule finite_imageI)
155.48 - thus "finite (UNIV :: 'b set)"
155.49 - by (simp only: type_definition.Abs_image [OF type])
155.50 -qed
155.51 -
155.52 -subsection {* Proving a subtype is chain-finite *}
155.53 -
155.54 -lemma ch2ch_Rep:
155.55 - assumes below: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
155.56 - shows "chain S \<Longrightarrow> chain (\<lambda>i. Rep (S i))"
155.57 -unfolding chain_def below .
155.58 -
155.59 -theorem typedef_chfin:
155.60 - fixes Abs :: "'a::chfin \<Rightarrow> 'b::po"
155.61 - assumes type: "type_definition Rep Abs A"
155.62 - and below: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
155.63 - shows "OFCLASS('b, chfin_class)"
155.64 - apply intro_classes
155.65 - apply (drule ch2ch_Rep [OF below])
155.66 - apply (drule chfin)
155.67 - apply (unfold max_in_chain_def)
155.68 - apply (simp add: type_definition.Rep_inject [OF type])
155.69 -done
155.70 -
155.71 -subsection {* Proving a subtype is complete *}
155.72 -
155.73 -text {*
155.74 - A subtype of a cpo is itself a cpo if the ordering is
155.75 - defined in the standard way, and the defining subset
155.76 - is closed with respect to limits of chains. A set is
155.77 - closed if and only if membership in the set is an
155.78 - admissible predicate.
155.79 -*}
155.80 -
155.81 -lemma typedef_is_lubI:
155.82 - assumes below: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
155.83 - shows "range (\<lambda>i. Rep (S i)) <<| Rep x \<Longrightarrow> range S <<| x"
155.84 -unfolding is_lub_def is_ub_def below by simp
155.85 -
155.86 -lemma Abs_inverse_lub_Rep:
155.87 - fixes Abs :: "'a::cpo \<Rightarrow> 'b::po"
155.88 - assumes type: "type_definition Rep Abs A"
155.89 - and below: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
155.90 - and adm: "adm (\<lambda>x. x \<in> A)"
155.91 - shows "chain S \<Longrightarrow> Rep (Abs (\<Squnion>i. Rep (S i))) = (\<Squnion>i. Rep (S i))"
155.92 - apply (rule type_definition.Abs_inverse [OF type])
155.93 - apply (erule admD [OF adm ch2ch_Rep [OF below]])
155.94 - apply (rule type_definition.Rep [OF type])
155.95 -done
155.96 -
155.97 -theorem typedef_is_lub:
155.98 - fixes Abs :: "'a::cpo \<Rightarrow> 'b::po"
155.99 - assumes type: "type_definition Rep Abs A"
155.100 - and below: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
155.101 - and adm: "adm (\<lambda>x. x \<in> A)"
155.102 - shows "chain S \<Longrightarrow> range S <<| Abs (\<Squnion>i. Rep (S i))"
155.103 -proof -
155.104 - assume S: "chain S"
155.105 - hence "chain (\<lambda>i. Rep (S i))" by (rule ch2ch_Rep [OF below])
155.106 - hence "range (\<lambda>i. Rep (S i)) <<| (\<Squnion>i. Rep (S i))" by (rule cpo_lubI)
155.107 - hence "range (\<lambda>i. Rep (S i)) <<| Rep (Abs (\<Squnion>i. Rep (S i)))"
155.108 - by (simp only: Abs_inverse_lub_Rep [OF type below adm S])
155.109 - thus "range S <<| Abs (\<Squnion>i. Rep (S i))"
155.110 - by (rule typedef_is_lubI [OF below])
155.111 -qed
155.112 -
155.113 -lemmas typedef_lub = typedef_is_lub [THEN lub_eqI, standard]
155.114 -
155.115 -theorem typedef_cpo:
155.116 - fixes Abs :: "'a::cpo \<Rightarrow> 'b::po"
155.117 - assumes type: "type_definition Rep Abs A"
155.118 - and below: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
155.119 - and adm: "adm (\<lambda>x. x \<in> A)"
155.120 - shows "OFCLASS('b, cpo_class)"
155.121 -proof
155.122 - fix S::"nat \<Rightarrow> 'b" assume "chain S"
155.123 - hence "range S <<| Abs (\<Squnion>i. Rep (S i))"
155.124 - by (rule typedef_is_lub [OF type below adm])
155.125 - thus "\<exists>x. range S <<| x" ..
155.126 -qed
155.127 -
155.128 -subsubsection {* Continuity of \emph{Rep} and \emph{Abs} *}
155.129 -
155.130 -text {* For any sub-cpo, the @{term Rep} function is continuous. *}
155.131 -
155.132 -theorem typedef_cont_Rep:
155.133 - fixes Abs :: "'a::cpo \<Rightarrow> 'b::cpo"
155.134 - assumes type: "type_definition Rep Abs A"
155.135 - and below: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
155.136 - and adm: "adm (\<lambda>x. x \<in> A)"
155.137 - shows "cont Rep"
155.138 - apply (rule contI)
155.139 - apply (simp only: typedef_lub [OF type below adm])
155.140 - apply (simp only: Abs_inverse_lub_Rep [OF type below adm])
155.141 - apply (rule cpo_lubI)
155.142 - apply (erule ch2ch_Rep [OF below])
155.143 -done
155.144 -
155.145 -text {*
155.146 - For a sub-cpo, we can make the @{term Abs} function continuous
155.147 - only if we restrict its domain to the defining subset by
155.148 - composing it with another continuous function.
155.149 -*}
155.150 -
155.151 -theorem typedef_cont_Abs:
155.152 - fixes Abs :: "'a::cpo \<Rightarrow> 'b::cpo"
155.153 - fixes f :: "'c::cpo \<Rightarrow> 'a::cpo"
155.154 - assumes type: "type_definition Rep Abs A"
155.155 - and below: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
155.156 - and adm: "adm (\<lambda>x. x \<in> A)" (* not used *)
155.157 - and f_in_A: "\<And>x. f x \<in> A"
155.158 - shows "cont f \<Longrightarrow> cont (\<lambda>x. Abs (f x))"
155.159 -unfolding cont_def is_lub_def is_ub_def ball_simps below
155.160 -by (simp add: type_definition.Abs_inverse [OF type f_in_A])
155.161 -
155.162 -subsection {* Proving subtype elements are compact *}
155.163 -
155.164 -theorem typedef_compact:
155.165 - fixes Abs :: "'a::cpo \<Rightarrow> 'b::cpo"
155.166 - assumes type: "type_definition Rep Abs A"
155.167 - and below: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
155.168 - and adm: "adm (\<lambda>x. x \<in> A)"
155.169 - shows "compact (Rep k) \<Longrightarrow> compact k"
155.170 -proof (unfold compact_def)
155.171 - have cont_Rep: "cont Rep"
155.172 - by (rule typedef_cont_Rep [OF type below adm])
155.173 - assume "adm (\<lambda>x. \<not> Rep k \<sqsubseteq> x)"
155.174 - with cont_Rep have "adm (\<lambda>x. \<not> Rep k \<sqsubseteq> Rep x)" by (rule adm_subst)
155.175 - thus "adm (\<lambda>x. \<not> k \<sqsubseteq> x)" by (unfold below)
155.176 -qed
155.177 -
155.178 -subsection {* Proving a subtype is pointed *}
155.179 -
155.180 -text {*
155.181 - A subtype of a cpo has a least element if and only if
155.182 - the defining subset has a least element.
155.183 -*}
155.184 -
155.185 -theorem typedef_pcpo_generic:
155.186 - fixes Abs :: "'a::cpo \<Rightarrow> 'b::cpo"
155.187 - assumes type: "type_definition Rep Abs A"
155.188 - and below: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
155.189 - and z_in_A: "z \<in> A"
155.190 - and z_least: "\<And>x. x \<in> A \<Longrightarrow> z \<sqsubseteq> x"
155.191 - shows "OFCLASS('b, pcpo_class)"
155.192 - apply (intro_classes)
155.193 - apply (rule_tac x="Abs z" in exI, rule allI)
155.194 - apply (unfold below)
155.195 - apply (subst type_definition.Abs_inverse [OF type z_in_A])
155.196 - apply (rule z_least [OF type_definition.Rep [OF type]])
155.197 -done
155.198 -
155.199 -text {*
155.200 - As a special case, a subtype of a pcpo has a least element
155.201 - if the defining subset contains @{term \<bottom>}.
155.202 -*}
155.203 -
155.204 -theorem typedef_pcpo:
155.205 - fixes Abs :: "'a::pcpo \<Rightarrow> 'b::cpo"
155.206 - assumes type: "type_definition Rep Abs A"
155.207 - and below: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
155.208 - and UU_in_A: "\<bottom> \<in> A"
155.209 - shows "OFCLASS('b, pcpo_class)"
155.210 -by (rule typedef_pcpo_generic [OF type below UU_in_A], rule minimal)
155.211 -
155.212 -subsubsection {* Strictness of \emph{Rep} and \emph{Abs} *}
155.213 -
155.214 -text {*
155.215 - For a sub-pcpo where @{term \<bottom>} is a member of the defining
155.216 - subset, @{term Rep} and @{term Abs} are both strict.
155.217 -*}
155.218 -
155.219 -theorem typedef_Abs_strict:
155.220 - assumes type: "type_definition Rep Abs A"
155.221 - and below: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
155.222 - and UU_in_A: "\<bottom> \<in> A"
155.223 - shows "Abs \<bottom> = \<bottom>"
155.224 - apply (rule UU_I, unfold below)
155.225 - apply (simp add: type_definition.Abs_inverse [OF type UU_in_A])
155.226 -done
155.227 -
155.228 -theorem typedef_Rep_strict:
155.229 - assumes type: "type_definition Rep Abs A"
155.230 - and below: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
155.231 - and UU_in_A: "\<bottom> \<in> A"
155.232 - shows "Rep \<bottom> = \<bottom>"
155.233 - apply (rule typedef_Abs_strict [OF type below UU_in_A, THEN subst])
155.234 - apply (rule type_definition.Abs_inverse [OF type UU_in_A])
155.235 -done
155.236 -
155.237 -theorem typedef_Abs_bottom_iff:
155.238 - assumes type: "type_definition Rep Abs A"
155.239 - and below: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
155.240 - and UU_in_A: "\<bottom> \<in> A"
155.241 - shows "x \<in> A \<Longrightarrow> (Abs x = \<bottom>) = (x = \<bottom>)"
155.242 - apply (rule typedef_Abs_strict [OF type below UU_in_A, THEN subst])
155.243 - apply (simp add: type_definition.Abs_inject [OF type] UU_in_A)
155.244 -done
155.245 -
155.246 -theorem typedef_Rep_bottom_iff:
155.247 - assumes type: "type_definition Rep Abs A"
155.248 - and below: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
155.249 - and UU_in_A: "\<bottom> \<in> A"
155.250 - shows "(Rep x = \<bottom>) = (x = \<bottom>)"
155.251 - apply (rule typedef_Rep_strict [OF type below UU_in_A, THEN subst])
155.252 - apply (simp add: type_definition.Rep_inject [OF type])
155.253 -done
155.254 -
155.255 -theorem typedef_Abs_defined:
155.256 - assumes type: "type_definition Rep Abs A"
155.257 - and below: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
155.258 - and UU_in_A: "\<bottom> \<in> A"
155.259 - shows "\<lbrakk>x \<noteq> \<bottom>; x \<in> A\<rbrakk> \<Longrightarrow> Abs x \<noteq> \<bottom>"
155.260 -by (simp add: typedef_Abs_bottom_iff [OF type below UU_in_A])
155.261 -
155.262 -theorem typedef_Rep_defined:
155.263 - assumes type: "type_definition Rep Abs A"
155.264 - and below: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
155.265 - and UU_in_A: "\<bottom> \<in> A"
155.266 - shows "x \<noteq> \<bottom> \<Longrightarrow> Rep x \<noteq> \<bottom>"
155.267 -by (simp add: typedef_Rep_bottom_iff [OF type below UU_in_A])
155.268 -
155.269 -subsection {* Proving a subtype is flat *}
155.270 -
155.271 -theorem typedef_flat:
155.272 - fixes Abs :: "'a::flat \<Rightarrow> 'b::pcpo"
155.273 - assumes type: "type_definition Rep Abs A"
155.274 - and below: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
155.275 - and UU_in_A: "\<bottom> \<in> A"
155.276 - shows "OFCLASS('b, flat_class)"
155.277 - apply (intro_classes)
155.278 - apply (unfold below)
155.279 - apply (simp add: type_definition.Rep_inject [OF type, symmetric])
155.280 - apply (simp add: typedef_Rep_strict [OF type below UU_in_A])
155.281 - apply (simp add: ax_flat)
155.282 -done
155.283 -
155.284 -subsection {* HOLCF type definition package *}
155.285 -
155.286 -use "Tools/cpodef.ML"
155.287 -
155.288 -end
156.1 --- a/src/HOLCF/Cprod.thy Sat Nov 27 14:34:54 2010 -0800
156.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
156.3 @@ -1,43 +0,0 @@
156.4 -(* Title: HOLCF/Cprod.thy
156.5 - Author: Franz Regensburger
156.6 -*)
156.7 -
156.8 -header {* The cpo of cartesian products *}
156.9 -
156.10 -theory Cprod
156.11 -imports Cfun
156.12 -begin
156.13 -
156.14 -default_sort cpo
156.15 -
156.16 -subsection {* Continuous case function for unit type *}
156.17 -
156.18 -definition
156.19 - unit_when :: "'a \<rightarrow> unit \<rightarrow> 'a" where
156.20 - "unit_when = (\<Lambda> a _. a)"
156.21 -
156.22 -translations
156.23 - "\<Lambda>(). t" == "CONST unit_when\<cdot>t"
156.24 -
156.25 -lemma unit_when [simp]: "unit_when\<cdot>a\<cdot>u = a"
156.26 -by (simp add: unit_when_def)
156.27 -
156.28 -subsection {* Continuous version of split function *}
156.29 -
156.30 -definition
156.31 - csplit :: "('a \<rightarrow> 'b \<rightarrow> 'c) \<rightarrow> ('a * 'b) \<rightarrow> 'c" where
156.32 - "csplit = (\<Lambda> f p. f\<cdot>(fst p)\<cdot>(snd p))"
156.33 -
156.34 -translations
156.35 - "\<Lambda>(CONST Pair x y). t" == "CONST csplit\<cdot>(\<Lambda> x y. t)"
156.36 -
156.37 -
156.38 -subsection {* Convert all lemmas to the continuous versions *}
156.39 -
156.40 -lemma csplit1 [simp]: "csplit\<cdot>f\<cdot>\<bottom> = f\<cdot>\<bottom>\<cdot>\<bottom>"
156.41 -by (simp add: csplit_def)
156.42 -
156.43 -lemma csplit_Pair [simp]: "csplit\<cdot>f\<cdot>(x, y) = f\<cdot>x\<cdot>y"
156.44 -by (simp add: csplit_def)
156.45 -
156.46 -end
157.1 --- a/src/HOLCF/Deflation.thy Sat Nov 27 14:34:54 2010 -0800
157.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
157.3 @@ -1,408 +0,0 @@
157.4 -(* Title: HOLCF/Deflation.thy
157.5 - Author: Brian Huffman
157.6 -*)
157.7 -
157.8 -header {* Continuous deflations and ep-pairs *}
157.9 -
157.10 -theory Deflation
157.11 -imports Plain_HOLCF
157.12 -begin
157.13 -
157.14 -default_sort cpo
157.15 -
157.16 -subsection {* Continuous deflations *}
157.17 -
157.18 -locale deflation =
157.19 - fixes d :: "'a \<rightarrow> 'a"
157.20 - assumes idem: "\<And>x. d\<cdot>(d\<cdot>x) = d\<cdot>x"
157.21 - assumes below: "\<And>x. d\<cdot>x \<sqsubseteq> x"
157.22 -begin
157.23 -
157.24 -lemma below_ID: "d \<sqsubseteq> ID"
157.25 -by (rule cfun_belowI, simp add: below)
157.26 -
157.27 -text {* The set of fixed points is the same as the range. *}
157.28 -
157.29 -lemma fixes_eq_range: "{x. d\<cdot>x = x} = range (\<lambda>x. d\<cdot>x)"
157.30 -by (auto simp add: eq_sym_conv idem)
157.31 -
157.32 -lemma range_eq_fixes: "range (\<lambda>x. d\<cdot>x) = {x. d\<cdot>x = x}"
157.33 -by (auto simp add: eq_sym_conv idem)
157.34 -
157.35 -text {*
157.36 - The pointwise ordering on deflation functions coincides with
157.37 - the subset ordering of their sets of fixed-points.
157.38 -*}
157.39 -
157.40 -lemma belowI:
157.41 - assumes f: "\<And>x. d\<cdot>x = x \<Longrightarrow> f\<cdot>x = x" shows "d \<sqsubseteq> f"
157.42 -proof (rule cfun_belowI)
157.43 - fix x
157.44 - from below have "f\<cdot>(d\<cdot>x) \<sqsubseteq> f\<cdot>x" by (rule monofun_cfun_arg)
157.45 - also from idem have "f\<cdot>(d\<cdot>x) = d\<cdot>x" by (rule f)
157.46 - finally show "d\<cdot>x \<sqsubseteq> f\<cdot>x" .
157.47 -qed
157.48 -
157.49 -lemma belowD: "\<lbrakk>f \<sqsubseteq> d; f\<cdot>x = x\<rbrakk> \<Longrightarrow> d\<cdot>x = x"
157.50 -proof (rule below_antisym)
157.51 - from below show "d\<cdot>x \<sqsubseteq> x" .
157.52 -next
157.53 - assume "f \<sqsubseteq> d"
157.54 - hence "f\<cdot>x \<sqsubseteq> d\<cdot>x" by (rule monofun_cfun_fun)
157.55 - also assume "f\<cdot>x = x"
157.56 - finally show "x \<sqsubseteq> d\<cdot>x" .
157.57 -qed
157.58 -
157.59 -end
157.60 -
157.61 -lemma deflation_strict: "deflation d \<Longrightarrow> d\<cdot>\<bottom> = \<bottom>"
157.62 -by (rule deflation.below [THEN UU_I])
157.63 -
157.64 -lemma adm_deflation: "adm (\<lambda>d. deflation d)"
157.65 -by (simp add: deflation_def)
157.66 -
157.67 -lemma deflation_ID: "deflation ID"
157.68 -by (simp add: deflation.intro)
157.69 -
157.70 -lemma deflation_UU: "deflation \<bottom>"
157.71 -by (simp add: deflation.intro)
157.72 -
157.73 -lemma deflation_below_iff:
157.74 - "\<lbrakk>deflation p; deflation q\<rbrakk> \<Longrightarrow> p \<sqsubseteq> q \<longleftrightarrow> (\<forall>x. p\<cdot>x = x \<longrightarrow> q\<cdot>x = x)"
157.75 - apply safe
157.76 - apply (simp add: deflation.belowD)
157.77 - apply (simp add: deflation.belowI)
157.78 -done
157.79 -
157.80 -text {*
157.81 - The composition of two deflations is equal to
157.82 - the lesser of the two (if they are comparable).
157.83 -*}
157.84 -
157.85 -lemma deflation_below_comp1:
157.86 - assumes "deflation f"
157.87 - assumes "deflation g"
157.88 - shows "f \<sqsubseteq> g \<Longrightarrow> f\<cdot>(g\<cdot>x) = f\<cdot>x"
157.89 -proof (rule below_antisym)
157.90 - interpret g: deflation g by fact
157.91 - from g.below show "f\<cdot>(g\<cdot>x) \<sqsubseteq> f\<cdot>x" by (rule monofun_cfun_arg)
157.92 -next
157.93 - interpret f: deflation f by fact
157.94 - assume "f \<sqsubseteq> g" hence "f\<cdot>x \<sqsubseteq> g\<cdot>x" by (rule monofun_cfun_fun)
157.95 - hence "f\<cdot>(f\<cdot>x) \<sqsubseteq> f\<cdot>(g\<cdot>x)" by (rule monofun_cfun_arg)
157.96 - also have "f\<cdot>(f\<cdot>x) = f\<cdot>x" by (rule f.idem)
157.97 - finally show "f\<cdot>x \<sqsubseteq> f\<cdot>(g\<cdot>x)" .
157.98 -qed
157.99 -
157.100 -lemma deflation_below_comp2:
157.101 - "\<lbrakk>deflation f; deflation g; f \<sqsubseteq> g\<rbrakk> \<Longrightarrow> g\<cdot>(f\<cdot>x) = f\<cdot>x"
157.102 -by (simp only: deflation.belowD deflation.idem)
157.103 -
157.104 -
157.105 -subsection {* Deflations with finite range *}
157.106 -
157.107 -lemma finite_range_imp_finite_fixes:
157.108 - "finite (range f) \<Longrightarrow> finite {x. f x = x}"
157.109 -proof -
157.110 - have "{x. f x = x} \<subseteq> range f"
157.111 - by (clarify, erule subst, rule rangeI)
157.112 - moreover assume "finite (range f)"
157.113 - ultimately show "finite {x. f x = x}"
157.114 - by (rule finite_subset)
157.115 -qed
157.116 -
157.117 -locale finite_deflation = deflation +
157.118 - assumes finite_fixes: "finite {x. d\<cdot>x = x}"
157.119 -begin
157.120 -
157.121 -lemma finite_range: "finite (range (\<lambda>x. d\<cdot>x))"
157.122 -by (simp add: range_eq_fixes finite_fixes)
157.123 -
157.124 -lemma finite_image: "finite ((\<lambda>x. d\<cdot>x) ` A)"
157.125 -by (rule finite_subset [OF image_mono [OF subset_UNIV] finite_range])
157.126 -
157.127 -lemma compact: "compact (d\<cdot>x)"
157.128 -proof (rule compactI2)
157.129 - fix Y :: "nat \<Rightarrow> 'a"
157.130 - assume Y: "chain Y"
157.131 - have "finite_chain (\<lambda>i. d\<cdot>(Y i))"
157.132 - proof (rule finite_range_imp_finch)
157.133 - show "chain (\<lambda>i. d\<cdot>(Y i))"
157.134 - using Y by simp
157.135 - have "range (\<lambda>i. d\<cdot>(Y i)) \<subseteq> range (\<lambda>x. d\<cdot>x)"
157.136 - by clarsimp
157.137 - thus "finite (range (\<lambda>i. d\<cdot>(Y i)))"
157.138 - using finite_range by (rule finite_subset)
157.139 - qed
157.140 - hence "\<exists>j. (\<Squnion>i. d\<cdot>(Y i)) = d\<cdot>(Y j)"
157.141 - by (simp add: finite_chain_def maxinch_is_thelub Y)
157.142 - then obtain j where j: "(\<Squnion>i. d\<cdot>(Y i)) = d\<cdot>(Y j)" ..
157.143 -
157.144 - assume "d\<cdot>x \<sqsubseteq> (\<Squnion>i. Y i)"
157.145 - hence "d\<cdot>(d\<cdot>x) \<sqsubseteq> d\<cdot>(\<Squnion>i. Y i)"
157.146 - by (rule monofun_cfun_arg)
157.147 - hence "d\<cdot>x \<sqsubseteq> (\<Squnion>i. d\<cdot>(Y i))"
157.148 - by (simp add: contlub_cfun_arg Y idem)
157.149 - hence "d\<cdot>x \<sqsubseteq> d\<cdot>(Y j)"
157.150 - using j by simp
157.151 - hence "d\<cdot>x \<sqsubseteq> Y j"
157.152 - using below by (rule below_trans)
157.153 - thus "\<exists>j. d\<cdot>x \<sqsubseteq> Y j" ..
157.154 -qed
157.155 -
157.156 -end
157.157 -
157.158 -lemma finite_deflation_intro:
157.159 - "deflation d \<Longrightarrow> finite {x. d\<cdot>x = x} \<Longrightarrow> finite_deflation d"
157.160 -by (intro finite_deflation.intro finite_deflation_axioms.intro)
157.161 -
157.162 -lemma finite_deflation_imp_deflation:
157.163 - "finite_deflation d \<Longrightarrow> deflation d"
157.164 -unfolding finite_deflation_def by simp
157.165 -
157.166 -lemma finite_deflation_UU: "finite_deflation \<bottom>"
157.167 -by default simp_all
157.168 -
157.169 -
157.170 -subsection {* Continuous embedding-projection pairs *}
157.171 -
157.172 -locale ep_pair =
157.173 - fixes e :: "'a \<rightarrow> 'b" and p :: "'b \<rightarrow> 'a"
157.174 - assumes e_inverse [simp]: "\<And>x. p\<cdot>(e\<cdot>x) = x"
157.175 - and e_p_below: "\<And>y. e\<cdot>(p\<cdot>y) \<sqsubseteq> y"
157.176 -begin
157.177 -
157.178 -lemma e_below_iff [simp]: "e\<cdot>x \<sqsubseteq> e\<cdot>y \<longleftrightarrow> x \<sqsubseteq> y"
157.179 -proof
157.180 - assume "e\<cdot>x \<sqsubseteq> e\<cdot>y"
157.181 - hence "p\<cdot>(e\<cdot>x) \<sqsubseteq> p\<cdot>(e\<cdot>y)" by (rule monofun_cfun_arg)
157.182 - thus "x \<sqsubseteq> y" by simp
157.183 -next
157.184 - assume "x \<sqsubseteq> y"
157.185 - thus "e\<cdot>x \<sqsubseteq> e\<cdot>y" by (rule monofun_cfun_arg)
157.186 -qed
157.187 -
157.188 -lemma e_eq_iff [simp]: "e\<cdot>x = e\<cdot>y \<longleftrightarrow> x = y"
157.189 -unfolding po_eq_conv e_below_iff ..
157.190 -
157.191 -lemma p_eq_iff:
157.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"
157.193 -by (safe, erule subst, erule subst, simp)
157.194 -
157.195 -lemma p_inverse: "(\<exists>x. y = e\<cdot>x) = (e\<cdot>(p\<cdot>y) = y)"
157.196 -by (auto, rule exI, erule sym)
157.197 -
157.198 -lemma e_below_iff_below_p: "e\<cdot>x \<sqsubseteq> y \<longleftrightarrow> x \<sqsubseteq> p\<cdot>y"
157.199 -proof
157.200 - assume "e\<cdot>x \<sqsubseteq> y"
157.201 - then have "p\<cdot>(e\<cdot>x) \<sqsubseteq> p\<cdot>y" by (rule monofun_cfun_arg)
157.202 - then show "x \<sqsubseteq> p\<cdot>y" by simp
157.203 -next
157.204 - assume "x \<sqsubseteq> p\<cdot>y"
157.205 - then have "e\<cdot>x \<sqsubseteq> e\<cdot>(p\<cdot>y)" by (rule monofun_cfun_arg)
157.206 - then show "e\<cdot>x \<sqsubseteq> y" using e_p_below by (rule below_trans)
157.207 -qed
157.208 -
157.209 -lemma compact_e_rev: "compact (e\<cdot>x) \<Longrightarrow> compact x"
157.210 -proof -
157.211 - assume "compact (e\<cdot>x)"
157.212 - hence "adm (\<lambda>y. \<not> e\<cdot>x \<sqsubseteq> y)" by (rule compactD)
157.213 - hence "adm (\<lambda>y. \<not> e\<cdot>x \<sqsubseteq> e\<cdot>y)" by (rule adm_subst [OF cont_Rep_cfun2])
157.214 - hence "adm (\<lambda>y. \<not> x \<sqsubseteq> y)" by simp
157.215 - thus "compact x" by (rule compactI)
157.216 -qed
157.217 -
157.218 -lemma compact_e: "compact x \<Longrightarrow> compact (e\<cdot>x)"
157.219 -proof -
157.220 - assume "compact x"
157.221 - hence "adm (\<lambda>y. \<not> x \<sqsubseteq> y)" by (rule compactD)
157.222 - hence "adm (\<lambda>y. \<not> x \<sqsubseteq> p\<cdot>y)" by (rule adm_subst [OF cont_Rep_cfun2])
157.223 - hence "adm (\<lambda>y. \<not> e\<cdot>x \<sqsubseteq> y)" by (simp add: e_below_iff_below_p)
157.224 - thus "compact (e\<cdot>x)" by (rule compactI)
157.225 -qed
157.226 -
157.227 -lemma compact_e_iff: "compact (e\<cdot>x) \<longleftrightarrow> compact x"
157.228 -by (rule iffI [OF compact_e_rev compact_e])
157.229 -
157.230 -text {* Deflations from ep-pairs *}
157.231 -
157.232 -lemma deflation_e_p: "deflation (e oo p)"
157.233 -by (simp add: deflation.intro e_p_below)
157.234 -
157.235 -lemma deflation_e_d_p:
157.236 - assumes "deflation d"
157.237 - shows "deflation (e oo d oo p)"
157.238 -proof
157.239 - interpret deflation d by fact
157.240 - fix x :: 'b
157.241 - show "(e oo d oo p)\<cdot>((e oo d oo p)\<cdot>x) = (e oo d oo p)\<cdot>x"
157.242 - by (simp add: idem)
157.243 - show "(e oo d oo p)\<cdot>x \<sqsubseteq> x"
157.244 - by (simp add: e_below_iff_below_p below)
157.245 -qed
157.246 -
157.247 -lemma finite_deflation_e_d_p:
157.248 - assumes "finite_deflation d"
157.249 - shows "finite_deflation (e oo d oo p)"
157.250 -proof
157.251 - interpret finite_deflation d by fact
157.252 - fix x :: 'b
157.253 - show "(e oo d oo p)\<cdot>((e oo d oo p)\<cdot>x) = (e oo d oo p)\<cdot>x"
157.254 - by (simp add: idem)
157.255 - show "(e oo d oo p)\<cdot>x \<sqsubseteq> x"
157.256 - by (simp add: e_below_iff_below_p below)
157.257 - have "finite ((\<lambda>x. e\<cdot>x) ` (\<lambda>x. d\<cdot>x) ` range (\<lambda>x. p\<cdot>x))"
157.258 - by (simp add: finite_image)
157.259 - hence "finite (range (\<lambda>x. (e oo d oo p)\<cdot>x))"
157.260 - by (simp add: image_image)
157.261 - thus "finite {x. (e oo d oo p)\<cdot>x = x}"
157.262 - by (rule finite_range_imp_finite_fixes)
157.263 -qed
157.264 -
157.265 -lemma deflation_p_d_e:
157.266 - assumes "deflation d"
157.267 - assumes d: "\<And>x. d\<cdot>x \<sqsubseteq> e\<cdot>(p\<cdot>x)"
157.268 - shows "deflation (p oo d oo e)"
157.269 -proof -
157.270 - interpret d: deflation d by fact
157.271 - {
157.272 - fix x
157.273 - have "d\<cdot>(e\<cdot>x) \<sqsubseteq> e\<cdot>x"
157.274 - by (rule d.below)
157.275 - hence "p\<cdot>(d\<cdot>(e\<cdot>x)) \<sqsubseteq> p\<cdot>(e\<cdot>x)"
157.276 - by (rule monofun_cfun_arg)
157.277 - hence "(p oo d oo e)\<cdot>x \<sqsubseteq> x"
157.278 - by simp
157.279 - }
157.280 - note p_d_e_below = this
157.281 - show ?thesis
157.282 - proof
157.283 - fix x
157.284 - show "(p oo d oo e)\<cdot>x \<sqsubseteq> x"
157.285 - by (rule p_d_e_below)
157.286 - next
157.287 - fix x
157.288 - show "(p oo d oo e)\<cdot>((p oo d oo e)\<cdot>x) = (p oo d oo e)\<cdot>x"
157.289 - proof (rule below_antisym)
157.290 - show "(p oo d oo e)\<cdot>((p oo d oo e)\<cdot>x) \<sqsubseteq> (p oo d oo e)\<cdot>x"
157.291 - by (rule p_d_e_below)
157.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)))))"
157.293 - by (intro monofun_cfun_arg d)
157.294 - hence "p\<cdot>(d\<cdot>(e\<cdot>x)) \<sqsubseteq> p\<cdot>(d\<cdot>(e\<cdot>(p\<cdot>(d\<cdot>(e\<cdot>x)))))"
157.295 - by (simp only: d.idem)
157.296 - thus "(p oo d oo e)\<cdot>x \<sqsubseteq> (p oo d oo e)\<cdot>((p oo d oo e)\<cdot>x)"
157.297 - by simp
157.298 - qed
157.299 - qed
157.300 -qed
157.301 -
157.302 -lemma finite_deflation_p_d_e:
157.303 - assumes "finite_deflation d"
157.304 - assumes d: "\<And>x. d\<cdot>x \<sqsubseteq> e\<cdot>(p\<cdot>x)"
157.305 - shows "finite_deflation (p oo d oo e)"
157.306 -proof -
157.307 - interpret d: finite_deflation d by fact
157.308 - show ?thesis
157.309 - proof (rule finite_deflation_intro)
157.310 - have "deflation d" ..
157.311 - thus "deflation (p oo d oo e)"
157.312 - using d by (rule deflation_p_d_e)
157.313 - next
157.314 - have "finite ((\<lambda>x. d\<cdot>x) ` range (\<lambda>x. e\<cdot>x))"
157.315 - by (rule d.finite_image)
157.316 - hence "finite ((\<lambda>x. p\<cdot>x) ` (\<lambda>x. d\<cdot>x) ` range (\<lambda>x. e\<cdot>x))"
157.317 - by (rule finite_imageI)
157.318 - hence "finite (range (\<lambda>x. (p oo d oo e)\<cdot>x))"
157.319 - by (simp add: image_image)
157.320 - thus "finite {x. (p oo d oo e)\<cdot>x = x}"
157.321 - by (rule finite_range_imp_finite_fixes)
157.322 - qed
157.323 -qed
157.324 -
157.325 -end
157.326 -
157.327 -subsection {* Uniqueness of ep-pairs *}
157.328 -
157.329 -lemma ep_pair_unique_e_lemma:
157.330 - assumes 1: "ep_pair e1 p" and 2: "ep_pair e2 p"
157.331 - shows "e1 \<sqsubseteq> e2"
157.332 -proof (rule cfun_belowI)
157.333 - fix x
157.334 - have "e1\<cdot>(p\<cdot>(e2\<cdot>x)) \<sqsubseteq> e2\<cdot>x"
157.335 - by (rule ep_pair.e_p_below [OF 1])
157.336 - thus "e1\<cdot>x \<sqsubseteq> e2\<cdot>x"
157.337 - by (simp only: ep_pair.e_inverse [OF 2])
157.338 -qed
157.339 -
157.340 -lemma ep_pair_unique_e:
157.341 - "\<lbrakk>ep_pair e1 p; ep_pair e2 p\<rbrakk> \<Longrightarrow> e1 = e2"
157.342 -by (fast intro: below_antisym elim: ep_pair_unique_e_lemma)
157.343 -
157.344 -lemma ep_pair_unique_p_lemma:
157.345 - assumes 1: "ep_pair e p1" and 2: "ep_pair e p2"
157.346 - shows "p1 \<sqsubseteq> p2"
157.347 -proof (rule cfun_belowI)
157.348 - fix x
157.349 - have "e\<cdot>(p1\<cdot>x) \<sqsubseteq> x"
157.350 - by (rule ep_pair.e_p_below [OF 1])
157.351 - hence "p2\<cdot>(e\<cdot>(p1\<cdot>x)) \<sqsubseteq> p2\<cdot>x"
157.352 - by (rule monofun_cfun_arg)
157.353 - thus "p1\<cdot>x \<sqsubseteq> p2\<cdot>x"
157.354 - by (simp only: ep_pair.e_inverse [OF 2])
157.355 -qed
157.356 -
157.357 -lemma ep_pair_unique_p:
157.358 - "\<lbrakk>ep_pair e p1; ep_pair e p2\<rbrakk> \<Longrightarrow> p1 = p2"
157.359 -by (fast intro: below_antisym elim: ep_pair_unique_p_lemma)
157.360 -
157.361 -subsection {* Composing ep-pairs *}
157.362 -
157.363 -lemma ep_pair_ID_ID: "ep_pair ID ID"
157.364 -by default simp_all
157.365 -
157.366 -lemma ep_pair_comp:
157.367 - assumes "ep_pair e1 p1" and "ep_pair e2 p2"
157.368 - shows "ep_pair (e2 oo e1) (p1 oo p2)"
157.369 -proof
157.370 - interpret ep1: ep_pair e1 p1 by fact
157.371 - interpret ep2: ep_pair e2 p2 by fact
157.372 - fix x y
157.373 - show "(p1 oo p2)\<cdot>((e2 oo e1)\<cdot>x) = x"
157.374 - by simp
157.375 - have "e1\<cdot>(p1\<cdot>(p2\<cdot>y)) \<sqsubseteq> p2\<cdot>y"
157.376 - by (rule ep1.e_p_below)
157.377 - hence "e2\<cdot>(e1\<cdot>(p1\<cdot>(p2\<cdot>y))) \<sqsubseteq> e2\<cdot>(p2\<cdot>y)"
157.378 - by (rule monofun_cfun_arg)
157.379 - also have "e2\<cdot>(p2\<cdot>y) \<sqsubseteq> y"
157.380 - by (rule ep2.e_p_below)
157.381 - finally show "(e2 oo e1)\<cdot>((p1 oo p2)\<cdot>y) \<sqsubseteq> y"
157.382 - by simp
157.383 -qed
157.384 -
157.385 -locale pcpo_ep_pair = ep_pair +
157.386 - constrains e :: "'a::pcpo \<rightarrow> 'b::pcpo"
157.387 - constrains p :: "'b::pcpo \<rightarrow> 'a::pcpo"
157.388 -begin
157.389 -
157.390 -lemma e_strict [simp]: "e\<cdot>\<bottom> = \<bottom>"
157.391 -proof -
157.392 - have "\<bottom> \<sqsubseteq> p\<cdot>\<bottom>" by (rule minimal)
157.393 - hence "e\<cdot>\<bottom> \<sqsubseteq> e\<cdot>(p\<cdot>\<bottom>)" by (rule monofun_cfun_arg)
157.394 - also have "e\<cdot>(p\<cdot>\<bottom>) \<sqsubseteq> \<bottom>" by (rule e_p_below)
157.395 - finally show "e\<cdot>\<bottom> = \<bottom>" by simp
157.396 -qed
157.397 -
157.398 -lemma e_bottom_iff [simp]: "e\<cdot>x = \<bottom> \<longleftrightarrow> x = \<bottom>"
157.399 -by (rule e_eq_iff [where y="\<bottom>", unfolded e_strict])
157.400 -
157.401 -lemma e_defined: "x \<noteq> \<bottom> \<Longrightarrow> e\<cdot>x \<noteq> \<bottom>"
157.402 -by simp
157.403 -
157.404 -lemma p_strict [simp]: "p\<cdot>\<bottom> = \<bottom>"
157.405 -by (rule e_inverse [where x="\<bottom>", unfolded e_strict])
157.406 -
157.407 -lemmas stricts = e_strict p_strict
157.408 -
157.409 -end
157.410 -
157.411 -end
158.1 --- a/src/HOLCF/Discrete.thy Sat Nov 27 14:34:54 2010 -0800
158.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
158.3 @@ -1,38 +0,0 @@
158.4 -(* Title: HOLCF/Discrete.thy
158.5 - Author: Tobias Nipkow
158.6 -*)
158.7 -
158.8 -header {* Discrete cpo types *}
158.9 -
158.10 -theory Discrete
158.11 -imports Cont
158.12 -begin
158.13 -
158.14 -datatype 'a discr = Discr "'a :: type"
158.15 -
158.16 -subsection {* Discrete cpo class instance *}
158.17 -
158.18 -instantiation discr :: (type) discrete_cpo
158.19 -begin
158.20 -
158.21 -definition
158.22 - "(op \<sqsubseteq> :: 'a discr \<Rightarrow> 'a discr \<Rightarrow> bool) = (op =)"
158.23 -
158.24 -instance
158.25 -by default (simp add: below_discr_def)
158.26 -
158.27 -end
158.28 -
158.29 -subsection {* \emph{undiscr} *}
158.30 -
158.31 -definition
158.32 - undiscr :: "('a::type)discr => 'a" where
158.33 - "undiscr x = (case x of Discr y => y)"
158.34 -
158.35 -lemma undiscr_Discr [simp]: "undiscr (Discr x) = x"
158.36 -by (simp add: undiscr_def)
158.37 -
158.38 -lemma Discr_undiscr [simp]: "Discr (undiscr y) = y"
158.39 -by (induct y) simp
158.40 -
158.41 -end
159.1 --- a/src/HOLCF/Domain.thy Sat Nov 27 14:34:54 2010 -0800
159.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
159.3 @@ -1,352 +0,0 @@
159.4 -(* Title: HOLCF/Domain.thy
159.5 - Author: Brian Huffman
159.6 -*)
159.7 -
159.8 -header {* Domain package *}
159.9 -
159.10 -theory Domain
159.11 -imports Bifinite Domain_Aux
159.12 -uses
159.13 - ("Tools/domaindef.ML")
159.14 - ("Tools/Domain/domain_isomorphism.ML")
159.15 - ("Tools/Domain/domain_axioms.ML")
159.16 - ("Tools/Domain/domain.ML")
159.17 -begin
159.18 -
159.19 -default_sort "domain"
159.20 -
159.21 -subsection {* Representations of types *}
159.22 -
159.23 -lemma emb_prj: "emb\<cdot>((prj\<cdot>x)::'a) = cast\<cdot>DEFL('a)\<cdot>x"
159.24 -by (simp add: cast_DEFL)
159.25 -
159.26 -lemma emb_prj_emb:
159.27 - fixes x :: "'a"
159.28 - assumes "DEFL('a) \<sqsubseteq> DEFL('b)"
159.29 - shows "emb\<cdot>(prj\<cdot>(emb\<cdot>x) :: 'b) = emb\<cdot>x"
159.30 -unfolding emb_prj
159.31 -apply (rule cast.belowD)
159.32 -apply (rule monofun_cfun_arg [OF assms])
159.33 -apply (simp add: cast_DEFL)
159.34 -done
159.35 -
159.36 -lemma prj_emb_prj:
159.37 - assumes "DEFL('a) \<sqsubseteq> DEFL('b)"
159.38 - shows "prj\<cdot>(emb\<cdot>(prj\<cdot>x :: 'b)) = (prj\<cdot>x :: 'a)"
159.39 - apply (rule emb_eq_iff [THEN iffD1])
159.40 - apply (simp only: emb_prj)
159.41 - apply (rule deflation_below_comp1)
159.42 - apply (rule deflation_cast)
159.43 - apply (rule deflation_cast)
159.44 - apply (rule monofun_cfun_arg [OF assms])
159.45 -done
159.46 -
159.47 -text {* Isomorphism lemmas used internally by the domain package: *}
159.48 -
159.49 -lemma domain_abs_iso:
159.50 - fixes abs and rep
159.51 - assumes DEFL: "DEFL('b) = DEFL('a)"
159.52 - assumes abs_def: "(abs :: 'a \<rightarrow> 'b) \<equiv> prj oo emb"
159.53 - assumes rep_def: "(rep :: 'b \<rightarrow> 'a) \<equiv> prj oo emb"
159.54 - shows "rep\<cdot>(abs\<cdot>x) = x"
159.55 -unfolding abs_def rep_def
159.56 -by (simp add: emb_prj_emb DEFL)
159.57 -
159.58 -lemma domain_rep_iso:
159.59 - fixes abs and rep
159.60 - assumes DEFL: "DEFL('b) = DEFL('a)"
159.61 - assumes abs_def: "(abs :: 'a \<rightarrow> 'b) \<equiv> prj oo emb"
159.62 - assumes rep_def: "(rep :: 'b \<rightarrow> 'a) \<equiv> prj oo emb"
159.63 - shows "abs\<cdot>(rep\<cdot>x) = x"
159.64 -unfolding abs_def rep_def
159.65 -by (simp add: emb_prj_emb DEFL)
159.66 -
159.67 -subsection {* Deflations as sets *}
159.68 -
159.69 -definition defl_set :: "defl \<Rightarrow> udom set"
159.70 -where "defl_set A = {x. cast\<cdot>A\<cdot>x = x}"
159.71 -
159.72 -lemma adm_defl_set: "adm (\<lambda>x. x \<in> defl_set A)"
159.73 -unfolding defl_set_def by simp
159.74 -
159.75 -lemma defl_set_bottom: "\<bottom> \<in> defl_set A"
159.76 -unfolding defl_set_def by simp
159.77 -
159.78 -lemma defl_set_cast [simp]: "cast\<cdot>A\<cdot>x \<in> defl_set A"
159.79 -unfolding defl_set_def by simp
159.80 -
159.81 -lemma defl_set_subset_iff: "defl_set A \<subseteq> defl_set B \<longleftrightarrow> A \<sqsubseteq> B"
159.82 -apply (simp add: defl_set_def subset_eq cast_below_cast [symmetric])
159.83 -apply (auto simp add: cast.belowI cast.belowD)
159.84 -done
159.85 -
159.86 -subsection {* Proving a subtype is representable *}
159.87 -
159.88 -text {* Temporarily relax type constraints. *}
159.89 -
159.90 -setup {*
159.91 - fold Sign.add_const_constraint
159.92 - [ (@{const_name defl}, SOME @{typ "'a::pcpo itself \<Rightarrow> defl"})
159.93 - , (@{const_name emb}, SOME @{typ "'a::pcpo \<rightarrow> udom"})
159.94 - , (@{const_name prj}, SOME @{typ "udom \<rightarrow> 'a::pcpo"})
159.95 - , (@{const_name liftdefl}, SOME @{typ "'a::pcpo itself \<Rightarrow> defl"})
159.96 - , (@{const_name liftemb}, SOME @{typ "'a::pcpo u \<rightarrow> udom"})
159.97 - , (@{const_name liftprj}, SOME @{typ "udom \<rightarrow> 'a::pcpo u"}) ]
159.98 -*}
159.99 -
159.100 -lemma typedef_liftdomain_class:
159.101 - fixes Rep :: "'a::pcpo \<Rightarrow> udom"
159.102 - fixes Abs :: "udom \<Rightarrow> 'a::pcpo"
159.103 - fixes t :: defl
159.104 - assumes type: "type_definition Rep Abs (defl_set t)"
159.105 - assumes below: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
159.106 - assumes emb: "emb \<equiv> (\<Lambda> x. Rep x)"
159.107 - assumes prj: "prj \<equiv> (\<Lambda> x. Abs (cast\<cdot>t\<cdot>x))"
159.108 - assumes defl: "defl \<equiv> (\<lambda> a::'a itself. t)"
159.109 - assumes liftemb: "(liftemb :: 'a u \<rightarrow> udom) \<equiv> udom_emb u_approx oo u_map\<cdot>emb"
159.110 - assumes liftprj: "(liftprj :: udom \<rightarrow> 'a u) \<equiv> u_map\<cdot>prj oo udom_prj u_approx"
159.111 - assumes liftdefl: "(liftdefl :: 'a itself \<Rightarrow> defl) \<equiv> (\<lambda>t. u_defl\<cdot>DEFL('a))"
159.112 - shows "OFCLASS('a, liftdomain_class)"
159.113 -using liftemb [THEN meta_eq_to_obj_eq]
159.114 -using liftprj [THEN meta_eq_to_obj_eq]
159.115 -proof (rule liftdomain_class_intro)
159.116 - have emb_beta: "\<And>x. emb\<cdot>x = Rep x"
159.117 - unfolding emb
159.118 - apply (rule beta_cfun)
159.119 - apply (rule typedef_cont_Rep [OF type below adm_defl_set])
159.120 - done
159.121 - have prj_beta: "\<And>y. prj\<cdot>y = Abs (cast\<cdot>t\<cdot>y)"
159.122 - unfolding prj
159.123 - apply (rule beta_cfun)
159.124 - apply (rule typedef_cont_Abs [OF type below adm_defl_set])
159.125 - apply simp_all
159.126 - done
159.127 - have prj_emb: "\<And>x::'a. prj\<cdot>(emb\<cdot>x) = x"
159.128 - using type_definition.Rep [OF type]
159.129 - unfolding prj_beta emb_beta defl_set_def
159.130 - by (simp add: type_definition.Rep_inverse [OF type])
159.131 - have emb_prj: "\<And>y. emb\<cdot>(prj\<cdot>y :: 'a) = cast\<cdot>t\<cdot>y"
159.132 - unfolding prj_beta emb_beta
159.133 - by (simp add: type_definition.Abs_inverse [OF type])
159.134 - show "ep_pair (emb :: 'a \<rightarrow> udom) prj"
159.135 - apply default
159.136 - apply (simp add: prj_emb)
159.137 - apply (simp add: emb_prj cast.below)
159.138 - done
159.139 - show "cast\<cdot>DEFL('a) = emb oo (prj :: udom \<rightarrow> 'a)"
159.140 - by (rule cfun_eqI, simp add: defl emb_prj)
159.141 - show "LIFTDEFL('a) = u_defl\<cdot>DEFL('a)"
159.142 - unfolding liftdefl ..
159.143 -qed
159.144 -
159.145 -lemma typedef_DEFL:
159.146 - assumes "defl \<equiv> (\<lambda>a::'a::pcpo itself. t)"
159.147 - shows "DEFL('a::pcpo) = t"
159.148 -unfolding assms ..
159.149 -
159.150 -text {* Restore original typing constraints. *}
159.151 -
159.152 -setup {*
159.153 - fold Sign.add_const_constraint
159.154 - [ (@{const_name defl}, SOME @{typ "'a::domain itself \<Rightarrow> defl"})
159.155 - , (@{const_name emb}, SOME @{typ "'a::domain \<rightarrow> udom"})
159.156 - , (@{const_name prj}, SOME @{typ "udom \<rightarrow> 'a::domain"})
159.157 - , (@{const_name liftdefl}, SOME @{typ "'a::predomain itself \<Rightarrow> defl"})
159.158 - , (@{const_name liftemb}, SOME @{typ "'a::predomain u \<rightarrow> udom"})
159.159 - , (@{const_name liftprj}, SOME @{typ "udom \<rightarrow> 'a::predomain u"}) ]
159.160 -*}
159.161 -
159.162 -use "Tools/domaindef.ML"
159.163 -
159.164 -subsection {* Isomorphic deflations *}
159.165 -
159.166 -definition
159.167 - isodefl :: "('a \<rightarrow> 'a) \<Rightarrow> defl \<Rightarrow> bool"
159.168 -where
159.169 - "isodefl d t \<longleftrightarrow> cast\<cdot>t = emb oo d oo prj"
159.170 -
159.171 -lemma isodeflI: "(\<And>x. cast\<cdot>t\<cdot>x = emb\<cdot>(d\<cdot>(prj\<cdot>x))) \<Longrightarrow> isodefl d t"
159.172 -unfolding isodefl_def by (simp add: cfun_eqI)
159.173 -
159.174 -lemma cast_isodefl: "isodefl d t \<Longrightarrow> cast\<cdot>t = (\<Lambda> x. emb\<cdot>(d\<cdot>(prj\<cdot>x)))"
159.175 -unfolding isodefl_def by (simp add: cfun_eqI)
159.176 -
159.177 -lemma isodefl_strict: "isodefl d t \<Longrightarrow> d\<cdot>\<bottom> = \<bottom>"
159.178 -unfolding isodefl_def
159.179 -by (drule cfun_fun_cong [where x="\<bottom>"], simp)
159.180 -
159.181 -lemma isodefl_imp_deflation:
159.182 - fixes d :: "'a \<rightarrow> 'a"
159.183 - assumes "isodefl d t" shows "deflation d"
159.184 -proof
159.185 - note assms [unfolded isodefl_def, simp]
159.186 - fix x :: 'a
159.187 - show "d\<cdot>(d\<cdot>x) = d\<cdot>x"
159.188 - using cast.idem [of t "emb\<cdot>x"] by simp
159.189 - show "d\<cdot>x \<sqsubseteq> x"
159.190 - using cast.below [of t "emb\<cdot>x"] by simp
159.191 -qed
159.192 -
159.193 -lemma isodefl_ID_DEFL: "isodefl (ID :: 'a \<rightarrow> 'a) DEFL('a)"
159.194 -unfolding isodefl_def by (simp add: cast_DEFL)
159.195 -
159.196 -lemma isodefl_LIFTDEFL:
159.197 - "isodefl (u_map\<cdot>(ID :: 'a \<rightarrow> 'a)) LIFTDEFL('a::predomain)"
159.198 -unfolding u_map_ID DEFL_u [symmetric]
159.199 -by (rule isodefl_ID_DEFL)
159.200 -
159.201 -lemma isodefl_DEFL_imp_ID: "isodefl (d :: 'a \<rightarrow> 'a) DEFL('a) \<Longrightarrow> d = ID"
159.202 -unfolding isodefl_def
159.203 -apply (simp add: cast_DEFL)
159.204 -apply (simp add: cfun_eq_iff)
159.205 -apply (rule allI)
159.206 -apply (drule_tac x="emb\<cdot>x" in spec)
159.207 -apply simp
159.208 -done
159.209 -
159.210 -lemma isodefl_bottom: "isodefl \<bottom> \<bottom>"
159.211 -unfolding isodefl_def by (simp add: cfun_eq_iff)
159.212 -
159.213 -lemma adm_isodefl:
159.214 - "cont f \<Longrightarrow> cont g \<Longrightarrow> adm (\<lambda>x. isodefl (f x) (g x))"
159.215 -unfolding isodefl_def by simp
159.216 -
159.217 -lemma isodefl_lub:
159.218 - assumes "chain d" and "chain t"
159.219 - assumes "\<And>i. isodefl (d i) (t i)"
159.220 - shows "isodefl (\<Squnion>i. d i) (\<Squnion>i. t i)"
159.221 -using prems unfolding isodefl_def
159.222 -by (simp add: contlub_cfun_arg contlub_cfun_fun)
159.223 -
159.224 -lemma isodefl_fix:
159.225 - assumes "\<And>d t. isodefl d t \<Longrightarrow> isodefl (f\<cdot>d) (g\<cdot>t)"
159.226 - shows "isodefl (fix\<cdot>f) (fix\<cdot>g)"
159.227 -unfolding fix_def2
159.228 -apply (rule isodefl_lub, simp, simp)
159.229 -apply (induct_tac i)
159.230 -apply (simp add: isodefl_bottom)
159.231 -apply (simp add: assms)
159.232 -done
159.233 -
159.234 -lemma isodefl_abs_rep:
159.235 - fixes abs and rep and d
159.236 - assumes DEFL: "DEFL('b) = DEFL('a)"
159.237 - assumes abs_def: "(abs :: 'a \<rightarrow> 'b) \<equiv> prj oo emb"
159.238 - assumes rep_def: "(rep :: 'b \<rightarrow> 'a) \<equiv> prj oo emb"
159.239 - shows "isodefl d t \<Longrightarrow> isodefl (abs oo d oo rep) t"
159.240 -unfolding isodefl_def
159.241 -by (simp add: cfun_eq_iff assms prj_emb_prj emb_prj_emb)
159.242 -
159.243 -lemma isodefl_sfun:
159.244 - "isodefl d1 t1 \<Longrightarrow> isodefl d2 t2 \<Longrightarrow>
159.245 - isodefl (sfun_map\<cdot>d1\<cdot>d2) (sfun_defl\<cdot>t1\<cdot>t2)"
159.246 -apply (rule isodeflI)
159.247 -apply (simp add: cast_sfun_defl cast_isodefl)
159.248 -apply (simp add: emb_sfun_def prj_sfun_def)
159.249 -apply (simp add: sfun_map_map isodefl_strict)
159.250 -done
159.251 -
159.252 -lemma isodefl_ssum:
159.253 - "isodefl d1 t1 \<Longrightarrow> isodefl d2 t2 \<Longrightarrow>
159.254 - isodefl (ssum_map\<cdot>d1\<cdot>d2) (ssum_defl\<cdot>t1\<cdot>t2)"
159.255 -apply (rule isodeflI)
159.256 -apply (simp add: cast_ssum_defl cast_isodefl)
159.257 -apply (simp add: emb_ssum_def prj_ssum_def)
159.258 -apply (simp add: ssum_map_map isodefl_strict)
159.259 -done
159.260 -
159.261 -lemma isodefl_sprod:
159.262 - "isodefl d1 t1 \<Longrightarrow> isodefl d2 t2 \<Longrightarrow>
159.263 - isodefl (sprod_map\<cdot>d1\<cdot>d2) (sprod_defl\<cdot>t1\<cdot>t2)"
159.264 -apply (rule isodeflI)
159.265 -apply (simp add: cast_sprod_defl cast_isodefl)
159.266 -apply (simp add: emb_sprod_def prj_sprod_def)
159.267 -apply (simp add: sprod_map_map isodefl_strict)
159.268 -done
159.269 -
159.270 -lemma isodefl_cprod:
159.271 - "isodefl d1 t1 \<Longrightarrow> isodefl d2 t2 \<Longrightarrow>
159.272 - isodefl (cprod_map\<cdot>d1\<cdot>d2) (prod_defl\<cdot>t1\<cdot>t2)"
159.273 -apply (rule isodeflI)
159.274 -apply (simp add: cast_prod_defl cast_isodefl)
159.275 -apply (simp add: emb_prod_def prj_prod_def)
159.276 -apply (simp add: cprod_map_map cfcomp1)
159.277 -done
159.278 -
159.279 -lemma isodefl_u:
159.280 - fixes d :: "'a::liftdomain \<rightarrow> 'a"
159.281 - shows "isodefl (d :: 'a \<rightarrow> 'a) t \<Longrightarrow> isodefl (u_map\<cdot>d) (u_defl\<cdot>t)"
159.282 -apply (rule isodeflI)
159.283 -apply (simp add: cast_u_defl cast_isodefl)
159.284 -apply (simp add: emb_u_def prj_u_def liftemb_eq liftprj_eq)
159.285 -apply (simp add: u_map_map)
159.286 -done
159.287 -
159.288 -lemma encode_prod_u_map:
159.289 - "encode_prod_u\<cdot>(u_map\<cdot>(cprod_map\<cdot>f\<cdot>g)\<cdot>(decode_prod_u\<cdot>x))
159.290 - = sprod_map\<cdot>(u_map\<cdot>f)\<cdot>(u_map\<cdot>g)\<cdot>x"
159.291 -unfolding encode_prod_u_def decode_prod_u_def
159.292 -apply (case_tac x, simp, rename_tac a b)
159.293 -apply (case_tac a, simp, case_tac b, simp, simp)
159.294 -done
159.295 -
159.296 -lemma isodefl_cprod_u:
159.297 - assumes "isodefl (u_map\<cdot>d1) t1" and "isodefl (u_map\<cdot>d2) t2"
159.298 - shows "isodefl (u_map\<cdot>(cprod_map\<cdot>d1\<cdot>d2)) (sprod_defl\<cdot>t1\<cdot>t2)"
159.299 -using assms unfolding isodefl_def
159.300 -apply (simp add: emb_u_def prj_u_def liftemb_prod_def liftprj_prod_def)
159.301 -apply (simp add: emb_u_def [symmetric] prj_u_def [symmetric])
159.302 -apply (simp add: cfcomp1 encode_prod_u_map cast_sprod_defl sprod_map_map)
159.303 -done
159.304 -
159.305 -lemma encode_cfun_map:
159.306 - "encode_cfun\<cdot>(cfun_map\<cdot>f\<cdot>g\<cdot>(decode_cfun\<cdot>x))
159.307 - = sfun_map\<cdot>(u_map\<cdot>f)\<cdot>g\<cdot>x"
159.308 -unfolding encode_cfun_def decode_cfun_def
159.309 -apply (simp add: sfun_eq_iff cfun_map_def sfun_map_def)
159.310 -apply (rule cfun_eqI, rename_tac y, case_tac y, simp_all)
159.311 -done
159.312 -
159.313 -lemma isodefl_cfun:
159.314 - "isodefl (u_map\<cdot>d1) t1 \<Longrightarrow> isodefl d2 t2 \<Longrightarrow>
159.315 - isodefl (cfun_map\<cdot>d1\<cdot>d2) (sfun_defl\<cdot>t1\<cdot>t2)"
159.316 -apply (rule isodeflI)
159.317 -apply (simp add: cast_sfun_defl cast_isodefl)
159.318 -apply (simp add: emb_cfun_def prj_cfun_def encode_cfun_map)
159.319 -apply (simp add: sfun_map_map isodefl_strict)
159.320 -done
159.321 -
159.322 -subsection {* Setting up the domain package *}
159.323 -
159.324 -use "Tools/Domain/domain_isomorphism.ML"
159.325 -use "Tools/Domain/domain_axioms.ML"
159.326 -use "Tools/Domain/domain.ML"
159.327 -
159.328 -setup Domain_Isomorphism.setup
159.329 -
159.330 -lemmas [domain_defl_simps] =
159.331 - DEFL_cfun DEFL_sfun DEFL_ssum DEFL_sprod DEFL_prod DEFL_u
159.332 - liftdefl_eq LIFTDEFL_prod
159.333 -
159.334 -lemmas [domain_map_ID] =
159.335 - cfun_map_ID sfun_map_ID ssum_map_ID sprod_map_ID cprod_map_ID u_map_ID
159.336 -
159.337 -lemmas [domain_isodefl] =
159.338 - isodefl_u isodefl_sfun isodefl_ssum isodefl_sprod
159.339 - isodefl_cfun isodefl_cprod isodefl_cprod_u
159.340 -
159.341 -lemmas [domain_deflation] =
159.342 - deflation_cfun_map deflation_sfun_map deflation_ssum_map
159.343 - deflation_sprod_map deflation_cprod_map deflation_u_map
159.344 -
159.345 -setup {*
159.346 - fold Domain_Take_Proofs.add_rec_type
159.347 - [(@{type_name cfun}, [true, true]),
159.348 - (@{type_name "sfun"}, [true, true]),
159.349 - (@{type_name ssum}, [true, true]),
159.350 - (@{type_name sprod}, [true, true]),
159.351 - (@{type_name prod}, [true, true]),
159.352 - (@{type_name "u"}, [true])]
159.353 -*}
159.354 -
159.355 -end
160.1 --- a/src/HOLCF/Domain_Aux.thy Sat Nov 27 14:34:54 2010 -0800
160.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
160.3 @@ -1,361 +0,0 @@
160.4 -(* Title: HOLCF/Domain_Aux.thy
160.5 - Author: Brian Huffman
160.6 -*)
160.7 -
160.8 -header {* Domain package support *}
160.9 -
160.10 -theory Domain_Aux
160.11 -imports Map_Functions Fixrec
160.12 -uses
160.13 - ("Tools/Domain/domain_take_proofs.ML")
160.14 - ("Tools/cont_consts.ML")
160.15 - ("Tools/cont_proc.ML")
160.16 - ("Tools/Domain/domain_constructors.ML")
160.17 - ("Tools/Domain/domain_induction.ML")
160.18 -begin
160.19 -
160.20 -subsection {* Continuous isomorphisms *}
160.21 -
160.22 -text {* A locale for continuous isomorphisms *}
160.23 -
160.24 -locale iso =
160.25 - fixes abs :: "'a \<rightarrow> 'b"
160.26 - fixes rep :: "'b \<rightarrow> 'a"
160.27 - assumes abs_iso [simp]: "rep\<cdot>(abs\<cdot>x) = x"
160.28 - assumes rep_iso [simp]: "abs\<cdot>(rep\<cdot>y) = y"
160.29 -begin
160.30 -
160.31 -lemma swap: "iso rep abs"
160.32 - by (rule iso.intro [OF rep_iso abs_iso])
160.33 -
160.34 -lemma abs_below: "(abs\<cdot>x \<sqsubseteq> abs\<cdot>y) = (x \<sqsubseteq> y)"
160.35 -proof
160.36 - assume "abs\<cdot>x \<sqsubseteq> abs\<cdot>y"
160.37 - then have "rep\<cdot>(abs\<cdot>x) \<sqsubseteq> rep\<cdot>(abs\<cdot>y)" by (rule monofun_cfun_arg)
160.38 - then show "x \<sqsubseteq> y" by simp
160.39 -next
160.40 - assume "x \<sqsubseteq> y"
160.41 - then show "abs\<cdot>x \<sqsubseteq> abs\<cdot>y" by (rule monofun_cfun_arg)
160.42 -qed
160.43 -
160.44 -lemma rep_below: "(rep\<cdot>x \<sqsubseteq> rep\<cdot>y) = (x \<sqsubseteq> y)"
160.45 - by (rule iso.abs_below [OF swap])
160.46 -
160.47 -lemma abs_eq: "(abs\<cdot>x = abs\<cdot>y) = (x = y)"
160.48 - by (simp add: po_eq_conv abs_below)
160.49 -
160.50 -lemma rep_eq: "(rep\<cdot>x = rep\<cdot>y) = (x = y)"
160.51 - by (rule iso.abs_eq [OF swap])
160.52 -
160.53 -lemma abs_strict: "abs\<cdot>\<bottom> = \<bottom>"
160.54 -proof -
160.55 - have "\<bottom> \<sqsubseteq> rep\<cdot>\<bottom>" ..
160.56 - then have "abs\<cdot>\<bottom> \<sqsubseteq> abs\<cdot>(rep\<cdot>\<bottom>)" by (rule monofun_cfun_arg)
160.57 - then have "abs\<cdot>\<bottom> \<sqsubseteq> \<bottom>" by simp
160.58 - then show ?thesis by (rule UU_I)
160.59 -qed
160.60 -
160.61 -lemma rep_strict: "rep\<cdot>\<bottom> = \<bottom>"
160.62 - by (rule iso.abs_strict [OF swap])
160.63 -
160.64 -lemma abs_defin': "abs\<cdot>x = \<bottom> \<Longrightarrow> x = \<bottom>"
160.65 -proof -
160.66 - have "x = rep\<cdot>(abs\<cdot>x)" by simp
160.67 - also assume "abs\<cdot>x = \<bottom>"
160.68 - also note rep_strict
160.69 - finally show "x = \<bottom>" .
160.70 -qed
160.71 -
160.72 -lemma rep_defin': "rep\<cdot>z = \<bottom> \<Longrightarrow> z = \<bottom>"
160.73 - by (rule iso.abs_defin' [OF swap])
160.74 -
160.75 -lemma abs_defined: "z \<noteq> \<bottom> \<Longrightarrow> abs\<cdot>z \<noteq> \<bottom>"
160.76 - by (erule contrapos_nn, erule abs_defin')
160.77 -
160.78 -lemma rep_defined: "z \<noteq> \<bottom> \<Longrightarrow> rep\<cdot>z \<noteq> \<bottom>"
160.79 - by (rule iso.abs_defined [OF iso.swap]) (rule iso_axioms)
160.80 -
160.81 -lemma abs_bottom_iff: "(abs\<cdot>x = \<bottom>) = (x = \<bottom>)"
160.82 - by (auto elim: abs_defin' intro: abs_strict)
160.83 -
160.84 -lemma rep_bottom_iff: "(rep\<cdot>x = \<bottom>) = (x = \<bottom>)"
160.85 - by (rule iso.abs_bottom_iff [OF iso.swap]) (rule iso_axioms)
160.86 -
160.87 -lemma casedist_rule: "rep\<cdot>x = \<bottom> \<or> P \<Longrightarrow> x = \<bottom> \<or> P"
160.88 - by (simp add: rep_bottom_iff)
160.89 -
160.90 -lemma compact_abs_rev: "compact (abs\<cdot>x) \<Longrightarrow> compact x"
160.91 -proof (unfold compact_def)
160.92 - assume "adm (\<lambda>y. \<not> abs\<cdot>x \<sqsubseteq> y)"
160.93 - with cont_Rep_cfun2
160.94 - have "adm (\<lambda>y. \<not> abs\<cdot>x \<sqsubseteq> abs\<cdot>y)" by (rule adm_subst)
160.95 - then show "adm (\<lambda>y. \<not> x \<sqsubseteq> y)" using abs_below by simp
160.96 -qed
160.97 -
160.98 -lemma compact_rep_rev: "compact (rep\<cdot>x) \<Longrightarrow> compact x"
160.99 - by (rule iso.compact_abs_rev [OF iso.swap]) (rule iso_axioms)
160.100 -
160.101 -lemma compact_abs: "compact x \<Longrightarrow> compact (abs\<cdot>x)"
160.102 - by (rule compact_rep_rev) simp
160.103 -
160.104 -lemma compact_rep: "compact x \<Longrightarrow> compact (rep\<cdot>x)"
160.105 - by (rule iso.compact_abs [OF iso.swap]) (rule iso_axioms)
160.106 -
160.107 -lemma iso_swap: "(x = abs\<cdot>y) = (rep\<cdot>x = y)"
160.108 -proof
160.109 - assume "x = abs\<cdot>y"
160.110 - then have "rep\<cdot>x = rep\<cdot>(abs\<cdot>y)" by simp
160.111 - then show "rep\<cdot>x = y" by simp
160.112 -next
160.113 - assume "rep\<cdot>x = y"
160.114 - then have "abs\<cdot>(rep\<cdot>x) = abs\<cdot>y" by simp
160.115 - then show "x = abs\<cdot>y" by simp
160.116 -qed
160.117 -
160.118 -end
160.119 -
160.120 -subsection {* Proofs about take functions *}
160.121 -
160.122 -text {*
160.123 - This section contains lemmas that are used in a module that supports
160.124 - the domain isomorphism package; the module contains proofs related
160.125 - to take functions and the finiteness predicate.
160.126 -*}
160.127 -
160.128 -lemma deflation_abs_rep:
160.129 - fixes abs and rep and d
160.130 - assumes abs_iso: "\<And>x. rep\<cdot>(abs\<cdot>x) = x"
160.131 - assumes rep_iso: "\<And>y. abs\<cdot>(rep\<cdot>y) = y"
160.132 - shows "deflation d \<Longrightarrow> deflation (abs oo d oo rep)"
160.133 -by (rule ep_pair.deflation_e_d_p) (simp add: ep_pair.intro assms)
160.134 -
160.135 -lemma deflation_chain_min:
160.136 - assumes chain: "chain d"
160.137 - assumes defl: "\<And>n. deflation (d n)"
160.138 - shows "d m\<cdot>(d n\<cdot>x) = d (min m n)\<cdot>x"
160.139 -proof (rule linorder_le_cases)
160.140 - assume "m \<le> n"
160.141 - with chain have "d m \<sqsubseteq> d n" by (rule chain_mono)
160.142 - then have "d m\<cdot>(d n\<cdot>x) = d m\<cdot>x"
160.143 - by (rule deflation_below_comp1 [OF defl defl])
160.144 - moreover from `m \<le> n` have "min m n = m" by simp
160.145 - ultimately show ?thesis by simp
160.146 -next
160.147 - assume "n \<le> m"
160.148 - with chain have "d n \<sqsubseteq> d m" by (rule chain_mono)
160.149 - then have "d m\<cdot>(d n\<cdot>x) = d n\<cdot>x"
160.150 - by (rule deflation_below_comp2 [OF defl defl])
160.151 - moreover from `n \<le> m` have "min m n = n" by simp
160.152 - ultimately show ?thesis by simp
160.153 -qed
160.154 -
160.155 -lemma lub_ID_take_lemma:
160.156 - assumes "chain t" and "(\<Squnion>n. t n) = ID"
160.157 - assumes "\<And>n. t n\<cdot>x = t n\<cdot>y" shows "x = y"
160.158 -proof -
160.159 - have "(\<Squnion>n. t n\<cdot>x) = (\<Squnion>n. t n\<cdot>y)"
160.160 - using assms(3) by simp
160.161 - then have "(\<Squnion>n. t n)\<cdot>x = (\<Squnion>n. t n)\<cdot>y"
160.162 - using assms(1) by (simp add: lub_distribs)
160.163 - then show "x = y"
160.164 - using assms(2) by simp
160.165 -qed
160.166 -
160.167 -lemma lub_ID_reach:
160.168 - assumes "chain t" and "(\<Squnion>n. t n) = ID"
160.169 - shows "(\<Squnion>n. t n\<cdot>x) = x"
160.170 -using assms by (simp add: lub_distribs)
160.171 -
160.172 -lemma lub_ID_take_induct:
160.173 - assumes "chain t" and "(\<Squnion>n. t n) = ID"
160.174 - assumes "adm P" and "\<And>n. P (t n\<cdot>x)" shows "P x"
160.175 -proof -
160.176 - from `chain t` have "chain (\<lambda>n. t n\<cdot>x)" by simp
160.177 - from `adm P` this `\<And>n. P (t n\<cdot>x)` have "P (\<Squnion>n. t n\<cdot>x)" by (rule admD)
160.178 - with `chain t` `(\<Squnion>n. t n) = ID` show "P x" by (simp add: lub_distribs)
160.179 -qed
160.180 -
160.181 -subsection {* Finiteness *}
160.182 -
160.183 -text {*
160.184 - Let a ``decisive'' function be a deflation that maps every input to
160.185 - either itself or bottom. Then if a domain's take functions are all
160.186 - decisive, then all values in the domain are finite.
160.187 -*}
160.188 -
160.189 -definition
160.190 - decisive :: "('a::pcpo \<rightarrow> 'a) \<Rightarrow> bool"
160.191 -where
160.192 - "decisive d \<longleftrightarrow> (\<forall>x. d\<cdot>x = x \<or> d\<cdot>x = \<bottom>)"
160.193 -
160.194 -lemma decisiveI: "(\<And>x. d\<cdot>x = x \<or> d\<cdot>x = \<bottom>) \<Longrightarrow> decisive d"
160.195 - unfolding decisive_def by simp
160.196 -
160.197 -lemma decisive_cases:
160.198 - assumes "decisive d" obtains "d\<cdot>x = x" | "d\<cdot>x = \<bottom>"
160.199 -using assms unfolding decisive_def by auto
160.200 -
160.201 -lemma decisive_bottom: "decisive \<bottom>"
160.202 - unfolding decisive_def by simp
160.203 -
160.204 -lemma decisive_ID: "decisive ID"
160.205 - unfolding decisive_def by simp
160.206 -
160.207 -lemma decisive_ssum_map:
160.208 - assumes f: "decisive f"
160.209 - assumes g: "decisive g"
160.210 - shows "decisive (ssum_map\<cdot>f\<cdot>g)"
160.211 -apply (rule decisiveI, rename_tac s)
160.212 -apply (case_tac s, simp_all)
160.213 -apply (rule_tac x=x in decisive_cases [OF f], simp_all)
160.214 -apply (rule_tac x=y in decisive_cases [OF g], simp_all)
160.215 -done
160.216 -
160.217 -lemma decisive_sprod_map:
160.218 - assumes f: "decisive f"
160.219 - assumes g: "decisive g"
160.220 - shows "decisive (sprod_map\<cdot>f\<cdot>g)"
160.221 -apply (rule decisiveI, rename_tac s)
160.222 -apply (case_tac s, simp_all)
160.223 -apply (rule_tac x=x in decisive_cases [OF f], simp_all)
160.224 -apply (rule_tac x=y in decisive_cases [OF g], simp_all)
160.225 -done
160.226 -
160.227 -lemma decisive_abs_rep:
160.228 - fixes abs rep
160.229 - assumes iso: "iso abs rep"
160.230 - assumes d: "decisive d"
160.231 - shows "decisive (abs oo d oo rep)"
160.232 -apply (rule decisiveI)
160.233 -apply (rule_tac x="rep\<cdot>x" in decisive_cases [OF d])
160.234 -apply (simp add: iso.rep_iso [OF iso])
160.235 -apply (simp add: iso.abs_strict [OF iso])
160.236 -done
160.237 -
160.238 -lemma lub_ID_finite:
160.239 - assumes chain: "chain d"
160.240 - assumes lub: "(\<Squnion>n. d n) = ID"
160.241 - assumes decisive: "\<And>n. decisive (d n)"
160.242 - shows "\<exists>n. d n\<cdot>x = x"
160.243 -proof -
160.244 - have 1: "chain (\<lambda>n. d n\<cdot>x)" using chain by simp
160.245 - have 2: "(\<Squnion>n. d n\<cdot>x) = x" using chain lub by (rule lub_ID_reach)
160.246 - have "\<forall>n. d n\<cdot>x = x \<or> d n\<cdot>x = \<bottom>"
160.247 - using decisive unfolding decisive_def by simp
160.248 - hence "range (\<lambda>n. d n\<cdot>x) \<subseteq> {x, \<bottom>}"
160.249 - by auto
160.250 - hence "finite (range (\<lambda>n. d n\<cdot>x))"
160.251 - by (rule finite_subset, simp)
160.252 - with 1 have "finite_chain (\<lambda>n. d n\<cdot>x)"
160.253 - by (rule finite_range_imp_finch)
160.254 - then have "\<exists>n. (\<Squnion>n. d n\<cdot>x) = d n\<cdot>x"
160.255 - unfolding finite_chain_def by (auto simp add: maxinch_is_thelub)
160.256 - with 2 show "\<exists>n. d n\<cdot>x = x" by (auto elim: sym)
160.257 -qed
160.258 -
160.259 -lemma lub_ID_finite_take_induct:
160.260 - assumes "chain d" and "(\<Squnion>n. d n) = ID" and "\<And>n. decisive (d n)"
160.261 - shows "(\<And>n. P (d n\<cdot>x)) \<Longrightarrow> P x"
160.262 -using lub_ID_finite [OF assms] by metis
160.263 -
160.264 -subsection {* Proofs about constructor functions *}
160.265 -
160.266 -text {* Lemmas for proving nchotomy rule: *}
160.267 -
160.268 -lemma ex_one_bottom_iff:
160.269 - "(\<exists>x. P x \<and> x \<noteq> \<bottom>) = P ONE"
160.270 -by simp
160.271 -
160.272 -lemma ex_up_bottom_iff:
160.273 - "(\<exists>x. P x \<and> x \<noteq> \<bottom>) = (\<exists>x. P (up\<cdot>x))"
160.274 -by (safe, case_tac x, auto)
160.275 -
160.276 -lemma ex_sprod_bottom_iff:
160.277 - "(\<exists>y. P y \<and> y \<noteq> \<bottom>) =
160.278 - (\<exists>x y. (P (:x, y:) \<and> x \<noteq> \<bottom>) \<and> y \<noteq> \<bottom>)"
160.279 -by (safe, case_tac y, auto)
160.280 -
160.281 -lemma ex_sprod_up_bottom_iff:
160.282 - "(\<exists>y. P y \<and> y \<noteq> \<bottom>) =
160.283 - (\<exists>x y. P (:up\<cdot>x, y:) \<and> y \<noteq> \<bottom>)"
160.284 -by (safe, case_tac y, simp, case_tac x, auto)
160.285 -
160.286 -lemma ex_ssum_bottom_iff:
160.287 - "(\<exists>x. P x \<and> x \<noteq> \<bottom>) =
160.288 - ((\<exists>x. P (sinl\<cdot>x) \<and> x \<noteq> \<bottom>) \<or>
160.289 - (\<exists>x. P (sinr\<cdot>x) \<and> x \<noteq> \<bottom>))"
160.290 -by (safe, case_tac x, auto)
160.291 -
160.292 -lemma exh_start: "p = \<bottom> \<or> (\<exists>x. p = x \<and> x \<noteq> \<bottom>)"
160.293 - by auto
160.294 -
160.295 -lemmas ex_bottom_iffs =
160.296 - ex_ssum_bottom_iff
160.297 - ex_sprod_up_bottom_iff
160.298 - ex_sprod_bottom_iff
160.299 - ex_up_bottom_iff
160.300 - ex_one_bottom_iff
160.301 -
160.302 -text {* Rules for turning nchotomy into exhaust: *}
160.303 -
160.304 -lemma exh_casedist0: "\<lbrakk>R; R \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P" (* like make_elim *)
160.305 - by auto
160.306 -
160.307 -lemma exh_casedist1: "((P \<or> Q \<Longrightarrow> R) \<Longrightarrow> S) \<equiv> (\<lbrakk>P \<Longrightarrow> R; Q \<Longrightarrow> R\<rbrakk> \<Longrightarrow> S)"
160.308 - by rule auto
160.309 -
160.310 -lemma exh_casedist2: "(\<exists>x. P x \<Longrightarrow> Q) \<equiv> (\<And>x. P x \<Longrightarrow> Q)"
160.311 - by rule auto
160.312 -
160.313 -lemma exh_casedist3: "(P \<and> Q \<Longrightarrow> R) \<equiv> (P \<Longrightarrow> Q \<Longrightarrow> R)"
160.314 - by rule auto
160.315 -
160.316 -lemmas exh_casedists = exh_casedist1 exh_casedist2 exh_casedist3
160.317 -
160.318 -text {* Rules for proving constructor properties *}
160.319 -
160.320 -lemmas con_strict_rules =
160.321 - sinl_strict sinr_strict spair_strict1 spair_strict2
160.322 -
160.323 -lemmas con_bottom_iff_rules =
160.324 - sinl_bottom_iff sinr_bottom_iff spair_bottom_iff up_defined ONE_defined
160.325 -
160.326 -lemmas con_below_iff_rules =
160.327 - sinl_below sinr_below sinl_below_sinr sinr_below_sinl con_bottom_iff_rules
160.328 -
160.329 -lemmas con_eq_iff_rules =
160.330 - sinl_eq sinr_eq sinl_eq_sinr sinr_eq_sinl con_bottom_iff_rules
160.331 -
160.332 -lemmas sel_strict_rules =
160.333 - cfcomp2 sscase1 sfst_strict ssnd_strict fup1
160.334 -
160.335 -lemma sel_app_extra_rules:
160.336 - "sscase\<cdot>ID\<cdot>\<bottom>\<cdot>(sinr\<cdot>x) = \<bottom>"
160.337 - "sscase\<cdot>ID\<cdot>\<bottom>\<cdot>(sinl\<cdot>x) = x"
160.338 - "sscase\<cdot>\<bottom>\<cdot>ID\<cdot>(sinl\<cdot>x) = \<bottom>"
160.339 - "sscase\<cdot>\<bottom>\<cdot>ID\<cdot>(sinr\<cdot>x) = x"
160.340 - "fup\<cdot>ID\<cdot>(up\<cdot>x) = x"
160.341 -by (cases "x = \<bottom>", simp, simp)+
160.342 -
160.343 -lemmas sel_app_rules =
160.344 - sel_strict_rules sel_app_extra_rules
160.345 - ssnd_spair sfst_spair up_defined spair_defined
160.346 -
160.347 -lemmas sel_bottom_iff_rules =
160.348 - cfcomp2 sfst_bottom_iff ssnd_bottom_iff
160.349 -
160.350 -lemmas take_con_rules =
160.351 - ssum_map_sinl' ssum_map_sinr' sprod_map_spair' u_map_up
160.352 - deflation_strict deflation_ID ID1 cfcomp2
160.353 -
160.354 -subsection {* ML setup *}
160.355 -
160.356 -use "Tools/Domain/domain_take_proofs.ML"
160.357 -use "Tools/cont_consts.ML"
160.358 -use "Tools/cont_proc.ML"
160.359 -use "Tools/Domain/domain_constructors.ML"
160.360 -use "Tools/Domain/domain_induction.ML"
160.361 -
160.362 -setup Domain_Take_Proofs.setup
160.363 -
160.364 -end
161.1 --- a/src/HOLCF/FOCUS/Buffer.thy Sat Nov 27 14:34:54 2010 -0800
161.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
161.3 @@ -1,381 +0,0 @@
161.4 -(* Title: HOLCF/FOCUS/Buffer.thy
161.5 - Author: David von Oheimb, TU Muenchen
161.6 -
161.7 -Formalization of section 4 of
161.8 -
161.9 -@inproceedings {broy_mod94,
161.10 - author = {Manfred Broy},
161.11 - title = {{Specification and Refinement of a Buffer of Length One}},
161.12 - booktitle = {Deductive Program Design},
161.13 - year = {1994},
161.14 - editor = {Manfred Broy},
161.15 - volume = {152},
161.16 - series = {ASI Series, Series F: Computer and System Sciences},
161.17 - pages = {273 -- 304},
161.18 - publisher = {Springer}
161.19 -}
161.20 -
161.21 -Slides available from http://ddvo.net/talks/1-Buffer.ps.gz
161.22 -
161.23 -*)
161.24 -
161.25 -theory Buffer
161.26 -imports FOCUS
161.27 -begin
161.28 -
161.29 -typedecl D
161.30 -
161.31 -datatype
161.32 -
161.33 - M = Md D | Mreq ("\<bullet>")
161.34 -
161.35 -datatype
161.36 -
161.37 - State = Sd D | Snil ("\<currency>")
161.38 -
161.39 -types
161.40 -
161.41 - SPF11 = "M fstream \<rightarrow> D fstream"
161.42 - SPEC11 = "SPF11 set"
161.43 - SPSF11 = "State \<Rightarrow> SPF11"
161.44 - SPECS11 = "SPSF11 set"
161.45 -
161.46 -definition
161.47 - BufEq_F :: "SPEC11 \<Rightarrow> SPEC11" where
161.48 - "BufEq_F B = {f. \<forall>d. f\<cdot>(Md d\<leadsto><>) = <> \<and>
161.49 - (\<forall>x. \<exists>ff\<in>B. f\<cdot>(Md d\<leadsto>\<bullet>\<leadsto>x) = d\<leadsto>ff\<cdot>x)}"
161.50 -
161.51 -definition
161.52 - BufEq :: "SPEC11" where
161.53 - "BufEq = gfp BufEq_F"
161.54 -
161.55 -definition
161.56 - BufEq_alt :: "SPEC11" where
161.57 - "BufEq_alt = gfp (\<lambda>B. {f. \<forall>d. f\<cdot>(Md d\<leadsto><> ) = <> \<and>
161.58 - (\<exists>ff\<in>B. (\<forall>x. f\<cdot>(Md d\<leadsto>\<bullet>\<leadsto>x) = d\<leadsto>ff\<cdot>x))})"
161.59 -
161.60 -definition
161.61 - BufAC_Asm_F :: " (M fstream set) \<Rightarrow> (M fstream set)" where
161.62 - "BufAC_Asm_F A = {s. s = <> \<or>
161.63 - (\<exists>d x. s = Md d\<leadsto>x \<and> (x = <> \<or> (ft\<cdot>x = Def \<bullet> \<and> (rt\<cdot>x)\<in>A)))}"
161.64 -
161.65 -definition
161.66 - BufAC_Asm :: " (M fstream set)" where
161.67 - "BufAC_Asm = gfp BufAC_Asm_F"
161.68 -
161.69 -definition
161.70 - BufAC_Cmt_F :: "((M fstream * D fstream) set) \<Rightarrow>
161.71 - ((M fstream * D fstream) set)" where
161.72 - "BufAC_Cmt_F C = {(s,t). \<forall>d x.
161.73 - (s = <> \<longrightarrow> t = <> ) \<and>
161.74 - (s = Md d\<leadsto><> \<longrightarrow> t = <> ) \<and>
161.75 - (s = Md d\<leadsto>\<bullet>\<leadsto>x \<longrightarrow> (ft\<cdot>t = Def d \<and> (x,rt\<cdot>t)\<in>C))}"
161.76 -
161.77 -definition
161.78 - BufAC_Cmt :: "((M fstream * D fstream) set)" where
161.79 - "BufAC_Cmt = gfp BufAC_Cmt_F"
161.80 -
161.81 -definition
161.82 - BufAC :: "SPEC11" where
161.83 - "BufAC = {f. \<forall>x. x\<in>BufAC_Asm \<longrightarrow> (x,f\<cdot>x)\<in>BufAC_Cmt}"
161.84 -
161.85 -definition
161.86 - BufSt_F :: "SPECS11 \<Rightarrow> SPECS11" where
161.87 - "BufSt_F H = {h. \<forall>s . h s \<cdot><> = <> \<and>
161.88 - (\<forall>d x. h \<currency> \<cdot>(Md d\<leadsto>x) = h (Sd d)\<cdot>x \<and>
161.89 - (\<exists>hh\<in>H. h (Sd d)\<cdot>(\<bullet> \<leadsto>x) = d\<leadsto>(hh \<currency>\<cdot>x)))}"
161.90 -
161.91 -definition
161.92 - BufSt_P :: "SPECS11" where
161.93 - "BufSt_P = gfp BufSt_F"
161.94 -
161.95 -definition
161.96 - BufSt :: "SPEC11" where
161.97 - "BufSt = {f. \<exists>h\<in>BufSt_P. f = h \<currency>}"
161.98 -
161.99 -
161.100 -lemma set_cong: "!!X. A = B ==> (x:A) = (x:B)"
161.101 -by (erule subst, rule refl)
161.102 -
161.103 -
161.104 -(**** BufEq *******************************************************************)
161.105 -
161.106 -lemma mono_BufEq_F: "mono BufEq_F"
161.107 -by (unfold mono_def BufEq_F_def, fast)
161.108 -
161.109 -lemmas BufEq_fix = mono_BufEq_F [THEN BufEq_def [THEN eq_reflection, THEN def_gfp_unfold]]
161.110 -
161.111 -lemma BufEq_unfold: "(f:BufEq) = (!d. f\<cdot>(Md d\<leadsto><>) = <> &
161.112 - (!x. ? ff:BufEq. f\<cdot>(Md d\<leadsto>\<bullet>\<leadsto>x) = d\<leadsto>(ff\<cdot>x)))"
161.113 -apply (subst BufEq_fix [THEN set_cong])
161.114 -apply (unfold BufEq_F_def)
161.115 -apply (simp)
161.116 -done
161.117 -
161.118 -lemma Buf_f_empty: "f:BufEq \<Longrightarrow> f\<cdot><> = <>"
161.119 -by (drule BufEq_unfold [THEN iffD1], auto)
161.120 -
161.121 -lemma Buf_f_d: "f:BufEq \<Longrightarrow> f\<cdot>(Md d\<leadsto><>) = <>"
161.122 -by (drule BufEq_unfold [THEN iffD1], auto)
161.123 -
161.124 -lemma Buf_f_d_req:
161.125 - "f:BufEq \<Longrightarrow> \<exists>ff. ff:BufEq \<and> f\<cdot>(Md d\<leadsto>\<bullet>\<leadsto>x) = d\<leadsto>ff\<cdot>x"
161.126 -by (drule BufEq_unfold [THEN iffD1], auto)
161.127 -
161.128 -
161.129 -(**** BufAC_Asm ***************************************************************)
161.130 -
161.131 -lemma mono_BufAC_Asm_F: "mono BufAC_Asm_F"
161.132 -by (unfold mono_def BufAC_Asm_F_def, fast)
161.133 -
161.134 -lemmas BufAC_Asm_fix =
161.135 - mono_BufAC_Asm_F [THEN BufAC_Asm_def [THEN eq_reflection, THEN def_gfp_unfold]]
161.136 -
161.137 -lemma BufAC_Asm_unfold: "(s:BufAC_Asm) = (s = <> | (? d x.
161.138 - s = Md d\<leadsto>x & (x = <> | (ft\<cdot>x = Def \<bullet> & (rt\<cdot>x):BufAC_Asm))))"
161.139 -apply (subst BufAC_Asm_fix [THEN set_cong])
161.140 -apply (unfold BufAC_Asm_F_def)
161.141 -apply (simp)
161.142 -done
161.143 -
161.144 -lemma BufAC_Asm_empty: "<> :BufAC_Asm"
161.145 -by (rule BufAC_Asm_unfold [THEN iffD2], auto)
161.146 -
161.147 -lemma BufAC_Asm_d: "Md d\<leadsto><>:BufAC_Asm"
161.148 -by (rule BufAC_Asm_unfold [THEN iffD2], auto)
161.149 -lemma BufAC_Asm_d_req: "x:BufAC_Asm ==> Md d\<leadsto>\<bullet>\<leadsto>x:BufAC_Asm"
161.150 -by (rule BufAC_Asm_unfold [THEN iffD2], auto)
161.151 -lemma BufAC_Asm_prefix2: "a\<leadsto>b\<leadsto>s:BufAC_Asm ==> s:BufAC_Asm"
161.152 -by (drule BufAC_Asm_unfold [THEN iffD1], auto)
161.153 -
161.154 -
161.155 -(**** BBufAC_Cmt **************************************************************)
161.156 -
161.157 -lemma mono_BufAC_Cmt_F: "mono BufAC_Cmt_F"
161.158 -by (unfold mono_def BufAC_Cmt_F_def, fast)
161.159 -
161.160 -lemmas BufAC_Cmt_fix =
161.161 - mono_BufAC_Cmt_F [THEN BufAC_Cmt_def [THEN eq_reflection, THEN def_gfp_unfold]]
161.162 -
161.163 -lemma BufAC_Cmt_unfold: "((s,t):BufAC_Cmt) = (!d x.
161.164 - (s = <> --> t = <>) &
161.165 - (s = Md d\<leadsto><> --> t = <>) &
161.166 - (s = Md d\<leadsto>\<bullet>\<leadsto>x --> ft\<cdot>t = Def d & (x, rt\<cdot>t):BufAC_Cmt))"
161.167 -apply (subst BufAC_Cmt_fix [THEN set_cong])
161.168 -apply (unfold BufAC_Cmt_F_def)
161.169 -apply (simp)
161.170 -done
161.171 -
161.172 -lemma BufAC_Cmt_empty: "f:BufEq ==> (<>, f\<cdot><>):BufAC_Cmt"
161.173 -by (rule BufAC_Cmt_unfold [THEN iffD2], auto simp add: Buf_f_empty)
161.174 -
161.175 -lemma BufAC_Cmt_d: "f:BufEq ==> (a\<leadsto>\<bottom>, f\<cdot>(a\<leadsto>\<bottom>)):BufAC_Cmt"
161.176 -by (rule BufAC_Cmt_unfold [THEN iffD2], auto simp add: Buf_f_d)
161.177 -
161.178 -lemma BufAC_Cmt_d2:
161.179 - "(Md d\<leadsto>\<bottom>, f\<cdot>(Md d\<leadsto>\<bottom>)):BufAC_Cmt ==> f\<cdot>(Md d\<leadsto>\<bottom>) = \<bottom>"
161.180 -by (drule BufAC_Cmt_unfold [THEN iffD1], auto)
161.181 -
161.182 -lemma BufAC_Cmt_d3:
161.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"
161.184 -by (drule BufAC_Cmt_unfold [THEN iffD1], auto)
161.185 -
161.186 -lemma BufAC_Cmt_d32:
161.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"
161.188 -by (drule BufAC_Cmt_unfold [THEN iffD1], auto)
161.189 -
161.190 -(**** BufAC *******************************************************************)
161.191 -
161.192 -lemma BufAC_f_d: "f \<in> BufAC \<Longrightarrow> f\<cdot>(Md d\<leadsto>\<bottom>) = \<bottom>"
161.193 -apply (unfold BufAC_def)
161.194 -apply (fast intro: BufAC_Cmt_d2 BufAC_Asm_d)
161.195 -done
161.196 -
161.197 -lemma ex_elim_lemma: "(? ff:B. (!x. f\<cdot>(a\<leadsto>b\<leadsto>x) = d\<leadsto>ff\<cdot>x)) =
161.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)"
161.199 -(* this is an instance (though unification cannot handle this) of
161.200 -lemma "(? ff:B. (!x. f\<cdot>x = d\<leadsto>ff\<cdot>x)) = \
161.201 - \((!x. ft\<cdot>(f\<cdot>x) = Def d) & (LAM x. rt\<cdot>(f\<cdot>x)):B)"*)
161.202 -apply safe
161.203 -apply ( rule_tac [2] P="(%x. x:B)" in ssubst)
161.204 -prefer 3
161.205 -apply ( assumption)
161.206 -apply ( rule_tac [2] cfun_eqI)
161.207 -apply ( drule_tac [2] spec)
161.208 -apply ( drule_tac [2] f="rt" in cfun_arg_cong)
161.209 -prefer 2
161.210 -apply ( simp)
161.211 -prefer 2
161.212 -apply ( simp)
161.213 -apply (rule_tac bexI)
161.214 -apply auto
161.215 -apply (drule spec)
161.216 -apply (erule exE)
161.217 -apply (erule ssubst)
161.218 -apply (simp)
161.219 -done
161.220 -
161.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"
161.222 -apply (unfold BufAC_def)
161.223 -apply (rule ex_elim_lemma [THEN iffD2])
161.224 -apply safe
161.225 -apply (fast intro: BufAC_Cmt_d32 [THEN Def_maximal]
161.226 - monofun_cfun_arg BufAC_Asm_empty [THEN BufAC_Asm_d_req])
161.227 -apply (auto intro: BufAC_Cmt_d3 BufAC_Asm_d_req)
161.228 -done
161.229 -
161.230 -
161.231 -(**** BufSt *******************************************************************)
161.232 -
161.233 -lemma mono_BufSt_F: "mono BufSt_F"
161.234 -by (unfold mono_def BufSt_F_def, fast)
161.235 -
161.236 -lemmas BufSt_P_fix =
161.237 - mono_BufSt_F [THEN BufSt_P_def [THEN eq_reflection, THEN def_gfp_unfold]]
161.238 -
161.239 -lemma BufSt_P_unfold: "(h:BufSt_P) = (!s. h s\<cdot><> = <> &
161.240 - (!d x. h \<currency> \<cdot>(Md d\<leadsto>x) = h (Sd d)\<cdot>x &
161.241 - (? hh:BufSt_P. h (Sd d)\<cdot>(\<bullet>\<leadsto>x) = d\<leadsto>(hh \<currency> \<cdot>x))))"
161.242 -apply (subst BufSt_P_fix [THEN set_cong])
161.243 -apply (unfold BufSt_F_def)
161.244 -apply (simp)
161.245 -done
161.246 -
161.247 -lemma BufSt_P_empty: "h:BufSt_P ==> h s \<cdot> <> = <>"
161.248 -by (drule BufSt_P_unfold [THEN iffD1], auto)
161.249 -lemma BufSt_P_d: "h:BufSt_P ==> h \<currency> \<cdot>(Md d\<leadsto>x) = h (Sd d)\<cdot>x"
161.250 -by (drule BufSt_P_unfold [THEN iffD1], auto)
161.251 -lemma BufSt_P_d_req: "h:BufSt_P ==> \<exists>hh\<in>BufSt_P.
161.252 - h (Sd d)\<cdot>(\<bullet> \<leadsto>x) = d\<leadsto>(hh \<currency> \<cdot>x)"
161.253 -by (drule BufSt_P_unfold [THEN iffD1], auto)
161.254 -
161.255 -
161.256 -(**** Buf_AC_imp_Eq ***********************************************************)
161.257 -
161.258 -lemma Buf_AC_imp_Eq: "BufAC \<subseteq> BufEq"
161.259 -apply (unfold BufEq_def)
161.260 -apply (rule gfp_upperbound)
161.261 -apply (unfold BufEq_F_def)
161.262 -apply safe
161.263 -apply (erule BufAC_f_d)
161.264 -apply (drule BufAC_f_d_req)
161.265 -apply (fast)
161.266 -done
161.267 -
161.268 -
161.269 -(**** Buf_Eq_imp_AC by coinduction ********************************************)
161.270 -
161.271 -lemma BufAC_Asm_cong_lemma [rule_format]: "\<forall>s f ff. f\<in>BufEq \<longrightarrow> ff\<in>BufEq \<longrightarrow>
161.272 - s\<in>BufAC_Asm \<longrightarrow> stream_take n\<cdot>(f\<cdot>s) = stream_take n\<cdot>(ff\<cdot>s)"
161.273 -apply (induct_tac "n")
161.274 -apply (simp)
161.275 -apply (intro strip)
161.276 -apply (drule BufAC_Asm_unfold [THEN iffD1])
161.277 -apply safe
161.278 -apply (simp add: Buf_f_empty)
161.279 -apply (simp add: Buf_f_d)
161.280 -apply (drule ft_eq [THEN iffD1])
161.281 -apply (clarsimp)
161.282 -apply (drule Buf_f_d_req)+
161.283 -apply safe
161.284 -apply (erule ssubst)+
161.285 -apply (simp (no_asm))
161.286 -apply (fast)
161.287 -done
161.288 -
161.289 -lemma BufAC_Asm_cong: "\<lbrakk>f \<in> BufEq; ff \<in> BufEq; s \<in> BufAC_Asm\<rbrakk> \<Longrightarrow> f\<cdot>s = ff\<cdot>s"
161.290 -apply (rule stream.take_lemma)
161.291 -apply (erule (2) BufAC_Asm_cong_lemma)
161.292 -done
161.293 -
161.294 -lemma Buf_Eq_imp_AC_lemma: "\<lbrakk>f \<in> BufEq; x \<in> BufAC_Asm\<rbrakk> \<Longrightarrow> (x, f\<cdot>x) \<in> BufAC_Cmt"
161.295 -apply (unfold BufAC_Cmt_def)
161.296 -apply (rotate_tac)
161.297 -apply (erule weak_coinduct_image)
161.298 -apply (unfold BufAC_Cmt_F_def)
161.299 -apply safe
161.300 -apply (erule Buf_f_empty)
161.301 -apply (erule Buf_f_d)
161.302 -apply (drule Buf_f_d_req)
161.303 -apply (clarsimp)
161.304 -apply (erule exI)
161.305 -apply (drule BufAC_Asm_prefix2)
161.306 -apply (frule Buf_f_d_req)
161.307 -apply (clarsimp)
161.308 -apply (erule ssubst)
161.309 -apply (simp)
161.310 -apply (drule (2) BufAC_Asm_cong)
161.311 -apply (erule subst)
161.312 -apply (erule imageI)
161.313 -done
161.314 -lemma Buf_Eq_imp_AC: "BufEq \<subseteq> BufAC"
161.315 -apply (unfold BufAC_def)
161.316 -apply (clarify)
161.317 -apply (erule (1) Buf_Eq_imp_AC_lemma)
161.318 -done
161.319 -
161.320 -(**** Buf_Eq_eq_AC ************************************************************)
161.321 -
161.322 -lemmas Buf_Eq_eq_AC = Buf_AC_imp_Eq [THEN Buf_Eq_imp_AC [THEN subset_antisym]]
161.323 -
161.324 -
161.325 -(**** alternative (not strictly) stronger version of Buf_Eq *******************)
161.326 -
161.327 -lemma Buf_Eq_alt_imp_Eq: "BufEq_alt \<subseteq> BufEq"
161.328 -apply (unfold BufEq_def BufEq_alt_def)
161.329 -apply (rule gfp_mono)
161.330 -apply (unfold BufEq_F_def)
161.331 -apply (fast)
161.332 -done
161.333 -
161.334 -(* direct proof of "BufEq \<subseteq> BufEq_alt" seems impossible *)
161.335 -
161.336 -
161.337 -lemma Buf_AC_imp_Eq_alt: "BufAC <= BufEq_alt"
161.338 -apply (unfold BufEq_alt_def)
161.339 -apply (rule gfp_upperbound)
161.340 -apply (fast elim: BufAC_f_d BufAC_f_d_req)
161.341 -done
161.342 -
161.343 -lemmas Buf_Eq_imp_Eq_alt = subset_trans [OF Buf_Eq_imp_AC Buf_AC_imp_Eq_alt]
161.344 -
161.345 -lemmas Buf_Eq_alt_eq = subset_antisym [OF Buf_Eq_alt_imp_Eq Buf_Eq_imp_Eq_alt]
161.346 -
161.347 -
161.348 -(**** Buf_Eq_eq_St ************************************************************)
161.349 -
161.350 -lemma Buf_St_imp_Eq: "BufSt <= BufEq"
161.351 -apply (unfold BufSt_def BufEq_def)
161.352 -apply (rule gfp_upperbound)
161.353 -apply (unfold BufEq_F_def)
161.354 -apply safe
161.355 -apply ( simp add: BufSt_P_d BufSt_P_empty)
161.356 -apply (simp add: BufSt_P_d)
161.357 -apply (drule BufSt_P_d_req)
161.358 -apply (force)
161.359 -done
161.360 -
161.361 -lemma Buf_Eq_imp_St: "BufEq <= BufSt"
161.362 -apply (unfold BufSt_def BufSt_P_def)
161.363 -apply safe
161.364 -apply (rename_tac f)
161.365 -apply (rule_tac x="\<lambda>s. case s of Sd d => \<Lambda> x. f\<cdot>(Md d\<leadsto>x)| \<currency> => f" in bexI)
161.366 -apply ( simp)
161.367 -apply (erule weak_coinduct_image)
161.368 -apply (unfold BufSt_F_def)
161.369 -apply (simp)
161.370 -apply safe
161.371 -apply ( rename_tac "s")
161.372 -apply ( induct_tac "s")
161.373 -apply ( simp add: Buf_f_d)
161.374 -apply ( simp add: Buf_f_empty)
161.375 -apply ( simp)
161.376 -apply (simp)
161.377 -apply (rename_tac f d x)
161.378 -apply (drule_tac d="d" and x="x" in Buf_f_d_req)
161.379 -apply auto
161.380 -done
161.381 -
161.382 -lemmas Buf_Eq_eq_St = Buf_St_imp_Eq [THEN Buf_Eq_imp_St [THEN subset_antisym]]
161.383 -
161.384 -end
162.1 --- a/src/HOLCF/FOCUS/Buffer_adm.thy Sat Nov 27 14:34:54 2010 -0800
162.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
162.3 @@ -1,300 +0,0 @@
162.4 -(* Title: HOLCF/FOCUS/Buffer_adm.thy
162.5 - Author: David von Oheimb, TU Muenchen
162.6 -*)
162.7 -
162.8 -header {* One-element buffer, proof of Buf_Eq_imp_AC by induction + admissibility *}
162.9 -
162.10 -theory Buffer_adm
162.11 -imports Buffer Stream_adm
162.12 -begin
162.13 -
162.14 -declare Fin_0 [simp]
162.15 -
162.16 -lemma BufAC_Asm_d2: "a\<leadsto>s:BufAC_Asm ==> ? d. a=Md d"
162.17 -by (drule BufAC_Asm_unfold [THEN iffD1], auto)
162.18 -
162.19 -lemma BufAC_Asm_d3:
162.20 - "a\<leadsto>b\<leadsto>s:BufAC_Asm ==> ? d. a=Md d & b=\<bullet> & s:BufAC_Asm"
162.21 -by (drule BufAC_Asm_unfold [THEN iffD1], auto)
162.22 -
162.23 -lemma BufAC_Asm_F_def3:
162.24 - "(s:BufAC_Asm_F A) = (s=<> |
162.25 - (? d. ft\<cdot>s=Def(Md d)) & (rt\<cdot>s=<> | ft\<cdot>(rt\<cdot>s)=Def \<bullet> & rt\<cdot>(rt\<cdot>s):A))"
162.26 -by (unfold BufAC_Asm_F_def, auto)
162.27 -
162.28 -lemma cont_BufAC_Asm_F: "down_cont BufAC_Asm_F"
162.29 -by (auto simp add: down_cont_def BufAC_Asm_F_def3)
162.30 -
162.31 -lemma BufAC_Cmt_F_def3:
162.32 - "((s,t):BufAC_Cmt_F C) = (!d x.
162.33 - (s = <> --> t = <> ) &
162.34 - (s = Md d\<leadsto><> --> t = <> ) &
162.35 - (s = Md d\<leadsto>\<bullet>\<leadsto>x --> ft\<cdot>t = Def d & (x,rt\<cdot>t):C))"
162.36 -apply (unfold BufAC_Cmt_F_def)
162.37 -apply (subgoal_tac "!d x. (s = Md d\<leadsto>\<bullet>\<leadsto>x --> (? y. t = d\<leadsto>y & (x,y):C)) =
162.38 - (s = Md d\<leadsto>\<bullet>\<leadsto>x --> ft\<cdot>t = Def d & (x,rt\<cdot>t):C)")
162.39 -apply (simp)
162.40 -apply (auto intro: surjectiv_scons [symmetric])
162.41 -done
162.42 -
162.43 -lemma cont_BufAC_Cmt_F: "down_cont BufAC_Cmt_F"
162.44 -by (auto simp add: down_cont_def BufAC_Cmt_F_def3)
162.45 -
162.46 -
162.47 -(**** adm_BufAC_Asm ***********************************************************)
162.48 -
162.49 -lemma BufAC_Asm_F_stream_monoP: "stream_monoP BufAC_Asm_F"
162.50 -apply (unfold BufAC_Asm_F_def stream_monoP_def)
162.51 -apply (rule_tac x="{x. (? d. x = Md d\<leadsto>\<bullet>\<leadsto><>)}" in exI)
162.52 -apply (rule_tac x="Suc (Suc 0)" in exI)
162.53 -apply (clarsimp)
162.54 -done
162.55 -
162.56 -lemma adm_BufAC_Asm: "adm (%x. x:BufAC_Asm)"
162.57 -apply (unfold BufAC_Asm_def)
162.58 -apply (rule cont_BufAC_Asm_F [THEN BufAC_Asm_F_stream_monoP [THEN fstream_gfp_admI]])
162.59 -done
162.60 -
162.61 -
162.62 -(**** adm_non_BufAC_Asm *******************************************************)
162.63 -
162.64 -lemma BufAC_Asm_F_stream_antiP: "stream_antiP BufAC_Asm_F"
162.65 -apply (unfold stream_antiP_def BufAC_Asm_F_def)
162.66 -apply (intro strip)
162.67 -apply (rule_tac x="{x. (? d. x = Md d\<leadsto>\<bullet>\<leadsto><>)}" in exI)
162.68 -apply (rule_tac x="Suc (Suc 0)" in exI)
162.69 -apply (rule conjI)
162.70 -prefer 2
162.71 -apply ( intro strip)
162.72 -apply ( drule slen_mono)
162.73 -apply ( drule (1) order_trans)
162.74 -apply (force)+
162.75 -done
162.76 -
162.77 -lemma adm_non_BufAC_Asm: "adm (%u. u~:BufAC_Asm)"
162.78 -apply (unfold BufAC_Asm_def)
162.79 -apply (rule cont_BufAC_Asm_F [THEN BufAC_Asm_F_stream_antiP [THEN fstream_non_gfp_admI]])
162.80 -done
162.81 -
162.82 -(**** adm_BufAC ***************************************************************)
162.83 -
162.84 -(*adm_non_BufAC_Asm*)
162.85 -lemma BufAC_Asm_cong [rule_format]: "!f ff. f:BufEq --> ff:BufEq --> s:BufAC_Asm --> f\<cdot>s = ff\<cdot>s"
162.86 -apply (rule fstream_ind2)
162.87 -apply (simp add: adm_non_BufAC_Asm)
162.88 -apply (force dest: Buf_f_empty)
162.89 -apply (force dest!: BufAC_Asm_d2
162.90 - dest: Buf_f_d elim: ssubst)
162.91 -apply (safe dest!: BufAC_Asm_d3)
162.92 -apply (drule Buf_f_d_req)+
162.93 -apply (fast elim: ssubst)
162.94 -done
162.95 -
162.96 -(*adm_non_BufAC_Asm,BufAC_Asm_cong*)
162.97 -lemma BufAC_Cmt_d_req:
162.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"
162.99 -apply (rule BufAC_Cmt_unfold [THEN iffD2])
162.100 -apply (intro strip)
162.101 -apply (frule Buf_f_d_req)
162.102 -apply (auto elim: BufAC_Asm_cong [THEN subst])
162.103 -done
162.104 -
162.105 -(*adm_BufAC_Asm*)
162.106 -lemma BufAC_Asm_antiton: "antitonP BufAC_Asm"
162.107 -apply (rule antitonPI)
162.108 -apply (rule allI)
162.109 -apply (rule fstream_ind2)
162.110 -apply ( rule adm_lemmas)+
162.111 -apply ( rule cont_id)
162.112 -apply ( rule adm_BufAC_Asm)
162.113 -apply ( safe)
162.114 -apply ( rule BufAC_Asm_empty)
162.115 -apply ( force dest!: fstream_prefix
162.116 - dest: BufAC_Asm_d2 intro: BufAC_Asm_d)
162.117 -apply ( force dest!: fstream_prefix
162.118 - dest: BufAC_Asm_d3 intro!: BufAC_Asm_d_req)
162.119 -done
162.120 -
162.121 -(*adm_BufAC_Asm,BufAC_Asm_antiton,adm_non_BufAC_Asm,BufAC_Asm_cong*)
162.122 -lemma BufAC_Cmt_2stream_monoP: "f:BufEq ==> ? l. !i x s. s:BufAC_Asm --> x << s --> Fin (l i) < #x -->
162.123 - (x,f\<cdot>x):down_iterate BufAC_Cmt_F i -->
162.124 - (s,f\<cdot>s):down_iterate BufAC_Cmt_F i"
162.125 -apply (rule_tac x="%i. 2*i" in exI)
162.126 -apply (rule allI)
162.127 -apply (induct_tac "i")
162.128 -apply ( simp)
162.129 -apply (simp add: add_commute)
162.130 -apply (intro strip)
162.131 -apply (subst BufAC_Cmt_F_def3)
162.132 -apply (drule_tac P="%x. x" in BufAC_Cmt_F_def3 [THEN subst])
162.133 -apply safe
162.134 -apply ( erule Buf_f_empty)
162.135 -apply ( erule Buf_f_d)
162.136 -apply ( drule Buf_f_d_req)
162.137 -apply ( safe, erule ssubst, simp)
162.138 -apply clarsimp
162.139 -apply (rename_tac i d xa ya t)
162.140 -(*
162.141 - 1. \<And>i d xa ya t.
162.142 - \<lbrakk>f \<in> BufEq;
162.143 - \<forall>x s. s \<in> BufAC_Asm \<longrightarrow>
162.144 - x \<sqsubseteq> s \<longrightarrow>
162.145 - Fin (2 * i) < #x \<longrightarrow>
162.146 - (x, f\<cdot>x) \<in> down_iterate BufAC_Cmt_F i \<longrightarrow>
162.147 - (s, f\<cdot>s) \<in> down_iterate BufAC_Cmt_F i;
162.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;
162.149 - (ya, t) \<in> down_iterate BufAC_Cmt_F i; ya \<sqsubseteq> xa\<rbrakk>
162.150 - \<Longrightarrow> (xa, rt\<cdot>(f\<cdot>(Md d\<leadsto>\<bullet>\<leadsto>xa))) \<in> down_iterate BufAC_Cmt_F i
162.151 -*)
162.152 -apply (rotate_tac 2)
162.153 -apply (drule BufAC_Asm_prefix2)
162.154 -apply (frule Buf_f_d_req, erule exE, erule conjE, rotate_tac -1, erule ssubst)
162.155 -apply (frule Buf_f_d_req, erule exE, erule conjE)
162.156 -apply ( subgoal_tac "f\<cdot>(Md d\<leadsto>\<bullet>\<leadsto>ya) = d\<leadsto>ffa\<cdot>ya")
162.157 -prefer 2
162.158 -apply ( assumption)
162.159 -apply ( rotate_tac -1)
162.160 -apply ( simp)
162.161 -apply (erule subst)
162.162 -(*
162.163 - 1. \<And>i d xa ya t ff ffa.
162.164 - \<lbrakk>f\<cdot>(Md d\<leadsto>\<bullet>\<leadsto>ya) = d\<leadsto>ffa\<cdot>ya; Fin (2 * i) < #ya;
162.165 - (ya, ffa\<cdot>ya) \<in> down_iterate BufAC_Cmt_F i; ya \<sqsubseteq> xa; f \<in> BufEq;
162.166 - \<forall>x s. s \<in> BufAC_Asm \<longrightarrow>
162.167 - x \<sqsubseteq> s \<longrightarrow>
162.168 - Fin (2 * i) < #x \<longrightarrow>
162.169 - (x, f\<cdot>x) \<in> down_iterate BufAC_Cmt_F i \<longrightarrow>
162.170 - (s, f\<cdot>s) \<in> down_iterate BufAC_Cmt_F i;
162.171 - xa \<in> BufAC_Asm; ff \<in> BufEq; ffa \<in> BufEq\<rbrakk>
162.172 - \<Longrightarrow> (xa, ff\<cdot>xa) \<in> down_iterate BufAC_Cmt_F i
162.173 -*)
162.174 -apply (drule spec, drule spec, drule (1) mp)
162.175 -apply (drule (1) mp)
162.176 -apply (drule (1) mp)
162.177 -apply (erule impE)
162.178 -apply ( subst BufAC_Asm_cong, assumption)
162.179 -prefer 3 apply assumption
162.180 -apply assumption
162.181 -apply ( erule (1) BufAC_Asm_antiton [THEN antitonPD])
162.182 -apply (subst BufAC_Asm_cong, assumption)
162.183 -prefer 3 apply assumption
162.184 -apply assumption
162.185 -apply assumption
162.186 -done
162.187 -
162.188 -lemma BufAC_Cmt_iterate_all: "(x\<in>BufAC_Cmt) = (\<forall>n. x\<in>down_iterate BufAC_Cmt_F n)"
162.189 -apply (unfold BufAC_Cmt_def)
162.190 -apply (subst cont_BufAC_Cmt_F [THEN INTER_down_iterate_is_gfp])
162.191 -apply (fast)
162.192 -done
162.193 -
162.194 -(*adm_BufAC_Asm,BufAC_Asm_antiton,adm_non_BufAC_Asm,BufAC_Asm_cong,
162.195 - BufAC_Cmt_2stream_monoP*)
162.196 -lemma adm_BufAC: "f:BufEq ==> adm (%s. s:BufAC_Asm --> (s, f\<cdot>s):BufAC_Cmt)"
162.197 -apply (rule flatstream_admI)
162.198 -apply (subst BufAC_Cmt_iterate_all)
162.199 -apply (drule BufAC_Cmt_2stream_monoP)
162.200 -apply safe
162.201 -apply (drule spec, erule exE)
162.202 -apply (drule spec, erule impE)
162.203 -apply (erule BufAC_Asm_antiton [THEN antitonPD])
162.204 -apply (erule is_ub_thelub)
162.205 -apply (tactic "smp_tac 3 1")
162.206 -apply (drule is_ub_thelub)
162.207 -apply (drule (1) mp)
162.208 -apply (drule (1) mp)
162.209 -apply (erule mp)
162.210 -apply (drule BufAC_Cmt_iterate_all [THEN iffD1])
162.211 -apply (erule spec)
162.212 -done
162.213 -
162.214 -
162.215 -
162.216 -(**** Buf_Eq_imp_AC by induction **********************************************)
162.217 -
162.218 -(*adm_BufAC_Asm,BufAC_Asm_antiton,adm_non_BufAC_Asm,BufAC_Asm_cong,
162.219 - BufAC_Cmt_2stream_monoP,adm_BufAC,BufAC_Cmt_d_req*)
162.220 -lemma Buf_Eq_imp_AC: "BufEq <= BufAC"
162.221 -apply (unfold BufAC_def)
162.222 -apply (rule subsetI)
162.223 -apply (simp)
162.224 -apply (rule allI)
162.225 -apply (rule fstream_ind2)
162.226 -back
162.227 -apply ( erule adm_BufAC)
162.228 -apply ( safe)
162.229 -apply ( erule BufAC_Cmt_empty)
162.230 -apply ( erule BufAC_Cmt_d)
162.231 -apply ( drule BufAC_Asm_prefix2)
162.232 -apply ( simp)
162.233 -apply (fast intro: BufAC_Cmt_d_req BufAC_Asm_prefix2)
162.234 -done
162.235 -
162.236 -(**** new approach for admissibility, reduces itself to absurdity *************)
162.237 -
162.238 -lemma adm_BufAC_Asm': "adm (\<lambda>x. x\<in>BufAC_Asm)"
162.239 -apply (rule def_gfp_admI)
162.240 -apply (rule BufAC_Asm_def [THEN eq_reflection])
162.241 -apply (safe)
162.242 -apply (unfold BufAC_Asm_F_def)
162.243 -apply (safe)
162.244 -apply (erule contrapos_np)
162.245 -apply (drule fstream_exhaust_eq [THEN iffD1])
162.246 -apply (clarsimp)
162.247 -apply (drule (1) fstream_lub_lemma)
162.248 -apply (clarify)
162.249 -apply (erule_tac x="j" in all_dupE)
162.250 -apply (simp)
162.251 -apply (drule BufAC_Asm_d2)
162.252 -apply (clarify)
162.253 -apply (simp)
162.254 -apply (rule disjCI)
162.255 -apply (erule contrapos_np)
162.256 -apply (drule fstream_exhaust_eq [THEN iffD1])
162.257 -apply (clarsimp)
162.258 -apply (drule (1) fstream_lub_lemma)
162.259 -apply (clarsimp)
162.260 -apply (tactic "simp_tac (HOL_basic_ss addsimps (ex_simps@all_simps RL[sym])) 1")
162.261 -apply (rule_tac x="Xa" in exI)
162.262 -apply (rule allI)
162.263 -apply (rotate_tac -1)
162.264 -apply (erule_tac x="i" in allE)
162.265 -apply (clarsimp)
162.266 -apply (erule_tac x="jb" in allE)
162.267 -apply (clarsimp)
162.268 -apply (erule_tac x="jc" in allE)
162.269 -apply (clarsimp dest!: BufAC_Asm_d3)
162.270 -done
162.271 -
162.272 -lemma adm_non_BufAC_Asm': "adm (\<lambda>u. u \<notin> BufAC_Asm)" (* uses antitonP *)
162.273 -apply (rule def_gfp_adm_nonP)
162.274 -apply (rule BufAC_Asm_def [THEN eq_reflection])
162.275 -apply (unfold BufAC_Asm_F_def)
162.276 -apply (safe)
162.277 -apply (erule contrapos_np)
162.278 -apply (drule fstream_exhaust_eq [THEN iffD1])
162.279 -apply (clarsimp)
162.280 -apply (frule fstream_prefix)
162.281 -apply (clarsimp)
162.282 -apply (frule BufAC_Asm_d2)
162.283 -apply (clarsimp)
162.284 -apply (rotate_tac -1)
162.285 -apply (erule contrapos_pp)
162.286 -apply (drule fstream_exhaust_eq [THEN iffD1])
162.287 -apply (clarsimp)
162.288 -apply (frule fstream_prefix)
162.289 -apply (clarsimp)
162.290 -apply (frule BufAC_Asm_d3)
162.291 -apply (force)
162.292 -done
162.293 -
162.294 -lemma adm_BufAC': "f \<in> BufEq \<Longrightarrow> adm (\<lambda>u. u \<in> BufAC_Asm \<longrightarrow> (u, f\<cdot>u) \<in> BufAC_Cmt)"
162.295 -apply (rule triv_admI)
162.296 -apply (clarify)
162.297 -apply (erule (1) Buf_Eq_imp_AC_lemma)
162.298 - (* this is what we originally aimed to show, using admissibilty :-( *)
162.299 -done
162.300 -
162.301 -end
162.302 -
162.303 -
163.1 --- a/src/HOLCF/FOCUS/FOCUS.thy Sat Nov 27 14:34:54 2010 -0800
163.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
163.3 @@ -1,29 +0,0 @@
163.4 -(* Title: HOLCF/FOCUS/FOCUS.thy
163.5 - Author: David von Oheimb, TU Muenchen
163.6 -*)
163.7 -
163.8 -header {* Top level of FOCUS *}
163.9 -
163.10 -theory FOCUS
163.11 -imports Fstream
163.12 -begin
163.13 -
163.14 -lemma ex_eqI [intro!]: "? xx. x = xx"
163.15 -by auto
163.16 -
163.17 -lemma ex2_eqI [intro!]: "? xx yy. x = xx & y = yy"
163.18 -by auto
163.19 -
163.20 -lemma eq_UU_symf: "(UU = f x) = (f x = UU)"
163.21 -by auto
163.22 -
163.23 -lemma fstream_exhaust_slen_eq: "(#x ~= 0) = (? a y. x = a~> y)"
163.24 -by (simp add: slen_empty_eq fstream_exhaust_eq)
163.25 -
163.26 -lemmas [simp] =
163.27 - slen_less_1_eq fstream_exhaust_slen_eq
163.28 - slen_fscons_eq slen_fscons_less_eq Suc_ile_eq
163.29 -
163.30 -declare strictI [elim]
163.31 -
163.32 -end
164.1 --- a/src/HOLCF/FOCUS/Fstream.thy Sat Nov 27 14:34:54 2010 -0800
164.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
164.3 @@ -1,263 +0,0 @@
164.4 -(* Title: HOLCF/FOCUS/Fstream.thy
164.5 - Author: David von Oheimb, TU Muenchen
164.6 -
164.7 -FOCUS streams (with lifted elements).
164.8 -
164.9 -TODO: integrate Fstreams.thy
164.10 -*)
164.11 -
164.12 -header {* FOCUS flat streams *}
164.13 -
164.14 -theory Fstream
164.15 -imports Stream
164.16 -begin
164.17 -
164.18 -default_sort type
164.19 -
164.20 -types 'a fstream = "'a lift stream"
164.21 -
164.22 -definition
164.23 - fscons :: "'a \<Rightarrow> 'a fstream \<rightarrow> 'a fstream" where
164.24 - "fscons a = (\<Lambda> s. Def a && s)"
164.25 -
164.26 -definition
164.27 - fsfilter :: "'a set \<Rightarrow> 'a fstream \<rightarrow> 'a fstream" where
164.28 - "fsfilter A = (sfilter\<cdot>(flift2 (\<lambda>x. x\<in>A)))"
164.29 -
164.30 -abbreviation
164.31 - emptystream :: "'a fstream" ("<>") where
164.32 - "<> == \<bottom>"
164.33 -
164.34 -abbreviation
164.35 - fscons' :: "'a \<Rightarrow> 'a fstream \<Rightarrow> 'a fstream" ("(_~>_)" [66,65] 65) where
164.36 - "a~>s == fscons a\<cdot>s"
164.37 -
164.38 -abbreviation
164.39 - fsfilter' :: "'a set \<Rightarrow> 'a fstream \<Rightarrow> 'a fstream" ("(_'(C')_)" [64,63] 63) where
164.40 - "A(C)s == fsfilter A\<cdot>s"
164.41 -
164.42 -notation (xsymbols)
164.43 - fscons' ("(_\<leadsto>_)" [66,65] 65) and
164.44 - fsfilter' ("(_\<copyright>_)" [64,63] 63)
164.45 -
164.46 -
164.47 -lemma Def_maximal: "a = Def d \<Longrightarrow> a\<sqsubseteq>b \<Longrightarrow> b = Def d"
164.48 -by simp
164.49 -
164.50 -
164.51 -section "fscons"
164.52 -
164.53 -lemma fscons_def2: "a~>s = Def a && s"
164.54 -apply (unfold fscons_def)
164.55 -apply (simp)
164.56 -done
164.57 -
164.58 -lemma fstream_exhaust: "x = UU | (? a y. x = a~> y)"
164.59 -apply (simp add: fscons_def2)
164.60 -apply (cut_tac stream.nchotomy)
164.61 -apply (fast dest: not_Undef_is_Def [THEN iffD1])
164.62 -done
164.63 -
164.64 -lemma fstream_cases: "[| x = UU ==> P; !!a y. x = a~> y ==> P |] ==> P"
164.65 -apply (cut_tac fstream_exhaust)
164.66 -apply (erule disjE)
164.67 -apply fast
164.68 -apply fast
164.69 -done
164.70 -
164.71 -lemma fstream_exhaust_eq: "(x ~= UU) = (? a y. x = a~> y)"
164.72 -apply (simp add: fscons_def2 stream_exhaust_eq)
164.73 -apply (fast dest: not_Undef_is_Def [THEN iffD1] elim: DefE)
164.74 -done
164.75 -
164.76 -
164.77 -lemma fscons_not_empty [simp]: "a~> s ~= <>"
164.78 -by (simp add: fscons_def2)
164.79 -
164.80 -
164.81 -lemma fscons_inject [simp]: "(a~> s = b~> t) = (a = b & s = t)"
164.82 -by (simp add: fscons_def2)
164.83 -
164.84 -lemma fstream_prefix: "a~> s << t ==> ? tt. t = a~> tt & s << tt"
164.85 -apply (cases t)
164.86 -apply (cut_tac fscons_not_empty)
164.87 -apply (fast dest: eq_UU_iff [THEN iffD2])
164.88 -apply (simp add: fscons_def2)
164.89 -done
164.90 -
164.91 -lemma fstream_prefix' [simp]:
164.92 - "x << a~> z = (x = <> | (? y. x = a~> y & y << z))"
164.93 -apply (simp add: fscons_def2 Def_not_UU [THEN stream_prefix'])
164.94 -apply (safe)
164.95 -apply (erule_tac [!] contrapos_np)
164.96 -prefer 2 apply (fast elim: DefE)
164.97 -apply (rule lift.exhaust)
164.98 -apply (erule (1) notE)
164.99 -apply (safe)
164.100 -apply (drule Def_below_Def [THEN iffD1])
164.101 -apply fast
164.102 -done
164.103 -
164.104 -(* ------------------------------------------------------------------------- *)
164.105 -
164.106 -section "ft & rt"
164.107 -
164.108 -lemmas ft_empty = stream.sel_rews (1)
164.109 -lemma ft_fscons [simp]: "ft\<cdot>(m~> s) = Def m"
164.110 -by (simp add: fscons_def)
164.111 -
164.112 -lemmas rt_empty = stream.sel_rews (2)
164.113 -lemma rt_fscons [simp]: "rt\<cdot>(m~> s) = s"
164.114 -by (simp add: fscons_def)
164.115 -
164.116 -lemma ft_eq [simp]: "(ft\<cdot>s = Def a) = (? t. s = a~> t)"
164.117 -apply (unfold fscons_def)
164.118 -apply (simp)
164.119 -apply (safe)
164.120 -apply (erule subst)
164.121 -apply (rule exI)
164.122 -apply (rule surjectiv_scons [symmetric])
164.123 -apply (simp)
164.124 -done
164.125 -
164.126 -lemma surjective_fscons_lemma: "(d\<leadsto>y = x) = (ft\<cdot>x = Def d & rt\<cdot>x = y)"
164.127 -by auto
164.128 -
164.129 -lemma surjective_fscons: "ft\<cdot>x = Def d \<Longrightarrow> d\<leadsto>rt\<cdot>x = x"
164.130 -by (simp add: surjective_fscons_lemma)
164.131 -
164.132 -
164.133 -(* ------------------------------------------------------------------------- *)
164.134 -
164.135 -section "take"
164.136 -
164.137 -lemma fstream_take_Suc [simp]:
164.138 - "stream_take (Suc n)\<cdot>(a~> s) = a~> stream_take n\<cdot>s"
164.139 -by (simp add: fscons_def)
164.140 -
164.141 -
164.142 -(* ------------------------------------------------------------------------- *)
164.143 -
164.144 -section "slen"
164.145 -
164.146 -lemma slen_fscons: "#(m~> s) = iSuc (#s)"
164.147 -by (simp add: fscons_def)
164.148 -
164.149 -lemma slen_fscons_eq:
164.150 - "(Fin (Suc n) < #x) = (? a y. x = a~> y & Fin n < #y)"
164.151 -apply (simp add: fscons_def2 slen_scons_eq)
164.152 -apply (fast dest: not_Undef_is_Def [THEN iffD1] elim: DefE)
164.153 -done
164.154 -
164.155 -lemma slen_fscons_eq_rev:
164.156 - "(#x < Fin (Suc (Suc n))) = (!a y. x ~= a~> y | #y < Fin (Suc n))"
164.157 -apply (simp add: fscons_def2 slen_scons_eq_rev)
164.158 -apply (tactic {* step_tac (HOL_cs addSEs @{thms DefE}) 1 *})
164.159 -apply (tactic {* step_tac (HOL_cs addSEs @{thms DefE}) 1 *})
164.160 -apply (tactic {* step_tac (HOL_cs addSEs @{thms DefE}) 1 *})
164.161 -apply (tactic {* step_tac (HOL_cs addSEs @{thms DefE}) 1 *})
164.162 -apply (tactic {* step_tac (HOL_cs addSEs @{thms DefE}) 1 *})
164.163 -apply (tactic {* step_tac (HOL_cs addSEs @{thms DefE}) 1 *})
164.164 -apply (erule contrapos_np)
164.165 -apply (fast dest: not_Undef_is_Def [THEN iffD1] elim: DefE)
164.166 -done
164.167 -
164.168 -lemma slen_fscons_less_eq:
164.169 - "(#(a~> y) < Fin (Suc (Suc n))) = (#y < Fin (Suc n))"
164.170 -apply (subst slen_fscons_eq_rev)
164.171 -apply (fast dest!: fscons_inject [THEN iffD1])
164.172 -done
164.173 -
164.174 -
164.175 -(* ------------------------------------------------------------------------- *)
164.176 -
164.177 -section "induction"
164.178 -
164.179 -lemma fstream_ind:
164.180 - "[| adm P; P <>; !!a s. P s ==> P (a~> s) |] ==> P x"
164.181 -apply (erule stream.induct)
164.182 -apply (assumption)
164.183 -apply (unfold fscons_def2)
164.184 -apply (fast dest: not_Undef_is_Def [THEN iffD1])
164.185 -done
164.186 -
164.187 -lemma fstream_ind2:
164.188 - "[| adm P; P UU; !!a. P (a~> UU); !!a b s. P s ==> P (a~> b~> s) |] ==> P x"
164.189 -apply (erule stream_ind2)
164.190 -apply (assumption)
164.191 -apply (unfold fscons_def2)
164.192 -apply (fast dest: not_Undef_is_Def [THEN iffD1])
164.193 -apply (fast dest: not_Undef_is_Def [THEN iffD1])
164.194 -done
164.195 -
164.196 -
164.197 -(* ------------------------------------------------------------------------- *)
164.198 -
164.199 -section "fsfilter"
164.200 -
164.201 -lemma fsfilter_empty: "A(C)UU = UU"
164.202 -apply (unfold fsfilter_def)
164.203 -apply (rule sfilter_empty)
164.204 -done
164.205 -
164.206 -lemma fsfilter_fscons:
164.207 - "A(C)x~> xs = (if x:A then x~> (A(C)xs) else A(C)xs)"
164.208 -apply (unfold fsfilter_def)
164.209 -apply (simp add: fscons_def2 If_and_if)
164.210 -done
164.211 -
164.212 -lemma fsfilter_emptys: "{}(C)x = UU"
164.213 -apply (rule_tac x="x" in fstream_ind)
164.214 -apply (simp)
164.215 -apply (rule fsfilter_empty)
164.216 -apply (simp add: fsfilter_fscons)
164.217 -done
164.218 -
164.219 -lemma fsfilter_insert: "(insert a A)(C)a~> x = a~> ((insert a A)(C)x)"
164.220 -by (simp add: fsfilter_fscons)
164.221 -
164.222 -lemma fsfilter_single_in: "{a}(C)a~> x = a~> ({a}(C)x)"
164.223 -by (rule fsfilter_insert)
164.224 -
164.225 -lemma fsfilter_single_out: "b ~= a ==> {a}(C)b~> x = ({a}(C)x)"
164.226 -by (simp add: fsfilter_fscons)
164.227 -
164.228 -lemma fstream_lub_lemma1:
164.229 - "\<lbrakk>chain Y; (\<Squnion>i. Y i) = a\<leadsto>s\<rbrakk> \<Longrightarrow> \<exists>j t. Y j = a\<leadsto>t"
164.230 -apply (case_tac "max_in_chain i Y")
164.231 -apply (drule (1) lub_finch1 [THEN lub_eqI, THEN sym])
164.232 -apply (force)
164.233 -apply (unfold max_in_chain_def)
164.234 -apply auto
164.235 -apply (frule (1) chain_mono)
164.236 -apply (rule_tac x="Y j" in fstream_cases)
164.237 -apply (force)
164.238 -apply (drule_tac x="j" in is_ub_thelub)
164.239 -apply (force)
164.240 -done
164.241 -
164.242 -lemma fstream_lub_lemma:
164.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)"
164.244 -apply (frule (1) fstream_lub_lemma1)
164.245 -apply (clarsimp)
164.246 -apply (rule_tac x="%i. rt\<cdot>(Y(i+j))" in exI)
164.247 -apply (rule conjI)
164.248 -apply (erule chain_shift [THEN chain_monofun])
164.249 -apply safe
164.250 -apply (drule_tac i="j" and j="i+j" in chain_mono)
164.251 -apply (simp)
164.252 -apply (simp)
164.253 -apply (rule_tac x="i+j" in exI)
164.254 -apply (drule fstream_prefix)
164.255 -apply (clarsimp)
164.256 -apply (subst contlub_cfun [symmetric])
164.257 -apply (rule chainI)
164.258 -apply (fast)
164.259 -apply (erule chain_shift)
164.260 -apply (subst lub_const)
164.261 -apply (subst lub_range_shift)
164.262 -apply (assumption)
164.263 -apply (simp)
164.264 -done
164.265 -
164.266 -end
165.1 --- a/src/HOLCF/FOCUS/Fstreams.thy Sat Nov 27 14:34:54 2010 -0800
165.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
165.3 @@ -1,331 +0,0 @@
165.4 -(* Title: HOLCF/FOCUS/Fstreams.thy
165.5 - Author: Borislav Gajanovic
165.6 -
165.7 -FOCUS flat streams (with lifted elements).
165.8 -
165.9 -TODO: integrate this with Fstream.
165.10 -*)
165.11 -
165.12 -theory Fstreams
165.13 -imports Stream
165.14 -begin
165.15 -
165.16 -default_sort type
165.17 -
165.18 -types 'a fstream = "('a lift) stream"
165.19 -
165.20 -definition
165.21 - fsingleton :: "'a => 'a fstream" ("<_>" [1000] 999) where
165.22 - fsingleton_def2: "fsingleton = (%a. Def a && UU)"
165.23 -
165.24 -definition
165.25 - fsfilter :: "'a set \<Rightarrow> 'a fstream \<rightarrow> 'a fstream" where
165.26 - "fsfilter A = sfilter\<cdot>(flift2 (\<lambda>x. x\<in>A))"
165.27 -
165.28 -definition
165.29 - fsmap :: "('a => 'b) => 'a fstream -> 'b fstream" where
165.30 - "fsmap f = smap$(flift2 f)"
165.31 -
165.32 -definition
165.33 - jth :: "nat => 'a fstream => 'a" where
165.34 - "jth = (%n s. if Fin n < #s then THE a. i_th n s = Def a else undefined)"
165.35 -
165.36 -definition
165.37 - first :: "'a fstream => 'a" where
165.38 - "first = (%s. jth 0 s)"
165.39 -
165.40 -definition
165.41 - last :: "'a fstream => 'a" where
165.42 - "last = (%s. case #s of Fin n => (if n~=0 then jth (THE k. Suc k = n) s else undefined))"
165.43 -
165.44 -
165.45 -abbreviation
165.46 - emptystream :: "'a fstream" ("<>") where
165.47 - "<> == \<bottom>"
165.48 -
165.49 -abbreviation
165.50 - fsfilter' :: "'a set \<Rightarrow> 'a fstream \<Rightarrow> 'a fstream" ("(_'(C')_)" [64,63] 63) where
165.51 - "A(C)s == fsfilter A\<cdot>s"
165.52 -
165.53 -notation (xsymbols)
165.54 - fsfilter' ("(_\<copyright>_)" [64,63] 63)
165.55 -
165.56 -
165.57 -lemma ft_fsingleton[simp]: "ft$(<a>) = Def a"
165.58 -by (simp add: fsingleton_def2)
165.59 -
165.60 -lemma slen_fsingleton[simp]: "#(<a>) = Fin 1"
165.61 -by (simp add: fsingleton_def2 inat_defs)
165.62 -
165.63 -lemma slen_fstreams[simp]: "#(<a> ooo s) = iSuc (#s)"
165.64 -by (simp add: fsingleton_def2)
165.65 -
165.66 -lemma slen_fstreams2[simp]: "#(s ooo <a>) = iSuc (#s)"
165.67 -apply (cases "#s")
165.68 -apply (auto simp add: iSuc_Fin)
165.69 -apply (insert slen_sconc [of _ s "Suc 0" "<a>"], auto)
165.70 -by (simp add: sconc_def)
165.71 -
165.72 -lemma j_th_0_fsingleton[simp]:"jth 0 (<a>) = a"
165.73 -apply (simp add: fsingleton_def2 jth_def)
165.74 -by (simp add: i_th_def Fin_0)
165.75 -
165.76 -lemma jth_0[simp]: "jth 0 (<a> ooo s) = a"
165.77 -apply (simp add: fsingleton_def2 jth_def)
165.78 -by (simp add: i_th_def Fin_0)
165.79 -
165.80 -lemma first_sconc[simp]: "first (<a> ooo s) = a"
165.81 -by (simp add: first_def)
165.82 -
165.83 -lemma first_fsingleton[simp]: "first (<a>) = a"
165.84 -by (simp add: first_def)
165.85 -
165.86 -lemma jth_n[simp]: "Fin n = #s ==> jth n (s ooo <a>) = a"
165.87 -apply (simp add: jth_def, auto)
165.88 -apply (simp add: i_th_def rt_sconc1)
165.89 -by (simp add: inat_defs split: inat_splits)
165.90 -
165.91 -lemma last_sconc[simp]: "Fin n = #s ==> last (s ooo <a>) = a"
165.92 -apply (simp add: last_def)
165.93 -apply (simp add: inat_defs split:inat_splits)
165.94 -by (drule sym, auto)
165.95 -
165.96 -lemma last_fsingleton[simp]: "last (<a>) = a"
165.97 -by (simp add: last_def)
165.98 -
165.99 -lemma first_UU[simp]: "first UU = undefined"
165.100 -by (simp add: first_def jth_def)
165.101 -
165.102 -lemma last_UU[simp]:"last UU = undefined"
165.103 -by (simp add: last_def jth_def inat_defs)
165.104 -
165.105 -lemma last_infinite[simp]:"#s = Infty ==> last s = undefined"
165.106 -by (simp add: last_def)
165.107 -
165.108 -lemma jth_slen_lemma1:"n <= k & Fin n = #s ==> jth k s = undefined"
165.109 -by (simp add: jth_def inat_defs split:inat_splits, auto)
165.110 -
165.111 -lemma jth_UU[simp]:"jth n UU = undefined"
165.112 -by (simp add: jth_def)
165.113 -
165.114 -lemma ext_last:"[|s ~= UU; Fin (Suc n) = #s|] ==> (stream_take n$s) ooo <(last s)> = s"
165.115 -apply (simp add: last_def)
165.116 -apply (case_tac "#s", auto)
165.117 -apply (simp add: fsingleton_def2)
165.118 -apply (subgoal_tac "Def (jth n s) = i_th n s")
165.119 -apply (auto simp add: i_th_last)
165.120 -apply (drule slen_take_lemma1, auto)
165.121 -apply (simp add: jth_def)
165.122 -apply (case_tac "i_th n s = UU")
165.123 -apply auto
165.124 -apply (simp add: i_th_def)
165.125 -apply (case_tac "i_rt n s = UU", auto)
165.126 -apply (drule i_rt_slen [THEN iffD1])
165.127 -apply (drule slen_take_eq_rev [rule_format, THEN iffD2],auto)
165.128 -by (drule not_Undef_is_Def [THEN iffD1], auto)
165.129 -
165.130 -
165.131 -lemma fsingleton_lemma1[simp]: "(<a> = <b>) = (a=b)"
165.132 -by (simp add: fsingleton_def2)
165.133 -
165.134 -lemma fsingleton_lemma2[simp]: "<a> ~= <>"
165.135 -by (simp add: fsingleton_def2)
165.136 -
165.137 -lemma fsingleton_sconc:"<a> ooo s = Def a && s"
165.138 -by (simp add: fsingleton_def2)
165.139 -
165.140 -lemma fstreams_ind:
165.141 - "[| adm P; P <>; !!a s. P s ==> P (<a> ooo s) |] ==> P x"
165.142 -apply (simp add: fsingleton_def2)
165.143 -apply (rule stream.induct, auto)
165.144 -by (drule not_Undef_is_Def [THEN iffD1], auto)
165.145 -
165.146 -lemma fstreams_ind2:
165.147 - "[| adm P; P <>; !!a. P (<a>); !!a b s. P s ==> P (<a> ooo <b> ooo s) |] ==> P x"
165.148 -apply (simp add: fsingleton_def2)
165.149 -apply (rule stream_ind2, auto)
165.150 -by (drule not_Undef_is_Def [THEN iffD1], auto)+
165.151 -
165.152 -lemma fstreams_take_Suc[simp]: "stream_take (Suc n)$(<a> ooo s) = <a> ooo stream_take n$s"
165.153 -by (simp add: fsingleton_def2)
165.154 -
165.155 -lemma fstreams_not_empty[simp]: "<a> ooo s ~= <>"
165.156 -by (simp add: fsingleton_def2)
165.157 -
165.158 -lemma fstreams_not_empty2[simp]: "s ooo <a> ~= <>"
165.159 -by (case_tac "s=UU", auto)
165.160 -
165.161 -lemma fstreams_exhaust: "x = UU | (EX a s. x = <a> ooo s)"
165.162 -apply (simp add: fsingleton_def2, auto)
165.163 -apply (erule contrapos_pp, auto)
165.164 -apply (drule stream_exhaust_eq [THEN iffD1], auto)
165.165 -by (drule not_Undef_is_Def [THEN iffD1], auto)
165.166 -
165.167 -lemma fstreams_cases: "[| x = UU ==> P; !!a y. x = <a> ooo y ==> P |] ==> P"
165.168 -by (insert fstreams_exhaust [of x], auto)
165.169 -
165.170 -lemma fstreams_exhaust_eq: "(x ~= UU) = (? a y. x = <a> ooo y)"
165.171 -apply (simp add: fsingleton_def2, auto)
165.172 -apply (drule stream_exhaust_eq [THEN iffD1], auto)
165.173 -by (drule not_Undef_is_Def [THEN iffD1], auto)
165.174 -
165.175 -lemma fstreams_inject: "(<a> ooo s = <b> ooo t) = (a=b & s=t)"
165.176 -by (simp add: fsingleton_def2)
165.177 -
165.178 -lemma fstreams_prefix: "<a> ooo s << t ==> EX tt. t = <a> ooo tt & s << tt"
165.179 -apply (simp add: fsingleton_def2)
165.180 -apply (insert stream_prefix [of "Def a" s t], auto)
165.181 -done
165.182 -
165.183 -lemma fstreams_prefix': "x << <a> ooo z = (x = <> | (EX y. x = <a> ooo y & y << z))"
165.184 -apply (auto, case_tac "x=UU", auto)
165.185 -apply (drule stream_exhaust_eq [THEN iffD1], auto)
165.186 -apply (simp add: fsingleton_def2, auto)
165.187 -apply (drule ax_flat, simp)
165.188 -by (erule sconc_mono)
165.189 -
165.190 -lemma ft_fstreams[simp]: "ft$(<a> ooo s) = Def a"
165.191 -by (simp add: fsingleton_def2)
165.192 -
165.193 -lemma rt_fstreams[simp]: "rt$(<a> ooo s) = s"
165.194 -by (simp add: fsingleton_def2)
165.195 -
165.196 -lemma ft_eq[simp]: "(ft$s = Def a) = (EX t. s = <a> ooo t)"
165.197 -apply (cases s, auto)
165.198 -by ((*drule sym,*) auto simp add: fsingleton_def2)
165.199 -
165.200 -lemma surjective_fstreams: "(<d> ooo y = x) = (ft$x = Def d & rt$x = y)"
165.201 -by auto
165.202 -
165.203 -lemma fstreams_mono: "<a> ooo b << <a> ooo c ==> b << c"
165.204 -by (simp add: fsingleton_def2)
165.205 -
165.206 -lemma fsmap_UU[simp]: "fsmap f$UU = UU"
165.207 -by (simp add: fsmap_def)
165.208 -
165.209 -lemma fsmap_fsingleton_sconc: "fsmap f$(<x> ooo xs) = <(f x)> ooo (fsmap f$xs)"
165.210 -by (simp add: fsmap_def fsingleton_def2 flift2_def)
165.211 -
165.212 -lemma fsmap_fsingleton[simp]: "fsmap f$(<x>) = <(f x)>"
165.213 -by (simp add: fsmap_def fsingleton_def2 flift2_def)
165.214 -
165.215 -
165.216 -lemma fstreams_chain_lemma[rule_format]:
165.217 - "ALL s x y. stream_take n$(s::'a fstream) << x & x << y & y << s & x ~= y --> stream_take (Suc n)$s << y"
165.218 -apply (induct_tac n, auto)
165.219 -apply (case_tac "s=UU", auto)
165.220 -apply (drule stream_exhaust_eq [THEN iffD1], auto)
165.221 -apply (case_tac "y=UU", auto)
165.222 -apply (drule stream_exhaust_eq [THEN iffD1], auto)
165.223 -apply (simp add: flat_below_iff)
165.224 -apply (case_tac "s=UU", auto)
165.225 -apply (drule stream_exhaust_eq [THEN iffD1], auto)
165.226 -apply (erule_tac x="ya" in allE)
165.227 -apply (drule stream_prefix, auto)
165.228 -apply (case_tac "y=UU",auto)
165.229 -apply (drule stream_exhaust_eq [THEN iffD1], clarsimp)
165.230 -apply auto
165.231 -apply (simp add: flat_below_iff)
165.232 -apply (erule_tac x="tt" in allE)
165.233 -apply (erule_tac x="yb" in allE, auto)
165.234 -apply (simp add: flat_below_iff)
165.235 -by (simp add: flat_below_iff)
165.236 -
165.237 -lemma fstreams_lub_lemma1: "[| chain Y; (LUB i. Y i) = <a> ooo s |] ==> EX j t. Y j = <a> ooo t"
165.238 -apply (subgoal_tac "(LUB i. Y i) ~= UU")
165.239 -apply (drule chain_UU_I_inverse2, auto)
165.240 -apply (drule_tac x="i" in is_ub_thelub, auto)
165.241 -by (drule fstreams_prefix' [THEN iffD1], auto)
165.242 -
165.243 -lemma fstreams_lub1:
165.244 - "[| chain Y; (LUB i. Y i) = <a> ooo s |]
165.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)"
165.246 -apply (auto simp add: fstreams_lub_lemma1)
165.247 -apply (rule_tac x="%n. stream_take n$s" in exI, auto)
165.248 -apply (induct_tac i, auto)
165.249 -apply (drule fstreams_lub_lemma1, auto)
165.250 -apply (rule_tac x="j" in exI, auto)
165.251 -apply (case_tac "max_in_chain j Y")
165.252 -apply (frule lub_finch1 [THEN lub_eqI], auto)
165.253 -apply (rule_tac x="j" in exI)
165.254 -apply (erule subst) back back
165.255 -apply (simp add: below_prod_def sconc_mono)
165.256 -apply (simp add: max_in_chain_def, auto)
165.257 -apply (rule_tac x="ja" in exI)
165.258 -apply (subgoal_tac "Y j << Y ja")
165.259 -apply (drule fstreams_prefix, auto)+
165.260 -apply (rule sconc_mono)
165.261 -apply (rule fstreams_chain_lemma, auto)
165.262 -apply (subgoal_tac "Y ja << (LUB i. (Y i))", clarsimp)
165.263 -apply (drule fstreams_mono, simp)
165.264 -apply (rule is_ub_thelub, simp)
165.265 -apply (blast intro: chain_mono)
165.266 -by (rule stream_reach2)
165.267 -
165.268 -
165.269 -lemma lub_Pair_not_UU_lemma:
165.270 - "[| chain Y; (LUB i. Y i) = ((a::'a::flat), b); a ~= UU; b ~= UU |]
165.271 - ==> EX j c d. Y j = (c, d) & c ~= UU & d ~= UU"
165.272 -apply (frule lub_prod, clarsimp)
165.273 -apply (drule chain_UU_I_inverse2, clarsimp)
165.274 -apply (case_tac "Y i", clarsimp)
165.275 -apply (case_tac "max_in_chain i Y")
165.276 -apply (drule maxinch_is_thelub, auto)
165.277 -apply (rule_tac x="i" in exI, auto)
165.278 -apply (simp add: max_in_chain_def, auto)
165.279 -apply (subgoal_tac "Y i << Y j",auto)
165.280 -apply (simp add: below_prod_def, clarsimp)
165.281 -apply (drule ax_flat, auto)
165.282 -apply (case_tac "snd (Y j) = UU",auto)
165.283 -apply (case_tac "Y j", auto)
165.284 -apply (rule_tac x="j" in exI)
165.285 -apply (case_tac "Y j",auto)
165.286 -by (drule chain_mono, auto)
165.287 -
165.288 -lemma fstreams_lub_lemma2:
165.289 - "[| chain Y; (LUB i. Y i) = (a, <m> ooo ms); (a::'a::flat) ~= UU |] ==> EX j t. Y j = (a, <m> ooo t)"
165.290 -apply (frule lub_Pair_not_UU_lemma, auto)
165.291 -apply (drule_tac x="j" in is_ub_thelub, auto)
165.292 -apply (drule ax_flat, clarsimp)
165.293 -by (drule fstreams_prefix' [THEN iffD1], auto)
165.294 -
165.295 -lemma fstreams_lub2:
165.296 - "[| chain Y; (LUB i. Y i) = (a, <m> ooo ms); (a::'a::flat) ~= UU |]
165.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)"
165.298 -apply (auto simp add: fstreams_lub_lemma2)
165.299 -apply (rule_tac x="%n. stream_take n$ms" in exI, auto)
165.300 -apply (induct_tac i, auto)
165.301 -apply (drule fstreams_lub_lemma2, auto)
165.302 -apply (rule_tac x="j" in exI, auto)
165.303 -apply (case_tac "max_in_chain j Y")
165.304 -apply (frule lub_finch1 [THEN lub_eqI], auto)
165.305 -apply (rule_tac x="j" in exI)
165.306 -apply (erule subst) back back
165.307 -apply (simp add: sconc_mono)
165.308 -apply (simp add: max_in_chain_def, auto)
165.309 -apply (rule_tac x="ja" in exI)
165.310 -apply (subgoal_tac "Y j << Y ja")
165.311 -apply (simp add: below_prod_def, auto)
165.312 -apply (drule below_trans)
165.313 -apply (simp add: ax_flat, auto)
165.314 -apply (drule fstreams_prefix, auto)+
165.315 -apply (rule sconc_mono)
165.316 -apply (subgoal_tac "tt ~= tta" "tta << ms")
165.317 -apply (blast intro: fstreams_chain_lemma)
165.318 -apply (frule lub_prod, auto)
165.319 -apply (subgoal_tac "snd (Y ja) << (LUB i. snd (Y i))", clarsimp)
165.320 -apply (drule fstreams_mono, simp)
165.321 -apply (rule is_ub_thelub chainI)
165.322 -apply (simp add: chain_def below_prod_def)
165.323 -apply (subgoal_tac "fst (Y j) ~= fst (Y ja) | snd (Y j) ~= snd (Y ja)", simp)
165.324 -apply (drule ax_flat, simp)+
165.325 -apply (drule prod_eqI, auto)
165.326 -apply (simp add: chain_mono)
165.327 -by (rule stream_reach2)
165.328 -
165.329 -
165.330 -lemma cpo_cont_lemma:
165.331 - "[| monofun (f::'a::cpo => 'b::cpo); (!Y. chain Y --> f (lub(range Y)) << (LUB i. f (Y i))) |] ==> cont f"
165.332 -by (erule contI2, simp)
165.333 -
165.334 -end
166.1 --- a/src/HOLCF/FOCUS/README.html Sat Nov 27 14:34:54 2010 -0800
166.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
166.3 @@ -1,22 +0,0 @@
166.4 -<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN" "http://www.w3.org/TR/html4/loose.dtd">
166.5 -
166.6 -<HTML>
166.7 -
166.8 -<HEAD>
166.9 - <meta http-equiv="Content-Type" content="text/html; charset=iso-8859-1">
166.10 - <TITLE>HOLCF/README</TITLE>
166.11 -</HEAD>
166.12 -
166.13 -<BODY>
166.14 -
166.15 -<H3>FOCUS: a theory of stream-processing functions Isabelle/<A HREF="..">HOLCF</A></H3>
166.16 -
166.17 -For introductions to FOCUSs, see
166.18 -<UL>
166.19 -<LI><A HREF="http://www4.in.tum.de/publ/html.php?e=2">The Design of Distributed Systems - An Introduction to FOCUS</A>
166.20 -<LI><A HREF="http://www4.in.tum.de/publ/html.php?e=15">Specification and Refinement of a Buffer of Length One</A>
166.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>
166.22 -</UL>
166.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>.
166.24 -
166.25 -</BODY></HTML>
167.1 --- a/src/HOLCF/FOCUS/ROOT.ML Sat Nov 27 14:34:54 2010 -0800
167.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
167.3 @@ -1,1 +0,0 @@
167.4 -use_thys ["Fstreams", "FOCUS", "Buffer_adm"];
168.1 --- a/src/HOLCF/FOCUS/Stream_adm.thy Sat Nov 27 14:34:54 2010 -0800
168.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
168.3 @@ -1,225 +0,0 @@
168.4 -(* Title: HOLCF/ex/Stream_adm.thy
168.5 - Author: David von Oheimb, TU Muenchen
168.6 -*)
168.7 -
168.8 -header {* Admissibility for streams *}
168.9 -
168.10 -theory Stream_adm
168.11 -imports Stream Continuity
168.12 -begin
168.13 -
168.14 -definition
168.15 - stream_monoP :: "(('a stream) set \<Rightarrow> ('a stream) set) \<Rightarrow> bool" where
168.16 - "stream_monoP F = (\<exists>Q i. \<forall>P s. Fin i \<le> #s \<longrightarrow>
168.17 - (s \<in> F P) = (stream_take i\<cdot>s \<in> Q \<and> iterate i\<cdot>rt\<cdot>s \<in> P))"
168.18 -
168.19 -definition
168.20 - stream_antiP :: "(('a stream) set \<Rightarrow> ('a stream) set) \<Rightarrow> bool" where
168.21 - "stream_antiP F = (\<forall>P x. \<exists>Q i.
168.22 - (#x < Fin i \<longrightarrow> (\<forall>y. x \<sqsubseteq> y \<longrightarrow> y \<in> F P \<longrightarrow> x \<in> F P)) \<and>
168.23 - (Fin i <= #x \<longrightarrow> (\<forall>y. x \<sqsubseteq> y \<longrightarrow>
168.24 - (y \<in> F P) = (stream_take i\<cdot>y \<in> Q \<and> iterate i\<cdot>rt\<cdot>y \<in> P))))"
168.25 -
168.26 -definition
168.27 - antitonP :: "'a set => bool" where
168.28 - "antitonP P = (\<forall>x y. x \<sqsubseteq> y \<longrightarrow> y\<in>P \<longrightarrow> x\<in>P)"
168.29 -
168.30 -
168.31 -(* ----------------------------------------------------------------------- *)
168.32 -
168.33 -section "admissibility"
168.34 -
168.35 -lemma infinite_chain_adm_lemma:
168.36 - "\<lbrakk>Porder.chain Y; \<forall>i. P (Y i);
168.37 - \<And>Y. \<lbrakk>Porder.chain Y; \<forall>i. P (Y i); \<not> finite_chain Y\<rbrakk> \<Longrightarrow> P (\<Squnion>i. Y i)\<rbrakk>
168.38 - \<Longrightarrow> P (\<Squnion>i. Y i)"
168.39 -apply (case_tac "finite_chain Y")
168.40 -prefer 2 apply fast
168.41 -apply (unfold finite_chain_def)
168.42 -apply safe
168.43 -apply (erule lub_finch1 [THEN lub_eqI, THEN ssubst])
168.44 -apply assumption
168.45 -apply (erule spec)
168.46 -done
168.47 -
168.48 -lemma increasing_chain_adm_lemma:
168.49 - "\<lbrakk>Porder.chain Y; \<forall>i. P (Y i); \<And>Y. \<lbrakk>Porder.chain Y; \<forall>i. P (Y i);
168.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>
168.51 - \<Longrightarrow> P (\<Squnion>i. Y i)"
168.52 -apply (erule infinite_chain_adm_lemma)
168.53 -apply assumption
168.54 -apply (erule thin_rl)
168.55 -apply (unfold finite_chain_def)
168.56 -apply (unfold max_in_chain_def)
168.57 -apply (fast dest: le_imp_less_or_eq elim: chain_mono_less)
168.58 -done
168.59 -
168.60 -lemma flatstream_adm_lemma:
168.61 - assumes 1: "Porder.chain Y"
168.62 - assumes 2: "!i. P (Y i)"
168.63 - assumes 3: "(!!Y. [| Porder.chain Y; !i. P (Y i); !k. ? j. Fin k < #((Y j)::'a::flat stream)|]
168.64 - ==> P(LUB i. Y i))"
168.65 - shows "P(LUB i. Y i)"
168.66 -apply (rule increasing_chain_adm_lemma [of _ P, OF 1 2])
168.67 -apply (erule 3, assumption)
168.68 -apply (erule thin_rl)
168.69 -apply (rule allI)
168.70 -apply (case_tac "!j. stream_finite (Y j)")
168.71 -apply ( rule chain_incr)
168.72 -apply ( rule allI)
168.73 -apply ( drule spec)
168.74 -apply ( safe)
168.75 -apply ( rule exI)
168.76 -apply ( rule slen_strict_mono)
168.77 -apply ( erule spec)
168.78 -apply ( assumption)
168.79 -apply ( assumption)
168.80 -apply (metis inat_ord_code(4) slen_infinite)
168.81 -done
168.82 -
168.83 -(* should be without reference to stream length? *)
168.84 -lemma flatstream_admI: "[|(!!Y. [| Porder.chain Y; !i. P (Y i);
168.85 - !k. ? j. Fin k < #((Y j)::'a::flat stream)|] ==> P(LUB i. Y i))|]==> adm P"
168.86 -apply (unfold adm_def)
168.87 -apply (intro strip)
168.88 -apply (erule (1) flatstream_adm_lemma)
168.89 -apply (fast)
168.90 -done
168.91 -
168.92 -
168.93 -(* context (theory "Nat_InFinity");*)
168.94 -lemma ile_lemma: "Fin (i + j) <= x ==> Fin i <= x"
168.95 - by (rule order_trans) auto
168.96 -
168.97 -lemma stream_monoP2I:
168.98 -"!!X. stream_monoP F ==> !i. ? l. !x y.
168.99 - Fin l <= #x --> (x::'a::flat stream) << y --> x:down_iterate F i --> y:down_iterate F i"
168.100 -apply (unfold stream_monoP_def)
168.101 -apply (safe)
168.102 -apply (rule_tac x="i*ia" in exI)
168.103 -apply (induct_tac "ia")
168.104 -apply ( simp)
168.105 -apply (simp)
168.106 -apply (intro strip)
168.107 -apply (erule allE, erule all_dupE, drule mp, erule ile_lemma)
168.108 -apply (drule_tac P="%x. x" in subst, assumption)
168.109 -apply (erule allE, drule mp, rule ile_lemma) back
168.110 -apply ( erule order_trans)
168.111 -apply ( erule slen_mono)
168.112 -apply (erule ssubst)
168.113 -apply (safe)
168.114 -apply ( erule (2) ile_lemma [THEN slen_take_lemma3, THEN subst])
168.115 -apply (erule allE)
168.116 -apply (drule mp)
168.117 -apply ( erule slen_rt_mult)
168.118 -apply (erule allE)
168.119 -apply (drule mp)
168.120 -apply (erule monofun_rt_mult)
168.121 -apply (drule (1) mp)
168.122 -apply (assumption)
168.123 -done
168.124 -
168.125 -lemma stream_monoP2_gfp_admI: "[| !i. ? l. !x y.
168.126 - Fin l <= #x --> (x::'a::flat stream) << y --> x:down_iterate F i --> y:down_iterate F i;
168.127 - down_cont F |] ==> adm (%x. x:gfp F)"
168.128 -apply (erule INTER_down_iterate_is_gfp [THEN ssubst]) (* cont *)
168.129 -apply (simp (no_asm))
168.130 -apply (rule adm_lemmas)
168.131 -apply (rule flatstream_admI)
168.132 -apply (erule allE)
168.133 -apply (erule exE)
168.134 -apply (erule allE, erule exE)
168.135 -apply (erule allE, erule allE, drule mp) (* stream_monoP *)
168.136 -apply ( drule ileI1)
168.137 -apply ( drule order_trans)
168.138 -apply ( rule ile_iSuc)
168.139 -apply ( drule iSuc_ile_mono [THEN iffD1])
168.140 -apply ( assumption)
168.141 -apply (drule mp)
168.142 -apply ( erule is_ub_thelub)
168.143 -apply (fast)
168.144 -done
168.145 -
168.146 -lemmas fstream_gfp_admI = stream_monoP2I [THEN stream_monoP2_gfp_admI]
168.147 -
168.148 -lemma stream_antiP2I:
168.149 -"!!X. [|stream_antiP (F::(('a::flat stream)set => ('a stream set)))|]
168.150 - ==> !i x y. x << y --> y:down_iterate F i --> x:down_iterate F i"
168.151 -apply (unfold stream_antiP_def)
168.152 -apply (rule allI)
168.153 -apply (induct_tac "i")
168.154 -apply ( simp)
168.155 -apply (simp)
168.156 -apply (intro strip)
168.157 -apply (erule allE, erule all_dupE, erule exE, erule exE)
168.158 -apply (erule conjE)
168.159 -apply (case_tac "#x < Fin i")
168.160 -apply ( fast)
168.161 -apply (unfold linorder_not_less)
168.162 -apply (drule (1) mp)
168.163 -apply (erule all_dupE, drule mp, rule below_refl)
168.164 -apply (erule ssubst)
168.165 -apply (erule allE, drule (1) mp)
168.166 -apply (drule_tac P="%x. x" in subst, assumption)
168.167 -apply (erule conjE, rule conjI)
168.168 -apply ( erule slen_take_lemma3 [THEN ssubst], assumption)
168.169 -apply ( assumption)
168.170 -apply (erule allE, erule allE, drule mp, erule monofun_rt_mult)
168.171 -apply (drule (1) mp)
168.172 -apply (assumption)
168.173 -done
168.174 -
168.175 -lemma stream_antiP2_non_gfp_admI:
168.176 -"!!X. [|!i x y. x << y --> y:down_iterate F i --> x:down_iterate F i; down_cont F |]
168.177 - ==> adm (%u. ~ u:gfp F)"
168.178 -apply (unfold adm_def)
168.179 -apply (simp add: INTER_down_iterate_is_gfp)
168.180 -apply (fast dest!: is_ub_thelub)
168.181 -done
168.182 -
168.183 -lemmas fstream_non_gfp_admI = stream_antiP2I [THEN stream_antiP2_non_gfp_admI]
168.184 -
168.185 -
168.186 -
168.187 -(**new approach for adm********************************************************)
168.188 -
168.189 -section "antitonP"
168.190 -
168.191 -lemma antitonPD: "[| antitonP P; y:P; x<<y |] ==> x:P"
168.192 -apply (unfold antitonP_def)
168.193 -apply auto
168.194 -done
168.195 -
168.196 -lemma antitonPI: "!x y. y:P --> x<<y --> x:P ==> antitonP P"
168.197 -apply (unfold antitonP_def)
168.198 -apply (fast)
168.199 -done
168.200 -
168.201 -lemma antitonP_adm_non_P: "antitonP P ==> adm (%u. u~:P)"
168.202 -apply (unfold adm_def)
168.203 -apply (auto dest: antitonPD elim: is_ub_thelub)
168.204 -done
168.205 -
168.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>
168.207 - adm (\<lambda>u. u\<notin>P)"
168.208 -apply (simp)
168.209 -apply (rule antitonP_adm_non_P)
168.210 -apply (rule antitonPI)
168.211 -apply (drule gfp_upperbound)
168.212 -apply (fast)
168.213 -done
168.214 -
168.215 -lemma adm_set:
168.216 -"{\<Squnion>i. Y i |Y. Porder.chain Y & (\<forall>i. Y i \<in> P)} \<subseteq> P \<Longrightarrow> adm (\<lambda>x. x\<in>P)"
168.217 -apply (unfold adm_def)
168.218 -apply (fast)
168.219 -done
168.220 -
168.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>
168.222 - F {\<Squnion>i. Y i |Y. Porder.chain Y \<and> (\<forall>i. Y i \<in> P)} \<Longrightarrow> adm (\<lambda>x. x\<in>P)"
168.223 -apply (simp)
168.224 -apply (rule adm_set)
168.225 -apply (erule gfp_upperbound)
168.226 -done
168.227 -
168.228 -end
169.1 --- a/src/HOLCF/Fix.thy Sat Nov 27 14:34:54 2010 -0800
169.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
169.3 @@ -1,229 +0,0 @@
169.4 -(* Title: HOLCF/Fix.thy
169.5 - Author: Franz Regensburger
169.6 - Author: Brian Huffman
169.7 -*)
169.8 -
169.9 -header {* Fixed point operator and admissibility *}
169.10 -
169.11 -theory Fix
169.12 -imports Cfun
169.13 -begin
169.14 -
169.15 -default_sort pcpo
169.16 -
169.17 -subsection {* Iteration *}
169.18 -
169.19 -primrec iterate :: "nat \<Rightarrow> ('a::cpo \<rightarrow> 'a) \<rightarrow> ('a \<rightarrow> 'a)" where
169.20 - "iterate 0 = (\<Lambda> F x. x)"
169.21 - | "iterate (Suc n) = (\<Lambda> F x. F\<cdot>(iterate n\<cdot>F\<cdot>x))"
169.22 -
169.23 -text {* Derive inductive properties of iterate from primitive recursion *}
169.24 -
169.25 -lemma iterate_0 [simp]: "iterate 0\<cdot>F\<cdot>x = x"
169.26 -by simp
169.27 -
169.28 -lemma iterate_Suc [simp]: "iterate (Suc n)\<cdot>F\<cdot>x = F\<cdot>(iterate n\<cdot>F\<cdot>x)"
169.29 -by simp
169.30 -
169.31 -declare iterate.simps [simp del]
169.32 -
169.33 -lemma iterate_Suc2: "iterate (Suc n)\<cdot>F\<cdot>x = iterate n\<cdot>F\<cdot>(F\<cdot>x)"
169.34 -by (induct n) simp_all
169.35 -
169.36 -lemma iterate_iterate:
169.37 - "iterate m\<cdot>F\<cdot>(iterate n\<cdot>F\<cdot>x) = iterate (m + n)\<cdot>F\<cdot>x"
169.38 -by (induct m) simp_all
169.39 -
169.40 -text {* The sequence of function iterations is a chain. *}
169.41 -
169.42 -lemma chain_iterate [simp]: "chain (\<lambda>i. iterate i\<cdot>F\<cdot>\<bottom>)"
169.43 -by (rule chainI, unfold iterate_Suc2, rule monofun_cfun_arg, rule minimal)
169.44 -
169.45 -
169.46 -subsection {* Least fixed point operator *}
169.47 -
169.48 -definition
169.49 - "fix" :: "('a \<rightarrow> 'a) \<rightarrow> 'a" where
169.50 - "fix = (\<Lambda> F. \<Squnion>i. iterate i\<cdot>F\<cdot>\<bottom>)"
169.51 -
169.52 -text {* Binder syntax for @{term fix} *}
169.53 -
169.54 -abbreviation
169.55 - fix_syn :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a" (binder "FIX " 10) where
169.56 - "fix_syn (\<lambda>x. f x) \<equiv> fix\<cdot>(\<Lambda> x. f x)"
169.57 -
169.58 -notation (xsymbols)
169.59 - fix_syn (binder "\<mu> " 10)
169.60 -
169.61 -text {* Properties of @{term fix} *}
169.62 -
169.63 -text {* direct connection between @{term fix} and iteration *}
169.64 -
169.65 -lemma fix_def2: "fix\<cdot>F = (\<Squnion>i. iterate i\<cdot>F\<cdot>\<bottom>)"
169.66 -unfolding fix_def by simp
169.67 -
169.68 -lemma iterate_below_fix: "iterate n\<cdot>f\<cdot>\<bottom> \<sqsubseteq> fix\<cdot>f"
169.69 - unfolding fix_def2
169.70 - using chain_iterate by (rule is_ub_thelub)
169.71 -
169.72 -text {*
169.73 - Kleene's fixed point theorems for continuous functions in pointed
169.74 - omega cpo's
169.75 -*}
169.76 -
169.77 -lemma fix_eq: "fix\<cdot>F = F\<cdot>(fix\<cdot>F)"
169.78 -apply (simp add: fix_def2)
169.79 -apply (subst lub_range_shift [of _ 1, symmetric])
169.80 -apply (rule chain_iterate)
169.81 -apply (subst contlub_cfun_arg)
169.82 -apply (rule chain_iterate)
169.83 -apply simp
169.84 -done
169.85 -
169.86 -lemma fix_least_below: "F\<cdot>x \<sqsubseteq> x \<Longrightarrow> fix\<cdot>F \<sqsubseteq> x"
169.87 -apply (simp add: fix_def2)
169.88 -apply (rule lub_below)
169.89 -apply (rule chain_iterate)
169.90 -apply (induct_tac i)
169.91 -apply simp
169.92 -apply simp
169.93 -apply (erule rev_below_trans)
169.94 -apply (erule monofun_cfun_arg)
169.95 -done
169.96 -
169.97 -lemma fix_least: "F\<cdot>x = x \<Longrightarrow> fix\<cdot>F \<sqsubseteq> x"
169.98 -by (rule fix_least_below, simp)
169.99 -
169.100 -lemma fix_eqI:
169.101 - assumes fixed: "F\<cdot>x = x" and least: "\<And>z. F\<cdot>z = z \<Longrightarrow> x \<sqsubseteq> z"
169.102 - shows "fix\<cdot>F = x"
169.103 -apply (rule below_antisym)
169.104 -apply (rule fix_least [OF fixed])
169.105 -apply (rule least [OF fix_eq [symmetric]])
169.106 -done
169.107 -
169.108 -lemma fix_eq2: "f \<equiv> fix\<cdot>F \<Longrightarrow> f = F\<cdot>f"
169.109 -by (simp add: fix_eq [symmetric])
169.110 -
169.111 -lemma fix_eq3: "f \<equiv> fix\<cdot>F \<Longrightarrow> f\<cdot>x = F\<cdot>f\<cdot>x"
169.112 -by (erule fix_eq2 [THEN cfun_fun_cong])
169.113 -
169.114 -lemma fix_eq4: "f = fix\<cdot>F \<Longrightarrow> f = F\<cdot>f"
169.115 -apply (erule ssubst)
169.116 -apply (rule fix_eq)
169.117 -done
169.118 -
169.119 -lemma fix_eq5: "f = fix\<cdot>F \<Longrightarrow> f\<cdot>x = F\<cdot>f\<cdot>x"
169.120 -by (erule fix_eq4 [THEN cfun_fun_cong])
169.121 -
169.122 -text {* strictness of @{term fix} *}
169.123 -
169.124 -lemma fix_bottom_iff: "(fix\<cdot>F = \<bottom>) = (F\<cdot>\<bottom> = \<bottom>)"
169.125 -apply (rule iffI)
169.126 -apply (erule subst)
169.127 -apply (rule fix_eq [symmetric])
169.128 -apply (erule fix_least [THEN UU_I])
169.129 -done
169.130 -
169.131 -lemma fix_strict: "F\<cdot>\<bottom> = \<bottom> \<Longrightarrow> fix\<cdot>F = \<bottom>"
169.132 -by (simp add: fix_bottom_iff)
169.133 -
169.134 -lemma fix_defined: "F\<cdot>\<bottom> \<noteq> \<bottom> \<Longrightarrow> fix\<cdot>F \<noteq> \<bottom>"
169.135 -by (simp add: fix_bottom_iff)
169.136 -
169.137 -text {* @{term fix} applied to identity and constant functions *}
169.138 -
169.139 -lemma fix_id: "(\<mu> x. x) = \<bottom>"
169.140 -by (simp add: fix_strict)
169.141 -
169.142 -lemma fix_const: "(\<mu> x. c) = c"
169.143 -by (subst fix_eq, simp)
169.144 -
169.145 -subsection {* Fixed point induction *}
169.146 -
169.147 -lemma fix_ind: "\<lbrakk>adm P; P \<bottom>; \<And>x. P x \<Longrightarrow> P (F\<cdot>x)\<rbrakk> \<Longrightarrow> P (fix\<cdot>F)"
169.148 -unfolding fix_def2
169.149 -apply (erule admD)
169.150 -apply (rule chain_iterate)
169.151 -apply (rule nat_induct, simp_all)
169.152 -done
169.153 -
169.154 -lemma def_fix_ind:
169.155 - "\<lbrakk>f \<equiv> fix\<cdot>F; adm P; P \<bottom>; \<And>x. P x \<Longrightarrow> P (F\<cdot>x)\<rbrakk> \<Longrightarrow> P f"
169.156 -by (simp add: fix_ind)
169.157 -
169.158 -lemma fix_ind2:
169.159 - assumes adm: "adm P"
169.160 - assumes 0: "P \<bottom>" and 1: "P (F\<cdot>\<bottom>)"
169.161 - assumes step: "\<And>x. \<lbrakk>P x; P (F\<cdot>x)\<rbrakk> \<Longrightarrow> P (F\<cdot>(F\<cdot>x))"
169.162 - shows "P (fix\<cdot>F)"
169.163 -unfolding fix_def2
169.164 -apply (rule admD [OF adm chain_iterate])
169.165 -apply (rule nat_less_induct)
169.166 -apply (case_tac n)
169.167 -apply (simp add: 0)
169.168 -apply (case_tac nat)
169.169 -apply (simp add: 1)
169.170 -apply (frule_tac x=nat in spec)
169.171 -apply (simp add: step)
169.172 -done
169.173 -
169.174 -lemma parallel_fix_ind:
169.175 - assumes adm: "adm (\<lambda>x. P (fst x) (snd x))"
169.176 - assumes base: "P \<bottom> \<bottom>"
169.177 - assumes step: "\<And>x y. P x y \<Longrightarrow> P (F\<cdot>x) (G\<cdot>y)"
169.178 - shows "P (fix\<cdot>F) (fix\<cdot>G)"
169.179 -proof -
169.180 - from adm have adm': "adm (split P)"
169.181 - unfolding split_def .
169.182 - have "\<And>i. P (iterate i\<cdot>F\<cdot>\<bottom>) (iterate i\<cdot>G\<cdot>\<bottom>)"
169.183 - by (induct_tac i, simp add: base, simp add: step)
169.184 - hence "\<And>i. split P (iterate i\<cdot>F\<cdot>\<bottom>, iterate i\<cdot>G\<cdot>\<bottom>)"
169.185 - by simp
169.186 - hence "split P (\<Squnion>i. (iterate i\<cdot>F\<cdot>\<bottom>, iterate i\<cdot>G\<cdot>\<bottom>))"
169.187 - by - (rule admD [OF adm'], simp, assumption)
169.188 - hence "split P (\<Squnion>i. iterate i\<cdot>F\<cdot>\<bottom>, \<Squnion>i. iterate i\<cdot>G\<cdot>\<bottom>)"
169.189 - by (simp add: lub_Pair)
169.190 - hence "P (\<Squnion>i. iterate i\<cdot>F\<cdot>\<bottom>) (\<Squnion>i. iterate i\<cdot>G\<cdot>\<bottom>)"
169.191 - by simp
169.192 - thus "P (fix\<cdot>F) (fix\<cdot>G)"
169.193 - by (simp add: fix_def2)
169.194 -qed
169.195 -
169.196 -subsection {* Fixed-points on product types *}
169.197 -
169.198 -text {*
169.199 - Bekic's Theorem: Simultaneous fixed points over pairs
169.200 - can be written in terms of separate fixed points.
169.201 -*}
169.202 -
169.203 -lemma fix_cprod:
169.204 - "fix\<cdot>(F::'a \<times> 'b \<rightarrow> 'a \<times> 'b) =
169.205 - (\<mu> x. fst (F\<cdot>(x, \<mu> y. snd (F\<cdot>(x, y)))),
169.206 - \<mu> y. snd (F\<cdot>(\<mu> x. fst (F\<cdot>(x, \<mu> y. snd (F\<cdot>(x, y)))), y)))"
169.207 - (is "fix\<cdot>F = (?x, ?y)")
169.208 -proof (rule fix_eqI)
169.209 - have 1: "fst (F\<cdot>(?x, ?y)) = ?x"
169.210 - by (rule trans [symmetric, OF fix_eq], simp)
169.211 - have 2: "snd (F\<cdot>(?x, ?y)) = ?y"
169.212 - by (rule trans [symmetric, OF fix_eq], simp)
169.213 - from 1 2 show "F\<cdot>(?x, ?y) = (?x, ?y)" by (simp add: Pair_fst_snd_eq)
169.214 -next
169.215 - fix z assume F_z: "F\<cdot>z = z"
169.216 - obtain x y where z: "z = (x,y)" by (rule prod.exhaust)
169.217 - from F_z z have F_x: "fst (F\<cdot>(x, y)) = x" by simp
169.218 - from F_z z have F_y: "snd (F\<cdot>(x, y)) = y" by simp
169.219 - let ?y1 = "\<mu> y. snd (F\<cdot>(x, y))"
169.220 - have "?y1 \<sqsubseteq> y" by (rule fix_least, simp add: F_y)
169.221 - hence "fst (F\<cdot>(x, ?y1)) \<sqsubseteq> fst (F\<cdot>(x, y))"
169.222 - by (simp add: fst_monofun monofun_cfun)
169.223 - hence "fst (F\<cdot>(x, ?y1)) \<sqsubseteq> x" using F_x by simp
169.224 - hence 1: "?x \<sqsubseteq> x" by (simp add: fix_least_below)
169.225 - hence "snd (F\<cdot>(?x, y)) \<sqsubseteq> snd (F\<cdot>(x, y))"
169.226 - by (simp add: snd_monofun monofun_cfun)
169.227 - hence "snd (F\<cdot>(?x, y)) \<sqsubseteq> y" using F_y by simp
169.228 - hence 2: "?y \<sqsubseteq> y" by (simp add: fix_least_below)
169.229 - show "(?x, ?y) \<sqsubseteq> z" using z 1 2 by simp
169.230 -qed
169.231 -
169.232 -end
170.1 --- a/src/HOLCF/Fixrec.thy Sat Nov 27 14:34:54 2010 -0800
170.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
170.3 @@ -1,252 +0,0 @@
170.4 -(* Title: HOLCF/Fixrec.thy
170.5 - Author: Amber Telfer and Brian Huffman
170.6 -*)
170.7 -
170.8 -header "Package for defining recursive functions in HOLCF"
170.9 -
170.10 -theory Fixrec
170.11 -imports Plain_HOLCF
170.12 -uses
170.13 - ("Tools/holcf_library.ML")
170.14 - ("Tools/fixrec.ML")
170.15 -begin
170.16 -
170.17 -subsection {* Pattern-match monad *}
170.18 -
170.19 -default_sort cpo
170.20 -
170.21 -pcpodef (open) 'a match = "UNIV::(one ++ 'a u) set"
170.22 -by simp_all
170.23 -
170.24 -definition
170.25 - fail :: "'a match" where
170.26 - "fail = Abs_match (sinl\<cdot>ONE)"
170.27 -
170.28 -definition
170.29 - succeed :: "'a \<rightarrow> 'a match" where
170.30 - "succeed = (\<Lambda> x. Abs_match (sinr\<cdot>(up\<cdot>x)))"
170.31 -
170.32 -lemma matchE [case_names bottom fail succeed, cases type: match]:
170.33 - "\<lbrakk>p = \<bottom> \<Longrightarrow> Q; p = fail \<Longrightarrow> Q; \<And>x. p = succeed\<cdot>x \<Longrightarrow> Q\<rbrakk> \<Longrightarrow> Q"
170.34 -unfolding fail_def succeed_def
170.35 -apply (cases p, rename_tac r)
170.36 -apply (rule_tac p=r in ssumE, simp add: Abs_match_strict)
170.37 -apply (rule_tac p=x in oneE, simp, simp)
170.38 -apply (rule_tac p=y in upE, simp, simp add: cont_Abs_match)
170.39 -done
170.40 -
170.41 -lemma succeed_defined [simp]: "succeed\<cdot>x \<noteq> \<bottom>"
170.42 -by (simp add: succeed_def cont_Abs_match Abs_match_defined)
170.43 -
170.44 -lemma fail_defined [simp]: "fail \<noteq> \<bottom>"
170.45 -by (simp add: fail_def Abs_match_defined)
170.46 -
170.47 -lemma succeed_eq [simp]: "(succeed\<cdot>x = succeed\<cdot>y) = (x = y)"
170.48 -by (simp add: succeed_def cont_Abs_match Abs_match_inject)
170.49 -
170.50 -lemma succeed_neq_fail [simp]:
170.51 - "succeed\<cdot>x \<noteq> fail" "fail \<noteq> succeed\<cdot>x"
170.52 -by (simp_all add: succeed_def fail_def cont_Abs_match Abs_match_inject)
170.53 -
170.54 -subsubsection {* Run operator *}
170.55 -
170.56 -definition
170.57 - run :: "'a match \<rightarrow> 'a::pcpo" where
170.58 - "run = (\<Lambda> m. sscase\<cdot>\<bottom>\<cdot>(fup\<cdot>ID)\<cdot>(Rep_match m))"
170.59 -
170.60 -text {* rewrite rules for run *}
170.61 -
170.62 -lemma run_strict [simp]: "run\<cdot>\<bottom> = \<bottom>"
170.63 -unfolding run_def
170.64 -by (simp add: cont_Rep_match Rep_match_strict)
170.65 -
170.66 -lemma run_fail [simp]: "run\<cdot>fail = \<bottom>"
170.67 -unfolding run_def fail_def
170.68 -by (simp add: cont_Rep_match Abs_match_inverse)
170.69 -
170.70 -lemma run_succeed [simp]: "run\<cdot>(succeed\<cdot>x) = x"
170.71 -unfolding run_def succeed_def
170.72 -by (simp add: cont_Rep_match cont_Abs_match Abs_match_inverse)
170.73 -
170.74 -subsubsection {* Monad plus operator *}
170.75 -
170.76 -definition
170.77 - mplus :: "'a match \<rightarrow> 'a match \<rightarrow> 'a match" where
170.78 - "mplus = (\<Lambda> m1 m2. sscase\<cdot>(\<Lambda> _. m2)\<cdot>(\<Lambda> _. m1)\<cdot>(Rep_match m1))"
170.79 -
170.80 -abbreviation
170.81 - mplus_syn :: "['a match, 'a match] \<Rightarrow> 'a match" (infixr "+++" 65) where
170.82 - "m1 +++ m2 == mplus\<cdot>m1\<cdot>m2"
170.83 -
170.84 -text {* rewrite rules for mplus *}
170.85 -
170.86 -lemmas cont2cont_Rep_match = cont_Rep_match [THEN cont_compose]
170.87 -
170.88 -lemma mplus_strict [simp]: "\<bottom> +++ m = \<bottom>"
170.89 -unfolding mplus_def
170.90 -by (simp add: cont2cont_Rep_match Rep_match_strict)
170.91 -
170.92 -lemma mplus_fail [simp]: "fail +++ m = m"
170.93 -unfolding mplus_def fail_def
170.94 -by (simp add: cont2cont_Rep_match Abs_match_inverse)
170.95 -
170.96 -lemma mplus_succeed [simp]: "succeed\<cdot>x +++ m = succeed\<cdot>x"
170.97 -unfolding mplus_def succeed_def
170.98 -by (simp add: cont2cont_Rep_match cont_Abs_match Abs_match_inverse)
170.99 -
170.100 -lemma mplus_fail2 [simp]: "m +++ fail = m"
170.101 -by (cases m, simp_all)
170.102 -
170.103 -lemma mplus_assoc: "(x +++ y) +++ z = x +++ (y +++ z)"
170.104 -by (cases x, simp_all)
170.105 -
170.106 -subsection {* Match functions for built-in types *}
170.107 -
170.108 -default_sort pcpo
170.109 -
170.110 -definition
170.111 - match_bottom :: "'a \<rightarrow> 'c match \<rightarrow> 'c match"
170.112 -where
170.113 - "match_bottom = (\<Lambda> x k. seq\<cdot>x\<cdot>fail)"
170.114 -
170.115 -definition
170.116 - match_Pair :: "'a::cpo \<times> 'b::cpo \<rightarrow> ('a \<rightarrow> 'b \<rightarrow> 'c match) \<rightarrow> 'c match"
170.117 -where
170.118 - "match_Pair = (\<Lambda> x k. csplit\<cdot>k\<cdot>x)"
170.119 -
170.120 -definition
170.121 - match_spair :: "'a \<otimes> 'b \<rightarrow> ('a \<rightarrow> 'b \<rightarrow> 'c match) \<rightarrow> 'c match"
170.122 -where
170.123 - "match_spair = (\<Lambda> x k. ssplit\<cdot>k\<cdot>x)"
170.124 -
170.125 -definition
170.126 - match_sinl :: "'a \<oplus> 'b \<rightarrow> ('a \<rightarrow> 'c match) \<rightarrow> 'c match"
170.127 -where
170.128 - "match_sinl = (\<Lambda> x k. sscase\<cdot>k\<cdot>(\<Lambda> b. fail)\<cdot>x)"
170.129 -
170.130 -definition
170.131 - match_sinr :: "'a \<oplus> 'b \<rightarrow> ('b \<rightarrow> 'c match) \<rightarrow> 'c match"
170.132 -where
170.133 - "match_sinr = (\<Lambda> x k. sscase\<cdot>(\<Lambda> a. fail)\<cdot>k\<cdot>x)"
170.134 -
170.135 -definition
170.136 - match_up :: "'a::cpo u \<rightarrow> ('a \<rightarrow> 'c match) \<rightarrow> 'c match"
170.137 -where
170.138 - "match_up = (\<Lambda> x k. fup\<cdot>k\<cdot>x)"
170.139 -
170.140 -definition
170.141 - match_ONE :: "one \<rightarrow> 'c match \<rightarrow> 'c match"
170.142 -where
170.143 - "match_ONE = (\<Lambda> ONE k. k)"
170.144 -
170.145 -definition
170.146 - match_TT :: "tr \<rightarrow> 'c match \<rightarrow> 'c match"
170.147 -where
170.148 - "match_TT = (\<Lambda> x k. If x then k else fail)"
170.149 -
170.150 -definition
170.151 - match_FF :: "tr \<rightarrow> 'c match \<rightarrow> 'c match"
170.152 -where
170.153 - "match_FF = (\<Lambda> x k. If x then fail else k)"
170.154 -
170.155 -lemma match_bottom_simps [simp]:
170.156 - "match_bottom\<cdot>\<bottom>\<cdot>k = \<bottom>"
170.157 - "x \<noteq> \<bottom> \<Longrightarrow> match_bottom\<cdot>x\<cdot>k = fail"
170.158 -by (simp_all add: match_bottom_def)
170.159 -
170.160 -lemma match_Pair_simps [simp]:
170.161 - "match_Pair\<cdot>(x, y)\<cdot>k = k\<cdot>x\<cdot>y"
170.162 -by (simp_all add: match_Pair_def)
170.163 -
170.164 -lemma match_spair_simps [simp]:
170.165 - "\<lbrakk>x \<noteq> \<bottom>; y \<noteq> \<bottom>\<rbrakk> \<Longrightarrow> match_spair\<cdot>(:x, y:)\<cdot>k = k\<cdot>x\<cdot>y"
170.166 - "match_spair\<cdot>\<bottom>\<cdot>k = \<bottom>"
170.167 -by (simp_all add: match_spair_def)
170.168 -
170.169 -lemma match_sinl_simps [simp]:
170.170 - "x \<noteq> \<bottom> \<Longrightarrow> match_sinl\<cdot>(sinl\<cdot>x)\<cdot>k = k\<cdot>x"
170.171 - "y \<noteq> \<bottom> \<Longrightarrow> match_sinl\<cdot>(sinr\<cdot>y)\<cdot>k = fail"
170.172 - "match_sinl\<cdot>\<bottom>\<cdot>k = \<bottom>"
170.173 -by (simp_all add: match_sinl_def)
170.174 -
170.175 -lemma match_sinr_simps [simp]:
170.176 - "x \<noteq> \<bottom> \<Longrightarrow> match_sinr\<cdot>(sinl\<cdot>x)\<cdot>k = fail"
170.177 - "y \<noteq> \<bottom> \<Longrightarrow> match_sinr\<cdot>(sinr\<cdot>y)\<cdot>k = k\<cdot>y"
170.178 - "match_sinr\<cdot>\<bottom>\<cdot>k = \<bottom>"
170.179 -by (simp_all add: match_sinr_def)
170.180 -
170.181 -lemma match_up_simps [simp]:
170.182 - "match_up\<cdot>(up\<cdot>x)\<cdot>k = k\<cdot>x"
170.183 - "match_up\<cdot>\<bottom>\<cdot>k = \<bottom>"
170.184 -by (simp_all add: match_up_def)
170.185 -
170.186 -lemma match_ONE_simps [simp]:
170.187 - "match_ONE\<cdot>ONE\<cdot>k = k"
170.188 - "match_ONE\<cdot>\<bottom>\<cdot>k = \<bottom>"
170.189 -by (simp_all add: match_ONE_def)
170.190 -
170.191 -lemma match_TT_simps [simp]:
170.192 - "match_TT\<cdot>TT\<cdot>k = k"
170.193 - "match_TT\<cdot>FF\<cdot>k = fail"
170.194 - "match_TT\<cdot>\<bottom>\<cdot>k = \<bottom>"
170.195 -by (simp_all add: match_TT_def)
170.196 -
170.197 -lemma match_FF_simps [simp]:
170.198 - "match_FF\<cdot>FF\<cdot>k = k"
170.199 - "match_FF\<cdot>TT\<cdot>k = fail"
170.200 - "match_FF\<cdot>\<bottom>\<cdot>k = \<bottom>"
170.201 -by (simp_all add: match_FF_def)
170.202 -
170.203 -subsection {* Mutual recursion *}
170.204 -
170.205 -text {*
170.206 - The following rules are used to prove unfolding theorems from
170.207 - fixed-point definitions of mutually recursive functions.
170.208 -*}
170.209 -
170.210 -lemma Pair_equalI: "\<lbrakk>x \<equiv> fst p; y \<equiv> snd p\<rbrakk> \<Longrightarrow> (x, y) \<equiv> p"
170.211 -by simp
170.212 -
170.213 -lemma Pair_eqD1: "(x, y) = (x', y') \<Longrightarrow> x = x'"
170.214 -by simp
170.215 -
170.216 -lemma Pair_eqD2: "(x, y) = (x', y') \<Longrightarrow> y = y'"
170.217 -by simp
170.218 -
170.219 -lemma def_cont_fix_eq:
170.220 - "\<lbrakk>f \<equiv> fix\<cdot>(Abs_cfun F); cont F\<rbrakk> \<Longrightarrow> f = F f"
170.221 -by (simp, subst fix_eq, simp)
170.222 -
170.223 -lemma def_cont_fix_ind:
170.224 - "\<lbrakk>f \<equiv> fix\<cdot>(Abs_cfun F); cont F; adm P; P \<bottom>; \<And>x. P x \<Longrightarrow> P (F x)\<rbrakk> \<Longrightarrow> P f"
170.225 -by (simp add: fix_ind)
170.226 -
170.227 -text {* lemma for proving rewrite rules *}
170.228 -
170.229 -lemma ssubst_lhs: "\<lbrakk>t = s; P s = Q\<rbrakk> \<Longrightarrow> P t = Q"
170.230 -by simp
170.231 -
170.232 -
170.233 -subsection {* Initializing the fixrec package *}
170.234 -
170.235 -use "Tools/holcf_library.ML"
170.236 -use "Tools/fixrec.ML"
170.237 -
170.238 -setup {* Fixrec.setup *}
170.239 -
170.240 -setup {*
170.241 - Fixrec.add_matchers
170.242 - [ (@{const_name up}, @{const_name match_up}),
170.243 - (@{const_name sinl}, @{const_name match_sinl}),
170.244 - (@{const_name sinr}, @{const_name match_sinr}),
170.245 - (@{const_name spair}, @{const_name match_spair}),
170.246 - (@{const_name Pair}, @{const_name match_Pair}),
170.247 - (@{const_name ONE}, @{const_name match_ONE}),
170.248 - (@{const_name TT}, @{const_name match_TT}),
170.249 - (@{const_name FF}, @{const_name match_FF}),
170.250 - (@{const_name UU}, @{const_name match_bottom}) ]
170.251 -*}
170.252 -
170.253 -hide_const (open) succeed fail run
170.254 -
170.255 -end
171.1 --- a/src/HOLCF/Fun_Cpo.thy Sat Nov 27 14:34:54 2010 -0800
171.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
171.3 @@ -1,179 +0,0 @@
171.4 -(* Title: HOLCF/Fun_Cpo.thy
171.5 - Author: Franz Regensburger
171.6 - Author: Brian Huffman
171.7 -*)
171.8 -
171.9 -header {* Class instances for the full function space *}
171.10 -
171.11 -theory Fun_Cpo
171.12 -imports Adm
171.13 -begin
171.14 -
171.15 -subsection {* Full function space is a partial order *}
171.16 -
171.17 -instantiation "fun" :: (type, below) below
171.18 -begin
171.19 -
171.20 -definition
171.21 - below_fun_def: "(op \<sqsubseteq>) \<equiv> (\<lambda>f g. \<forall>x. f x \<sqsubseteq> g x)"
171.22 -
171.23 -instance ..
171.24 -end
171.25 -
171.26 -instance "fun" :: (type, po) po
171.27 -proof
171.28 - fix f :: "'a \<Rightarrow> 'b"
171.29 - show "f \<sqsubseteq> f"
171.30 - by (simp add: below_fun_def)
171.31 -next
171.32 - fix f g :: "'a \<Rightarrow> 'b"
171.33 - assume "f \<sqsubseteq> g" and "g \<sqsubseteq> f" thus "f = g"
171.34 - by (simp add: below_fun_def fun_eq_iff below_antisym)
171.35 -next
171.36 - fix f g h :: "'a \<Rightarrow> 'b"
171.37 - assume "f \<sqsubseteq> g" and "g \<sqsubseteq> h" thus "f \<sqsubseteq> h"
171.38 - unfolding below_fun_def by (fast elim: below_trans)
171.39 -qed
171.40 -
171.41 -lemma fun_below_iff: "f \<sqsubseteq> g \<longleftrightarrow> (\<forall>x. f x \<sqsubseteq> g x)"
171.42 -by (simp add: below_fun_def)
171.43 -
171.44 -lemma fun_belowI: "(\<And>x. f x \<sqsubseteq> g x) \<Longrightarrow> f \<sqsubseteq> g"
171.45 -by (simp add: below_fun_def)
171.46 -
171.47 -lemma fun_belowD: "f \<sqsubseteq> g \<Longrightarrow> f x \<sqsubseteq> g x"
171.48 -by (simp add: below_fun_def)
171.49 -
171.50 -subsection {* Full function space is chain complete *}
171.51 -
171.52 -text {* Properties of chains of functions. *}
171.53 -
171.54 -lemma fun_chain_iff: "chain S \<longleftrightarrow> (\<forall>x. chain (\<lambda>i. S i x))"
171.55 -unfolding chain_def fun_below_iff by auto
171.56 -
171.57 -lemma ch2ch_fun: "chain S \<Longrightarrow> chain (\<lambda>i. S i x)"
171.58 -by (simp add: chain_def below_fun_def)
171.59 -
171.60 -lemma ch2ch_lambda: "(\<And>x. chain (\<lambda>i. S i x)) \<Longrightarrow> chain S"
171.61 -by (simp add: chain_def below_fun_def)
171.62 -
171.63 -text {* upper bounds of function chains yield upper bound in the po range *}
171.64 -
171.65 -lemma ub2ub_fun:
171.66 - "range S <| u \<Longrightarrow> range (\<lambda>i. S i x) <| u x"
171.67 -by (auto simp add: is_ub_def below_fun_def)
171.68 -
171.69 -text {* Type @{typ "'a::type => 'b::cpo"} is chain complete *}
171.70 -
171.71 -lemma is_lub_lambda:
171.72 - "(\<And>x. range (\<lambda>i. Y i x) <<| f x) \<Longrightarrow> range Y <<| f"
171.73 -unfolding is_lub_def is_ub_def below_fun_def by simp
171.74 -
171.75 -lemma lub_fun:
171.76 - "chain (S::nat \<Rightarrow> 'a::type \<Rightarrow> 'b::cpo)
171.77 - \<Longrightarrow> range S <<| (\<lambda>x. \<Squnion>i. S i x)"
171.78 -apply (rule is_lub_lambda)
171.79 -apply (rule cpo_lubI)
171.80 -apply (erule ch2ch_fun)
171.81 -done
171.82 -
171.83 -lemma thelub_fun:
171.84 - "chain (S::nat \<Rightarrow> 'a::type \<Rightarrow> 'b::cpo)
171.85 - \<Longrightarrow> (\<Squnion>i. S i) = (\<lambda>x. \<Squnion>i. S i x)"
171.86 -by (rule lub_fun [THEN lub_eqI])
171.87 -
171.88 -instance "fun" :: (type, cpo) cpo
171.89 -by intro_classes (rule exI, erule lub_fun)
171.90 -
171.91 -subsection {* Chain-finiteness of function space *}
171.92 -
171.93 -lemma maxinch2maxinch_lambda:
171.94 - "(\<And>x. max_in_chain n (\<lambda>i. S i x)) \<Longrightarrow> max_in_chain n S"
171.95 -unfolding max_in_chain_def fun_eq_iff by simp
171.96 -
171.97 -lemma maxinch_mono:
171.98 - "\<lbrakk>max_in_chain i Y; i \<le> j\<rbrakk> \<Longrightarrow> max_in_chain j Y"
171.99 -unfolding max_in_chain_def
171.100 -proof (intro allI impI)
171.101 - fix k
171.102 - assume Y: "\<forall>n\<ge>i. Y i = Y n"
171.103 - assume ij: "i \<le> j"
171.104 - assume jk: "j \<le> k"
171.105 - from ij jk have ik: "i \<le> k" by simp
171.106 - from Y ij have Yij: "Y i = Y j" by simp
171.107 - from Y ik have Yik: "Y i = Y k" by simp
171.108 - from Yij Yik show "Y j = Y k" by auto
171.109 -qed
171.110 -
171.111 -instance "fun" :: (type, discrete_cpo) discrete_cpo
171.112 -proof
171.113 - fix f g :: "'a \<Rightarrow> 'b"
171.114 - show "f \<sqsubseteq> g \<longleftrightarrow> f = g"
171.115 - unfolding fun_below_iff fun_eq_iff
171.116 - by simp
171.117 -qed
171.118 -
171.119 -subsection {* Full function space is pointed *}
171.120 -
171.121 -lemma minimal_fun: "(\<lambda>x. \<bottom>) \<sqsubseteq> f"
171.122 -by (simp add: below_fun_def)
171.123 -
171.124 -instance "fun" :: (type, pcpo) pcpo
171.125 -by default (fast intro: minimal_fun)
171.126 -
171.127 -lemma inst_fun_pcpo: "\<bottom> = (\<lambda>x. \<bottom>)"
171.128 -by (rule minimal_fun [THEN UU_I, symmetric])
171.129 -
171.130 -lemma app_strict [simp]: "\<bottom> x = \<bottom>"
171.131 -by (simp add: inst_fun_pcpo)
171.132 -
171.133 -lemma lambda_strict: "(\<lambda>x. \<bottom>) = \<bottom>"
171.134 -by (rule UU_I, rule minimal_fun)
171.135 -
171.136 -subsection {* Propagation of monotonicity and continuity *}
171.137 -
171.138 -text {* The lub of a chain of monotone functions is monotone. *}
171.139 -
171.140 -lemma adm_monofun: "adm monofun"
171.141 -by (rule admI, simp add: thelub_fun fun_chain_iff monofun_def lub_mono)
171.142 -
171.143 -text {* The lub of a chain of continuous functions is continuous. *}
171.144 -
171.145 -lemma adm_cont: "adm cont"
171.146 -by (rule admI, simp add: thelub_fun fun_chain_iff)
171.147 -
171.148 -text {* Function application preserves monotonicity and continuity. *}
171.149 -
171.150 -lemma mono2mono_fun: "monofun f \<Longrightarrow> monofun (\<lambda>x. f x y)"
171.151 -by (simp add: monofun_def fun_below_iff)
171.152 -
171.153 -lemma cont2cont_fun: "cont f \<Longrightarrow> cont (\<lambda>x. f x y)"
171.154 -apply (rule contI2)
171.155 -apply (erule cont2mono [THEN mono2mono_fun])
171.156 -apply (simp add: cont2contlubE thelub_fun ch2ch_cont)
171.157 -done
171.158 -
171.159 -lemma cont_fun: "cont (\<lambda>f. f x)"
171.160 -using cont_id by (rule cont2cont_fun)
171.161 -
171.162 -text {*
171.163 - Lambda abstraction preserves monotonicity and continuity.
171.164 - (Note @{text "(\<lambda>x. \<lambda>y. f x y) = f"}.)
171.165 -*}
171.166 -
171.167 -lemma mono2mono_lambda:
171.168 - assumes f: "\<And>y. monofun (\<lambda>x. f x y)" shows "monofun f"
171.169 -using f by (simp add: monofun_def fun_below_iff)
171.170 -
171.171 -lemma cont2cont_lambda [simp]:
171.172 - assumes f: "\<And>y. cont (\<lambda>x. f x y)" shows "cont f"
171.173 -by (rule contI, rule is_lub_lambda, rule contE [OF f])
171.174 -
171.175 -text {* What D.A.Schmidt calls continuity of abstraction; never used here *}
171.176 -
171.177 -lemma contlub_lambda:
171.178 - "(\<And>x::'a::type. chain (\<lambda>i. S i x::'b::cpo))
171.179 - \<Longrightarrow> (\<lambda>x. \<Squnion>i. S i x) = (\<Squnion>i. (\<lambda>x. S i x))"
171.180 -by (simp add: thelub_fun ch2ch_lambda)
171.181 -
171.182 -end
172.1 --- a/src/HOLCF/HOLCF.thy Sat Nov 27 14:34:54 2010 -0800
172.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
172.3 @@ -1,39 +0,0 @@
172.4 -(* Title: HOLCF/HOLCF.thy
172.5 - Author: Franz Regensburger
172.6 -
172.7 -HOLCF -- a semantic extension of HOL by the LCF logic.
172.8 -*)
172.9 -
172.10 -theory HOLCF
172.11 -imports
172.12 - Main
172.13 - Domain
172.14 - Powerdomains
172.15 -begin
172.16 -
172.17 -default_sort "domain"
172.18 -
172.19 -ML {* path_add "~~/src/HOLCF/Library" *}
172.20 -
172.21 -text {* Legacy theorem names deprecated after Isabelle2009-2: *}
172.22 -
172.23 -lemmas expand_fun_below = fun_below_iff
172.24 -lemmas below_fun_ext = fun_belowI
172.25 -lemmas expand_cfun_eq = cfun_eq_iff
172.26 -lemmas ext_cfun = cfun_eqI
172.27 -lemmas expand_cfun_below = cfun_below_iff
172.28 -lemmas below_cfun_ext = cfun_belowI
172.29 -lemmas monofun_fun_fun = fun_belowD
172.30 -lemmas monofun_fun_arg = monofunE
172.31 -lemmas monofun_lub_fun = adm_monofun [THEN admD]
172.32 -lemmas cont_lub_fun = adm_cont [THEN admD]
172.33 -lemmas cont2cont_Rep_CFun = cont2cont_APP
172.34 -lemmas cont_Rep_CFun_app = cont_APP_app
172.35 -lemmas cont_Rep_CFun_app_app = cont_APP_app_app
172.36 -lemmas cont_cfun_fun = cont_Rep_cfun1 [THEN contE]
172.37 -lemmas cont_cfun_arg = cont_Rep_cfun2 [THEN contE]
172.38 -(*
172.39 -lemmas thelubI = lub_eqI
172.40 -*)
172.41 -
172.42 -end
173.1 --- a/src/HOLCF/IMP/Denotational.thy Sat Nov 27 14:34:54 2010 -0800
173.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
173.3 @@ -1,78 +0,0 @@
173.4 -(* Title: HOLCF/IMP/Denotational.thy
173.5 - Author: Tobias Nipkow and Robert Sandner, TUM
173.6 - Copyright 1996 TUM
173.7 -*)
173.8 -
173.9 -header "Denotational Semantics of Commands in HOLCF"
173.10 -
173.11 -theory Denotational imports HOLCF "../../HOL/IMP/Natural" begin
173.12 -
173.13 -text {* Disable conflicting syntax from HOL Map theory. *}
173.14 -
173.15 -no_syntax
173.16 - "_maplet" :: "['a, 'a] => maplet" ("_ /|->/ _")
173.17 - "_maplets" :: "['a, 'a] => maplet" ("_ /[|->]/ _")
173.18 - "" :: "maplet => maplets" ("_")
173.19 - "_Maplets" :: "[maplet, maplets] => maplets" ("_,/ _")
173.20 - "_MapUpd" :: "['a ~=> 'b, maplets] => 'a ~=> 'b" ("_/'(_')" [900,0]900)
173.21 - "_Map" :: "maplets => 'a ~=> 'b" ("(1[_])")
173.22 -
173.23 -subsection "Definition"
173.24 -
173.25 -definition
173.26 - dlift :: "(('a::type) discr -> 'b::pcpo) => ('a lift -> 'b)" where
173.27 - "dlift f = (LAM x. case x of UU => UU | Def y => f\<cdot>(Discr y))"
173.28 -
173.29 -primrec D :: "com => state discr -> state lift"
173.30 -where
173.31 - "D(\<SKIP>) = (LAM s. Def(undiscr s))"
173.32 -| "D(X :== a) = (LAM s. Def((undiscr s)[X \<mapsto> a(undiscr s)]))"
173.33 -| "D(c0 ; c1) = (dlift(D c1) oo (D c0))"
173.34 -| "D(\<IF> b \<THEN> c1 \<ELSE> c2) =
173.35 - (LAM s. if b (undiscr s) then (D c1)\<cdot>s else (D c2)\<cdot>s)"
173.36 -| "D(\<WHILE> b \<DO> c) =
173.37 - fix\<cdot>(LAM w s. if b (undiscr s) then (dlift w)\<cdot>((D c)\<cdot>s)
173.38 - else Def(undiscr s))"
173.39 -
173.40 -subsection
173.41 - "Equivalence of Denotational Semantics in HOLCF and Evaluation Semantics in HOL"
173.42 -
173.43 -lemma dlift_Def [simp]: "dlift f\<cdot>(Def x) = f\<cdot>(Discr x)"
173.44 - by (simp add: dlift_def)
173.45 -
173.46 -lemma cont_dlift [iff]: "cont (%f. dlift f)"
173.47 - by (simp add: dlift_def)
173.48 -
173.49 -lemma dlift_is_Def [simp]:
173.50 - "(dlift f\<cdot>l = Def y) = (\<exists>x. l = Def x \<and> f\<cdot>(Discr x) = Def y)"
173.51 - by (simp add: dlift_def split: lift.split)
173.52 -
173.53 -lemma eval_implies_D: "\<langle>c,s\<rangle> \<longrightarrow>\<^sub>c t ==> D c\<cdot>(Discr s) = (Def t)"
173.54 - apply (induct set: evalc)
173.55 - apply simp_all
173.56 - apply (subst fix_eq)
173.57 - apply simp
173.58 - apply (subst fix_eq)
173.59 - apply simp
173.60 - done
173.61 -
173.62 -lemma D_implies_eval: "!s t. D c\<cdot>(Discr s) = (Def t) --> \<langle>c,s\<rangle> \<longrightarrow>\<^sub>c t"
173.63 - apply (induct c)
173.64 - apply simp
173.65 - apply simp
173.66 - apply force
173.67 - apply (simp (no_asm))
173.68 - apply force
173.69 - apply (simp (no_asm))
173.70 - apply (rule fix_ind)
173.71 - apply (fast intro!: adm_lemmas adm_chfindom ax_flat)
173.72 - apply (simp (no_asm))
173.73 - apply (simp (no_asm))
173.74 - apply safe
173.75 - apply fast
173.76 - done
173.77 -
173.78 -theorem D_is_eval: "(D c\<cdot>(Discr s) = (Def t)) = (\<langle>c,s\<rangle> \<longrightarrow>\<^sub>c t)"
173.79 - by (fast elim!: D_implies_eval [rule_format] eval_implies_D)
173.80 -
173.81 -end
174.1 --- a/src/HOLCF/IMP/HoareEx.thy Sat Nov 27 14:34:54 2010 -0800
174.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
174.3 @@ -1,33 +0,0 @@
174.4 -(* Title: HOLCF/IMP/HoareEx.thy
174.5 - Author: Tobias Nipkow, TUM
174.6 - Copyright 1997 TUM
174.7 -*)
174.8 -
174.9 -header "Correctness of Hoare by Fixpoint Reasoning"
174.10 -
174.11 -theory HoareEx imports Denotational begin
174.12 -
174.13 -text {*
174.14 - An example from the HOLCF paper by Müller, Nipkow, Oheimb, Slotosch
174.15 - \cite{MuellerNvOS99}. It demonstrates fixpoint reasoning by showing
174.16 - the correctness of the Hoare rule for while-loops.
174.17 -*}
174.18 -
174.19 -types assn = "state => bool"
174.20 -
174.21 -definition
174.22 - hoare_valid :: "[assn, com, assn] => bool" ("|= {(1_)}/ (_)/ {(1_)}" 50) where
174.23 - "|= {A} c {B} = (\<forall>s t. A s \<and> D c $(Discr s) = Def t --> B t)"
174.24 -
174.25 -lemma WHILE_rule_sound:
174.26 - "|= {A} c {A} ==> |= {A} \<WHILE> b \<DO> c {\<lambda>s. A s \<and> \<not> b s}"
174.27 - apply (unfold hoare_valid_def)
174.28 - apply (simp (no_asm))
174.29 - apply (rule fix_ind)
174.30 - apply (simp (no_asm)) -- "simplifier with enhanced @{text adm}-tactic"
174.31 - apply (simp (no_asm))
174.32 - apply (simp (no_asm))
174.33 - apply blast
174.34 - done
174.35 -
174.36 -end
175.1 --- a/src/HOLCF/IMP/README.html Sat Nov 27 14:34:54 2010 -0800
175.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
175.3 @@ -1,18 +0,0 @@
175.4 -<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN" "http://www.w3.org/TR/html4/loose.dtd">
175.5 -
175.6 -<HTML>
175.7 -
175.8 -<HEAD>
175.9 - <meta http-equiv="Content-Type" content="text/html; charset=iso-8859-1">
175.10 - <TITLE>HOLCF/IMP/README</TITLE>
175.11 -</HEAD>
175.12 -
175.13 -<BODY>
175.14 -
175.15 -<H2>IMP -- A <KBD>WHILE</KBD>-language and its Semantics</H2>
175.16 -
175.17 -This is the HOLCF-based denotational semantics of a simple
175.18 -<tt>WHILE</tt>-language. For a full description see <A
175.19 -HREF="../../HOL/IMP/index.html">HOL/IMP</A>.
175.20 -</BODY>
175.21 -</HTML>
176.1 --- a/src/HOLCF/IMP/ROOT.ML Sat Nov 27 14:34:54 2010 -0800
176.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
176.3 @@ -1,1 +0,0 @@
176.4 -use_thys ["HoareEx"];
177.1 --- a/src/HOLCF/IMP/document/root.bib Sat Nov 27 14:34:54 2010 -0800
177.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
177.3 @@ -1,7 +0,0 @@
177.4 -@string{JFP="J. Functional Programming"}
177.5 -
177.6 -@article{MuellerNvOS99,
177.7 -author=
177.8 -{Olaf M{\"u}ller and Tobias Nipkow and Oheimb, David von and Oskar Slotosch},
177.9 -title={{HOLCF = HOL + LCF}},journal=JFP,year=1999,volume=9,pages={191--223}}
177.10 -
178.1 --- a/src/HOLCF/IMP/document/root.tex Sat Nov 27 14:34:54 2010 -0800
178.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
178.3 @@ -1,36 +0,0 @@
178.4 -
178.5 -\documentclass[11pt,a4paper]{article}
178.6 -\usepackage[latin1]{inputenc}
178.7 -\usepackage{isabelle,isabellesym}
178.8 -\usepackage{pdfsetup}
178.9 -
178.10 -\urlstyle{rm}
178.11 -
178.12 -% pretty printing for the Com language
178.13 -%\newcommand{\CMD}[1]{\isatext{\bf\sffamily#1}}
178.14 -\newcommand{\CMD}[1]{\isatext{\rm\sffamily#1}}
178.15 -\newcommand{\isasymSKIP}{\CMD{skip}}
178.16 -\newcommand{\isasymIF}{\CMD{if}}
178.17 -\newcommand{\isasymTHEN}{\CMD{then}}
178.18 -\newcommand{\isasymELSE}{\CMD{else}}
178.19 -\newcommand{\isasymWHILE}{\CMD{while}}
178.20 -\newcommand{\isasymDO}{\CMD{do}}
178.21 -
178.22 -\addtolength{\hoffset}{-1cm}
178.23 -\addtolength{\textwidth}{2cm}
178.24 -
178.25 -\begin{document}
178.26 -
178.27 -\title{IMP in HOLCF}
178.28 -\author{Tobias Nipkow and Robert Sandner}
178.29 -\maketitle
178.30 -
178.31 -\tableofcontents
178.32 -
178.33 -\parindent 0pt\parskip 0.5ex
178.34 -\input{session}
178.35 -
178.36 -\bibliographystyle{abbrv}
178.37 -\bibliography{root}
178.38 -
178.39 -\end{document}
179.1 --- a/src/HOLCF/IOA/ABP/Abschannel.thy Sat Nov 27 14:34:54 2010 -0800
179.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
179.3 @@ -1,89 +0,0 @@
179.4 -(* Title: HOLCF/IOA/ABP/Abschannel.thy
179.5 - Author: Olaf Müller
179.6 -*)
179.7 -
179.8 -header {* The transmission channel *}
179.9 -
179.10 -theory Abschannel
179.11 -imports IOA Action Lemmas
179.12 -begin
179.13 -
179.14 -datatype 'a abs_action = S 'a | R 'a
179.15 -
179.16 -
179.17 -(**********************************************************
179.18 - G e n e r i c C h a n n e l
179.19 - *********************************************************)
179.20 -
179.21 -definition
179.22 - ch_asig :: "'a abs_action signature" where
179.23 - "ch_asig = (UN b. {S(b)}, UN b. {R(b)}, {})"
179.24 -
179.25 -definition
179.26 - ch_trans :: "('a abs_action, 'a list)transition set" where
179.27 - "ch_trans =
179.28 - {tr. let s = fst(tr);
179.29 - t = snd(snd(tr))
179.30 - in
179.31 - case fst(snd(tr))
179.32 - of S(b) => ((t = s) | (t = s @ [b])) |
179.33 - R(b) => s ~= [] &
179.34 - b = hd(s) &
179.35 - ((t = s) | (t = tl(s)))}"
179.36 -
179.37 -definition
179.38 - ch_ioa :: "('a abs_action, 'a list)ioa" where
179.39 - "ch_ioa = (ch_asig, {[]}, ch_trans,{},{})"
179.40 -
179.41 -
179.42 -(**********************************************************
179.43 - C o n c r e t e C h a n n e l s b y R e n a m i n g
179.44 - *********************************************************)
179.45 -
179.46 -definition
179.47 - rsch_actions :: "'m action => bool abs_action option" where
179.48 - "rsch_actions (akt) =
179.49 - (case akt of
179.50 - Next => None |
179.51 - S_msg(m) => None |
179.52 - R_msg(m) => None |
179.53 - S_pkt(packet) => None |
179.54 - R_pkt(packet) => None |
179.55 - S_ack(b) => Some(S(b)) |
179.56 - R_ack(b) => Some(R(b)))"
179.57 -
179.58 -definition
179.59 - srch_actions :: "'m action =>(bool * 'm) abs_action option" where
179.60 - "srch_actions akt =
179.61 - (case akt of
179.62 - Next => None |
179.63 - S_msg(m) => None |
179.64 - R_msg(m) => None |
179.65 - S_pkt(p) => Some(S(p)) |
179.66 - R_pkt(p) => Some(R(p)) |
179.67 - S_ack(b) => None |
179.68 - R_ack(b) => None)"
179.69 -
179.70 -definition
179.71 - srch_ioa :: "('m action, 'm packet list)ioa" where
179.72 - "srch_ioa = rename ch_ioa srch_actions"
179.73 -definition
179.74 - rsch_ioa :: "('m action, bool list)ioa" where
179.75 - "rsch_ioa = rename ch_ioa rsch_actions"
179.76 -
179.77 -definition
179.78 - srch_asig :: "'m action signature" where
179.79 - "srch_asig = asig_of(srch_ioa)"
179.80 -
179.81 -definition
179.82 - rsch_asig :: "'m action signature" where
179.83 - "rsch_asig = asig_of(rsch_ioa)"
179.84 -
179.85 -definition
179.86 - srch_trans :: "('m action, 'm packet list)transition set" where
179.87 - "srch_trans = trans_of(srch_ioa)"
179.88 -definition
179.89 - rsch_trans :: "('m action, bool list)transition set" where
179.90 - "rsch_trans = trans_of(rsch_ioa)"
179.91 -
179.92 -end
180.1 --- a/src/HOLCF/IOA/ABP/Abschannel_finite.thy Sat Nov 27 14:34:54 2010 -0800
180.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
180.3 @@ -1,61 +0,0 @@
180.4 -(* Title: HOLCF/IOA/ABP/Abschannels.thy
180.5 - Author: Olaf Müller
180.6 -*)
180.7 -
180.8 -header {* The transmission channel -- finite version *}
180.9 -
180.10 -theory Abschannel_finite
180.11 -imports Abschannel IOA Action Lemmas
180.12 -begin
180.13 -
180.14 -primrec reverse :: "'a list => 'a list"
180.15 -where
180.16 - reverse_Nil: "reverse([]) = []"
180.17 -| reverse_Cons: "reverse(x#xs) = reverse(xs)@[x]"
180.18 -
180.19 -definition
180.20 - ch_fin_asig :: "'a abs_action signature" where
180.21 - "ch_fin_asig = ch_asig"
180.22 -
180.23 -definition
180.24 - ch_fin_trans :: "('a abs_action, 'a list)transition set" where
180.25 - "ch_fin_trans =
180.26 - {tr. let s = fst(tr);
180.27 - t = snd(snd(tr))
180.28 - in
180.29 - case fst(snd(tr))
180.30 - of S(b) => ((t = s) |
180.31 - (if (b=hd(reverse(s)) & s~=[]) then t=s else t=s@[b])) |
180.32 - R(b) => s ~= [] &
180.33 - b = hd(s) &
180.34 - ((t = s) | (t = tl(s)))}"
180.35 -
180.36 -definition
180.37 - ch_fin_ioa :: "('a abs_action, 'a list)ioa" where
180.38 - "ch_fin_ioa = (ch_fin_asig, {[]}, ch_fin_trans,{},{})"
180.39 -
180.40 -definition
180.41 - srch_fin_ioa :: "('m action, 'm packet list)ioa" where
180.42 - "srch_fin_ioa = rename ch_fin_ioa srch_actions"
180.43 -
180.44 -definition
180.45 - rsch_fin_ioa :: "('m action, bool list)ioa" where
180.46 - "rsch_fin_ioa = rename ch_fin_ioa rsch_actions"
180.47 -
180.48 -definition
180.49 - srch_fin_asig :: "'m action signature" where
180.50 - "srch_fin_asig = asig_of(srch_fin_ioa)"
180.51 -
180.52 -definition
180.53 - rsch_fin_asig :: "'m action signature" where
180.54 - "rsch_fin_asig = asig_of(rsch_fin_ioa)"
180.55 -
180.56 -definition
180.57 - srch_fin_trans :: "('m action, 'm packet list)transition set" where
180.58 - "srch_fin_trans = trans_of(srch_fin_ioa)"
180.59 -
180.60 -definition
180.61 - rsch_fin_trans :: "('m action, bool list)transition set" where
180.62 - "rsch_fin_trans = trans_of(rsch_fin_ioa)"
180.63 -
180.64 -end
181.1 --- a/src/HOLCF/IOA/ABP/Action.thy Sat Nov 27 14:34:54 2010 -0800
181.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
181.3 @@ -1,16 +0,0 @@
181.4 -(* Title: HOLCF/IOA/ABP/Action.thy
181.5 - Author: Olaf Müller
181.6 -*)
181.7 -
181.8 -header {* The set of all actions of the system *}
181.9 -
181.10 -theory Action
181.11 -imports Packet
181.12 -begin
181.13 -
181.14 -datatype 'm action =
181.15 - Next | S_msg 'm | R_msg 'm
181.16 - | S_pkt "'m packet" | R_pkt "'m packet"
181.17 - | S_ack bool | R_ack bool
181.18 -
181.19 -end
182.1 --- a/src/HOLCF/IOA/ABP/Check.ML Sat Nov 27 14:34:54 2010 -0800
182.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
182.3 @@ -1,178 +0,0 @@
182.4 -(* Title: HOLCF/IOA/ABP/Check.ML
182.5 - Author: Olaf Mueller
182.6 -
182.7 -The Model Checker.
182.8 -*)
182.9 -
182.10 -structure Check =
182.11 -struct
182.12 -
182.13 -(* ----------------------------------------------------------------
182.14 - P r o t o t y p e M o d e l C h e c k e r
182.15 - ----------------------------------------------------------------*)
182.16 -
182.17 -fun check(extacts,intacts,string_of_a,startsI,string_of_s,
182.18 - nexts,hom,transA,startsS) =
182.19 - let fun check_s(s,unchecked,checked) =
182.20 - let fun check_sa a unchecked =
182.21 - let fun check_sas t unchecked =
182.22 - (if member (op =) extacts a then
182.23 - (if transA(hom s,a,hom t) then ( )
182.24 - else (writeln("Error: Mapping of Externals!");
182.25 - string_of_s s; writeln"";
182.26 - string_of_a a; writeln"";
182.27 - string_of_s t;writeln"";writeln"" ))
182.28 - else (if hom(s)=hom(t) then ( )
182.29 - else (writeln("Error: Mapping of Internals!");
182.30 - string_of_s s; writeln"";
182.31 - string_of_a a; writeln"";
182.32 - string_of_s t;writeln"";writeln"" ));
182.33 - if member (op =) checked t then unchecked else insert (op =) t unchecked)
182.34 - in fold check_sas (nexts s a) unchecked end;
182.35 - val unchecked' = fold check_sa (extacts @ intacts) unchecked
182.36 - in (if member (op =) startsI s then
182.37 - (if member (op =) startsS (hom s) then ()
182.38 - else writeln("Error: At start states!"))
182.39 - else ();
182.40 - checks(unchecked',s::checked)) end
182.41 - and checks([],_) = ()
182.42 - | checks(s::unchecked,checked) = check_s(s,unchecked,checked)
182.43 - in checks(startsI,[]) end;
182.44 -
182.45 -
182.46 -(* ------------------------------------------------------
182.47 - A B P E x a m p l e
182.48 - -------------------------------------------------------*)
182.49 -
182.50 -datatype msg = m | n | l;
182.51 -datatype act = Next | S_msg of msg | R_msg of msg
182.52 - | S_pkt of bool * msg | R_pkt of bool * msg
182.53 - | S_ack of bool | R_ack of bool;
182.54 -
182.55 -(* -------------------- Transition relation of Specification -----------*)
182.56 -
182.57 -fun transA((u,s),a,(v,t)) =
182.58 - (case a of
182.59 - Next => v andalso t = s |
182.60 - S_msg(q) => u andalso not(v) andalso t = s@[q] |
182.61 - R_msg(q) => u = v andalso s = (q::t) |
182.62 - S_pkt(b,q) => false |
182.63 - R_pkt(b,q) => false |
182.64 - S_ack(b) => false |
182.65 - R_ack(b) => false);
182.66 -
182.67 -
182.68 -(* ---------------------- Abstraction function --------------------------*)
182.69 -
182.70 -fun hom((env,p,a,q,b,_,_)) = (env,q@(if (a=b) then tl(p) else p));
182.71 -
182.72 -
182.73 -(* --------------------- Transition relation of Implementation ----------*)
182.74 -
182.75 -fun nexts (s as (env,p,a,q,b,ch1,ch2)) action =
182.76 - (case action of
182.77 - Next => if p=[] then [(true,p,a,q,b,ch1,ch2)] else [] |
182.78 - S_msg(mornorl) => if env then [(false,p@[mornorl],a,q,b,ch1,ch2)] else [] |
182.79 - R_msg(mornorl) => if (q<>[] andalso mornorl=hd(q))
182.80 - then [(env,p,a,tl(q),b,ch1,ch2)]
182.81 - else [] |
182.82 - S_pkt(h,mornorl) => if (p<>[] andalso mornorl=hd(p) andalso h=a)
182.83 - then (if (ch1<>[] andalso hd(rev(ch1))=(h,mornorl))
182.84 - then [s]
182.85 - else [s,(env,p,a,q,b,ch1@[(h,mornorl)],ch2)])
182.86 - else [] |
182.87 - R_pkt(h,mornorl) => if (ch1<>[] andalso hd(ch1)=(h,mornorl))
182.88 - then (if (h<>b andalso q=[])
182.89 - then [(env,p,a,q@[mornorl],not(b),ch1,ch2),
182.90 - (env,p,a,q@[mornorl],not(b),tl(ch1),ch2)]
182.91 - else [s,(env,p,a,q,b,tl(ch1),ch2)])
182.92 - else [] |
182.93 - S_ack(h) => if (h=b)
182.94 - then (if (ch2<>[] andalso h=hd(rev(ch2)))
182.95 - then [s]
182.96 - else [s,(env,p,a,q,b,ch1,ch2@[h])])
182.97 - else [] |
182.98 - R_ack(h) => if (ch2<>[] andalso hd(ch2)=h)
182.99 - then (if h=a
182.100 - then [(env,tl(p),not(a),q,b,ch1,ch2),
182.101 - (env,tl(p),not(a),q,b,ch1,tl(ch2))]
182.102 - else [s,(env,p,a,q,b,ch1,tl(ch2))])
182.103 - else [])
182.104 -
182.105 -
182.106 -val extactions = [Next,S_msg(m),R_msg(m),S_msg(n),R_msg(n),S_msg(l),R_msg(l)];
182.107 -val intactions = [S_pkt(true,m),R_pkt(true,m),S_ack(true),R_ack(true),
182.108 - S_pkt(false,m),R_pkt(false,m),S_ack(false),R_ack(false),
182.109 - S_pkt(true,n),R_pkt(true,n),S_pkt(true,l),R_pkt(true,l),
182.110 - S_pkt(false,n),R_pkt(false,n),S_pkt(false,l),R_pkt(false,l)];
182.111 -
182.112 -
182.113 -(* ------------------------------------
182.114 - Input / Output utilities
182.115 - ------------------------------------*)
182.116 -
182.117 -fun print_list (lpar, rpar, pre: 'a -> unit) (lll : 'a list) =
182.118 - let fun prec x = (Output.raw_stdout ","; pre x)
182.119 - in
182.120 - (case lll of
182.121 - [] => (Output.raw_stdout lpar; Output.raw_stdout rpar)
182.122 - | x::lll => (Output.raw_stdout lpar; pre x; List.app prec lll; Output.raw_stdout rpar))
182.123 - end;
182.124 -
182.125 -fun pr_bool true = Output.raw_stdout "true"
182.126 -| pr_bool false = Output.raw_stdout "false";
182.127 -
182.128 -fun pr_msg m = Output.raw_stdout "m"
182.129 -| pr_msg n = Output.raw_stdout "n"
182.130 -| pr_msg l = Output.raw_stdout "l";
182.131 -
182.132 -fun pr_act a = Output.raw_stdout (case a of
182.133 - Next => "Next"|
182.134 - S_msg(ma) => "S_msg(ma)" |
182.135 - R_msg(ma) => "R_msg(ma)" |
182.136 - S_pkt(b,ma) => "S_pkt(b,ma)" |
182.137 - R_pkt(b,ma) => "R_pkt(b,ma)" |
182.138 - S_ack(b) => "S_ack(b)" |
182.139 - R_ack(b) => "R_ack(b)");
182.140 -
182.141 -fun pr_pkt (b,ma) = (Output.raw_stdout "<"; pr_bool b;Output.raw_stdout ", "; pr_msg ma; Output.raw_stdout ">");
182.142 -
182.143 -val pr_bool_list = print_list("[","]",pr_bool);
182.144 -val pr_msg_list = print_list("[","]",pr_msg);
182.145 -val pr_pkt_list = print_list("[","]",pr_pkt);
182.146 -
182.147 -fun pr_tuple (env,p,a,q,b,ch1,ch2) =
182.148 - (Output.raw_stdout "{"; pr_bool env; Output.raw_stdout ", "; pr_msg_list p; Output.raw_stdout ", ";
182.149 - pr_bool a; Output.raw_stdout ", "; pr_msg_list q; Output.raw_stdout ", ";
182.150 - pr_bool b; Output.raw_stdout ", "; pr_pkt_list ch1; Output.raw_stdout ", ";
182.151 - pr_bool_list ch2; Output.raw_stdout "}");
182.152 -
182.153 -
182.154 -
182.155 -(* ---------------------------------
182.156 - Main function call
182.157 - ---------------------------------*)
182.158 -
182.159 -(*
182.160 -check(extactions,intactions,pr_act, [(true,[],true,[],false,[],[])],
182.161 - pr_tuple, nexts, hom, transA, [(true,[])]);
182.162 -*)
182.163 -
182.164 -
182.165 -
182.166 -
182.167 -
182.168 -(*
182.169 - Little test example
182.170 -
182.171 -datatype act = A;
182.172 -fun transA(s,a,t) = (not(s)=t);
182.173 -fun hom(i) = i mod 2 = 0;
182.174 -fun nexts s A = [(s+1) mod 4];
182.175 -check([A],[],K"A", [0], string_of_int, nexts, hom, transA, [true]);
182.176 -
182.177 -fun nexts s A = [(s+1) mod 5];
182.178 -
182.179 -*)
182.180 -
182.181 -end;
183.1 --- a/src/HOLCF/IOA/ABP/Correctness.thy Sat Nov 27 14:34:54 2010 -0800
183.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
183.3 @@ -1,326 +0,0 @@
183.4 -(* Title: HOLCF/IOA/ABP/Correctness.thy
183.5 - Author: Olaf Müller
183.6 -*)
183.7 -
183.8 -header {* The main correctness proof: System_fin implements System *}
183.9 -
183.10 -theory Correctness
183.11 -imports IOA Env Impl Impl_finite
183.12 -uses "Check.ML"
183.13 -begin
183.14 -
183.15 -primrec reduce :: "'a list => 'a list"
183.16 -where
183.17 - reduce_Nil: "reduce [] = []"
183.18 -| reduce_Cons: "reduce(x#xs) =
183.19 - (case xs of
183.20 - [] => [x]
183.21 - | y#ys => (if (x=y)
183.22 - then reduce xs
183.23 - else (x#(reduce xs))))"
183.24 -
183.25 -definition
183.26 - abs where
183.27 - "abs =
183.28 - (%p.(fst(p),(fst(snd(p)),(fst(snd(snd(p))),
183.29 - (reduce(fst(snd(snd(snd(p))))),reduce(snd(snd(snd(snd(p))))))))))"
183.30 -
183.31 -definition
183.32 - system_ioa :: "('m action, bool * 'm impl_state)ioa" where
183.33 - "system_ioa = (env_ioa || impl_ioa)"
183.34 -
183.35 -definition
183.36 - system_fin_ioa :: "('m action, bool * 'm impl_state)ioa" where
183.37 - "system_fin_ioa = (env_ioa || impl_fin_ioa)"
183.38 -
183.39 -
183.40 -axiomatization where
183.41 - sys_IOA: "IOA system_ioa" and
183.42 - sys_fin_IOA: "IOA system_fin_ioa"
183.43 -
183.44 -
183.45 -
183.46 -declare split_paired_All [simp del] Collect_empty_eq [simp del]
183.47 -
183.48 -lemmas [simp] =
183.49 - srch_asig_def rsch_asig_def rsch_ioa_def srch_ioa_def ch_ioa_def
183.50 - ch_asig_def srch_actions_def rsch_actions_def rename_def rename_set_def asig_of_def
183.51 - actions_def exis_elim srch_trans_def rsch_trans_def ch_trans_def
183.52 - trans_of_def asig_projections set_lemmas
183.53 -
183.54 -lemmas abschannel_fin [simp] =
183.55 - srch_fin_asig_def rsch_fin_asig_def
183.56 - rsch_fin_ioa_def srch_fin_ioa_def
183.57 - ch_fin_ioa_def ch_fin_trans_def ch_fin_asig_def
183.58 -
183.59 -lemmas impl_ioas = sender_ioa_def receiver_ioa_def
183.60 - and impl_trans = sender_trans_def receiver_trans_def
183.61 - and impl_asigs = sender_asig_def receiver_asig_def
183.62 -
183.63 -declare let_weak_cong [cong]
183.64 -declare ioa_triple_proj [simp] starts_of_par [simp]
183.65 -
183.66 -lemmas env_ioas = env_ioa_def env_asig_def env_trans_def
183.67 -lemmas hom_ioas =
183.68 - env_ioas [simp] impl_ioas [simp] impl_trans [simp] impl_asigs [simp]
183.69 - asig_projections set_lemmas
183.70 -
183.71 -
183.72 -subsection {* lemmas about reduce *}
183.73 -
183.74 -lemma l_iff_red_nil: "(reduce l = []) = (l = [])"
183.75 - by (induct l) (auto split: list.split)
183.76 -
183.77 -lemma hd_is_reduce_hd: "s ~= [] --> hd s = hd (reduce s)"
183.78 - by (induct s) (auto split: list.split)
183.79 -
183.80 -text {* to be used in the following Lemma *}
183.81 -lemma rev_red_not_nil [rule_format]:
183.82 - "l ~= [] --> reverse (reduce l) ~= []"
183.83 - by (induct l) (auto split: list.split)
183.84 -
183.85 -text {* shows applicability of the induction hypothesis of the following Lemma 1 *}
183.86 -lemma last_ind_on_first:
183.87 - "l ~= [] ==> hd (reverse (reduce (a # l))) = hd (reverse (reduce l))"
183.88 - apply simp
183.89 - apply (tactic {* auto_tac (@{claset},
183.90 - HOL_ss addsplits [@{thm list.split}]
183.91 - addsimps (@{thms reverse.simps} @ [@{thm hd_append}, @{thm rev_red_not_nil}])) *})
183.92 - done
183.93 -
183.94 -text {* Main Lemma 1 for @{text "S_pkt"} in showing that reduce is refinement. *}
183.95 -lemma reduce_hd:
183.96 - "if x=hd(reverse(reduce(l))) & reduce(l)~=[] then
183.97 - reduce(l@[x])=reduce(l) else
183.98 - reduce(l@[x])=reduce(l)@[x]"
183.99 -apply (simplesubst split_if)
183.100 -apply (rule conjI)
183.101 -txt {* @{text "-->"} *}
183.102 -apply (induct_tac "l")
183.103 -apply (simp (no_asm))
183.104 -apply (case_tac "list=[]")
183.105 - apply simp
183.106 - apply (rule impI)
183.107 -apply (simp (no_asm))
183.108 -apply (cut_tac l = "list" in cons_not_nil)
183.109 - apply (simp del: reduce_Cons)
183.110 - apply (erule exE)+
183.111 - apply hypsubst
183.112 -apply (simp del: reduce_Cons add: last_ind_on_first l_iff_red_nil)
183.113 -txt {* @{text "<--"} *}
183.114 -apply (simp (no_asm) add: and_de_morgan_and_absorbe l_iff_red_nil)
183.115 -apply (induct_tac "l")
183.116 -apply (simp (no_asm))
183.117 -apply (case_tac "list=[]")
183.118 -apply (cut_tac [2] l = "list" in cons_not_nil)
183.119 -apply simp
183.120 -apply (auto simp del: reduce_Cons simp add: last_ind_on_first l_iff_red_nil split: split_if)
183.121 -apply simp
183.122 -done
183.123 -
183.124 -
183.125 -text {* Main Lemma 2 for R_pkt in showing that reduce is refinement. *}
183.126 -lemma reduce_tl: "s~=[] ==>
183.127 - if hd(s)=hd(tl(s)) & tl(s)~=[] then
183.128 - reduce(tl(s))=reduce(s) else
183.129 - reduce(tl(s))=tl(reduce(s))"
183.130 -apply (cut_tac l = "s" in cons_not_nil)
183.131 -apply simp
183.132 -apply (erule exE)+
183.133 -apply (auto split: list.split)
183.134 -done
183.135 -
183.136 -
183.137 -subsection {* Channel Abstraction *}
183.138 -
183.139 -declare split_if [split del]
183.140 -
183.141 -lemma channel_abstraction: "is_weak_ref_map reduce ch_ioa ch_fin_ioa"
183.142 -apply (simp (no_asm) add: is_weak_ref_map_def)
183.143 -txt {* main-part *}
183.144 -apply (rule allI)+
183.145 -apply (rule imp_conj_lemma)
183.146 -apply (induct_tac "a")
183.147 -txt {* 2 cases *}
183.148 -apply (simp_all (no_asm) cong del: if_weak_cong add: externals_def)
183.149 -txt {* fst case *}
183.150 - apply (rule impI)
183.151 - apply (rule disjI2)
183.152 -apply (rule reduce_hd)
183.153 -txt {* snd case *}
183.154 - apply (rule impI)
183.155 - apply (erule conjE)+
183.156 - apply (erule disjE)
183.157 -apply (simp add: l_iff_red_nil)
183.158 -apply (erule hd_is_reduce_hd [THEN mp])
183.159 -apply (simp add: l_iff_red_nil)
183.160 -apply (rule conjI)
183.161 -apply (erule hd_is_reduce_hd [THEN mp])
183.162 -apply (rule bool_if_impl_or [THEN mp])
183.163 -apply (erule reduce_tl)
183.164 -done
183.165 -
183.166 -declare split_if [split]
183.167 -
183.168 -lemma sender_abstraction: "is_weak_ref_map reduce srch_ioa srch_fin_ioa"
183.169 -apply (tactic {*
183.170 - simp_tac (HOL_ss addsimps [@{thm srch_fin_ioa_def}, @{thm rsch_fin_ioa_def},
183.171 - @{thm srch_ioa_def}, @{thm rsch_ioa_def}, @{thm rename_through_pmap},
183.172 - @{thm channel_abstraction}]) 1 *})
183.173 -done
183.174 -
183.175 -lemma receiver_abstraction: "is_weak_ref_map reduce rsch_ioa rsch_fin_ioa"
183.176 -apply (tactic {*
183.177 - simp_tac (HOL_ss addsimps [@{thm srch_fin_ioa_def}, @{thm rsch_fin_ioa_def},
183.178 - @{thm srch_ioa_def}, @{thm rsch_ioa_def}, @{thm rename_through_pmap},
183.179 - @{thm channel_abstraction}]) 1 *})
183.180 -done
183.181 -
183.182 -
183.183 -text {* 3 thms that do not hold generally! The lucky restriction here is
183.184 - the absence of internal actions. *}
183.185 -lemma sender_unchanged: "is_weak_ref_map (%id. id) sender_ioa sender_ioa"
183.186 -apply (simp (no_asm) add: is_weak_ref_map_def)
183.187 -txt {* main-part *}
183.188 -apply (rule allI)+
183.189 -apply (induct_tac a)
183.190 -txt {* 7 cases *}
183.191 -apply (simp_all (no_asm) add: externals_def)
183.192 -done
183.193 -
183.194 -text {* 2 copies of before *}
183.195 -lemma receiver_unchanged: "is_weak_ref_map (%id. id) receiver_ioa receiver_ioa"
183.196 -apply (simp (no_asm) add: is_weak_ref_map_def)
183.197 -txt {* main-part *}
183.198 -apply (rule allI)+
183.199 -apply (induct_tac a)
183.200 -txt {* 7 cases *}
183.201 -apply (simp_all (no_asm) add: externals_def)
183.202 -done
183.203 -
183.204 -lemma env_unchanged: "is_weak_ref_map (%id. id) env_ioa env_ioa"
183.205 -apply (simp (no_asm) add: is_weak_ref_map_def)
183.206 -txt {* main-part *}
183.207 -apply (rule allI)+
183.208 -apply (induct_tac a)
183.209 -txt {* 7 cases *}
183.210 -apply (simp_all (no_asm) add: externals_def)
183.211 -done
183.212 -
183.213 -
183.214 -lemma compat_single_ch: "compatible srch_ioa rsch_ioa"
183.215 -apply (simp add: compatible_def Int_def)
183.216 -apply (rule set_eqI)
183.217 -apply (induct_tac x)
183.218 -apply simp_all
183.219 -done
183.220 -
183.221 -text {* totally the same as before *}
183.222 -lemma compat_single_fin_ch: "compatible srch_fin_ioa rsch_fin_ioa"
183.223 -apply (simp add: compatible_def Int_def)
183.224 -apply (rule set_eqI)
183.225 -apply (induct_tac x)
183.226 -apply simp_all
183.227 -done
183.228 -
183.229 -lemmas del_simps = trans_of_def srch_asig_def rsch_asig_def
183.230 - asig_of_def actions_def srch_trans_def rsch_trans_def srch_ioa_def
183.231 - srch_fin_ioa_def rsch_fin_ioa_def rsch_ioa_def sender_trans_def
183.232 - receiver_trans_def set_lemmas
183.233 -
183.234 -lemma compat_rec: "compatible receiver_ioa (srch_ioa || rsch_ioa)"
183.235 -apply (simp del: del_simps
183.236 - add: compatible_def asig_of_par asig_comp_def actions_def Int_def)
183.237 -apply simp
183.238 -apply (rule set_eqI)
183.239 -apply (induct_tac x)
183.240 -apply simp_all
183.241 -done
183.242 -
183.243 -text {* 5 proofs totally the same as before *}
183.244 -lemma compat_rec_fin: "compatible receiver_ioa (srch_fin_ioa || rsch_fin_ioa)"
183.245 -apply (simp del: del_simps
183.246 - add: compatible_def asig_of_par asig_comp_def actions_def Int_def)
183.247 -apply simp
183.248 -apply (rule set_eqI)
183.249 -apply (induct_tac x)
183.250 -apply simp_all
183.251 -done
183.252 -
183.253 -lemma compat_sen: "compatible sender_ioa
183.254 - (receiver_ioa || srch_ioa || rsch_ioa)"
183.255 -apply (simp del: del_simps
183.256 - add: compatible_def asig_of_par asig_comp_def actions_def Int_def)
183.257 -apply simp
183.258 -apply (rule set_eqI)
183.259 -apply (induct_tac x)
183.260 -apply simp_all
183.261 -done
183.262 -
183.263 -lemma compat_sen_fin: "compatible sender_ioa
183.264 - (receiver_ioa || srch_fin_ioa || rsch_fin_ioa)"
183.265 -apply (simp del: del_simps
183.266 - add: compatible_def asig_of_par asig_comp_def actions_def Int_def)
183.267 -apply simp
183.268 -apply (rule set_eqI)
183.269 -apply (induct_tac x)
183.270 -apply simp_all
183.271 -done
183.272 -
183.273 -lemma compat_env: "compatible env_ioa
183.274 - (sender_ioa || receiver_ioa || srch_ioa || rsch_ioa)"
183.275 -apply (simp del: del_simps
183.276 - add: compatible_def asig_of_par asig_comp_def actions_def Int_def)
183.277 -apply simp
183.278 -apply (rule set_eqI)
183.279 -apply (induct_tac x)
183.280 -apply simp_all
183.281 -done
183.282 -
183.283 -lemma compat_env_fin: "compatible env_ioa
183.284 - (sender_ioa || receiver_ioa || srch_fin_ioa || rsch_fin_ioa)"
183.285 -apply (simp del: del_simps
183.286 - add: compatible_def asig_of_par asig_comp_def actions_def Int_def)
183.287 -apply simp
183.288 -apply (rule set_eqI)
183.289 -apply (induct_tac x)
183.290 -apply simp_all
183.291 -done
183.292 -
183.293 -
183.294 -text {* lemmata about externals of channels *}
183.295 -lemma ext_single_ch: "externals(asig_of(srch_fin_ioa)) = externals(asig_of(srch_ioa)) &
183.296 - externals(asig_of(rsch_fin_ioa)) = externals(asig_of(rsch_ioa))"
183.297 - by (simp add: externals_def)
183.298 -
183.299 -
183.300 -subsection {* Soundness of Abstraction *}
183.301 -
183.302 -lemmas ext_simps = externals_of_par ext_single_ch
183.303 - and compat_simps = compat_single_ch compat_single_fin_ch compat_rec
183.304 - compat_rec_fin compat_sen compat_sen_fin compat_env compat_env_fin
183.305 - and abstractions = env_unchanged sender_unchanged
183.306 - receiver_unchanged sender_abstraction receiver_abstraction
183.307 -
183.308 -
183.309 -(* FIX: this proof should be done with compositionality on trace level, not on
183.310 - weak_ref_map level, as done here with fxg_is_weak_ref_map_of_product_IOA
183.311 -
183.312 -Goal "is_weak_ref_map abs system_ioa system_fin_ioa"
183.313 -
183.314 -by (simp_tac (impl_ss delsimps ([srch_ioa_def, rsch_ioa_def, srch_fin_ioa_def,
183.315 - rsch_fin_ioa_def] @ env_ioas @ impl_ioas)
183.316 - addsimps [system_def, system_fin_def, abs_def,
183.317 - impl_ioa_def, impl_fin_ioa_def, sys_IOA,
183.318 - sys_fin_IOA]) 1);
183.319 -
183.320 -by (REPEAT (EVERY[rtac fxg_is_weak_ref_map_of_product_IOA 1,
183.321 - simp_tac (ss addsimps abstractions) 1,
183.322 - rtac conjI 1]));
183.323 -
183.324 -by (ALLGOALS (simp_tac (ss addsimps ext_ss @ compat_ss)));
183.325 -
183.326 -qed "system_refinement";
183.327 -*)
183.328 -
183.329 -end
184.1 --- a/src/HOLCF/IOA/ABP/Env.thy Sat Nov 27 14:34:54 2010 -0800
184.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
184.3 @@ -1,42 +0,0 @@
184.4 -(* Title: HOLCF/IOA/ABP/Impl.thy
184.5 - Author: Olaf Müller
184.6 -*)
184.7 -
184.8 -header {* The environment *}
184.9 -
184.10 -theory Env
184.11 -imports IOA Action
184.12 -begin
184.13 -
184.14 -types
184.15 - 'm env_state = bool -- {* give next bit to system *}
184.16 -
184.17 -definition
184.18 - env_asig :: "'m action signature" where
184.19 - "env_asig == ({Next},
184.20 - UN m. {S_msg(m)},
184.21 - {})"
184.22 -
184.23 -definition
184.24 - env_trans :: "('m action, 'm env_state)transition set" where
184.25 - "env_trans =
184.26 - {tr. let s = fst(tr);
184.27 - t = snd(snd(tr))
184.28 - in case fst(snd(tr))
184.29 - of
184.30 - Next => t=True |
184.31 - S_msg(m) => s=True & t=False |
184.32 - R_msg(m) => False |
184.33 - S_pkt(pkt) => False |
184.34 - R_pkt(pkt) => False |
184.35 - S_ack(b) => False |
184.36 - R_ack(b) => False}"
184.37 -
184.38 -definition
184.39 - env_ioa :: "('m action, 'm env_state)ioa" where
184.40 - "env_ioa = (env_asig, {True}, env_trans,{},{})"
184.41 -
184.42 -axiomatization
184.43 - "next" :: "'m env_state => bool"
184.44 -
184.45 -end
185.1 --- a/src/HOLCF/IOA/ABP/Impl.thy Sat Nov 27 14:34:54 2010 -0800
185.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
185.3 @@ -1,35 +0,0 @@
185.4 -(* Title: HOLCF/IOA/ABP/Impl.thy
185.5 - Author: Olaf Müller
185.6 -*)
185.7 -
185.8 -header {* The implementation *}
185.9 -
185.10 -theory Impl
185.11 -imports Sender Receiver Abschannel
185.12 -begin
185.13 -
185.14 -types
185.15 - 'm impl_state = "'m sender_state * 'm receiver_state * 'm packet list * bool list"
185.16 - (* sender_state * receiver_state * srch_state * rsch_state *)
185.17 -
185.18 -definition
185.19 - impl_ioa :: "('m action, 'm impl_state)ioa" where
185.20 - "impl_ioa = (sender_ioa || receiver_ioa || srch_ioa || rsch_ioa)"
185.21 -
185.22 -definition
185.23 - sen :: "'m impl_state => 'm sender_state" where
185.24 - "sen = fst"
185.25 -
185.26 -definition
185.27 - rec :: "'m impl_state => 'm receiver_state" where
185.28 - "rec = fst o snd"
185.29 -
185.30 -definition
185.31 - srch :: "'m impl_state => 'm packet list" where
185.32 - "srch = fst o snd o snd"
185.33 -
185.34 -definition
185.35 - rsch :: "'m impl_state => bool list" where
185.36 - "rsch = snd o snd o snd"
185.37 -
185.38 -end
186.1 --- a/src/HOLCF/IOA/ABP/Impl_finite.thy Sat Nov 27 14:34:54 2010 -0800
186.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
186.3 @@ -1,37 +0,0 @@
186.4 -(* Title: HOLCF/IOA/ABP/Impl.thy
186.5 - Author: Olaf Müller
186.6 -*)
186.7 -
186.8 -header {* The implementation *}
186.9 -
186.10 -theory Impl_finite
186.11 -imports Sender Receiver Abschannel_finite
186.12 -begin
186.13 -
186.14 -types
186.15 - 'm impl_fin_state
186.16 - = "'m sender_state * 'm receiver_state * 'm packet list * bool list"
186.17 -(* sender_state * receiver_state * srch_state * rsch_state *)
186.18 -
186.19 -definition
186.20 - impl_fin_ioa :: "('m action, 'm impl_fin_state)ioa" where
186.21 - "impl_fin_ioa = (sender_ioa || receiver_ioa || srch_fin_ioa ||
186.22 - rsch_fin_ioa)"
186.23 -
186.24 -definition
186.25 - sen_fin :: "'m impl_fin_state => 'm sender_state" where
186.26 - "sen_fin = fst"
186.27 -
186.28 -definition
186.29 - rec_fin :: "'m impl_fin_state => 'm receiver_state" where
186.30 - "rec_fin = fst o snd"
186.31 -
186.32 -definition
186.33 - srch_fin :: "'m impl_fin_state => 'm packet list" where
186.34 - "srch_fin = fst o snd o snd"
186.35 -
186.36 -definition
186.37 - rsch_fin :: "'m impl_fin_state => bool list" where
186.38 - "rsch_fin = snd o snd o snd"
186.39 -
186.40 -end
187.1 --- a/src/HOLCF/IOA/ABP/Lemmas.thy Sat Nov 27 14:34:54 2010 -0800
187.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
187.3 @@ -1,44 +0,0 @@
187.4 -(* Title: HOLCF/IOA/ABP/Lemmas.thy
187.5 - Author: Olaf Müller
187.6 -*)
187.7 -
187.8 -theory Lemmas
187.9 -imports Main
187.10 -begin
187.11 -
187.12 -subsection {* Logic *}
187.13 -
187.14 -lemma and_de_morgan_and_absorbe: "(~(A&B)) = ((~A)&B| ~B)"
187.15 - by blast
187.16 -
187.17 -lemma bool_if_impl_or: "(if C then A else B) --> (A|B)"
187.18 - by auto
187.19 -
187.20 -lemma exis_elim: "(? x. x=P & Q(x)) = Q(P)"
187.21 - by blast
187.22 -
187.23 -
187.24 -subsection {* Sets *}
187.25 -
187.26 -lemma set_lemmas:
187.27 - "f(x) : (UN x. {f(x)})"
187.28 - "f x y : (UN x y. {f x y})"
187.29 - "!!a. (!x. a ~= f(x)) ==> a ~: (UN x. {f(x)})"
187.30 - "!!a. (!x y. a ~= f x y) ==> a ~: (UN x y. {f x y})"
187.31 - by auto
187.32 -
187.33 -text {* 2 Lemmas to add to @{text "set_lemmas"}, used also for action handling,
187.34 - namely for Intersections and the empty list (compatibility of IOA!). *}
187.35 -lemma singleton_set: "(UN b.{x. x=f(b)})= (UN b.{f(b)})"
187.36 - by blast
187.37 -
187.38 -lemma de_morgan: "((A|B)=False) = ((~A)&(~B))"
187.39 - by blast
187.40 -
187.41 -
187.42 -subsection {* Lists *}
187.43 -
187.44 -lemma cons_not_nil: "l ~= [] --> (? x xs. l = (x#xs))"
187.45 - by (induct l) simp_all
187.46 -
187.47 -end
188.1 --- a/src/HOLCF/IOA/ABP/Packet.thy Sat Nov 27 14:34:54 2010 -0800
188.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
188.3 @@ -1,22 +0,0 @@
188.4 -(* Title: HOLCF/IOA/ABP/Packet.thy
188.5 - Author: Olaf Müller
188.6 -*)
188.7 -
188.8 -header {* Packets *}
188.9 -
188.10 -theory Packet
188.11 -imports Main
188.12 -begin
188.13 -
188.14 -types
188.15 - 'msg packet = "bool * 'msg"
188.16 -
188.17 -definition
188.18 - hdr :: "'msg packet => bool" where
188.19 - "hdr = fst"
188.20 -
188.21 -definition
188.22 - msg :: "'msg packet => 'msg" where
188.23 - "msg = snd"
188.24 -
188.25 -end
189.1 --- a/src/HOLCF/IOA/ABP/ROOT.ML Sat Nov 27 14:34:54 2010 -0800
189.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
189.3 @@ -1,7 +0,0 @@
189.4 -(* Title: HOLCF/IOA/ABP/ROOT.ML
189.5 - Author: Olaf Mueller
189.6 -
189.7 -This is the ROOT file for the Alternating Bit Protocol performed in
189.8 -I/O-Automata.
189.9 -*)
189.10 -use_thys ["Correctness"];
190.1 --- a/src/HOLCF/IOA/ABP/Read_me Sat Nov 27 14:34:54 2010 -0800
190.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
190.3 @@ -1,10 +0,0 @@
190.4 -Isabelle Verification of the Alternating Bit Protocol by
190.5 -combining IOA with Model Checking
190.6 -
190.7 --------------------------------------------------------------
190.8 -
190.9 -Correctness.ML contains the proof of the abstraction from unbounded
190.10 -channels to finite ones.
190.11 -
190.12 -Check.ML contains a simple ModelChecker prototype checking Spec against
190.13 -the finite version of the ABP-protocol.
191.1 --- a/src/HOLCF/IOA/ABP/Receiver.thy Sat Nov 27 14:34:54 2010 -0800
191.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
191.3 @@ -1,57 +0,0 @@
191.4 -(* Title: HOLCF/IOA/ABP/Receiver.thy
191.5 - Author: Olaf Müller
191.6 -*)
191.7 -
191.8 -header {* The implementation: receiver *}
191.9 -
191.10 -theory Receiver
191.11 -imports IOA Action Lemmas
191.12 -begin
191.13 -
191.14 -types
191.15 - 'm receiver_state = "'m list * bool" -- {* messages, mode *}
191.16 -
191.17 -definition
191.18 - rq :: "'m receiver_state => 'm list" where
191.19 - "rq = fst"
191.20 -
191.21 -definition
191.22 - rbit :: "'m receiver_state => bool" where
191.23 - "rbit = snd"
191.24 -
191.25 -definition
191.26 - receiver_asig :: "'m action signature" where
191.27 - "receiver_asig =
191.28 - (UN pkt. {R_pkt(pkt)},
191.29 - (UN m. {R_msg(m)}) Un (UN b. {S_ack(b)}),
191.30 - {})"
191.31 -
191.32 -definition
191.33 - receiver_trans :: "('m action, 'm receiver_state)transition set" where
191.34 - "receiver_trans =
191.35 - {tr. let s = fst(tr);
191.36 - t = snd(snd(tr))
191.37 - in
191.38 - case fst(snd(tr))
191.39 - of
191.40 - Next => False |
191.41 - S_msg(m) => False |
191.42 - R_msg(m) => (rq(s) ~= []) &
191.43 - m = hd(rq(s)) &
191.44 - rq(t) = tl(rq(s)) &
191.45 - rbit(t)=rbit(s) |
191.46 - S_pkt(pkt) => False |
191.47 - R_pkt(pkt) => if (hdr(pkt) ~= rbit(s))&rq(s)=[] then
191.48 - rq(t) = (rq(s)@[msg(pkt)]) &rbit(t) = (~rbit(s)) else
191.49 - rq(t) =rq(s) & rbit(t)=rbit(s) |
191.50 - S_ack(b) => b = rbit(s) &
191.51 - rq(t) = rq(s) &
191.52 - rbit(t)=rbit(s) |
191.53 - R_ack(b) => False}"
191.54 -
191.55 -definition
191.56 - receiver_ioa :: "('m action, 'm receiver_state)ioa" where
191.57 - "receiver_ioa =
191.58 - (receiver_asig, {([],False)}, receiver_trans,{},{})"
191.59 -
191.60 -end
192.1 --- a/src/HOLCF/IOA/ABP/Sender.thy Sat Nov 27 14:34:54 2010 -0800
192.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
192.3 @@ -1,55 +0,0 @@
192.4 -(* Title: HOLCF/IOA/ABP/Sender.thy
192.5 - Author: Olaf Müller
192.6 -*)
192.7 -
192.8 -header {* The implementation: sender *}
192.9 -
192.10 -theory Sender
192.11 -imports IOA Action Lemmas
192.12 -begin
192.13 -
192.14 -types
192.15 - 'm sender_state = "'m list * bool" -- {* messages, Alternating Bit *}
192.16 -
192.17 -definition
192.18 - sq :: "'m sender_state => 'm list" where
192.19 - "sq = fst"
192.20 -
192.21 -definition
192.22 - sbit :: "'m sender_state => bool" where
192.23 - "sbit = snd"
192.24 -
192.25 -definition
192.26 - sender_asig :: "'m action signature" where
192.27 - "sender_asig = ((UN m. {S_msg(m)}) Un (UN b. {R_ack(b)}),
192.28 - UN pkt. {S_pkt(pkt)},
192.29 - {})"
192.30 -
192.31 -definition
192.32 - sender_trans :: "('m action, 'm sender_state)transition set" where
192.33 - "sender_trans =
192.34 - {tr. let s = fst(tr);
192.35 - t = snd(snd(tr))
192.36 - in case fst(snd(tr))
192.37 - of
192.38 - Next => if sq(s)=[] then t=s else False |
192.39 - S_msg(m) => sq(t)=sq(s)@[m] &
192.40 - sbit(t)=sbit(s) |
192.41 - R_msg(m) => False |
192.42 - S_pkt(pkt) => sq(s) ~= [] &
192.43 - hdr(pkt) = sbit(s) &
192.44 - msg(pkt) = hd(sq(s)) &
192.45 - sq(t) = sq(s) &
192.46 - sbit(t) = sbit(s) |
192.47 - R_pkt(pkt) => False |
192.48 - S_ack(b) => False |
192.49 - R_ack(b) => if b = sbit(s) then
192.50 - sq(t)=tl(sq(s)) & sbit(t)=(~sbit(s)) else
192.51 - sq(t)=sq(s) & sbit(t)=sbit(s)}"
192.52 -
192.53 -definition
192.54 - sender_ioa :: "('m action, 'm sender_state)ioa" where
192.55 - "sender_ioa =
192.56 - (sender_asig, {([],True)}, sender_trans,{},{})"
192.57 -
192.58 -end
193.1 --- a/src/HOLCF/IOA/ABP/Spec.thy Sat Nov 27 14:34:54 2010 -0800
193.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
193.3 @@ -1,37 +0,0 @@
193.4 -(* Title: HOLCF/IOA/ABP/Spec.thy
193.5 - Author: Olaf Müller
193.6 -*)
193.7 -
193.8 -header {* The specification of reliable transmission *}
193.9 -
193.10 -theory Spec
193.11 -imports IOA Action
193.12 -begin
193.13 -
193.14 -definition
193.15 - spec_sig :: "'m action signature" where
193.16 - sig_def: "spec_sig = (UN m.{S_msg(m)},
193.17 - UN m.{R_msg(m)} Un {Next},
193.18 - {})"
193.19 -
193.20 -definition
193.21 - spec_trans :: "('m action, 'm list)transition set" where
193.22 - trans_def: "spec_trans =
193.23 - {tr. let s = fst(tr);
193.24 - t = snd(snd(tr))
193.25 - in
193.26 - case fst(snd(tr))
193.27 - of
193.28 - Next => t=s | (* Note that there is condition as in Sender *)
193.29 - S_msg(m) => t = s@[m] |
193.30 - R_msg(m) => s = (m#t) |
193.31 - S_pkt(pkt) => False |
193.32 - R_pkt(pkt) => False |
193.33 - S_ack(b) => False |
193.34 - R_ack(b) => False}"
193.35 -
193.36 -definition
193.37 - spec_ioa :: "('m action, 'm list)ioa" where
193.38 - ioa_def: "spec_ioa = (spec_sig, {[]}, spec_trans)"
193.39 -
193.40 -end
194.1 --- a/src/HOLCF/IOA/NTP/Abschannel.thy Sat Nov 27 14:34:54 2010 -0800
194.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
194.3 @@ -1,141 +0,0 @@
194.4 -(* Title: HOL/IOA/NTP/Abschannel.thy
194.5 - Author: Olaf Müller
194.6 -*)
194.7 -
194.8 -header {* The (faulty) transmission channel (both directions) *}
194.9 -
194.10 -theory Abschannel
194.11 -imports IOA Action
194.12 -begin
194.13 -
194.14 -datatype 'a abs_action = S 'a | R 'a
194.15 -
194.16 -definition
194.17 - ch_asig :: "'a abs_action signature" where
194.18 - "ch_asig = (UN b. {S(b)}, UN b. {R(b)}, {})"
194.19 -
194.20 -definition
194.21 - ch_trans :: "('a abs_action, 'a multiset)transition set" where
194.22 - "ch_trans =
194.23 - {tr. let s = fst(tr);
194.24 - t = snd(snd(tr))
194.25 - in
194.26 - case fst(snd(tr))
194.27 - of S(b) => t = addm s b |
194.28 - R(b) => count s b ~= 0 & t = delm s b}"
194.29 -
194.30 -definition
194.31 - ch_ioa :: "('a abs_action, 'a multiset)ioa" where
194.32 - "ch_ioa = (ch_asig, {{|}}, ch_trans,{},{})"
194.33 -
194.34 -definition
194.35 - rsch_actions :: "'m action => bool abs_action option" where
194.36 - "rsch_actions (akt) =
194.37 - (case akt of
194.38 - S_msg(m) => None |
194.39 - R_msg(m) => None |
194.40 - S_pkt(packet) => None |
194.41 - R_pkt(packet) => None |
194.42 - S_ack(b) => Some(S(b)) |
194.43 - R_ack(b) => Some(R(b)) |
194.44 - C_m_s => None |
194.45 - C_m_r => None |
194.46 - C_r_s => None |
194.47 - C_r_r(m) => None)"
194.48 -
194.49 -definition
194.50 - srch_actions :: "'m action =>(bool * 'm) abs_action option" where
194.51 - "srch_actions (akt) =
194.52 - (case akt of
194.53 - S_msg(m) => None |
194.54 - R_msg(m) => None |
194.55 - S_pkt(p) => Some(S(p)) |
194.56 - R_pkt(p) => Some(R(p)) |
194.57 - S_ack(b) => None |
194.58 - R_ack(b) => None |
194.59 - C_m_s => None |
194.60 - C_m_r => None |
194.61 - C_r_s => None |
194.62 - C_r_r(m) => None)"
194.63 -
194.64 -definition
194.65 - srch_ioa :: "('m action, 'm packet multiset)ioa" where
194.66 - "srch_ioa = rename ch_ioa srch_actions"
194.67 -
194.68 -definition
194.69 - rsch_ioa :: "('m action, bool multiset)ioa" where
194.70 - "rsch_ioa = rename ch_ioa rsch_actions"
194.71 -
194.72 -definition
194.73 - srch_asig :: "'m action signature" where
194.74 - "srch_asig = asig_of(srch_ioa)"
194.75 -
194.76 -definition
194.77 - rsch_asig :: "'m action signature" where
194.78 - "rsch_asig = asig_of(rsch_ioa)"
194.79 -
194.80 -definition
194.81 - srch_wfair :: "('m action)set set" where
194.82 - "srch_wfair = wfair_of(srch_ioa)"
194.83 -definition
194.84 - srch_sfair :: "('m action)set set" where
194.85 - "srch_sfair = sfair_of(srch_ioa)"
194.86 -definition
194.87 - rsch_sfair :: "('m action)set set" where
194.88 - "rsch_sfair = sfair_of(rsch_ioa)"
194.89 -definition
194.90 - rsch_wfair :: "('m action)set set" where
194.91 - "rsch_wfair = wfair_of(rsch_ioa)"
194.92 -
194.93 -definition
194.94 - srch_trans :: "('m action, 'm packet multiset)transition set" where
194.95 - "srch_trans = trans_of(srch_ioa)"
194.96 -definition
194.97 - rsch_trans :: "('m action, bool multiset)transition set" where
194.98 - "rsch_trans = trans_of(rsch_ioa)"
194.99 -
194.100 -
194.101 -lemmas unfold_renaming =
194.102 - srch_asig_def rsch_asig_def rsch_ioa_def srch_ioa_def ch_ioa_def
194.103 - ch_asig_def srch_actions_def rsch_actions_def rename_def rename_set_def asig_of_def
194.104 - actions_def srch_trans_def rsch_trans_def ch_trans_def starts_of_def
194.105 - trans_of_def asig_projections
194.106 -
194.107 -lemma in_srch_asig:
194.108 - "S_msg(m) ~: actions(srch_asig) &
194.109 - R_msg(m) ~: actions(srch_asig) &
194.110 - S_pkt(pkt) : actions(srch_asig) &
194.111 - R_pkt(pkt) : actions(srch_asig) &
194.112 - S_ack(b) ~: actions(srch_asig) &
194.113 - R_ack(b) ~: actions(srch_asig) &
194.114 - C_m_s ~: actions(srch_asig) &
194.115 - C_m_r ~: actions(srch_asig) &
194.116 - C_r_s ~: actions(srch_asig) & C_r_r(m) ~: actions(srch_asig)"
194.117 - by (simp add: unfold_renaming)
194.118 -
194.119 -lemma in_rsch_asig:
194.120 - "S_msg(m) ~: actions(rsch_asig) &
194.121 - R_msg(m) ~: actions(rsch_asig) &
194.122 - S_pkt(pkt) ~: actions(rsch_asig) &
194.123 - R_pkt(pkt) ~: actions(rsch_asig) &
194.124 - S_ack(b) : actions(rsch_asig) &
194.125 - R_ack(b) : actions(rsch_asig) &
194.126 - C_m_s ~: actions(rsch_asig) &
194.127 - C_m_r ~: actions(rsch_asig) &
194.128 - C_r_s ~: actions(rsch_asig) &
194.129 - C_r_r(m) ~: actions(rsch_asig)"
194.130 - by (simp add: unfold_renaming)
194.131 -
194.132 -lemma srch_ioa_thm: "srch_ioa =
194.133 - (srch_asig, {{|}}, srch_trans,srch_wfair,srch_sfair)"
194.134 -apply (simp (no_asm) add: srch_asig_def srch_trans_def asig_of_def trans_of_def wfair_of_def sfair_of_def srch_wfair_def srch_sfair_def)
194.135 -apply (simp (no_asm) add: unfold_renaming)
194.136 -done
194.137 -
194.138 -lemma rsch_ioa_thm: "rsch_ioa =
194.139 - (rsch_asig, {{|}}, rsch_trans,rsch_wfair,rsch_sfair)"
194.140 -apply (simp (no_asm) add: rsch_asig_def rsch_trans_def asig_of_def trans_of_def wfair_of_def sfair_of_def rsch_wfair_def rsch_sfair_def)
194.141 -apply (simp (no_asm) add: unfold_renaming)
194.142 -done
194.143 -
194.144 -end
195.1 --- a/src/HOLCF/IOA/NTP/Action.thy Sat Nov 27 14:34:54 2010 -0800
195.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
195.3 @@ -1,16 +0,0 @@
195.4 -(* Title: HOL/IOA/NTP/Action.thy
195.5 - Author: Tobias Nipkow & Konrad Slind
195.6 -*)
195.7 -
195.8 -header {* The set of all actions of the system *}
195.9 -
195.10 -theory Action
195.11 -imports Packet
195.12 -begin
195.13 -
195.14 -datatype 'm action = S_msg 'm | R_msg 'm
195.15 - | S_pkt "'m packet" | R_pkt "'m packet"
195.16 - | S_ack bool | R_ack bool
195.17 - | C_m_s | C_m_r | C_r_s | C_r_r 'm
195.18 -
195.19 -end
196.1 --- a/src/HOLCF/IOA/NTP/Correctness.thy Sat Nov 27 14:34:54 2010 -0800
196.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
196.3 @@ -1,105 +0,0 @@
196.4 -(* Title: HOL/IOA/NTP/Correctness.thy
196.5 - Author: Tobias Nipkow & Konrad Slind
196.6 -*)
196.7 -
196.8 -header {* The main correctness proof: Impl implements Spec *}
196.9 -
196.10 -theory Correctness
196.11 -imports Impl Spec
196.12 -begin
196.13 -
196.14 -definition
196.15 - hom :: "'m impl_state => 'm list" where
196.16 - "hom s = rq(rec(s)) @ (if rbit(rec s) = sbit(sen s) then sq(sen s)
196.17 - else tl(sq(sen s)))"
196.18 -
196.19 -declaration {* fn _ =>
196.20 - (* repeated from Traces.ML *)
196.21 - Classical.map_cs (fn cs => cs delSWrapper "split_all_tac")
196.22 -*}
196.23 -
196.24 -lemmas hom_ioas = Spec.ioa_def Spec.trans_def sender_trans_def receiver_trans_def impl_ioas
196.25 - and impl_asigs = sender_asig_def receiver_asig_def srch_asig_def rsch_asig_def
196.26 -
196.27 -declare split_paired_All [simp del]
196.28 -
196.29 -
196.30 -text {*
196.31 - A lemma about restricting the action signature of the implementation
196.32 - to that of the specification.
196.33 -*}
196.34 -
196.35 -lemma externals_lemma:
196.36 - "a:externals(asig_of(Automata.restrict impl_ioa (externals spec_sig))) =
196.37 - (case a of
196.38 - S_msg(m) => True
196.39 - | R_msg(m) => True
196.40 - | S_pkt(pkt) => False
196.41 - | R_pkt(pkt) => False
196.42 - | S_ack(b) => False
196.43 - | R_ack(b) => False
196.44 - | C_m_s => False
196.45 - | C_m_r => False
196.46 - | C_r_s => False
196.47 - | C_r_r(m) => False)"
196.48 - apply (simp (no_asm) add: externals_def restrict_def restrict_asig_def Spec.sig_def asig_projections)
196.49 -
196.50 - apply (induct_tac "a")
196.51 - apply (simp_all (no_asm) add: actions_def asig_projections)
196.52 - txt {* 2 *}
196.53 - apply (simp (no_asm) add: impl_ioas)
196.54 - apply (simp (no_asm) add: impl_asigs)
196.55 - apply (simp (no_asm) add: asig_of_par asig_comp_def asig_projections)
196.56 - apply (simp (no_asm) add: "transitions"(1) unfold_renaming)
196.57 - txt {* 1 *}
196.58 - apply (simp (no_asm) add: impl_ioas)
196.59 - apply (simp (no_asm) add: impl_asigs)
196.60 - apply (simp (no_asm) add: asig_of_par asig_comp_def asig_projections)
196.61 - done
196.62 -
196.63 -lemmas sels = sbit_def sq_def ssending_def rbit_def rq_def rsending_def
196.64 -
196.65 -
196.66 -text {* Proof of correctness *}
196.67 -lemma ntp_correct:
196.68 - "is_weak_ref_map hom (Automata.restrict impl_ioa (externals spec_sig)) spec_ioa"
196.69 -apply (unfold Spec.ioa_def is_weak_ref_map_def)
196.70 -apply (simp (no_asm) cong del: if_weak_cong split del: split_if add: Correctness.hom_def
196.71 - cancel_restrict externals_lemma)
196.72 -apply (rule conjI)
196.73 - apply (simp (no_asm) add: hom_ioas)
196.74 - apply (simp (no_asm_simp) add: sels)
196.75 -apply (rule allI)+
196.76 -apply (rule imp_conj_lemma)
196.77 -
196.78 -apply (induct_tac "a")
196.79 -apply (simp_all (no_asm_simp) add: hom_ioas)
196.80 -apply (frule inv4)
196.81 -apply force
196.82 -
196.83 -apply (frule inv4)
196.84 -apply (frule inv2)
196.85 -apply (erule disjE)
196.86 -apply (simp (no_asm_simp))
196.87 -apply force
196.88 -
196.89 -apply (frule inv2)
196.90 -apply (erule disjE)
196.91 -
196.92 -apply (frule inv3)
196.93 -apply (case_tac "sq (sen (s))=[]")
196.94 -
196.95 -apply (simp add: hom_ioas)
196.96 -apply (blast dest!: add_leD1 [THEN leD])
196.97 -
196.98 -apply (case_tac "m = hd (sq (sen (s)))")
196.99 -
196.100 -apply force
196.101 -
196.102 -apply simp
196.103 -apply (blast dest!: add_leD1 [THEN leD])
196.104 -
196.105 -apply simp
196.106 -done
196.107 -
196.108 -end
197.1 --- a/src/HOLCF/IOA/NTP/Impl.thy Sat Nov 27 14:34:54 2010 -0800
197.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
197.3 @@ -1,356 +0,0 @@
197.4 -(* Title: HOL/IOA/NTP/Impl.thy
197.5 - Author: Tobias Nipkow & Konrad Slind
197.6 -*)
197.7 -
197.8 -header {* The implementation *}
197.9 -
197.10 -theory Impl
197.11 -imports Sender Receiver Abschannel
197.12 -begin
197.13 -
197.14 -types 'm impl_state
197.15 - = "'m sender_state * 'm receiver_state * 'm packet multiset * bool multiset"
197.16 - (* sender_state * receiver_state * srch_state * rsch_state *)
197.17 -
197.18 -
197.19 -definition
197.20 - impl_ioa :: "('m action, 'm impl_state)ioa" where
197.21 - impl_def: "impl_ioa == (sender_ioa || receiver_ioa || srch_ioa || rsch_ioa)"
197.22 -
197.23 -definition sen :: "'m impl_state => 'm sender_state" where "sen = fst"
197.24 -definition rec :: "'m impl_state => 'm receiver_state" where "rec = fst o snd"
197.25 -definition srch :: "'m impl_state => 'm packet multiset" where "srch = fst o snd o snd"
197.26 -definition rsch :: "'m impl_state => bool multiset" where "rsch = snd o snd o snd"
197.27 -
197.28 -definition
197.29 - hdr_sum :: "'m packet multiset => bool => nat" where
197.30 - "hdr_sum M b == countm M (%pkt. hdr(pkt) = b)"
197.31 -
197.32 -(* Lemma 5.1 *)
197.33 -definition
197.34 - "inv1(s) ==
197.35 - (!b. count (rsent(rec s)) b = count (srcvd(sen s)) b + count (rsch s) b)
197.36 - & (!b. count (ssent(sen s)) b
197.37 - = hdr_sum (rrcvd(rec s)) b + hdr_sum (srch s) b)"
197.38 -
197.39 -(* Lemma 5.2 *)
197.40 -definition
197.41 - "inv2(s) ==
197.42 - (rbit(rec(s)) = sbit(sen(s)) &
197.43 - ssending(sen(s)) &
197.44 - count (rsent(rec s)) (~sbit(sen s)) <= count (ssent(sen s)) (~sbit(sen s)) &
197.45 - count (ssent(sen s)) (~sbit(sen s)) <= count (rsent(rec s)) (sbit(sen s)))
197.46 - |
197.47 - (rbit(rec(s)) = (~sbit(sen(s))) &
197.48 - rsending(rec(s)) &
197.49 - count (ssent(sen s)) (~sbit(sen s)) <= count (rsent(rec s)) (sbit(sen s)) &
197.50 - count (rsent(rec s)) (sbit(sen s)) <= count (ssent(sen s)) (sbit(sen s)))"
197.51 -
197.52 -(* Lemma 5.3 *)
197.53 -definition
197.54 - "inv3(s) ==
197.55 - rbit(rec(s)) = sbit(sen(s))
197.56 - --> (!m. sq(sen(s))=[] | m ~= hd(sq(sen(s)))
197.57 - --> count (rrcvd(rec s)) (sbit(sen(s)),m)
197.58 - + count (srch s) (sbit(sen(s)),m)
197.59 - <= count (rsent(rec s)) (~sbit(sen s)))"
197.60 -
197.61 -(* Lemma 5.4 *)
197.62 -definition "inv4(s) == rbit(rec(s)) = (~sbit(sen(s))) --> sq(sen(s)) ~= []"
197.63 -
197.64 -
197.65 -subsection {* Invariants *}
197.66 -
197.67 -declare le_SucI [simp]
197.68 -
197.69 -lemmas impl_ioas =
197.70 - impl_def sender_ioa_def receiver_ioa_def srch_ioa_thm [THEN eq_reflection]
197.71 - rsch_ioa_thm [THEN eq_reflection]
197.72 -
197.73 -lemmas "transitions" =
197.74 - sender_trans_def receiver_trans_def srch_trans_def rsch_trans_def
197.75 -
197.76 -
197.77 -lemmas [simp] =
197.78 - ioa_triple_proj starts_of_par trans_of_par4 in_sender_asig
197.79 - in_receiver_asig in_srch_asig in_rsch_asig
197.80 -
197.81 -declare let_weak_cong [cong]
197.82 -
197.83 -lemma [simp]:
197.84 - "fst(x) = sen(x)"
197.85 - "fst(snd(x)) = rec(x)"
197.86 - "fst(snd(snd(x))) = srch(x)"
197.87 - "snd(snd(snd(x))) = rsch(x)"
197.88 - by (simp_all add: sen_def rec_def srch_def rsch_def)
197.89 -
197.90 -lemma [simp]:
197.91 - "a:actions(sender_asig)
197.92 - | a:actions(receiver_asig)
197.93 - | a:actions(srch_asig)
197.94 - | a:actions(rsch_asig)"
197.95 - by (induct a) simp_all
197.96 -
197.97 -declare split_paired_All [simp del]
197.98 -
197.99 -
197.100 -(* Three Simp_sets in different sizes
197.101 -----------------------------------------------
197.102 -
197.103 -1) simpset() does not unfold the transition relations
197.104 -2) ss unfolds transition relations
197.105 -3) renname_ss unfolds transitions and the abstract channel *)
197.106 -
197.107 -ML {*
197.108 -val ss = @{simpset} addsimps @{thms "transitions"};
197.109 -val rename_ss = ss addsimps @{thms unfold_renaming};
197.110 -
197.111 -val tac = asm_simp_tac (ss addcongs [@{thm conj_cong}] addsplits [@{thm split_if}])
197.112 -val tac_ren = asm_simp_tac (rename_ss addcongs [@{thm conj_cong}] addsplits [@{thm split_if}])
197.113 -*}
197.114 -
197.115 -
197.116 -subsubsection {* Invariant 1 *}
197.117 -
197.118 -lemma raw_inv1: "invariant impl_ioa inv1"
197.119 -
197.120 -apply (unfold impl_ioas)
197.121 -apply (rule invariantI)
197.122 -apply (simp add: inv1_def hdr_sum_def srcvd_def ssent_def rsent_def rrcvd_def)
197.123 -
197.124 -apply (simp (no_asm) del: trans_of_par4 add: imp_conjR inv1_def)
197.125 -
197.126 -txt {* Split proof in two *}
197.127 -apply (rule conjI)
197.128 -
197.129 -(* First half *)
197.130 -apply (simp add: Impl.inv1_def split del: split_if)
197.131 -apply (induct_tac a)
197.132 -
197.133 -apply (tactic "EVERY1[tac, tac, tac, tac]")
197.134 -apply (tactic "tac 1")
197.135 -apply (tactic "tac_ren 1")
197.136 -
197.137 -txt {* 5 + 1 *}
197.138 -
197.139 -apply (tactic "tac 1")
197.140 -apply (tactic "tac_ren 1")
197.141 -
197.142 -txt {* 4 + 1 *}
197.143 -apply (tactic {* EVERY1[tac, tac, tac, tac] *})
197.144 -
197.145 -
197.146 -txt {* Now the other half *}
197.147 -apply (simp add: Impl.inv1_def split del: split_if)
197.148 -apply (induct_tac a)
197.149 -apply (tactic "EVERY1 [tac, tac]")
197.150 -
197.151 -txt {* detour 1 *}
197.152 -apply (tactic "tac 1")
197.153 -apply (tactic "tac_ren 1")
197.154 -apply (rule impI)
197.155 -apply (erule conjE)+
197.156 -apply (simp (no_asm_simp) add: hdr_sum_def Multiset.count_def Multiset.countm_nonempty_def
197.157 - split add: split_if)
197.158 -txt {* detour 2 *}
197.159 -apply (tactic "tac 1")
197.160 -apply (tactic "tac_ren 1")
197.161 -apply (rule impI)
197.162 -apply (erule conjE)+
197.163 -apply (simp add: Impl.hdr_sum_def Multiset.count_def Multiset.countm_nonempty_def
197.164 - Multiset.delm_nonempty_def split add: split_if)
197.165 -apply (rule allI)
197.166 -apply (rule conjI)
197.167 -apply (rule impI)
197.168 -apply hypsubst
197.169 -apply (rule pred_suc [THEN iffD1])
197.170 -apply (drule less_le_trans)
197.171 -apply (cut_tac eq_packet_imp_eq_hdr [unfolded Packet.hdr_def, THEN countm_props])
197.172 -apply assumption
197.173 -apply assumption
197.174 -
197.175 -apply (rule countm_done_delm [THEN mp, symmetric])
197.176 -apply (rule refl)
197.177 -apply (simp (no_asm_simp) add: Multiset.count_def)
197.178 -
197.179 -apply (rule impI)
197.180 -apply (simp add: neg_flip)
197.181 -apply hypsubst
197.182 -apply (rule countm_spurious_delm)
197.183 -apply (simp (no_asm))
197.184 -
197.185 -apply (tactic "EVERY1 [tac, tac, tac, tac, tac, tac]")
197.186 -
197.187 -done
197.188 -
197.189 -
197.190 -
197.191 -subsubsection {* INVARIANT 2 *}
197.192 -
197.193 -lemma raw_inv2: "invariant impl_ioa inv2"
197.194 -
197.195 - apply (rule invariantI1)
197.196 - txt {* Base case *}
197.197 - apply (simp add: inv2_def receiver_projections sender_projections impl_ioas)
197.198 -
197.199 - apply (simp (no_asm_simp) add: impl_ioas split del: split_if)
197.200 - apply (induct_tac "a")
197.201 -
197.202 - txt {* 10 cases. First 4 are simple, since state doesn't change *}
197.203 -
197.204 - ML_prf {* val tac2 = asm_full_simp_tac (ss addsimps [@{thm inv2_def}]) *}
197.205 -
197.206 - txt {* 10 - 7 *}
197.207 - apply (tactic "EVERY1 [tac2,tac2,tac2,tac2]")
197.208 - txt {* 6 *}
197.209 - apply (tactic {* forward_tac [rewrite_rule [@{thm Impl.inv1_def}]
197.210 - (@{thm raw_inv1} RS @{thm invariantE}) RS conjunct1] 1 *})
197.211 -
197.212 - txt {* 6 - 5 *}
197.213 - apply (tactic "EVERY1 [tac2,tac2]")
197.214 -
197.215 - txt {* 4 *}
197.216 - apply (tactic {* forward_tac [rewrite_rule [@{thm Impl.inv1_def}]
197.217 - (@{thm raw_inv1} RS @{thm invariantE}) RS conjunct1] 1 *})
197.218 - apply (tactic "tac2 1")
197.219 -
197.220 - txt {* 3 *}
197.221 - apply (tactic {* forward_tac [rewrite_rule [@{thm Impl.inv1_def}]
197.222 - (@{thm raw_inv1} RS @{thm invariantE})] 1 *})
197.223 -
197.224 - apply (tactic "tac2 1")
197.225 - apply (tactic {* fold_goals_tac [rewrite_rule [@{thm Packet.hdr_def}]
197.226 - (@{thm Impl.hdr_sum_def})] *})
197.227 - apply arith
197.228 -
197.229 - txt {* 2 *}
197.230 - apply (tactic "tac2 1")
197.231 - apply (tactic {* forward_tac [rewrite_rule [@{thm Impl.inv1_def}]
197.232 - (@{thm raw_inv1} RS @{thm invariantE}) RS conjunct1] 1 *})
197.233 - apply (intro strip)
197.234 - apply (erule conjE)+
197.235 - apply simp
197.236 -
197.237 - txt {* 1 *}
197.238 - apply (tactic "tac2 1")
197.239 - apply (tactic {* forward_tac [rewrite_rule [@{thm Impl.inv1_def}]
197.240 - (@{thm raw_inv1} RS @{thm invariantE}) RS conjunct2] 1 *})
197.241 - apply (intro strip)
197.242 - apply (erule conjE)+
197.243 - apply (tactic {* fold_goals_tac [rewrite_rule [@{thm Packet.hdr_def}] (@{thm Impl.hdr_sum_def})] *})
197.244 - apply simp
197.245 -
197.246 - done
197.247 -
197.248 -
197.249 -subsubsection {* INVARIANT 3 *}
197.250 -
197.251 -lemma raw_inv3: "invariant impl_ioa inv3"
197.252 -
197.253 - apply (rule invariantI)
197.254 - txt {* Base case *}
197.255 - apply (simp add: Impl.inv3_def receiver_projections sender_projections impl_ioas)
197.256 -
197.257 - apply (simp (no_asm_simp) add: impl_ioas split del: split_if)
197.258 - apply (induct_tac "a")
197.259 -
197.260 - ML_prf {* val tac3 = asm_full_simp_tac (ss addsimps [@{thm inv3_def}]) *}
197.261 -
197.262 - txt {* 10 - 8 *}
197.263 -
197.264 - apply (tactic "EVERY1[tac3,tac3,tac3]")
197.265 -
197.266 - apply (tactic "tac_ren 1")
197.267 - apply (intro strip, (erule conjE)+)
197.268 - apply hypsubst
197.269 - apply (erule exE)
197.270 - apply simp
197.271 -
197.272 - txt {* 7 *}
197.273 - apply (tactic "tac3 1")
197.274 - apply (tactic "tac_ren 1")
197.275 - apply force
197.276 -
197.277 - txt {* 6 - 3 *}
197.278 -
197.279 - apply (tactic "EVERY1[tac3,tac3,tac3,tac3]")
197.280 -
197.281 - txt {* 2 *}
197.282 - apply (tactic "asm_full_simp_tac ss 1")
197.283 - apply (simp (no_asm) add: inv3_def)
197.284 - apply (intro strip, (erule conjE)+)
197.285 - apply (rule imp_disjL [THEN iffD1])
197.286 - apply (rule impI)
197.287 - apply (tactic {* forward_tac [rewrite_rule [@{thm Impl.inv2_def}]
197.288 - (@{thm raw_inv2} RS @{thm invariantE})] 1 *})
197.289 - apply simp
197.290 - apply (erule conjE)+
197.291 - apply (rule_tac j = "count (ssent (sen s)) (~sbit (sen s))" and
197.292 - k = "count (rsent (rec s)) (sbit (sen s))" in le_trans)
197.293 - apply (tactic {* forward_tac [rewrite_rule [@{thm inv1_def}]
197.294 - (@{thm raw_inv1} RS @{thm invariantE}) RS conjunct2] 1 *})
197.295 - apply (simp add: hdr_sum_def Multiset.count_def)
197.296 - apply (rule add_le_mono)
197.297 - apply (rule countm_props)
197.298 - apply (simp (no_asm))
197.299 - apply (rule countm_props)
197.300 - apply (simp (no_asm))
197.301 - apply assumption
197.302 -
197.303 - txt {* 1 *}
197.304 - apply (tactic "tac3 1")
197.305 - apply (intro strip, (erule conjE)+)
197.306 - apply (rule imp_disjL [THEN iffD1])
197.307 - apply (rule impI)
197.308 - apply (tactic {* forward_tac [rewrite_rule [@{thm Impl.inv2_def}]
197.309 - (@{thm raw_inv2} RS @{thm invariantE})] 1 *})
197.310 - apply simp
197.311 - done
197.312 -
197.313 -
197.314 -subsubsection {* INVARIANT 4 *}
197.315 -
197.316 -lemma raw_inv4: "invariant impl_ioa inv4"
197.317 -
197.318 - apply (rule invariantI)
197.319 - txt {* Base case *}
197.320 - apply (simp add: Impl.inv4_def receiver_projections sender_projections impl_ioas)
197.321 -
197.322 - apply (simp (no_asm_simp) add: impl_ioas split del: split_if)
197.323 - apply (induct_tac "a")
197.324 -
197.325 - ML_prf {* val tac4 = asm_full_simp_tac (ss addsimps [@{thm inv4_def}]) *}
197.326 -
197.327 - txt {* 10 - 2 *}
197.328 -
197.329 - apply (tactic "EVERY1[tac4,tac4,tac4,tac4,tac4,tac4,tac4,tac4,tac4]")
197.330 -
197.331 - txt {* 2 b *}
197.332 -
197.333 - apply (intro strip, (erule conjE)+)
197.334 - apply (tactic {* forward_tac [rewrite_rule [@{thm Impl.inv2_def}]
197.335 - (@{thm raw_inv2} RS @{thm invariantE})] 1 *})
197.336 - apply simp
197.337 -
197.338 - txt {* 1 *}
197.339 - apply (tactic "tac4 1")
197.340 - apply (intro strip, (erule conjE)+)
197.341 - apply (rule ccontr)
197.342 - apply (tactic {* forward_tac [rewrite_rule [@{thm Impl.inv2_def}]
197.343 - (@{thm raw_inv2} RS @{thm invariantE})] 1 *})
197.344 - apply (tactic {* forward_tac [rewrite_rule [@{thm Impl.inv3_def}]
197.345 - (@{thm raw_inv3} RS @{thm invariantE})] 1 *})
197.346 - apply simp
197.347 - apply (erule_tac x = "m" in allE)
197.348 - apply simp
197.349 - done
197.350 -
197.351 -
197.352 -text {* rebind them *}
197.353 -
197.354 -lemmas inv1 = raw_inv1 [THEN invariantE, unfolded inv1_def]
197.355 - and inv2 = raw_inv2 [THEN invariantE, unfolded inv2_def]
197.356 - and inv3 = raw_inv3 [THEN invariantE, unfolded inv3_def]
197.357 - and inv4 = raw_inv4 [THEN invariantE, unfolded inv4_def]
197.358 -
197.359 -end
198.1 --- a/src/HOLCF/IOA/NTP/Lemmas.thy Sat Nov 27 14:34:54 2010 -0800
198.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
198.3 @@ -1,32 +0,0 @@
198.4 -(* Title: HOL/IOA/NTP/Lemmas.thy
198.5 - Author: Tobias Nipkow & Konrad Slind
198.6 -*)
198.7 -
198.8 -theory Lemmas
198.9 -imports Main
198.10 -begin
198.11 -
198.12 -subsubsection {* Logic *}
198.13 -
198.14 -lemma neg_flip: "(X = (~ Y)) = ((~X) = Y)"
198.15 - by blast
198.16 -
198.17 -
198.18 -subsection {* Sets *}
198.19 -
198.20 -lemma set_lemmas:
198.21 - "f(x) : (UN x. {f(x)})"
198.22 - "f x y : (UN x y. {f x y})"
198.23 - "!!a. (!x. a ~= f(x)) ==> a ~: (UN x. {f(x)})"
198.24 - "!!a. (!x y. a ~= f x y) ==> a ~: (UN x y. {f x y})"
198.25 - by auto
198.26 -
198.27 -
198.28 -subsection {* Arithmetic *}
198.29 -
198.30 -lemma pred_suc: "0<x ==> (x - 1 = y) = (x = Suc(y))"
198.31 - by (simp add: diff_Suc split add: nat.split)
198.32 -
198.33 -lemmas [simp] = hd_append set_lemmas
198.34 -
198.35 -end
199.1 --- a/src/HOLCF/IOA/NTP/Multiset.thy Sat Nov 27 14:34:54 2010 -0800
199.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
199.3 @@ -1,95 +0,0 @@
199.4 -(* Title: HOL/IOA/NTP/Multiset.thy
199.5 - Author: Tobias Nipkow & Konrad Slind
199.6 -*)
199.7 -
199.8 -header {* Axiomatic multisets *}
199.9 -
199.10 -theory Multiset
199.11 -imports Lemmas
199.12 -begin
199.13 -
199.14 -typedecl
199.15 - 'a multiset
199.16 -
199.17 -consts
199.18 -
199.19 - "{|}" :: "'a multiset" ("{|}")
199.20 - addm :: "['a multiset, 'a] => 'a multiset"
199.21 - delm :: "['a multiset, 'a] => 'a multiset"
199.22 - countm :: "['a multiset, 'a => bool] => nat"
199.23 - count :: "['a multiset, 'a] => nat"
199.24 -
199.25 -axioms
199.26 -
199.27 -delm_empty_def:
199.28 - "delm {|} x = {|}"
199.29 -
199.30 -delm_nonempty_def:
199.31 - "delm (addm M x) y == (if x=y then M else addm (delm M y) x)"
199.32 -
199.33 -countm_empty_def:
199.34 - "countm {|} P == 0"
199.35 -
199.36 -countm_nonempty_def:
199.37 - "countm (addm M x) P == countm M P + (if P x then Suc 0 else 0)"
199.38 -
199.39 -count_def:
199.40 - "count M x == countm M (%y. y = x)"
199.41 -
199.42 -"induction":
199.43 - "[| P({|}); !!M x. P(M) ==> P(addm M x) |] ==> P(M)"
199.44 -
199.45 -lemma count_empty:
199.46 - "count {|} x = 0"
199.47 - by (simp add: Multiset.count_def Multiset.countm_empty_def)
199.48 -
199.49 -lemma count_addm_simp:
199.50 - "count (addm M x) y = (if y=x then Suc(count M y) else count M y)"
199.51 - by (simp add: Multiset.count_def Multiset.countm_nonempty_def)
199.52 -
199.53 -lemma count_leq_addm: "count M y <= count (addm M x) y"
199.54 - by (simp add: count_addm_simp)
199.55 -
199.56 -lemma count_delm_simp:
199.57 - "count (delm M x) y = (if y=x then count M y - 1 else count M y)"
199.58 -apply (unfold Multiset.count_def)
199.59 -apply (rule_tac M = "M" in Multiset.induction)
199.60 -apply (simp (no_asm_simp) add: Multiset.delm_empty_def Multiset.countm_empty_def)
199.61 -apply (simp add: Multiset.delm_nonempty_def Multiset.countm_nonempty_def)
199.62 -apply safe
199.63 -apply simp
199.64 -done
199.65 -
199.66 -lemma countm_props: "!!M. (!x. P(x) --> Q(x)) ==> (countm M P <= countm M Q)"
199.67 -apply (rule_tac M = "M" in Multiset.induction)
199.68 - apply (simp (no_asm) add: Multiset.countm_empty_def)
199.69 -apply (simp (no_asm) add: Multiset.countm_nonempty_def)
199.70 -apply auto
199.71 -done
199.72 -
199.73 -lemma countm_spurious_delm: "!!P. ~P(obj) ==> countm M P = countm (delm M obj) P"
199.74 - apply (rule_tac M = "M" in Multiset.induction)
199.75 - apply (simp (no_asm) add: Multiset.delm_empty_def Multiset.countm_empty_def)
199.76 - apply (simp (no_asm_simp) add: Multiset.countm_nonempty_def Multiset.delm_nonempty_def)
199.77 - done
199.78 -
199.79 -
199.80 -lemma pos_count_imp_pos_countm [rule_format (no_asm)]: "!!P. P(x) ==> 0<count M x --> countm M P > 0"
199.81 - apply (rule_tac M = "M" in Multiset.induction)
199.82 - apply (simp (no_asm) add: Multiset.delm_empty_def Multiset.count_def Multiset.countm_empty_def)
199.83 - apply (simp add: Multiset.count_def Multiset.delm_nonempty_def Multiset.countm_nonempty_def)
199.84 - done
199.85 -
199.86 -lemma countm_done_delm:
199.87 - "!!P. P(x) ==> 0<count M x --> countm (delm M x) P = countm M P - 1"
199.88 - apply (rule_tac M = "M" in Multiset.induction)
199.89 - apply (simp (no_asm) add: Multiset.delm_empty_def Multiset.countm_empty_def)
199.90 - apply (simp (no_asm_simp) add: count_addm_simp Multiset.delm_nonempty_def Multiset.countm_nonempty_def pos_count_imp_pos_countm)
199.91 - apply auto
199.92 - done
199.93 -
199.94 -
199.95 -declare count_addm_simp [simp] count_delm_simp [simp]
199.96 - Multiset.countm_empty_def [simp] Multiset.delm_empty_def [simp] count_empty [simp]
199.97 -
199.98 -end
200.1 --- a/src/HOLCF/IOA/NTP/Packet.thy Sat Nov 27 14:34:54 2010 -0800
200.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
200.3 @@ -1,27 +0,0 @@
200.4 -(* Title: HOL/IOA/NTP/Packet.thy
200.5 - Author: Tobias Nipkow & Konrad Slind
200.6 -*)
200.7 -
200.8 -theory Packet
200.9 -imports Multiset
200.10 -begin
200.11 -
200.12 -types
200.13 - 'msg packet = "bool * 'msg"
200.14 -
200.15 -definition
200.16 - hdr :: "'msg packet => bool" where
200.17 - "hdr == fst"
200.18 -
200.19 -definition
200.20 - msg :: "'msg packet => 'msg" where
200.21 - "msg == snd"
200.22 -
200.23 -
200.24 -text {* Instantiation of a tautology? *}
200.25 -lemma eq_packet_imp_eq_hdr: "!x. x = packet --> hdr(x) = hdr(packet)"
200.26 - by simp
200.27 -
200.28 -declare hdr_def [simp] msg_def [simp]
200.29 -
200.30 -end
201.1 --- a/src/HOLCF/IOA/NTP/ROOT.ML Sat Nov 27 14:34:54 2010 -0800
201.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
201.3 @@ -1,9 +0,0 @@
201.4 -(* Title: HOLCF/IOA/NTP/ROOT.ML
201.5 - Author: Tobias Nipkow & Konrad Slind
201.6 -
201.7 -This is the ROOT file for a network transmission protocol (NTP
201.8 -subdirectory), performed in the I/O automata formalization by Olaf
201.9 -Mueller.
201.10 -*)
201.11 -
201.12 -use_thys ["Correctness"];
202.1 --- a/src/HOLCF/IOA/NTP/Read_me Sat Nov 27 14:34:54 2010 -0800
202.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
202.3 @@ -1,167 +0,0 @@
202.4 -Isabelle Verification of a protocol using IOA.
202.5 -
202.6 -------------------------------------------------------------------------------
202.7 -
202.8 -The System.
202.9 -
202.10 -The system being proved correct is a parallel composition of 4 processes:
202.11 -
202.12 - Sender || Schannel || Receiver || Rchannel
202.13 -
202.14 -Accordingly, the system state is a 4-tuple:
202.15 -
202.16 - (Sender_state, Schannel_state, Receiver_state, Rchannel_state)
202.17 -
202.18 -------------------------------------------------------------------------------
202.19 -Packets.
202.20 -
202.21 -The objects going over the medium from Sender to Receiver are modelled
202.22 -with the type
202.23 -
202.24 - 'm packet = bool * 'm
202.25 -
202.26 -This expresses that messages (modelled by polymorphic type "'m") are
202.27 -sent with a single header bit. Packet fields are accessed by
202.28 -
202.29 - hdr<b,m> = b
202.30 - mesg<b,m> = m
202.31 -------------------------------------------------------------------------------
202.32 -
202.33 -The Sender.
202.34 -
202.35 -The state of the process "Sender" is a 5-tuple:
202.36 -
202.37 - 1. messages : 'm list (* sq *)
202.38 - 2. sent : bool multiset (* ssent *)
202.39 - 3. received : bool multiset (* srcvd *)
202.40 - 4. header : bool (* sbit *)
202.41 - 5. mode : bool (* ssending *)
202.42 -
202.43 -
202.44 -The Receiver.
202.45 -
202.46 -The state of the process "Receiver" is a 5-tuple:
202.47 -
202.48 - 1. messages : 'm list (* rq *)
202.49 - 2. replies : bool multiset (* rsent *)
202.50 - 3. received : 'm packet multiset (* rrcvd *)
202.51 - 4. header : bool (* rbit *)
202.52 - 5. mode : bool (* rsending *)
202.53 -
202.54 -
202.55 -The Channels.
202.56 -
202.57 -The Sender and Receiver each have a proprietary channel, named
202.58 -"Schannel" and "Rchannel" respectively. The messages sent by the Sender
202.59 -and Receiver are never lost, but the channels may mix them
202.60 -up. Accordingly, multisets are used in modelling the state of the
202.61 -channels. The state of "Schannel" is modelled with the following type:
202.62 -
202.63 - 'm packet multiset
202.64 -
202.65 -The state of "Rchannel" is modelled with the following type:
202.66 -
202.67 - bool multiset
202.68 -
202.69 -This expresses that replies from the Receiver are just one bit.
202.70 -
202.71 -Both Channels are instances of an abstract channel, that is modelled with
202.72 -the type
202.73 -
202.74 - 'a multiset.
202.75 -
202.76 -------------------------------------------------------------------------------
202.77 -
202.78 -The events.
202.79 -
202.80 -An `execution' of the system is modelled by a sequence of
202.81 -
202.82 - <system_state, action, system_state>
202.83 -
202.84 -transitions. The actions, or events, of the system are described by the
202.85 -following ML-style datatype declaration:
202.86 -
202.87 - 'm action = S_msg ('m) (* Rqt for Sender to send mesg *)
202.88 - | R_msg ('m) (* Mesg taken from Receiver's queue *)
202.89 - | S_pkt_sr ('m packet) (* Packet arrives in Schannel *)
202.90 - | R_pkt_sr ('m packet) (* Packet leaves Schannel *)
202.91 - | S_pkt_rs (bool) (* Packet arrives in Rchannel *)
202.92 - | R_pkt_rs (bool) (* Packet leaves Rchannel *)
202.93 - | C_m_s (* Change mode in Sender *)
202.94 - | C_m_r (* Change mode in Receiver *)
202.95 - | C_r_s (* Change round in Sender *)
202.96 - | C_r_r ('m) (* Change round in Receiver *)
202.97 -
202.98 -------------------------------------------------------------------------------
202.99 -
202.100 -The Specification.
202.101 -
202.102 -The abstract description of system behaviour is given by defining an
202.103 -IO/automaton named "Spec". The state of Spec is a message queue,
202.104 -modelled as an "'m list". The only actions performed in the abstract
202.105 -system are: "S_msg(m)" (putting message "m" at the end of the queue);
202.106 -and "R_msg(m)" (taking message "m" from the head of the queue).
202.107 -
202.108 -
202.109 -------------------------------------------------------------------------------
202.110 -
202.111 -The Verification.
202.112 -
202.113 -The verification proceeds by showing that a certain mapping ("hom") from
202.114 -the concrete system state to the abstract system state is a `weak
202.115 -possibilities map` from "Impl" to "Spec".
202.116 -
202.117 -
202.118 - hom : (S_state * Sch_state * R_state * Rch_state) -> queue
202.119 -
202.120 -The verification depends on several system invariants that relate the
202.121 -states of the 4 processes. These invariants must hold in all reachable
202.122 -states of the system. These invariants are difficult to make sense of;
202.123 -however, we attempt to give loose English paraphrases of them.
202.124 -
202.125 -Invariant 1.
202.126 -
202.127 -This expresses that no packets from the Receiver to the Sender are
202.128 -dropped by Rchannel. The analogous statement for Schannel is also true.
202.129 -
202.130 - !b. R.replies b = S.received b + Rch b
202.131 - /\
202.132 - !pkt. S.sent(hdr(pkt)) = R.received(hdr(b)) + Sch(pkt)
202.133 -
202.134 -
202.135 -Invariant 2.
202.136 -
202.137 -This expresses a complicated relationship about how many messages are
202.138 -sent and header bits.
202.139 -
202.140 - R.header = S.header
202.141 - /\ S.mode = SENDING
202.142 - /\ R.replies (flip S.header) <= S.sent (flip S.header)
202.143 - /\ S.sent (flip S.header) <= R.replies header
202.144 - OR
202.145 - R.header = flip S.header
202.146 - /\ R.mode = SENDING
202.147 - /\ S.sent (flip S.header) <= R.replies S.header
202.148 - /\ R.replies S.header <= S.sent S.header
202.149 -
202.150 -
202.151 -Invariant 3.
202.152 -
202.153 -The number of incoming messages in the Receiver plus the number of those
202.154 -messages in transit (in Schannel) is not greater than the number of
202.155 -replies, provided the message isn't current and the header bits agree.
202.156 -
202.157 - let mesg = <S.header, m>
202.158 - in
202.159 - R.header = S.header
202.160 - ==>
202.161 - !m. (S.messages = [] \/ m ~= hd S.messages)
202.162 - ==> R.received mesg + Sch mesg <= R.replies (flip S.header)
202.163 -
202.164 -
202.165 -Invariant 4.
202.166 -
202.167 -If the headers are opposite, then the Sender queue has a message in it.
202.168 -
202.169 - R.header = flip S.header ==> S.messages ~= []
202.170 -
203.1 --- a/src/HOLCF/IOA/NTP/Receiver.thy Sat Nov 27 14:34:54 2010 -0800
203.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
203.3 @@ -1,96 +0,0 @@
203.4 -(* Title: HOL/IOA/NTP/Receiver.thy
203.5 - Author: Tobias Nipkow & Konrad Slind
203.6 -*)
203.7 -
203.8 -header {* The implementation: receiver *}
203.9 -
203.10 -theory Receiver
203.11 -imports IOA Action
203.12 -begin
203.13 -
203.14 -types
203.15 -
203.16 -'m receiver_state
203.17 -= "'m list * bool multiset * 'm packet multiset * bool * bool"
203.18 -(* messages #replies #received header mode *)
203.19 -
203.20 -definition rq :: "'m receiver_state => 'm list" where "rq == fst"
203.21 -definition rsent :: "'m receiver_state => bool multiset" where "rsent == fst o snd"
203.22 -definition rrcvd :: "'m receiver_state => 'm packet multiset" where "rrcvd == fst o snd o snd"
203.23 -definition rbit :: "'m receiver_state => bool" where "rbit == fst o snd o snd o snd"
203.24 -definition rsending :: "'m receiver_state => bool" where "rsending == snd o snd o snd o snd"
203.25 -
203.26 -definition
203.27 - receiver_asig :: "'m action signature" where
203.28 - "receiver_asig =
203.29 - (UN pkt. {R_pkt(pkt)},
203.30 - (UN m. {R_msg(m)}) Un (UN b. {S_ack(b)}),
203.31 - insert C_m_r (UN m. {C_r_r(m)}))"
203.32 -
203.33 -definition
203.34 - receiver_trans:: "('m action, 'm receiver_state)transition set" where
203.35 -"receiver_trans =
203.36 - {tr. let s = fst(tr);
203.37 - t = snd(snd(tr))
203.38 - in
203.39 - case fst(snd(tr))
203.40 - of
203.41 - S_msg(m) => False |
203.42 - R_msg(m) => rq(s) = (m # rq(t)) &
203.43 - rsent(t)=rsent(s) &
203.44 - rrcvd(t)=rrcvd(s) &
203.45 - rbit(t)=rbit(s) &
203.46 - rsending(t)=rsending(s) |
203.47 - S_pkt(pkt) => False |
203.48 - R_pkt(pkt) => rq(t) = rq(s) &
203.49 - rsent(t) = rsent(s) &
203.50 - rrcvd(t) = addm (rrcvd s) pkt &
203.51 - rbit(t) = rbit(s) &
203.52 - rsending(t) = rsending(s) |
203.53 - S_ack(b) => b = rbit(s) &
203.54 - rq(t) = rq(s) &
203.55 - rsent(t) = addm (rsent s) (rbit s) &
203.56 - rrcvd(t) = rrcvd(s) &
203.57 - rbit(t)=rbit(s) &
203.58 - rsending(s) &
203.59 - rsending(t) |
203.60 - R_ack(b) => False |
203.61 - C_m_s => False |
203.62 - C_m_r => count (rsent s) (~rbit s) < countm (rrcvd s) (%y. hdr(y)=rbit(s)) &
203.63 - rq(t) = rq(s) &
203.64 - rsent(t)=rsent(s) &
203.65 - rrcvd(t)=rrcvd(s) &
203.66 - rbit(t)=rbit(s) &
203.67 - rsending(s) &
203.68 - ~rsending(t) |
203.69 - C_r_s => False |
203.70 - C_r_r(m) => count (rsent s) (rbit s) <= countm (rrcvd s) (%y. hdr(y)=rbit(s)) &
203.71 - count (rsent s) (~rbit s) < count (rrcvd s) (rbit(s),m) &
203.72 - rq(t) = rq(s)@[m] &
203.73 - rsent(t)=rsent(s) &
203.74 - rrcvd(t)=rrcvd(s) &
203.75 - rbit(t) = (~rbit(s)) &
203.76 - ~rsending(s) &
203.77 - rsending(t)}"
203.78 -
203.79 -definition
203.80 - receiver_ioa :: "('m action, 'm receiver_state)ioa" where
203.81 - "receiver_ioa =
203.82 - (receiver_asig, {([],{|},{|},False,False)}, receiver_trans,{},{})"
203.83 -
203.84 -lemma in_receiver_asig:
203.85 - "S_msg(m) ~: actions(receiver_asig)"
203.86 - "R_msg(m) : actions(receiver_asig)"
203.87 - "S_pkt(pkt) ~: actions(receiver_asig)"
203.88 - "R_pkt(pkt) : actions(receiver_asig)"
203.89 - "S_ack(b) : actions(receiver_asig)"
203.90 - "R_ack(b) ~: actions(receiver_asig)"
203.91 - "C_m_s ~: actions(receiver_asig)"
203.92 - "C_m_r : actions(receiver_asig)"
203.93 - "C_r_s ~: actions(receiver_asig)"
203.94 - "C_r_r(m) : actions(receiver_asig)"
203.95 - by (simp_all add: receiver_asig_def actions_def asig_projections)
203.96 -
203.97 -lemmas receiver_projections = rq_def rsent_def rrcvd_def rbit_def rsending_def
203.98 -
203.99 -end
204.1 --- a/src/HOLCF/IOA/NTP/Sender.thy Sat Nov 27 14:34:54 2010 -0800
204.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
204.3 @@ -1,92 +0,0 @@
204.4 -(* Title: HOL/IOA/NTP/Sender.thy
204.5 - Author: Tobias Nipkow & Konrad Slind
204.6 -*)
204.7 -
204.8 -header {* The implementation: sender *}
204.9 -
204.10 -theory Sender
204.11 -imports IOA Action
204.12 -begin
204.13 -
204.14 -types
204.15 -'m sender_state = "'m list * bool multiset * bool multiset * bool * bool"
204.16 -(* messages #sent #received header mode *)
204.17 -
204.18 -definition sq :: "'m sender_state => 'm list" where "sq = fst"
204.19 -definition ssent :: "'m sender_state => bool multiset" where "ssent = fst o snd"
204.20 -definition srcvd :: "'m sender_state => bool multiset" where "srcvd = fst o snd o snd"
204.21 -definition sbit :: "'m sender_state => bool" where "sbit = fst o snd o snd o snd"
204.22 -definition ssending :: "'m sender_state => bool" where "ssending = snd o snd o snd o snd"
204.23 -
204.24 -definition
204.25 - sender_asig :: "'m action signature" where
204.26 - "sender_asig = ((UN m. {S_msg(m)}) Un (UN b. {R_ack(b)}),
204.27 - UN pkt. {S_pkt(pkt)},
204.28 - {C_m_s,C_r_s})"
204.29 -
204.30 -definition
204.31 - sender_trans :: "('m action, 'm sender_state)transition set" where
204.32 - "sender_trans =
204.33 - {tr. let s = fst(tr);
204.34 - t = snd(snd(tr))
204.35 - in case fst(snd(tr))
204.36 - of
204.37 - S_msg(m) => sq(t)=sq(s)@[m] &
204.38 - ssent(t)=ssent(s) &
204.39 - srcvd(t)=srcvd(s) &
204.40 - sbit(t)=sbit(s) &
204.41 - ssending(t)=ssending(s) |
204.42 - R_msg(m) => False |
204.43 - S_pkt(pkt) => hdr(pkt) = sbit(s) &
204.44 - (? Q. sq(s) = (msg(pkt)#Q)) &
204.45 - sq(t) = sq(s) &
204.46 - ssent(t) = addm (ssent s) (sbit s) &
204.47 - srcvd(t) = srcvd(s) &
204.48 - sbit(t) = sbit(s) &
204.49 - ssending(s) &
204.50 - ssending(t) |
204.51 - R_pkt(pkt) => False |
204.52 - S_ack(b) => False |
204.53 - R_ack(b) => sq(t)=sq(s) &
204.54 - ssent(t)=ssent(s) &
204.55 - srcvd(t) = addm (srcvd s) b &
204.56 - sbit(t)=sbit(s) &
204.57 - ssending(t)=ssending(s) |
204.58 - C_m_s => count (ssent s) (~sbit s) < count (srcvd s) (~sbit s) &
204.59 - sq(t)=sq(s) &
204.60 - ssent(t)=ssent(s) &
204.61 - srcvd(t)=srcvd(s) &
204.62 - sbit(t)=sbit(s) &
204.63 - ssending(s) &
204.64 - ~ssending(t) |
204.65 - C_m_r => False |
204.66 - C_r_s => count (ssent s) (sbit s) <= count (srcvd s) (~sbit s) &
204.67 - sq(t)=tl(sq(s)) &
204.68 - ssent(t)=ssent(s) &
204.69 - srcvd(t)=srcvd(s) &
204.70 - sbit(t) = (~sbit(s)) &
204.71 - ~ssending(s) &
204.72 - ssending(t) |
204.73 - C_r_r(m) => False}"
204.74 -
204.75 -definition
204.76 - sender_ioa :: "('m action, 'm sender_state)ioa" where
204.77 - "sender_ioa =
204.78 - (sender_asig, {([],{|},{|},False,True)}, sender_trans,{},{})"
204.79 -
204.80 -lemma in_sender_asig:
204.81 - "S_msg(m) : actions(sender_asig)"
204.82 - "R_msg(m) ~: actions(sender_asig)"
204.83 - "S_pkt(pkt) : actions(sender_asig)"
204.84 - "R_pkt(pkt) ~: actions(sender_asig)"
204.85 - "S_ack(b) ~: actions(sender_asig)"
204.86 - "R_ack(b) : actions(sender_asig)"
204.87 - "C_m_s : actions(sender_asig)"
204.88 - "C_m_r ~: actions(sender_asig)"
204.89 - "C_r_s : actions(sender_asig)"
204.90 - "C_r_r(m) ~: actions(sender_asig)"
204.91 - by (simp_all add: sender_asig_def actions_def asig_projections)
204.92 -
204.93 -lemmas sender_projections = sq_def ssent_def srcvd_def sbit_def ssending_def
204.94 -
204.95 -end
205.1 --- a/src/HOLCF/IOA/NTP/Spec.thy Sat Nov 27 14:34:54 2010 -0800
205.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
205.3 @@ -1,40 +0,0 @@
205.4 -(* Title: HOL/IOA/NTP/Spec.thy
205.5 - Author: Tobias Nipkow & Konrad Slind
205.6 -*)
205.7 -
205.8 -header {* The specification of reliable transmission *}
205.9 -
205.10 -theory Spec
205.11 -imports IOA Action
205.12 -begin
205.13 -
205.14 -definition
205.15 - spec_sig :: "'m action signature" where
205.16 - sig_def: "spec_sig = (UN m.{S_msg(m)},
205.17 - UN m.{R_msg(m)},
205.18 - {})"
205.19 -
205.20 -definition
205.21 - spec_trans :: "('m action, 'm list)transition set" where
205.22 - trans_def: "spec_trans =
205.23 - {tr. let s = fst(tr);
205.24 - t = snd(snd(tr))
205.25 - in
205.26 - case fst(snd(tr))
205.27 - of
205.28 - S_msg(m) => t = s@[m] |
205.29 - R_msg(m) => s = (m#t) |
205.30 - S_pkt(pkt) => False |
205.31 - R_pkt(pkt) => False |
205.32 - S_ack(b) => False |
205.33 - R_ack(b) => False |
205.34 - C_m_s => False |
205.35 - C_m_r => False |
205.36 - C_r_s => False |
205.37 - C_r_r(m) => False}"
205.38 -
205.39 -definition
205.40 - spec_ioa :: "('m action, 'm list)ioa" where
205.41 - ioa_def: "spec_ioa = (spec_sig, {[]}, spec_trans,{},{})"
205.42 -
205.43 -end
206.1 --- a/src/HOLCF/IOA/README.html Sat Nov 27 14:34:54 2010 -0800
206.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
206.3 @@ -1,24 +0,0 @@
206.4 -<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN" "http://www.w3.org/TR/html4/loose.dtd">
206.5 -
206.6 -<HTML>
206.7 -
206.8 -<HEAD>
206.9 - <meta http-equiv="Content-Type" content="text/html; charset=iso-8859-1">
206.10 - <TITLE>HOLCF/IOA/README</TITLE>
206.11 -</HEAD>
206.12 -
206.13 -<BODY>
206.14 -
206.15 -<H3>IOA: A formalization of I/O automata in HOLCF</H3>
206.16 -
206.17 -Author: Olaf Müller<BR>
206.18 -Copyright 1997 Technische Universität München<P>
206.19 -
206.20 -The distribution contains simulation relations, temporal logic, and an abstraction theory.
206.21 -Everything is based upon a domain-theoretic model of finite and infinite sequences.
206.22 -<p>
206.23 -For details see the <A HREF="http://www4.informatik.tu-muenchen.de/~isabelle/IOA/">IOA project</a>.
206.24 -
206.25 -</BODY></HTML>
206.26 -
206.27 -
207.1 --- a/src/HOLCF/IOA/ROOT.ML Sat Nov 27 14:34:54 2010 -0800
207.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
207.3 @@ -1,8 +0,0 @@
207.4 -(* Title: HOLCF/IOA/ROOT.ML
207.5 - Author: Olaf Mueller
207.6 -
207.7 -Formalization of a semantic model of I/O-Automata. See README.html
207.8 -for details.
207.9 -*)
207.10 -
207.11 -use_thys ["meta_theory/Abstraction"];
208.1 --- a/src/HOLCF/IOA/Storage/Action.thy Sat Nov 27 14:34:54 2010 -0800
208.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
208.3 @@ -1,16 +0,0 @@
208.4 -(* Title: HOLCF/IOA/ABP/Action.thy
208.5 - Author: Olaf Müller
208.6 -*)
208.7 -
208.8 -header {* The set of all actions of the system *}
208.9 -
208.10 -theory Action
208.11 -imports Main
208.12 -begin
208.13 -
208.14 -datatype action = New | Loc nat | Free nat
208.15 -
208.16 -lemma [cong]: "!!x. x = y ==> action_case a b c x = action_case a b c y"
208.17 - by simp
208.18 -
208.19 -end
209.1 --- a/src/HOLCF/IOA/Storage/Correctness.thy Sat Nov 27 14:34:54 2010 -0800
209.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
209.3 @@ -1,75 +0,0 @@
209.4 -(* Title: HOL/IOA/example/Correctness.thy
209.5 - Author: Olaf Müller
209.6 -*)
209.7 -
209.8 -header {* Correctness Proof *}
209.9 -
209.10 -theory Correctness
209.11 -imports SimCorrectness Spec Impl
209.12 -begin
209.13 -
209.14 -default_sort type
209.15 -
209.16 -definition
209.17 - sim_relation :: "((nat * bool) * (nat set * bool)) set" where
209.18 - "sim_relation = {qua. let c = fst qua; a = snd qua ;
209.19 - k = fst c; b = snd c;
209.20 - used = fst a; c = snd a
209.21 - in
209.22 - (! l:used. l < k) & b=c}"
209.23 -
209.24 -declare split_paired_Ex [simp del]
209.25 -
209.26 -
209.27 -(* Idea: instead of impl_con_lemma do not rewrite impl_ioa, but derive
209.28 - simple lemmas asig_of impl_ioa = impl_sig, trans_of impl_ioa = impl_trans
209.29 - Idea: ?ex. move .. should be generally replaced by a step via a subst tac if desired,
209.30 - as this can be done globally *)
209.31 -
209.32 -lemma issimulation:
209.33 - "is_simulation sim_relation impl_ioa spec_ioa"
209.34 -apply (simp (no_asm) add: is_simulation_def)
209.35 -apply (rule conjI)
209.36 -txt {* start states *}
209.37 -apply (auto)[1]
209.38 -apply (rule_tac x = " ({},False) " in exI)
209.39 -apply (simp add: sim_relation_def starts_of_def spec_ioa_def impl_ioa_def)
209.40 -txt {* main-part *}
209.41 -apply (rule allI)+
209.42 -apply (rule imp_conj_lemma)
209.43 -apply (rename_tac k b used c k' b' a)
209.44 -apply (induct_tac "a")
209.45 -apply (simp_all (no_asm) add: sim_relation_def impl_ioa_def impl_trans_def trans_of_def)
209.46 -apply auto
209.47 -txt {* NEW *}
209.48 -apply (rule_tac x = "(used,True)" in exI)
209.49 -apply simp
209.50 -apply (rule transition_is_ex)
209.51 -apply (simp (no_asm) add: spec_ioa_def spec_trans_def trans_of_def)
209.52 -txt {* LOC *}
209.53 -apply (rule_tac x = " (used Un {k},False) " in exI)
209.54 -apply (simp add: less_SucI)
209.55 -apply (rule transition_is_ex)
209.56 -apply (simp (no_asm) add: spec_ioa_def spec_trans_def trans_of_def)
209.57 -apply fast
209.58 -txt {* FREE *}
209.59 -apply (rule_tac x = " (used - {nat},c) " in exI)
209.60 -apply simp
209.61 -apply (rule transition_is_ex)
209.62 -apply (simp (no_asm) add: spec_ioa_def spec_trans_def trans_of_def)
209.63 -done
209.64 -
209.65 -
209.66 -lemma implementation:
209.67 -"impl_ioa =<| spec_ioa"
209.68 -apply (unfold ioa_implements_def)
209.69 -apply (rule conjI)
209.70 -apply (simp (no_asm) add: impl_sig_def spec_sig_def impl_ioa_def spec_ioa_def
209.71 - asig_outputs_def asig_of_def asig_inputs_def)
209.72 -apply (rule trace_inclusion_for_simulations)
209.73 -apply (simp (no_asm) add: impl_sig_def spec_sig_def impl_ioa_def spec_ioa_def
209.74 - externals_def asig_outputs_def asig_of_def asig_inputs_def)
209.75 -apply (rule issimulation)
209.76 -done
209.77 -
209.78 -end
210.1 --- a/src/HOLCF/IOA/Storage/Impl.thy Sat Nov 27 14:34:54 2010 -0800
210.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
210.3 @@ -1,39 +0,0 @@
210.4 -(* Title: HOL/IOA/example/Spec.thy
210.5 - Author: Olaf Müller
210.6 -*)
210.7 -
210.8 -header {* The implementation of a memory *}
210.9 -
210.10 -theory Impl
210.11 -imports IOA Action
210.12 -begin
210.13 -
210.14 -definition
210.15 - impl_sig :: "action signature" where
210.16 - "impl_sig = (UN l.{Free l} Un {New},
210.17 - UN l.{Loc l},
210.18 - {})"
210.19 -
210.20 -definition
210.21 - impl_trans :: "(action, nat * bool)transition set" where
210.22 - "impl_trans =
210.23 - {tr. let s = fst(tr); k = fst s; b = snd s;
210.24 - t = snd(snd(tr)); k' = fst t; b' = snd t
210.25 - in
210.26 - case fst(snd(tr))
210.27 - of
210.28 - New => k' = k & b' |
210.29 - Loc l => b & l= k & k'= (Suc k) & ~b' |
210.30 - Free l => k'=k & b'=b}"
210.31 -
210.32 -definition
210.33 - impl_ioa :: "(action, nat * bool)ioa" where
210.34 - "impl_ioa = (impl_sig, {(0,False)}, impl_trans,{},{})"
210.35 -
210.36 -lemma in_impl_asig:
210.37 - "New : actions(impl_sig) &
210.38 - Loc l : actions(impl_sig) &
210.39 - Free l : actions(impl_sig) "
210.40 - by (simp add: impl_sig_def actions_def asig_projections)
210.41 -
210.42 -end
211.1 --- a/src/HOLCF/IOA/Storage/ROOT.ML Sat Nov 27 14:34:54 2010 -0800
211.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
211.3 @@ -1,6 +0,0 @@
211.4 -(* Title: HOLCF/IOA/Storage/ROOT.ML
211.5 - Author: Olaf Mueller
211.6 -
211.7 -Memory storage case study.
211.8 -*)
211.9 -use_thys ["Correctness"];
212.1 --- a/src/HOLCF/IOA/Storage/Spec.thy Sat Nov 27 14:34:54 2010 -0800
212.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
212.3 @@ -1,33 +0,0 @@
212.4 -(* Title: HOL/IOA/example/Spec.thy
212.5 - Author: Olaf Müller
212.6 -*)
212.7 -
212.8 -header {* The specification of a memory *}
212.9 -
212.10 -theory Spec
212.11 -imports IOA Action
212.12 -begin
212.13 -
212.14 -definition
212.15 - spec_sig :: "action signature" where
212.16 - "spec_sig = (UN l.{Free l} Un {New},
212.17 - UN l.{Loc l},
212.18 - {})"
212.19 -
212.20 -definition
212.21 - spec_trans :: "(action, nat set * bool)transition set" where
212.22 - "spec_trans =
212.23 - {tr. let s = fst(tr); used = fst s; c = snd s;
212.24 - t = snd(snd(tr)); used' = fst t; c' = snd t
212.25 - in
212.26 - case fst(snd(tr))
212.27 - of
212.28 - New => used' = used & c' |
212.29 - Loc l => c & l~:used & used'= used Un {l} & ~c' |
212.30 - Free l => used'=used - {l} & c'=c}"
212.31 -
212.32 -definition
212.33 - spec_ioa :: "(action, nat set * bool)ioa" where
212.34 - "spec_ioa = (spec_sig, {({},False)}, spec_trans,{},{})"
212.35 -
212.36 -end
213.1 --- a/src/HOLCF/IOA/ex/ROOT.ML Sat Nov 27 14:34:54 2010 -0800
213.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
213.3 @@ -1,5 +0,0 @@
213.4 -(* Title: HOLCF/IOA/ex/ROOT.ML
213.5 - Author: Olaf Mueller
213.6 -*)
213.7 -
213.8 -use_thys ["TrivEx", "TrivEx2"];
214.1 --- a/src/HOLCF/IOA/ex/TrivEx.thy Sat Nov 27 14:34:54 2010 -0800
214.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
214.3 @@ -1,72 +0,0 @@
214.4 -(* Title: HOLCF/IOA/TrivEx.thy
214.5 - Author: Olaf Müller
214.6 -*)
214.7 -
214.8 -header {* Trivial Abstraction Example *}
214.9 -
214.10 -theory TrivEx
214.11 -imports Abstraction
214.12 -begin
214.13 -
214.14 -datatype action = INC
214.15 -
214.16 -definition
214.17 - C_asig :: "action signature" where
214.18 - "C_asig = ({},{INC},{})"
214.19 -definition
214.20 - C_trans :: "(action, nat)transition set" where
214.21 - "C_trans =
214.22 - {tr. let s = fst(tr);
214.23 - t = snd(snd(tr))
214.24 - in case fst(snd(tr))
214.25 - of
214.26 - INC => t = Suc(s)}"
214.27 -definition
214.28 - C_ioa :: "(action, nat)ioa" where
214.29 - "C_ioa = (C_asig, {0}, C_trans,{},{})"
214.30 -
214.31 -definition
214.32 - A_asig :: "action signature" where
214.33 - "A_asig = ({},{INC},{})"
214.34 -definition
214.35 - A_trans :: "(action, bool)transition set" where
214.36 - "A_trans =
214.37 - {tr. let s = fst(tr);
214.38 - t = snd(snd(tr))
214.39 - in case fst(snd(tr))
214.40 - of
214.41 - INC => t = True}"
214.42 -definition
214.43 - A_ioa :: "(action, bool)ioa" where
214.44 - "A_ioa = (A_asig, {False}, A_trans,{},{})"
214.45 -
214.46 -definition
214.47 - h_abs :: "nat => bool" where
214.48 - "h_abs n = (n~=0)"
214.49 -
214.50 -axiomatization where
214.51 - MC_result: "validIOA A_ioa (<>[] <%(b,a,c). b>)"
214.52 -
214.53 -lemma h_abs_is_abstraction:
214.54 - "is_abstraction h_abs C_ioa A_ioa"
214.55 -apply (unfold is_abstraction_def)
214.56 -apply (rule conjI)
214.57 -txt {* start states *}
214.58 -apply (simp (no_asm) add: h_abs_def starts_of_def C_ioa_def A_ioa_def)
214.59 -txt {* step case *}
214.60 -apply (rule allI)+
214.61 -apply (rule imp_conj_lemma)
214.62 -apply (simp (no_asm) add: trans_of_def C_ioa_def A_ioa_def C_trans_def A_trans_def)
214.63 -apply (induct_tac "a")
214.64 -apply (simp add: h_abs_def)
214.65 -done
214.66 -
214.67 -lemma TrivEx_abstraction: "validIOA C_ioa (<>[] <%(n,a,m). n~=0>)"
214.68 -apply (rule AbsRuleT1)
214.69 -apply (rule h_abs_is_abstraction)
214.70 -apply (rule MC_result)
214.71 -apply abstraction
214.72 -apply (simp add: h_abs_def)
214.73 -done
214.74 -
214.75 -end
215.1 --- a/src/HOLCF/IOA/ex/TrivEx2.thy Sat Nov 27 14:34:54 2010 -0800
215.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
215.3 @@ -1,102 +0,0 @@
215.4 -(* Title: HOLCF/IOA/TrivEx.thy
215.5 - Author: Olaf Müller
215.6 -*)
215.7 -
215.8 -header {* Trivial Abstraction Example with fairness *}
215.9 -
215.10 -theory TrivEx2
215.11 -imports IOA Abstraction
215.12 -begin
215.13 -
215.14 -datatype action = INC
215.15 -
215.16 -definition
215.17 - C_asig :: "action signature" where
215.18 - "C_asig = ({},{INC},{})"
215.19 -definition
215.20 - C_trans :: "(action, nat)transition set" where
215.21 - "C_trans =
215.22 - {tr. let s = fst(tr);
215.23 - t = snd(snd(tr))
215.24 - in case fst(snd(tr))
215.25 - of
215.26 - INC => t = Suc(s)}"
215.27 -definition
215.28 - C_ioa :: "(action, nat)ioa" where
215.29 - "C_ioa = (C_asig, {0}, C_trans,{},{})"
215.30 -definition
215.31 - C_live_ioa :: "(action, nat)live_ioa" where
215.32 - "C_live_ioa = (C_ioa, WF C_ioa {INC})"
215.33 -
215.34 -definition
215.35 - A_asig :: "action signature" where
215.36 - "A_asig = ({},{INC},{})"
215.37 -definition
215.38 - A_trans :: "(action, bool)transition set" where
215.39 - "A_trans =
215.40 - {tr. let s = fst(tr);
215.41 - t = snd(snd(tr))
215.42 - in case fst(snd(tr))
215.43 - of
215.44 - INC => t = True}"
215.45 -definition
215.46 - A_ioa :: "(action, bool)ioa" where
215.47 - "A_ioa = (A_asig, {False}, A_trans,{},{})"
215.48 -definition
215.49 - A_live_ioa :: "(action, bool)live_ioa" where
215.50 - "A_live_ioa = (A_ioa, WF A_ioa {INC})"
215.51 -
215.52 -definition
215.53 - h_abs :: "nat => bool" where
215.54 - "h_abs n = (n~=0)"
215.55 -
215.56 -axiomatization where
215.57 - MC_result: "validLIOA (A_ioa,WF A_ioa {INC}) (<>[] <%(b,a,c). b>)"
215.58 -
215.59 -
215.60 -lemma h_abs_is_abstraction:
215.61 -"is_abstraction h_abs C_ioa A_ioa"
215.62 -apply (unfold is_abstraction_def)
215.63 -apply (rule conjI)
215.64 -txt {* start states *}
215.65 -apply (simp (no_asm) add: h_abs_def starts_of_def C_ioa_def A_ioa_def)
215.66 -txt {* step case *}
215.67 -apply (rule allI)+
215.68 -apply (rule imp_conj_lemma)
215.69 -apply (simp (no_asm) add: trans_of_def C_ioa_def A_ioa_def C_trans_def A_trans_def)
215.70 -apply (induct_tac "a")
215.71 -apply (simp (no_asm) add: h_abs_def)
215.72 -done
215.73 -
215.74 -
215.75 -lemma Enabled_implication:
215.76 - "!!s. Enabled A_ioa {INC} (h_abs s) ==> Enabled C_ioa {INC} s"
215.77 - apply (unfold Enabled_def enabled_def h_abs_def A_ioa_def C_ioa_def A_trans_def
215.78 - C_trans_def trans_of_def)
215.79 - apply auto
215.80 - done
215.81 -
215.82 -
215.83 -lemma h_abs_is_liveabstraction:
215.84 -"is_live_abstraction h_abs (C_ioa, WF C_ioa {INC}) (A_ioa, WF A_ioa {INC})"
215.85 -apply (unfold is_live_abstraction_def)
215.86 -apply auto
215.87 -txt {* is_abstraction *}
215.88 -apply (rule h_abs_is_abstraction)
215.89 -txt {* temp_weakening *}
215.90 -apply abstraction
215.91 -apply (erule Enabled_implication)
215.92 -done
215.93 -
215.94 -
215.95 -lemma TrivEx2_abstraction:
215.96 - "validLIOA C_live_ioa (<>[] <%(n,a,m). n~=0>)"
215.97 -apply (unfold C_live_ioa_def)
215.98 -apply (rule AbsRuleT2)
215.99 -apply (rule h_abs_is_liveabstraction)
215.100 -apply (rule MC_result)
215.101 -apply abstraction
215.102 -apply (simp add: h_abs_def)
215.103 -done
215.104 -
215.105 -end
216.1 --- a/src/HOLCF/IOA/meta_theory/Abstraction.thy Sat Nov 27 14:34:54 2010 -0800
216.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
216.3 @@ -1,615 +0,0 @@
216.4 -(* Title: HOLCF/IOA/meta_theory/Abstraction.thy
216.5 - Author: Olaf Müller
216.6 -*)
216.7 -
216.8 -header {* Abstraction Theory -- tailored for I/O automata *}
216.9 -
216.10 -theory Abstraction
216.11 -imports LiveIOA
216.12 -begin
216.13 -
216.14 -default_sort type
216.15 -
216.16 -definition
216.17 - cex_abs :: "('s1 => 's2) => ('a,'s1)execution => ('a,'s2)execution" where
216.18 - "cex_abs f ex = (f (fst ex), Map (%(a,t). (a,f t))$(snd ex))"
216.19 -definition
216.20 - -- {* equals cex_abs on Sequences -- after ex2seq application *}
216.21 - cex_absSeq :: "('s1 => 's2) => ('a option,'s1)transition Seq => ('a option,'s2)transition Seq" where
216.22 - "cex_absSeq f = (%s. Map (%(s,a,t). (f s,a,f t))$s)"
216.23 -
216.24 -definition
216.25 - is_abstraction ::"[('s1=>'s2),('a,'s1)ioa,('a,'s2)ioa] => bool" where
216.26 - "is_abstraction f C A =
216.27 - ((!s:starts_of(C). f(s):starts_of(A)) &
216.28 - (!s t a. reachable C s & s -a--C-> t
216.29 - --> (f s) -a--A-> (f t)))"
216.30 -
216.31 -definition
216.32 - weakeningIOA :: "('a,'s2)ioa => ('a,'s1)ioa => ('s1 => 's2) => bool" where
216.33 - "weakeningIOA A C h = (!ex. ex : executions C --> cex_abs h ex : executions A)"
216.34 -definition
216.35 - temp_strengthening :: "('a,'s2)ioa_temp => ('a,'s1)ioa_temp => ('s1 => 's2) => bool" where
216.36 - "temp_strengthening Q P h = (!ex. (cex_abs h ex |== Q) --> (ex |== P))"
216.37 -definition
216.38 - temp_weakening :: "('a,'s2)ioa_temp => ('a,'s1)ioa_temp => ('s1 => 's2) => bool" where
216.39 - "temp_weakening Q P h = temp_strengthening (.~ Q) (.~ P) h"
216.40 -
216.41 -definition
216.42 - state_strengthening :: "('a,'s2)step_pred => ('a,'s1)step_pred => ('s1 => 's2) => bool" where
216.43 - "state_strengthening Q P h = (!s t a. Q (h(s),a,h(t)) --> P (s,a,t))"
216.44 -definition
216.45 - state_weakening :: "('a,'s2)step_pred => ('a,'s1)step_pred => ('s1 => 's2) => bool" where
216.46 - "state_weakening Q P h = state_strengthening (.~Q) (.~P) h"
216.47 -
216.48 -definition
216.49 - is_live_abstraction :: "('s1 => 's2) => ('a,'s1)live_ioa => ('a,'s2)live_ioa => bool" where
216.50 - "is_live_abstraction h CL AM =
216.51 - (is_abstraction h (fst CL) (fst AM) &
216.52 - temp_weakening (snd AM) (snd CL) h)"
216.53 -
216.54 -
216.55 -axiomatization where
216.56 -(* thm about ex2seq which is not provable by induction as ex2seq is not continous *)
216.57 -ex2seq_abs_cex:
216.58 - "ex2seq (cex_abs h ex) = cex_absSeq h (ex2seq ex)"
216.59 -
216.60 -axiomatization where
216.61 -(* analog to the proved thm strength_Box - proof skipped as trivial *)
216.62 -weak_Box:
216.63 -"temp_weakening P Q h
216.64 - ==> temp_weakening ([] P) ([] Q) h"
216.65 -
216.66 -axiomatization where
216.67 -(* analog to the proved thm strength_Next - proof skipped as trivial *)
216.68 -weak_Next:
216.69 -"temp_weakening P Q h
216.70 - ==> temp_weakening (Next P) (Next Q) h"
216.71 -
216.72 -
216.73 -subsection "cex_abs"
216.74 -
216.75 -lemma cex_abs_UU: "cex_abs f (s,UU) = (f s, UU)"
216.76 - by (simp add: cex_abs_def)
216.77 -
216.78 -lemma cex_abs_nil: "cex_abs f (s,nil) = (f s, nil)"
216.79 - by (simp add: cex_abs_def)
216.80 -
216.81 -lemma cex_abs_cons: "cex_abs f (s,(a,t)>>ex) = (f s, (a,f t) >> (snd (cex_abs f (t,ex))))"
216.82 - by (simp add: cex_abs_def)
216.83 -
216.84 -declare cex_abs_UU [simp] cex_abs_nil [simp] cex_abs_cons [simp]
216.85 -
216.86 -
216.87 -subsection "lemmas"
216.88 -
216.89 -lemma temp_weakening_def2: "temp_weakening Q P h = (! ex. (ex |== P) --> (cex_abs h ex |== Q))"
216.90 - apply (simp add: temp_weakening_def temp_strengthening_def NOT_def temp_sat_def satisfies_def)
216.91 - apply auto
216.92 - done
216.93 -
216.94 -lemma state_weakening_def2: "state_weakening Q P h = (! s t a. P (s,a,t) --> Q (h(s),a,h(t)))"
216.95 - apply (simp add: state_weakening_def state_strengthening_def NOT_def)
216.96 - apply auto
216.97 - done
216.98 -
216.99 -
216.100 -subsection "Abstraction Rules for Properties"
216.101 -
216.102 -lemma exec_frag_abstraction [rule_format]:
216.103 - "[| is_abstraction h C A |] ==>
216.104 - !s. reachable C s & is_exec_frag C (s,xs)
216.105 - --> is_exec_frag A (cex_abs h (s,xs))"
216.106 -apply (unfold cex_abs_def)
216.107 -apply simp
216.108 -apply (tactic {* pair_induct_tac @{context} "xs" [@{thm is_exec_frag_def}] 1 *})
216.109 -txt {* main case *}
216.110 -apply (auto dest: reachable.reachable_n simp add: is_abstraction_def)
216.111 -done
216.112 -
216.113 -
216.114 -lemma abs_is_weakening: "is_abstraction h C A ==> weakeningIOA A C h"
216.115 -apply (simp add: weakeningIOA_def)
216.116 -apply auto
216.117 -apply (simp add: executions_def)
216.118 -txt {* start state *}
216.119 -apply (rule conjI)
216.120 -apply (simp add: is_abstraction_def cex_abs_def)
216.121 -txt {* is-execution-fragment *}
216.122 -apply (erule exec_frag_abstraction)
216.123 -apply (simp add: reachable.reachable_0)
216.124 -done
216.125 -
216.126 -
216.127 -lemma AbsRuleT1: "[|is_abstraction h C A; validIOA A Q; temp_strengthening Q P h |]
216.128 - ==> validIOA C P"
216.129 -apply (drule abs_is_weakening)
216.130 -apply (simp add: weakeningIOA_def validIOA_def temp_strengthening_def)
216.131 -apply (auto simp add: split_paired_all)
216.132 -done
216.133 -
216.134 -
216.135 -(* FIX: Nach TLS.ML *)
216.136 -
216.137 -lemma IMPLIES_temp_sat: "(ex |== P .--> Q) = ((ex |== P) --> (ex |== Q))"
216.138 - by (simp add: IMPLIES_def temp_sat_def satisfies_def)
216.139 -
216.140 -lemma AND_temp_sat: "(ex |== P .& Q) = ((ex |== P) & (ex |== Q))"
216.141 - by (simp add: AND_def temp_sat_def satisfies_def)
216.142 -
216.143 -lemma OR_temp_sat: "(ex |== P .| Q) = ((ex |== P) | (ex |== Q))"
216.144 - by (simp add: OR_def temp_sat_def satisfies_def)
216.145 -
216.146 -lemma NOT_temp_sat: "(ex |== .~ P) = (~ (ex |== P))"
216.147 - by (simp add: NOT_def temp_sat_def satisfies_def)
216.148 -
216.149 -declare IMPLIES_temp_sat [simp] AND_temp_sat [simp] OR_temp_sat [simp] NOT_temp_sat [simp]
216.150 -
216.151 -
216.152 -lemma AbsRuleT2:
216.153 - "[|is_live_abstraction h (C,L) (A,M);
216.154 - validLIOA (A,M) Q; temp_strengthening Q P h |]
216.155 - ==> validLIOA (C,L) P"
216.156 -apply (unfold is_live_abstraction_def)
216.157 -apply auto
216.158 -apply (drule abs_is_weakening)
216.159 -apply (simp add: weakeningIOA_def temp_weakening_def2 validLIOA_def validIOA_def temp_strengthening_def)
216.160 -apply (auto simp add: split_paired_all)
216.161 -done
216.162 -
216.163 -
216.164 -lemma AbsRuleTImprove:
216.165 - "[|is_live_abstraction h (C,L) (A,M);
216.166 - validLIOA (A,M) (H1 .--> Q); temp_strengthening Q P h;
216.167 - temp_weakening H1 H2 h; validLIOA (C,L) H2 |]
216.168 - ==> validLIOA (C,L) P"
216.169 -apply (unfold is_live_abstraction_def)
216.170 -apply auto
216.171 -apply (drule abs_is_weakening)
216.172 -apply (simp add: weakeningIOA_def temp_weakening_def2 validLIOA_def validIOA_def temp_strengthening_def)
216.173 -apply (auto simp add: split_paired_all)
216.174 -done
216.175 -
216.176 -
216.177 -subsection "Correctness of safe abstraction"
216.178 -
216.179 -lemma abstraction_is_ref_map:
216.180 -"is_abstraction h C A ==> is_ref_map h C A"
216.181 -apply (unfold is_abstraction_def is_ref_map_def)
216.182 -apply auto
216.183 -apply (rule_tac x = "(a,h t) >>nil" in exI)
216.184 -apply (simp add: move_def)
216.185 -done
216.186 -
216.187 -
216.188 -lemma abs_safety: "[| inp(C)=inp(A); out(C)=out(A);
216.189 - is_abstraction h C A |]
216.190 - ==> C =<| A"
216.191 -apply (simp add: ioa_implements_def)
216.192 -apply (rule trace_inclusion)
216.193 -apply (simp (no_asm) add: externals_def)
216.194 -apply (auto)[1]
216.195 -apply (erule abstraction_is_ref_map)
216.196 -done
216.197 -
216.198 -
216.199 -subsection "Correctness of life abstraction"
216.200 -
216.201 -(* Reduces to Filter (Map fst x) = Filter (Map fst (Map (%(a,t). (a,x)) x),
216.202 - that is to special Map Lemma *)
216.203 -lemma traces_coincide_abs:
216.204 - "ext C = ext A
216.205 - ==> mk_trace C$xs = mk_trace A$(snd (cex_abs f (s,xs)))"
216.206 -apply (unfold cex_abs_def mk_trace_def filter_act_def)
216.207 -apply simp
216.208 -apply (tactic {* pair_induct_tac @{context} "xs" [] 1 *})
216.209 -done
216.210 -
216.211 -
216.212 -(* Does not work with abstraction_is_ref_map as proof of abs_safety, because
216.213 - is_live_abstraction includes temp_strengthening which is necessarily based
216.214 - on cex_abs and not on corresp_ex. Thus, the proof is redoone in a more specific
216.215 - way for cex_abs *)
216.216 -lemma abs_liveness: "[| inp(C)=inp(A); out(C)=out(A);
216.217 - is_live_abstraction h (C,M) (A,L) |]
216.218 - ==> live_implements (C,M) (A,L)"
216.219 -apply (simp add: is_live_abstraction_def live_implements_def livetraces_def liveexecutions_def)
216.220 -apply auto
216.221 -apply (rule_tac x = "cex_abs h ex" in exI)
216.222 -apply auto
216.223 - (* Traces coincide *)
216.224 - apply (tactic {* pair_tac @{context} "ex" 1 *})
216.225 - apply (rule traces_coincide_abs)
216.226 - apply (simp (no_asm) add: externals_def)
216.227 - apply (auto)[1]
216.228 -
216.229 - (* cex_abs is execution *)
216.230 - apply (tactic {* pair_tac @{context} "ex" 1 *})
216.231 - apply (simp add: executions_def)
216.232 - (* start state *)
216.233 - apply (rule conjI)
216.234 - apply (simp add: is_abstraction_def cex_abs_def)
216.235 - (* is-execution-fragment *)
216.236 - apply (erule exec_frag_abstraction)
216.237 - apply (simp add: reachable.reachable_0)
216.238 -
216.239 - (* Liveness *)
216.240 -apply (simp add: temp_weakening_def2)
216.241 - apply (tactic {* pair_tac @{context} "ex" 1 *})
216.242 -done
216.243 -
216.244 -(* FIX: NAch Traces.ML bringen *)
216.245 -
216.246 -lemma implements_trans:
216.247 -"[| A =<| B; B =<| C|] ==> A =<| C"
216.248 -by (auto simp add: ioa_implements_def)
216.249 -
216.250 -
216.251 -subsection "Abstraction Rules for Automata"
216.252 -
216.253 -lemma AbsRuleA1: "[| inp(C)=inp(A); out(C)=out(A);
216.254 - inp(Q)=inp(P); out(Q)=out(P);
216.255 - is_abstraction h1 C A;
216.256 - A =<| Q ;
216.257 - is_abstraction h2 Q P |]
216.258 - ==> C =<| P"
216.259 -apply (drule abs_safety)
216.260 -apply assumption+
216.261 -apply (drule abs_safety)
216.262 -apply assumption+
216.263 -apply (erule implements_trans)
216.264 -apply (erule implements_trans)
216.265 -apply assumption
216.266 -done
216.267 -
216.268 -
216.269 -lemma AbsRuleA2: "!!LC. [| inp(C)=inp(A); out(C)=out(A);
216.270 - inp(Q)=inp(P); out(Q)=out(P);
216.271 - is_live_abstraction h1 (C,LC) (A,LA);
216.272 - live_implements (A,LA) (Q,LQ) ;
216.273 - is_live_abstraction h2 (Q,LQ) (P,LP) |]
216.274 - ==> live_implements (C,LC) (P,LP)"
216.275 -apply (drule abs_liveness)
216.276 -apply assumption+
216.277 -apply (drule abs_liveness)
216.278 -apply assumption+
216.279 -apply (erule live_implements_trans)
216.280 -apply (erule live_implements_trans)
216.281 -apply assumption
216.282 -done
216.283 -
216.284 -
216.285 -declare split_paired_All [simp del]
216.286 -
216.287 -
216.288 -subsection "Localizing Temporal Strengthenings and Weakenings"
216.289 -
216.290 -lemma strength_AND:
216.291 -"[| temp_strengthening P1 Q1 h;
216.292 - temp_strengthening P2 Q2 h |]
216.293 - ==> temp_strengthening (P1 .& P2) (Q1 .& Q2) h"
216.294 -apply (unfold temp_strengthening_def)
216.295 -apply auto
216.296 -done
216.297 -
216.298 -lemma strength_OR:
216.299 -"[| temp_strengthening P1 Q1 h;
216.300 - temp_strengthening P2 Q2 h |]
216.301 - ==> temp_strengthening (P1 .| P2) (Q1 .| Q2) h"
216.302 -apply (unfold temp_strengthening_def)
216.303 -apply auto
216.304 -done
216.305 -
216.306 -lemma strength_NOT:
216.307 -"[| temp_weakening P Q h |]
216.308 - ==> temp_strengthening (.~ P) (.~ Q) h"
216.309 -apply (unfold temp_strengthening_def)
216.310 -apply (simp add: temp_weakening_def2)
216.311 -apply auto
216.312 -done
216.313 -
216.314 -lemma strength_IMPLIES:
216.315 -"[| temp_weakening P1 Q1 h;
216.316 - temp_strengthening P2 Q2 h |]
216.317 - ==> temp_strengthening (P1 .--> P2) (Q1 .--> Q2) h"
216.318 -apply (unfold temp_strengthening_def)
216.319 -apply (simp add: temp_weakening_def2)
216.320 -done
216.321 -
216.322 -
216.323 -lemma weak_AND:
216.324 -"[| temp_weakening P1 Q1 h;
216.325 - temp_weakening P2 Q2 h |]
216.326 - ==> temp_weakening (P1 .& P2) (Q1 .& Q2) h"
216.327 -apply (simp add: temp_weakening_def2)
216.328 -done
216.329 -
216.330 -lemma weak_OR:
216.331 -"[| temp_weakening P1 Q1 h;
216.332 - temp_weakening P2 Q2 h |]
216.333 - ==> temp_weakening (P1 .| P2) (Q1 .| Q2) h"
216.334 -apply (simp add: temp_weakening_def2)
216.335 -done
216.336 -
216.337 -lemma weak_NOT:
216.338 -"[| temp_strengthening P Q h |]
216.339 - ==> temp_weakening (.~ P) (.~ Q) h"
216.340 -apply (unfold temp_strengthening_def)
216.341 -apply (simp add: temp_weakening_def2)
216.342 -apply auto
216.343 -done
216.344 -
216.345 -lemma weak_IMPLIES:
216.346 -"[| temp_strengthening P1 Q1 h;
216.347 - temp_weakening P2 Q2 h |]
216.348 - ==> temp_weakening (P1 .--> P2) (Q1 .--> Q2) h"
216.349 -apply (unfold temp_strengthening_def)
216.350 -apply (simp add: temp_weakening_def2)
216.351 -done
216.352 -
216.353 -
216.354 -subsubsection {* Box *}
216.355 -
216.356 -(* FIX: should be same as nil_is_Conc2 when all nils are turned to right side !! *)
216.357 -lemma UU_is_Conc: "(UU = x @@ y) = (((x::'a Seq)= UU) | (x=nil & y=UU))"
216.358 -apply (tactic {* Seq_case_simp_tac @{context} "x" 1 *})
216.359 -done
216.360 -
216.361 -lemma ex2seqConc [rule_format]:
216.362 -"Finite s1 -->
216.363 - (! ex. (s~=nil & s~=UU & ex2seq ex = s1 @@ s) --> (? ex'. s = ex2seq ex'))"
216.364 -apply (rule impI)
216.365 -apply (tactic {* Seq_Finite_induct_tac @{context} 1 *})
216.366 -apply blast
216.367 -(* main case *)
216.368 -apply clarify
216.369 -apply (tactic {* pair_tac @{context} "ex" 1 *})
216.370 -apply (tactic {* Seq_case_simp_tac @{context} "y" 1 *})
216.371 -(* UU case *)
216.372 -apply (simp add: nil_is_Conc)
216.373 -(* nil case *)
216.374 -apply (simp add: nil_is_Conc)
216.375 -(* cons case *)
216.376 -apply (tactic {* pair_tac @{context} "aa" 1 *})
216.377 -apply auto
216.378 -done
216.379 -
216.380 -(* important property of ex2seq: can be shiftet, as defined "pointwise" *)
216.381 -
216.382 -lemma ex2seq_tsuffix:
216.383 -"tsuffix s (ex2seq ex) ==> ? ex'. s = (ex2seq ex')"
216.384 -apply (unfold tsuffix_def suffix_def)
216.385 -apply auto
216.386 -apply (drule ex2seqConc)
216.387 -apply auto
216.388 -done
216.389 -
216.390 -
216.391 -(* FIX: NAch Sequence.ML bringen *)
216.392 -
216.393 -lemma Mapnil: "(Map f$s = nil) = (s=nil)"
216.394 -apply (tactic {* Seq_case_simp_tac @{context} "s" 1 *})
216.395 -done
216.396 -
216.397 -lemma MapUU: "(Map f$s = UU) = (s=UU)"
216.398 -apply (tactic {* Seq_case_simp_tac @{context} "s" 1 *})
216.399 -done
216.400 -
216.401 -
216.402 -(* important property of cex_absSeq: As it is a 1to1 correspondence,
216.403 - properties carry over *)
216.404 -
216.405 -lemma cex_absSeq_tsuffix:
216.406 -"tsuffix s t ==> tsuffix (cex_absSeq h s) (cex_absSeq h t)"
216.407 -apply (unfold tsuffix_def suffix_def cex_absSeq_def)
216.408 -apply auto
216.409 -apply (simp add: Mapnil)
216.410 -apply (simp add: MapUU)
216.411 -apply (rule_tac x = "Map (% (s,a,t) . (h s,a, h t))$s1" in exI)
216.412 -apply (simp add: Map2Finite MapConc)
216.413 -done
216.414 -
216.415 -
216.416 -lemma strength_Box:
216.417 -"[| temp_strengthening P Q h |]
216.418 - ==> temp_strengthening ([] P) ([] Q) h"
216.419 -apply (unfold temp_strengthening_def state_strengthening_def temp_sat_def satisfies_def Box_def)
216.420 -apply clarify
216.421 -apply (frule ex2seq_tsuffix)
216.422 -apply clarify
216.423 -apply (drule_tac h = "h" in cex_absSeq_tsuffix)
216.424 -apply (simp add: ex2seq_abs_cex)
216.425 -done
216.426 -
216.427 -
216.428 -subsubsection {* Init *}
216.429 -
216.430 -lemma strength_Init:
216.431 -"[| state_strengthening P Q h |]
216.432 - ==> temp_strengthening (Init P) (Init Q) h"
216.433 -apply (unfold temp_strengthening_def state_strengthening_def
216.434 - temp_sat_def satisfies_def Init_def unlift_def)
216.435 -apply auto
216.436 -apply (tactic {* pair_tac @{context} "ex" 1 *})
216.437 -apply (tactic {* Seq_case_simp_tac @{context} "y" 1 *})
216.438 -apply (tactic {* pair_tac @{context} "a" 1 *})
216.439 -done
216.440 -
216.441 -
216.442 -subsubsection {* Next *}
216.443 -
216.444 -lemma TL_ex2seq_UU:
216.445 -"(TL$(ex2seq (cex_abs h ex))=UU) = (TL$(ex2seq ex)=UU)"
216.446 -apply (tactic {* pair_tac @{context} "ex" 1 *})
216.447 -apply (tactic {* Seq_case_simp_tac @{context} "y" 1 *})
216.448 -apply (tactic {* pair_tac @{context} "a" 1 *})
216.449 -apply (tactic {* Seq_case_simp_tac @{context} "s" 1 *})
216.450 -apply (tactic {* pair_tac @{context} "a" 1 *})
216.451 -done
216.452 -
216.453 -lemma TL_ex2seq_nil:
216.454 -"(TL$(ex2seq (cex_abs h ex))=nil) = (TL$(ex2seq ex)=nil)"
216.455 -apply (tactic {* pair_tac @{context} "ex" 1 *})
216.456 -apply (tactic {* Seq_case_simp_tac @{context} "y" 1 *})
216.457 -apply (tactic {* pair_tac @{context} "a" 1 *})
216.458 -apply (tactic {* Seq_case_simp_tac @{context} "s" 1 *})
216.459 -apply (tactic {* pair_tac @{context} "a" 1 *})
216.460 -done
216.461 -
216.462 -(* FIX: put to Sequence Lemmas *)
216.463 -lemma MapTL: "Map f$(TL$s) = TL$(Map f$s)"
216.464 -apply (tactic {* Seq_induct_tac @{context} "s" [] 1 *})
216.465 -done
216.466 -
216.467 -(* important property of cex_absSeq: As it is a 1to1 correspondence,
216.468 - properties carry over *)
216.469 -
216.470 -lemma cex_absSeq_TL:
216.471 -"cex_absSeq h (TL$s) = (TL$(cex_absSeq h s))"
216.472 -apply (unfold cex_absSeq_def)
216.473 -apply (simp add: MapTL)
216.474 -done
216.475 -
216.476 -(* important property of ex2seq: can be shiftet, as defined "pointwise" *)
216.477 -
216.478 -lemma TLex2seq: "[| (snd ex)~=UU ; (snd ex)~=nil |] ==> (? ex'. TL$(ex2seq ex) = ex2seq ex')"
216.479 -apply (tactic {* pair_tac @{context} "ex" 1 *})
216.480 -apply (tactic {* Seq_case_simp_tac @{context} "y" 1 *})
216.481 -apply (tactic {* pair_tac @{context} "a" 1 *})
216.482 -apply auto
216.483 -done
216.484 -
216.485 -
216.486 -lemma ex2seqnilTL: "(TL$(ex2seq ex)~=nil) = ((snd ex)~=nil & (snd ex)~=UU)"
216.487 -apply (tactic {* pair_tac @{context} "ex" 1 *})
216.488 -apply (tactic {* Seq_case_simp_tac @{context} "y" 1 *})
216.489 -apply (tactic {* pair_tac @{context} "a" 1 *})
216.490 -apply (tactic {* Seq_case_simp_tac @{context} "s" 1 *})
216.491 -apply (tactic {* pair_tac @{context} "a" 1 *})
216.492 -done
216.493 -
216.494 -
216.495 -lemma strength_Next:
216.496 -"[| temp_strengthening P Q h |]
216.497 - ==> temp_strengthening (Next P) (Next Q) h"
216.498 -apply (unfold temp_strengthening_def state_strengthening_def temp_sat_def satisfies_def Next_def)
216.499 -apply simp
216.500 -apply auto
216.501 -apply (simp add: TL_ex2seq_nil TL_ex2seq_UU)
216.502 -apply (simp add: TL_ex2seq_nil TL_ex2seq_UU)
216.503 -apply (simp add: TL_ex2seq_nil TL_ex2seq_UU)
216.504 -apply (simp add: TL_ex2seq_nil TL_ex2seq_UU)
216.505 -(* cons case *)
216.506 -apply (simp add: TL_ex2seq_nil TL_ex2seq_UU ex2seq_abs_cex cex_absSeq_TL [symmetric] ex2seqnilTL)
216.507 -apply (erule conjE)
216.508 -apply (drule TLex2seq)
216.509 -apply assumption
216.510 -apply auto
216.511 -done
216.512 -
216.513 -
216.514 -text {* Localizing Temporal Weakenings - 2 *}
216.515 -
216.516 -lemma weak_Init:
216.517 -"[| state_weakening P Q h |]
216.518 - ==> temp_weakening (Init P) (Init Q) h"
216.519 -apply (simp add: temp_weakening_def2 state_weakening_def2
216.520 - temp_sat_def satisfies_def Init_def unlift_def)
216.521 -apply auto
216.522 -apply (tactic {* pair_tac @{context} "ex" 1 *})
216.523 -apply (tactic {* Seq_case_simp_tac @{context} "y" 1 *})
216.524 -apply (tactic {* pair_tac @{context} "a" 1 *})
216.525 -done
216.526 -
216.527 -
216.528 -text {* Localizing Temproal Strengthenings - 3 *}
216.529 -
216.530 -lemma strength_Diamond:
216.531 -"[| temp_strengthening P Q h |]
216.532 - ==> temp_strengthening (<> P) (<> Q) h"
216.533 -apply (unfold Diamond_def)
216.534 -apply (rule strength_NOT)
216.535 -apply (rule weak_Box)
216.536 -apply (erule weak_NOT)
216.537 -done
216.538 -
216.539 -lemma strength_Leadsto:
216.540 -"[| temp_weakening P1 P2 h;
216.541 - temp_strengthening Q1 Q2 h |]
216.542 - ==> temp_strengthening (P1 ~> Q1) (P2 ~> Q2) h"
216.543 -apply (unfold Leadsto_def)
216.544 -apply (rule strength_Box)
216.545 -apply (erule strength_IMPLIES)
216.546 -apply (erule strength_Diamond)
216.547 -done
216.548 -
216.549 -
216.550 -text {* Localizing Temporal Weakenings - 3 *}
216.551 -
216.552 -lemma weak_Diamond:
216.553 -"[| temp_weakening P Q h |]
216.554 - ==> temp_weakening (<> P) (<> Q) h"
216.555 -apply (unfold Diamond_def)
216.556 -apply (rule weak_NOT)
216.557 -apply (rule strength_Box)
216.558 -apply (erule strength_NOT)
216.559 -done
216.560 -
216.561 -lemma weak_Leadsto:
216.562 -"[| temp_strengthening P1 P2 h;
216.563 - temp_weakening Q1 Q2 h |]
216.564 - ==> temp_weakening (P1 ~> Q1) (P2 ~> Q2) h"
216.565 -apply (unfold Leadsto_def)
216.566 -apply (rule weak_Box)
216.567 -apply (erule weak_IMPLIES)
216.568 -apply (erule weak_Diamond)
216.569 -done
216.570 -
216.571 -lemma weak_WF:
216.572 - " !!A. [| !! s. Enabled A acts (h s) ==> Enabled C acts s|]
216.573 - ==> temp_weakening (WF A acts) (WF C acts) h"
216.574 -apply (unfold WF_def)
216.575 -apply (rule weak_IMPLIES)
216.576 -apply (rule strength_Diamond)
216.577 -apply (rule strength_Box)
216.578 -apply (rule strength_Init)
216.579 -apply (rule_tac [2] weak_Box)
216.580 -apply (rule_tac [2] weak_Diamond)
216.581 -apply (rule_tac [2] weak_Init)
216.582 -apply (auto simp add: state_weakening_def state_strengthening_def
216.583 - xt2_def plift_def option_lift_def NOT_def)
216.584 -done
216.585 -
216.586 -lemma weak_SF:
216.587 - " !!A. [| !! s. Enabled A acts (h s) ==> Enabled C acts s|]
216.588 - ==> temp_weakening (SF A acts) (SF C acts) h"
216.589 -apply (unfold SF_def)
216.590 -apply (rule weak_IMPLIES)
216.591 -apply (rule strength_Box)
216.592 -apply (rule strength_Diamond)
216.593 -apply (rule strength_Init)
216.594 -apply (rule_tac [2] weak_Box)
216.595 -apply (rule_tac [2] weak_Diamond)
216.596 -apply (rule_tac [2] weak_Init)
216.597 -apply (auto simp add: state_weakening_def state_strengthening_def
216.598 - xt2_def plift_def option_lift_def NOT_def)
216.599 -done
216.600 -
216.601 -
216.602 -lemmas weak_strength_lemmas =
216.603 - weak_OR weak_AND weak_NOT weak_IMPLIES weak_Box weak_Next weak_Init
216.604 - weak_Diamond weak_Leadsto strength_OR strength_AND strength_NOT
216.605 - strength_IMPLIES strength_Box strength_Next strength_Init
216.606 - strength_Diamond strength_Leadsto weak_WF weak_SF
216.607 -
216.608 -ML {*
216.609 -fun abstraction_tac ctxt =
216.610 - let val (cs, ss) = clasimpset_of ctxt in
216.611 - SELECT_GOAL (auto_tac (cs addSIs @{thms weak_strength_lemmas},
216.612 - ss addsimps [@{thm state_strengthening_def}, @{thm state_weakening_def}]))
216.613 - end
216.614 -*}
216.615 -
216.616 -method_setup abstraction = {* Scan.succeed (SIMPLE_METHOD' o abstraction_tac) *} ""
216.617 -
216.618 -end
217.1 --- a/src/HOLCF/IOA/meta_theory/Asig.thy Sat Nov 27 14:34:54 2010 -0800
217.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
217.3 @@ -1,101 +0,0 @@
217.4 -(* Title: HOL/IOA/meta_theory/Asig.thy
217.5 - Author: Olaf Müller, Tobias Nipkow & Konrad Slind
217.6 -*)
217.7 -
217.8 -header {* Action signatures *}
217.9 -
217.10 -theory Asig
217.11 -imports Main
217.12 -begin
217.13 -
217.14 -types
217.15 - 'a signature = "('a set * 'a set * 'a set)"
217.16 -
217.17 -definition
217.18 - inputs :: "'action signature => 'action set" where
217.19 - asig_inputs_def: "inputs = fst"
217.20 -
217.21 -definition
217.22 - outputs :: "'action signature => 'action set" where
217.23 - asig_outputs_def: "outputs = (fst o snd)"
217.24 -
217.25 -definition
217.26 - internals :: "'action signature => 'action set" where
217.27 - asig_internals_def: "internals = (snd o snd)"
217.28 -
217.29 -definition
217.30 - actions :: "'action signature => 'action set" where
217.31 - "actions(asig) = (inputs(asig) Un outputs(asig) Un internals(asig))"
217.32 -
217.33 -definition
217.34 - externals :: "'action signature => 'action set" where
217.35 - "externals(asig) = (inputs(asig) Un outputs(asig))"
217.36 -
217.37 -definition
217.38 - locals :: "'action signature => 'action set" where
217.39 - "locals asig = ((internals asig) Un (outputs asig))"
217.40 -
217.41 -definition
217.42 - is_asig :: "'action signature => bool" where
217.43 - "is_asig(triple) =
217.44 - ((inputs(triple) Int outputs(triple) = {}) &
217.45 - (outputs(triple) Int internals(triple) = {}) &
217.46 - (inputs(triple) Int internals(triple) = {}))"
217.47 -
217.48 -definition
217.49 - mk_ext_asig :: "'action signature => 'action signature" where
217.50 - "mk_ext_asig(triple) = (inputs(triple), outputs(triple), {})"
217.51 -
217.52 -
217.53 -lemmas asig_projections = asig_inputs_def asig_outputs_def asig_internals_def
217.54 -
217.55 -lemma asig_triple_proj:
217.56 - "(outputs (a,b,c) = b) &
217.57 - (inputs (a,b,c) = a) &
217.58 - (internals (a,b,c) = c)"
217.59 - apply (simp add: asig_projections)
217.60 - done
217.61 -
217.62 -lemma int_and_ext_is_act: "[| a~:internals(S) ;a~:externals(S)|] ==> a~:actions(S)"
217.63 -apply (simp add: externals_def actions_def)
217.64 -done
217.65 -
217.66 -lemma ext_is_act: "[|a:externals(S)|] ==> a:actions(S)"
217.67 -apply (simp add: externals_def actions_def)
217.68 -done
217.69 -
217.70 -lemma int_is_act: "[|a:internals S|] ==> a:actions S"
217.71 -apply (simp add: asig_internals_def actions_def)
217.72 -done
217.73 -
217.74 -lemma inp_is_act: "[|a:inputs S|] ==> a:actions S"
217.75 -apply (simp add: asig_inputs_def actions_def)
217.76 -done
217.77 -
217.78 -lemma out_is_act: "[|a:outputs S|] ==> a:actions S"
217.79 -apply (simp add: asig_outputs_def actions_def)
217.80 -done
217.81 -
217.82 -lemma ext_and_act: "(x: actions S & x : externals S) = (x: externals S)"
217.83 -apply (fast intro!: ext_is_act)
217.84 -done
217.85 -
217.86 -lemma not_ext_is_int: "[|is_asig S;x: actions S|] ==> (x~:externals S) = (x: internals S)"
217.87 -apply (simp add: actions_def is_asig_def externals_def)
217.88 -apply blast
217.89 -done
217.90 -
217.91 -lemma not_ext_is_int_or_not_act: "is_asig S ==> (x~:externals S) = (x: internals S | x~:actions S)"
217.92 -apply (simp add: actions_def is_asig_def externals_def)
217.93 -apply blast
217.94 -done
217.95 -
217.96 -lemma int_is_not_ext:
217.97 - "[| is_asig (S); x:internals S |] ==> x~:externals S"
217.98 -apply (unfold externals_def actions_def is_asig_def)
217.99 -apply simp
217.100 -apply blast
217.101 -done
217.102 -
217.103 -
217.104 -end
218.1 --- a/src/HOLCF/IOA/meta_theory/Automata.thy Sat Nov 27 14:34:54 2010 -0800
218.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
218.3 @@ -1,691 +0,0 @@
218.4 -(* Title: HOLCF/IOA/meta_theory/Automata.thy
218.5 - Author: Olaf Müller, Konrad Slind, Tobias Nipkow
218.6 -*)
218.7 -
218.8 -header {* The I/O automata of Lynch and Tuttle in HOLCF *}
218.9 -
218.10 -theory Automata
218.11 -imports Asig
218.12 -begin
218.13 -
218.14 -default_sort type
218.15 -
218.16 -types
218.17 - ('a, 's) transition = "'s * 'a * 's"
218.18 - ('a, 's) ioa = "'a signature * 's set * ('a,'s)transition set * ('a set set) * ('a set set)"
218.19 -
218.20 -consts
218.21 -
218.22 - (* IO automata *)
218.23 -
218.24 - asig_of ::"('a,'s)ioa => 'a signature"
218.25 - starts_of ::"('a,'s)ioa => 's set"
218.26 - trans_of ::"('a,'s)ioa => ('a,'s)transition set"
218.27 - wfair_of ::"('a,'s)ioa => ('a set) set"
218.28 - sfair_of ::"('a,'s)ioa => ('a set) set"
218.29 -
218.30 - is_asig_of ::"('a,'s)ioa => bool"
218.31 - is_starts_of ::"('a,'s)ioa => bool"
218.32 - is_trans_of ::"('a,'s)ioa => bool"
218.33 - input_enabled ::"('a,'s)ioa => bool"
218.34 - IOA ::"('a,'s)ioa => bool"
218.35 -
218.36 - (* constraints for fair IOA *)
218.37 -
218.38 - fairIOA ::"('a,'s)ioa => bool"
218.39 - input_resistant::"('a,'s)ioa => bool"
218.40 -
218.41 - (* enabledness of actions and action sets *)
218.42 -
218.43 - enabled ::"('a,'s)ioa => 'a => 's => bool"
218.44 - Enabled ::"('a,'s)ioa => 'a set => 's => bool"
218.45 -
218.46 - (* action set keeps enabled until probably disabled by itself *)
218.47 -
218.48 - en_persistent :: "('a,'s)ioa => 'a set => bool"
218.49 -
218.50 - (* post_conditions for actions and action sets *)
218.51 -
218.52 - was_enabled ::"('a,'s)ioa => 'a => 's => bool"
218.53 - set_was_enabled ::"('a,'s)ioa => 'a set => 's => bool"
218.54 -
218.55 - (* invariants *)
218.56 - invariant :: "[('a,'s)ioa, 's=>bool] => bool"
218.57 -
218.58 - (* binary composition of action signatures and automata *)
218.59 - asig_comp ::"['a signature, 'a signature] => 'a signature"
218.60 - compatible ::"[('a,'s)ioa, ('a,'t)ioa] => bool"
218.61 - par ::"[('a,'s)ioa, ('a,'t)ioa] => ('a,'s*'t)ioa" (infixr "||" 10)
218.62 -
218.63 - (* hiding and restricting *)
218.64 - hide_asig :: "['a signature, 'a set] => 'a signature"
218.65 - hide :: "[('a,'s)ioa, 'a set] => ('a,'s)ioa"
218.66 - restrict_asig :: "['a signature, 'a set] => 'a signature"
218.67 - restrict :: "[('a,'s)ioa, 'a set] => ('a,'s)ioa"
218.68 -
218.69 - (* renaming *)
218.70 - rename_set :: "'a set => ('c => 'a option) => 'c set"
218.71 - rename :: "('a, 'b)ioa => ('c => 'a option) => ('c,'b)ioa"
218.72 -
218.73 -notation (xsymbols)
218.74 - par (infixr "\<parallel>" 10)
218.75 -
218.76 -
218.77 -inductive
218.78 - reachable :: "('a, 's) ioa => 's => bool"
218.79 - for C :: "('a, 's) ioa"
218.80 - where
218.81 - reachable_0: "s : starts_of C ==> reachable C s"
218.82 - | reachable_n: "[| reachable C s; (s, a, t) : trans_of C |] ==> reachable C t"
218.83 -
218.84 -abbreviation
218.85 - trans_of_syn ("_ -_--_-> _" [81,81,81,81] 100) where
218.86 - "s -a--A-> t == (s,a,t):trans_of A"
218.87 -
218.88 -notation (xsymbols)
218.89 - trans_of_syn ("_ \<midarrow>_\<midarrow>_\<longrightarrow> _" [81,81,81,81] 100)
218.90 -
218.91 -abbreviation "act A == actions (asig_of A)"
218.92 -abbreviation "ext A == externals (asig_of A)"
218.93 -abbreviation int where "int A == internals (asig_of A)"
218.94 -abbreviation "inp A == inputs (asig_of A)"
218.95 -abbreviation "out A == outputs (asig_of A)"
218.96 -abbreviation "local A == locals (asig_of A)"
218.97 -
218.98 -defs
218.99 -
218.100 -(* --------------------------------- IOA ---------------------------------*)
218.101 -
218.102 -asig_of_def: "asig_of == fst"
218.103 -starts_of_def: "starts_of == (fst o snd)"
218.104 -trans_of_def: "trans_of == (fst o snd o snd)"
218.105 -wfair_of_def: "wfair_of == (fst o snd o snd o snd)"
218.106 -sfair_of_def: "sfair_of == (snd o snd o snd o snd)"
218.107 -
218.108 -is_asig_of_def:
218.109 - "is_asig_of A == is_asig (asig_of A)"
218.110 -
218.111 -is_starts_of_def:
218.112 - "is_starts_of A == (~ starts_of A = {})"
218.113 -
218.114 -is_trans_of_def:
218.115 - "is_trans_of A ==
218.116 - (!triple. triple:(trans_of A) --> fst(snd(triple)):actions(asig_of A))"
218.117 -
218.118 -input_enabled_def:
218.119 - "input_enabled A ==
218.120 - (!a. (a:inputs(asig_of A)) --> (!s1. ? s2. (s1,a,s2):(trans_of A)))"
218.121 -
218.122 -
218.123 -ioa_def:
218.124 - "IOA A == (is_asig_of A &
218.125 - is_starts_of A &
218.126 - is_trans_of A &
218.127 - input_enabled A)"
218.128 -
218.129 -
218.130 -invariant_def: "invariant A P == (!s. reachable A s --> P(s))"
218.131 -
218.132 -
218.133 -(* ------------------------- parallel composition --------------------------*)
218.134 -
218.135 -
218.136 -compatible_def:
218.137 - "compatible A B ==
218.138 - (((out A Int out B) = {}) &
218.139 - ((int A Int act B) = {}) &
218.140 - ((int B Int act A) = {}))"
218.141 -
218.142 -asig_comp_def:
218.143 - "asig_comp a1 a2 ==
218.144 - (((inputs(a1) Un inputs(a2)) - (outputs(a1) Un outputs(a2)),
218.145 - (outputs(a1) Un outputs(a2)),
218.146 - (internals(a1) Un internals(a2))))"
218.147 -
218.148 -par_def:
218.149 - "(A || B) ==
218.150 - (asig_comp (asig_of A) (asig_of B),
218.151 - {pr. fst(pr):starts_of(A) & snd(pr):starts_of(B)},
218.152 - {tr. let s = fst(tr); a = fst(snd(tr)); t = snd(snd(tr))
218.153 - in (a:act A | a:act B) &
218.154 - (if a:act A then
218.155 - (fst(s),a,fst(t)):trans_of(A)
218.156 - else fst(t) = fst(s))
218.157 - &
218.158 - (if a:act B then
218.159 - (snd(s),a,snd(t)):trans_of(B)
218.160 - else snd(t) = snd(s))},
218.161 - wfair_of A Un wfair_of B,
218.162 - sfair_of A Un sfair_of B)"
218.163 -
218.164 -
218.165 -(* ------------------------ hiding -------------------------------------------- *)
218.166 -
218.167 -restrict_asig_def:
218.168 - "restrict_asig asig actns ==
218.169 - (inputs(asig) Int actns,
218.170 - outputs(asig) Int actns,
218.171 - internals(asig) Un (externals(asig) - actns))"
218.172 -
218.173 -(* Notice that for wfair_of and sfair_of nothing has to be changed, as
218.174 - changes from the outputs to the internals does not touch the locals as
218.175 - a whole, which is of importance for fairness only *)
218.176 -
218.177 -restrict_def:
218.178 - "restrict A actns ==
218.179 - (restrict_asig (asig_of A) actns,
218.180 - starts_of A,
218.181 - trans_of A,
218.182 - wfair_of A,
218.183 - sfair_of A)"
218.184 -
218.185 -hide_asig_def:
218.186 - "hide_asig asig actns ==
218.187 - (inputs(asig) - actns,
218.188 - outputs(asig) - actns,
218.189 - internals(asig) Un actns)"
218.190 -
218.191 -hide_def:
218.192 - "hide A actns ==
218.193 - (hide_asig (asig_of A) actns,
218.194 - starts_of A,
218.195 - trans_of A,
218.196 - wfair_of A,
218.197 - sfair_of A)"
218.198 -
218.199 -(* ------------------------- renaming ------------------------------------------- *)
218.200 -
218.201 -rename_set_def:
218.202 - "rename_set A ren == {b. ? x. Some x = ren b & x : A}"
218.203 -
218.204 -rename_def:
218.205 -"rename ioa ren ==
218.206 - ((rename_set (inp ioa) ren,
218.207 - rename_set (out ioa) ren,
218.208 - rename_set (int ioa) ren),
218.209 - starts_of ioa,
218.210 - {tr. let s = fst(tr); a = fst(snd(tr)); t = snd(snd(tr))
218.211 - in
218.212 - ? x. Some(x) = ren(a) & (s,x,t):trans_of ioa},
218.213 - {rename_set s ren | s. s: wfair_of ioa},
218.214 - {rename_set s ren | s. s: sfair_of ioa})"
218.215 -
218.216 -(* ------------------------- fairness ----------------------------- *)
218.217 -
218.218 -fairIOA_def:
218.219 - "fairIOA A == (! S : wfair_of A. S<= local A) &
218.220 - (! S : sfair_of A. S<= local A)"
218.221 -
218.222 -input_resistant_def:
218.223 - "input_resistant A == ! W : sfair_of A. ! s a t.
218.224 - reachable A s & reachable A t & a:inp A &
218.225 - Enabled A W s & s -a--A-> t
218.226 - --> Enabled A W t"
218.227 -
218.228 -enabled_def:
218.229 - "enabled A a s == ? t. s-a--A-> t"
218.230 -
218.231 -Enabled_def:
218.232 - "Enabled A W s == ? w:W. enabled A w s"
218.233 -
218.234 -en_persistent_def:
218.235 - "en_persistent A W == ! s a t. Enabled A W s &
218.236 - a ~:W &
218.237 - s -a--A-> t
218.238 - --> Enabled A W t"
218.239 -was_enabled_def:
218.240 - "was_enabled A a t == ? s. s-a--A-> t"
218.241 -
218.242 -set_was_enabled_def:
218.243 - "set_was_enabled A W t == ? w:W. was_enabled A w t"
218.244 -
218.245 -
218.246 -declare split_paired_Ex [simp del]
218.247 -
218.248 -lemmas ioa_projections = asig_of_def starts_of_def trans_of_def wfair_of_def sfair_of_def
218.249 -
218.250 -
218.251 -subsection "asig_of, starts_of, trans_of"
218.252 -
218.253 -lemma ioa_triple_proj:
218.254 - "((asig_of (x,y,z,w,s)) = x) &
218.255 - ((starts_of (x,y,z,w,s)) = y) &
218.256 - ((trans_of (x,y,z,w,s)) = z) &
218.257 - ((wfair_of (x,y,z,w,s)) = w) &
218.258 - ((sfair_of (x,y,z,w,s)) = s)"
218.259 - apply (simp add: ioa_projections)
218.260 - done
218.261 -
218.262 -lemma trans_in_actions:
218.263 - "[| is_trans_of A; (s1,a,s2):trans_of(A) |] ==> a:act A"
218.264 -apply (unfold is_trans_of_def actions_def is_asig_def)
218.265 - apply (erule allE, erule impE, assumption)
218.266 - apply simp
218.267 -done
218.268 -
218.269 -lemma starts_of_par:
218.270 -"starts_of(A || B) = {p. fst(p):starts_of(A) & snd(p):starts_of(B)}"
218.271 - apply (simp add: par_def ioa_projections)
218.272 -done
218.273 -
218.274 -lemma trans_of_par:
218.275 -"trans_of(A || B) = {tr. let s = fst(tr); a = fst(snd(tr)); t = snd(snd(tr))
218.276 - in (a:act A | a:act B) &
218.277 - (if a:act A then
218.278 - (fst(s),a,fst(t)):trans_of(A)
218.279 - else fst(t) = fst(s))
218.280 - &
218.281 - (if a:act B then
218.282 - (snd(s),a,snd(t)):trans_of(B)
218.283 - else snd(t) = snd(s))}"
218.284 -
218.285 -apply (simp add: par_def ioa_projections)
218.286 -done
218.287 -
218.288 -
218.289 -subsection "actions and par"
218.290 -
218.291 -lemma actions_asig_comp:
218.292 - "actions(asig_comp a b) = actions(a) Un actions(b)"
218.293 - apply (simp (no_asm) add: actions_def asig_comp_def asig_projections)
218.294 - apply blast
218.295 - done
218.296 -
218.297 -lemma asig_of_par: "asig_of(A || B) = asig_comp (asig_of A) (asig_of B)"
218.298 - apply (simp add: par_def ioa_projections)
218.299 - done
218.300 -
218.301 -
218.302 -lemma externals_of_par: "ext (A1||A2) =
218.303 - (ext A1) Un (ext A2)"
218.304 -apply (simp add: externals_def asig_of_par asig_comp_def
218.305 - asig_inputs_def asig_outputs_def Un_def set_diff_eq)
218.306 -apply blast
218.307 -done
218.308 -
218.309 -lemma actions_of_par: "act (A1||A2) =
218.310 - (act A1) Un (act A2)"
218.311 -apply (simp add: actions_def asig_of_par asig_comp_def
218.312 - asig_inputs_def asig_outputs_def asig_internals_def Un_def set_diff_eq)
218.313 -apply blast
218.314 -done
218.315 -
218.316 -lemma inputs_of_par: "inp (A1||A2) =
218.317 - ((inp A1) Un (inp A2)) - ((out A1) Un (out A2))"
218.318 -apply (simp add: actions_def asig_of_par asig_comp_def
218.319 - asig_inputs_def asig_outputs_def Un_def set_diff_eq)
218.320 -done
218.321 -
218.322 -lemma outputs_of_par: "out (A1||A2) =
218.323 - (out A1) Un (out A2)"
218.324 -apply (simp add: actions_def asig_of_par asig_comp_def
218.325 - asig_outputs_def Un_def set_diff_eq)
218.326 -done
218.327 -
218.328 -lemma internals_of_par: "int (A1||A2) =
218.329 - (int A1) Un (int A2)"
218.330 -apply (simp add: actions_def asig_of_par asig_comp_def
218.331 - asig_inputs_def asig_outputs_def asig_internals_def Un_def set_diff_eq)
218.332 -done
218.333 -
218.334 -
218.335 -subsection "actions and compatibility"
218.336 -
218.337 -lemma compat_commute: "compatible A B = compatible B A"
218.338 -apply (simp add: compatible_def Int_commute)
218.339 -apply auto
218.340 -done
218.341 -
218.342 -lemma ext1_is_not_int2:
218.343 - "[| compatible A1 A2; a:ext A1|] ==> a~:int A2"
218.344 -apply (unfold externals_def actions_def compatible_def)
218.345 -apply simp
218.346 -apply blast
218.347 -done
218.348 -
218.349 -(* just commuting the previous one: better commute compatible *)
218.350 -lemma ext2_is_not_int1:
218.351 - "[| compatible A2 A1 ; a:ext A1|] ==> a~:int A2"
218.352 -apply (unfold externals_def actions_def compatible_def)
218.353 -apply simp
218.354 -apply blast
218.355 -done
218.356 -
218.357 -lemmas ext1_ext2_is_not_act2 = ext1_is_not_int2 [THEN int_and_ext_is_act, standard]
218.358 -lemmas ext1_ext2_is_not_act1 = ext2_is_not_int1 [THEN int_and_ext_is_act, standard]
218.359 -
218.360 -lemma intA_is_not_extB:
218.361 - "[| compatible A B; x:int A |] ==> x~:ext B"
218.362 -apply (unfold externals_def actions_def compatible_def)
218.363 -apply simp
218.364 -apply blast
218.365 -done
218.366 -
218.367 -lemma intA_is_not_actB:
218.368 -"[| compatible A B; a:int A |] ==> a ~: act B"
218.369 -apply (unfold externals_def actions_def compatible_def is_asig_def asig_of_def)
218.370 -apply simp
218.371 -apply blast
218.372 -done
218.373 -
218.374 -(* the only one that needs disjointness of outputs and of internals and _all_ acts *)
218.375 -lemma outAactB_is_inpB:
218.376 -"[| compatible A B; a:out A ;a:act B|] ==> a : inp B"
218.377 -apply (unfold asig_outputs_def asig_internals_def actions_def asig_inputs_def
218.378 - compatible_def is_asig_def asig_of_def)
218.379 -apply simp
218.380 -apply blast
218.381 -done
218.382 -
218.383 -(* needed for propagation of input_enabledness from A,B to A||B *)
218.384 -lemma inpAAactB_is_inpBoroutB:
218.385 -"[| compatible A B; a:inp A ;a:act B|] ==> a : inp B | a: out B"
218.386 -apply (unfold asig_outputs_def asig_internals_def actions_def asig_inputs_def
218.387 - compatible_def is_asig_def asig_of_def)
218.388 -apply simp
218.389 -apply blast
218.390 -done
218.391 -
218.392 -
218.393 -subsection "input_enabledness and par"
218.394 -
218.395 -
218.396 -(* ugly case distinctions. Heart of proof:
218.397 - 1. inpAAactB_is_inpBoroutB ie. internals are really hidden.
218.398 - 2. inputs_of_par: outputs are no longer inputs of par. This is important here *)
218.399 -lemma input_enabled_par:
218.400 -"[| compatible A B; input_enabled A; input_enabled B|]
218.401 - ==> input_enabled (A||B)"
218.402 -apply (unfold input_enabled_def)
218.403 -apply (simp add: Let_def inputs_of_par trans_of_par)
218.404 -apply (tactic "safe_tac (global_claset_of @{theory Fun})")
218.405 -apply (simp add: inp_is_act)
218.406 -prefer 2
218.407 -apply (simp add: inp_is_act)
218.408 -(* a: inp A *)
218.409 -apply (case_tac "a:act B")
218.410 -(* a:act B *)
218.411 -apply (erule_tac x = "a" in allE)
218.412 -apply simp
218.413 -apply (drule inpAAactB_is_inpBoroutB)
218.414 -apply assumption
218.415 -apply assumption
218.416 -apply (erule_tac x = "a" in allE)
218.417 -apply simp
218.418 -apply (erule_tac x = "aa" in allE)
218.419 -apply (erule_tac x = "b" in allE)
218.420 -apply (erule exE)
218.421 -apply (erule exE)
218.422 -apply (rule_tac x = " (s2,s2a) " in exI)
218.423 -apply (simp add: inp_is_act)
218.424 -(* a~: act B*)
218.425 -apply (simp add: inp_is_act)
218.426 -apply (erule_tac x = "a" in allE)
218.427 -apply simp
218.428 -apply (erule_tac x = "aa" in allE)
218.429 -apply (erule exE)
218.430 -apply (rule_tac x = " (s2,b) " in exI)
218.431 -apply simp
218.432 -
218.433 -(* a:inp B *)
218.434 -apply (case_tac "a:act A")
218.435 -(* a:act A *)
218.436 -apply (erule_tac x = "a" in allE)
218.437 -apply (erule_tac x = "a" in allE)
218.438 -apply (simp add: inp_is_act)
218.439 -apply (frule_tac A1 = "A" in compat_commute [THEN iffD1])
218.440 -apply (drule inpAAactB_is_inpBoroutB)
218.441 -back
218.442 -apply assumption
218.443 -apply assumption
218.444 -apply simp
218.445 -apply (erule_tac x = "aa" in allE)
218.446 -apply (erule_tac x = "b" in allE)
218.447 -apply (erule exE)
218.448 -apply (erule exE)
218.449 -apply (rule_tac x = " (s2,s2a) " in exI)
218.450 -apply (simp add: inp_is_act)
218.451 -(* a~: act B*)
218.452 -apply (simp add: inp_is_act)
218.453 -apply (erule_tac x = "a" in allE)
218.454 -apply (erule_tac x = "a" in allE)
218.455 -apply simp
218.456 -apply (erule_tac x = "b" in allE)
218.457 -apply (erule exE)
218.458 -apply (rule_tac x = " (aa,s2) " in exI)
218.459 -apply simp
218.460 -done
218.461 -
218.462 -
218.463 -subsection "invariants"
218.464 -
218.465 -lemma invariantI:
218.466 - "[| !!s. s:starts_of(A) ==> P(s);
218.467 - !!s t a. [|reachable A s; P(s)|] ==> (s,a,t): trans_of(A) --> P(t) |]
218.468 - ==> invariant A P"
218.469 -apply (unfold invariant_def)
218.470 -apply (rule allI)
218.471 -apply (rule impI)
218.472 -apply (rule_tac x = "s" in reachable.induct)
218.473 -apply assumption
218.474 -apply blast
218.475 -apply blast
218.476 -done
218.477 -
218.478 -lemma invariantI1:
218.479 - "[| !!s. s : starts_of(A) ==> P(s);
218.480 - !!s t a. reachable A s ==> P(s) --> (s,a,t):trans_of(A) --> P(t)
218.481 - |] ==> invariant A P"
218.482 - apply (blast intro: invariantI)
218.483 - done
218.484 -
218.485 -lemma invariantE: "[| invariant A P; reachable A s |] ==> P(s)"
218.486 - apply (unfold invariant_def)
218.487 - apply blast
218.488 - done
218.489 -
218.490 -
218.491 -subsection "restrict"
218.492 -
218.493 -
218.494 -lemmas reachable_0 = reachable.reachable_0
218.495 - and reachable_n = reachable.reachable_n
218.496 -
218.497 -lemma cancel_restrict_a: "starts_of(restrict ioa acts) = starts_of(ioa) &
218.498 - trans_of(restrict ioa acts) = trans_of(ioa)"
218.499 -apply (simp add: restrict_def ioa_projections)
218.500 -done
218.501 -
218.502 -lemma cancel_restrict_b: "reachable (restrict ioa acts) s = reachable ioa s"
218.503 -apply (rule iffI)
218.504 -apply (erule reachable.induct)
218.505 -apply (simp add: cancel_restrict_a reachable_0)
218.506 -apply (erule reachable_n)
218.507 -apply (simp add: cancel_restrict_a)
218.508 -(* <-- *)
218.509 -apply (erule reachable.induct)
218.510 -apply (rule reachable_0)
218.511 -apply (simp add: cancel_restrict_a)
218.512 -apply (erule reachable_n)
218.513 -apply (simp add: cancel_restrict_a)
218.514 -done
218.515 -
218.516 -lemma acts_restrict: "act (restrict A acts) = act A"
218.517 -apply (simp (no_asm) add: actions_def asig_internals_def
218.518 - asig_outputs_def asig_inputs_def externals_def asig_of_def restrict_def restrict_asig_def)
218.519 -apply auto
218.520 -done
218.521 -
218.522 -lemma cancel_restrict: "starts_of(restrict ioa acts) = starts_of(ioa) &
218.523 - trans_of(restrict ioa acts) = trans_of(ioa) &
218.524 - reachable (restrict ioa acts) s = reachable ioa s &
218.525 - act (restrict A acts) = act A"
218.526 - apply (simp (no_asm) add: cancel_restrict_a cancel_restrict_b acts_restrict)
218.527 - done
218.528 -
218.529 -
218.530 -subsection "rename"
218.531 -
218.532 -lemma trans_rename: "s -a--(rename C f)-> t ==> (? x. Some(x) = f(a) & s -x--C-> t)"
218.533 -apply (simp add: Let_def rename_def trans_of_def)
218.534 -done
218.535 -
218.536 -
218.537 -lemma reachable_rename: "[| reachable (rename C g) s |] ==> reachable C s"
218.538 -apply (erule reachable.induct)
218.539 -apply (rule reachable_0)
218.540 -apply (simp add: rename_def ioa_projections)
218.541 -apply (drule trans_rename)
218.542 -apply (erule exE)
218.543 -apply (erule conjE)
218.544 -apply (erule reachable_n)
218.545 -apply assumption
218.546 -done
218.547 -
218.548 -
218.549 -subsection "trans_of(A||B)"
218.550 -
218.551 -
218.552 -lemma trans_A_proj: "[|(s,a,t):trans_of (A||B); a:act A|]
218.553 - ==> (fst s,a,fst t):trans_of A"
218.554 -apply (simp add: Let_def par_def trans_of_def)
218.555 -done
218.556 -
218.557 -lemma trans_B_proj: "[|(s,a,t):trans_of (A||B); a:act B|]
218.558 - ==> (snd s,a,snd t):trans_of B"
218.559 -apply (simp add: Let_def par_def trans_of_def)
218.560 -done
218.561 -
218.562 -lemma trans_A_proj2: "[|(s,a,t):trans_of (A||B); a~:act A|]
218.563 - ==> fst s = fst t"
218.564 -apply (simp add: Let_def par_def trans_of_def)
218.565 -done
218.566 -
218.567 -lemma trans_B_proj2: "[|(s,a,t):trans_of (A||B); a~:act B|]
218.568 - ==> snd s = snd t"
218.569 -apply (simp add: Let_def par_def trans_of_def)
218.570 -done
218.571 -
218.572 -lemma trans_AB_proj: "(s,a,t):trans_of (A||B)
218.573 - ==> a :act A | a :act B"
218.574 -apply (simp add: Let_def par_def trans_of_def)
218.575 -done
218.576 -
218.577 -lemma trans_AB: "[|a:act A;a:act B;
218.578 - (fst s,a,fst t):trans_of A;(snd s,a,snd t):trans_of B|]
218.579 - ==> (s,a,t):trans_of (A||B)"
218.580 -apply (simp add: Let_def par_def trans_of_def)
218.581 -done
218.582 -
218.583 -lemma trans_A_notB: "[|a:act A;a~:act B;
218.584 - (fst s,a,fst t):trans_of A;snd s=snd t|]
218.585 - ==> (s,a,t):trans_of (A||B)"
218.586 -apply (simp add: Let_def par_def trans_of_def)
218.587 -done
218.588 -
218.589 -lemma trans_notA_B: "[|a~:act A;a:act B;
218.590 - (snd s,a,snd t):trans_of B;fst s=fst t|]
218.591 - ==> (s,a,t):trans_of (A||B)"
218.592 -apply (simp add: Let_def par_def trans_of_def)
218.593 -done
218.594 -
218.595 -lemmas trans_of_defs1 = trans_AB trans_A_notB trans_notA_B
218.596 - and trans_of_defs2 = trans_A_proj trans_B_proj trans_A_proj2 trans_B_proj2 trans_AB_proj
218.597 -
218.598 -
218.599 -lemma trans_of_par4:
218.600 -"((s,a,t) : trans_of(A || B || C || D)) =
218.601 - ((a:actions(asig_of(A)) | a:actions(asig_of(B)) | a:actions(asig_of(C)) |
218.602 - a:actions(asig_of(D))) &
218.603 - (if a:actions(asig_of(A)) then (fst(s),a,fst(t)):trans_of(A)
218.604 - else fst t=fst s) &
218.605 - (if a:actions(asig_of(B)) then (fst(snd(s)),a,fst(snd(t))):trans_of(B)
218.606 - else fst(snd(t))=fst(snd(s))) &
218.607 - (if a:actions(asig_of(C)) then
218.608 - (fst(snd(snd(s))),a,fst(snd(snd(t)))):trans_of(C)
218.609 - else fst(snd(snd(t)))=fst(snd(snd(s)))) &
218.610 - (if a:actions(asig_of(D)) then
218.611 - (snd(snd(snd(s))),a,snd(snd(snd(t)))):trans_of(D)
218.612 - else snd(snd(snd(t)))=snd(snd(snd(s)))))"
218.613 - apply (simp (no_asm) add: par_def actions_asig_comp Pair_fst_snd_eq Let_def ioa_projections)
218.614 - done
218.615 -
218.616 -
218.617 -subsection "proof obligation generator for IOA requirements"
218.618 -
218.619 -(* without assumptions on A and B because is_trans_of is also incorporated in ||def *)
218.620 -lemma is_trans_of_par: "is_trans_of (A||B)"
218.621 -apply (unfold is_trans_of_def)
218.622 -apply (simp add: Let_def actions_of_par trans_of_par)
218.623 -done
218.624 -
218.625 -lemma is_trans_of_restrict:
218.626 -"is_trans_of A ==> is_trans_of (restrict A acts)"
218.627 -apply (unfold is_trans_of_def)
218.628 -apply (simp add: cancel_restrict acts_restrict)
218.629 -done
218.630 -
218.631 -lemma is_trans_of_rename:
218.632 -"is_trans_of A ==> is_trans_of (rename A f)"
218.633 -apply (unfold is_trans_of_def restrict_def restrict_asig_def)
218.634 -apply (simp add: Let_def actions_def trans_of_def asig_internals_def
218.635 - asig_outputs_def asig_inputs_def externals_def asig_of_def rename_def rename_set_def)
218.636 -apply blast
218.637 -done
218.638 -
218.639 -lemma is_asig_of_par: "[| is_asig_of A; is_asig_of B; compatible A B|]
218.640 - ==> is_asig_of (A||B)"
218.641 -apply (simp add: is_asig_of_def asig_of_par asig_comp_def compatible_def
218.642 - asig_internals_def asig_outputs_def asig_inputs_def actions_def is_asig_def)
218.643 -apply (simp add: asig_of_def)
218.644 -apply auto
218.645 -done
218.646 -
218.647 -lemma is_asig_of_restrict:
218.648 -"is_asig_of A ==> is_asig_of (restrict A f)"
218.649 -apply (unfold is_asig_of_def is_asig_def asig_of_def restrict_def restrict_asig_def
218.650 - asig_internals_def asig_outputs_def asig_inputs_def externals_def o_def)
218.651 -apply simp
218.652 -apply auto
218.653 -done
218.654 -
218.655 -lemma is_asig_of_rename: "is_asig_of A ==> is_asig_of (rename A f)"
218.656 -apply (simp add: is_asig_of_def rename_def rename_set_def asig_internals_def
218.657 - asig_outputs_def asig_inputs_def actions_def is_asig_def asig_of_def)
218.658 -apply auto
218.659 -apply (drule_tac [!] s = "Some ?x" in sym)
218.660 -apply auto
218.661 -done
218.662 -
218.663 -lemmas [simp] = is_asig_of_par is_asig_of_restrict
218.664 - is_asig_of_rename is_trans_of_par is_trans_of_restrict is_trans_of_rename
218.665 -
218.666 -
218.667 -lemma compatible_par:
218.668 -"[|compatible A B; compatible A C |]==> compatible A (B||C)"
218.669 -apply (unfold compatible_def)
218.670 -apply (simp add: internals_of_par outputs_of_par actions_of_par)
218.671 -apply auto
218.672 -done
218.673 -
218.674 -(* better derive by previous one and compat_commute *)
218.675 -lemma compatible_par2:
218.676 -"[|compatible A C; compatible B C |]==> compatible (A||B) C"
218.677 -apply (unfold compatible_def)
218.678 -apply (simp add: internals_of_par outputs_of_par actions_of_par)
218.679 -apply auto
218.680 -done
218.681 -
218.682 -lemma compatible_restrict:
218.683 -"[| compatible A B; (ext B - S) Int ext A = {}|]
218.684 - ==> compatible A (restrict B S)"
218.685 -apply (unfold compatible_def)
218.686 -apply (simp add: ioa_triple_proj asig_triple_proj externals_def
218.687 - restrict_def restrict_asig_def actions_def)
218.688 -apply auto
218.689 -done
218.690 -
218.691 -
218.692 -declare split_paired_Ex [simp]
218.693 -
218.694 -end
219.1 --- a/src/HOLCF/IOA/meta_theory/CompoExecs.thy Sat Nov 27 14:34:54 2010 -0800
219.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
219.3 @@ -1,303 +0,0 @@
219.4 -(* Title: HOLCF/IOA/meta_theory/CompoExecs.thy
219.5 - Author: Olaf Müller
219.6 -*)
219.7 -
219.8 -header {* Compositionality on Execution level *}
219.9 -
219.10 -theory CompoExecs
219.11 -imports Traces
219.12 -begin
219.13 -
219.14 -definition
219.15 - ProjA2 :: "('a,'s * 't)pairs -> ('a,'s)pairs" where
219.16 - "ProjA2 = Map (%x.(fst x,fst(snd x)))"
219.17 -
219.18 -definition
219.19 - ProjA :: "('a,'s * 't)execution => ('a,'s)execution" where
219.20 - "ProjA ex = (fst (fst ex), ProjA2$(snd ex))"
219.21 -
219.22 -definition
219.23 - ProjB2 :: "('a,'s * 't)pairs -> ('a,'t)pairs" where
219.24 - "ProjB2 = Map (%x.(fst x,snd(snd x)))"
219.25 -
219.26 -definition
219.27 - ProjB :: "('a,'s * 't)execution => ('a,'t)execution" where
219.28 - "ProjB ex = (snd (fst ex), ProjB2$(snd ex))"
219.29 -
219.30 -definition
219.31 - Filter_ex2 :: "'a signature => ('a,'s)pairs -> ('a,'s)pairs" where
219.32 - "Filter_ex2 sig = Filter (%x. fst x:actions sig)"
219.33 -
219.34 -definition
219.35 - Filter_ex :: "'a signature => ('a,'s)execution => ('a,'s)execution" where
219.36 - "Filter_ex sig ex = (fst ex,Filter_ex2 sig$(snd ex))"
219.37 -
219.38 -definition
219.39 - stutter2 :: "'a signature => ('a,'s)pairs -> ('s => tr)" where
219.40 - "stutter2 sig = (fix$(LAM h ex. (%s. case ex of
219.41 - nil => TT
219.42 - | x##xs => (flift1
219.43 - (%p.(If Def ((fst p)~:actions sig)
219.44 - then Def (s=(snd p))
219.45 - else TT)
219.46 - andalso (h$xs) (snd p))
219.47 - $x)
219.48 - )))"
219.49 -
219.50 -definition
219.51 - stutter :: "'a signature => ('a,'s)execution => bool" where
219.52 - "stutter sig ex = ((stutter2 sig$(snd ex)) (fst ex) ~= FF)"
219.53 -
219.54 -definition
219.55 - par_execs :: "[('a,'s)execution_module,('a,'t)execution_module] => ('a,'s*'t)execution_module" where
219.56 - "par_execs ExecsA ExecsB =
219.57 - (let exA = fst ExecsA; sigA = snd ExecsA;
219.58 - exB = fst ExecsB; sigB = snd ExecsB
219.59 - in
219.60 - ( {ex. Filter_ex sigA (ProjA ex) : exA}
219.61 - Int {ex. Filter_ex sigB (ProjB ex) : exB}
219.62 - Int {ex. stutter sigA (ProjA ex)}
219.63 - Int {ex. stutter sigB (ProjB ex)}
219.64 - Int {ex. Forall (%x. fst x:(actions sigA Un actions sigB)) (snd ex)},
219.65 - asig_comp sigA sigB))"
219.66 -
219.67 -
219.68 -lemmas [simp del] = split_paired_All
219.69 -
219.70 -
219.71 -section "recursive equations of operators"
219.72 -
219.73 -
219.74 -(* ---------------------------------------------------------------- *)
219.75 -(* ProjA2 *)
219.76 -(* ---------------------------------------------------------------- *)
219.77 -
219.78 -
219.79 -lemma ProjA2_UU: "ProjA2$UU = UU"
219.80 -apply (simp add: ProjA2_def)
219.81 -done
219.82 -
219.83 -lemma ProjA2_nil: "ProjA2$nil = nil"
219.84 -apply (simp add: ProjA2_def)
219.85 -done
219.86 -
219.87 -lemma ProjA2_cons: "ProjA2$((a,t)>>xs) = (a,fst t) >> ProjA2$xs"
219.88 -apply (simp add: ProjA2_def)
219.89 -done
219.90 -
219.91 -
219.92 -(* ---------------------------------------------------------------- *)
219.93 -(* ProjB2 *)
219.94 -(* ---------------------------------------------------------------- *)
219.95 -
219.96 -
219.97 -lemma ProjB2_UU: "ProjB2$UU = UU"
219.98 -apply (simp add: ProjB2_def)
219.99 -done
219.100 -
219.101 -lemma ProjB2_nil: "ProjB2$nil = nil"
219.102 -apply (simp add: ProjB2_def)
219.103 -done
219.104 -
219.105 -lemma ProjB2_cons: "ProjB2$((a,t)>>xs) = (a,snd t) >> ProjB2$xs"
219.106 -apply (simp add: ProjB2_def)
219.107 -done
219.108 -
219.109 -
219.110 -
219.111 -(* ---------------------------------------------------------------- *)
219.112 -(* Filter_ex2 *)
219.113 -(* ---------------------------------------------------------------- *)
219.114 -
219.115 -
219.116 -lemma Filter_ex2_UU: "Filter_ex2 sig$UU=UU"
219.117 -apply (simp add: Filter_ex2_def)
219.118 -done
219.119 -
219.120 -lemma Filter_ex2_nil: "Filter_ex2 sig$nil=nil"
219.121 -apply (simp add: Filter_ex2_def)
219.122 -done
219.123 -
219.124 -lemma Filter_ex2_cons: "Filter_ex2 sig$(at >> xs) =
219.125 - (if (fst at:actions sig)
219.126 - then at >> (Filter_ex2 sig$xs)
219.127 - else Filter_ex2 sig$xs)"
219.128 -
219.129 -apply (simp add: Filter_ex2_def)
219.130 -done
219.131 -
219.132 -
219.133 -(* ---------------------------------------------------------------- *)
219.134 -(* stutter2 *)
219.135 -(* ---------------------------------------------------------------- *)
219.136 -
219.137 -
219.138 -lemma stutter2_unfold: "stutter2 sig = (LAM ex. (%s. case ex of
219.139 - nil => TT
219.140 - | x##xs => (flift1
219.141 - (%p.(If Def ((fst p)~:actions sig)
219.142 - then Def (s=(snd p))
219.143 - else TT)
219.144 - andalso (stutter2 sig$xs) (snd p))
219.145 - $x)
219.146 - ))"
219.147 -apply (rule trans)
219.148 -apply (rule fix_eq2)
219.149 -apply (simp only: stutter2_def)
219.150 -apply (rule beta_cfun)
219.151 -apply (simp add: flift1_def)
219.152 -done
219.153 -
219.154 -lemma stutter2_UU: "(stutter2 sig$UU) s=UU"
219.155 -apply (subst stutter2_unfold)
219.156 -apply simp
219.157 -done
219.158 -
219.159 -lemma stutter2_nil: "(stutter2 sig$nil) s = TT"
219.160 -apply (subst stutter2_unfold)
219.161 -apply simp
219.162 -done
219.163 -
219.164 -lemma stutter2_cons: "(stutter2 sig$(at>>xs)) s =
219.165 - ((if (fst at)~:actions sig then Def (s=snd at) else TT)
219.166 - andalso (stutter2 sig$xs) (snd at))"
219.167 -apply (rule trans)
219.168 -apply (subst stutter2_unfold)
219.169 -apply (simp add: Consq_def flift1_def If_and_if)
219.170 -apply simp
219.171 -done
219.172 -
219.173 -
219.174 -declare stutter2_UU [simp] stutter2_nil [simp] stutter2_cons [simp]
219.175 -
219.176 -
219.177 -(* ---------------------------------------------------------------- *)
219.178 -(* stutter *)
219.179 -(* ---------------------------------------------------------------- *)
219.180 -
219.181 -lemma stutter_UU: "stutter sig (s, UU)"
219.182 -apply (simp add: stutter_def)
219.183 -done
219.184 -
219.185 -lemma stutter_nil: "stutter sig (s, nil)"
219.186 -apply (simp add: stutter_def)
219.187 -done
219.188 -
219.189 -lemma stutter_cons: "stutter sig (s, (a,t)>>ex) =
219.190 - ((a~:actions sig --> (s=t)) & stutter sig (t,ex))"
219.191 -apply (simp add: stutter_def)
219.192 -done
219.193 -
219.194 -(* ----------------------------------------------------------------------------------- *)
219.195 -
219.196 -declare stutter2_UU [simp del] stutter2_nil [simp del] stutter2_cons [simp del]
219.197 -
219.198 -lemmas compoex_simps = ProjA2_UU ProjA2_nil ProjA2_cons
219.199 - ProjB2_UU ProjB2_nil ProjB2_cons
219.200 - Filter_ex2_UU Filter_ex2_nil Filter_ex2_cons
219.201 - stutter_UU stutter_nil stutter_cons
219.202 -
219.203 -declare compoex_simps [simp]
219.204 -
219.205 -
219.206 -
219.207 -(* ------------------------------------------------------------------ *)
219.208 -(* The following lemmata aim for *)
219.209 -(* COMPOSITIONALITY on EXECUTION Level *)
219.210 -(* ------------------------------------------------------------------ *)
219.211 -
219.212 -
219.213 -(* --------------------------------------------------------------------- *)
219.214 -(* Lemma_1_1a : is_ex_fr propagates from A||B to Projections A and B *)
219.215 -(* --------------------------------------------------------------------- *)
219.216 -
219.217 -lemma lemma_1_1a: "!s. is_exec_frag (A||B) (s,xs)
219.218 - --> is_exec_frag A (fst s, Filter_ex2 (asig_of A)$(ProjA2$xs)) &
219.219 - is_exec_frag B (snd s, Filter_ex2 (asig_of B)$(ProjB2$xs))"
219.220 -
219.221 -apply (tactic {* pair_induct_tac @{context} "xs" [@{thm is_exec_frag_def}] 1 *})
219.222 -(* main case *)
219.223 -apply (auto simp add: trans_of_defs2)
219.224 -done
219.225 -
219.226 -
219.227 -(* --------------------------------------------------------------------- *)
219.228 -(* Lemma_1_1b : is_ex_fr (A||B) implies stuttering on Projections *)
219.229 -(* --------------------------------------------------------------------- *)
219.230 -
219.231 -lemma lemma_1_1b: "!s. is_exec_frag (A||B) (s,xs)
219.232 - --> stutter (asig_of A) (fst s,ProjA2$xs) &
219.233 - stutter (asig_of B) (snd s,ProjB2$xs)"
219.234 -
219.235 -apply (tactic {* pair_induct_tac @{context} "xs"
219.236 - [@{thm stutter_def}, @{thm is_exec_frag_def}] 1 *})
219.237 -(* main case *)
219.238 -apply (auto simp add: trans_of_defs2)
219.239 -done
219.240 -
219.241 -
219.242 -(* --------------------------------------------------------------------- *)
219.243 -(* Lemma_1_1c : Executions of A||B have only A- or B-actions *)
219.244 -(* --------------------------------------------------------------------- *)
219.245 -
219.246 -lemma lemma_1_1c: "!s. (is_exec_frag (A||B) (s,xs)
219.247 - --> Forall (%x. fst x:act (A||B)) xs)"
219.248 -
219.249 -apply (tactic {* pair_induct_tac @{context} "xs" [@{thm Forall_def}, @{thm sforall_def},
219.250 - @{thm is_exec_frag_def}] 1 *})
219.251 -(* main case *)
219.252 -apply auto
219.253 -apply (simp add: trans_of_defs2 actions_asig_comp asig_of_par)
219.254 -done
219.255 -
219.256 -
219.257 -(* ----------------------------------------------------------------------- *)
219.258 -(* Lemma_1_2 : ex A, exB, stuttering and forall a:A|B implies ex (A||B) *)
219.259 -(* ----------------------------------------------------------------------- *)
219.260 -
219.261 -lemma lemma_1_2:
219.262 -"!s. is_exec_frag A (fst s,Filter_ex2 (asig_of A)$(ProjA2$xs)) &
219.263 - is_exec_frag B (snd s,Filter_ex2 (asig_of B)$(ProjB2$xs)) &
219.264 - stutter (asig_of A) (fst s,(ProjA2$xs)) &
219.265 - stutter (asig_of B) (snd s,(ProjB2$xs)) &
219.266 - Forall (%x. fst x:act (A||B)) xs
219.267 - --> is_exec_frag (A||B) (s,xs)"
219.268 -
219.269 -apply (tactic {* pair_induct_tac @{context} "xs" [@{thm Forall_def}, @{thm sforall_def},
219.270 - @{thm is_exec_frag_def}, @{thm stutter_def}] 1 *})
219.271 -apply (auto simp add: trans_of_defs1 actions_asig_comp asig_of_par)
219.272 -done
219.273 -
219.274 -
219.275 -subsection {* COMPOSITIONALITY on EXECUTION Level -- Main Theorem *}
219.276 -
219.277 -lemma compositionality_ex:
219.278 -"(ex:executions(A||B)) =
219.279 - (Filter_ex (asig_of A) (ProjA ex) : executions A &
219.280 - Filter_ex (asig_of B) (ProjB ex) : executions B &
219.281 - stutter (asig_of A) (ProjA ex) & stutter (asig_of B) (ProjB ex) &
219.282 - Forall (%x. fst x:act (A||B)) (snd ex))"
219.283 -
219.284 -apply (simp (no_asm) add: executions_def ProjB_def Filter_ex_def ProjA_def starts_of_par)
219.285 -apply (tactic {* pair_tac @{context} "ex" 1 *})
219.286 -apply (rule iffI)
219.287 -(* ==> *)
219.288 -apply (erule conjE)+
219.289 -apply (simp add: lemma_1_1a lemma_1_1b lemma_1_1c)
219.290 -(* <== *)
219.291 -apply (erule conjE)+
219.292 -apply (simp add: lemma_1_2)
219.293 -done
219.294 -
219.295 -
219.296 -subsection {* COMPOSITIONALITY on EXECUTION Level -- for Modules *}
219.297 -
219.298 -lemma compositionality_ex_modules:
219.299 - "Execs (A||B) = par_execs (Execs A) (Execs B)"
219.300 -apply (unfold Execs_def par_execs_def)
219.301 -apply (simp add: asig_of_par)
219.302 -apply (rule set_eqI)
219.303 -apply (simp add: compositionality_ex actions_of_par)
219.304 -done
219.305 -
219.306 -end
220.1 --- a/src/HOLCF/IOA/meta_theory/CompoScheds.thy Sat Nov 27 14:34:54 2010 -0800
220.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
220.3 @@ -1,553 +0,0 @@
220.4 -(* Title: HOLCF/IOA/meta_theory/CompoScheds.thy
220.5 - Author: Olaf Müller
220.6 -*)
220.7 -
220.8 -header {* Compositionality on Schedule level *}
220.9 -
220.10 -theory CompoScheds
220.11 -imports CompoExecs
220.12 -begin
220.13 -
220.14 -definition
220.15 - mkex2 :: "('a,'s)ioa => ('a,'t)ioa => 'a Seq ->
220.16 - ('a,'s)pairs -> ('a,'t)pairs ->
220.17 - ('s => 't => ('a,'s*'t)pairs)" where
220.18 - "mkex2 A B = (fix$(LAM h sch exA exB. (%s t. case sch of
220.19 - nil => nil
220.20 - | x##xs =>
220.21 - (case x of
220.22 - UU => UU
220.23 - | Def y =>
220.24 - (if y:act A then
220.25 - (if y:act B then
220.26 - (case HD$exA of
220.27 - UU => UU
220.28 - | Def a => (case HD$exB of
220.29 - UU => UU
220.30 - | Def b =>
220.31 - (y,(snd a,snd b))>>
220.32 - (h$xs$(TL$exA)$(TL$exB)) (snd a) (snd b)))
220.33 - else
220.34 - (case HD$exA of
220.35 - UU => UU
220.36 - | Def a =>
220.37 - (y,(snd a,t))>>(h$xs$(TL$exA)$exB) (snd a) t)
220.38 - )
220.39 - else
220.40 - (if y:act B then
220.41 - (case HD$exB of
220.42 - UU => UU
220.43 - | Def b =>
220.44 - (y,(s,snd b))>>(h$xs$exA$(TL$exB)) s (snd b))
220.45 - else
220.46 - UU
220.47 - )
220.48 - )
220.49 - ))))"
220.50 -
220.51 -definition
220.52 - mkex :: "('a,'s)ioa => ('a,'t)ioa => 'a Seq =>
220.53 - ('a,'s)execution => ('a,'t)execution =>('a,'s*'t)execution" where
220.54 - "mkex A B sch exA exB =
220.55 - ((fst exA,fst exB),
220.56 - (mkex2 A B$sch$(snd exA)$(snd exB)) (fst exA) (fst exB))"
220.57 -
220.58 -definition
220.59 - par_scheds ::"['a schedule_module,'a schedule_module] => 'a schedule_module" where
220.60 - "par_scheds SchedsA SchedsB =
220.61 - (let schA = fst SchedsA; sigA = snd SchedsA;
220.62 - schB = fst SchedsB; sigB = snd SchedsB
220.63 - in
220.64 - ( {sch. Filter (%a. a:actions sigA)$sch : schA}
220.65 - Int {sch. Filter (%a. a:actions sigB)$sch : schB}
220.66 - Int {sch. Forall (%x. x:(actions sigA Un actions sigB)) sch},
220.67 - asig_comp sigA sigB))"
220.68 -
220.69 -
220.70 -subsection "mkex rewrite rules"
220.71 -
220.72 -
220.73 -lemma mkex2_unfold:
220.74 -"mkex2 A B = (LAM sch exA exB. (%s t. case sch of
220.75 - nil => nil
220.76 - | x##xs =>
220.77 - (case x of
220.78 - UU => UU
220.79 - | Def y =>
220.80 - (if y:act A then
220.81 - (if y:act B then
220.82 - (case HD$exA of
220.83 - UU => UU
220.84 - | Def a => (case HD$exB of
220.85 - UU => UU
220.86 - | Def b =>
220.87 - (y,(snd a,snd b))>>
220.88 - (mkex2 A B$xs$(TL$exA)$(TL$exB)) (snd a) (snd b)))
220.89 - else
220.90 - (case HD$exA of
220.91 - UU => UU
220.92 - | Def a =>
220.93 - (y,(snd a,t))>>(mkex2 A B$xs$(TL$exA)$exB) (snd a) t)
220.94 - )
220.95 - else
220.96 - (if y:act B then
220.97 - (case HD$exB of
220.98 - UU => UU
220.99 - | Def b =>
220.100 - (y,(s,snd b))>>(mkex2 A B$xs$exA$(TL$exB)) s (snd b))
220.101 - else
220.102 - UU
220.103 - )
220.104 - )
220.105 - )))"
220.106 -apply (rule trans)
220.107 -apply (rule fix_eq2)
220.108 -apply (simp only: mkex2_def)
220.109 -apply (rule beta_cfun)
220.110 -apply simp
220.111 -done
220.112 -
220.113 -lemma mkex2_UU: "(mkex2 A B$UU$exA$exB) s t = UU"
220.114 -apply (subst mkex2_unfold)
220.115 -apply simp
220.116 -done
220.117 -
220.118 -lemma mkex2_nil: "(mkex2 A B$nil$exA$exB) s t= nil"
220.119 -apply (subst mkex2_unfold)
220.120 -apply simp
220.121 -done
220.122 -
220.123 -lemma mkex2_cons_1: "[| x:act A; x~:act B; HD$exA=Def a|]
220.124 - ==> (mkex2 A B$(x>>sch)$exA$exB) s t =
220.125 - (x,snd a,t) >> (mkex2 A B$sch$(TL$exA)$exB) (snd a) t"
220.126 -apply (rule trans)
220.127 -apply (subst mkex2_unfold)
220.128 -apply (simp add: Consq_def If_and_if)
220.129 -apply (simp add: Consq_def)
220.130 -done
220.131 -
220.132 -lemma mkex2_cons_2: "[| x~:act A; x:act B; HD$exB=Def b|]
220.133 - ==> (mkex2 A B$(x>>sch)$exA$exB) s t =
220.134 - (x,s,snd b) >> (mkex2 A B$sch$exA$(TL$exB)) s (snd b)"
220.135 -apply (rule trans)
220.136 -apply (subst mkex2_unfold)
220.137 -apply (simp add: Consq_def If_and_if)
220.138 -apply (simp add: Consq_def)
220.139 -done
220.140 -
220.141 -lemma mkex2_cons_3: "[| x:act A; x:act B; HD$exA=Def a;HD$exB=Def b|]
220.142 - ==> (mkex2 A B$(x>>sch)$exA$exB) s t =
220.143 - (x,snd a,snd b) >>
220.144 - (mkex2 A B$sch$(TL$exA)$(TL$exB)) (snd a) (snd b)"
220.145 -apply (rule trans)
220.146 -apply (subst mkex2_unfold)
220.147 -apply (simp add: Consq_def If_and_if)
220.148 -apply (simp add: Consq_def)
220.149 -done
220.150 -
220.151 -declare mkex2_UU [simp] mkex2_nil [simp] mkex2_cons_1 [simp]
220.152 - mkex2_cons_2 [simp] mkex2_cons_3 [simp]
220.153 -
220.154 -
220.155 -subsection {* mkex *}
220.156 -
220.157 -lemma mkex_UU: "mkex A B UU (s,exA) (t,exB) = ((s,t),UU)"
220.158 -apply (simp add: mkex_def)
220.159 -done
220.160 -
220.161 -lemma mkex_nil: "mkex A B nil (s,exA) (t,exB) = ((s,t),nil)"
220.162 -apply (simp add: mkex_def)
220.163 -done
220.164 -
220.165 -lemma mkex_cons_1: "[| x:act A; x~:act B |]
220.166 - ==> mkex A B (x>>sch) (s,a>>exA) (t,exB) =
220.167 - ((s,t), (x,snd a,t) >> snd (mkex A B sch (snd a,exA) (t,exB)))"
220.168 -apply (simp (no_asm) add: mkex_def)
220.169 -apply (cut_tac exA = "a>>exA" in mkex2_cons_1)
220.170 -apply auto
220.171 -done
220.172 -
220.173 -lemma mkex_cons_2: "[| x~:act A; x:act B |]
220.174 - ==> mkex A B (x>>sch) (s,exA) (t,b>>exB) =
220.175 - ((s,t), (x,s,snd b) >> snd (mkex A B sch (s,exA) (snd b,exB)))"
220.176 -apply (simp (no_asm) add: mkex_def)
220.177 -apply (cut_tac exB = "b>>exB" in mkex2_cons_2)
220.178 -apply auto
220.179 -done
220.180 -
220.181 -lemma mkex_cons_3: "[| x:act A; x:act B |]
220.182 - ==> mkex A B (x>>sch) (s,a>>exA) (t,b>>exB) =
220.183 - ((s,t), (x,snd a,snd b) >> snd (mkex A B sch (snd a,exA) (snd b,exB)))"
220.184 -apply (simp (no_asm) add: mkex_def)
220.185 -apply (cut_tac exB = "b>>exB" and exA = "a>>exA" in mkex2_cons_3)
220.186 -apply auto
220.187 -done
220.188 -
220.189 -declare mkex2_UU [simp del] mkex2_nil [simp del]
220.190 - mkex2_cons_1 [simp del] mkex2_cons_2 [simp del] mkex2_cons_3 [simp del]
220.191 -
220.192 -lemmas composch_simps = mkex_UU mkex_nil mkex_cons_1 mkex_cons_2 mkex_cons_3
220.193 -
220.194 -declare composch_simps [simp]
220.195 -
220.196 -
220.197 -subsection {* COMPOSITIONALITY on SCHEDULE Level *}
220.198 -
220.199 -subsubsection "Lemmas for ==>"
220.200 -
220.201 -(* --------------------------------------------------------------------- *)
220.202 -(* Lemma_2_1 : tfilter(ex) and filter_act are commutative *)
220.203 -(* --------------------------------------------------------------------- *)
220.204 -
220.205 -lemma lemma_2_1a:
220.206 - "filter_act$(Filter_ex2 (asig_of A)$xs)=
220.207 - Filter (%a. a:act A)$(filter_act$xs)"
220.208 -
220.209 -apply (unfold filter_act_def Filter_ex2_def)
220.210 -apply (simp (no_asm) add: MapFilter o_def)
220.211 -done
220.212 -
220.213 -
220.214 -(* --------------------------------------------------------------------- *)
220.215 -(* Lemma_2_2 : State-projections do not affect filter_act *)
220.216 -(* --------------------------------------------------------------------- *)
220.217 -
220.218 -lemma lemma_2_1b:
220.219 - "filter_act$(ProjA2$xs) =filter_act$xs &
220.220 - filter_act$(ProjB2$xs) =filter_act$xs"
220.221 -apply (tactic {* pair_induct_tac @{context} "xs" [] 1 *})
220.222 -done
220.223 -
220.224 -
220.225 -(* --------------------------------------------------------------------- *)
220.226 -(* Schedules of A||B have only A- or B-actions *)
220.227 -(* --------------------------------------------------------------------- *)
220.228 -
220.229 -(* very similar to lemma_1_1c, but it is not checking if every action element of
220.230 - an ex is in A or B, but after projecting it onto the action schedule. Of course, this
220.231 - is the same proposition, but we cannot change this one, when then rather lemma_1_1c *)
220.232 -
220.233 -lemma sch_actions_in_AorB: "!s. is_exec_frag (A||B) (s,xs)
220.234 - --> Forall (%x. x:act (A||B)) (filter_act$xs)"
220.235 -
220.236 -apply (tactic {* pair_induct_tac @{context} "xs" [@{thm is_exec_frag_def}, @{thm Forall_def},
220.237 - @{thm sforall_def}] 1 *})
220.238 -(* main case *)
220.239 -apply auto
220.240 -apply (simp add: trans_of_defs2 actions_asig_comp asig_of_par)
220.241 -done
220.242 -
220.243 -
220.244 -subsubsection "Lemmas for <=="
220.245 -
220.246 -(*---------------------------------------------------------------------------
220.247 - Filtering actions out of mkex(sch,exA,exB) yields the oracle sch
220.248 - structural induction
220.249 - --------------------------------------------------------------------------- *)
220.250 -
220.251 -lemma Mapfst_mkex_is_sch: "! exA exB s t.
220.252 - Forall (%x. x:act (A||B)) sch &
220.253 - Filter (%a. a:act A)$sch << filter_act$exA &
220.254 - Filter (%a. a:act B)$sch << filter_act$exB
220.255 - --> filter_act$(snd (mkex A B sch (s,exA) (t,exB))) = sch"
220.256 -
220.257 -apply (tactic {* Seq_induct_tac @{context} "sch" [@{thm Filter_def}, @{thm Forall_def},
220.258 - @{thm sforall_def}, @{thm mkex_def}] 1 *})
220.259 -
220.260 -(* main case *)
220.261 -(* splitting into 4 cases according to a:A, a:B *)
220.262 -apply auto
220.263 -
220.264 -(* Case y:A, y:B *)
220.265 -apply (tactic {* Seq_case_simp_tac @{context} "exA" 1 *})
220.266 -(* Case exA=UU, Case exA=nil*)
220.267 -(* These UU and nil cases are the only places where the assumption filter A sch<<f_act exA
220.268 - is used! --> to generate a contradiction using ~a>>ss<< UU(nil), using theorems
220.269 - Cons_not_less_UU and Cons_not_less_nil *)
220.270 -apply (tactic {* Seq_case_simp_tac @{context} "exB" 1 *})
220.271 -(* Case exA=a>>x, exB=b>>y *)
220.272 -(* here it is important that Seq_case_simp_tac uses no !full!_simp_tac for the cons case,
220.273 - as otherwise mkex_cons_3 would not be rewritten without use of rotate_tac: then tactic
220.274 - would not be generally applicable *)
220.275 -apply simp
220.276 -
220.277 -(* Case y:A, y~:B *)
220.278 -apply (tactic {* Seq_case_simp_tac @{context} "exA" 1 *})
220.279 -apply simp
220.280 -
220.281 -(* Case y~:A, y:B *)
220.282 -apply (tactic {* Seq_case_simp_tac @{context} "exB" 1 *})
220.283 -apply simp
220.284 -
220.285 -(* Case y~:A, y~:B *)
220.286 -apply (simp add: asig_of_par actions_asig_comp)
220.287 -done
220.288 -
220.289 -
220.290 -(* generalizing the proof above to a tactic *)
220.291 -
220.292 -ML {*
220.293 -
220.294 -local
220.295 - val defs = [@{thm Filter_def}, @{thm Forall_def}, @{thm sforall_def}, @{thm mkex_def},
220.296 - @{thm stutter_def}]
220.297 - val asigs = [@{thm asig_of_par}, @{thm actions_asig_comp}]
220.298 -in
220.299 -
220.300 -fun mkex_induct_tac ctxt sch exA exB =
220.301 - let val ss = simpset_of ctxt in
220.302 - EVERY1[Seq_induct_tac ctxt sch defs,
220.303 - asm_full_simp_tac ss,
220.304 - SELECT_GOAL (safe_tac (global_claset_of @{theory Fun})),
220.305 - Seq_case_simp_tac ctxt exA,
220.306 - Seq_case_simp_tac ctxt exB,
220.307 - asm_full_simp_tac ss,
220.308 - Seq_case_simp_tac ctxt exA,
220.309 - asm_full_simp_tac ss,
220.310 - Seq_case_simp_tac ctxt exB,
220.311 - asm_full_simp_tac ss,
220.312 - asm_full_simp_tac (ss addsimps asigs)
220.313 - ]
220.314 - end
220.315 -
220.316 -end
220.317 -*}
220.318 -
220.319 -
220.320 -(*---------------------------------------------------------------------------
220.321 - Projection of mkex(sch,exA,exB) onto A stutters on A
220.322 - structural induction
220.323 - --------------------------------------------------------------------------- *)
220.324 -
220.325 -lemma stutterA_mkex: "! exA exB s t.
220.326 - Forall (%x. x:act (A||B)) sch &
220.327 - Filter (%a. a:act A)$sch << filter_act$exA &
220.328 - Filter (%a. a:act B)$sch << filter_act$exB
220.329 - --> stutter (asig_of A) (s,ProjA2$(snd (mkex A B sch (s,exA) (t,exB))))"
220.330 -
220.331 -apply (tactic {* mkex_induct_tac @{context} "sch" "exA" "exB" *})
220.332 -done
220.333 -
220.334 -
220.335 -lemma stutter_mkex_on_A: "[|
220.336 - Forall (%x. x:act (A||B)) sch ;
220.337 - Filter (%a. a:act A)$sch << filter_act$(snd exA) ;
220.338 - Filter (%a. a:act B)$sch << filter_act$(snd exB) |]
220.339 - ==> stutter (asig_of A) (ProjA (mkex A B sch exA exB))"
220.340 -
220.341 -apply (cut_tac stutterA_mkex)
220.342 -apply (simp add: stutter_def ProjA_def mkex_def)
220.343 -apply (erule allE)+
220.344 -apply (drule mp)
220.345 -prefer 2 apply (assumption)
220.346 -apply simp
220.347 -done
220.348 -
220.349 -
220.350 -(*---------------------------------------------------------------------------
220.351 - Projection of mkex(sch,exA,exB) onto B stutters on B
220.352 - structural induction
220.353 - --------------------------------------------------------------------------- *)
220.354 -
220.355 -lemma stutterB_mkex: "! exA exB s t.
220.356 - Forall (%x. x:act (A||B)) sch &
220.357 - Filter (%a. a:act A)$sch << filter_act$exA &
220.358 - Filter (%a. a:act B)$sch << filter_act$exB
220.359 - --> stutter (asig_of B) (t,ProjB2$(snd (mkex A B sch (s,exA) (t,exB))))"
220.360 -apply (tactic {* mkex_induct_tac @{context} "sch" "exA" "exB" *})
220.361 -done
220.362 -
220.363 -
220.364 -lemma stutter_mkex_on_B: "[|
220.365 - Forall (%x. x:act (A||B)) sch ;
220.366 - Filter (%a. a:act A)$sch << filter_act$(snd exA) ;
220.367 - Filter (%a. a:act B)$sch << filter_act$(snd exB) |]
220.368 - ==> stutter (asig_of B) (ProjB (mkex A B sch exA exB))"
220.369 -apply (cut_tac stutterB_mkex)
220.370 -apply (simp add: stutter_def ProjB_def mkex_def)
220.371 -apply (erule allE)+
220.372 -apply (drule mp)
220.373 -prefer 2 apply (assumption)
220.374 -apply simp
220.375 -done
220.376 -
220.377 -
220.378 -(*---------------------------------------------------------------------------
220.379 - Filter of mkex(sch,exA,exB) to A after projection onto A is exA
220.380 - -- using zip$(proj1$exA)$(proj2$exA) instead of exA --
220.381 - -- because of admissibility problems --
220.382 - structural induction
220.383 - --------------------------------------------------------------------------- *)
220.384 -
220.385 -lemma filter_mkex_is_exA_tmp: "! exA exB s t.
220.386 - Forall (%x. x:act (A||B)) sch &
220.387 - Filter (%a. a:act A)$sch << filter_act$exA &
220.388 - Filter (%a. a:act B)$sch << filter_act$exB
220.389 - --> Filter_ex2 (asig_of A)$(ProjA2$(snd (mkex A B sch (s,exA) (t,exB)))) =
220.390 - Zip$(Filter (%a. a:act A)$sch)$(Map snd$exA)"
220.391 -apply (tactic {* mkex_induct_tac @{context} "sch" "exB" "exA" *})
220.392 -done
220.393 -
220.394 -(*---------------------------------------------------------------------------
220.395 - zip$(proj1$y)$(proj2$y) = y (using the lift operations)
220.396 - lemma for admissibility problems
220.397 - --------------------------------------------------------------------------- *)
220.398 -
220.399 -lemma Zip_Map_fst_snd: "Zip$(Map fst$y)$(Map snd$y) = y"
220.400 -apply (tactic {* Seq_induct_tac @{context} "y" [] 1 *})
220.401 -done
220.402 -
220.403 -
220.404 -(*---------------------------------------------------------------------------
220.405 - filter A$sch = proj1$ex --> zip$(filter A$sch)$(proj2$ex) = ex
220.406 - lemma for eliminating non admissible equations in assumptions
220.407 - --------------------------------------------------------------------------- *)
220.408 -
220.409 -lemma trick_against_eq_in_ass: "!! sch ex.
220.410 - Filter (%a. a:act AB)$sch = filter_act$ex
220.411 - ==> ex = Zip$(Filter (%a. a:act AB)$sch)$(Map snd$ex)"
220.412 -apply (simp add: filter_act_def)
220.413 -apply (rule Zip_Map_fst_snd [symmetric])
220.414 -done
220.415 -
220.416 -(*---------------------------------------------------------------------------
220.417 - Filter of mkex(sch,exA,exB) to A after projection onto A is exA
220.418 - using the above trick
220.419 - --------------------------------------------------------------------------- *)
220.420 -
220.421 -
220.422 -lemma filter_mkex_is_exA: "!!sch exA exB.
220.423 - [| Forall (%a. a:act (A||B)) sch ;
220.424 - Filter (%a. a:act A)$sch = filter_act$(snd exA) ;
220.425 - Filter (%a. a:act B)$sch = filter_act$(snd exB) |]
220.426 - ==> Filter_ex (asig_of A) (ProjA (mkex A B sch exA exB)) = exA"
220.427 -apply (simp add: ProjA_def Filter_ex_def)
220.428 -apply (tactic {* pair_tac @{context} "exA" 1 *})
220.429 -apply (tactic {* pair_tac @{context} "exB" 1 *})
220.430 -apply (rule conjI)
220.431 -apply (simp (no_asm) add: mkex_def)
220.432 -apply (simplesubst trick_against_eq_in_ass)
220.433 -back
220.434 -apply assumption
220.435 -apply (simp add: filter_mkex_is_exA_tmp)
220.436 -done
220.437 -
220.438 -
220.439 -(*---------------------------------------------------------------------------
220.440 - Filter of mkex(sch,exA,exB) to B after projection onto B is exB
220.441 - -- using zip$(proj1$exB)$(proj2$exB) instead of exB --
220.442 - -- because of admissibility problems --
220.443 - structural induction
220.444 - --------------------------------------------------------------------------- *)
220.445 -
220.446 -lemma filter_mkex_is_exB_tmp: "! exA exB s t.
220.447 - Forall (%x. x:act (A||B)) sch &
220.448 - Filter (%a. a:act A)$sch << filter_act$exA &
220.449 - Filter (%a. a:act B)$sch << filter_act$exB
220.450 - --> Filter_ex2 (asig_of B)$(ProjB2$(snd (mkex A B sch (s,exA) (t,exB)))) =
220.451 - Zip$(Filter (%a. a:act B)$sch)$(Map snd$exB)"
220.452 -
220.453 -(* notice necessary change of arguments exA and exB *)
220.454 -apply (tactic {* mkex_induct_tac @{context} "sch" "exA" "exB" *})
220.455 -done
220.456 -
220.457 -
220.458 -(*---------------------------------------------------------------------------
220.459 - Filter of mkex(sch,exA,exB) to A after projection onto B is exB
220.460 - using the above trick
220.461 - --------------------------------------------------------------------------- *)
220.462 -
220.463 -
220.464 -lemma filter_mkex_is_exB: "!!sch exA exB.
220.465 - [| Forall (%a. a:act (A||B)) sch ;
220.466 - Filter (%a. a:act A)$sch = filter_act$(snd exA) ;
220.467 - Filter (%a. a:act B)$sch = filter_act$(snd exB) |]
220.468 - ==> Filter_ex (asig_of B) (ProjB (mkex A B sch exA exB)) = exB"
220.469 -apply (simp add: ProjB_def Filter_ex_def)
220.470 -apply (tactic {* pair_tac @{context} "exA" 1 *})
220.471 -apply (tactic {* pair_tac @{context} "exB" 1 *})
220.472 -apply (rule conjI)
220.473 -apply (simp (no_asm) add: mkex_def)
220.474 -apply (simplesubst trick_against_eq_in_ass)
220.475 -back
220.476 -apply assumption
220.477 -apply (simp add: filter_mkex_is_exB_tmp)
220.478 -done
220.479 -
220.480 -(* --------------------------------------------------------------------- *)
220.481 -(* mkex has only A- or B-actions *)
220.482 -(* --------------------------------------------------------------------- *)
220.483 -
220.484 -
220.485 -lemma mkex_actions_in_AorB: "!s t exA exB.
220.486 - Forall (%x. x : act (A || B)) sch &
220.487 - Filter (%a. a:act A)$sch << filter_act$exA &
220.488 - Filter (%a. a:act B)$sch << filter_act$exB
220.489 - --> Forall (%x. fst x : act (A ||B))
220.490 - (snd (mkex A B sch (s,exA) (t,exB)))"
220.491 -apply (tactic {* mkex_induct_tac @{context} "sch" "exA" "exB" *})
220.492 -done
220.493 -
220.494 -
220.495 -(* ------------------------------------------------------------------ *)
220.496 -(* COMPOSITIONALITY on SCHEDULE Level *)
220.497 -(* Main Theorem *)
220.498 -(* ------------------------------------------------------------------ *)
220.499 -
220.500 -lemma compositionality_sch:
220.501 -"(sch : schedules (A||B)) =
220.502 - (Filter (%a. a:act A)$sch : schedules A &
220.503 - Filter (%a. a:act B)$sch : schedules B &
220.504 - Forall (%x. x:act (A||B)) sch)"
220.505 -apply (simp (no_asm) add: schedules_def has_schedule_def)
220.506 -apply auto
220.507 -(* ==> *)
220.508 -apply (rule_tac x = "Filter_ex (asig_of A) (ProjA ex) " in bexI)
220.509 -prefer 2
220.510 -apply (simp add: compositionality_ex)
220.511 -apply (simp (no_asm) add: Filter_ex_def ProjA_def lemma_2_1a lemma_2_1b)
220.512 -apply (rule_tac x = "Filter_ex (asig_of B) (ProjB ex) " in bexI)
220.513 -prefer 2
220.514 -apply (simp add: compositionality_ex)
220.515 -apply (simp (no_asm) add: Filter_ex_def ProjB_def lemma_2_1a lemma_2_1b)
220.516 -apply (simp add: executions_def)
220.517 -apply (tactic {* pair_tac @{context} "ex" 1 *})
220.518 -apply (erule conjE)
220.519 -apply (simp add: sch_actions_in_AorB)
220.520 -
220.521 -(* <== *)
220.522 -
220.523 -(* mkex is exactly the construction of exA||B out of exA, exB, and the oracle sch,
220.524 - we need here *)
220.525 -apply (rename_tac exA exB)
220.526 -apply (rule_tac x = "mkex A B sch exA exB" in bexI)
220.527 -(* mkex actions are just the oracle *)
220.528 -apply (tactic {* pair_tac @{context} "exA" 1 *})
220.529 -apply (tactic {* pair_tac @{context} "exB" 1 *})
220.530 -apply (simp add: Mapfst_mkex_is_sch)
220.531 -
220.532 -(* mkex is an execution -- use compositionality on ex-level *)
220.533 -apply (simp add: compositionality_ex)
220.534 -apply (simp add: stutter_mkex_on_A stutter_mkex_on_B filter_mkex_is_exB filter_mkex_is_exA)
220.535 -apply (tactic {* pair_tac @{context} "exA" 1 *})
220.536 -apply (tactic {* pair_tac @{context} "exB" 1 *})
220.537 -apply (simp add: mkex_actions_in_AorB)
220.538 -done
220.539 -
220.540 -
220.541 -subsection {* COMPOSITIONALITY on SCHEDULE Level -- for Modules *}
220.542 -
220.543 -lemma compositionality_sch_modules:
220.544 - "Scheds (A||B) = par_scheds (Scheds A) (Scheds B)"
220.545 -
220.546 -apply (unfold Scheds_def par_scheds_def)
220.547 -apply (simp add: asig_of_par)
220.548 -apply (rule set_eqI)
220.549 -apply (simp add: compositionality_sch actions_of_par)
220.550 -done
220.551 -
220.552 -
220.553 -declare compoex_simps [simp del]
220.554 -declare composch_simps [simp del]
220.555 -
220.556 -end
221.1 --- a/src/HOLCF/IOA/meta_theory/CompoTraces.thy Sat Nov 27 14:34:54 2010 -0800
221.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
221.3 @@ -1,973 +0,0 @@
221.4 -(* Title: HOLCF/IOA/meta_theory/CompoTraces.thy
221.5 - Author: Olaf Müller
221.6 -*)
221.7 -
221.8 -header {* Compositionality on Trace level *}
221.9 -
221.10 -theory CompoTraces
221.11 -imports CompoScheds ShortExecutions
221.12 -begin
221.13 -
221.14 -
221.15 -consts
221.16 -
221.17 - mksch ::"('a,'s)ioa => ('a,'t)ioa => 'a Seq -> 'a Seq -> 'a Seq -> 'a Seq"
221.18 - par_traces ::"['a trace_module,'a trace_module] => 'a trace_module"
221.19 -
221.20 -defs
221.21 -
221.22 -mksch_def:
221.23 - "mksch A B == (fix$(LAM h tr schA schB. case tr of
221.24 - nil => nil
221.25 - | x##xs =>
221.26 - (case x of
221.27 - UU => UU
221.28 - | Def y =>
221.29 - (if y:act A then
221.30 - (if y:act B then
221.31 - ((Takewhile (%a. a:int A)$schA)
221.32 - @@ (Takewhile (%a. a:int B)$schB)
221.33 - @@ (y>>(h$xs
221.34 - $(TL$(Dropwhile (%a. a:int A)$schA))
221.35 - $(TL$(Dropwhile (%a. a:int B)$schB))
221.36 - )))
221.37 - else
221.38 - ((Takewhile (%a. a:int A)$schA)
221.39 - @@ (y>>(h$xs
221.40 - $(TL$(Dropwhile (%a. a:int A)$schA))
221.41 - $schB)))
221.42 - )
221.43 - else
221.44 - (if y:act B then
221.45 - ((Takewhile (%a. a:int B)$schB)
221.46 - @@ (y>>(h$xs
221.47 - $schA
221.48 - $(TL$(Dropwhile (%a. a:int B)$schB))
221.49 - )))
221.50 - else
221.51 - UU
221.52 - )
221.53 - )
221.54 - )))"
221.55 -
221.56 -
221.57 -par_traces_def:
221.58 - "par_traces TracesA TracesB ==
221.59 - let trA = fst TracesA; sigA = snd TracesA;
221.60 - trB = fst TracesB; sigB = snd TracesB
221.61 - in
221.62 - ( {tr. Filter (%a. a:actions sigA)$tr : trA}
221.63 - Int {tr. Filter (%a. a:actions sigB)$tr : trB}
221.64 - Int {tr. Forall (%x. x:(externals sigA Un externals sigB)) tr},
221.65 - asig_comp sigA sigB)"
221.66 -
221.67 -axioms
221.68 -
221.69 -finiteR_mksch:
221.70 - "Finite (mksch A B$tr$x$y) --> Finite tr"
221.71 -
221.72 -
221.73 -declaration {* fn _ => Simplifier.map_ss (fn ss => ss setmksym (K (K NONE))) *}
221.74 -
221.75 -
221.76 -subsection "mksch rewrite rules"
221.77 -
221.78 -lemma mksch_unfold:
221.79 -"mksch A B = (LAM tr schA schB. case tr of
221.80 - nil => nil
221.81 - | x##xs =>
221.82 - (case x of
221.83 - UU => UU
221.84 - | Def y =>
221.85 - (if y:act A then
221.86 - (if y:act B then
221.87 - ((Takewhile (%a. a:int A)$schA)
221.88 - @@(Takewhile (%a. a:int B)$schB)
221.89 - @@(y>>(mksch A B$xs
221.90 - $(TL$(Dropwhile (%a. a:int A)$schA))
221.91 - $(TL$(Dropwhile (%a. a:int B)$schB))
221.92 - )))
221.93 - else
221.94 - ((Takewhile (%a. a:int A)$schA)
221.95 - @@ (y>>(mksch A B$xs
221.96 - $(TL$(Dropwhile (%a. a:int A)$schA))
221.97 - $schB)))
221.98 - )
221.99 - else
221.100 - (if y:act B then
221.101 - ((Takewhile (%a. a:int B)$schB)
221.102 - @@ (y>>(mksch A B$xs
221.103 - $schA
221.104 - $(TL$(Dropwhile (%a. a:int B)$schB))
221.105 - )))
221.106 - else
221.107 - UU
221.108 - )
221.109 - )
221.110 - ))"
221.111 -apply (rule trans)
221.112 -apply (rule fix_eq2)
221.113 -apply (rule mksch_def)
221.114 -apply (rule beta_cfun)
221.115 -apply simp
221.116 -done
221.117 -
221.118 -lemma mksch_UU: "mksch A B$UU$schA$schB = UU"
221.119 -apply (subst mksch_unfold)
221.120 -apply simp
221.121 -done
221.122 -
221.123 -lemma mksch_nil: "mksch A B$nil$schA$schB = nil"
221.124 -apply (subst mksch_unfold)
221.125 -apply simp
221.126 -done
221.127 -
221.128 -lemma mksch_cons1: "[|x:act A;x~:act B|]
221.129 - ==> mksch A B$(x>>tr)$schA$schB =
221.130 - (Takewhile (%a. a:int A)$schA)
221.131 - @@ (x>>(mksch A B$tr$(TL$(Dropwhile (%a. a:int A)$schA))
221.132 - $schB))"
221.133 -apply (rule trans)
221.134 -apply (subst mksch_unfold)
221.135 -apply (simp add: Consq_def If_and_if)
221.136 -apply (simp add: Consq_def)
221.137 -done
221.138 -
221.139 -lemma mksch_cons2: "[|x~:act A;x:act B|]
221.140 - ==> mksch A B$(x>>tr)$schA$schB =
221.141 - (Takewhile (%a. a:int B)$schB)
221.142 - @@ (x>>(mksch A B$tr$schA$(TL$(Dropwhile (%a. a:int B)$schB))
221.143 - ))"
221.144 -apply (rule trans)
221.145 -apply (subst mksch_unfold)
221.146 -apply (simp add: Consq_def If_and_if)
221.147 -apply (simp add: Consq_def)
221.148 -done
221.149 -
221.150 -lemma mksch_cons3: "[|x:act A;x:act B|]
221.151 - ==> mksch A B$(x>>tr)$schA$schB =
221.152 - (Takewhile (%a. a:int A)$schA)
221.153 - @@ ((Takewhile (%a. a:int B)$schB)
221.154 - @@ (x>>(mksch A B$tr$(TL$(Dropwhile (%a. a:int A)$schA))
221.155 - $(TL$(Dropwhile (%a. a:int B)$schB))))
221.156 - )"
221.157 -apply (rule trans)
221.158 -apply (subst mksch_unfold)
221.159 -apply (simp add: Consq_def If_and_if)
221.160 -apply (simp add: Consq_def)
221.161 -done
221.162 -
221.163 -lemmas compotr_simps = mksch_UU mksch_nil mksch_cons1 mksch_cons2 mksch_cons3
221.164 -
221.165 -declare compotr_simps [simp]
221.166 -
221.167 -
221.168 -subsection {* COMPOSITIONALITY on TRACE Level *}
221.169 -
221.170 -subsubsection "Lemmata for ==>"
221.171 -
221.172 -(* Consequence out of ext1_ext2_is_not_act1(2), which in turn are consequences out of
221.173 - the compatibility of IOA, in particular out of the condition that internals are
221.174 - really hidden. *)
221.175 -
221.176 -lemma compatibility_consequence1: "(eB & ~eA --> ~A) -->
221.177 - (A & (eA | eB)) = (eA & A)"
221.178 -apply fast
221.179 -done
221.180 -
221.181 -
221.182 -(* very similar to above, only the commutativity of | is used to make a slight change *)
221.183 -
221.184 -lemma compatibility_consequence2: "(eB & ~eA --> ~A) -->
221.185 - (A & (eB | eA)) = (eA & A)"
221.186 -apply fast
221.187 -done
221.188 -
221.189 -
221.190 -subsubsection "Lemmata for <=="
221.191 -
221.192 -(* Lemma for substitution of looping assumption in another specific assumption *)
221.193 -lemma subst_lemma1: "[| f << (g x) ; x=(h x) |] ==> f << g (h x)"
221.194 -by (erule subst)
221.195 -
221.196 -(* Lemma for substitution of looping assumption in another specific assumption *)
221.197 -lemma subst_lemma2: "[| (f x) = y >> g; x=(h x) |] ==> (f (h x)) = y >> g"
221.198 -by (erule subst)
221.199 -
221.200 -lemma ForallAorB_mksch [rule_format]:
221.201 - "!!A B. compatible A B ==>
221.202 - ! schA schB. Forall (%x. x:act (A||B)) tr
221.203 - --> Forall (%x. x:act (A||B)) (mksch A B$tr$schA$schB)"
221.204 -apply (tactic {* Seq_induct_tac @{context} "tr"
221.205 - [@{thm Forall_def}, @{thm sforall_def}, @{thm mksch_def}] 1 *})
221.206 -apply auto
221.207 -apply (simp add: actions_of_par)
221.208 -apply (case_tac "a:act A")
221.209 -apply (case_tac "a:act B")
221.210 -(* a:A, a:B *)
221.211 -apply simp
221.212 -apply (rule Forall_Conc_impl [THEN mp])
221.213 -apply (simp add: intA_is_not_actB int_is_act)
221.214 -apply (rule Forall_Conc_impl [THEN mp])
221.215 -apply (simp add: intA_is_not_actB int_is_act)
221.216 -(* a:A,a~:B *)
221.217 -apply simp
221.218 -apply (rule Forall_Conc_impl [THEN mp])
221.219 -apply (simp add: intA_is_not_actB int_is_act)
221.220 -apply (case_tac "a:act B")
221.221 -(* a~:A, a:B *)
221.222 -apply simp
221.223 -apply (rule Forall_Conc_impl [THEN mp])
221.224 -apply (simp add: intA_is_not_actB int_is_act)
221.225 -(* a~:A,a~:B *)
221.226 -apply auto
221.227 -done
221.228 -
221.229 -lemma ForallBnAmksch [rule_format (no_asm)]: "!!A B. compatible B A ==>
221.230 - ! schA schB. (Forall (%x. x:act B & x~:act A) tr
221.231 - --> Forall (%x. x:act B & x~:act A) (mksch A B$tr$schA$schB))"
221.232 -apply (tactic {* Seq_induct_tac @{context} "tr"
221.233 - [@{thm Forall_def}, @{thm sforall_def}, @{thm mksch_def}] 1 *})
221.234 -apply auto
221.235 -apply (rule Forall_Conc_impl [THEN mp])
221.236 -apply (simp add: intA_is_not_actB int_is_act)
221.237 -done
221.238 -
221.239 -lemma ForallAnBmksch [rule_format (no_asm)]: "!!A B. compatible A B ==>
221.240 - ! schA schB. (Forall (%x. x:act A & x~:act B) tr
221.241 - --> Forall (%x. x:act A & x~:act B) (mksch A B$tr$schA$schB))"
221.242 -apply (tactic {* Seq_induct_tac @{context} "tr"
221.243 - [@{thm Forall_def}, @{thm sforall_def}, @{thm mksch_def}] 1 *})
221.244 -apply auto
221.245 -apply (rule Forall_Conc_impl [THEN mp])
221.246 -apply (simp add: intA_is_not_actB int_is_act)
221.247 -done
221.248 -
221.249 -(* safe-tac makes too many case distinctions with this lemma in the next proof *)
221.250 -declare FiniteConc [simp del]
221.251 -
221.252 -lemma FiniteL_mksch [rule_format (no_asm)]: "[| Finite tr; is_asig(asig_of A); is_asig(asig_of B) |] ==>
221.253 - ! x y. Forall (%x. x:act A) x & Forall (%x. x:act B) y &
221.254 - Filter (%a. a:ext A)$x = Filter (%a. a:act A)$tr &
221.255 - Filter (%a. a:ext B)$y = Filter (%a. a:act B)$tr &
221.256 - Forall (%x. x:ext (A||B)) tr
221.257 - --> Finite (mksch A B$tr$x$y)"
221.258 -
221.259 -apply (erule Seq_Finite_ind)
221.260 -apply simp
221.261 -(* main case *)
221.262 -apply simp
221.263 -apply auto
221.264 -
221.265 -(* a: act A; a: act B *)
221.266 -apply (frule sym [THEN eq_imp_below, THEN divide_Seq])
221.267 -apply (frule sym [THEN eq_imp_below, THEN divide_Seq])
221.268 -back
221.269 -apply (erule conjE)+
221.270 -(* Finite (tw iA x) and Finite (tw iB y) *)
221.271 -apply (simp add: not_ext_is_int_or_not_act FiniteConc)
221.272 -(* now for conclusion IH applicable, but assumptions have to be transformed *)
221.273 -apply (drule_tac x = "x" and g = "Filter (%a. a:act A) $s" in subst_lemma2)
221.274 -apply assumption
221.275 -apply (drule_tac x = "y" and g = "Filter (%a. a:act B) $s" in subst_lemma2)
221.276 -apply assumption
221.277 -(* IH *)
221.278 -apply (simp add: not_ext_is_int_or_not_act ForallTL ForallDropwhile)
221.279 -
221.280 -(* a: act B; a~: act A *)
221.281 -apply (frule sym [THEN eq_imp_below, THEN divide_Seq])
221.282 -
221.283 -apply (erule conjE)+
221.284 -(* Finite (tw iB y) *)
221.285 -apply (simp add: not_ext_is_int_or_not_act FiniteConc)
221.286 -(* now for conclusion IH applicable, but assumptions have to be transformed *)
221.287 -apply (drule_tac x = "y" and g = "Filter (%a. a:act B) $s" in subst_lemma2)
221.288 -apply assumption
221.289 -(* IH *)
221.290 -apply (simp add: not_ext_is_int_or_not_act ForallTL ForallDropwhile)
221.291 -
221.292 -(* a~: act B; a: act A *)
221.293 -apply (frule sym [THEN eq_imp_below, THEN divide_Seq])
221.294 -
221.295 -apply (erule conjE)+
221.296 -(* Finite (tw iA x) *)
221.297 -apply (simp add: not_ext_is_int_or_not_act FiniteConc)
221.298 -(* now for conclusion IH applicable, but assumptions have to be transformed *)
221.299 -apply (drule_tac x = "x" and g = "Filter (%a. a:act A) $s" in subst_lemma2)
221.300 -apply assumption
221.301 -(* IH *)
221.302 -apply (simp add: not_ext_is_int_or_not_act ForallTL ForallDropwhile)
221.303 -
221.304 -(* a~: act B; a~: act A *)
221.305 -apply (fastsimp intro!: ext_is_act simp: externals_of_par)
221.306 -done
221.307 -
221.308 -declare FiniteConc [simp]
221.309 -
221.310 -declare FilterConc [simp del]
221.311 -
221.312 -lemma reduceA_mksch1 [rule_format (no_asm)]: " [| Finite bs; is_asig(asig_of A); is_asig(asig_of B);compatible A B|] ==>
221.313 - ! y. Forall (%x. x:act B) y & Forall (%x. x:act B & x~:act A) bs &
221.314 - Filter (%a. a:ext B)$y = Filter (%a. a:act B)$(bs @@ z)
221.315 - --> (? y1 y2. (mksch A B$(bs @@ z)$x$y) = (y1 @@ (mksch A B$z$x$y2)) &
221.316 - Forall (%x. x:act B & x~:act A) y1 &
221.317 - Finite y1 & y = (y1 @@ y2) &
221.318 - Filter (%a. a:ext B)$y1 = bs)"
221.319 -apply (frule_tac A1 = "A" in compat_commute [THEN iffD1])
221.320 -apply (erule Seq_Finite_ind)
221.321 -apply (rule allI)+
221.322 -apply (rule impI)
221.323 -apply (rule_tac x = "nil" in exI)
221.324 -apply (rule_tac x = "y" in exI)
221.325 -apply simp
221.326 -(* main case *)
221.327 -apply (rule allI)+
221.328 -apply (rule impI)
221.329 -apply simp
221.330 -apply (erule conjE)+
221.331 -apply simp
221.332 -(* divide_Seq on s *)
221.333 -apply (frule sym [THEN eq_imp_below, THEN divide_Seq])
221.334 -apply (erule conjE)+
221.335 -(* transform assumption f eB y = f B (s@z) *)
221.336 -apply (drule_tac x = "y" and g = "Filter (%a. a:act B) $ (s@@z) " in subst_lemma2)
221.337 -apply assumption
221.338 -apply (simp add: not_ext_is_int_or_not_act FilterConc)
221.339 -(* apply IH *)
221.340 -apply (erule_tac x = "TL$ (Dropwhile (%a. a:int B) $y) " in allE)
221.341 -apply (simp add: ForallTL ForallDropwhile FilterConc)
221.342 -apply (erule exE)+
221.343 -apply (erule conjE)+
221.344 -apply (simp add: FilterConc)
221.345 -(* for replacing IH in conclusion *)
221.346 -apply (rotate_tac -2)
221.347 -(* instantiate y1a and y2a *)
221.348 -apply (rule_tac x = "Takewhile (%a. a:int B) $y @@ a>>y1" in exI)
221.349 -apply (rule_tac x = "y2" in exI)
221.350 -(* elminate all obligations up to two depending on Conc_assoc *)
221.351 -apply (simp add: intA_is_not_actB int_is_act int_is_not_ext FilterConc)
221.352 -apply (simp (no_asm) add: Conc_assoc FilterConc)
221.353 -done
221.354 -
221.355 -lemmas reduceA_mksch = conjI [THEN [6] conjI [THEN [5] reduceA_mksch1]]
221.356 -
221.357 -lemma reduceB_mksch1 [rule_format]:
221.358 -" [| Finite a_s; is_asig(asig_of A); is_asig(asig_of B);compatible A B|] ==>
221.359 - ! x. Forall (%x. x:act A) x & Forall (%x. x:act A & x~:act B) a_s &
221.360 - Filter (%a. a:ext A)$x = Filter (%a. a:act A)$(a_s @@ z)
221.361 - --> (? x1 x2. (mksch A B$(a_s @@ z)$x$y) = (x1 @@ (mksch A B$z$x2$y)) &
221.362 - Forall (%x. x:act A & x~:act B) x1 &
221.363 - Finite x1 & x = (x1 @@ x2) &
221.364 - Filter (%a. a:ext A)$x1 = a_s)"
221.365 -apply (frule_tac A1 = "A" in compat_commute [THEN iffD1])
221.366 -apply (erule Seq_Finite_ind)
221.367 -apply (rule allI)+
221.368 -apply (rule impI)
221.369 -apply (rule_tac x = "nil" in exI)
221.370 -apply (rule_tac x = "x" in exI)
221.371 -apply simp
221.372 -(* main case *)
221.373 -apply (rule allI)+
221.374 -apply (rule impI)
221.375 -apply simp
221.376 -apply (erule conjE)+
221.377 -apply simp
221.378 -(* divide_Seq on s *)
221.379 -apply (frule sym [THEN eq_imp_below, THEN divide_Seq])
221.380 -apply (erule conjE)+
221.381 -(* transform assumption f eA x = f A (s@z) *)
221.382 -apply (drule_tac x = "x" and g = "Filter (%a. a:act A) $ (s@@z) " in subst_lemma2)
221.383 -apply assumption
221.384 -apply (simp add: not_ext_is_int_or_not_act FilterConc)
221.385 -(* apply IH *)
221.386 -apply (erule_tac x = "TL$ (Dropwhile (%a. a:int A) $x) " in allE)
221.387 -apply (simp add: ForallTL ForallDropwhile FilterConc)
221.388 -apply (erule exE)+
221.389 -apply (erule conjE)+
221.390 -apply (simp add: FilterConc)
221.391 -(* for replacing IH in conclusion *)
221.392 -apply (rotate_tac -2)
221.393 -(* instantiate y1a and y2a *)
221.394 -apply (rule_tac x = "Takewhile (%a. a:int A) $x @@ a>>x1" in exI)
221.395 -apply (rule_tac x = "x2" in exI)
221.396 -(* elminate all obligations up to two depending on Conc_assoc *)
221.397 -apply (simp add: intA_is_not_actB int_is_act int_is_not_ext FilterConc)
221.398 -apply (simp (no_asm) add: Conc_assoc FilterConc)
221.399 -done
221.400 -
221.401 -lemmas reduceB_mksch = conjI [THEN [6] conjI [THEN [5] reduceB_mksch1]]
221.402 -
221.403 -declare FilterConc [simp]
221.404 -
221.405 -
221.406 -subsection "Filtering external actions out of mksch(tr,schA,schB) yields the oracle tr"
221.407 -
221.408 -lemma FilterA_mksch_is_tr:
221.409 -"!! A B. [| compatible A B; compatible B A;
221.410 - is_asig(asig_of A); is_asig(asig_of B) |] ==>
221.411 - ! schA schB. Forall (%x. x:act A) schA & Forall (%x. x:act B) schB &
221.412 - Forall (%x. x:ext (A||B)) tr &
221.413 - Filter (%a. a:act A)$tr << Filter (%a. a:ext A)$schA &
221.414 - Filter (%a. a:act B)$tr << Filter (%a. a:ext B)$schB
221.415 - --> Filter (%a. a:ext (A||B))$(mksch A B$tr$schA$schB) = tr"
221.416 -
221.417 -apply (tactic {* Seq_induct_tac @{context} "tr"
221.418 - [@{thm Forall_def}, @{thm sforall_def}, @{thm mksch_def}] 1 *})
221.419 -(* main case *)
221.420 -(* splitting into 4 cases according to a:A, a:B *)
221.421 -apply auto
221.422 -
221.423 -(* Case a:A, a:B *)
221.424 -apply (frule divide_Seq)
221.425 -apply (frule divide_Seq)
221.426 -back
221.427 -apply (erule conjE)+
221.428 -(* filtering internals of A in schA and of B in schB is nil *)
221.429 -apply (simp add: not_ext_is_int_or_not_act externals_of_par intA_is_not_extB int_is_not_ext)
221.430 -(* conclusion of IH ok, but assumptions of IH have to be transformed *)
221.431 -apply (drule_tac x = "schA" in subst_lemma1)
221.432 -apply assumption
221.433 -apply (drule_tac x = "schB" in subst_lemma1)
221.434 -apply assumption
221.435 -(* IH *)
221.436 -apply (simp add: not_ext_is_int_or_not_act ForallTL ForallDropwhile)
221.437 -
221.438 -(* Case a:A, a~:B *)
221.439 -apply (frule divide_Seq)
221.440 -apply (erule conjE)+
221.441 -(* filtering internals of A is nil *)
221.442 -apply (simp add: not_ext_is_int_or_not_act externals_of_par intA_is_not_extB int_is_not_ext)
221.443 -apply (drule_tac x = "schA" in subst_lemma1)
221.444 -apply assumption
221.445 -apply (simp add: not_ext_is_int_or_not_act ForallTL ForallDropwhile)
221.446 -
221.447 -(* Case a:B, a~:A *)
221.448 -apply (frule divide_Seq)
221.449 -apply (erule conjE)+
221.450 -(* filtering internals of A is nil *)
221.451 -apply (simp add: not_ext_is_int_or_not_act externals_of_par intA_is_not_extB int_is_not_ext)
221.452 -apply (drule_tac x = "schB" in subst_lemma1)
221.453 -back
221.454 -apply assumption
221.455 -apply (simp add: not_ext_is_int_or_not_act ForallTL ForallDropwhile)
221.456 -
221.457 -(* Case a~:A, a~:B *)
221.458 -apply (fastsimp intro!: ext_is_act simp: externals_of_par)
221.459 -done
221.460 -
221.461 -
221.462 -subsection" Filter of mksch(tr,schA,schB) to A is schA -- take lemma proof"
221.463 -
221.464 -lemma FilterAmksch_is_schA: "!! A B. [| compatible A B; compatible B A;
221.465 - is_asig(asig_of A); is_asig(asig_of B) |] ==>
221.466 - Forall (%x. x:ext (A||B)) tr &
221.467 - Forall (%x. x:act A) schA & Forall (%x. x:act B) schB &
221.468 - Filter (%a. a:ext A)$schA = Filter (%a. a:act A)$tr &
221.469 - Filter (%a. a:ext B)$schB = Filter (%a. a:act B)$tr &
221.470 - LastActExtsch A schA & LastActExtsch B schB
221.471 - --> Filter (%a. a:act A)$(mksch A B$tr$schA$schB) = schA"
221.472 -apply (intro strip)
221.473 -apply (rule seq.take_lemma)
221.474 -apply (rule mp)
221.475 -prefer 2 apply assumption
221.476 -back back back back
221.477 -apply (rule_tac x = "schA" in spec)
221.478 -apply (rule_tac x = "schB" in spec)
221.479 -apply (rule_tac x = "tr" in spec)
221.480 -apply (tactic "thin_tac' 5 1")
221.481 -apply (rule nat_less_induct)
221.482 -apply (rule allI)+
221.483 -apply (rename_tac tr schB schA)
221.484 -apply (intro strip)
221.485 -apply (erule conjE)+
221.486 -
221.487 -apply (case_tac "Forall (%x. x:act B & x~:act A) tr")
221.488 -
221.489 -apply (rule seq_take_lemma [THEN iffD2, THEN spec])
221.490 -apply (tactic "thin_tac' 5 1")
221.491 -
221.492 -
221.493 -apply (case_tac "Finite tr")
221.494 -
221.495 -(* both sides of this equation are nil *)
221.496 -apply (subgoal_tac "schA=nil")
221.497 -apply (simp (no_asm_simp))
221.498 -(* first side: mksch = nil *)
221.499 -apply (auto intro!: ForallQFilterPnil ForallBnAmksch FiniteL_mksch)[1]
221.500 -(* second side: schA = nil *)
221.501 -apply (erule_tac A = "A" in LastActExtimplnil)
221.502 -apply (simp (no_asm_simp))
221.503 -apply (erule_tac Q = "%x. x:act B & x~:act A" in ForallQFilterPnil)
221.504 -apply assumption
221.505 -apply fast
221.506 -
221.507 -(* case ~ Finite s *)
221.508 -
221.509 -(* both sides of this equation are UU *)
221.510 -apply (subgoal_tac "schA=UU")
221.511 -apply (simp (no_asm_simp))
221.512 -(* first side: mksch = UU *)
221.513 -apply (auto intro!: ForallQFilterPUU finiteR_mksch [THEN mp, COMP rev_contrapos] ForallBnAmksch)[1]
221.514 -(* schA = UU *)
221.515 -apply (erule_tac A = "A" in LastActExtimplUU)
221.516 -apply (simp (no_asm_simp))
221.517 -apply (erule_tac Q = "%x. x:act B & x~:act A" in ForallQFilterPUU)
221.518 -apply assumption
221.519 -apply fast
221.520 -
221.521 -(* case" ~ Forall (%x.x:act B & x~:act A) s" *)
221.522 -
221.523 -apply (drule divide_Seq3)
221.524 -
221.525 -apply (erule exE)+
221.526 -apply (erule conjE)+
221.527 -apply hypsubst
221.528 -
221.529 -(* bring in lemma reduceA_mksch *)
221.530 -apply (frule_tac x = "schA" and y = "schB" and A = "A" and B = "B" in reduceA_mksch)
221.531 -apply assumption+
221.532 -apply (erule exE)+
221.533 -apply (erule conjE)+
221.534 -
221.535 -(* use reduceA_mksch to rewrite conclusion *)
221.536 -apply hypsubst
221.537 -apply simp
221.538 -
221.539 -(* eliminate the B-only prefix *)
221.540 -
221.541 -apply (subgoal_tac " (Filter (%a. a :act A) $y1) = nil")
221.542 -apply (erule_tac [2] ForallQFilterPnil)
221.543 -prefer 2 apply assumption
221.544 -prefer 2 apply fast
221.545 -
221.546 -(* Now real recursive step follows (in y) *)
221.547 -
221.548 -apply simp
221.549 -apply (case_tac "x:act A")
221.550 -apply (case_tac "x~:act B")
221.551 -apply (rotate_tac -2)
221.552 -apply simp
221.553 -
221.554 -apply (subgoal_tac "Filter (%a. a:act A & a:ext B) $y1=nil")
221.555 -apply (rotate_tac -1)
221.556 -apply simp
221.557 -(* eliminate introduced subgoal 2 *)
221.558 -apply (erule_tac [2] ForallQFilterPnil)
221.559 -prefer 2 apply assumption
221.560 -prefer 2 apply fast
221.561 -
221.562 -(* bring in divide Seq for s *)
221.563 -apply (frule sym [THEN eq_imp_below, THEN divide_Seq])
221.564 -apply (erule conjE)+
221.565 -
221.566 -(* subst divide_Seq in conclusion, but only at the righest occurence *)
221.567 -apply (rule_tac t = "schA" in ssubst)
221.568 -back
221.569 -back
221.570 -back
221.571 -apply assumption
221.572 -
221.573 -(* reduce trace_takes from n to strictly smaller k *)
221.574 -apply (rule take_reduction)
221.575 -
221.576 -(* f A (tw iA) = tw ~eA *)
221.577 -apply (simp add: int_is_act not_ext_is_int_or_not_act)
221.578 -apply (rule refl)
221.579 -apply (simp add: int_is_act not_ext_is_int_or_not_act)
221.580 -apply (rotate_tac -11)
221.581 -
221.582 -(* now conclusion fulfills induction hypothesis, but assumptions are not ready *)
221.583 -
221.584 -(* assumption Forall tr *)
221.585 -(* assumption schB *)
221.586 -apply (simp add: ext_and_act)
221.587 -(* assumption schA *)
221.588 -apply (drule_tac x = "schA" and g = "Filter (%a. a:act A) $rs" in subst_lemma2)
221.589 -apply assumption
221.590 -apply (simp add: int_is_not_ext)
221.591 -(* assumptions concerning LastActExtsch, cannot be rewritten, as LastActExtsmalli are looping *)
221.592 -apply (drule_tac sch = "schA" and P = "%a. a:int A" in LastActExtsmall1)
221.593 -apply (frule_tac ?sch1.0 = "y1" in LastActExtsmall2)
221.594 -apply assumption
221.595 -
221.596 -(* assumption Forall schA *)
221.597 -apply (drule_tac s = "schA" and P = "Forall (%x. x:act A) " in subst)
221.598 -apply assumption
221.599 -apply (simp add: int_is_act)
221.600 -
221.601 -(* case x:actions(asig_of A) & x: actions(asig_of B) *)
221.602 -
221.603 -
221.604 -apply (rotate_tac -2)
221.605 -apply simp
221.606 -
221.607 -apply (subgoal_tac "Filter (%a. a:act A & a:ext B) $y1=nil")
221.608 -apply (rotate_tac -1)
221.609 -apply simp
221.610 -(* eliminate introduced subgoal 2 *)
221.611 -apply (erule_tac [2] ForallQFilterPnil)
221.612 -prefer 2 apply (assumption)
221.613 -prefer 2 apply (fast)
221.614 -
221.615 -(* bring in divide Seq for s *)
221.616 -apply (frule sym [THEN eq_imp_below, THEN divide_Seq])
221.617 -apply (erule conjE)+
221.618 -
221.619 -(* subst divide_Seq in conclusion, but only at the righest occurence *)
221.620 -apply (rule_tac t = "schA" in ssubst)
221.621 -back
221.622 -back
221.623 -back
221.624 -apply assumption
221.625 -
221.626 -(* f A (tw iA) = tw ~eA *)
221.627 -apply (simp add: int_is_act not_ext_is_int_or_not_act)
221.628 -
221.629 -(* rewrite assumption forall and schB *)
221.630 -apply (rotate_tac 13)
221.631 -apply (simp add: ext_and_act)
221.632 -
221.633 -(* divide_Seq for schB2 *)
221.634 -apply (frule_tac y = "y2" in sym [THEN eq_imp_below, THEN divide_Seq])
221.635 -apply (erule conjE)+
221.636 -(* assumption schA *)
221.637 -apply (drule_tac x = "schA" and g = "Filter (%a. a:act A) $rs" in subst_lemma2)
221.638 -apply assumption
221.639 -apply (simp add: int_is_not_ext)
221.640 -
221.641 -(* f A (tw iB schB2) = nil *)
221.642 -apply (simp add: int_is_not_ext not_ext_is_int_or_not_act intA_is_not_actB)
221.643 -
221.644 -
221.645 -(* reduce trace_takes from n to strictly smaller k *)
221.646 -apply (rule take_reduction)
221.647 -apply (rule refl)
221.648 -apply (rule refl)
221.649 -
221.650 -(* now conclusion fulfills induction hypothesis, but assumptions are not all ready *)
221.651 -
221.652 -(* assumption schB *)
221.653 -apply (drule_tac x = "y2" and g = "Filter (%a. a:act B) $rs" in subst_lemma2)
221.654 -apply assumption
221.655 -apply (simp add: intA_is_not_actB int_is_not_ext)
221.656 -
221.657 -(* conclusions concerning LastActExtsch, cannot be rewritten, as LastActExtsmalli are looping *)
221.658 -apply (drule_tac sch = "schA" and P = "%a. a:int A" in LastActExtsmall1)
221.659 -apply (frule_tac ?sch1.0 = "y1" in LastActExtsmall2)
221.660 -apply assumption
221.661 -apply (drule_tac sch = "y2" and P = "%a. a:int B" in LastActExtsmall1)
221.662 -
221.663 -(* assumption Forall schA, and Forall schA are performed by ForallTL,ForallDropwhile *)
221.664 -apply (simp add: ForallTL ForallDropwhile)
221.665 -
221.666 -(* case x~:A & x:B *)
221.667 -(* cannot occur, as just this case has been scheduled out before as the B-only prefix *)
221.668 -apply (case_tac "x:act B")
221.669 -apply fast
221.670 -
221.671 -(* case x~:A & x~:B *)
221.672 -(* cannot occur because of assumption: Forall (a:ext A | a:ext B) *)
221.673 -apply (rotate_tac -9)
221.674 -(* reduce forall assumption from tr to (x>>rs) *)
221.675 -apply (simp add: externals_of_par)
221.676 -apply (fast intro!: ext_is_act)
221.677 -
221.678 -done
221.679 -
221.680 -
221.681 -
221.682 -subsection" Filter of mksch(tr,schA,schB) to B is schB -- take lemma proof"
221.683 -
221.684 -lemma FilterBmksch_is_schB: "!! A B. [| compatible A B; compatible B A;
221.685 - is_asig(asig_of A); is_asig(asig_of B) |] ==>
221.686 - Forall (%x. x:ext (A||B)) tr &
221.687 - Forall (%x. x:act A) schA & Forall (%x. x:act B) schB &
221.688 - Filter (%a. a:ext A)$schA = Filter (%a. a:act A)$tr &
221.689 - Filter (%a. a:ext B)$schB = Filter (%a. a:act B)$tr &
221.690 - LastActExtsch A schA & LastActExtsch B schB
221.691 - --> Filter (%a. a:act B)$(mksch A B$tr$schA$schB) = schB"
221.692 -apply (intro strip)
221.693 -apply (rule seq.take_lemma)
221.694 -apply (rule mp)
221.695 -prefer 2 apply assumption
221.696 -back back back back
221.697 -apply (rule_tac x = "schA" in spec)
221.698 -apply (rule_tac x = "schB" in spec)
221.699 -apply (rule_tac x = "tr" in spec)
221.700 -apply (tactic "thin_tac' 5 1")
221.701 -apply (rule nat_less_induct)
221.702 -apply (rule allI)+
221.703 -apply (rename_tac tr schB schA)
221.704 -apply (intro strip)
221.705 -apply (erule conjE)+
221.706 -
221.707 -apply (case_tac "Forall (%x. x:act A & x~:act B) tr")
221.708 -
221.709 -apply (rule seq_take_lemma [THEN iffD2, THEN spec])
221.710 -apply (tactic "thin_tac' 5 1")
221.711 -
221.712 -apply (case_tac "Finite tr")
221.713 -
221.714 -(* both sides of this equation are nil *)
221.715 -apply (subgoal_tac "schB=nil")
221.716 -apply (simp (no_asm_simp))
221.717 -(* first side: mksch = nil *)
221.718 -apply (auto intro!: ForallQFilterPnil ForallAnBmksch FiniteL_mksch)[1]
221.719 -(* second side: schA = nil *)
221.720 -apply (erule_tac A = "B" in LastActExtimplnil)
221.721 -apply (simp (no_asm_simp))
221.722 -apply (erule_tac Q = "%x. x:act A & x~:act B" in ForallQFilterPnil)
221.723 -apply assumption
221.724 -apply fast
221.725 -
221.726 -(* case ~ Finite tr *)
221.727 -
221.728 -(* both sides of this equation are UU *)
221.729 -apply (subgoal_tac "schB=UU")
221.730 -apply (simp (no_asm_simp))
221.731 -(* first side: mksch = UU *)
221.732 -apply (force intro!: ForallQFilterPUU finiteR_mksch [THEN mp, COMP rev_contrapos] ForallAnBmksch)
221.733 -(* schA = UU *)
221.734 -apply (erule_tac A = "B" in LastActExtimplUU)
221.735 -apply (simp (no_asm_simp))
221.736 -apply (erule_tac Q = "%x. x:act A & x~:act B" in ForallQFilterPUU)
221.737 -apply assumption
221.738 -apply fast
221.739 -
221.740 -(* case" ~ Forall (%x.x:act B & x~:act A) s" *)
221.741 -
221.742 -apply (drule divide_Seq3)
221.743 -
221.744 -apply (erule exE)+
221.745 -apply (erule conjE)+
221.746 -apply hypsubst
221.747 -
221.748 -(* bring in lemma reduceB_mksch *)
221.749 -apply (frule_tac y = "schB" and x = "schA" and A = "A" and B = "B" in reduceB_mksch)
221.750 -apply assumption+
221.751 -apply (erule exE)+
221.752 -apply (erule conjE)+
221.753 -
221.754 -(* use reduceB_mksch to rewrite conclusion *)
221.755 -apply hypsubst
221.756 -apply simp
221.757 -
221.758 -(* eliminate the A-only prefix *)
221.759 -
221.760 -apply (subgoal_tac "(Filter (%a. a :act B) $x1) = nil")
221.761 -apply (erule_tac [2] ForallQFilterPnil)
221.762 -prefer 2 apply (assumption)
221.763 -prefer 2 apply (fast)
221.764 -
221.765 -(* Now real recursive step follows (in x) *)
221.766 -
221.767 -apply simp
221.768 -apply (case_tac "x:act B")
221.769 -apply (case_tac "x~:act A")
221.770 -apply (rotate_tac -2)
221.771 -apply simp
221.772 -
221.773 -apply (subgoal_tac "Filter (%a. a:act B & a:ext A) $x1=nil")
221.774 -apply (rotate_tac -1)
221.775 -apply simp
221.776 -(* eliminate introduced subgoal 2 *)
221.777 -apply (erule_tac [2] ForallQFilterPnil)
221.778 -prefer 2 apply (assumption)
221.779 -prefer 2 apply (fast)
221.780 -
221.781 -(* bring in divide Seq for s *)
221.782 -apply (frule sym [THEN eq_imp_below, THEN divide_Seq])
221.783 -apply (erule conjE)+
221.784 -
221.785 -(* subst divide_Seq in conclusion, but only at the righest occurence *)
221.786 -apply (rule_tac t = "schB" in ssubst)
221.787 -back
221.788 -back
221.789 -back
221.790 -apply assumption
221.791 -
221.792 -(* reduce trace_takes from n to strictly smaller k *)
221.793 -apply (rule take_reduction)
221.794 -
221.795 -(* f B (tw iB) = tw ~eB *)
221.796 -apply (simp add: int_is_act not_ext_is_int_or_not_act)
221.797 -apply (rule refl)
221.798 -apply (simp add: int_is_act not_ext_is_int_or_not_act)
221.799 -apply (rotate_tac -11)
221.800 -
221.801 -(* now conclusion fulfills induction hypothesis, but assumptions are not ready *)
221.802 -
221.803 -(* assumption schA *)
221.804 -apply (simp add: ext_and_act)
221.805 -(* assumption schB *)
221.806 -apply (drule_tac x = "schB" and g = "Filter (%a. a:act B) $rs" in subst_lemma2)
221.807 -apply assumption
221.808 -apply (simp add: int_is_not_ext)
221.809 -(* assumptions concerning LastActExtsch, cannot be rewritten, as LastActExtsmalli are looping *)
221.810 -apply (drule_tac sch = "schB" and P = "%a. a:int B" in LastActExtsmall1)
221.811 -apply (frule_tac ?sch1.0 = "x1" in LastActExtsmall2)
221.812 -apply assumption
221.813 -
221.814 -(* assumption Forall schB *)
221.815 -apply (drule_tac s = "schB" and P = "Forall (%x. x:act B) " in subst)
221.816 -apply assumption
221.817 -apply (simp add: int_is_act)
221.818 -
221.819 -(* case x:actions(asig_of A) & x: actions(asig_of B) *)
221.820 -
221.821 -apply (rotate_tac -2)
221.822 -apply simp
221.823 -
221.824 -apply (subgoal_tac "Filter (%a. a:act B & a:ext A) $x1=nil")
221.825 -apply (rotate_tac -1)
221.826 -apply simp
221.827 -(* eliminate introduced subgoal 2 *)
221.828 -apply (erule_tac [2] ForallQFilterPnil)
221.829 -prefer 2 apply (assumption)
221.830 -prefer 2 apply (fast)
221.831 -
221.832 -(* bring in divide Seq for s *)
221.833 -apply (frule sym [THEN eq_imp_below, THEN divide_Seq])
221.834 -apply (erule conjE)+
221.835 -
221.836 -(* subst divide_Seq in conclusion, but only at the righest occurence *)
221.837 -apply (rule_tac t = "schB" in ssubst)
221.838 -back
221.839 -back
221.840 -back
221.841 -apply assumption
221.842 -
221.843 -(* f B (tw iB) = tw ~eB *)
221.844 -apply (simp add: int_is_act not_ext_is_int_or_not_act)
221.845 -
221.846 -(* rewrite assumption forall and schB *)
221.847 -apply (rotate_tac 13)
221.848 -apply (simp add: ext_and_act)
221.849 -
221.850 -(* divide_Seq for schB2 *)
221.851 -apply (frule_tac y = "x2" in sym [THEN eq_imp_below, THEN divide_Seq])
221.852 -apply (erule conjE)+
221.853 -(* assumption schA *)
221.854 -apply (drule_tac x = "schB" and g = "Filter (%a. a:act B) $rs" in subst_lemma2)
221.855 -apply assumption
221.856 -apply (simp add: int_is_not_ext)
221.857 -
221.858 -(* f B (tw iA schA2) = nil *)
221.859 -apply (simp add: int_is_not_ext not_ext_is_int_or_not_act intA_is_not_actB)
221.860 -
221.861 -
221.862 -(* reduce trace_takes from n to strictly smaller k *)
221.863 -apply (rule take_reduction)
221.864 -apply (rule refl)
221.865 -apply (rule refl)
221.866 -
221.867 -(* now conclusion fulfills induction hypothesis, but assumptions are not all ready *)
221.868 -
221.869 -(* assumption schA *)
221.870 -apply (drule_tac x = "x2" and g = "Filter (%a. a:act A) $rs" in subst_lemma2)
221.871 -apply assumption
221.872 -apply (simp add: intA_is_not_actB int_is_not_ext)
221.873 -
221.874 -(* conclusions concerning LastActExtsch, cannot be rewritten, as LastActExtsmalli are looping *)
221.875 -apply (drule_tac sch = "schB" and P = "%a. a:int B" in LastActExtsmall1)
221.876 -apply (frule_tac ?sch1.0 = "x1" in LastActExtsmall2)
221.877 -apply assumption
221.878 -apply (drule_tac sch = "x2" and P = "%a. a:int A" in LastActExtsmall1)
221.879 -
221.880 -(* assumption Forall schA, and Forall schA are performed by ForallTL,ForallDropwhile *)
221.881 -apply (simp add: ForallTL ForallDropwhile)
221.882 -
221.883 -(* case x~:B & x:A *)
221.884 -(* cannot occur, as just this case has been scheduled out before as the B-only prefix *)
221.885 -apply (case_tac "x:act A")
221.886 -apply fast
221.887 -
221.888 -(* case x~:B & x~:A *)
221.889 -(* cannot occur because of assumption: Forall (a:ext A | a:ext B) *)
221.890 -apply (rotate_tac -9)
221.891 -(* reduce forall assumption from tr to (x>>rs) *)
221.892 -apply (simp add: externals_of_par)
221.893 -apply (fast intro!: ext_is_act)
221.894 -
221.895 -done
221.896 -
221.897 -
221.898 -subsection "COMPOSITIONALITY on TRACE Level -- Main Theorem"
221.899 -
221.900 -lemma compositionality_tr:
221.901 -"!! A B. [| is_trans_of A; is_trans_of B; compatible A B; compatible B A;
221.902 - is_asig(asig_of A); is_asig(asig_of B)|]
221.903 - ==> (tr: traces(A||B)) =
221.904 - (Filter (%a. a:act A)$tr : traces A &
221.905 - Filter (%a. a:act B)$tr : traces B &
221.906 - Forall (%x. x:ext(A||B)) tr)"
221.907 -
221.908 -apply (simp (no_asm) add: traces_def has_trace_def)
221.909 -apply auto
221.910 -
221.911 -(* ==> *)
221.912 -(* There is a schedule of A *)
221.913 -apply (rule_tac x = "Filter (%a. a:act A) $sch" in bexI)
221.914 -prefer 2
221.915 -apply (simp add: compositionality_sch)
221.916 -apply (simp add: compatibility_consequence1 externals_of_par ext1_ext2_is_not_act1)
221.917 -(* There is a schedule of B *)
221.918 -apply (rule_tac x = "Filter (%a. a:act B) $sch" in bexI)
221.919 -prefer 2
221.920 -apply (simp add: compositionality_sch)
221.921 -apply (simp add: compatibility_consequence2 externals_of_par ext1_ext2_is_not_act2)
221.922 -(* Traces of A||B have only external actions from A or B *)
221.923 -apply (rule ForallPFilterP)
221.924 -
221.925 -(* <== *)
221.926 -
221.927 -(* replace schA and schB by Cut(schA) and Cut(schB) *)
221.928 -apply (drule exists_LastActExtsch)
221.929 -apply assumption
221.930 -apply (drule exists_LastActExtsch)
221.931 -apply assumption
221.932 -apply (erule exE)+
221.933 -apply (erule conjE)+
221.934 -(* Schedules of A(B) have only actions of A(B) *)
221.935 -apply (drule scheds_in_sig)
221.936 -apply assumption
221.937 -apply (drule scheds_in_sig)
221.938 -apply assumption
221.939 -
221.940 -apply (rename_tac h1 h2 schA schB)
221.941 -(* mksch is exactly the construction of trA||B out of schA, schB, and the oracle tr,
221.942 - we need here *)
221.943 -apply (rule_tac x = "mksch A B$tr$schA$schB" in bexI)
221.944 -
221.945 -(* External actions of mksch are just the oracle *)
221.946 -apply (simp add: FilterA_mksch_is_tr)
221.947 -
221.948 -(* mksch is a schedule -- use compositionality on sch-level *)
221.949 -apply (simp add: compositionality_sch)
221.950 -apply (simp add: FilterAmksch_is_schA FilterBmksch_is_schB)
221.951 -apply (erule ForallAorB_mksch)
221.952 -apply (erule ForallPForallQ)
221.953 -apply (erule ext_is_act)
221.954 -done
221.955 -
221.956 -
221.957 -
221.958 -subsection {* COMPOSITIONALITY on TRACE Level -- for Modules *}
221.959 -
221.960 -lemma compositionality_tr_modules:
221.961 -
221.962 -"!! A B. [| is_trans_of A; is_trans_of B; compatible A B; compatible B A;
221.963 - is_asig(asig_of A); is_asig(asig_of B)|]
221.964 - ==> Traces (A||B) = par_traces (Traces A) (Traces B)"
221.965 -
221.966 -apply (unfold Traces_def par_traces_def)
221.967 -apply (simp add: asig_of_par)
221.968 -apply (rule set_eqI)
221.969 -apply (simp add: compositionality_tr externals_of_par)
221.970 -done
221.971 -
221.972 -
221.973 -declaration {* fn _ => Simplifier.map_ss (fn ss => ss setmksym (K (SOME o symmetric_fun))) *}
221.974 -
221.975 -
221.976 -end
222.1 --- a/src/HOLCF/IOA/meta_theory/Compositionality.thy Sat Nov 27 14:34:54 2010 -0800
222.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
222.3 @@ -1,75 +0,0 @@
222.4 -(* Title: HOLCF/IOA/meta_theory/Compositionality.thy
222.5 - Author: Olaf Müller
222.6 -*)
222.7 -
222.8 -header {* Compositionality of I/O automata *}
222.9 -theory Compositionality
222.10 -imports CompoTraces
222.11 -begin
222.12 -
222.13 -lemma compatibility_consequence3: "[|eA --> A ; eB & ~eA --> ~A|] ==> (eA | eB) --> A=eA"
222.14 -apply auto
222.15 -done
222.16 -
222.17 -
222.18 -lemma Filter_actAisFilter_extA:
222.19 -"!! A B. [| compatible A B; Forall (%a. a: ext A | a: ext B) tr |] ==>
222.20 - Filter (%a. a: act A)$tr= Filter (%a. a: ext A)$tr"
222.21 -apply (rule ForallPFilterQR)
222.22 -(* i.e.: [| (! x. P x --> (Q x = R x)) ; Forall P tr |] ==> Filter Q$tr = Filter R$tr *)
222.23 -prefer 2 apply (assumption)
222.24 -apply (rule compatibility_consequence3)
222.25 -apply (simp_all add: ext_is_act ext1_ext2_is_not_act1)
222.26 -done
222.27 -
222.28 -
222.29 -(* the next two theorems are only necessary, as there is no theorem ext (A||B) = ext (B||A) *)
222.30 -
222.31 -lemma compatibility_consequence4: "[|eA --> A ; eB & ~eA --> ~A|] ==> (eB | eA) --> A=eA"
222.32 -apply auto
222.33 -done
222.34 -
222.35 -lemma Filter_actAisFilter_extA2: "[| compatible A B; Forall (%a. a: ext B | a: ext A) tr |] ==>
222.36 - Filter (%a. a: act A)$tr= Filter (%a. a: ext A)$tr"
222.37 -apply (rule ForallPFilterQR)
222.38 -prefer 2 apply (assumption)
222.39 -apply (rule compatibility_consequence4)
222.40 -apply (simp_all add: ext_is_act ext1_ext2_is_not_act1)
222.41 -done
222.42 -
222.43 -
222.44 -subsection " Main Compositionality Theorem "
222.45 -
222.46 -lemma compositionality: "[| is_trans_of A1; is_trans_of A2; is_trans_of B1; is_trans_of B2;
222.47 - is_asig_of A1; is_asig_of A2;
222.48 - is_asig_of B1; is_asig_of B2;
222.49 - compatible A1 B1; compatible A2 B2;
222.50 - A1 =<| A2;
222.51 - B1 =<| B2 |]
222.52 - ==> (A1 || B1) =<| (A2 || B2)"
222.53 -apply (simp add: is_asig_of_def)
222.54 -apply (frule_tac A1 = "A1" in compat_commute [THEN iffD1])
222.55 -apply (frule_tac A1 = "A2" in compat_commute [THEN iffD1])
222.56 -apply (simp add: ioa_implements_def inputs_of_par outputs_of_par externals_of_par)
222.57 -apply auto
222.58 -apply (simp add: compositionality_tr)
222.59 -apply (subgoal_tac "ext A1 = ext A2 & ext B1 = ext B2")
222.60 -prefer 2
222.61 -apply (simp add: externals_def)
222.62 -apply (erule conjE)+
222.63 -(* rewrite with proven subgoal *)
222.64 -apply (simp add: externals_of_par)
222.65 -apply auto
222.66 -
222.67 -(* 2 goals, the 3rd has been solved automatically *)
222.68 -(* 1: Filter A2 x : traces A2 *)
222.69 -apply (drule_tac A = "traces A1" in subsetD)
222.70 -apply assumption
222.71 -apply (simp add: Filter_actAisFilter_extA)
222.72 -(* 2: Filter B2 x : traces B2 *)
222.73 -apply (drule_tac A = "traces B1" in subsetD)
222.74 -apply assumption
222.75 -apply (simp add: Filter_actAisFilter_extA2)
222.76 -done
222.77 -
222.78 -end
223.1 --- a/src/HOLCF/IOA/meta_theory/Deadlock.thy Sat Nov 27 14:34:54 2010 -0800
223.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
223.3 @@ -1,92 +0,0 @@
223.4 -(* Title: HOLCF/IOA/meta_theory/Deadlock.thy
223.5 - Author: Olaf Müller
223.6 -*)
223.7 -
223.8 -header {* Deadlock freedom of I/O Automata *}
223.9 -
223.10 -theory Deadlock
223.11 -imports RefCorrectness CompoScheds
223.12 -begin
223.13 -
223.14 -text {* input actions may always be added to a schedule *}
223.15 -
223.16 -lemma scheds_input_enabled:
223.17 - "[| Filter (%x. x:act A)$sch : schedules A; a:inp A; input_enabled A; Finite sch|]
223.18 - ==> Filter (%x. x:act A)$sch @@ a>>nil : schedules A"
223.19 -apply (simp add: schedules_def has_schedule_def)
223.20 -apply auto
223.21 -apply (frule inp_is_act)
223.22 -apply (simp add: executions_def)
223.23 -apply (tactic {* pair_tac @{context} "ex" 1 *})
223.24 -apply (rename_tac s ex)
223.25 -apply (subgoal_tac "Finite ex")
223.26 -prefer 2
223.27 -apply (simp add: filter_act_def)
223.28 -defer
223.29 -apply (rule_tac [2] Map2Finite [THEN iffD1])
223.30 -apply (rule_tac [2] t = "Map fst$ex" in subst)
223.31 -prefer 2 apply (assumption)
223.32 -apply (erule_tac [2] FiniteFilter)
223.33 -(* subgoal 1 *)
223.34 -apply (frule exists_laststate)
223.35 -apply (erule allE)
223.36 -apply (erule exE)
223.37 -(* using input-enabledness *)
223.38 -apply (simp add: input_enabled_def)
223.39 -apply (erule conjE)+
223.40 -apply (erule_tac x = "a" in allE)
223.41 -apply simp
223.42 -apply (erule_tac x = "u" in allE)
223.43 -apply (erule exE)
223.44 -(* instantiate execution *)
223.45 -apply (rule_tac x = " (s,ex @@ (a,s2) >>nil) " in exI)
223.46 -apply (simp add: filter_act_def MapConc)
223.47 -apply (erule_tac t = "u" in lemma_2_1)
223.48 -apply simp
223.49 -apply (rule sym)
223.50 -apply assumption
223.51 -done
223.52 -
223.53 -text {*
223.54 - Deadlock freedom: component B cannot block an out or int action
223.55 - of component A in every schedule.
223.56 - Needs compositionality on schedule level, input-enabledness, compatibility
223.57 - and distributivity of is_exec_frag over @@
223.58 -*}
223.59 -
223.60 -declare split_if [split del]
223.61 -lemma IOA_deadlock_free: "[| a : local A; Finite sch; sch : schedules (A||B);
223.62 - Filter (%x. x:act A)$(sch @@ a>>nil) : schedules A; compatible A B; input_enabled B |]
223.63 - ==> (sch @@ a>>nil) : schedules (A||B)"
223.64 -apply (simp add: compositionality_sch locals_def)
223.65 -apply (rule conjI)
223.66 -(* a : act (A||B) *)
223.67 -prefer 2
223.68 -apply (simp add: actions_of_par)
223.69 -apply (blast dest: int_is_act out_is_act)
223.70 -
223.71 -(* Filter B (sch@@[a]) : schedules B *)
223.72 -
223.73 -apply (case_tac "a:int A")
223.74 -apply (drule intA_is_not_actB)
223.75 -apply (assumption) (* --> a~:act B *)
223.76 -apply simp
223.77 -
223.78 -(* case a~:int A , i.e. a:out A *)
223.79 -apply (case_tac "a~:act B")
223.80 -apply simp
223.81 -(* case a:act B *)
223.82 -apply simp
223.83 -apply (subgoal_tac "a:out A")
223.84 -prefer 2 apply (blast)
223.85 -apply (drule outAactB_is_inpB)
223.86 -apply assumption
223.87 -apply assumption
223.88 -apply (rule scheds_input_enabled)
223.89 -apply simp
223.90 -apply assumption+
223.91 -done
223.92 -
223.93 -declare split_if [split]
223.94 -
223.95 -end
224.1 --- a/src/HOLCF/IOA/meta_theory/IOA.thy Sat Nov 27 14:34:54 2010 -0800
224.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
224.3 @@ -1,11 +0,0 @@
224.4 -(* Title: HOLCF/IOA/meta_theory/IOA.thy
224.5 - Author: Olaf Müller
224.6 -*)
224.7 -
224.8 -header {* The theory of I/O automata in HOLCF *}
224.9 -
224.10 -theory IOA
224.11 -imports SimCorrectness Compositionality Deadlock
224.12 -begin
224.13 -
224.14 -end
225.1 --- a/src/HOLCF/IOA/meta_theory/LiveIOA.thy Sat Nov 27 14:34:54 2010 -0800
225.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
225.3 @@ -1,82 +0,0 @@
225.4 -(* Title: HOLCF/IOA/meta_theory/LiveIOA.thy
225.5 - Author: Olaf Müller
225.6 -*)
225.7 -
225.8 -header {* Live I/O automata -- specified by temproal formulas *}
225.9 -
225.10 -theory LiveIOA
225.11 -imports TLS
225.12 -begin
225.13 -
225.14 -default_sort type
225.15 -
225.16 -types
225.17 - ('a, 's) live_ioa = "('a,'s)ioa * ('a,'s)ioa_temp"
225.18 -
225.19 -definition
225.20 - validLIOA :: "('a,'s)live_ioa => ('a,'s)ioa_temp => bool" where
225.21 - "validLIOA AL P = validIOA (fst AL) ((snd AL) .--> P)"
225.22 -
225.23 -definition
225.24 - WF :: "('a,'s)ioa => 'a set => ('a,'s)ioa_temp" where
225.25 - "WF A acts = (<> [] <%(s,a,t) . Enabled A acts s> .--> [] <> <xt2 (plift (%a. a : acts))>)"
225.26 -definition
225.27 - SF :: "('a,'s)ioa => 'a set => ('a,'s)ioa_temp" where
225.28 - "SF A acts = ([] <> <%(s,a,t) . Enabled A acts s> .--> [] <> <xt2 (plift (%a. a : acts))>)"
225.29 -
225.30 -definition
225.31 - liveexecutions :: "('a,'s)live_ioa => ('a,'s)execution set" where
225.32 - "liveexecutions AP = {exec. exec : executions (fst AP) & (exec |== (snd AP))}"
225.33 -definition
225.34 - livetraces :: "('a,'s)live_ioa => 'a trace set" where
225.35 - "livetraces AP = {mk_trace (fst AP)$(snd ex) | ex. ex:liveexecutions AP}"
225.36 -definition
225.37 - live_implements :: "('a,'s1)live_ioa => ('a,'s2)live_ioa => bool" where
225.38 - "live_implements CL AM = ((inp (fst CL) = inp (fst AM)) &
225.39 - (out (fst CL) = out (fst AM)) &
225.40 - livetraces CL <= livetraces AM)"
225.41 -definition
225.42 - is_live_ref_map :: "('s1 => 's2) => ('a,'s1)live_ioa => ('a,'s2)live_ioa => bool" where
225.43 - "is_live_ref_map f CL AM =
225.44 - (is_ref_map f (fst CL ) (fst AM) &
225.45 - (! exec : executions (fst CL). (exec |== (snd CL)) -->
225.46 - ((corresp_ex (fst AM) f exec) |== (snd AM))))"
225.47 -
225.48 -
225.49 -lemma live_implements_trans:
225.50 -"!!LC. [| live_implements (A,LA) (B,LB); live_implements (B,LB) (C,LC) |]
225.51 - ==> live_implements (A,LA) (C,LC)"
225.52 -apply (unfold live_implements_def)
225.53 -apply auto
225.54 -done
225.55 -
225.56 -
225.57 -subsection "Correctness of live refmap"
225.58 -
225.59 -lemma live_implements: "[| inp(C)=inp(A); out(C)=out(A);
225.60 - is_live_ref_map f (C,M) (A,L) |]
225.61 - ==> live_implements (C,M) (A,L)"
225.62 -apply (simp add: is_live_ref_map_def live_implements_def livetraces_def liveexecutions_def)
225.63 -apply auto
225.64 -apply (rule_tac x = "corresp_ex A f ex" in exI)
225.65 -apply auto
225.66 - (* Traces coincide, Lemma 1 *)
225.67 - apply (tactic {* pair_tac @{context} "ex" 1 *})
225.68 - apply (erule lemma_1 [THEN spec, THEN mp])
225.69 - apply (simp (no_asm) add: externals_def)
225.70 - apply (auto)[1]
225.71 - apply (simp add: executions_def reachable.reachable_0)
225.72 -
225.73 - (* corresp_ex is execution, Lemma 2 *)
225.74 - apply (tactic {* pair_tac @{context} "ex" 1 *})
225.75 - apply (simp add: executions_def)
225.76 - (* start state *)
225.77 - apply (rule conjI)
225.78 - apply (simp add: is_ref_map_def corresp_ex_def)
225.79 - (* is-execution-fragment *)
225.80 - apply (erule lemma_2 [THEN spec, THEN mp])
225.81 - apply (simp add: reachable.reachable_0)
225.82 -
225.83 -done
225.84 -
225.85 -end
226.1 --- a/src/HOLCF/IOA/meta_theory/Pred.thy Sat Nov 27 14:34:54 2010 -0800
226.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
226.3 @@ -1,69 +0,0 @@
226.4 -(* Title: HOLCF/IOA/meta_theory/Pred.thy
226.5 - Author: Olaf Müller
226.6 -*)
226.7 -
226.8 -header {* Logical Connectives lifted to predicates *}
226.9 -
226.10 -theory Pred
226.11 -imports Main
226.12 -begin
226.13 -
226.14 -default_sort type
226.15 -
226.16 -types
226.17 - 'a predicate = "'a => bool"
226.18 -
226.19 -consts
226.20 -
226.21 -satisfies ::"'a => 'a predicate => bool" ("_ |= _" [100,9] 8)
226.22 -valid ::"'a predicate => bool" (* ("|-") *)
226.23 -
226.24 -NOT ::"'a predicate => 'a predicate" (".~ _" [40] 40)
226.25 -AND ::"'a predicate => 'a predicate => 'a predicate" (infixr ".&" 35)
226.26 -OR ::"'a predicate => 'a predicate => 'a predicate" (infixr ".|" 30)
226.27 -IMPLIES ::"'a predicate => 'a predicate => 'a predicate" (infixr ".-->" 25)
226.28 -
226.29 -
226.30 -notation (output)
226.31 - NOT ("~ _" [40] 40) and
226.32 - AND (infixr "&" 35) and
226.33 - OR (infixr "|" 30) and
226.34 - IMPLIES (infixr "-->" 25)
226.35 -
226.36 -notation (xsymbols output)
226.37 - NOT ("\<not> _" [40] 40) and
226.38 - AND (infixr "\<and>" 35) and
226.39 - OR (infixr "\<or>" 30) and
226.40 - IMPLIES (infixr "\<longrightarrow>" 25)
226.41 -
226.42 -notation (xsymbols)
226.43 - satisfies ("_ \<Turnstile> _" [100,9] 8)
226.44 -
226.45 -notation (HTML output)
226.46 - NOT ("\<not> _" [40] 40) and
226.47 - AND (infixr "\<and>" 35) and
226.48 - OR (infixr "\<or>" 30)
226.49 -
226.50 -
226.51 -defs
226.52 -
226.53 -satisfies_def:
226.54 - "s |= P == P s"
226.55 -
226.56 -(* priority einfuegen, da clash mit |=, wenn graphisches Symbol *)
226.57 -valid_def:
226.58 - "valid P == (! s. (s |= P))"
226.59 -
226.60 -NOT_def:
226.61 - "NOT P s == ~ (P s)"
226.62 -
226.63 -AND_def:
226.64 - "(P .& Q) s == (P s) & (Q s)"
226.65 -
226.66 -OR_def:
226.67 - "(P .| Q) s == (P s) | (Q s)"
226.68 -
226.69 -IMPLIES_def:
226.70 - "(P .--> Q) s == (P s) --> (Q s)"
226.71 -
226.72 -end
227.1 --- a/src/HOLCF/IOA/meta_theory/RefCorrectness.thy Sat Nov 27 14:34:54 2010 -0800
227.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
227.3 @@ -1,371 +0,0 @@
227.4 -(* Title: HOLCF/IOA/meta_theory/RefCorrectness.thy
227.5 - Author: Olaf Müller
227.6 -*)
227.7 -
227.8 -header {* Correctness of Refinement Mappings in HOLCF/IOA *}
227.9 -
227.10 -theory RefCorrectness
227.11 -imports RefMappings
227.12 -begin
227.13 -
227.14 -definition
227.15 - corresp_exC :: "('a,'s2)ioa => ('s1 => 's2) => ('a,'s1)pairs
227.16 - -> ('s1 => ('a,'s2)pairs)" where
227.17 - "corresp_exC A f = (fix$(LAM h ex. (%s. case ex of
227.18 - nil => nil
227.19 - | x##xs => (flift1 (%pr. (@cex. move A cex (f s) (fst pr) (f (snd pr)))
227.20 - @@ ((h$xs) (snd pr)))
227.21 - $x) )))"
227.22 -definition
227.23 - corresp_ex :: "('a,'s2)ioa => ('s1 => 's2) =>
227.24 - ('a,'s1)execution => ('a,'s2)execution" where
227.25 - "corresp_ex A f ex = (f (fst ex),(corresp_exC A f$(snd ex)) (fst ex))"
227.26 -
227.27 -definition
227.28 - is_fair_ref_map :: "('s1 => 's2) => ('a,'s1)ioa => ('a,'s2)ioa => bool" where
227.29 - "is_fair_ref_map f C A =
227.30 - (is_ref_map f C A &
227.31 - (! ex : executions(C). fair_ex C ex --> fair_ex A (corresp_ex A f ex)))"
227.32 -
227.33 -(* Axioms for fair trace inclusion proof support, not for the correctness proof
227.34 - of refinement mappings!
227.35 - Note: Everything is superseded by LiveIOA.thy! *)
227.36 -
227.37 -axiomatization where
227.38 -corresp_laststate:
227.39 - "Finite ex ==> laststate (corresp_ex A f (s,ex)) = f (laststate (s,ex))"
227.40 -
227.41 -axiomatization where
227.42 -corresp_Finite:
227.43 - "Finite (snd (corresp_ex A f (s,ex))) = Finite ex"
227.44 -
227.45 -axiomatization where
227.46 -FromAtoC:
227.47 - "fin_often (%x. P (snd x)) (snd (corresp_ex A f (s,ex))) ==> fin_often (%y. P (f (snd y))) ex"
227.48 -
227.49 -axiomatization where
227.50 -FromCtoA:
227.51 - "inf_often (%y. P (fst y)) ex ==> inf_often (%x. P (fst x)) (snd (corresp_ex A f (s,ex)))"
227.52 -
227.53 -
227.54 -(* Proof by case on inf W in ex: If so, ok. If not, only fin W in ex, ie there is
227.55 - an index i from which on no W in ex. But W inf enabled, ie at least once after i
227.56 - W is enabled. As W does not occur after i and W is enabling_persistent, W keeps
227.57 - enabled until infinity, ie. indefinitely *)
227.58 -axiomatization where
227.59 -persistent:
227.60 - "[|inf_often (%x. Enabled A W (snd x)) ex; en_persistent A W|]
227.61 - ==> inf_often (%x. fst x :W) ex | fin_often (%x. ~Enabled A W (snd x)) ex"
227.62 -
227.63 -axiomatization where
227.64 -infpostcond:
227.65 - "[| is_exec_frag A (s,ex); inf_often (%x. fst x:W) ex|]
227.66 - ==> inf_often (% x. set_was_enabled A W (snd x)) ex"
227.67 -
227.68 -
227.69 -subsection "corresp_ex"
227.70 -
227.71 -lemma corresp_exC_unfold: "corresp_exC A f = (LAM ex. (%s. case ex of
227.72 - nil => nil
227.73 - | x##xs => (flift1 (%pr. (@cex. move A cex (f s) (fst pr) (f (snd pr)))
227.74 - @@ ((corresp_exC A f $xs) (snd pr)))
227.75 - $x) ))"
227.76 -apply (rule trans)
227.77 -apply (rule fix_eq2)
227.78 -apply (simp only: corresp_exC_def)
227.79 -apply (rule beta_cfun)
227.80 -apply (simp add: flift1_def)
227.81 -done
227.82 -
227.83 -lemma corresp_exC_UU: "(corresp_exC A f$UU) s=UU"
227.84 -apply (subst corresp_exC_unfold)
227.85 -apply simp
227.86 -done
227.87 -
227.88 -lemma corresp_exC_nil: "(corresp_exC A f$nil) s = nil"
227.89 -apply (subst corresp_exC_unfold)
227.90 -apply simp
227.91 -done
227.92 -
227.93 -lemma corresp_exC_cons: "(corresp_exC A f$(at>>xs)) s =
227.94 - (@cex. move A cex (f s) (fst at) (f (snd at)))
227.95 - @@ ((corresp_exC A f$xs) (snd at))"
227.96 -apply (rule trans)
227.97 -apply (subst corresp_exC_unfold)
227.98 -apply (simp add: Consq_def flift1_def)
227.99 -apply simp
227.100 -done
227.101 -
227.102 -
227.103 -declare corresp_exC_UU [simp] corresp_exC_nil [simp] corresp_exC_cons [simp]
227.104 -
227.105 -
227.106 -
227.107 -subsection "properties of move"
227.108 -
227.109 -lemma move_is_move:
227.110 - "[|is_ref_map f C A; reachable C s; (s,a,t):trans_of C|] ==>
227.111 - move A (@x. move A x (f s) a (f t)) (f s) a (f t)"
227.112 -apply (unfold is_ref_map_def)
227.113 -apply (subgoal_tac "? ex. move A ex (f s) a (f t) ")
227.114 -prefer 2
227.115 -apply simp
227.116 -apply (erule exE)
227.117 -apply (rule someI)
227.118 -apply assumption
227.119 -done
227.120 -
227.121 -lemma move_subprop1:
227.122 - "[|is_ref_map f C A; reachable C s; (s,a,t):trans_of C|] ==>
227.123 - is_exec_frag A (f s,@x. move A x (f s) a (f t))"
227.124 -apply (cut_tac move_is_move)
227.125 -defer
227.126 -apply assumption+
227.127 -apply (simp add: move_def)
227.128 -done
227.129 -
227.130 -lemma move_subprop2:
227.131 - "[|is_ref_map f C A; reachable C s; (s,a,t):trans_of C|] ==>
227.132 - Finite ((@x. move A x (f s) a (f t)))"
227.133 -apply (cut_tac move_is_move)
227.134 -defer
227.135 -apply assumption+
227.136 -apply (simp add: move_def)
227.137 -done
227.138 -
227.139 -lemma move_subprop3:
227.140 - "[|is_ref_map f C A; reachable C s; (s,a,t):trans_of C|] ==>
227.141 - laststate (f s,@x. move A x (f s) a (f t)) = (f t)"
227.142 -apply (cut_tac move_is_move)
227.143 -defer
227.144 -apply assumption+
227.145 -apply (simp add: move_def)
227.146 -done
227.147 -
227.148 -lemma move_subprop4:
227.149 - "[|is_ref_map f C A; reachable C s; (s,a,t):trans_of C|] ==>
227.150 - mk_trace A$((@x. move A x (f s) a (f t))) =
227.151 - (if a:ext A then a>>nil else nil)"
227.152 -apply (cut_tac move_is_move)
227.153 -defer
227.154 -apply assumption+
227.155 -apply (simp add: move_def)
227.156 -done
227.157 -
227.158 -
227.159 -(* ------------------------------------------------------------------ *)
227.160 -(* The following lemmata contribute to *)
227.161 -(* TRACE INCLUSION Part 1: Traces coincide *)
227.162 -(* ------------------------------------------------------------------ *)
227.163 -
227.164 -section "Lemmata for <=="
227.165 -
227.166 -(* --------------------------------------------------- *)
227.167 -(* Lemma 1.1: Distribution of mk_trace and @@ *)
227.168 -(* --------------------------------------------------- *)
227.169 -
227.170 -lemma mk_traceConc: "mk_trace C$(ex1 @@ ex2)= (mk_trace C$ex1) @@ (mk_trace C$ex2)"
227.171 -apply (simp add: mk_trace_def filter_act_def MapConc)
227.172 -done
227.173 -
227.174 -
227.175 -
227.176 -(* ------------------------------------------------------
227.177 - Lemma 1 :Traces coincide
227.178 - ------------------------------------------------------- *)
227.179 -declare split_if [split del]
227.180 -
227.181 -lemma lemma_1:
227.182 - "[|is_ref_map f C A; ext C = ext A|] ==>
227.183 - !s. reachable C s & is_exec_frag C (s,xs) -->
227.184 - mk_trace C$xs = mk_trace A$(snd (corresp_ex A f (s,xs)))"
227.185 -apply (unfold corresp_ex_def)
227.186 -apply (tactic {* pair_induct_tac @{context} "xs" [@{thm is_exec_frag_def}] 1 *})
227.187 -(* cons case *)
227.188 -apply (auto simp add: mk_traceConc)
227.189 -apply (frule reachable.reachable_n)
227.190 -apply assumption
227.191 -apply (erule_tac x = "y" in allE)
227.192 -apply (simp add: move_subprop4 split add: split_if)
227.193 -done
227.194 -
227.195 -declare split_if [split]
227.196 -
227.197 -(* ------------------------------------------------------------------ *)
227.198 -(* The following lemmata contribute to *)
227.199 -(* TRACE INCLUSION Part 2: corresp_ex is execution *)
227.200 -(* ------------------------------------------------------------------ *)
227.201 -
227.202 -section "Lemmata for ==>"
227.203 -
227.204 -(* -------------------------------------------------- *)
227.205 -(* Lemma 2.1 *)
227.206 -(* -------------------------------------------------- *)
227.207 -
227.208 -lemma lemma_2_1 [rule_format (no_asm)]:
227.209 -"Finite xs -->
227.210 - (!s .is_exec_frag A (s,xs) & is_exec_frag A (t,ys) &
227.211 - t = laststate (s,xs)
227.212 - --> is_exec_frag A (s,xs @@ ys))"
227.213 -
227.214 -apply (rule impI)
227.215 -apply (tactic {* Seq_Finite_induct_tac @{context} 1 *})
227.216 -(* main case *)
227.217 -apply (auto simp add: split_paired_all)
227.218 -done
227.219 -
227.220 -
227.221 -(* ----------------------------------------------------------- *)
227.222 -(* Lemma 2 : corresp_ex is execution *)
227.223 -(* ----------------------------------------------------------- *)
227.224 -
227.225 -
227.226 -
227.227 -lemma lemma_2:
227.228 - "[| is_ref_map f C A |] ==>
227.229 - !s. reachable C s & is_exec_frag C (s,xs)
227.230 - --> is_exec_frag A (corresp_ex A f (s,xs))"
227.231 -
227.232 -apply (unfold corresp_ex_def)
227.233 -
227.234 -apply simp
227.235 -apply (tactic {* pair_induct_tac @{context} "xs" [@{thm is_exec_frag_def}] 1 *})
227.236 -(* main case *)
227.237 -apply auto
227.238 -apply (rule_tac t = "f y" in lemma_2_1)
227.239 -
227.240 -(* Finite *)
227.241 -apply (erule move_subprop2)
227.242 -apply assumption+
227.243 -apply (rule conjI)
227.244 -
227.245 -(* is_exec_frag *)
227.246 -apply (erule move_subprop1)
227.247 -apply assumption+
227.248 -apply (rule conjI)
227.249 -
227.250 -(* Induction hypothesis *)
227.251 -(* reachable_n looping, therefore apply it manually *)
227.252 -apply (erule_tac x = "y" in allE)
227.253 -apply simp
227.254 -apply (frule reachable.reachable_n)
227.255 -apply assumption
227.256 -apply simp
227.257 -(* laststate *)
227.258 -apply (erule move_subprop3 [symmetric])
227.259 -apply assumption+
227.260 -done
227.261 -
227.262 -
227.263 -subsection "Main Theorem: TRACE - INCLUSION"
227.264 -
227.265 -lemma trace_inclusion:
227.266 - "[| ext C = ext A; is_ref_map f C A |]
227.267 - ==> traces C <= traces A"
227.268 -
227.269 - apply (unfold traces_def)
227.270 -
227.271 - apply (simp (no_asm) add: has_trace_def2)
227.272 - apply auto
227.273 -
227.274 - (* give execution of abstract automata *)
227.275 - apply (rule_tac x = "corresp_ex A f ex" in bexI)
227.276 -
227.277 - (* Traces coincide, Lemma 1 *)
227.278 - apply (tactic {* pair_tac @{context} "ex" 1 *})
227.279 - apply (erule lemma_1 [THEN spec, THEN mp])
227.280 - apply assumption+
227.281 - apply (simp add: executions_def reachable.reachable_0)
227.282 -
227.283 - (* corresp_ex is execution, Lemma 2 *)
227.284 - apply (tactic {* pair_tac @{context} "ex" 1 *})
227.285 - apply (simp add: executions_def)
227.286 - (* start state *)
227.287 - apply (rule conjI)
227.288 - apply (simp add: is_ref_map_def corresp_ex_def)
227.289 - (* is-execution-fragment *)
227.290 - apply (erule lemma_2 [THEN spec, THEN mp])
227.291 - apply (simp add: reachable.reachable_0)
227.292 - done
227.293 -
227.294 -
227.295 -subsection "Corollary: FAIR TRACE - INCLUSION"
227.296 -
227.297 -lemma fininf: "(~inf_often P s) = fin_often P s"
227.298 -apply (unfold fin_often_def)
227.299 -apply auto
227.300 -done
227.301 -
227.302 -
227.303 -lemma WF_alt: "is_wfair A W (s,ex) =
227.304 - (fin_often (%x. ~Enabled A W (snd x)) ex --> inf_often (%x. fst x :W) ex)"
227.305 -apply (simp add: is_wfair_def fin_often_def)
227.306 -apply auto
227.307 -done
227.308 -
227.309 -lemma WF_persistent: "[|is_wfair A W (s,ex); inf_often (%x. Enabled A W (snd x)) ex;
227.310 - en_persistent A W|]
227.311 - ==> inf_often (%x. fst x :W) ex"
227.312 -apply (drule persistent)
227.313 -apply assumption
227.314 -apply (simp add: WF_alt)
227.315 -apply auto
227.316 -done
227.317 -
227.318 -
227.319 -lemma fair_trace_inclusion: "!! C A.
227.320 - [| is_ref_map f C A; ext C = ext A;
227.321 - !! ex. [| ex:executions C; fair_ex C ex|] ==> fair_ex A (corresp_ex A f ex) |]
227.322 - ==> fairtraces C <= fairtraces A"
227.323 -apply (simp (no_asm) add: fairtraces_def fairexecutions_def)
227.324 -apply auto
227.325 -apply (rule_tac x = "corresp_ex A f ex" in exI)
227.326 -apply auto
227.327 -
227.328 - (* Traces coincide, Lemma 1 *)
227.329 - apply (tactic {* pair_tac @{context} "ex" 1 *})
227.330 - apply (erule lemma_1 [THEN spec, THEN mp])
227.331 - apply assumption+
227.332 - apply (simp add: executions_def reachable.reachable_0)
227.333 -
227.334 - (* corresp_ex is execution, Lemma 2 *)
227.335 - apply (tactic {* pair_tac @{context} "ex" 1 *})
227.336 - apply (simp add: executions_def)
227.337 - (* start state *)
227.338 - apply (rule conjI)
227.339 - apply (simp add: is_ref_map_def corresp_ex_def)
227.340 - (* is-execution-fragment *)
227.341 - apply (erule lemma_2 [THEN spec, THEN mp])
227.342 - apply (simp add: reachable.reachable_0)
227.343 -
227.344 -done
227.345 -
227.346 -lemma fair_trace_inclusion2: "!! C A.
227.347 - [| inp(C) = inp(A); out(C)=out(A);
227.348 - is_fair_ref_map f C A |]
227.349 - ==> fair_implements C A"
227.350 -apply (simp add: is_fair_ref_map_def fair_implements_def fairtraces_def fairexecutions_def)
227.351 -apply auto
227.352 -apply (rule_tac x = "corresp_ex A f ex" in exI)
227.353 -apply auto
227.354 -
227.355 - (* Traces coincide, Lemma 1 *)
227.356 - apply (tactic {* pair_tac @{context} "ex" 1 *})
227.357 - apply (erule lemma_1 [THEN spec, THEN mp])
227.358 - apply (simp (no_asm) add: externals_def)
227.359 - apply (auto)[1]
227.360 - apply (simp add: executions_def reachable.reachable_0)
227.361 -
227.362 - (* corresp_ex is execution, Lemma 2 *)
227.363 - apply (tactic {* pair_tac @{context} "ex" 1 *})
227.364 - apply (simp add: executions_def)
227.365 - (* start state *)
227.366 - apply (rule conjI)
227.367 - apply (simp add: is_ref_map_def corresp_ex_def)
227.368 - (* is-execution-fragment *)
227.369 - apply (erule lemma_2 [THEN spec, THEN mp])
227.370 - apply (simp add: reachable.reachable_0)
227.371 -
227.372 -done
227.373 -
227.374 -end
228.1 --- a/src/HOLCF/IOA/meta_theory/RefMappings.thy Sat Nov 27 14:34:54 2010 -0800
228.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
228.3 @@ -1,129 +0,0 @@
228.4 -(* Title: HOLCF/IOA/meta_theory/RefMappings.thy
228.5 - Author: Olaf Müller
228.6 -*)
228.7 -
228.8 -header {* Refinement Mappings in HOLCF/IOA *}
228.9 -
228.10 -theory RefMappings
228.11 -imports Traces
228.12 -begin
228.13 -
228.14 -default_sort type
228.15 -
228.16 -definition
228.17 - move :: "[('a,'s)ioa,('a,'s)pairs,'s,'a,'s] => bool" where
228.18 - "move ioa ex s a t =
228.19 - (is_exec_frag ioa (s,ex) & Finite ex &
228.20 - laststate (s,ex)=t &
228.21 - mk_trace ioa$ex = (if a:ext(ioa) then a>>nil else nil))"
228.22 -
228.23 -definition
228.24 - is_ref_map :: "[('s1=>'s2),('a,'s1)ioa,('a,'s2)ioa] => bool" where
228.25 - "is_ref_map f C A =
228.26 - ((!s:starts_of(C). f(s):starts_of(A)) &
228.27 - (!s t a. reachable C s &
228.28 - s -a--C-> t
228.29 - --> (? ex. move A ex (f s) a (f t))))"
228.30 -
228.31 -definition
228.32 - is_weak_ref_map :: "[('s1=>'s2),('a,'s1)ioa,('a,'s2)ioa] => bool" where
228.33 - "is_weak_ref_map f C A =
228.34 - ((!s:starts_of(C). f(s):starts_of(A)) &
228.35 - (!s t a. reachable C s &
228.36 - s -a--C-> t
228.37 - --> (if a:ext(C)
228.38 - then (f s) -a--A-> (f t)
228.39 - else (f s)=(f t))))"
228.40 -
228.41 -
228.42 -subsection "transitions and moves"
228.43 -
228.44 -
228.45 -lemma transition_is_ex: "s -a--A-> t ==> ? ex. move A ex s a t"
228.46 -apply (rule_tac x = " (a,t) >>nil" in exI)
228.47 -apply (simp add: move_def)
228.48 -done
228.49 -
228.50 -
228.51 -lemma nothing_is_ex: "(~a:ext A) & s=t ==> ? ex. move A ex s a t"
228.52 -apply (rule_tac x = "nil" in exI)
228.53 -apply (simp add: move_def)
228.54 -done
228.55 -
228.56 -
228.57 -lemma ei_transitions_are_ex: "(s -a--A-> s') & (s' -a'--A-> s'') & (~a':ext A)
228.58 - ==> ? ex. move A ex s a s''"
228.59 -apply (rule_tac x = " (a,s') >> (a',s'') >>nil" in exI)
228.60 -apply (simp add: move_def)
228.61 -done
228.62 -
228.63 -
228.64 -lemma eii_transitions_are_ex: "(s1 -a1--A-> s2) & (s2 -a2--A-> s3) & (s3 -a3--A-> s4) &
228.65 - (~a2:ext A) & (~a3:ext A) ==>
228.66 - ? ex. move A ex s1 a1 s4"
228.67 -apply (rule_tac x = " (a1,s2) >> (a2,s3) >> (a3,s4) >>nil" in exI)
228.68 -apply (simp add: move_def)
228.69 -done
228.70 -
228.71 -
228.72 -subsection "weak_ref_map and ref_map"
228.73 -
228.74 -lemma weak_ref_map2ref_map:
228.75 - "[| ext C = ext A;
228.76 - is_weak_ref_map f C A |] ==> is_ref_map f C A"
228.77 -apply (unfold is_weak_ref_map_def is_ref_map_def)
228.78 -apply auto
228.79 -apply (case_tac "a:ext A")
228.80 -apply (auto intro: transition_is_ex nothing_is_ex)
228.81 -done
228.82 -
228.83 -
228.84 -lemma imp_conj_lemma: "(P ==> Q-->R) ==> P&Q --> R"
228.85 - by blast
228.86 -
228.87 -declare split_if [split del]
228.88 -declare if_weak_cong [cong del]
228.89 -
228.90 -lemma rename_through_pmap: "[| is_weak_ref_map f C A |]
228.91 - ==> (is_weak_ref_map f (rename C g) (rename A g))"
228.92 -apply (simp add: is_weak_ref_map_def)
228.93 -apply (rule conjI)
228.94 -(* 1: start states *)
228.95 -apply (simp add: rename_def rename_set_def starts_of_def)
228.96 -(* 2: reachable transitions *)
228.97 -apply (rule allI)+
228.98 -apply (rule imp_conj_lemma)
228.99 -apply (simp (no_asm) add: rename_def rename_set_def)
228.100 -apply (simp add: externals_def asig_inputs_def asig_outputs_def asig_of_def trans_of_def)
228.101 -apply safe
228.102 -apply (simplesubst split_if)
228.103 - apply (rule conjI)
228.104 - apply (rule impI)
228.105 - apply (erule disjE)
228.106 - apply (erule exE)
228.107 -apply (erule conjE)
228.108 -(* x is input *)
228.109 - apply (drule sym)
228.110 - apply (drule sym)
228.111 -apply simp
228.112 -apply hypsubst+
228.113 -apply (frule reachable_rename)
228.114 -apply simp
228.115 -(* x is output *)
228.116 - apply (erule exE)
228.117 -apply (erule conjE)
228.118 - apply (drule sym)
228.119 - apply (drule sym)
228.120 -apply simp
228.121 -apply hypsubst+
228.122 -apply (frule reachable_rename)
228.123 -apply simp
228.124 -(* x is internal *)
228.125 -apply (frule reachable_rename)
228.126 -apply auto
228.127 -done
228.128 -
228.129 -declare split_if [split]
228.130 -declare if_weak_cong [cong]
228.131 -
228.132 -end
229.1 --- a/src/HOLCF/IOA/meta_theory/Seq.thy Sat Nov 27 14:34:54 2010 -0800
229.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
229.3 @@ -1,328 +0,0 @@
229.4 -(* Title: HOLCF/IOA/meta_theory/Seq.thy
229.5 - Author: Olaf Müller
229.6 -*)
229.7 -
229.8 -header {* Partial, Finite and Infinite Sequences (lazy lists), modeled as domain *}
229.9 -
229.10 -theory Seq
229.11 -imports HOLCF
229.12 -begin
229.13 -
229.14 -default_sort pcpo
229.15 -
229.16 -domain (unsafe) 'a seq = nil ("nil") | cons (HD :: 'a) (lazy TL :: "'a seq") (infixr "##" 65)
229.17 -
229.18 -(*
229.19 - sfilter :: "('a -> tr) -> 'a seq -> 'a seq"
229.20 - smap :: "('a -> 'b) -> 'a seq -> 'b seq"
229.21 - sforall :: "('a -> tr) => 'a seq => bool"
229.22 - sforall2 :: "('a -> tr) -> 'a seq -> tr"
229.23 - slast :: "'a seq -> 'a"
229.24 - sconc :: "'a seq -> 'a seq -> 'a seq"
229.25 - sdropwhile :: "('a -> tr) -> 'a seq -> 'a seq"
229.26 - stakewhile :: "('a -> tr) -> 'a seq -> 'a seq"
229.27 - szip :: "'a seq -> 'b seq -> ('a*'b) seq"
229.28 - sflat :: "('a seq) seq -> 'a seq"
229.29 -
229.30 - sfinite :: "'a seq set"
229.31 - Partial :: "'a seq => bool"
229.32 - Infinite :: "'a seq => bool"
229.33 -
229.34 - nproj :: "nat => 'a seq => 'a"
229.35 - sproj :: "nat => 'a seq => 'a seq"
229.36 -*)
229.37 -
229.38 -inductive
229.39 - Finite :: "'a seq => bool"
229.40 - where
229.41 - sfinite_0: "Finite nil"
229.42 - | sfinite_n: "[| Finite tr; a~=UU |] ==> Finite (a##tr)"
229.43 -
229.44 -declare Finite.intros [simp]
229.45 -
229.46 -definition
229.47 - Partial :: "'a seq => bool"
229.48 -where
229.49 - "Partial x == (seq_finite x) & ~(Finite x)"
229.50 -
229.51 -definition
229.52 - Infinite :: "'a seq => bool"
229.53 -where
229.54 - "Infinite x == ~(seq_finite x)"
229.55 -
229.56 -
229.57 -subsection {* recursive equations of operators *}
229.58 -
229.59 -subsubsection {* smap *}
229.60 -
229.61 -fixrec
229.62 - smap :: "('a -> 'b) -> 'a seq -> 'b seq"
229.63 -where
229.64 - smap_nil: "smap$f$nil=nil"
229.65 -| smap_cons: "[|x~=UU|] ==> smap$f$(x##xs)= (f$x)##smap$f$xs"
229.66 -
229.67 -lemma smap_UU [simp]: "smap$f$UU=UU"
229.68 -by fixrec_simp
229.69 -
229.70 -subsubsection {* sfilter *}
229.71 -
229.72 -fixrec
229.73 - sfilter :: "('a -> tr) -> 'a seq -> 'a seq"
229.74 -where
229.75 - sfilter_nil: "sfilter$P$nil=nil"
229.76 -| sfilter_cons:
229.77 - "x~=UU ==> sfilter$P$(x##xs)=
229.78 - (If P$x then x##(sfilter$P$xs) else sfilter$P$xs)"
229.79 -
229.80 -lemma sfilter_UU [simp]: "sfilter$P$UU=UU"
229.81 -by fixrec_simp
229.82 -
229.83 -subsubsection {* sforall2 *}
229.84 -
229.85 -fixrec
229.86 - sforall2 :: "('a -> tr) -> 'a seq -> tr"
229.87 -where
229.88 - sforall2_nil: "sforall2$P$nil=TT"
229.89 -| sforall2_cons:
229.90 - "x~=UU ==> sforall2$P$(x##xs)= ((P$x) andalso sforall2$P$xs)"
229.91 -
229.92 -lemma sforall2_UU [simp]: "sforall2$P$UU=UU"
229.93 -by fixrec_simp
229.94 -
229.95 -definition
229.96 - sforall_def: "sforall P t == (sforall2$P$t ~=FF)"
229.97 -
229.98 -subsubsection {* stakewhile *}
229.99 -
229.100 -fixrec
229.101 - stakewhile :: "('a -> tr) -> 'a seq -> 'a seq"
229.102 -where
229.103 - stakewhile_nil: "stakewhile$P$nil=nil"
229.104 -| stakewhile_cons:
229.105 - "x~=UU ==> stakewhile$P$(x##xs) =
229.106 - (If P$x then x##(stakewhile$P$xs) else nil)"
229.107 -
229.108 -lemma stakewhile_UU [simp]: "stakewhile$P$UU=UU"
229.109 -by fixrec_simp
229.110 -
229.111 -subsubsection {* sdropwhile *}
229.112 -
229.113 -fixrec
229.114 - sdropwhile :: "('a -> tr) -> 'a seq -> 'a seq"
229.115 -where
229.116 - sdropwhile_nil: "sdropwhile$P$nil=nil"
229.117 -| sdropwhile_cons:
229.118 - "x~=UU ==> sdropwhile$P$(x##xs) =
229.119 - (If P$x then sdropwhile$P$xs else x##xs)"
229.120 -
229.121 -lemma sdropwhile_UU [simp]: "sdropwhile$P$UU=UU"
229.122 -by fixrec_simp
229.123 -
229.124 -subsubsection {* slast *}
229.125 -
229.126 -fixrec
229.127 - slast :: "'a seq -> 'a"
229.128 -where
229.129 - slast_nil: "slast$nil=UU"
229.130 -| slast_cons:
229.131 - "x~=UU ==> slast$(x##xs)= (If is_nil$xs then x else slast$xs)"
229.132 -
229.133 -lemma slast_UU [simp]: "slast$UU=UU"
229.134 -by fixrec_simp
229.135 -
229.136 -subsubsection {* sconc *}
229.137 -
229.138 -fixrec
229.139 - sconc :: "'a seq -> 'a seq -> 'a seq"
229.140 -where
229.141 - sconc_nil: "sconc$nil$y = y"
229.142 -| sconc_cons':
229.143 - "x~=UU ==> sconc$(x##xs)$y = x##(sconc$xs$y)"
229.144 -
229.145 -abbreviation
229.146 - sconc_syn :: "'a seq => 'a seq => 'a seq" (infixr "@@" 65) where
229.147 - "xs @@ ys == sconc $ xs $ ys"
229.148 -
229.149 -lemma sconc_UU [simp]: "UU @@ y=UU"
229.150 -by fixrec_simp
229.151 -
229.152 -lemma sconc_cons [simp]: "(x##xs) @@ y=x##(xs @@ y)"
229.153 -apply (cases "x=UU")
229.154 -apply simp_all
229.155 -done
229.156 -
229.157 -declare sconc_cons' [simp del]
229.158 -
229.159 -subsubsection {* sflat *}
229.160 -
229.161 -fixrec
229.162 - sflat :: "('a seq) seq -> 'a seq"
229.163 -where
229.164 - sflat_nil: "sflat$nil=nil"
229.165 -| sflat_cons': "x~=UU ==> sflat$(x##xs)= x@@(sflat$xs)"
229.166 -
229.167 -lemma sflat_UU [simp]: "sflat$UU=UU"
229.168 -by fixrec_simp
229.169 -
229.170 -lemma sflat_cons [simp]: "sflat$(x##xs)= x@@(sflat$xs)"
229.171 -by (cases "x=UU", simp_all)
229.172 -
229.173 -declare sflat_cons' [simp del]
229.174 -
229.175 -subsubsection {* szip *}
229.176 -
229.177 -fixrec
229.178 - szip :: "'a seq -> 'b seq -> ('a*'b) seq"
229.179 -where
229.180 - szip_nil: "szip$nil$y=nil"
229.181 -| szip_cons_nil: "x~=UU ==> szip$(x##xs)$nil=UU"
229.182 -| szip_cons:
229.183 - "[| x~=UU; y~=UU|] ==> szip$(x##xs)$(y##ys) = (x,y)##szip$xs$ys"
229.184 -
229.185 -lemma szip_UU1 [simp]: "szip$UU$y=UU"
229.186 -by fixrec_simp
229.187 -
229.188 -lemma szip_UU2 [simp]: "x~=nil ==> szip$x$UU=UU"
229.189 -by (cases x, simp_all, fixrec_simp)
229.190 -
229.191 -
229.192 -subsection "scons, nil"
229.193 -
229.194 -lemma scons_inject_eq:
229.195 - "[|x~=UU;y~=UU|]==> (x##xs=y##ys) = (x=y & xs=ys)"
229.196 -by simp
229.197 -
229.198 -lemma nil_less_is_nil: "nil<<x ==> nil=x"
229.199 -apply (cases x)
229.200 -apply simp
229.201 -apply simp
229.202 -apply simp
229.203 -done
229.204 -
229.205 -subsection "sfilter, sforall, sconc"
229.206 -
229.207 -lemma if_and_sconc [simp]: "(if b then tr1 else tr2) @@ tr
229.208 - = (if b then tr1 @@ tr else tr2 @@ tr)"
229.209 -by simp
229.210 -
229.211 -
229.212 -lemma sfiltersconc: "sfilter$P$(x @@ y) = (sfilter$P$x @@ sfilter$P$y)"
229.213 -apply (induct x)
229.214 -(* adm *)
229.215 -apply simp
229.216 -(* base cases *)
229.217 -apply simp
229.218 -apply simp
229.219 -(* main case *)
229.220 -apply (rule_tac p="P$a" in trE)
229.221 -apply simp
229.222 -apply simp
229.223 -apply simp
229.224 -done
229.225 -
229.226 -lemma sforallPstakewhileP: "sforall P (stakewhile$P$x)"
229.227 -apply (simp add: sforall_def)
229.228 -apply (induct x)
229.229 -(* adm *)
229.230 -apply simp
229.231 -(* base cases *)
229.232 -apply simp
229.233 -apply simp
229.234 -(* main case *)
229.235 -apply (rule_tac p="P$a" in trE)
229.236 -apply simp
229.237 -apply simp
229.238 -apply simp
229.239 -done
229.240 -
229.241 -lemma forallPsfilterP: "sforall P (sfilter$P$x)"
229.242 -apply (simp add: sforall_def)
229.243 -apply (induct x)
229.244 -(* adm *)
229.245 -apply simp
229.246 -(* base cases *)
229.247 -apply simp
229.248 -apply simp
229.249 -(* main case *)
229.250 -apply (rule_tac p="P$a" in trE)
229.251 -apply simp
229.252 -apply simp
229.253 -apply simp
229.254 -done
229.255 -
229.256 -
229.257 -subsection "Finite"
229.258 -
229.259 -(* ---------------------------------------------------- *)
229.260 -(* Proofs of rewrite rules for Finite: *)
229.261 -(* 1. Finite(nil), (by definition) *)
229.262 -(* 2. ~Finite(UU), *)
229.263 -(* 3. a~=UU==> Finite(a##x)=Finite(x) *)
229.264 -(* ---------------------------------------------------- *)
229.265 -
229.266 -lemma Finite_UU_a: "Finite x --> x~=UU"
229.267 -apply (rule impI)
229.268 -apply (erule Finite.induct)
229.269 - apply simp
229.270 -apply simp
229.271 -done
229.272 -
229.273 -lemma Finite_UU [simp]: "~(Finite UU)"
229.274 -apply (cut_tac x="UU" in Finite_UU_a)
229.275 -apply fast
229.276 -done
229.277 -
229.278 -lemma Finite_cons_a: "Finite x --> a~=UU --> x=a##xs --> Finite xs"
229.279 -apply (intro strip)
229.280 -apply (erule Finite.cases)
229.281 -apply fastsimp
229.282 -apply simp
229.283 -done
229.284 -
229.285 -lemma Finite_cons: "a~=UU ==>(Finite (a##x)) = (Finite x)"
229.286 -apply (rule iffI)
229.287 -apply (erule (1) Finite_cons_a [rule_format])
229.288 -apply fast
229.289 -apply simp
229.290 -done
229.291 -
229.292 -lemma Finite_upward: "\<lbrakk>Finite x; x \<sqsubseteq> y\<rbrakk> \<Longrightarrow> Finite y"
229.293 -apply (induct arbitrary: y set: Finite)
229.294 -apply (case_tac y, simp, simp, simp)
229.295 -apply (case_tac y, simp, simp)
229.296 -apply simp
229.297 -done
229.298 -
229.299 -lemma adm_Finite [simp]: "adm Finite"
229.300 -by (rule adm_upward, rule Finite_upward)
229.301 -
229.302 -
229.303 -subsection "induction"
229.304 -
229.305 -
229.306 -(*-------------------------------- *)
229.307 -(* Extensions to Induction Theorems *)
229.308 -(*-------------------------------- *)
229.309 -
229.310 -
229.311 -lemma seq_finite_ind_lemma:
229.312 - assumes "(!!n. P(seq_take n$s))"
229.313 - shows "seq_finite(s) -->P(s)"
229.314 -apply (unfold seq.finite_def)
229.315 -apply (intro strip)
229.316 -apply (erule exE)
229.317 -apply (erule subst)
229.318 -apply (rule prems)
229.319 -done
229.320 -
229.321 -
229.322 -lemma seq_finite_ind: "!!P.[|P(UU);P(nil);
229.323 - !! x s1.[|x~=UU;P(s1)|] ==> P(x##s1)
229.324 - |] ==> seq_finite(s) --> P(s)"
229.325 -apply (rule seq_finite_ind_lemma)
229.326 -apply (erule seq.finite_induct)
229.327 - apply assumption
229.328 -apply simp
229.329 -done
229.330 -
229.331 -end
230.1 --- a/src/HOLCF/IOA/meta_theory/Sequence.thy Sat Nov 27 14:34:54 2010 -0800
230.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
230.3 @@ -1,1118 +0,0 @@
230.4 -(* Title: HOLCF/IOA/meta_theory/Sequence.thy
230.5 - Author: Olaf Müller
230.6 -
230.7 -Sequences over flat domains with lifted elements.
230.8 -*)
230.9 -
230.10 -theory Sequence
230.11 -imports Seq
230.12 -begin
230.13 -
230.14 -default_sort type
230.15 -
230.16 -types 'a Seq = "'a lift seq"
230.17 -
230.18 -consts
230.19 -
230.20 - Consq ::"'a => 'a Seq -> 'a Seq"
230.21 - Filter ::"('a => bool) => 'a Seq -> 'a Seq"
230.22 - Map ::"('a => 'b) => 'a Seq -> 'b Seq"
230.23 - Forall ::"('a => bool) => 'a Seq => bool"
230.24 - Last ::"'a Seq -> 'a lift"
230.25 - Dropwhile ::"('a => bool) => 'a Seq -> 'a Seq"
230.26 - Takewhile ::"('a => bool) => 'a Seq -> 'a Seq"
230.27 - Zip ::"'a Seq -> 'b Seq -> ('a * 'b) Seq"
230.28 - Flat ::"('a Seq) seq -> 'a Seq"
230.29 -
230.30 - Filter2 ::"('a => bool) => 'a Seq -> 'a Seq"
230.31 -
230.32 -abbreviation
230.33 - Consq_syn ("(_/>>_)" [66,65] 65) where
230.34 - "a>>s == Consq a$s"
230.35 -
230.36 -notation (xsymbols)
230.37 - Consq_syn ("(_\<leadsto>_)" [66,65] 65)
230.38 -
230.39 -
230.40 -(* list Enumeration *)
230.41 -syntax
230.42 - "_totlist" :: "args => 'a Seq" ("[(_)!]")
230.43 - "_partlist" :: "args => 'a Seq" ("[(_)?]")
230.44 -translations
230.45 - "[x, xs!]" == "x>>[xs!]"
230.46 - "[x!]" == "x>>nil"
230.47 - "[x, xs?]" == "x>>[xs?]"
230.48 - "[x?]" == "x>>CONST UU"
230.49 -
230.50 -defs
230.51 -
230.52 -Consq_def: "Consq a == LAM s. Def a ## s"
230.53 -
230.54 -Filter_def: "Filter P == sfilter$(flift2 P)"
230.55 -
230.56 -Map_def: "Map f == smap$(flift2 f)"
230.57 -
230.58 -Forall_def: "Forall P == sforall (flift2 P)"
230.59 -
230.60 -Last_def: "Last == slast"
230.61 -
230.62 -Dropwhile_def: "Dropwhile P == sdropwhile$(flift2 P)"
230.63 -
230.64 -Takewhile_def: "Takewhile P == stakewhile$(flift2 P)"
230.65 -
230.66 -Flat_def: "Flat == sflat"
230.67 -
230.68 -Zip_def:
230.69 - "Zip == (fix$(LAM h t1 t2. case t1 of
230.70 - nil => nil
230.71 - | x##xs => (case t2 of
230.72 - nil => UU
230.73 - | y##ys => (case x of
230.74 - UU => UU
230.75 - | Def a => (case y of
230.76 - UU => UU
230.77 - | Def b => Def (a,b)##(h$xs$ys))))))"
230.78 -
230.79 -Filter2_def: "Filter2 P == (fix$(LAM h t. case t of
230.80 - nil => nil
230.81 - | x##xs => (case x of UU => UU | Def y => (if P y
230.82 - then x##(h$xs)
230.83 - else h$xs))))"
230.84 -
230.85 -declare andalso_and [simp]
230.86 -declare andalso_or [simp]
230.87 -
230.88 -subsection "recursive equations of operators"
230.89 -
230.90 -subsubsection "Map"
230.91 -
230.92 -lemma Map_UU: "Map f$UU =UU"
230.93 -by (simp add: Map_def)
230.94 -
230.95 -lemma Map_nil: "Map f$nil =nil"
230.96 -by (simp add: Map_def)
230.97 -
230.98 -lemma Map_cons: "Map f$(x>>xs)=(f x) >> Map f$xs"
230.99 -by (simp add: Map_def Consq_def flift2_def)
230.100 -
230.101 -
230.102 -subsubsection {* Filter *}
230.103 -
230.104 -lemma Filter_UU: "Filter P$UU =UU"
230.105 -by (simp add: Filter_def)
230.106 -
230.107 -lemma Filter_nil: "Filter P$nil =nil"
230.108 -by (simp add: Filter_def)
230.109 -
230.110 -lemma Filter_cons:
230.111 - "Filter P$(x>>xs)= (if P x then x>>(Filter P$xs) else Filter P$xs)"
230.112 -by (simp add: Filter_def Consq_def flift2_def If_and_if)
230.113 -
230.114 -
230.115 -subsubsection {* Forall *}
230.116 -
230.117 -lemma Forall_UU: "Forall P UU"
230.118 -by (simp add: Forall_def sforall_def)
230.119 -
230.120 -lemma Forall_nil: "Forall P nil"
230.121 -by (simp add: Forall_def sforall_def)
230.122 -
230.123 -lemma Forall_cons: "Forall P (x>>xs)= (P x & Forall P xs)"
230.124 -by (simp add: Forall_def sforall_def Consq_def flift2_def)
230.125 -
230.126 -
230.127 -subsubsection {* Conc *}
230.128 -
230.129 -lemma Conc_cons: "(x>>xs) @@ y = x>>(xs @@y)"
230.130 -by (simp add: Consq_def)
230.131 -
230.132 -
230.133 -subsubsection {* Takewhile *}
230.134 -
230.135 -lemma Takewhile_UU: "Takewhile P$UU =UU"
230.136 -by (simp add: Takewhile_def)
230.137 -
230.138 -lemma Takewhile_nil: "Takewhile P$nil =nil"
230.139 -by (simp add: Takewhile_def)
230.140 -
230.141 -lemma Takewhile_cons:
230.142 - "Takewhile P$(x>>xs)= (if P x then x>>(Takewhile P$xs) else nil)"
230.143 -by (simp add: Takewhile_def Consq_def flift2_def If_and_if)
230.144 -
230.145 -
230.146 -subsubsection {* DropWhile *}
230.147 -
230.148 -lemma Dropwhile_UU: "Dropwhile P$UU =UU"
230.149 -by (simp add: Dropwhile_def)
230.150 -
230.151 -lemma Dropwhile_nil: "Dropwhile P$nil =nil"
230.152 -by (simp add: Dropwhile_def)
230.153 -
230.154 -lemma Dropwhile_cons:
230.155 - "Dropwhile P$(x>>xs)= (if P x then Dropwhile P$xs else x>>xs)"
230.156 -by (simp add: Dropwhile_def Consq_def flift2_def If_and_if)
230.157 -
230.158 -
230.159 -subsubsection {* Last *}
230.160 -
230.161 -lemma Last_UU: "Last$UU =UU"
230.162 -by (simp add: Last_def)
230.163 -
230.164 -lemma Last_nil: "Last$nil =UU"
230.165 -by (simp add: Last_def)
230.166 -
230.167 -lemma Last_cons: "Last$(x>>xs)= (if xs=nil then Def x else Last$xs)"
230.168 -apply (simp add: Last_def Consq_def)
230.169 -apply (cases xs)
230.170 -apply simp_all
230.171 -done
230.172 -
230.173 -
230.174 -subsubsection {* Flat *}
230.175 -
230.176 -lemma Flat_UU: "Flat$UU =UU"
230.177 -by (simp add: Flat_def)
230.178 -
230.179 -lemma Flat_nil: "Flat$nil =nil"
230.180 -by (simp add: Flat_def)
230.181 -
230.182 -lemma Flat_cons: "Flat$(x##xs)= x @@ (Flat$xs)"
230.183 -by (simp add: Flat_def Consq_def)
230.184 -
230.185 -
230.186 -subsubsection {* Zip *}
230.187 -
230.188 -lemma Zip_unfold:
230.189 -"Zip = (LAM t1 t2. case t1 of
230.190 - nil => nil
230.191 - | x##xs => (case t2 of
230.192 - nil => UU
230.193 - | y##ys => (case x of
230.194 - UU => UU
230.195 - | Def a => (case y of
230.196 - UU => UU
230.197 - | Def b => Def (a,b)##(Zip$xs$ys)))))"
230.198 -apply (rule trans)
230.199 -apply (rule fix_eq2)
230.200 -apply (rule Zip_def)
230.201 -apply (rule beta_cfun)
230.202 -apply simp
230.203 -done
230.204 -
230.205 -lemma Zip_UU1: "Zip$UU$y =UU"
230.206 -apply (subst Zip_unfold)
230.207 -apply simp
230.208 -done
230.209 -
230.210 -lemma Zip_UU2: "x~=nil ==> Zip$x$UU =UU"
230.211 -apply (subst Zip_unfold)
230.212 -apply simp
230.213 -apply (cases x)
230.214 -apply simp_all
230.215 -done
230.216 -
230.217 -lemma Zip_nil: "Zip$nil$y =nil"
230.218 -apply (subst Zip_unfold)
230.219 -apply simp
230.220 -done
230.221 -
230.222 -lemma Zip_cons_nil: "Zip$(x>>xs)$nil= UU"
230.223 -apply (subst Zip_unfold)
230.224 -apply (simp add: Consq_def)
230.225 -done
230.226 -
230.227 -lemma Zip_cons: "Zip$(x>>xs)$(y>>ys)= (x,y) >> Zip$xs$ys"
230.228 -apply (rule trans)
230.229 -apply (subst Zip_unfold)
230.230 -apply simp
230.231 -apply (simp add: Consq_def)
230.232 -done
230.233 -
230.234 -lemmas [simp del] =
230.235 - sfilter_UU sfilter_nil sfilter_cons
230.236 - smap_UU smap_nil smap_cons
230.237 - sforall2_UU sforall2_nil sforall2_cons
230.238 - slast_UU slast_nil slast_cons
230.239 - stakewhile_UU stakewhile_nil stakewhile_cons
230.240 - sdropwhile_UU sdropwhile_nil sdropwhile_cons
230.241 - sflat_UU sflat_nil sflat_cons
230.242 - szip_UU1 szip_UU2 szip_nil szip_cons_nil szip_cons
230.243 -
230.244 -lemmas [simp] =
230.245 - Filter_UU Filter_nil Filter_cons
230.246 - Map_UU Map_nil Map_cons
230.247 - Forall_UU Forall_nil Forall_cons
230.248 - Last_UU Last_nil Last_cons
230.249 - Conc_cons
230.250 - Takewhile_UU Takewhile_nil Takewhile_cons
230.251 - Dropwhile_UU Dropwhile_nil Dropwhile_cons
230.252 - Zip_UU1 Zip_UU2 Zip_nil Zip_cons_nil Zip_cons
230.253 -
230.254 -
230.255 -
230.256 -section "Cons"
230.257 -
230.258 -lemma Consq_def2: "a>>s = (Def a)##s"
230.259 -apply (simp add: Consq_def)
230.260 -done
230.261 -
230.262 -lemma Seq_exhaust: "x = UU | x = nil | (? a s. x = a >> s)"
230.263 -apply (simp add: Consq_def2)
230.264 -apply (cut_tac seq.nchotomy)
230.265 -apply (fast dest: not_Undef_is_Def [THEN iffD1])
230.266 -done
230.267 -
230.268 -
230.269 -lemma Seq_cases:
230.270 -"!!P. [| x = UU ==> P; x = nil ==> P; !!a s. x = a >> s ==> P |] ==> P"
230.271 -apply (cut_tac x="x" in Seq_exhaust)
230.272 -apply (erule disjE)
230.273 -apply simp
230.274 -apply (erule disjE)
230.275 -apply simp
230.276 -apply (erule exE)+
230.277 -apply simp
230.278 -done
230.279 -
230.280 -(*
230.281 -fun Seq_case_tac s i = rule_tac x",s)] Seq_cases i
230.282 - THEN hyp_subst_tac i THEN hyp_subst_tac (i+1) THEN hyp_subst_tac (i+2);
230.283 -*)
230.284 -(* on a>>s only simp_tac, as full_simp_tac is uncomplete and often causes errors *)
230.285 -(*
230.286 -fun Seq_case_simp_tac s i = Seq_case_tac s i THEN Asm_simp_tac (i+2)
230.287 - THEN Asm_full_simp_tac (i+1)
230.288 - THEN Asm_full_simp_tac i;
230.289 -*)
230.290 -
230.291 -lemma Cons_not_UU: "a>>s ~= UU"
230.292 -apply (subst Consq_def2)
230.293 -apply simp
230.294 -done
230.295 -
230.296 -
230.297 -lemma Cons_not_less_UU: "~(a>>x) << UU"
230.298 -apply (rule notI)
230.299 -apply (drule below_antisym)
230.300 -apply simp
230.301 -apply (simp add: Cons_not_UU)
230.302 -done
230.303 -
230.304 -lemma Cons_not_less_nil: "~a>>s << nil"
230.305 -apply (simp add: Consq_def2)
230.306 -done
230.307 -
230.308 -lemma Cons_not_nil: "a>>s ~= nil"
230.309 -apply (simp add: Consq_def2)
230.310 -done
230.311 -
230.312 -lemma Cons_not_nil2: "nil ~= a>>s"
230.313 -apply (simp add: Consq_def2)
230.314 -done
230.315 -
230.316 -lemma Cons_inject_eq: "(a>>s = b>>t) = (a = b & s = t)"
230.317 -apply (simp only: Consq_def2)
230.318 -apply (simp add: scons_inject_eq)
230.319 -done
230.320 -
230.321 -lemma Cons_inject_less_eq: "(a>>s<<b>>t) = (a = b & s<<t)"
230.322 -apply (simp add: Consq_def2)
230.323 -done
230.324 -
230.325 -lemma seq_take_Cons: "seq_take (Suc n)$(a>>x) = a>> (seq_take n$x)"
230.326 -apply (simp add: Consq_def)
230.327 -done
230.328 -
230.329 -lemmas [simp] =
230.330 - Cons_not_nil2 Cons_inject_eq Cons_inject_less_eq seq_take_Cons
230.331 - Cons_not_UU Cons_not_less_UU Cons_not_less_nil Cons_not_nil
230.332 -
230.333 -
230.334 -subsection "induction"
230.335 -
230.336 -lemma Seq_induct:
230.337 -"!! P. [| adm P; P UU; P nil; !! a s. P s ==> P (a>>s)|] ==> P x"
230.338 -apply (erule (2) seq.induct)
230.339 -apply defined
230.340 -apply (simp add: Consq_def)
230.341 -done
230.342 -
230.343 -lemma Seq_FinitePartial_ind:
230.344 -"!! P.[|P UU;P nil; !! a s. P s ==> P(a>>s) |]
230.345 - ==> seq_finite x --> P x"
230.346 -apply (erule (1) seq_finite_ind)
230.347 -apply defined
230.348 -apply (simp add: Consq_def)
230.349 -done
230.350 -
230.351 -lemma Seq_Finite_ind:
230.352 -"!! P.[| Finite x; P nil; !! a s. [| Finite s; P s|] ==> P (a>>s) |] ==> P x"
230.353 -apply (erule (1) Finite.induct)
230.354 -apply defined
230.355 -apply (simp add: Consq_def)
230.356 -done
230.357 -
230.358 -
230.359 -(* rws are definitions to be unfolded for admissibility check *)
230.360 -(*
230.361 -fun Seq_induct_tac s rws i = rule_tac x",s)] Seq_induct i
230.362 - THEN (REPEAT_DETERM (CHANGED (Asm_simp_tac (i+1))))
230.363 - THEN simp add: rws) i;
230.364 -
230.365 -fun Seq_Finite_induct_tac i = erule Seq_Finite_ind i
230.366 - THEN (REPEAT_DETERM (CHANGED (Asm_simp_tac i)));
230.367 -
230.368 -fun pair_tac s = rule_tac p",s)] PairE
230.369 - THEN' hyp_subst_tac THEN' Simp_tac;
230.370 -*)
230.371 -(* induction on a sequence of pairs with pairsplitting and simplification *)
230.372 -(*
230.373 -fun pair_induct_tac s rws i =
230.374 - rule_tac x",s)] Seq_induct i
230.375 - THEN pair_tac "a" (i+3)
230.376 - THEN (REPEAT_DETERM (CHANGED (Simp_tac (i+1))))
230.377 - THEN simp add: rws) i;
230.378 -*)
230.379 -
230.380 -
230.381 -(* ------------------------------------------------------------------------------------ *)
230.382 -
230.383 -subsection "HD,TL"
230.384 -
230.385 -lemma HD_Cons [simp]: "HD$(x>>y) = Def x"
230.386 -apply (simp add: Consq_def)
230.387 -done
230.388 -
230.389 -lemma TL_Cons [simp]: "TL$(x>>y) = y"
230.390 -apply (simp add: Consq_def)
230.391 -done
230.392 -
230.393 -(* ------------------------------------------------------------------------------------ *)
230.394 -
230.395 -subsection "Finite, Partial, Infinite"
230.396 -
230.397 -lemma Finite_Cons [simp]: "Finite (a>>xs) = Finite xs"
230.398 -apply (simp add: Consq_def2 Finite_cons)
230.399 -done
230.400 -
230.401 -lemma FiniteConc_1: "Finite (x::'a Seq) ==> Finite y --> Finite (x@@y)"
230.402 -apply (erule Seq_Finite_ind, simp_all)
230.403 -done
230.404 -
230.405 -lemma FiniteConc_2:
230.406 -"Finite (z::'a Seq) ==> !x y. z= x@@y --> (Finite x & Finite y)"
230.407 -apply (erule Seq_Finite_ind)
230.408 -(* nil*)
230.409 -apply (intro strip)
230.410 -apply (rule_tac x="x" in Seq_cases, simp_all)
230.411 -(* cons *)
230.412 -apply (intro strip)
230.413 -apply (rule_tac x="x" in Seq_cases, simp_all)
230.414 -apply (rule_tac x="y" in Seq_cases, simp_all)
230.415 -done
230.416 -
230.417 -lemma FiniteConc [simp]: "Finite(x@@y) = (Finite (x::'a Seq) & Finite y)"
230.418 -apply (rule iffI)
230.419 -apply (erule FiniteConc_2 [rule_format])
230.420 -apply (rule refl)
230.421 -apply (rule FiniteConc_1 [rule_format])
230.422 -apply auto
230.423 -done
230.424 -
230.425 -
230.426 -lemma FiniteMap1: "Finite s ==> Finite (Map f$s)"
230.427 -apply (erule Seq_Finite_ind, simp_all)
230.428 -done
230.429 -
230.430 -lemma FiniteMap2: "Finite s ==> ! t. (s = Map f$t) --> Finite t"
230.431 -apply (erule Seq_Finite_ind)
230.432 -apply (intro strip)
230.433 -apply (rule_tac x="t" in Seq_cases, simp_all)
230.434 -(* main case *)
230.435 -apply auto
230.436 -apply (rule_tac x="t" in Seq_cases, simp_all)
230.437 -done
230.438 -
230.439 -lemma Map2Finite: "Finite (Map f$s) = Finite s"
230.440 -apply auto
230.441 -apply (erule FiniteMap2 [rule_format])
230.442 -apply (rule refl)
230.443 -apply (erule FiniteMap1)
230.444 -done
230.445 -
230.446 -
230.447 -lemma FiniteFilter: "Finite s ==> Finite (Filter P$s)"
230.448 -apply (erule Seq_Finite_ind, simp_all)
230.449 -done
230.450 -
230.451 -
230.452 -(* ----------------------------------------------------------------------------------- *)
230.453 -
230.454 -subsection "Conc"
230.455 -
230.456 -lemma Conc_cong: "!! x::'a Seq. Finite x ==> ((x @@ y) = (x @@ z)) = (y = z)"
230.457 -apply (erule Seq_Finite_ind, simp_all)
230.458 -done
230.459 -
230.460 -lemma Conc_assoc: "(x @@ y) @@ z = (x::'a Seq) @@ y @@ z"
230.461 -apply (rule_tac x="x" in Seq_induct, simp_all)
230.462 -done
230.463 -
230.464 -lemma nilConc [simp]: "s@@ nil = s"
230.465 -apply (induct s)
230.466 -apply simp
230.467 -apply simp
230.468 -apply simp
230.469 -apply simp
230.470 -done
230.471 -
230.472 -
230.473 -(* should be same as nil_is_Conc2 when all nils are turned to right side !! *)
230.474 -lemma nil_is_Conc: "(nil = x @@ y) = ((x::'a Seq)= nil & y = nil)"
230.475 -apply (rule_tac x="x" in Seq_cases)
230.476 -apply auto
230.477 -done
230.478 -
230.479 -lemma nil_is_Conc2: "(x @@ y = nil) = ((x::'a Seq)= nil & y = nil)"
230.480 -apply (rule_tac x="x" in Seq_cases)
230.481 -apply auto
230.482 -done
230.483 -
230.484 -
230.485 -(* ------------------------------------------------------------------------------------ *)
230.486 -
230.487 -subsection "Last"
230.488 -
230.489 -lemma Finite_Last1: "Finite s ==> s~=nil --> Last$s~=UU"
230.490 -apply (erule Seq_Finite_ind, simp_all)
230.491 -done
230.492 -
230.493 -lemma Finite_Last2: "Finite s ==> Last$s=UU --> s=nil"
230.494 -apply (erule Seq_Finite_ind, simp_all)
230.495 -apply fast
230.496 -done
230.497 -
230.498 -
230.499 -(* ------------------------------------------------------------------------------------ *)
230.500 -
230.501 -
230.502 -subsection "Filter, Conc"
230.503 -
230.504 -
230.505 -lemma FilterPQ: "Filter P$(Filter Q$s) = Filter (%x. P x & Q x)$s"
230.506 -apply (rule_tac x="s" in Seq_induct, simp_all)
230.507 -done
230.508 -
230.509 -lemma FilterConc: "Filter P$(x @@ y) = (Filter P$x @@ Filter P$y)"
230.510 -apply (simp add: Filter_def sfiltersconc)
230.511 -done
230.512 -
230.513 -(* ------------------------------------------------------------------------------------ *)
230.514 -
230.515 -subsection "Map"
230.516 -
230.517 -lemma MapMap: "Map f$(Map g$s) = Map (f o g)$s"
230.518 -apply (rule_tac x="s" in Seq_induct, simp_all)
230.519 -done
230.520 -
230.521 -lemma MapConc: "Map f$(x@@y) = (Map f$x) @@ (Map f$y)"
230.522 -apply (rule_tac x="x" in Seq_induct, simp_all)
230.523 -done
230.524 -
230.525 -lemma MapFilter: "Filter P$(Map f$x) = Map f$(Filter (P o f)$x)"
230.526 -apply (rule_tac x="x" in Seq_induct, simp_all)
230.527 -done
230.528 -
230.529 -lemma nilMap: "nil = (Map f$s) --> s= nil"
230.530 -apply (rule_tac x="s" in Seq_cases, simp_all)
230.531 -done
230.532 -
230.533 -
230.534 -lemma ForallMap: "Forall P (Map f$s) = Forall (P o f) s"
230.535 -apply (rule_tac x="s" in Seq_induct)
230.536 -apply (simp add: Forall_def sforall_def)
230.537 -apply simp_all
230.538 -done
230.539 -
230.540 -
230.541 -
230.542 -
230.543 -(* ------------------------------------------------------------------------------------ *)
230.544 -
230.545 -subsection "Forall"
230.546 -
230.547 -
230.548 -lemma ForallPForallQ1: "Forall P ys & (! x. P x --> Q x)
230.549 - --> Forall Q ys"
230.550 -apply (rule_tac x="ys" in Seq_induct)
230.551 -apply (simp add: Forall_def sforall_def)
230.552 -apply simp_all
230.553 -done
230.554 -
230.555 -lemmas ForallPForallQ =
230.556 - ForallPForallQ1 [THEN mp, OF conjI, OF _ allI, OF _ impI]
230.557 -
230.558 -lemma Forall_Conc_impl: "(Forall P x & Forall P y) --> Forall P (x @@ y)"
230.559 -apply (rule_tac x="x" in Seq_induct)
230.560 -apply (simp add: Forall_def sforall_def)
230.561 -apply simp_all
230.562 -done
230.563 -
230.564 -lemma Forall_Conc [simp]:
230.565 - "Finite x ==> Forall P (x @@ y) = (Forall P x & Forall P y)"
230.566 -apply (erule Seq_Finite_ind, simp_all)
230.567 -done
230.568 -
230.569 -lemma ForallTL1: "Forall P s --> Forall P (TL$s)"
230.570 -apply (rule_tac x="s" in Seq_induct)
230.571 -apply (simp add: Forall_def sforall_def)
230.572 -apply simp_all
230.573 -done
230.574 -
230.575 -lemmas ForallTL = ForallTL1 [THEN mp]
230.576 -
230.577 -lemma ForallDropwhile1: "Forall P s --> Forall P (Dropwhile Q$s)"
230.578 -apply (rule_tac x="s" in Seq_induct)
230.579 -apply (simp add: Forall_def sforall_def)
230.580 -apply simp_all
230.581 -done
230.582 -
230.583 -lemmas ForallDropwhile = ForallDropwhile1 [THEN mp]
230.584 -
230.585 -
230.586 -(* only admissible in t, not if done in s *)
230.587 -
230.588 -lemma Forall_prefix: "! s. Forall P s --> t<<s --> Forall P t"
230.589 -apply (rule_tac x="t" in Seq_induct)
230.590 -apply (simp add: Forall_def sforall_def)
230.591 -apply simp_all
230.592 -apply (intro strip)
230.593 -apply (rule_tac x="sa" in Seq_cases)
230.594 -apply simp
230.595 -apply auto
230.596 -done
230.597 -
230.598 -lemmas Forall_prefixclosed = Forall_prefix [rule_format]
230.599 -
230.600 -lemma Forall_postfixclosed:
230.601 - "[| Finite h; Forall P s; s= h @@ t |] ==> Forall P t"
230.602 -apply auto
230.603 -done
230.604 -
230.605 -
230.606 -lemma ForallPFilterQR1:
230.607 - "((! x. P x --> (Q x = R x)) & Forall P tr) --> Filter Q$tr = Filter R$tr"
230.608 -apply (rule_tac x="tr" in Seq_induct)
230.609 -apply (simp add: Forall_def sforall_def)
230.610 -apply simp_all
230.611 -done
230.612 -
230.613 -lemmas ForallPFilterQR = ForallPFilterQR1 [THEN mp, OF conjI, OF allI]
230.614 -
230.615 -
230.616 -(* ------------------------------------------------------------------------------------- *)
230.617 -
230.618 -subsection "Forall, Filter"
230.619 -
230.620 -
230.621 -lemma ForallPFilterP: "Forall P (Filter P$x)"
230.622 -apply (simp add: Filter_def Forall_def forallPsfilterP)
230.623 -done
230.624 -
230.625 -(* holds also in other direction, then equal to forallPfilterP *)
230.626 -lemma ForallPFilterPid1: "Forall P x --> Filter P$x = x"
230.627 -apply (rule_tac x="x" in Seq_induct)
230.628 -apply (simp add: Forall_def sforall_def Filter_def)
230.629 -apply simp_all
230.630 -done
230.631 -
230.632 -lemmas ForallPFilterPid = ForallPFilterPid1 [THEN mp]
230.633 -
230.634 -
230.635 -(* holds also in other direction *)
230.636 -lemma ForallnPFilterPnil1: "!! ys . Finite ys ==>
230.637 - Forall (%x. ~P x) ys --> Filter P$ys = nil "
230.638 -apply (erule Seq_Finite_ind, simp_all)
230.639 -done
230.640 -
230.641 -lemmas ForallnPFilterPnil = ForallnPFilterPnil1 [THEN mp]
230.642 -
230.643 -
230.644 -(* holds also in other direction *)
230.645 -lemma ForallnPFilterPUU1: "~Finite ys & Forall (%x. ~P x) ys
230.646 - --> Filter P$ys = UU "
230.647 -apply (rule_tac x="ys" in Seq_induct)
230.648 -apply (simp add: Forall_def sforall_def)
230.649 -apply simp_all
230.650 -done
230.651 -
230.652 -lemmas ForallnPFilterPUU = ForallnPFilterPUU1 [THEN mp, OF conjI]
230.653 -
230.654 -
230.655 -(* inverse of ForallnPFilterPnil *)
230.656 -
230.657 -lemma FilternPnilForallP1: "!! ys . Filter P$ys = nil -->
230.658 - (Forall (%x. ~P x) ys & Finite ys)"
230.659 -apply (rule_tac x="ys" in Seq_induct)
230.660 -(* adm *)
230.661 -apply (simp add: Forall_def sforall_def)
230.662 -(* base cases *)
230.663 -apply simp
230.664 -apply simp
230.665 -(* main case *)
230.666 -apply simp
230.667 -done
230.668 -
230.669 -lemmas FilternPnilForallP = FilternPnilForallP1 [THEN mp]
230.670 -
230.671 -(* inverse of ForallnPFilterPUU. proved apply 2 lemmas because of adm problems *)
230.672 -
230.673 -lemma FilterUU_nFinite_lemma1: "Finite ys ==> Filter P$ys ~= UU"
230.674 -apply (erule Seq_Finite_ind, simp_all)
230.675 -done
230.676 -
230.677 -lemma FilterUU_nFinite_lemma2: "~ Forall (%x. ~P x) ys --> Filter P$ys ~= UU"
230.678 -apply (rule_tac x="ys" in Seq_induct)
230.679 -apply (simp add: Forall_def sforall_def)
230.680 -apply simp_all
230.681 -done
230.682 -
230.683 -lemma FilternPUUForallP:
230.684 - "Filter P$ys = UU ==> (Forall (%x. ~P x) ys & ~Finite ys)"
230.685 -apply (rule conjI)
230.686 -apply (cut_tac FilterUU_nFinite_lemma2 [THEN mp, COMP rev_contrapos])
230.687 -apply auto
230.688 -apply (blast dest!: FilterUU_nFinite_lemma1)
230.689 -done
230.690 -
230.691 -
230.692 -lemma ForallQFilterPnil:
230.693 - "!! Q P.[| Forall Q ys; Finite ys; !!x. Q x ==> ~P x|]
230.694 - ==> Filter P$ys = nil"
230.695 -apply (erule ForallnPFilterPnil)
230.696 -apply (erule ForallPForallQ)
230.697 -apply auto
230.698 -done
230.699 -
230.700 -lemma ForallQFilterPUU:
230.701 - "!! Q P. [| ~Finite ys; Forall Q ys; !!x. Q x ==> ~P x|]
230.702 - ==> Filter P$ys = UU "
230.703 -apply (erule ForallnPFilterPUU)
230.704 -apply (erule ForallPForallQ)
230.705 -apply auto
230.706 -done
230.707 -
230.708 -
230.709 -
230.710 -(* ------------------------------------------------------------------------------------- *)
230.711 -
230.712 -subsection "Takewhile, Forall, Filter"
230.713 -
230.714 -
230.715 -lemma ForallPTakewhileP [simp]: "Forall P (Takewhile P$x)"
230.716 -apply (simp add: Forall_def Takewhile_def sforallPstakewhileP)
230.717 -done
230.718 -
230.719 -
230.720 -lemma ForallPTakewhileQ [simp]:
230.721 -"!! P. [| !!x. Q x==> P x |] ==> Forall P (Takewhile Q$x)"
230.722 -apply (rule ForallPForallQ)
230.723 -apply (rule ForallPTakewhileP)
230.724 -apply auto
230.725 -done
230.726 -
230.727 -
230.728 -lemma FilterPTakewhileQnil [simp]:
230.729 - "!! Q P.[| Finite (Takewhile Q$ys); !!x. Q x ==> ~P x |]
230.730 - ==> Filter P$(Takewhile Q$ys) = nil"
230.731 -apply (erule ForallnPFilterPnil)
230.732 -apply (rule ForallPForallQ)
230.733 -apply (rule ForallPTakewhileP)
230.734 -apply auto
230.735 -done
230.736 -
230.737 -lemma FilterPTakewhileQid [simp]:
230.738 - "!! Q P. [| !!x. Q x ==> P x |] ==>
230.739 - Filter P$(Takewhile Q$ys) = (Takewhile Q$ys)"
230.740 -apply (rule ForallPFilterPid)
230.741 -apply (rule ForallPForallQ)
230.742 -apply (rule ForallPTakewhileP)
230.743 -apply auto
230.744 -done
230.745 -
230.746 -
230.747 -lemma Takewhile_idempotent: "Takewhile P$(Takewhile P$s) = Takewhile P$s"
230.748 -apply (rule_tac x="s" in Seq_induct)
230.749 -apply (simp add: Forall_def sforall_def)
230.750 -apply simp_all
230.751 -done
230.752 -
230.753 -lemma ForallPTakewhileQnP [simp]:
230.754 - "Forall P s --> Takewhile (%x. Q x | (~P x))$s = Takewhile Q$s"
230.755 -apply (rule_tac x="s" in Seq_induct)
230.756 -apply (simp add: Forall_def sforall_def)
230.757 -apply simp_all
230.758 -done
230.759 -
230.760 -lemma ForallPDropwhileQnP [simp]:
230.761 - "Forall P s --> Dropwhile (%x. Q x | (~P x))$s = Dropwhile Q$s"
230.762 -apply (rule_tac x="s" in Seq_induct)
230.763 -apply (simp add: Forall_def sforall_def)
230.764 -apply simp_all
230.765 -done
230.766 -
230.767 -
230.768 -lemma TakewhileConc1:
230.769 - "Forall P s --> Takewhile P$(s @@ t) = s @@ (Takewhile P$t)"
230.770 -apply (rule_tac x="s" in Seq_induct)
230.771 -apply (simp add: Forall_def sforall_def)
230.772 -apply simp_all
230.773 -done
230.774 -
230.775 -lemmas TakewhileConc = TakewhileConc1 [THEN mp]
230.776 -
230.777 -lemma DropwhileConc1:
230.778 - "Finite s ==> Forall P s --> Dropwhile P$(s @@ t) = Dropwhile P$t"
230.779 -apply (erule Seq_Finite_ind, simp_all)
230.780 -done
230.781 -
230.782 -lemmas DropwhileConc = DropwhileConc1 [THEN mp]
230.783 -
230.784 -
230.785 -
230.786 -(* ----------------------------------------------------------------------------------- *)
230.787 -
230.788 -subsection "coinductive characterizations of Filter"
230.789 -
230.790 -
230.791 -lemma divide_Seq_lemma:
230.792 - "HD$(Filter P$y) = Def x
230.793 - --> y = ((Takewhile (%x. ~P x)$y) @@ (x >> TL$(Dropwhile (%a.~P a)$y)))
230.794 - & Finite (Takewhile (%x. ~ P x)$y) & P x"
230.795 -
230.796 -(* FIX: pay attention: is only admissible with chain-finite package to be added to
230.797 - adm test and Finite f x admissibility *)
230.798 -apply (rule_tac x="y" in Seq_induct)
230.799 -apply (simp add: adm_subst [OF _ adm_Finite])
230.800 -apply simp
230.801 -apply simp
230.802 -apply (case_tac "P a")
230.803 - apply simp
230.804 - apply blast
230.805 -(* ~ P a *)
230.806 -apply simp
230.807 -done
230.808 -
230.809 -lemma divide_Seq: "(x>>xs) << Filter P$y
230.810 - ==> y = ((Takewhile (%a. ~ P a)$y) @@ (x >> TL$(Dropwhile (%a.~P a)$y)))
230.811 - & Finite (Takewhile (%a. ~ P a)$y) & P x"
230.812 -apply (rule divide_Seq_lemma [THEN mp])
230.813 -apply (drule_tac f="HD" and x="x>>xs" in monofun_cfun_arg)
230.814 -apply simp
230.815 -done
230.816 -
230.817 -
230.818 -lemma nForall_HDFilter:
230.819 - "~Forall P y --> (? x. HD$(Filter (%a. ~P a)$y) = Def x)"
230.820 -unfolding not_Undef_is_Def [symmetric]
230.821 -apply (induct y rule: Seq_induct)
230.822 -apply (simp add: Forall_def sforall_def)
230.823 -apply simp_all
230.824 -done
230.825 -
230.826 -
230.827 -lemma divide_Seq2: "~Forall P y
230.828 - ==> ? x. y= (Takewhile P$y @@ (x >> TL$(Dropwhile P$y))) &
230.829 - Finite (Takewhile P$y) & (~ P x)"
230.830 -apply (drule nForall_HDFilter [THEN mp])
230.831 -apply safe
230.832 -apply (rule_tac x="x" in exI)
230.833 -apply (cut_tac P1="%x. ~ P x" in divide_Seq_lemma [THEN mp])
230.834 -apply auto
230.835 -done
230.836 -
230.837 -
230.838 -lemma divide_Seq3: "~Forall P y
230.839 - ==> ? x bs rs. y= (bs @@ (x>>rs)) & Finite bs & Forall P bs & (~ P x)"
230.840 -apply (drule divide_Seq2)
230.841 -(*Auto_tac no longer proves it*)
230.842 -apply fastsimp
230.843 -done
230.844 -
230.845 -lemmas [simp] = FilterPQ FilterConc Conc_cong
230.846 -
230.847 -
230.848 -(* ------------------------------------------------------------------------------------- *)
230.849 -
230.850 -
230.851 -subsection "take_lemma"
230.852 -
230.853 -lemma seq_take_lemma: "(!n. seq_take n$x = seq_take n$x') = (x = x')"
230.854 -apply (rule iffI)
230.855 -apply (rule seq.take_lemma)
230.856 -apply auto
230.857 -done
230.858 -
230.859 -lemma take_reduction1:
230.860 -" ! n. ((! k. k < n --> seq_take k$y1 = seq_take k$y2)
230.861 - --> seq_take n$(x @@ (t>>y1)) = seq_take n$(x @@ (t>>y2)))"
230.862 -apply (rule_tac x="x" in Seq_induct)
230.863 -apply simp_all
230.864 -apply (intro strip)
230.865 -apply (case_tac "n")
230.866 -apply auto
230.867 -apply (case_tac "n")
230.868 -apply auto
230.869 -done
230.870 -
230.871 -
230.872 -lemma take_reduction:
230.873 - "!! n.[| x=y; s=t; !! k. k<n ==> seq_take k$y1 = seq_take k$y2|]
230.874 - ==> seq_take n$(x @@ (s>>y1)) = seq_take n$(y @@ (t>>y2))"
230.875 -apply (auto intro!: take_reduction1 [rule_format])
230.876 -done
230.877 -
230.878 -(* ------------------------------------------------------------------
230.879 - take-lemma and take_reduction for << instead of =
230.880 - ------------------------------------------------------------------ *)
230.881 -
230.882 -lemma take_reduction_less1:
230.883 -" ! n. ((! k. k < n --> seq_take k$y1 << seq_take k$y2)
230.884 - --> seq_take n$(x @@ (t>>y1)) << seq_take n$(x @@ (t>>y2)))"
230.885 -apply (rule_tac x="x" in Seq_induct)
230.886 -apply simp_all
230.887 -apply (intro strip)
230.888 -apply (case_tac "n")
230.889 -apply auto
230.890 -apply (case_tac "n")
230.891 -apply auto
230.892 -done
230.893 -
230.894 -
230.895 -lemma take_reduction_less:
230.896 - "!! n.[| x=y; s=t;!! k. k<n ==> seq_take k$y1 << seq_take k$y2|]
230.897 - ==> seq_take n$(x @@ (s>>y1)) << seq_take n$(y @@ (t>>y2))"
230.898 -apply (auto intro!: take_reduction_less1 [rule_format])
230.899 -done
230.900 -
230.901 -lemma take_lemma_less1:
230.902 - assumes "!! n. seq_take n$s1 << seq_take n$s2"
230.903 - shows "s1<<s2"
230.904 -apply (rule_tac t="s1" in seq.reach [THEN subst])
230.905 -apply (rule_tac t="s2" in seq.reach [THEN subst])
230.906 -apply (rule lub_mono)
230.907 -apply (rule seq.chain_take [THEN ch2ch_Rep_cfunL])
230.908 -apply (rule seq.chain_take [THEN ch2ch_Rep_cfunL])
230.909 -apply (rule assms)
230.910 -done
230.911 -
230.912 -
230.913 -lemma take_lemma_less: "(!n. seq_take n$x << seq_take n$x') = (x << x')"
230.914 -apply (rule iffI)
230.915 -apply (rule take_lemma_less1)
230.916 -apply auto
230.917 -apply (erule monofun_cfun_arg)
230.918 -done
230.919 -
230.920 -(* ------------------------------------------------------------------
230.921 - take-lemma proof principles
230.922 - ------------------------------------------------------------------ *)
230.923 -
230.924 -lemma take_lemma_principle1:
230.925 - "!! Q. [|!! s. [| Forall Q s; A s |] ==> (f s) = (g s) ;
230.926 - !! s1 s2 y. [| Forall Q s1; Finite s1; ~ Q y; A (s1 @@ y>>s2)|]
230.927 - ==> (f (s1 @@ y>>s2)) = (g (s1 @@ y>>s2)) |]
230.928 - ==> A x --> (f x)=(g x)"
230.929 -apply (case_tac "Forall Q x")
230.930 -apply (auto dest!: divide_Seq3)
230.931 -done
230.932 -
230.933 -lemma take_lemma_principle2:
230.934 - "!! Q. [|!! s. [| Forall Q s; A s |] ==> (f s) = (g s) ;
230.935 - !! s1 s2 y. [| Forall Q s1; Finite s1; ~ Q y; A (s1 @@ y>>s2)|]
230.936 - ==> ! n. seq_take n$(f (s1 @@ y>>s2))
230.937 - = seq_take n$(g (s1 @@ y>>s2)) |]
230.938 - ==> A x --> (f x)=(g x)"
230.939 -apply (case_tac "Forall Q x")
230.940 -apply (auto dest!: divide_Seq3)
230.941 -apply (rule seq.take_lemma)
230.942 -apply auto
230.943 -done
230.944 -
230.945 -
230.946 -(* Note: in the following proofs the ordering of proof steps is very
230.947 - important, as otherwise either (Forall Q s1) would be in the IH as
230.948 - assumption (then rule useless) or it is not possible to strengthen
230.949 - the IH apply doing a forall closure of the sequence t (then rule also useless).
230.950 - This is also the reason why the induction rule (nat_less_induct or nat_induct) has to
230.951 - to be imbuilt into the rule, as induction has to be done early and the take lemma
230.952 - has to be used in the trivial direction afterwards for the (Forall Q x) case. *)
230.953 -
230.954 -lemma take_lemma_induct:
230.955 -"!! Q. [|!! s. [| Forall Q s; A s |] ==> (f s) = (g s) ;
230.956 - !! s1 s2 y n. [| ! t. A t --> seq_take n$(f t) = seq_take n$(g t);
230.957 - Forall Q s1; Finite s1; ~ Q y; A (s1 @@ y>>s2) |]
230.958 - ==> seq_take (Suc n)$(f (s1 @@ y>>s2))
230.959 - = seq_take (Suc n)$(g (s1 @@ y>>s2)) |]
230.960 - ==> A x --> (f x)=(g x)"
230.961 -apply (rule impI)
230.962 -apply (rule seq.take_lemma)
230.963 -apply (rule mp)
230.964 -prefer 2 apply assumption
230.965 -apply (rule_tac x="x" in spec)
230.966 -apply (rule nat.induct)
230.967 -apply simp
230.968 -apply (rule allI)
230.969 -apply (case_tac "Forall Q xa")
230.970 -apply (force intro!: seq_take_lemma [THEN iffD2, THEN spec])
230.971 -apply (auto dest!: divide_Seq3)
230.972 -done
230.973 -
230.974 -
230.975 -lemma take_lemma_less_induct:
230.976 -"!! Q. [|!! s. [| Forall Q s; A s |] ==> (f s) = (g s) ;
230.977 - !! s1 s2 y n. [| ! t m. m < n --> A t --> seq_take m$(f t) = seq_take m$(g t);
230.978 - Forall Q s1; Finite s1; ~ Q y; A (s1 @@ y>>s2) |]
230.979 - ==> seq_take n$(f (s1 @@ y>>s2))
230.980 - = seq_take n$(g (s1 @@ y>>s2)) |]
230.981 - ==> A x --> (f x)=(g x)"
230.982 -apply (rule impI)
230.983 -apply (rule seq.take_lemma)
230.984 -apply (rule mp)
230.985 -prefer 2 apply assumption
230.986 -apply (rule_tac x="x" in spec)
230.987 -apply (rule nat_less_induct)
230.988 -apply (rule allI)
230.989 -apply (case_tac "Forall Q xa")
230.990 -apply (force intro!: seq_take_lemma [THEN iffD2, THEN spec])
230.991 -apply (auto dest!: divide_Seq3)
230.992 -done
230.993 -
230.994 -
230.995 -
230.996 -lemma take_lemma_in_eq_out:
230.997 -"!! Q. [| A UU ==> (f UU) = (g UU) ;
230.998 - A nil ==> (f nil) = (g nil) ;
230.999 - !! s y n. [| ! t. A t --> seq_take n$(f t) = seq_take n$(g t);
230.1000 - A (y>>s) |]
230.1001 - ==> seq_take (Suc n)$(f (y>>s))
230.1002 - = seq_take (Suc n)$(g (y>>s)) |]
230.1003 - ==> A x --> (f x)=(g x)"
230.1004 -apply (rule impI)
230.1005 -apply (rule seq.take_lemma)
230.1006 -apply (rule mp)
230.1007 -prefer 2 apply assumption
230.1008 -apply (rule_tac x="x" in spec)
230.1009 -apply (rule nat.induct)
230.1010 -apply simp
230.1011 -apply (rule allI)
230.1012 -apply (rule_tac x="xa" in Seq_cases)
230.1013 -apply simp_all
230.1014 -done
230.1015 -
230.1016 -
230.1017 -(* ------------------------------------------------------------------------------------ *)
230.1018 -
230.1019 -subsection "alternative take_lemma proofs"
230.1020 -
230.1021 -
230.1022 -(* --------------------------------------------------------------- *)
230.1023 -(* Alternative Proof of FilterPQ *)
230.1024 -(* --------------------------------------------------------------- *)
230.1025 -
230.1026 -declare FilterPQ [simp del]
230.1027 -
230.1028 -
230.1029 -(* In general: How to do this case without the same adm problems
230.1030 - as for the entire proof ? *)
230.1031 -lemma Filter_lemma1: "Forall (%x.~(P x & Q x)) s
230.1032 - --> Filter P$(Filter Q$s) =
230.1033 - Filter (%x. P x & Q x)$s"
230.1034 -
230.1035 -apply (rule_tac x="s" in Seq_induct)
230.1036 -apply (simp add: Forall_def sforall_def)
230.1037 -apply simp_all
230.1038 -done
230.1039 -
230.1040 -lemma Filter_lemma2: "Finite s ==>
230.1041 - (Forall (%x. (~P x) | (~ Q x)) s
230.1042 - --> Filter P$(Filter Q$s) = nil)"
230.1043 -apply (erule Seq_Finite_ind, simp_all)
230.1044 -done
230.1045 -
230.1046 -lemma Filter_lemma3: "Finite s ==>
230.1047 - Forall (%x. (~P x) | (~ Q x)) s
230.1048 - --> Filter (%x. P x & Q x)$s = nil"
230.1049 -apply (erule Seq_Finite_ind, simp_all)
230.1050 -done
230.1051 -
230.1052 -
230.1053 -lemma FilterPQ_takelemma: "Filter P$(Filter Q$s) = Filter (%x. P x & Q x)$s"
230.1054 -apply (rule_tac A1="%x. True" and
230.1055 - Q1="%x.~(P x & Q x)" and x1="s" in
230.1056 - take_lemma_induct [THEN mp])
230.1057 -(* better support for A = %x. True *)
230.1058 -apply (simp add: Filter_lemma1)
230.1059 -apply (simp add: Filter_lemma2 Filter_lemma3)
230.1060 -apply simp
230.1061 -done
230.1062 -
230.1063 -declare FilterPQ [simp]
230.1064 -
230.1065 -
230.1066 -(* --------------------------------------------------------------- *)
230.1067 -(* Alternative Proof of MapConc *)
230.1068 -(* --------------------------------------------------------------- *)
230.1069 -
230.1070 -
230.1071 -
230.1072 -lemma MapConc_takelemma: "Map f$(x@@y) = (Map f$x) @@ (Map f$y)"
230.1073 -apply (rule_tac A1="%x. True" and x1="x" in
230.1074 - take_lemma_in_eq_out [THEN mp])
230.1075 -apply auto
230.1076 -done
230.1077 -
230.1078 -
230.1079 -ML {*
230.1080 -
230.1081 -fun Seq_case_tac ctxt s i =
230.1082 - res_inst_tac ctxt [(("x", 0), s)] @{thm Seq_cases} i
230.1083 - THEN hyp_subst_tac i THEN hyp_subst_tac (i+1) THEN hyp_subst_tac (i+2);
230.1084 -
230.1085 -(* on a>>s only simp_tac, as full_simp_tac is uncomplete and often causes errors *)
230.1086 -fun Seq_case_simp_tac ctxt s i =
230.1087 - let val ss = simpset_of ctxt in
230.1088 - Seq_case_tac ctxt s i
230.1089 - THEN asm_simp_tac ss (i+2)
230.1090 - THEN asm_full_simp_tac ss (i+1)
230.1091 - THEN asm_full_simp_tac ss i
230.1092 - end;
230.1093 -
230.1094 -(* rws are definitions to be unfolded for admissibility check *)
230.1095 -fun Seq_induct_tac ctxt s rws i =
230.1096 - let val ss = simpset_of ctxt in
230.1097 - res_inst_tac ctxt [(("x", 0), s)] @{thm Seq_induct} i
230.1098 - THEN (REPEAT_DETERM (CHANGED (asm_simp_tac ss (i+1))))
230.1099 - THEN simp_tac (ss addsimps rws) i
230.1100 - end;
230.1101 -
230.1102 -fun Seq_Finite_induct_tac ctxt i =
230.1103 - etac @{thm Seq_Finite_ind} i
230.1104 - THEN (REPEAT_DETERM (CHANGED (asm_simp_tac (simpset_of ctxt) i)));
230.1105 -
230.1106 -fun pair_tac ctxt s =
230.1107 - res_inst_tac ctxt [(("p", 0), s)] @{thm PairE}
230.1108 - THEN' hyp_subst_tac THEN' asm_full_simp_tac (simpset_of ctxt);
230.1109 -
230.1110 -(* induction on a sequence of pairs with pairsplitting and simplification *)
230.1111 -fun pair_induct_tac ctxt s rws i =
230.1112 - let val ss = simpset_of ctxt in
230.1113 - res_inst_tac ctxt [(("x", 0), s)] @{thm Seq_induct} i
230.1114 - THEN pair_tac ctxt "a" (i+3)
230.1115 - THEN (REPEAT_DETERM (CHANGED (simp_tac ss (i+1))))
230.1116 - THEN simp_tac (ss addsimps rws) i
230.1117 - end;
230.1118 -
230.1119 -*}
230.1120 -
230.1121 -end
231.1 --- a/src/HOLCF/IOA/meta_theory/ShortExecutions.thy Sat Nov 27 14:34:54 2010 -0800
231.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
231.3 @@ -1,278 +0,0 @@
231.4 -(* Title: HOLCF/IOA/meta_theory/ShortExecutions.thy
231.5 - Author: Olaf Müller
231.6 -*)
231.7 -
231.8 -theory ShortExecutions
231.9 -imports Traces
231.10 -begin
231.11 -
231.12 -text {*
231.13 - Some properties about @{text "Cut ex"}, defined as follows:
231.14 -
231.15 - For every execution ex there is another shorter execution @{text "Cut ex"}
231.16 - that has the same trace as ex, but its schedule ends with an external action.
231.17 -*}
231.18 -
231.19 -definition
231.20 - oraclebuild :: "('a => bool) => 'a Seq -> 'a Seq -> 'a Seq" where
231.21 - "oraclebuild P = (fix$(LAM h s t. case t of
231.22 - nil => nil
231.23 - | x##xs =>
231.24 - (case x of
231.25 - UU => UU
231.26 - | Def y => (Takewhile (%x.~P x)$s)
231.27 - @@ (y>>(h$(TL$(Dropwhile (%x.~ P x)$s))$xs))
231.28 - )
231.29 - ))"
231.30 -
231.31 -definition
231.32 - Cut :: "('a => bool) => 'a Seq => 'a Seq" where
231.33 - "Cut P s = oraclebuild P$s$(Filter P$s)"
231.34 -
231.35 -definition
231.36 - LastActExtsch :: "('a,'s)ioa => 'a Seq => bool" where
231.37 - "LastActExtsch A sch = (Cut (%x. x: ext A) sch = sch)"
231.38 -
231.39 -(* LastActExtex ::"('a,'s)ioa => ('a,'s) pairs => bool"*)
231.40 -(* LastActExtex_def:
231.41 - "LastActExtex A ex == LastActExtsch A (filter_act$ex)" *)
231.42 -
231.43 -axiomatization where
231.44 - Cut_prefixcl_Finite: "Finite s ==> (? y. s = Cut P s @@ y)"
231.45 -
231.46 -axiomatization where
231.47 - LastActExtsmall1: "LastActExtsch A sch ==> LastActExtsch A (TL$(Dropwhile P$sch))"
231.48 -
231.49 -axiomatization where
231.50 - LastActExtsmall2: "[| Finite sch1; LastActExtsch A (sch1 @@ sch2) |] ==> LastActExtsch A sch2"
231.51 -
231.52 -
231.53 -ML {*
231.54 -fun thin_tac' j =
231.55 - rotate_tac (j - 1) THEN'
231.56 - etac thin_rl THEN'
231.57 - rotate_tac (~ (j - 1))
231.58 -*}
231.59 -
231.60 -
231.61 -subsection "oraclebuild rewrite rules"
231.62 -
231.63 -
231.64 -lemma oraclebuild_unfold:
231.65 -"oraclebuild P = (LAM s t. case t of
231.66 - nil => nil
231.67 - | x##xs =>
231.68 - (case x of
231.69 - UU => UU
231.70 - | Def y => (Takewhile (%a.~ P a)$s)
231.71 - @@ (y>>(oraclebuild P$(TL$(Dropwhile (%a.~ P a)$s))$xs))
231.72 - )
231.73 - )"
231.74 -apply (rule trans)
231.75 -apply (rule fix_eq2)
231.76 -apply (simp only: oraclebuild_def)
231.77 -apply (rule beta_cfun)
231.78 -apply simp
231.79 -done
231.80 -
231.81 -lemma oraclebuild_UU: "oraclebuild P$sch$UU = UU"
231.82 -apply (subst oraclebuild_unfold)
231.83 -apply simp
231.84 -done
231.85 -
231.86 -lemma oraclebuild_nil: "oraclebuild P$sch$nil = nil"
231.87 -apply (subst oraclebuild_unfold)
231.88 -apply simp
231.89 -done
231.90 -
231.91 -lemma oraclebuild_cons: "oraclebuild P$s$(x>>t) =
231.92 - (Takewhile (%a.~ P a)$s)
231.93 - @@ (x>>(oraclebuild P$(TL$(Dropwhile (%a.~ P a)$s))$t))"
231.94 -apply (rule trans)
231.95 -apply (subst oraclebuild_unfold)
231.96 -apply (simp add: Consq_def)
231.97 -apply (simp add: Consq_def)
231.98 -done
231.99 -
231.100 -
231.101 -subsection "Cut rewrite rules"
231.102 -
231.103 -lemma Cut_nil:
231.104 -"[| Forall (%a.~ P a) s; Finite s|]
231.105 - ==> Cut P s =nil"
231.106 -apply (unfold Cut_def)
231.107 -apply (subgoal_tac "Filter P$s = nil")
231.108 -apply (simp (no_asm_simp) add: oraclebuild_nil)
231.109 -apply (rule ForallQFilterPnil)
231.110 -apply assumption+
231.111 -done
231.112 -
231.113 -lemma Cut_UU:
231.114 -"[| Forall (%a.~ P a) s; ~Finite s|]
231.115 - ==> Cut P s =UU"
231.116 -apply (unfold Cut_def)
231.117 -apply (subgoal_tac "Filter P$s= UU")
231.118 -apply (simp (no_asm_simp) add: oraclebuild_UU)
231.119 -apply (rule ForallQFilterPUU)
231.120 -apply assumption+
231.121 -done
231.122 -
231.123 -lemma Cut_Cons:
231.124 -"[| P t; Forall (%x.~ P x) ss; Finite ss|]
231.125 - ==> Cut P (ss @@ (t>> rs))
231.126 - = ss @@ (t >> Cut P rs)"
231.127 -apply (unfold Cut_def)
231.128 -apply (simp add: ForallQFilterPnil oraclebuild_cons TakewhileConc DropwhileConc)
231.129 -done
231.130 -
231.131 -
231.132 -subsection "Cut lemmas for main theorem"
231.133 -
231.134 -lemma FilterCut: "Filter P$s = Filter P$(Cut P s)"
231.135 -apply (rule_tac A1 = "%x. True" and Q1 = "%x.~ P x" and x1 = "s" in take_lemma_induct [THEN mp])
231.136 -prefer 3 apply (fast)
231.137 -apply (case_tac "Finite s")
231.138 -apply (simp add: Cut_nil ForallQFilterPnil)
231.139 -apply (simp add: Cut_UU ForallQFilterPUU)
231.140 -(* main case *)
231.141 -apply (simp add: Cut_Cons ForallQFilterPnil)
231.142 -done
231.143 -
231.144 -
231.145 -lemma Cut_idemp: "Cut P (Cut P s) = (Cut P s)"
231.146 -apply (rule_tac A1 = "%x. True" and Q1 = "%x.~ P x" and x1 = "s" in
231.147 - take_lemma_less_induct [THEN mp])
231.148 -prefer 3 apply (fast)
231.149 -apply (case_tac "Finite s")
231.150 -apply (simp add: Cut_nil ForallQFilterPnil)
231.151 -apply (simp add: Cut_UU ForallQFilterPUU)
231.152 -(* main case *)
231.153 -apply (simp add: Cut_Cons ForallQFilterPnil)
231.154 -apply (rule take_reduction)
231.155 -apply auto
231.156 -done
231.157 -
231.158 -
231.159 -lemma MapCut: "Map f$(Cut (P o f) s) = Cut P (Map f$s)"
231.160 -apply (rule_tac A1 = "%x. True" and Q1 = "%x.~ P (f x) " and x1 = "s" in
231.161 - take_lemma_less_induct [THEN mp])
231.162 -prefer 3 apply (fast)
231.163 -apply (case_tac "Finite s")
231.164 -apply (simp add: Cut_nil)
231.165 -apply (rule Cut_nil [symmetric])
231.166 -apply (simp add: ForallMap o_def)
231.167 -apply (simp add: Map2Finite)
231.168 -(* csae ~ Finite s *)
231.169 -apply (simp add: Cut_UU)
231.170 -apply (rule Cut_UU)
231.171 -apply (simp add: ForallMap o_def)
231.172 -apply (simp add: Map2Finite)
231.173 -(* main case *)
231.174 -apply (simp add: Cut_Cons MapConc ForallMap FiniteMap1 o_def)
231.175 -apply (rule take_reduction)
231.176 -apply auto
231.177 -done
231.178 -
231.179 -
231.180 -lemma Cut_prefixcl_nFinite [rule_format (no_asm)]: "~Finite s --> Cut P s << s"
231.181 -apply (intro strip)
231.182 -apply (rule take_lemma_less [THEN iffD1])
231.183 -apply (intro strip)
231.184 -apply (rule mp)
231.185 -prefer 2 apply (assumption)
231.186 -apply (tactic "thin_tac' 1 1")
231.187 -apply (rule_tac x = "s" in spec)
231.188 -apply (rule nat_less_induct)
231.189 -apply (intro strip)
231.190 -apply (rename_tac na n s)
231.191 -apply (case_tac "Forall (%x. ~ P x) s")
231.192 -apply (rule take_lemma_less [THEN iffD2, THEN spec])
231.193 -apply (simp add: Cut_UU)
231.194 -(* main case *)
231.195 -apply (drule divide_Seq3)
231.196 -apply (erule exE)+
231.197 -apply (erule conjE)+
231.198 -apply hypsubst
231.199 -apply (simp add: Cut_Cons)
231.200 -apply (rule take_reduction_less)
231.201 -(* auto makes also reasoning about Finiteness of parts of s ! *)
231.202 -apply auto
231.203 -done
231.204 -
231.205 -
231.206 -lemma execThruCut: "!!ex .is_exec_frag A (s,ex) ==> is_exec_frag A (s,Cut P ex)"
231.207 -apply (case_tac "Finite ex")
231.208 -apply (cut_tac s = "ex" and P = "P" in Cut_prefixcl_Finite)
231.209 -apply assumption
231.210 -apply (erule exE)
231.211 -apply (rule exec_prefix2closed)
231.212 -apply (erule_tac s = "ex" and t = "Cut P ex @@ y" in subst)
231.213 -apply assumption
231.214 -apply (erule exec_prefixclosed)
231.215 -apply (erule Cut_prefixcl_nFinite)
231.216 -done
231.217 -
231.218 -
231.219 -subsection "Main Cut Theorem"
231.220 -
231.221 -lemma exists_LastActExtsch:
231.222 - "[|sch : schedules A ; tr = Filter (%a. a:ext A)$sch|]
231.223 - ==> ? sch. sch : schedules A &
231.224 - tr = Filter (%a. a:ext A)$sch &
231.225 - LastActExtsch A sch"
231.226 -
231.227 -apply (unfold schedules_def has_schedule_def)
231.228 -apply auto
231.229 -apply (rule_tac x = "filter_act$ (Cut (%a. fst a:ext A) (snd ex))" in exI)
231.230 -apply (simp add: executions_def)
231.231 -apply (tactic {* pair_tac @{context} "ex" 1 *})
231.232 -apply auto
231.233 -apply (rule_tac x = " (x,Cut (%a. fst a:ext A) y) " in exI)
231.234 -apply (simp (no_asm_simp))
231.235 -
231.236 -(* Subgoal 1: Lemma: propagation of execution through Cut *)
231.237 -
231.238 -apply (simp add: execThruCut)
231.239 -
231.240 -(* Subgoal 2: Lemma: Filter P s = Filter P (Cut P s) *)
231.241 -
231.242 -apply (simp (no_asm) add: filter_act_def)
231.243 -apply (subgoal_tac "Map fst$ (Cut (%a. fst a: ext A) y) = Cut (%a. a:ext A) (Map fst$y) ")
231.244 -
231.245 -apply (rule_tac [2] MapCut [unfolded o_def])
231.246 -apply (simp add: FilterCut [symmetric])
231.247 -
231.248 -(* Subgoal 3: Lemma: Cut idempotent *)
231.249 -
231.250 -apply (simp (no_asm) add: LastActExtsch_def filter_act_def)
231.251 -apply (subgoal_tac "Map fst$ (Cut (%a. fst a: ext A) y) = Cut (%a. a:ext A) (Map fst$y) ")
231.252 -apply (rule_tac [2] MapCut [unfolded o_def])
231.253 -apply (simp add: Cut_idemp)
231.254 -done
231.255 -
231.256 -
231.257 -subsection "Further Cut lemmas"
231.258 -
231.259 -lemma LastActExtimplnil:
231.260 - "[| LastActExtsch A sch; Filter (%x. x:ext A)$sch = nil |]
231.261 - ==> sch=nil"
231.262 -apply (unfold LastActExtsch_def)
231.263 -apply (drule FilternPnilForallP)
231.264 -apply (erule conjE)
231.265 -apply (drule Cut_nil)
231.266 -apply assumption
231.267 -apply simp
231.268 -done
231.269 -
231.270 -lemma LastActExtimplUU:
231.271 - "[| LastActExtsch A sch; Filter (%x. x:ext A)$sch = UU |]
231.272 - ==> sch=UU"
231.273 -apply (unfold LastActExtsch_def)
231.274 -apply (drule FilternPUUForallP)
231.275 -apply (erule conjE)
231.276 -apply (drule Cut_UU)
231.277 -apply assumption
231.278 -apply simp
231.279 -done
231.280 -
231.281 -end
232.1 --- a/src/HOLCF/IOA/meta_theory/SimCorrectness.thy Sat Nov 27 14:34:54 2010 -0800
232.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
232.3 @@ -1,292 +0,0 @@
232.4 -(* Title: HOLCF/IOA/meta_theory/SimCorrectness.thy
232.5 - Author: Olaf Müller
232.6 -*)
232.7 -
232.8 -header {* Correctness of Simulations in HOLCF/IOA *}
232.9 -
232.10 -theory SimCorrectness
232.11 -imports Simulations
232.12 -begin
232.13 -
232.14 -definition
232.15 - (* Note: s2 instead of s1 in last argument type !! *)
232.16 - corresp_ex_simC :: "('a,'s2)ioa => (('s1 * 's2)set) => ('a,'s1)pairs
232.17 - -> ('s2 => ('a,'s2)pairs)" where
232.18 - "corresp_ex_simC A R = (fix$(LAM h ex. (%s. case ex of
232.19 - nil => nil
232.20 - | x##xs => (flift1 (%pr. let a = (fst pr); t = (snd pr);
232.21 - T' = @t'. ? ex1. (t,t'):R & move A ex1 s a t'
232.22 - in
232.23 - (@cex. move A cex s a T')
232.24 - @@ ((h$xs) T'))
232.25 - $x) )))"
232.26 -
232.27 -definition
232.28 - corresp_ex_sim :: "('a,'s2)ioa => (('s1 *'s2)set) =>
232.29 - ('a,'s1)execution => ('a,'s2)execution" where
232.30 - "corresp_ex_sim A R ex == let S'= (@s'.(fst ex,s'):R & s': starts_of A)
232.31 - in
232.32 - (S',(corresp_ex_simC A R$(snd ex)) S')"
232.33 -
232.34 -
232.35 -subsection "corresp_ex_sim"
232.36 -
232.37 -lemma corresp_ex_simC_unfold: "corresp_ex_simC A R = (LAM ex. (%s. case ex of
232.38 - nil => nil
232.39 - | x##xs => (flift1 (%pr. let a = (fst pr); t = (snd pr);
232.40 - T' = @t'. ? ex1. (t,t'):R & move A ex1 s a t'
232.41 - in
232.42 - (@cex. move A cex s a T')
232.43 - @@ ((corresp_ex_simC A R $xs) T'))
232.44 - $x) ))"
232.45 -apply (rule trans)
232.46 -apply (rule fix_eq2)
232.47 -apply (simp only: corresp_ex_simC_def)
232.48 -apply (rule beta_cfun)
232.49 -apply (simp add: flift1_def)
232.50 -done
232.51 -
232.52 -lemma corresp_ex_simC_UU: "(corresp_ex_simC A R$UU) s=UU"
232.53 -apply (subst corresp_ex_simC_unfold)
232.54 -apply simp
232.55 -done
232.56 -
232.57 -lemma corresp_ex_simC_nil: "(corresp_ex_simC A R$nil) s = nil"
232.58 -apply (subst corresp_ex_simC_unfold)
232.59 -apply simp
232.60 -done
232.61 -
232.62 -lemma corresp_ex_simC_cons: "(corresp_ex_simC A R$((a,t)>>xs)) s =
232.63 - (let T' = @t'. ? ex1. (t,t'):R & move A ex1 s a t'
232.64 - in
232.65 - (@cex. move A cex s a T')
232.66 - @@ ((corresp_ex_simC A R$xs) T'))"
232.67 -apply (rule trans)
232.68 -apply (subst corresp_ex_simC_unfold)
232.69 -apply (simp add: Consq_def flift1_def)
232.70 -apply simp
232.71 -done
232.72 -
232.73 -
232.74 -declare corresp_ex_simC_UU [simp] corresp_ex_simC_nil [simp] corresp_ex_simC_cons [simp]
232.75 -
232.76 -
232.77 -subsection "properties of move"
232.78 -
232.79 -declare Let_def [simp del]
232.80 -
232.81 -lemma move_is_move_sim:
232.82 - "[|is_simulation R C A; reachable C s; s -a--C-> t; (s,s'):R|] ==>
232.83 - let T' = @t'. ? ex1. (t,t'):R & move A ex1 s' a t' in
232.84 - (t,T'): R & move A (@ex2. move A ex2 s' a T') s' a T'"
232.85 -apply (unfold is_simulation_def)
232.86 -
232.87 -(* Does not perform conditional rewriting on assumptions automatically as
232.88 - usual. Instantiate all variables per hand. Ask Tobias?? *)
232.89 -apply (subgoal_tac "? t' ex. (t,t') :R & move A ex s' a t'")
232.90 -prefer 2
232.91 -apply simp
232.92 -apply (erule conjE)
232.93 -apply (erule_tac x = "s" in allE)
232.94 -apply (erule_tac x = "s'" in allE)
232.95 -apply (erule_tac x = "t" in allE)
232.96 -apply (erule_tac x = "a" in allE)
232.97 -apply simp
232.98 -(* Go on as usual *)
232.99 -apply (erule exE)
232.100 -apply (drule_tac x = "t'" and P = "%t'. ? ex. (t,t') :R & move A ex s' a t'" in someI)
232.101 -apply (erule exE)
232.102 -apply (erule conjE)
232.103 -apply (simp add: Let_def)
232.104 -apply (rule_tac x = "ex" in someI)
232.105 -apply (erule conjE)
232.106 -apply assumption
232.107 -done
232.108 -
232.109 -declare Let_def [simp]
232.110 -
232.111 -lemma move_subprop1_sim:
232.112 - "[|is_simulation R C A; reachable C s; s-a--C-> t; (s,s'):R|] ==>
232.113 - let T' = @t'. ? ex1. (t,t'):R & move A ex1 s' a t' in
232.114 - is_exec_frag A (s',@x. move A x s' a T')"
232.115 -apply (cut_tac move_is_move_sim)
232.116 -defer
232.117 -apply assumption+
232.118 -apply (simp add: move_def)
232.119 -done
232.120 -
232.121 -lemma move_subprop2_sim:
232.122 - "[|is_simulation R C A; reachable C s; s-a--C-> t; (s,s'):R|] ==>
232.123 - let T' = @t'. ? ex1. (t,t'):R & move A ex1 s' a t' in
232.124 - Finite (@x. move A x s' a T')"
232.125 -apply (cut_tac move_is_move_sim)
232.126 -defer
232.127 -apply assumption+
232.128 -apply (simp add: move_def)
232.129 -done
232.130 -
232.131 -lemma move_subprop3_sim:
232.132 - "[|is_simulation R C A; reachable C s; s-a--C-> t; (s,s'):R|] ==>
232.133 - let T' = @t'. ? ex1. (t,t'):R & move A ex1 s' a t' in
232.134 - laststate (s',@x. move A x s' a T') = T'"
232.135 -apply (cut_tac move_is_move_sim)
232.136 -defer
232.137 -apply assumption+
232.138 -apply (simp add: move_def)
232.139 -done
232.140 -
232.141 -lemma move_subprop4_sim:
232.142 - "[|is_simulation R C A; reachable C s; s-a--C-> t; (s,s'):R|] ==>
232.143 - let T' = @t'. ? ex1. (t,t'):R & move A ex1 s' a t' in
232.144 - mk_trace A$((@x. move A x s' a T')) =
232.145 - (if a:ext A then a>>nil else nil)"
232.146 -apply (cut_tac move_is_move_sim)
232.147 -defer
232.148 -apply assumption+
232.149 -apply (simp add: move_def)
232.150 -done
232.151 -
232.152 -lemma move_subprop5_sim:
232.153 - "[|is_simulation R C A; reachable C s; s-a--C-> t; (s,s'):R|] ==>
232.154 - let T' = @t'. ? ex1. (t,t'):R & move A ex1 s' a t' in
232.155 - (t,T'):R"
232.156 -apply (cut_tac move_is_move_sim)
232.157 -defer
232.158 -apply assumption+
232.159 -apply (simp add: move_def)
232.160 -done
232.161 -
232.162 -
232.163 -subsection {* TRACE INCLUSION Part 1: Traces coincide *}
232.164 -
232.165 -subsubsection "Lemmata for <=="
232.166 -
232.167 -(* ------------------------------------------------------
232.168 - Lemma 1 :Traces coincide
232.169 - ------------------------------------------------------- *)
232.170 -
232.171 -declare split_if [split del]
232.172 -lemma traces_coincide_sim [rule_format (no_asm)]:
232.173 - "[|is_simulation R C A; ext C = ext A|] ==>
232.174 - !s s'. reachable C s & is_exec_frag C (s,ex) & (s,s'): R -->
232.175 - mk_trace C$ex = mk_trace A$((corresp_ex_simC A R$ex) s')"
232.176 -
232.177 -apply (tactic {* pair_induct_tac @{context} "ex" [@{thm is_exec_frag_def}] 1 *})
232.178 -(* cons case *)
232.179 -apply auto
232.180 -apply (rename_tac ex a t s s')
232.181 -apply (simp add: mk_traceConc)
232.182 -apply (frule reachable.reachable_n)
232.183 -apply assumption
232.184 -apply (erule_tac x = "t" in allE)
232.185 -apply (erule_tac x = "@t'. ? ex1. (t,t') :R & move A ex1 s' a t'" in allE)
232.186 -apply (simp add: move_subprop5_sim [unfolded Let_def]
232.187 - move_subprop4_sim [unfolded Let_def] split add: split_if)
232.188 -done
232.189 -declare split_if [split]
232.190 -
232.191 -
232.192 -(* ----------------------------------------------------------- *)
232.193 -(* Lemma 2 : corresp_ex_sim is execution *)
232.194 -(* ----------------------------------------------------------- *)
232.195 -
232.196 -
232.197 -lemma correspsim_is_execution [rule_format (no_asm)]:
232.198 - "[| is_simulation R C A |] ==>
232.199 - !s s'. reachable C s & is_exec_frag C (s,ex) & (s,s'):R
232.200 - --> is_exec_frag A (s',(corresp_ex_simC A R$ex) s')"
232.201 -
232.202 -apply (tactic {* pair_induct_tac @{context} "ex" [@{thm is_exec_frag_def}] 1 *})
232.203 -(* main case *)
232.204 -apply auto
232.205 -apply (rename_tac ex a t s s')
232.206 -apply (rule_tac t = "@t'. ? ex1. (t,t') :R & move A ex1 s' a t'" in lemma_2_1)
232.207 -
232.208 -(* Finite *)
232.209 -apply (erule move_subprop2_sim [unfolded Let_def])
232.210 -apply assumption+
232.211 -apply (rule conjI)
232.212 -
232.213 -(* is_exec_frag *)
232.214 -apply (erule move_subprop1_sim [unfolded Let_def])
232.215 -apply assumption+
232.216 -apply (rule conjI)
232.217 -
232.218 -(* Induction hypothesis *)
232.219 -(* reachable_n looping, therefore apply it manually *)
232.220 -apply (erule_tac x = "t" in allE)
232.221 -apply (erule_tac x = "@t'. ? ex1. (t,t') :R & move A ex1 s' a t'" in allE)
232.222 -apply simp
232.223 -apply (frule reachable.reachable_n)
232.224 -apply assumption
232.225 -apply (simp add: move_subprop5_sim [unfolded Let_def])
232.226 -(* laststate *)
232.227 -apply (erule move_subprop3_sim [unfolded Let_def, symmetric])
232.228 -apply assumption+
232.229 -done
232.230 -
232.231 -
232.232 -subsection "Main Theorem: TRACE - INCLUSION"
232.233 -
232.234 -(* -------------------------------------------------------------------------------- *)
232.235 -
232.236 - (* generate condition (s,S'):R & S':starts_of A, the first being intereting
232.237 - for the induction cases concerning the two lemmas correpsim_is_execution and
232.238 - traces_coincide_sim, the second for the start state case.
232.239 - S':= @s'. (s,s'):R & s':starts_of A, where s:starts_of C *)
232.240 -
232.241 -lemma simulation_starts:
232.242 -"[| is_simulation R C A; s:starts_of C |]
232.243 - ==> let S' = @s'. (s,s'):R & s':starts_of A in
232.244 - (s,S'):R & S':starts_of A"
232.245 - apply (simp add: is_simulation_def corresp_ex_sim_def Int_non_empty Image_def)
232.246 - apply (erule conjE)+
232.247 - apply (erule ballE)
232.248 - prefer 2 apply (blast)
232.249 - apply (erule exE)
232.250 - apply (rule someI2)
232.251 - apply assumption
232.252 - apply blast
232.253 - done
232.254 -
232.255 -lemmas sim_starts1 = simulation_starts [unfolded Let_def, THEN conjunct1, standard]
232.256 -lemmas sim_starts2 = simulation_starts [unfolded Let_def, THEN conjunct2, standard]
232.257 -
232.258 -
232.259 -lemma trace_inclusion_for_simulations:
232.260 - "[| ext C = ext A; is_simulation R C A |]
232.261 - ==> traces C <= traces A"
232.262 -
232.263 - apply (unfold traces_def)
232.264 -
232.265 - apply (simp (no_asm) add: has_trace_def2)
232.266 - apply auto
232.267 -
232.268 - (* give execution of abstract automata *)
232.269 - apply (rule_tac x = "corresp_ex_sim A R ex" in bexI)
232.270 -
232.271 - (* Traces coincide, Lemma 1 *)
232.272 - apply (tactic {* pair_tac @{context} "ex" 1 *})
232.273 - apply (rename_tac s ex)
232.274 - apply (simp (no_asm) add: corresp_ex_sim_def)
232.275 - apply (rule_tac s = "s" in traces_coincide_sim)
232.276 - apply assumption+
232.277 - apply (simp add: executions_def reachable.reachable_0 sim_starts1)
232.278 -
232.279 - (* corresp_ex_sim is execution, Lemma 2 *)
232.280 - apply (tactic {* pair_tac @{context} "ex" 1 *})
232.281 - apply (simp add: executions_def)
232.282 - apply (rename_tac s ex)
232.283 -
232.284 - (* start state *)
232.285 - apply (rule conjI)
232.286 - apply (simp add: sim_starts2 corresp_ex_sim_def)
232.287 -
232.288 - (* is-execution-fragment *)
232.289 - apply (simp add: corresp_ex_sim_def)
232.290 - apply (rule_tac s = s in correspsim_is_execution)
232.291 - apply assumption
232.292 - apply (simp add: reachable.reachable_0 sim_starts1)
232.293 - done
232.294 -
232.295 -end
233.1 --- a/src/HOLCF/IOA/meta_theory/Simulations.thy Sat Nov 27 14:34:54 2010 -0800
233.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
233.3 @@ -1,85 +0,0 @@
233.4 -(* Title: HOLCF/IOA/meta_theory/Simulations.thy
233.5 - Author: Olaf Müller
233.6 -*)
233.7 -
233.8 -header {* Simulations in HOLCF/IOA *}
233.9 -
233.10 -theory Simulations
233.11 -imports RefCorrectness
233.12 -begin
233.13 -
233.14 -default_sort type
233.15 -
233.16 -definition
233.17 - is_simulation :: "[('s1 * 's2)set,('a,'s1)ioa,('a,'s2)ioa] => bool" where
233.18 - "is_simulation R C A =
233.19 - ((!s:starts_of C. R``{s} Int starts_of A ~= {}) &
233.20 - (!s s' t a. reachable C s &
233.21 - s -a--C-> t &
233.22 - (s,s') : R
233.23 - --> (? t' ex. (t,t'):R & move A ex s' a t')))"
233.24 -
233.25 -definition
233.26 - is_backward_simulation :: "[('s1 * 's2)set,('a,'s1)ioa,('a,'s2)ioa] => bool" where
233.27 - "is_backward_simulation R C A =
233.28 - ((!s:starts_of C. R``{s} <= starts_of A) &
233.29 - (!s t t' a. reachable C s &
233.30 - s -a--C-> t &
233.31 - (t,t') : R
233.32 - --> (? ex s'. (s,s'):R & move A ex s' a t')))"
233.33 -
233.34 -definition
233.35 - is_forw_back_simulation :: "[('s1 * 's2 set)set,('a,'s1)ioa,('a,'s2)ioa] => bool" where
233.36 - "is_forw_back_simulation R C A =
233.37 - ((!s:starts_of C. ? S'. (s,S'):R & S'<= starts_of A) &
233.38 - (!s S' t a. reachable C s &
233.39 - s -a--C-> t &
233.40 - (s,S') : R
233.41 - --> (? T'. (t,T'):R & (! t':T'. ? s':S'. ? ex. move A ex s' a t'))))"
233.42 -
233.43 -definition
233.44 - is_back_forw_simulation :: "[('s1 * 's2 set)set,('a,'s1)ioa,('a,'s2)ioa] => bool" where
233.45 - "is_back_forw_simulation R C A =
233.46 - ((!s:starts_of C. ! S'. (s,S'):R --> S' Int starts_of A ~={}) &
233.47 - (!s t T' a. reachable C s &
233.48 - s -a--C-> t &
233.49 - (t,T') : R
233.50 - --> (? S'. (s,S'):R & (! s':S'. ? t':T'. ? ex. move A ex s' a t'))))"
233.51 -
233.52 -definition
233.53 - is_history_relation :: "[('s1 * 's2)set,('a,'s1)ioa,('a,'s2)ioa] => bool" where
233.54 - "is_history_relation R C A = (is_simulation R C A &
233.55 - is_ref_map (%x.(@y. (x,y):(R^-1))) A C)"
233.56 -
233.57 -definition
233.58 - is_prophecy_relation :: "[('s1 * 's2)set,('a,'s1)ioa,('a,'s2)ioa] => bool" where
233.59 - "is_prophecy_relation R C A = (is_backward_simulation R C A &
233.60 - is_ref_map (%x.(@y. (x,y):(R^-1))) A C)"
233.61 -
233.62 -
233.63 -lemma set_non_empty: "(A~={}) = (? x. x:A)"
233.64 -apply auto
233.65 -done
233.66 -
233.67 -lemma Int_non_empty: "(A Int B ~= {}) = (? x. x: A & x:B)"
233.68 -apply (simp add: set_non_empty)
233.69 -done
233.70 -
233.71 -
233.72 -lemma Sim_start_convert:
233.73 -"(R``{x} Int S ~= {}) = (? y. (x,y):R & y:S)"
233.74 -apply (unfold Image_def)
233.75 -apply (simp add: Int_non_empty)
233.76 -done
233.77 -
233.78 -declare Sim_start_convert [simp]
233.79 -
233.80 -
233.81 -lemma ref_map_is_simulation:
233.82 -"!! f. is_ref_map f C A ==> is_simulation {p. (snd p) = f (fst p)} C A"
233.83 -
233.84 -apply (unfold is_ref_map_def is_simulation_def)
233.85 -apply simp
233.86 -done
233.87 -
233.88 -end
234.1 --- a/src/HOLCF/IOA/meta_theory/TL.thy Sat Nov 27 14:34:54 2010 -0800
234.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
234.3 @@ -1,203 +0,0 @@
234.4 -(* Title: HOLCF/IOA/meta_theory/TLS.thy
234.5 - Author: Olaf Müller
234.6 -*)
234.7 -
234.8 -header {* A General Temporal Logic *}
234.9 -
234.10 -theory TL
234.11 -imports Pred Sequence
234.12 -begin
234.13 -
234.14 -default_sort type
234.15 -
234.16 -types
234.17 - 'a temporal = "'a Seq predicate"
234.18 -
234.19 -
234.20 -consts
234.21 -suffix :: "'a Seq => 'a Seq => bool"
234.22 -tsuffix :: "'a Seq => 'a Seq => bool"
234.23 -
234.24 -validT :: "'a Seq predicate => bool"
234.25 -
234.26 -unlift :: "'a lift => 'a"
234.27 -
234.28 -Init ::"'a predicate => 'a temporal" ("<_>" [0] 1000)
234.29 -
234.30 -Box ::"'a temporal => 'a temporal" ("[] (_)" [80] 80)
234.31 -Diamond ::"'a temporal => 'a temporal" ("<> (_)" [80] 80)
234.32 -Next ::"'a temporal => 'a temporal"
234.33 -Leadsto ::"'a temporal => 'a temporal => 'a temporal" (infixr "~>" 22)
234.34 -
234.35 -notation (xsymbols)
234.36 - Box ("\<box> (_)" [80] 80) and
234.37 - Diamond ("\<diamond> (_)" [80] 80) and
234.38 - Leadsto (infixr "\<leadsto>" 22)
234.39 -
234.40 -defs
234.41 -
234.42 -unlift_def:
234.43 - "unlift x == (case x of Def y => y)"
234.44 -
234.45 -(* this means that for nil and UU the effect is unpredictable *)
234.46 -Init_def:
234.47 - "Init P s == (P (unlift (HD$s)))"
234.48 -
234.49 -suffix_def:
234.50 - "suffix s2 s == ? s1. (Finite s1 & s = s1 @@ s2)"
234.51 -
234.52 -tsuffix_def:
234.53 - "tsuffix s2 s == s2 ~= nil & s2 ~= UU & suffix s2 s"
234.54 -
234.55 -Box_def:
234.56 - "([] P) s == ! s2. tsuffix s2 s --> P s2"
234.57 -
234.58 -Next_def:
234.59 - "(Next P) s == if (TL$s=UU | TL$s=nil) then (P s) else P (TL$s)"
234.60 -
234.61 -Diamond_def:
234.62 - "<> P == .~ ([] (.~ P))"
234.63 -
234.64 -Leadsto_def:
234.65 - "P ~> Q == ([] (P .--> (<> Q)))"
234.66 -
234.67 -validT_def:
234.68 - "validT P == ! s. s~=UU & s~=nil --> (s |= P)"
234.69 -
234.70 -
234.71 -lemma simple: "[] <> (.~ P) = (.~ <> [] P)"
234.72 -apply (rule ext)
234.73 -apply (simp add: Diamond_def NOT_def Box_def)
234.74 -done
234.75 -
234.76 -lemma Boxnil: "nil |= [] P"
234.77 -apply (simp add: satisfies_def Box_def tsuffix_def suffix_def nil_is_Conc)
234.78 -done
234.79 -
234.80 -lemma Diamondnil: "~(nil |= <> P)"
234.81 -apply (simp add: Diamond_def satisfies_def NOT_def)
234.82 -apply (cut_tac Boxnil)
234.83 -apply (simp add: satisfies_def)
234.84 -done
234.85 -
234.86 -lemma Diamond_def2: "(<> F) s = (? s2. tsuffix s2 s & F s2)"
234.87 -apply (simp add: Diamond_def NOT_def Box_def)
234.88 -done
234.89 -
234.90 -
234.91 -
234.92 -subsection "TLA Axiomatization by Merz"
234.93 -
234.94 -lemma suffix_refl: "suffix s s"
234.95 -apply (simp add: suffix_def)
234.96 -apply (rule_tac x = "nil" in exI)
234.97 -apply auto
234.98 -done
234.99 -
234.100 -lemma reflT: "s~=UU & s~=nil --> (s |= [] F .--> F)"
234.101 -apply (simp add: satisfies_def IMPLIES_def Box_def)
234.102 -apply (rule impI)+
234.103 -apply (erule_tac x = "s" in allE)
234.104 -apply (simp add: tsuffix_def suffix_refl)
234.105 -done
234.106 -
234.107 -
234.108 -lemma suffix_trans: "[| suffix y x ; suffix z y |] ==> suffix z x"
234.109 -apply (simp add: suffix_def)
234.110 -apply auto
234.111 -apply (rule_tac x = "s1 @@ s1a" in exI)
234.112 -apply auto
234.113 -apply (simp (no_asm) add: Conc_assoc)
234.114 -done
234.115 -
234.116 -lemma transT: "s |= [] F .--> [] [] F"
234.117 -apply (simp (no_asm) add: satisfies_def IMPLIES_def Box_def tsuffix_def)
234.118 -apply auto
234.119 -apply (drule suffix_trans)
234.120 -apply assumption
234.121 -apply (erule_tac x = "s2a" in allE)
234.122 -apply auto
234.123 -done
234.124 -
234.125 -
234.126 -lemma normalT: "s |= [] (F .--> G) .--> [] F .--> [] G"
234.127 -apply (simp (no_asm) add: satisfies_def IMPLIES_def Box_def)
234.128 -done
234.129 -
234.130 -
234.131 -subsection "TLA Rules by Lamport"
234.132 -
234.133 -lemma STL1a: "validT P ==> validT ([] P)"
234.134 -apply (simp add: validT_def satisfies_def Box_def tsuffix_def)
234.135 -done
234.136 -
234.137 -lemma STL1b: "valid P ==> validT (Init P)"
234.138 -apply (simp add: valid_def validT_def satisfies_def Init_def)
234.139 -done
234.140 -
234.141 -lemma STL1: "valid P ==> validT ([] (Init P))"
234.142 -apply (rule STL1a)
234.143 -apply (erule STL1b)
234.144 -done
234.145 -
234.146 -(* Note that unlift and HD is not at all used !!! *)
234.147 -lemma STL4: "valid (P .--> Q) ==> validT ([] (Init P) .--> [] (Init Q))"
234.148 -apply (simp add: valid_def validT_def satisfies_def IMPLIES_def Box_def Init_def)
234.149 -done
234.150 -
234.151 -
234.152 -subsection "LTL Axioms by Manna/Pnueli"
234.153 -
234.154 -lemma tsuffix_TL [rule_format (no_asm)]:
234.155 -"s~=UU & s~=nil --> tsuffix s2 (TL$s) --> tsuffix s2 s"
234.156 -apply (unfold tsuffix_def suffix_def)
234.157 -apply auto
234.158 -apply (tactic {* Seq_case_simp_tac @{context} "s" 1 *})
234.159 -apply (rule_tac x = "a>>s1" in exI)
234.160 -apply auto
234.161 -done
234.162 -
234.163 -lemmas tsuffix_TL2 = conjI [THEN tsuffix_TL]
234.164 -
234.165 -declare split_if [split del]
234.166 -lemma LTL1:
234.167 - "s~=UU & s~=nil --> (s |= [] F .--> (F .& (Next ([] F))))"
234.168 -apply (unfold Next_def satisfies_def NOT_def IMPLIES_def AND_def Box_def)
234.169 -apply auto
234.170 -(* []F .--> F *)
234.171 -apply (erule_tac x = "s" in allE)
234.172 -apply (simp add: tsuffix_def suffix_refl)
234.173 -(* []F .--> Next [] F *)
234.174 -apply (simp split add: split_if)
234.175 -apply auto
234.176 -apply (drule tsuffix_TL2)
234.177 -apply assumption+
234.178 -apply auto
234.179 -done
234.180 -declare split_if [split]
234.181 -
234.182 -
234.183 -lemma LTL2a:
234.184 - "s |= .~ (Next F) .--> (Next (.~ F))"
234.185 -apply (unfold Next_def satisfies_def NOT_def IMPLIES_def)
234.186 -apply simp
234.187 -done
234.188 -
234.189 -lemma LTL2b:
234.190 - "s |= (Next (.~ F)) .--> (.~ (Next F))"
234.191 -apply (unfold Next_def satisfies_def NOT_def IMPLIES_def)
234.192 -apply simp
234.193 -done
234.194 -
234.195 -lemma LTL3:
234.196 -"ex |= (Next (F .--> G)) .--> (Next F) .--> (Next G)"
234.197 -apply (unfold Next_def satisfies_def NOT_def IMPLIES_def)
234.198 -apply simp
234.199 -done
234.200 -
234.201 -
234.202 -lemma ModusPonens: "[| validT (P .--> Q); validT P |] ==> validT Q"
234.203 -apply (simp add: validT_def satisfies_def IMPLIES_def)
234.204 -done
234.205 -
234.206 -end
235.1 --- a/src/HOLCF/IOA/meta_theory/TLS.thy Sat Nov 27 14:34:54 2010 -0800
235.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
235.3 @@ -1,201 +0,0 @@
235.4 -(* Title: HOLCF/IOA/meta_theory/TLS.thy
235.5 - Author: Olaf Müller
235.6 -*)
235.7 -
235.8 -header {* Temporal Logic of Steps -- tailored for I/O automata *}
235.9 -
235.10 -theory TLS
235.11 -imports IOA TL
235.12 -begin
235.13 -
235.14 -default_sort type
235.15 -
235.16 -types
235.17 - ('a, 's) ioa_temp = "('a option,'s)transition temporal"
235.18 - ('a, 's) step_pred = "('a option,'s)transition predicate"
235.19 - 's state_pred = "'s predicate"
235.20 -
235.21 -consts
235.22 -
235.23 -option_lift :: "('a => 'b) => 'b => ('a option => 'b)"
235.24 -plift :: "('a => bool) => ('a option => bool)"
235.25 -
235.26 -temp_sat :: "('a,'s)execution => ('a,'s)ioa_temp => bool" (infixr "|==" 22)
235.27 -xt1 :: "'s predicate => ('a,'s)step_pred"
235.28 -xt2 :: "'a option predicate => ('a,'s)step_pred"
235.29 -
235.30 -validTE :: "('a,'s)ioa_temp => bool"
235.31 -validIOA :: "('a,'s)ioa => ('a,'s)ioa_temp => bool"
235.32 -
235.33 -mkfin :: "'a Seq => 'a Seq"
235.34 -
235.35 -ex2seq :: "('a,'s)execution => ('a option,'s)transition Seq"
235.36 -ex2seqC :: "('a,'s)pairs -> ('s => ('a option,'s)transition Seq)"
235.37 -
235.38 -
235.39 -defs
235.40 -
235.41 -mkfin_def:
235.42 - "mkfin s == if Partial s then @t. Finite t & s = t @@ UU
235.43 - else s"
235.44 -
235.45 -option_lift_def:
235.46 - "option_lift f s y == case y of None => s | Some x => (f x)"
235.47 -
235.48 -(* plift is used to determine that None action is always false in
235.49 - transition predicates *)
235.50 -plift_def:
235.51 - "plift P == option_lift P False"
235.52 -
235.53 -temp_sat_def:
235.54 - "ex |== P == ((ex2seq ex) |= P)"
235.55 -
235.56 -xt1_def:
235.57 - "xt1 P tr == P (fst tr)"
235.58 -
235.59 -xt2_def:
235.60 - "xt2 P tr == P (fst (snd tr))"
235.61 -
235.62 -ex2seq_def:
235.63 - "ex2seq ex == ((ex2seqC $(mkfin (snd ex))) (fst ex))"
235.64 -
235.65 -ex2seqC_def:
235.66 - "ex2seqC == (fix$(LAM h ex. (%s. case ex of
235.67 - nil => (s,None,s)>>nil
235.68 - | x##xs => (flift1 (%pr.
235.69 - (s,Some (fst pr), snd pr)>> (h$xs) (snd pr))
235.70 - $x)
235.71 - )))"
235.72 -
235.73 -validTE_def:
235.74 - "validTE P == ! ex. (ex |== P)"
235.75 -
235.76 -validIOA_def:
235.77 - "validIOA A P == ! ex : executions A . (ex |== P)"
235.78 -
235.79 -
235.80 -axioms
235.81 -
235.82 -mkfin_UU:
235.83 - "mkfin UU = nil"
235.84 -
235.85 -mkfin_nil:
235.86 - "mkfin nil =nil"
235.87 -
235.88 -mkfin_cons:
235.89 - "(mkfin (a>>s)) = (a>>(mkfin s))"
235.90 -
235.91 -
235.92 -lemmas [simp del] = HOL.ex_simps HOL.all_simps split_paired_Ex
235.93 -
235.94 -declaration {* fn _ => Classical.map_cs (fn cs => cs delSWrapper "split_all_tac") *}
235.95 -
235.96 -
235.97 -subsection {* ex2seqC *}
235.98 -
235.99 -lemma ex2seqC_unfold: "ex2seqC = (LAM ex. (%s. case ex of
235.100 - nil => (s,None,s)>>nil
235.101 - | x##xs => (flift1 (%pr.
235.102 - (s,Some (fst pr), snd pr)>> (ex2seqC$xs) (snd pr))
235.103 - $x)
235.104 - ))"
235.105 -apply (rule trans)
235.106 -apply (rule fix_eq2)
235.107 -apply (rule ex2seqC_def)
235.108 -apply (rule beta_cfun)
235.109 -apply (simp add: flift1_def)
235.110 -done
235.111 -
235.112 -lemma ex2seqC_UU: "(ex2seqC $UU) s=UU"
235.113 -apply (subst ex2seqC_unfold)
235.114 -apply simp
235.115 -done
235.116 -
235.117 -lemma ex2seqC_nil: "(ex2seqC $nil) s = (s,None,s)>>nil"
235.118 -apply (subst ex2seqC_unfold)
235.119 -apply simp
235.120 -done
235.121 -
235.122 -lemma ex2seqC_cons: "(ex2seqC $((a,t)>>xs)) s =
235.123 - (s,Some a,t)>> ((ex2seqC$xs) t)"
235.124 -apply (rule trans)
235.125 -apply (subst ex2seqC_unfold)
235.126 -apply (simp add: Consq_def flift1_def)
235.127 -apply (simp add: Consq_def flift1_def)
235.128 -done
235.129 -
235.130 -declare ex2seqC_UU [simp] ex2seqC_nil [simp] ex2seqC_cons [simp]
235.131 -
235.132 -
235.133 -
235.134 -declare mkfin_UU [simp] mkfin_nil [simp] mkfin_cons [simp]
235.135 -
235.136 -lemma ex2seq_UU: "ex2seq (s, UU) = (s,None,s)>>nil"
235.137 -apply (simp add: ex2seq_def)
235.138 -done
235.139 -
235.140 -lemma ex2seq_nil: "ex2seq (s, nil) = (s,None,s)>>nil"
235.141 -apply (simp add: ex2seq_def)
235.142 -done
235.143 -
235.144 -lemma ex2seq_cons: "ex2seq (s, (a,t)>>ex) = (s,Some a,t) >> ex2seq (t, ex)"
235.145 -apply (simp add: ex2seq_def)
235.146 -done
235.147 -
235.148 -declare ex2seqC_UU [simp del] ex2seqC_nil [simp del] ex2seqC_cons [simp del]
235.149 -declare ex2seq_UU [simp] ex2seq_nil [simp] ex2seq_cons [simp]
235.150 -
235.151 -
235.152 -lemma ex2seq_nUUnnil: "ex2seq exec ~= UU & ex2seq exec ~= nil"
235.153 -apply (tactic {* pair_tac @{context} "exec" 1 *})
235.154 -apply (tactic {* Seq_case_simp_tac @{context} "y" 1 *})
235.155 -apply (tactic {* pair_tac @{context} "a" 1 *})
235.156 -done
235.157 -
235.158 -
235.159 -subsection {* Interface TL -- TLS *}
235.160 -
235.161 -(* uses the fact that in executions states overlap, which is lost in
235.162 - after the translation via ex2seq !! *)
235.163 -
235.164 -lemma TL_TLS:
235.165 - "[| ! s a t. (P s) & s-a--A-> t --> (Q t) |]
235.166 - ==> ex |== (Init (%(s,a,t). P s) .& Init (%(s,a,t). s -a--A-> t)
235.167 - .--> (Next (Init (%(s,a,t).Q s))))"
235.168 -apply (unfold Init_def Next_def temp_sat_def satisfies_def IMPLIES_def AND_def)
235.169 -
235.170 -apply clarify
235.171 -apply (simp split add: split_if)
235.172 -(* TL = UU *)
235.173 -apply (rule conjI)
235.174 -apply (tactic {* pair_tac @{context} "ex" 1 *})
235.175 -apply (tactic {* Seq_case_simp_tac @{context} "y" 1 *})
235.176 -apply (tactic {* pair_tac @{context} "a" 1 *})
235.177 -apply (tactic {* Seq_case_simp_tac @{context} "s" 1 *})
235.178 -apply (tactic {* pair_tac @{context} "a" 1 *})
235.179 -(* TL = nil *)
235.180 -apply (rule conjI)
235.181 -apply (tactic {* pair_tac @{context} "ex" 1 *})
235.182 -apply (tactic {* Seq_case_tac @{context} "y" 1 *})
235.183 -apply (simp add: unlift_def)
235.184 -apply fast
235.185 -apply (simp add: unlift_def)
235.186 -apply fast
235.187 -apply (simp add: unlift_def)
235.188 -apply (tactic {* pair_tac @{context} "a" 1 *})
235.189 -apply (tactic {* Seq_case_simp_tac @{context} "s" 1 *})
235.190 -apply (tactic {* pair_tac @{context} "a" 1 *})
235.191 -(* TL =cons *)
235.192 -apply (simp add: unlift_def)
235.193 -
235.194 -apply (tactic {* pair_tac @{context} "ex" 1 *})
235.195 -apply (tactic {* Seq_case_simp_tac @{context} "y" 1 *})
235.196 -apply (tactic {* pair_tac @{context} "a" 1 *})
235.197 -apply (tactic {* Seq_case_simp_tac @{context} "s" 1 *})
235.198 -apply blast
235.199 -apply fastsimp
235.200 -apply (tactic {* pair_tac @{context} "a" 1 *})
235.201 - apply fastsimp
235.202 -done
235.203 -
235.204 -end
236.1 --- a/src/HOLCF/IOA/meta_theory/Traces.thy Sat Nov 27 14:34:54 2010 -0800
236.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
236.3 @@ -1,410 +0,0 @@
236.4 -(* Title: HOLCF/IOA/meta_theory/Traces.thy
236.5 - Author: Olaf Müller
236.6 -*)
236.7 -
236.8 -header {* Executions and Traces of I/O automata in HOLCF *}
236.9 -
236.10 -theory Traces
236.11 -imports Sequence Automata
236.12 -begin
236.13 -
236.14 -default_sort type
236.15 -
236.16 -types
236.17 - ('a,'s)pairs = "('a * 's) Seq"
236.18 - ('a,'s)execution = "'s * ('a,'s)pairs"
236.19 - 'a trace = "'a Seq"
236.20 -
236.21 - ('a,'s)execution_module = "('a,'s)execution set * 'a signature"
236.22 - 'a schedule_module = "'a trace set * 'a signature"
236.23 - 'a trace_module = "'a trace set * 'a signature"
236.24 -
236.25 -consts
236.26 -
236.27 - (* Executions *)
236.28 -
236.29 - is_exec_fragC ::"('a,'s)ioa => ('a,'s)pairs -> 's => tr"
236.30 - is_exec_frag ::"[('a,'s)ioa, ('a,'s)execution] => bool"
236.31 - has_execution ::"[('a,'s)ioa, ('a,'s)execution] => bool"
236.32 - executions :: "('a,'s)ioa => ('a,'s)execution set"
236.33 -
236.34 - (* Schedules and traces *)
236.35 - filter_act ::"('a,'s)pairs -> 'a trace"
236.36 - has_schedule :: "[('a,'s)ioa, 'a trace] => bool"
236.37 - has_trace :: "[('a,'s)ioa, 'a trace] => bool"
236.38 - schedules :: "('a,'s)ioa => 'a trace set"
236.39 - traces :: "('a,'s)ioa => 'a trace set"
236.40 - mk_trace :: "('a,'s)ioa => ('a,'s)pairs -> 'a trace"
236.41 -
236.42 - laststate ::"('a,'s)execution => 's"
236.43 -
236.44 - (* A predicate holds infinitely (finitely) often in a sequence *)
236.45 -
236.46 - inf_often ::"('a => bool) => 'a Seq => bool"
236.47 - fin_often ::"('a => bool) => 'a Seq => bool"
236.48 -
236.49 - (* fairness of executions *)
236.50 -
236.51 - wfair_ex ::"('a,'s)ioa => ('a,'s)execution => bool"
236.52 - sfair_ex ::"('a,'s)ioa => ('a,'s)execution => bool"
236.53 - is_wfair ::"('a,'s)ioa => 'a set => ('a,'s)execution => bool"
236.54 - is_sfair ::"('a,'s)ioa => 'a set => ('a,'s)execution => bool"
236.55 - fair_ex ::"('a,'s)ioa => ('a,'s)execution => bool"
236.56 -
236.57 - (* fair behavior sets *)
236.58 -
236.59 - fairexecutions ::"('a,'s)ioa => ('a,'s)execution set"
236.60 - fairtraces ::"('a,'s)ioa => 'a trace set"
236.61 -
236.62 - (* Notions of implementation *)
236.63 - ioa_implements :: "[('a,'s1)ioa, ('a,'s2)ioa] => bool" (infixr "=<|" 12)
236.64 - fair_implements :: "('a,'s1)ioa => ('a,'s2)ioa => bool"
236.65 -
236.66 - (* Execution, schedule and trace modules *)
236.67 - Execs :: "('a,'s)ioa => ('a,'s)execution_module"
236.68 - Scheds :: "('a,'s)ioa => 'a schedule_module"
236.69 - Traces :: "('a,'s)ioa => 'a trace_module"
236.70 -
236.71 -
236.72 -defs
236.73 -
236.74 -
236.75 -(* ------------------- Executions ------------------------------ *)
236.76 -
236.77 -
236.78 -is_exec_frag_def:
236.79 - "is_exec_frag A ex == ((is_exec_fragC A$(snd ex)) (fst ex) ~= FF)"
236.80 -
236.81 -
236.82 -is_exec_fragC_def:
236.83 - "is_exec_fragC A ==(fix$(LAM h ex. (%s. case ex of
236.84 - nil => TT
236.85 - | x##xs => (flift1
236.86 - (%p. Def ((s,p):trans_of A) andalso (h$xs) (snd p))
236.87 - $x)
236.88 - )))"
236.89 -
236.90 -
236.91 -
236.92 -executions_def:
236.93 - "executions ioa == {e. ((fst e) : starts_of(ioa)) &
236.94 - is_exec_frag ioa e}"
236.95 -
236.96 -
236.97 -(* ------------------- Schedules ------------------------------ *)
236.98 -
236.99 -
236.100 -filter_act_def:
236.101 - "filter_act == Map fst"
236.102 -
236.103 -has_schedule_def:
236.104 - "has_schedule ioa sch ==
236.105 - (? ex:executions ioa. sch = filter_act$(snd ex))"
236.106 -
236.107 -schedules_def:
236.108 - "schedules ioa == {sch. has_schedule ioa sch}"
236.109 -
236.110 -
236.111 -(* ------------------- Traces ------------------------------ *)
236.112 -
236.113 -has_trace_def:
236.114 - "has_trace ioa tr ==
236.115 - (? sch:schedules ioa. tr = Filter (%a. a:ext(ioa))$sch)"
236.116 -
236.117 -traces_def:
236.118 - "traces ioa == {tr. has_trace ioa tr}"
236.119 -
236.120 -
236.121 -mk_trace_def:
236.122 - "mk_trace ioa == LAM tr.
236.123 - Filter (%a. a:ext(ioa))$(filter_act$tr)"
236.124 -
236.125 -
236.126 -(* ------------------- Fair Traces ------------------------------ *)
236.127 -
236.128 -laststate_def:
236.129 - "laststate ex == case Last$(snd ex) of
236.130 - UU => fst ex
236.131 - | Def at => snd at"
236.132 -
236.133 -inf_often_def:
236.134 - "inf_often P s == Infinite (Filter P$s)"
236.135 -
236.136 -(* filtering P yields a finite or partial sequence *)
236.137 -fin_often_def:
236.138 - "fin_often P s == ~inf_often P s"
236.139 -
236.140 -(* Note that partial execs cannot be wfair as the inf_often predicate in the
236.141 - else branch prohibits it. However they can be sfair in the case when all W
236.142 - are only finitely often enabled: Is this the right model?
236.143 - See LiveIOA for solution conforming with the literature and superseding this one *)
236.144 -wfair_ex_def:
236.145 - "wfair_ex A ex == ! W : wfair_of A.
236.146 - if Finite (snd ex)
236.147 - then ~Enabled A W (laststate ex)
236.148 - else is_wfair A W ex"
236.149 -
236.150 -is_wfair_def:
236.151 - "is_wfair A W ex == (inf_often (%x. fst x:W) (snd ex)
236.152 - | inf_often (%x.~Enabled A W (snd x)) (snd ex))"
236.153 -
236.154 -sfair_ex_def:
236.155 - "sfair_ex A ex == ! W : sfair_of A.
236.156 - if Finite (snd ex)
236.157 - then ~Enabled A W (laststate ex)
236.158 - else is_sfair A W ex"
236.159 -
236.160 -is_sfair_def:
236.161 - "is_sfair A W ex == (inf_often (%x. fst x:W) (snd ex)
236.162 - | fin_often (%x. Enabled A W (snd x)) (snd ex))"
236.163 -
236.164 -fair_ex_def:
236.165 - "fair_ex A ex == wfair_ex A ex & sfair_ex A ex"
236.166 -
236.167 -fairexecutions_def:
236.168 - "fairexecutions A == {ex. ex:executions A & fair_ex A ex}"
236.169 -
236.170 -fairtraces_def:
236.171 - "fairtraces A == {mk_trace A$(snd ex) | ex. ex:fairexecutions A}"
236.172 -
236.173 -
236.174 -(* ------------------- Implementation ------------------------------ *)
236.175 -
236.176 -ioa_implements_def:
236.177 - "ioa1 =<| ioa2 ==
236.178 - (((inputs(asig_of(ioa1)) = inputs(asig_of(ioa2))) &
236.179 - (outputs(asig_of(ioa1)) = outputs(asig_of(ioa2)))) &
236.180 - traces(ioa1) <= traces(ioa2))"
236.181 -
236.182 -fair_implements_def:
236.183 - "fair_implements C A == inp(C) = inp(A) & out(C)=out(A) &
236.184 - fairtraces(C) <= fairtraces(A)"
236.185 -
236.186 -(* ------------------- Modules ------------------------------ *)
236.187 -
236.188 -Execs_def:
236.189 - "Execs A == (executions A, asig_of A)"
236.190 -
236.191 -Scheds_def:
236.192 - "Scheds A == (schedules A, asig_of A)"
236.193 -
236.194 -Traces_def:
236.195 - "Traces A == (traces A,asig_of A)"
236.196 -
236.197 -
236.198 -lemmas [simp del] = HOL.ex_simps HOL.all_simps split_paired_Ex
236.199 -declare Let_def [simp]
236.200 -declaration {* fn _ => Classical.map_cs (fn cs => cs delSWrapper "split_all_tac") *}
236.201 -
236.202 -lemmas exec_rws = executions_def is_exec_frag_def
236.203 -
236.204 -
236.205 -
236.206 -subsection "recursive equations of operators"
236.207 -
236.208 -(* ---------------------------------------------------------------- *)
236.209 -(* filter_act *)
236.210 -(* ---------------------------------------------------------------- *)
236.211 -
236.212 -
236.213 -lemma filter_act_UU: "filter_act$UU = UU"
236.214 -apply (simp add: filter_act_def)
236.215 -done
236.216 -
236.217 -lemma filter_act_nil: "filter_act$nil = nil"
236.218 -apply (simp add: filter_act_def)
236.219 -done
236.220 -
236.221 -lemma filter_act_cons: "filter_act$(x>>xs) = (fst x) >> filter_act$xs"
236.222 -apply (simp add: filter_act_def)
236.223 -done
236.224 -
236.225 -declare filter_act_UU [simp] filter_act_nil [simp] filter_act_cons [simp]
236.226 -
236.227 -
236.228 -(* ---------------------------------------------------------------- *)
236.229 -(* mk_trace *)
236.230 -(* ---------------------------------------------------------------- *)
236.231 -
236.232 -lemma mk_trace_UU: "mk_trace A$UU=UU"
236.233 -apply (simp add: mk_trace_def)
236.234 -done
236.235 -
236.236 -lemma mk_trace_nil: "mk_trace A$nil=nil"
236.237 -apply (simp add: mk_trace_def)
236.238 -done
236.239 -
236.240 -lemma mk_trace_cons: "mk_trace A$(at >> xs) =
236.241 - (if ((fst at):ext A)
236.242 - then (fst at) >> (mk_trace A$xs)
236.243 - else mk_trace A$xs)"
236.244 -
236.245 -apply (simp add: mk_trace_def)
236.246 -done
236.247 -
236.248 -declare mk_trace_UU [simp] mk_trace_nil [simp] mk_trace_cons [simp]
236.249 -
236.250 -(* ---------------------------------------------------------------- *)
236.251 -(* is_exec_fragC *)
236.252 -(* ---------------------------------------------------------------- *)
236.253 -
236.254 -
236.255 -lemma is_exec_fragC_unfold: "is_exec_fragC A = (LAM ex. (%s. case ex of
236.256 - nil => TT
236.257 - | x##xs => (flift1
236.258 - (%p. Def ((s,p):trans_of A) andalso (is_exec_fragC A$xs) (snd p))
236.259 - $x)
236.260 - ))"
236.261 -apply (rule trans)
236.262 -apply (rule fix_eq2)
236.263 -apply (rule is_exec_fragC_def)
236.264 -apply (rule beta_cfun)
236.265 -apply (simp add: flift1_def)
236.266 -done
236.267 -
236.268 -lemma is_exec_fragC_UU: "(is_exec_fragC A$UU) s=UU"
236.269 -apply (subst is_exec_fragC_unfold)
236.270 -apply simp
236.271 -done
236.272 -
236.273 -lemma is_exec_fragC_nil: "(is_exec_fragC A$nil) s = TT"
236.274 -apply (subst is_exec_fragC_unfold)
236.275 -apply simp
236.276 -done
236.277 -
236.278 -lemma is_exec_fragC_cons: "(is_exec_fragC A$(pr>>xs)) s =
236.279 - (Def ((s,pr):trans_of A)
236.280 - andalso (is_exec_fragC A$xs)(snd pr))"
236.281 -apply (rule trans)
236.282 -apply (subst is_exec_fragC_unfold)
236.283 -apply (simp add: Consq_def flift1_def)
236.284 -apply simp
236.285 -done
236.286 -
236.287 -
236.288 -declare is_exec_fragC_UU [simp] is_exec_fragC_nil [simp] is_exec_fragC_cons [simp]
236.289 -
236.290 -
236.291 -(* ---------------------------------------------------------------- *)
236.292 -(* is_exec_frag *)
236.293 -(* ---------------------------------------------------------------- *)
236.294 -
236.295 -lemma is_exec_frag_UU: "is_exec_frag A (s, UU)"
236.296 -apply (simp add: is_exec_frag_def)
236.297 -done
236.298 -
236.299 -lemma is_exec_frag_nil: "is_exec_frag A (s, nil)"
236.300 -apply (simp add: is_exec_frag_def)
236.301 -done
236.302 -
236.303 -lemma is_exec_frag_cons: "is_exec_frag A (s, (a,t)>>ex) =
236.304 - (((s,a,t):trans_of A) &
236.305 - is_exec_frag A (t, ex))"
236.306 -apply (simp add: is_exec_frag_def)
236.307 -done
236.308 -
236.309 -
236.310 -(* Delsimps [is_exec_fragC_UU,is_exec_fragC_nil,is_exec_fragC_cons]; *)
236.311 -declare is_exec_frag_UU [simp] is_exec_frag_nil [simp] is_exec_frag_cons [simp]
236.312 -
236.313 -(* ---------------------------------------------------------------------------- *)
236.314 - section "laststate"
236.315 -(* ---------------------------------------------------------------------------- *)
236.316 -
236.317 -lemma laststate_UU: "laststate (s,UU) = s"
236.318 -apply (simp add: laststate_def)
236.319 -done
236.320 -
236.321 -lemma laststate_nil: "laststate (s,nil) = s"
236.322 -apply (simp add: laststate_def)
236.323 -done
236.324 -
236.325 -lemma laststate_cons: "!! ex. Finite ex ==> laststate (s,at>>ex) = laststate (snd at,ex)"
236.326 -apply (simp (no_asm) add: laststate_def)
236.327 -apply (case_tac "ex=nil")
236.328 -apply (simp (no_asm_simp))
236.329 -apply (simp (no_asm_simp))
236.330 -apply (drule Finite_Last1 [THEN mp])
236.331 -apply assumption
236.332 -apply defined
236.333 -done
236.334 -
236.335 -declare laststate_UU [simp] laststate_nil [simp] laststate_cons [simp]
236.336 -
236.337 -lemma exists_laststate: "!!ex. Finite ex ==> (! s. ? u. laststate (s,ex)=u)"
236.338 -apply (tactic "Seq_Finite_induct_tac @{context} 1")
236.339 -done
236.340 -
236.341 -
236.342 -subsection "has_trace, mk_trace"
236.343 -
236.344 -(* alternative definition of has_trace tailored for the refinement proof, as it does not
236.345 - take the detour of schedules *)
236.346 -
236.347 -lemma has_trace_def2:
236.348 -"has_trace A b = (? ex:executions A. b = mk_trace A$(snd ex))"
236.349 -apply (unfold executions_def mk_trace_def has_trace_def schedules_def has_schedule_def)
236.350 -apply auto
236.351 -done
236.352 -
236.353 -
236.354 -subsection "signatures and executions, schedules"
236.355 -
236.356 -(* All executions of A have only actions of A. This is only true because of the
236.357 - predicate state_trans (part of the predicate IOA): We have no dependent types.
236.358 - For executions of parallel automata this assumption is not needed, as in par_def
236.359 - this condition is included once more. (see Lemmas 1.1.1c in CompoExecs for example) *)
236.360 -
236.361 -lemma execfrag_in_sig:
236.362 - "!! A. is_trans_of A ==>
236.363 - ! s. is_exec_frag A (s,xs) --> Forall (%a. a:act A) (filter_act$xs)"
236.364 -apply (tactic {* pair_induct_tac @{context} "xs" [@{thm is_exec_frag_def},
236.365 - @{thm Forall_def}, @{thm sforall_def}] 1 *})
236.366 -(* main case *)
236.367 -apply (auto simp add: is_trans_of_def)
236.368 -done
236.369 -
236.370 -lemma exec_in_sig:
236.371 - "!! A.[| is_trans_of A; x:executions A |] ==>
236.372 - Forall (%a. a:act A) (filter_act$(snd x))"
236.373 -apply (simp add: executions_def)
236.374 -apply (tactic {* pair_tac @{context} "x" 1 *})
236.375 -apply (rule execfrag_in_sig [THEN spec, THEN mp])
236.376 -apply auto
236.377 -done
236.378 -
236.379 -lemma scheds_in_sig:
236.380 - "!! A.[| is_trans_of A; x:schedules A |] ==>
236.381 - Forall (%a. a:act A) x"
236.382 -apply (unfold schedules_def has_schedule_def)
236.383 -apply (fast intro!: exec_in_sig)
236.384 -done
236.385 -
236.386 -
236.387 -subsection "executions are prefix closed"
236.388 -
236.389 -(* only admissible in y, not if done in x !! *)
236.390 -lemma execfrag_prefixclosed: "!x s. is_exec_frag A (s,x) & y<<x --> is_exec_frag A (s,y)"
236.391 -apply (tactic {* pair_induct_tac @{context} "y" [@{thm is_exec_frag_def}] 1 *})
236.392 -apply (intro strip)
236.393 -apply (tactic {* Seq_case_simp_tac @{context} "xa" 1 *})
236.394 -apply (tactic {* pair_tac @{context} "a" 1 *})
236.395 -apply auto
236.396 -done
236.397 -
236.398 -lemmas exec_prefixclosed =
236.399 - conjI [THEN execfrag_prefixclosed [THEN spec, THEN spec, THEN mp], standard]
236.400 -
236.401 -
236.402 -(* second prefix notion for Finite x *)
236.403 -
236.404 -lemma exec_prefix2closed [rule_format]:
236.405 - "! y s. is_exec_frag A (s,x@@y) --> is_exec_frag A (s,x)"
236.406 -apply (tactic {* pair_induct_tac @{context} "x" [@{thm is_exec_frag_def}] 1 *})
236.407 -apply (intro strip)
236.408 -apply (tactic {* Seq_case_simp_tac @{context} "s" 1 *})
236.409 -apply (tactic {* pair_tac @{context} "a" 1 *})
236.410 -apply auto
236.411 -done
236.412 -
236.413 -end
237.1 --- a/src/HOLCF/IsaMakefile Sat Nov 27 14:34:54 2010 -0800
237.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
237.3 @@ -1,224 +0,0 @@
237.4 -#
237.5 -# IsaMakefile for HOLCF
237.6 -#
237.7 -
237.8 -## targets
237.9 -
237.10 -default: HOLCF
237.11 -images: HOLCF IOA
237.12 -test: \
237.13 - HOLCF-FOCUS \
237.14 - HOLCF-IMP \
237.15 - HOLCF-Library \
237.16 - HOLCF-Tutorial \
237.17 - HOLCF-ex \
237.18 - IOA-ABP \
237.19 - IOA-NTP \
237.20 - IOA-Storage \
237.21 - IOA-ex
237.22 -all: images test
237.23 -
237.24 -
237.25 -## global settings
237.26 -
237.27 -SRC = $(ISABELLE_HOME)/src
237.28 -OUT = $(ISABELLE_OUTPUT)
237.29 -LOG = $(OUT)/log
237.30 -
237.31 -
237.32 -## HOLCF
237.33 -
237.34 -HOLCF: HOL $(OUT)/HOLCF
237.35 -
237.36 -HOL:
237.37 - @cd $(SRC)/HOL; $(ISABELLE_TOOL) make HOL
237.38 -
237.39 -$(OUT)/HOLCF: $(OUT)/HOL \
237.40 - ROOT.ML \
237.41 - Adm.thy \
237.42 - Algebraic.thy \
237.43 - Bifinite.thy \
237.44 - Cfun.thy \
237.45 - CompactBasis.thy \
237.46 - Completion.thy \
237.47 - Cont.thy \
237.48 - ConvexPD.thy \
237.49 - Cpodef.thy \
237.50 - Cprod.thy \
237.51 - Discrete.thy \
237.52 - Deflation.thy \
237.53 - Domain.thy \
237.54 - Domain_Aux.thy \
237.55 - Fixrec.thy \
237.56 - Fix.thy \
237.57 - Fun_Cpo.thy \
237.58 - HOLCF.thy \
237.59 - Lift.thy \
237.60 - LowerPD.thy \
237.61 - Map_Functions.thy \
237.62 - One.thy \
237.63 - Pcpo.thy \
237.64 - Plain_HOLCF.thy \
237.65 - Porder.thy \
237.66 - Powerdomains.thy \
237.67 - Product_Cpo.thy \
237.68 - Sfun.thy \
237.69 - Sprod.thy \
237.70 - Ssum.thy \
237.71 - Tr.thy \
237.72 - Universal.thy \
237.73 - UpperPD.thy \
237.74 - Up.thy \
237.75 - Tools/cont_consts.ML \
237.76 - Tools/cont_proc.ML \
237.77 - Tools/holcf_library.ML \
237.78 - Tools/Domain/domain.ML \
237.79 - Tools/Domain/domain_axioms.ML \
237.80 - Tools/Domain/domain_constructors.ML \
237.81 - Tools/Domain/domain_induction.ML \
237.82 - Tools/Domain/domain_isomorphism.ML \
237.83 - Tools/Domain/domain_take_proofs.ML \
237.84 - Tools/cpodef.ML \
237.85 - Tools/domaindef.ML \
237.86 - Tools/fixrec.ML \
237.87 - document/root.tex
237.88 - @$(ISABELLE_TOOL) usedir -b -g true -r $(OUT)/HOL HOLCF
237.89 -
237.90 -
237.91 -## HOLCF-Tutorial
237.92 -
237.93 -HOLCF-Tutorial: HOLCF $(LOG)/HOLCF-Tutorial.gz
237.94 -
237.95 -$(LOG)/HOLCF-Tutorial.gz: $(OUT)/HOLCF \
237.96 - Tutorial/Domain_ex.thy \
237.97 - Tutorial/Fixrec_ex.thy \
237.98 - Tutorial/New_Domain.thy \
237.99 - Tutorial/document/root.tex \
237.100 - Tutorial/ROOT.ML
237.101 - @$(ISABELLE_TOOL) usedir $(OUT)/HOLCF Tutorial
237.102 -
237.103 -
237.104 -## HOLCF-Library
237.105 -
237.106 -HOLCF-Library: HOLCF $(LOG)/HOLCF-Library.gz
237.107 -
237.108 -$(LOG)/HOLCF-Library.gz: $(OUT)/HOLCF \
237.109 - Library/Defl_Bifinite.thy \
237.110 - Library/List_Cpo.thy \
237.111 - Library/Stream.thy \
237.112 - Library/Sum_Cpo.thy \
237.113 - Library/HOLCF_Library.thy \
237.114 - Library/ROOT.ML
237.115 - @$(ISABELLE_TOOL) usedir $(OUT)/HOLCF Library
237.116 -
237.117 -
237.118 -## HOLCF-IMP
237.119 -
237.120 -HOLCF-IMP: HOLCF $(LOG)/HOLCF-IMP.gz
237.121 -
237.122 -$(LOG)/HOLCF-IMP.gz: $(OUT)/HOLCF IMP/HoareEx.thy \
237.123 - IMP/Denotational.thy IMP/ROOT.ML IMP/document/root.tex
237.124 - @$(ISABELLE_TOOL) usedir $(OUT)/HOLCF IMP
237.125 -
237.126 -
237.127 -## HOLCF-ex
237.128 -
237.129 -HOLCF-ex: HOLCF $(LOG)/HOLCF-ex.gz
237.130 -
237.131 -$(LOG)/HOLCF-ex.gz: $(OUT)/HOLCF \
237.132 - ../HOL/Library/Nat_Infinity.thy \
237.133 - ex/Dagstuhl.thy \
237.134 - ex/Dnat.thy \
237.135 - ex/Domain_Proofs.thy \
237.136 - ex/Fix2.thy \
237.137 - ex/Focus_ex.thy \
237.138 - ex/Hoare.thy \
237.139 - ex/Letrec.thy \
237.140 - ex/Loop.thy \
237.141 - ex/Pattern_Match.thy \
237.142 - ex/Powerdomain_ex.thy \
237.143 - ex/ROOT.ML
237.144 - @$(ISABELLE_TOOL) usedir $(OUT)/HOLCF ex
237.145 -
237.146 -
237.147 -## HOLCF-FOCUS
237.148 -
237.149 -HOLCF-FOCUS: HOLCF $(LOG)/HOLCF-FOCUS.gz
237.150 -
237.151 -$(LOG)/HOLCF-FOCUS.gz: $(OUT)/HOLCF \
237.152 - Library/Stream.thy \
237.153 - FOCUS/Fstreams.thy \
237.154 - FOCUS/Fstream.thy FOCUS/FOCUS.thy \
237.155 - FOCUS/Stream_adm.thy ../HOL/Library/Continuity.thy \
237.156 - FOCUS/Buffer.thy FOCUS/Buffer_adm.thy
237.157 - @$(ISABELLE_TOOL) usedir $(OUT)/HOLCF FOCUS
237.158 -
237.159 -## IOA
237.160 -
237.161 -IOA: HOLCF $(OUT)/IOA
237.162 -
237.163 -$(OUT)/IOA: $(OUT)/HOLCF IOA/ROOT.ML IOA/meta_theory/Traces.thy \
237.164 - IOA/meta_theory/Asig.thy IOA/meta_theory/CompoScheds.thy \
237.165 - IOA/meta_theory/CompoTraces.thy IOA/meta_theory/Seq.thy \
237.166 - IOA/meta_theory/RefCorrectness.thy IOA/meta_theory/Automata.thy \
237.167 - IOA/meta_theory/ShortExecutions.thy IOA/meta_theory/IOA.thy \
237.168 - IOA/meta_theory/Sequence.thy IOA/meta_theory/CompoExecs.thy \
237.169 - IOA/meta_theory/RefMappings.thy IOA/meta_theory/Compositionality.thy \
237.170 - IOA/meta_theory/TL.thy IOA/meta_theory/TLS.thy \
237.171 - IOA/meta_theory/LiveIOA.thy IOA/meta_theory/Pred.thy \
237.172 - IOA/meta_theory/Abstraction.thy IOA/meta_theory/Simulations.thy \
237.173 - IOA/meta_theory/SimCorrectness.thy
237.174 - @cd IOA; $(ISABELLE_TOOL) usedir -b $(OUT)/HOLCF IOA
237.175 -
237.176 -
237.177 -## IOA-ABP
237.178 -
237.179 -IOA-ABP: IOA $(LOG)/IOA-ABP.gz
237.180 -
237.181 -$(LOG)/IOA-ABP.gz: $(OUT)/IOA IOA/ABP/Abschannel.thy \
237.182 - IOA/ABP/Abschannel_finite.thy IOA/ABP/Action.thy \
237.183 - IOA/ABP/Check.ML IOA/ABP/Correctness.thy \
237.184 - IOA/ABP/Env.thy IOA/ABP/Impl.thy IOA/ABP/Impl_finite.thy \
237.185 - IOA/ABP/Lemmas.thy IOA/ABP/Packet.thy \
237.186 - IOA/ABP/ROOT.ML IOA/ABP/Receiver.thy IOA/ABP/Sender.thy \
237.187 - IOA/ABP/Spec.thy
237.188 - @cd IOA; $(ISABELLE_TOOL) usedir $(OUT)/IOA ABP
237.189 -
237.190 -## IOA-NTP
237.191 -
237.192 -IOA-NTP: IOA $(LOG)/IOA-NTP.gz
237.193 -
237.194 -$(LOG)/IOA-NTP.gz: $(OUT)/IOA \
237.195 - IOA/NTP/Abschannel.thy IOA/NTP/Action.thy IOA/NTP/Correctness.thy \
237.196 - IOA/NTP/Impl.thy IOA/NTP/Lemmas.thy IOA/NTP/Multiset.thy \
237.197 - IOA/NTP/Packet.thy IOA/NTP/ROOT.ML IOA/NTP/Receiver.thy IOA/NTP/Sender.thy \
237.198 - IOA/NTP/Spec.thy
237.199 - @cd IOA; $(ISABELLE_TOOL) usedir $(OUT)/IOA NTP
237.200 -
237.201 -
237.202 -## IOA-Storage
237.203 -
237.204 -IOA-Storage: IOA $(LOG)/IOA-Storage.gz
237.205 -
237.206 -$(LOG)/IOA-Storage.gz: $(OUT)/IOA IOA/Storage/Action.thy \
237.207 - IOA/Storage/Correctness.thy IOA/Storage/Impl.thy \
237.208 - IOA/Storage/ROOT.ML IOA/Storage/Spec.thy
237.209 - @cd IOA; $(ISABELLE_TOOL) usedir $(OUT)/IOA Storage
237.210 -
237.211 -
237.212 -## IOA-ex
237.213 -
237.214 -IOA-ex: IOA $(LOG)/IOA-ex.gz
237.215 -
237.216 -$(LOG)/IOA-ex.gz: $(OUT)/IOA IOA/ex/ROOT.ML IOA/ex/TrivEx.thy IOA/ex/TrivEx2.thy
237.217 - @cd IOA; $(ISABELLE_TOOL) usedir $(OUT)/IOA ex
237.218 -
237.219 -
237.220 -## clean
237.221 -
237.222 -clean:
237.223 - @rm -f $(OUT)/HOLCF $(LOG)/HOLCF.gz $(LOG)/HOLCF-IMP.gz \
237.224 - $(LOG)/HOLCF-ex.gz $(LOG)/HOLCF-FOCUS.gz $(OUT)/IOA \
237.225 - $(LOG)/IOA.gz $(LOG)/IOA-ABP.gz $(LOG)/IOA-NTP.gz \
237.226 - $(LOG)/IOA-Storage.gz $(LOG)/HOLCF-Library.gz \
237.227 - $(LOG)/IOA-ex.gz $(LOG)/HOLCF-Tutorial.gz
238.1 --- a/src/HOLCF/Library/Defl_Bifinite.thy Sat Nov 27 14:34:54 2010 -0800
238.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
238.3 @@ -1,661 +0,0 @@
238.4 -(* Title: HOLCF/Library/Defl_Bifinite.thy
238.5 - Author: Brian Huffman
238.6 -*)
238.7 -
238.8 -header {* Algebraic deflations are a bifinite domain *}
238.9 -
238.10 -theory Defl_Bifinite
238.11 -imports HOLCF Infinite_Set
238.12 -begin
238.13 -
238.14 -subsection {* Lemmas about MOST *}
238.15 -
238.16 -default_sort type
238.17 -
238.18 -lemma MOST_INFM:
238.19 - assumes inf: "infinite (UNIV::'a set)"
238.20 - shows "MOST x::'a. P x \<Longrightarrow> INFM x::'a. P x"
238.21 - unfolding Alm_all_def Inf_many_def
238.22 - apply (auto simp add: Collect_neg_eq)
238.23 - apply (drule (1) finite_UnI)
238.24 - apply (simp add: Compl_partition2 inf)
238.25 - done
238.26 -
238.27 -lemma MOST_SucI: "MOST n. P n \<Longrightarrow> MOST n. P (Suc n)"
238.28 -by (rule MOST_inj [OF _ inj_Suc])
238.29 -
238.30 -lemma MOST_SucD: "MOST n. P (Suc n) \<Longrightarrow> MOST n. P n"
238.31 -unfolding MOST_nat
238.32 -apply (clarify, rule_tac x="Suc m" in exI, clarify)
238.33 -apply (erule Suc_lessE, simp)
238.34 -done
238.35 -
238.36 -lemma MOST_Suc_iff: "(MOST n. P (Suc n)) \<longleftrightarrow> (MOST n. P n)"
238.37 -by (rule iffI [OF MOST_SucD MOST_SucI])
238.38 -
238.39 -lemma INFM_finite_Bex_distrib:
238.40 - "finite A \<Longrightarrow> (INFM y. \<exists>x\<in>A. P x y) \<longleftrightarrow> (\<exists>x\<in>A. INFM y. P x y)"
238.41 -by (induct set: finite, simp, simp add: INFM_disj_distrib)
238.42 -
238.43 -lemma MOST_finite_Ball_distrib:
238.44 - "finite A \<Longrightarrow> (MOST y. \<forall>x\<in>A. P x y) \<longleftrightarrow> (\<forall>x\<in>A. MOST y. P x y)"
238.45 -by (induct set: finite, simp, simp add: MOST_conj_distrib)
238.46 -
238.47 -lemma MOST_ge_nat: "MOST n::nat. m \<le> n"
238.48 -unfolding MOST_nat_le by fast
238.49 -
238.50 -subsection {* Eventually constant sequences *}
238.51 -
238.52 -definition
238.53 - eventually_constant :: "(nat \<Rightarrow> 'a) \<Rightarrow> bool"
238.54 -where
238.55 - "eventually_constant S = (\<exists>x. MOST i. S i = x)"
238.56 -
238.57 -lemma eventually_constant_MOST_MOST:
238.58 - "eventually_constant S \<longleftrightarrow> (MOST m. MOST n. S n = S m)"
238.59 -unfolding eventually_constant_def MOST_nat
238.60 -apply safe
238.61 -apply (rule_tac x=m in exI, clarify)
238.62 -apply (rule_tac x=m in exI, clarify)
238.63 -apply simp
238.64 -apply fast
238.65 -done
238.66 -
238.67 -lemma eventually_constantI: "MOST i. S i = x \<Longrightarrow> eventually_constant S"
238.68 -unfolding eventually_constant_def by fast
238.69 -
238.70 -lemma eventually_constant_comp:
238.71 - "eventually_constant (\<lambda>i. S i) \<Longrightarrow> eventually_constant (\<lambda>i. f (S i))"
238.72 -unfolding eventually_constant_def
238.73 -apply (erule exE, rule_tac x="f x" in exI)
238.74 -apply (erule MOST_mono, simp)
238.75 -done
238.76 -
238.77 -lemma eventually_constant_Suc_iff:
238.78 - "eventually_constant (\<lambda>i. S (Suc i)) \<longleftrightarrow> eventually_constant (\<lambda>i. S i)"
238.79 -unfolding eventually_constant_def
238.80 -by (subst MOST_Suc_iff, rule refl)
238.81 -
238.82 -lemma eventually_constant_SucD:
238.83 - "eventually_constant (\<lambda>i. S (Suc i)) \<Longrightarrow> eventually_constant (\<lambda>i. S i)"
238.84 -by (rule eventually_constant_Suc_iff [THEN iffD1])
238.85 -
238.86 -subsection {* Limits of eventually constant sequences *}
238.87 -
238.88 -definition
238.89 - eventual :: "(nat \<Rightarrow> 'a) \<Rightarrow> 'a" where
238.90 - "eventual S = (THE x. MOST i. S i = x)"
238.91 -
238.92 -lemma eventual_eqI: "MOST i. S i = x \<Longrightarrow> eventual S = x"
238.93 -unfolding eventual_def
238.94 -apply (rule the_equality, assumption)
238.95 -apply (rename_tac y)
238.96 -apply (subgoal_tac "MOST i::nat. y = x", simp)
238.97 -apply (erule MOST_rev_mp)
238.98 -apply (erule MOST_rev_mp)
238.99 -apply simp
238.100 -done
238.101 -
238.102 -lemma MOST_eq_eventual:
238.103 - "eventually_constant S \<Longrightarrow> MOST i. S i = eventual S"
238.104 -unfolding eventually_constant_def
238.105 -by (erule exE, simp add: eventual_eqI)
238.106 -
238.107 -lemma eventual_mem_range:
238.108 - "eventually_constant S \<Longrightarrow> eventual S \<in> range S"
238.109 -apply (drule MOST_eq_eventual)
238.110 -apply (simp only: MOST_nat_le, clarify)
238.111 -apply (drule spec, drule mp, rule order_refl)
238.112 -apply (erule range_eqI [OF sym])
238.113 -done
238.114 -
238.115 -lemma eventually_constant_MOST_iff:
238.116 - assumes S: "eventually_constant S"
238.117 - shows "(MOST n. P (S n)) \<longleftrightarrow> P (eventual S)"
238.118 -apply (subgoal_tac "(MOST n. P (S n)) \<longleftrightarrow> (MOST n::nat. P (eventual S))")
238.119 -apply simp
238.120 -apply (rule iffI)
238.121 -apply (rule MOST_rev_mp [OF MOST_eq_eventual [OF S]])
238.122 -apply (erule MOST_mono, force)
238.123 -apply (rule MOST_rev_mp [OF MOST_eq_eventual [OF S]])
238.124 -apply (erule MOST_mono, simp)
238.125 -done
238.126 -
238.127 -lemma MOST_eventual:
238.128 - "\<lbrakk>eventually_constant S; MOST n. P (S n)\<rbrakk> \<Longrightarrow> P (eventual S)"
238.129 -proof -
238.130 - assume "eventually_constant S"
238.131 - hence "MOST n. S n = eventual S"
238.132 - by (rule MOST_eq_eventual)
238.133 - moreover assume "MOST n. P (S n)"
238.134 - ultimately have "MOST n. S n = eventual S \<and> P (S n)"
238.135 - by (rule MOST_conj_distrib [THEN iffD2, OF conjI])
238.136 - hence "MOST n::nat. P (eventual S)"
238.137 - by (rule MOST_mono) auto
238.138 - thus ?thesis by simp
238.139 -qed
238.140 -
238.141 -lemma eventually_constant_MOST_Suc_eq:
238.142 - "eventually_constant S \<Longrightarrow> MOST n. S (Suc n) = S n"
238.143 -apply (drule MOST_eq_eventual)
238.144 -apply (frule MOST_Suc_iff [THEN iffD2])
238.145 -apply (erule MOST_rev_mp)
238.146 -apply (erule MOST_rev_mp)
238.147 -apply simp
238.148 -done
238.149 -
238.150 -lemma eventual_comp:
238.151 - "eventually_constant S \<Longrightarrow> eventual (\<lambda>i. f (S i)) = f (eventual (\<lambda>i. S i))"
238.152 -apply (rule eventual_eqI)
238.153 -apply (rule MOST_mono)
238.154 -apply (erule MOST_eq_eventual)
238.155 -apply simp
238.156 -done
238.157 -
238.158 -subsection {* Constructing finite deflations by iteration *}
238.159 -
238.160 -default_sort cpo
238.161 -
238.162 -lemma le_Suc_induct:
238.163 - assumes le: "i \<le> j"
238.164 - assumes step: "\<And>i. P i (Suc i)"
238.165 - assumes refl: "\<And>i. P i i"
238.166 - assumes trans: "\<And>i j k. \<lbrakk>P i j; P j k\<rbrakk> \<Longrightarrow> P i k"
238.167 - shows "P i j"
238.168 -proof (cases "i = j")
238.169 - assume "i = j"
238.170 - thus "P i j" by (simp add: refl)
238.171 -next
238.172 - assume "i \<noteq> j"
238.173 - with le have "i < j" by simp
238.174 - thus "P i j" using step trans by (rule less_Suc_induct)
238.175 -qed
238.176 -
238.177 -definition
238.178 - eventual_iterate :: "('a \<rightarrow> 'a::cpo) \<Rightarrow> ('a \<rightarrow> 'a)"
238.179 -where
238.180 - "eventual_iterate f = eventual (\<lambda>n. iterate n\<cdot>f)"
238.181 -
238.182 -text {* A pre-deflation is like a deflation, but not idempotent. *}
238.183 -
238.184 -locale pre_deflation =
238.185 - fixes f :: "'a \<rightarrow> 'a::cpo"
238.186 - assumes below: "\<And>x. f\<cdot>x \<sqsubseteq> x"
238.187 - assumes finite_range: "finite (range (\<lambda>x. f\<cdot>x))"
238.188 -begin
238.189 -
238.190 -lemma iterate_below: "iterate i\<cdot>f\<cdot>x \<sqsubseteq> x"
238.191 -by (induct i, simp_all add: below_trans [OF below])
238.192 -
238.193 -lemma iterate_fixed: "f\<cdot>x = x \<Longrightarrow> iterate i\<cdot>f\<cdot>x = x"
238.194 -by (induct i, simp_all)
238.195 -
238.196 -lemma antichain_iterate_app: "i \<le> j \<Longrightarrow> iterate j\<cdot>f\<cdot>x \<sqsubseteq> iterate i\<cdot>f\<cdot>x"
238.197 -apply (erule le_Suc_induct)
238.198 -apply (simp add: below)
238.199 -apply (rule below_refl)
238.200 -apply (erule (1) below_trans)
238.201 -done
238.202 -
238.203 -lemma finite_range_iterate_app: "finite (range (\<lambda>i. iterate i\<cdot>f\<cdot>x))"
238.204 -proof (rule finite_subset)
238.205 - show "range (\<lambda>i. iterate i\<cdot>f\<cdot>x) \<subseteq> insert x (range (\<lambda>x. f\<cdot>x))"
238.206 - by (clarify, case_tac i, simp_all)
238.207 - show "finite (insert x (range (\<lambda>x. f\<cdot>x)))"
238.208 - by (simp add: finite_range)
238.209 -qed
238.210 -
238.211 -lemma eventually_constant_iterate_app:
238.212 - "eventually_constant (\<lambda>i. iterate i\<cdot>f\<cdot>x)"
238.213 -unfolding eventually_constant_def MOST_nat_le
238.214 -proof -
238.215 - let ?Y = "\<lambda>i. iterate i\<cdot>f\<cdot>x"
238.216 - have "\<exists>j. \<forall>k. ?Y j \<sqsubseteq> ?Y k"
238.217 - apply (rule finite_range_has_max)
238.218 - apply (erule antichain_iterate_app)
238.219 - apply (rule finite_range_iterate_app)
238.220 - done
238.221 - then obtain j where j: "\<And>k. ?Y j \<sqsubseteq> ?Y k" by fast
238.222 - show "\<exists>z m. \<forall>n\<ge>m. ?Y n = z"
238.223 - proof (intro exI allI impI)
238.224 - fix k
238.225 - assume "j \<le> k"
238.226 - hence "?Y k \<sqsubseteq> ?Y j" by (rule antichain_iterate_app)
238.227 - also have "?Y j \<sqsubseteq> ?Y k" by (rule j)
238.228 - finally show "?Y k = ?Y j" .
238.229 - qed
238.230 -qed
238.231 -
238.232 -lemma eventually_constant_iterate:
238.233 - "eventually_constant (\<lambda>n. iterate n\<cdot>f)"
238.234 -proof -
238.235 - have "\<forall>y\<in>range (\<lambda>x. f\<cdot>x). eventually_constant (\<lambda>i. iterate i\<cdot>f\<cdot>y)"
238.236 - by (simp add: eventually_constant_iterate_app)
238.237 - hence "\<forall>y\<in>range (\<lambda>x. f\<cdot>x). MOST i. MOST j. iterate j\<cdot>f\<cdot>y = iterate i\<cdot>f\<cdot>y"
238.238 - unfolding eventually_constant_MOST_MOST .
238.239 - hence "MOST i. MOST j. \<forall>y\<in>range (\<lambda>x. f\<cdot>x). iterate j\<cdot>f\<cdot>y = iterate i\<cdot>f\<cdot>y"
238.240 - by (simp only: MOST_finite_Ball_distrib [OF finite_range])
238.241 - hence "MOST i. MOST j. \<forall>x. iterate j\<cdot>f\<cdot>(f\<cdot>x) = iterate i\<cdot>f\<cdot>(f\<cdot>x)"
238.242 - by simp
238.243 - hence "MOST i. MOST j. \<forall>x. iterate (Suc j)\<cdot>f\<cdot>x = iterate (Suc i)\<cdot>f\<cdot>x"
238.244 - by (simp only: iterate_Suc2)
238.245 - hence "MOST i. MOST j. iterate (Suc j)\<cdot>f = iterate (Suc i)\<cdot>f"
238.246 - by (simp only: cfun_eq_iff)
238.247 - hence "eventually_constant (\<lambda>i. iterate (Suc i)\<cdot>f)"
238.248 - unfolding eventually_constant_MOST_MOST .
238.249 - thus "eventually_constant (\<lambda>i. iterate i\<cdot>f)"
238.250 - by (rule eventually_constant_SucD)
238.251 -qed
238.252 -
238.253 -abbreviation
238.254 - d :: "'a \<rightarrow> 'a"
238.255 -where
238.256 - "d \<equiv> eventual_iterate f"
238.257 -
238.258 -lemma MOST_d: "MOST n. P (iterate n\<cdot>f) \<Longrightarrow> P d"
238.259 -unfolding eventual_iterate_def
238.260 -using eventually_constant_iterate by (rule MOST_eventual)
238.261 -
238.262 -lemma f_d: "f\<cdot>(d\<cdot>x) = d\<cdot>x"
238.263 -apply (rule MOST_d)
238.264 -apply (subst iterate_Suc [symmetric])
238.265 -apply (rule eventually_constant_MOST_Suc_eq)
238.266 -apply (rule eventually_constant_iterate_app)
238.267 -done
238.268 -
238.269 -lemma d_fixed_iff: "d\<cdot>x = x \<longleftrightarrow> f\<cdot>x = x"
238.270 -proof
238.271 - assume "d\<cdot>x = x"
238.272 - with f_d [where x=x]
238.273 - show "f\<cdot>x = x" by simp
238.274 -next
238.275 - assume f: "f\<cdot>x = x"
238.276 - have "\<forall>n. iterate n\<cdot>f\<cdot>x = x"
238.277 - by (rule allI, rule nat.induct, simp, simp add: f)
238.278 - hence "MOST n. iterate n\<cdot>f\<cdot>x = x"
238.279 - by (rule ALL_MOST)
238.280 - thus "d\<cdot>x = x"
238.281 - by (rule MOST_d)
238.282 -qed
238.283 -
238.284 -lemma finite_deflation_d: "finite_deflation d"
238.285 -proof
238.286 - fix x :: 'a
238.287 - have "d \<in> range (\<lambda>n. iterate n\<cdot>f)"
238.288 - unfolding eventual_iterate_def
238.289 - using eventually_constant_iterate
238.290 - by (rule eventual_mem_range)
238.291 - then obtain n where n: "d = iterate n\<cdot>f" ..
238.292 - have "iterate n\<cdot>f\<cdot>(d\<cdot>x) = d\<cdot>x"
238.293 - using f_d by (rule iterate_fixed)
238.294 - thus "d\<cdot>(d\<cdot>x) = d\<cdot>x"
238.295 - by (simp add: n)
238.296 -next
238.297 - fix x :: 'a
238.298 - show "d\<cdot>x \<sqsubseteq> x"
238.299 - by (rule MOST_d, simp add: iterate_below)
238.300 -next
238.301 - from finite_range
238.302 - have "finite {x. f\<cdot>x = x}"
238.303 - by (rule finite_range_imp_finite_fixes)
238.304 - thus "finite {x. d\<cdot>x = x}"
238.305 - by (simp add: d_fixed_iff)
238.306 -qed
238.307 -
238.308 -lemma deflation_d: "deflation d"
238.309 -using finite_deflation_d
238.310 -by (rule finite_deflation_imp_deflation)
238.311 -
238.312 -end
238.313 -
238.314 -lemma finite_deflation_eventual_iterate:
238.315 - "pre_deflation d \<Longrightarrow> finite_deflation (eventual_iterate d)"
238.316 -by (rule pre_deflation.finite_deflation_d)
238.317 -
238.318 -lemma pre_deflation_oo:
238.319 - assumes "finite_deflation d"
238.320 - assumes f: "\<And>x. f\<cdot>x \<sqsubseteq> x"
238.321 - shows "pre_deflation (d oo f)"
238.322 -proof
238.323 - interpret d: finite_deflation d by fact
238.324 - fix x
238.325 - show "\<And>x. (d oo f)\<cdot>x \<sqsubseteq> x"
238.326 - by (simp, rule below_trans [OF d.below f])
238.327 - show "finite (range (\<lambda>x. (d oo f)\<cdot>x))"
238.328 - by (rule finite_subset [OF _ d.finite_range], auto)
238.329 -qed
238.330 -
238.331 -lemma eventual_iterate_oo_fixed_iff:
238.332 - assumes "finite_deflation d"
238.333 - assumes f: "\<And>x. f\<cdot>x \<sqsubseteq> x"
238.334 - shows "eventual_iterate (d oo f)\<cdot>x = x \<longleftrightarrow> d\<cdot>x = x \<and> f\<cdot>x = x"
238.335 -proof -
238.336 - interpret d: finite_deflation d by fact
238.337 - let ?e = "d oo f"
238.338 - interpret e: pre_deflation "d oo f"
238.339 - using `finite_deflation d` f
238.340 - by (rule pre_deflation_oo)
238.341 - let ?g = "eventual (\<lambda>n. iterate n\<cdot>?e)"
238.342 - show ?thesis
238.343 - apply (subst e.d_fixed_iff)
238.344 - apply simp
238.345 - apply safe
238.346 - apply (erule subst)
238.347 - apply (rule d.idem)
238.348 - apply (rule below_antisym)
238.349 - apply (rule f)
238.350 - apply (erule subst, rule d.below)
238.351 - apply simp
238.352 - done
238.353 -qed
238.354 -
238.355 -lemma eventual_mono:
238.356 - assumes A: "eventually_constant A"
238.357 - assumes B: "eventually_constant B"
238.358 - assumes below: "\<And>n. A n \<sqsubseteq> B n"
238.359 - shows "eventual A \<sqsubseteq> eventual B"
238.360 -proof -
238.361 - from A have "MOST n. A n = eventual A"
238.362 - by (rule MOST_eq_eventual)
238.363 - then have "MOST n. eventual A \<sqsubseteq> B n"
238.364 - by (rule MOST_mono) (erule subst, rule below)
238.365 - with B show "eventual A \<sqsubseteq> eventual B"
238.366 - by (rule MOST_eventual)
238.367 -qed
238.368 -
238.369 -lemma eventual_iterate_mono:
238.370 - assumes f: "pre_deflation f" and g: "pre_deflation g" and "f \<sqsubseteq> g"
238.371 - shows "eventual_iterate f \<sqsubseteq> eventual_iterate g"
238.372 -unfolding eventual_iterate_def
238.373 -apply (rule eventual_mono)
238.374 -apply (rule pre_deflation.eventually_constant_iterate [OF f])
238.375 -apply (rule pre_deflation.eventually_constant_iterate [OF g])
238.376 -apply (rule monofun_cfun_arg [OF `f \<sqsubseteq> g`])
238.377 -done
238.378 -
238.379 -lemma cont2cont_eventual_iterate_oo:
238.380 - assumes d: "finite_deflation d"
238.381 - assumes cont: "cont f" and below: "\<And>x y. f x\<cdot>y \<sqsubseteq> y"
238.382 - shows "cont (\<lambda>x. eventual_iterate (d oo f x))"
238.383 - (is "cont ?e")
238.384 -proof (rule contI2)
238.385 - show "monofun ?e"
238.386 - apply (rule monofunI)
238.387 - apply (rule eventual_iterate_mono)
238.388 - apply (rule pre_deflation_oo [OF d below])
238.389 - apply (rule pre_deflation_oo [OF d below])
238.390 - apply (rule monofun_cfun_arg)
238.391 - apply (erule cont2monofunE [OF cont])
238.392 - done
238.393 -next
238.394 - fix Y :: "nat \<Rightarrow> 'b"
238.395 - assume Y: "chain Y"
238.396 - with cont have fY: "chain (\<lambda>i. f (Y i))"
238.397 - by (rule ch2ch_cont)
238.398 - assume eY: "chain (\<lambda>i. ?e (Y i))"
238.399 - have lub_below: "\<And>x. f (\<Squnion>i. Y i)\<cdot>x \<sqsubseteq> x"
238.400 - by (rule admD [OF _ Y], simp add: cont, rule below)
238.401 - have "deflation (?e (\<Squnion>i. Y i))"
238.402 - apply (rule pre_deflation.deflation_d)
238.403 - apply (rule pre_deflation_oo [OF d lub_below])
238.404 - done
238.405 - then show "?e (\<Squnion>i. Y i) \<sqsubseteq> (\<Squnion>i. ?e (Y i))"
238.406 - proof (rule deflation.belowI)
238.407 - fix x :: 'a
238.408 - assume "?e (\<Squnion>i. Y i)\<cdot>x = x"
238.409 - hence "d\<cdot>x = x" and "f (\<Squnion>i. Y i)\<cdot>x = x"
238.410 - by (simp_all add: eventual_iterate_oo_fixed_iff [OF d lub_below])
238.411 - hence "(\<Squnion>i. f (Y i)\<cdot>x) = x"
238.412 - apply (simp only: cont2contlubE [OF cont Y])
238.413 - apply (simp only: contlub_cfun_fun [OF fY])
238.414 - done
238.415 - have "compact (d\<cdot>x)"
238.416 - using d by (rule finite_deflation.compact)
238.417 - then have "compact x"
238.418 - using `d\<cdot>x = x` by simp
238.419 - then have "compact (\<Squnion>i. f (Y i)\<cdot>x)"
238.420 - using `(\<Squnion>i. f (Y i)\<cdot>x) = x` by simp
238.421 - then have "\<exists>n. max_in_chain n (\<lambda>i. f (Y i)\<cdot>x)"
238.422 - by - (rule compact_imp_max_in_chain, simp add: fY, assumption)
238.423 - then obtain n where n: "max_in_chain n (\<lambda>i. f (Y i)\<cdot>x)" ..
238.424 - then have "f (Y n)\<cdot>x = x"
238.425 - using `(\<Squnion>i. f (Y i)\<cdot>x) = x` fY by (simp add: maxinch_is_thelub)
238.426 - with `d\<cdot>x = x` have "?e (Y n)\<cdot>x = x"
238.427 - by (simp add: eventual_iterate_oo_fixed_iff [OF d below])
238.428 - moreover have "?e (Y n)\<cdot>x \<sqsubseteq> (\<Squnion>i. ?e (Y i)\<cdot>x)"
238.429 - by (rule is_ub_thelub, simp add: eY)
238.430 - ultimately have "x \<sqsubseteq> (\<Squnion>i. ?e (Y i))\<cdot>x"
238.431 - by (simp add: contlub_cfun_fun eY)
238.432 - also have "(\<Squnion>i. ?e (Y i))\<cdot>x \<sqsubseteq> x"
238.433 - apply (rule deflation.below)
238.434 - apply (rule admD [OF adm_deflation eY])
238.435 - apply (rule pre_deflation.deflation_d)
238.436 - apply (rule pre_deflation_oo [OF d below])
238.437 - done
238.438 - finally show "(\<Squnion>i. ?e (Y i))\<cdot>x = x" ..
238.439 - qed
238.440 -qed
238.441 -
238.442 -subsection {* Take function for finite deflations *}
238.443 -
238.444 -definition
238.445 - defl_take :: "nat \<Rightarrow> (udom \<rightarrow> udom) \<Rightarrow> (udom \<rightarrow> udom)"
238.446 -where
238.447 - "defl_take i d = eventual_iterate (udom_approx i oo d)"
238.448 -
238.449 -lemma finite_deflation_defl_take:
238.450 - "deflation d \<Longrightarrow> finite_deflation (defl_take i d)"
238.451 -unfolding defl_take_def
238.452 -apply (rule pre_deflation.finite_deflation_d)
238.453 -apply (rule pre_deflation_oo)
238.454 -apply (rule finite_deflation_udom_approx)
238.455 -apply (erule deflation.below)
238.456 -done
238.457 -
238.458 -lemma deflation_defl_take:
238.459 - "deflation d \<Longrightarrow> deflation (defl_take i d)"
238.460 -apply (rule finite_deflation_imp_deflation)
238.461 -apply (erule finite_deflation_defl_take)
238.462 -done
238.463 -
238.464 -lemma defl_take_fixed_iff:
238.465 - "deflation d \<Longrightarrow> defl_take i d\<cdot>x = x \<longleftrightarrow> udom_approx i\<cdot>x = x \<and> d\<cdot>x = x"
238.466 -unfolding defl_take_def
238.467 -apply (rule eventual_iterate_oo_fixed_iff)
238.468 -apply (rule finite_deflation_udom_approx)
238.469 -apply (erule deflation.below)
238.470 -done
238.471 -
238.472 -lemma defl_take_below:
238.473 - "\<lbrakk>a \<sqsubseteq> b; deflation a; deflation b\<rbrakk> \<Longrightarrow> defl_take i a \<sqsubseteq> defl_take i b"
238.474 -apply (rule deflation.belowI)
238.475 -apply (erule deflation_defl_take)
238.476 -apply (simp add: defl_take_fixed_iff)
238.477 -apply (erule (1) deflation.belowD)
238.478 -apply (erule conjunct2)
238.479 -done
238.480 -
238.481 -lemma cont2cont_defl_take:
238.482 - assumes cont: "cont f" and below: "\<And>x y. f x\<cdot>y \<sqsubseteq> y"
238.483 - shows "cont (\<lambda>x. defl_take i (f x))"
238.484 -unfolding defl_take_def
238.485 -using finite_deflation_udom_approx assms
238.486 -by (rule cont2cont_eventual_iterate_oo)
238.487 -
238.488 -definition
238.489 - fd_take :: "nat \<Rightarrow> fin_defl \<Rightarrow> fin_defl"
238.490 -where
238.491 - "fd_take i d = Abs_fin_defl (defl_take i (Rep_fin_defl d))"
238.492 -
238.493 -lemma Rep_fin_defl_fd_take:
238.494 - "Rep_fin_defl (fd_take i d) = defl_take i (Rep_fin_defl d)"
238.495 -unfolding fd_take_def
238.496 -apply (rule Abs_fin_defl_inverse [unfolded mem_Collect_eq])
238.497 -apply (rule finite_deflation_defl_take)
238.498 -apply (rule deflation_Rep_fin_defl)
238.499 -done
238.500 -
238.501 -lemma fd_take_fixed_iff:
238.502 - "Rep_fin_defl (fd_take i d)\<cdot>x = x \<longleftrightarrow>
238.503 - udom_approx i\<cdot>x = x \<and> Rep_fin_defl d\<cdot>x = x"
238.504 -unfolding Rep_fin_defl_fd_take
238.505 -apply (rule defl_take_fixed_iff)
238.506 -apply (rule deflation_Rep_fin_defl)
238.507 -done
238.508 -
238.509 -lemma fd_take_below: "fd_take n d \<sqsubseteq> d"
238.510 -apply (rule fin_defl_belowI)
238.511 -apply (simp add: fd_take_fixed_iff)
238.512 -done
238.513 -
238.514 -lemma fd_take_idem: "fd_take n (fd_take n d) = fd_take n d"
238.515 -apply (rule fin_defl_eqI)
238.516 -apply (simp add: fd_take_fixed_iff)
238.517 -done
238.518 -
238.519 -lemma fd_take_mono: "a \<sqsubseteq> b \<Longrightarrow> fd_take n a \<sqsubseteq> fd_take n b"
238.520 -apply (rule fin_defl_belowI)
238.521 -apply (simp add: fd_take_fixed_iff)
238.522 -apply (simp add: fin_defl_belowD)
238.523 -done
238.524 -
238.525 -lemma approx_fixed_le_lemma: "\<lbrakk>i \<le> j; udom_approx i\<cdot>x = x\<rbrakk> \<Longrightarrow> udom_approx j\<cdot>x = x"
238.526 -apply (rule deflation.belowD)
238.527 -apply (rule finite_deflation_imp_deflation)
238.528 -apply (rule finite_deflation_udom_approx)
238.529 -apply (erule chain_mono [OF chain_udom_approx])
238.530 -apply assumption
238.531 -done
238.532 -
238.533 -lemma fd_take_chain: "m \<le> n \<Longrightarrow> fd_take m a \<sqsubseteq> fd_take n a"
238.534 -apply (rule fin_defl_belowI)
238.535 -apply (simp add: fd_take_fixed_iff)
238.536 -apply (simp add: approx_fixed_le_lemma)
238.537 -done
238.538 -
238.539 -lemma finite_range_fd_take: "finite (range (fd_take n))"
238.540 -apply (rule finite_imageD [where f="\<lambda>a. {x. Rep_fin_defl a\<cdot>x = x}"])
238.541 -apply (rule finite_subset [where B="Pow {x. udom_approx n\<cdot>x = x}"])
238.542 -apply (clarify, simp add: fd_take_fixed_iff)
238.543 -apply (simp add: finite_deflation.finite_fixes [OF finite_deflation_udom_approx])
238.544 -apply (rule inj_onI, clarify)
238.545 -apply (simp add: set_eq_iff fin_defl_eqI)
238.546 -done
238.547 -
238.548 -lemma fd_take_covers: "\<exists>n. fd_take n a = a"
238.549 -apply (rule_tac x=
238.550 - "Max ((\<lambda>x. LEAST n. udom_approx n\<cdot>x = x) ` {x. Rep_fin_defl a\<cdot>x = x})" in exI)
238.551 -apply (rule below_antisym)
238.552 -apply (rule fd_take_below)
238.553 -apply (rule fin_defl_belowI)
238.554 -apply (simp add: fd_take_fixed_iff)
238.555 -apply (rule approx_fixed_le_lemma)
238.556 -apply (rule Max_ge)
238.557 -apply (rule finite_imageI)
238.558 -apply (rule Rep_fin_defl.finite_fixes)
238.559 -apply (rule imageI)
238.560 -apply (erule CollectI)
238.561 -apply (rule LeastI_ex)
238.562 -apply (rule approx_chain.compact_eq_approx [OF udom_approx])
238.563 -apply (erule subst)
238.564 -apply (rule Rep_fin_defl.compact)
238.565 -done
238.566 -
238.567 -subsection {* Chain of approx functions on algebraic deflations *}
238.568 -
238.569 -definition
238.570 - defl_approx :: "nat \<Rightarrow> defl \<rightarrow> defl"
238.571 -where
238.572 - "defl_approx = (\<lambda>i. defl.basis_fun (\<lambda>d. defl_principal (fd_take i d)))"
238.573 -
238.574 -lemma defl_approx_principal:
238.575 - "defl_approx i\<cdot>(defl_principal d) = defl_principal (fd_take i d)"
238.576 -unfolding defl_approx_def
238.577 -by (simp add: defl.basis_fun_principal fd_take_mono)
238.578 -
238.579 -lemma defl_approx: "approx_chain defl_approx"
238.580 -proof
238.581 - show chain: "chain defl_approx"
238.582 - unfolding defl_approx_def
238.583 - by (simp add: chainI defl.basis_fun_mono fd_take_mono fd_take_chain)
238.584 - show idem: "\<And>i x. defl_approx i\<cdot>(defl_approx i\<cdot>x) = defl_approx i\<cdot>x"
238.585 - apply (induct_tac x rule: defl.principal_induct, simp)
238.586 - apply (simp add: defl_approx_principal fd_take_idem)
238.587 - done
238.588 - show below: "\<And>i x. defl_approx i\<cdot>x \<sqsubseteq> x"
238.589 - apply (induct_tac x rule: defl.principal_induct, simp)
238.590 - apply (simp add: defl_approx_principal fd_take_below)
238.591 - done
238.592 - show lub: "(\<Squnion>i. defl_approx i) = ID"
238.593 - apply (rule cfun_eqI, rule below_antisym)
238.594 - apply (simp add: contlub_cfun_fun chain lub_below_iff chain below)
238.595 - apply (induct_tac x rule: defl.principal_induct, simp)
238.596 - apply (simp add: contlub_cfun_fun chain)
238.597 - apply (simp add: compact_below_lub_iff defl.compact_principal chain)
238.598 - apply (simp add: defl_approx_principal)
238.599 - apply (subgoal_tac "\<exists>i. fd_take i a = a", metis below_refl)
238.600 - apply (rule fd_take_covers)
238.601 - done
238.602 - show "\<And>i. finite {x. defl_approx i\<cdot>x = x}"
238.603 - apply (rule finite_range_imp_finite_fixes)
238.604 - apply (rule_tac B="defl_principal ` range (fd_take i)" in rev_finite_subset)
238.605 - apply (simp add: finite_range_fd_take)
238.606 - apply (clarsimp, rename_tac x)
238.607 - apply (induct_tac x rule: defl.principal_induct)
238.608 - apply (simp add: adm_mem_finite finite_range_fd_take)
238.609 - apply (simp add: defl_approx_principal)
238.610 - done
238.611 -qed
238.612 -
238.613 -subsection {* Algebraic deflations are a bifinite domain *}
238.614 -
238.615 -instantiation defl :: liftdomain
238.616 -begin
238.617 -
238.618 -definition
238.619 - "emb = udom_emb defl_approx"
238.620 -
238.621 -definition
238.622 - "prj = udom_prj defl_approx"
238.623 -
238.624 -definition
238.625 - "defl (t::defl itself) =
238.626 - (\<Squnion>i. defl_principal (Abs_fin_defl (emb oo defl_approx i oo prj)))"
238.627 -
238.628 -definition
238.629 - "(liftemb :: defl u \<rightarrow> udom) = udom_emb u_approx oo u_map\<cdot>emb"
238.630 -
238.631 -definition
238.632 - "(liftprj :: udom \<rightarrow> defl u) = u_map\<cdot>prj oo udom_prj u_approx"
238.633 -
238.634 -definition
238.635 - "liftdefl (t::defl itself) = u_defl\<cdot>DEFL(defl)"
238.636 -
238.637 -instance
238.638 -using liftemb_defl_def liftprj_defl_def liftdefl_defl_def
238.639 -proof (rule liftdomain_class_intro)
238.640 - show ep: "ep_pair emb (prj :: udom \<rightarrow> defl)"
238.641 - unfolding emb_defl_def prj_defl_def
238.642 - by (rule ep_pair_udom [OF defl_approx])
238.643 - show "cast\<cdot>DEFL(defl) = emb oo (prj :: udom \<rightarrow> defl)"
238.644 - unfolding defl_defl_def
238.645 - apply (subst contlub_cfun_arg)
238.646 - apply (rule chainI)
238.647 - apply (rule defl.principal_mono)
238.648 - apply (simp add: below_fin_defl_def)
238.649 - apply (simp add: Abs_fin_defl_inverse approx_chain.finite_deflation_approx [OF defl_approx]
238.650 - ep_pair.finite_deflation_e_d_p [OF ep])
238.651 - apply (intro monofun_cfun below_refl)
238.652 - apply (rule chainE)
238.653 - apply (rule approx_chain.chain_approx [OF defl_approx])
238.654 - apply (subst cast_defl_principal)
238.655 - apply (simp add: Abs_fin_defl_inverse approx_chain.finite_deflation_approx [OF defl_approx]
238.656 - ep_pair.finite_deflation_e_d_p [OF ep])
238.657 - apply (simp add: lub_distribs approx_chain.chain_approx [OF defl_approx]
238.658 - approx_chain.lub_approx [OF defl_approx])
238.659 - done
238.660 -qed
238.661 -
238.662 -end
238.663 -
238.664 -end
239.1 --- a/src/HOLCF/Library/HOLCF_Library.thy Sat Nov 27 14:34:54 2010 -0800
239.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
239.3 @@ -1,9 +0,0 @@
239.4 -theory HOLCF_Library
239.5 -imports
239.6 - Defl_Bifinite
239.7 - List_Cpo
239.8 - Stream
239.9 - Sum_Cpo
239.10 -begin
239.11 -
239.12 -end
240.1 --- a/src/HOLCF/Library/List_Cpo.thy Sat Nov 27 14:34:54 2010 -0800
240.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
240.3 @@ -1,268 +0,0 @@
240.4 -(* Title: HOLCF/Library/List_Cpo.thy
240.5 - Author: Brian Huffman
240.6 -*)
240.7 -
240.8 -header {* Lists as a complete partial order *}
240.9 -
240.10 -theory List_Cpo
240.11 -imports HOLCF
240.12 -begin
240.13 -
240.14 -subsection {* Lists are a partial order *}
240.15 -
240.16 -instantiation list :: (po) po
240.17 -begin
240.18 -
240.19 -definition
240.20 - "xs \<sqsubseteq> ys \<longleftrightarrow> list_all2 (op \<sqsubseteq>) xs ys"
240.21 -
240.22 -instance proof
240.23 - fix xs :: "'a list"
240.24 - from below_refl show "xs \<sqsubseteq> xs"
240.25 - unfolding below_list_def
240.26 - by (rule list_all2_refl)
240.27 -next
240.28 - fix xs ys zs :: "'a list"
240.29 - assume "xs \<sqsubseteq> ys" and "ys \<sqsubseteq> zs"
240.30 - with below_trans show "xs \<sqsubseteq> zs"
240.31 - unfolding below_list_def
240.32 - by (rule list_all2_trans)
240.33 -next
240.34 - fix xs ys zs :: "'a list"
240.35 - assume "xs \<sqsubseteq> ys" and "ys \<sqsubseteq> xs"
240.36 - with below_antisym show "xs = ys"
240.37 - unfolding below_list_def
240.38 - by (rule list_all2_antisym)
240.39 -qed
240.40 -
240.41 -end
240.42 -
240.43 -lemma below_list_simps [simp]:
240.44 - "[] \<sqsubseteq> []"
240.45 - "x # xs \<sqsubseteq> y # ys \<longleftrightarrow> x \<sqsubseteq> y \<and> xs \<sqsubseteq> ys"
240.46 - "\<not> [] \<sqsubseteq> y # ys"
240.47 - "\<not> x # xs \<sqsubseteq> []"
240.48 -by (simp_all add: below_list_def)
240.49 -
240.50 -lemma Nil_below_iff [simp]: "[] \<sqsubseteq> xs \<longleftrightarrow> xs = []"
240.51 -by (cases xs, simp_all)
240.52 -
240.53 -lemma below_Nil_iff [simp]: "xs \<sqsubseteq> [] \<longleftrightarrow> xs = []"
240.54 -by (cases xs, simp_all)
240.55 -
240.56 -lemma list_below_induct [consumes 1, case_names Nil Cons]:
240.57 - assumes "xs \<sqsubseteq> ys"
240.58 - assumes 1: "P [] []"
240.59 - assumes 2: "\<And>x y xs ys. \<lbrakk>x \<sqsubseteq> y; xs \<sqsubseteq> ys; P xs ys\<rbrakk> \<Longrightarrow> P (x # xs) (y # ys)"
240.60 - shows "P xs ys"
240.61 -using `xs \<sqsubseteq> ys`
240.62 -proof (induct xs arbitrary: ys)
240.63 - case Nil thus ?case by (simp add: 1)
240.64 -next
240.65 - case (Cons x xs) thus ?case by (cases ys, simp_all add: 2)
240.66 -qed
240.67 -
240.68 -lemma list_below_cases:
240.69 - assumes "xs \<sqsubseteq> ys"
240.70 - obtains "xs = []" and "ys = []" |
240.71 - x y xs' ys' where "xs = x # xs'" and "ys = y # ys'"
240.72 -using assms by (cases xs, simp, cases ys, auto)
240.73 -
240.74 -text "Thanks to Joachim Breitner"
240.75 -
240.76 -lemma list_Cons_below:
240.77 - assumes "a # as \<sqsubseteq> xs"
240.78 - obtains b and bs where "a \<sqsubseteq> b" and "as \<sqsubseteq> bs" and "xs = b # bs"
240.79 - using assms by (cases xs, auto)
240.80 -
240.81 -lemma list_below_Cons:
240.82 - assumes "xs \<sqsubseteq> b # bs"
240.83 - obtains a and as where "a \<sqsubseteq> b" and "as \<sqsubseteq> bs" and "xs = a # as"
240.84 - using assms by (cases xs, auto)
240.85 -
240.86 -lemma hd_mono: "xs \<sqsubseteq> ys \<Longrightarrow> hd xs \<sqsubseteq> hd ys"
240.87 -by (cases xs, simp, cases ys, simp, simp)
240.88 -
240.89 -lemma tl_mono: "xs \<sqsubseteq> ys \<Longrightarrow> tl xs \<sqsubseteq> tl ys"
240.90 -by (cases xs, simp, cases ys, simp, simp)
240.91 -
240.92 -lemma ch2ch_hd [simp]: "chain (\<lambda>i. S i) \<Longrightarrow> chain (\<lambda>i. hd (S i))"
240.93 -by (rule chainI, rule hd_mono, erule chainE)
240.94 -
240.95 -lemma ch2ch_tl [simp]: "chain (\<lambda>i. S i) \<Longrightarrow> chain (\<lambda>i. tl (S i))"
240.96 -by (rule chainI, rule tl_mono, erule chainE)
240.97 -
240.98 -lemma below_same_length: "xs \<sqsubseteq> ys \<Longrightarrow> length xs = length ys"
240.99 -unfolding below_list_def by (rule list_all2_lengthD)
240.100 -
240.101 -lemma list_chain_induct [consumes 1, case_names Nil Cons]:
240.102 - assumes "chain S"
240.103 - assumes 1: "P (\<lambda>i. [])"
240.104 - assumes 2: "\<And>A B. chain A \<Longrightarrow> chain B \<Longrightarrow> P B \<Longrightarrow> P (\<lambda>i. A i # B i)"
240.105 - shows "P S"
240.106 -using `chain S`
240.107 -proof (induct "S 0" arbitrary: S)
240.108 - case Nil
240.109 - have "\<forall>i. S 0 \<sqsubseteq> S i" by (simp add: chain_mono [OF `chain S`])
240.110 - with Nil have "\<forall>i. S i = []" by simp
240.111 - thus ?case by (simp add: 1)
240.112 -next
240.113 - case (Cons x xs)
240.114 - have "\<forall>i. S 0 \<sqsubseteq> S i" by (simp add: chain_mono [OF `chain S`])
240.115 - hence *: "\<forall>i. S i \<noteq> []" by (rule all_forward, insert Cons) auto
240.116 - have "chain (\<lambda>i. hd (S i))" and "chain (\<lambda>i. tl (S i))"
240.117 - using `chain S` by simp_all
240.118 - moreover have "P (\<lambda>i. tl (S i))"
240.119 - using `chain S` and `x # xs = S 0` [symmetric]
240.120 - by (simp add: Cons(1))
240.121 - ultimately have "P (\<lambda>i. hd (S i) # tl (S i))"
240.122 - by (rule 2)
240.123 - thus "P S" by (simp add: *)
240.124 -qed
240.125 -
240.126 -lemma list_chain_cases:
240.127 - assumes S: "chain S"
240.128 - obtains "S = (\<lambda>i. [])" |
240.129 - A B where "chain A" and "chain B" and "S = (\<lambda>i. A i # B i)"
240.130 -using S by (induct rule: list_chain_induct) simp_all
240.131 -
240.132 -subsection {* Lists are a complete partial order *}
240.133 -
240.134 -lemma is_lub_Cons:
240.135 - assumes A: "range A <<| x"
240.136 - assumes B: "range B <<| xs"
240.137 - shows "range (\<lambda>i. A i # B i) <<| x # xs"
240.138 -using assms
240.139 -unfolding is_lub_def is_ub_def
240.140 -by (clarsimp, case_tac u, simp_all)
240.141 -
240.142 -instance list :: (cpo) cpo
240.143 -proof
240.144 - fix S :: "nat \<Rightarrow> 'a list"
240.145 - assume "chain S" thus "\<exists>x. range S <<| x"
240.146 - proof (induct rule: list_chain_induct)
240.147 - case Nil thus ?case by (auto intro: is_lub_const)
240.148 - next
240.149 - case (Cons A B) thus ?case by (auto intro: is_lub_Cons cpo_lubI)
240.150 - qed
240.151 -qed
240.152 -
240.153 -subsection {* Continuity of list operations *}
240.154 -
240.155 -lemma cont2cont_Cons [simp, cont2cont]:
240.156 - assumes f: "cont (\<lambda>x. f x)"
240.157 - assumes g: "cont (\<lambda>x. g x)"
240.158 - shows "cont (\<lambda>x. f x # g x)"
240.159 -apply (rule contI)
240.160 -apply (rule is_lub_Cons)
240.161 -apply (erule contE [OF f])
240.162 -apply (erule contE [OF g])
240.163 -done
240.164 -
240.165 -lemma lub_Cons:
240.166 - fixes A :: "nat \<Rightarrow> 'a::cpo"
240.167 - assumes A: "chain A" and B: "chain B"
240.168 - shows "(\<Squnion>i. A i # B i) = (\<Squnion>i. A i) # (\<Squnion>i. B i)"
240.169 -by (intro lub_eqI is_lub_Cons cpo_lubI A B)
240.170 -
240.171 -lemma cont2cont_list_case:
240.172 - assumes f: "cont (\<lambda>x. f x)"
240.173 - assumes g: "cont (\<lambda>x. g x)"
240.174 - assumes h1: "\<And>y ys. cont (\<lambda>x. h x y ys)"
240.175 - assumes h2: "\<And>x ys. cont (\<lambda>y. h x y ys)"
240.176 - assumes h3: "\<And>x y. cont (\<lambda>ys. h x y ys)"
240.177 - shows "cont (\<lambda>x. case f x of [] \<Rightarrow> g x | y # ys \<Rightarrow> h x y ys)"
240.178 -apply (rule cont_apply [OF f])
240.179 -apply (rule contI)
240.180 -apply (erule list_chain_cases)
240.181 -apply (simp add: is_lub_const)
240.182 -apply (simp add: lub_Cons)
240.183 -apply (simp add: cont2contlubE [OF h2])
240.184 -apply (simp add: cont2contlubE [OF h3])
240.185 -apply (simp add: diag_lub ch2ch_cont [OF h2] ch2ch_cont [OF h3])
240.186 -apply (rule cpo_lubI, rule chainI, rule below_trans)
240.187 -apply (erule cont2monofunE [OF h2 chainE])
240.188 -apply (erule cont2monofunE [OF h3 chainE])
240.189 -apply (case_tac y, simp_all add: g h1)
240.190 -done
240.191 -
240.192 -lemma cont2cont_list_case' [simp, cont2cont]:
240.193 - assumes f: "cont (\<lambda>x. f x)"
240.194 - assumes g: "cont (\<lambda>x. g x)"
240.195 - assumes h: "cont (\<lambda>p. h (fst p) (fst (snd p)) (snd (snd p)))"
240.196 - shows "cont (\<lambda>x. case f x of [] \<Rightarrow> g x | y # ys \<Rightarrow> h x y ys)"
240.197 -using assms by (simp add: cont2cont_list_case prod_cont_iff)
240.198 -
240.199 -text {* The simple version (due to Joachim Breitner) is needed if the
240.200 - element type of the list is not a cpo. *}
240.201 -
240.202 -lemma cont2cont_list_case_simple [simp, cont2cont]:
240.203 - assumes "cont (\<lambda>x. f1 x)"
240.204 - assumes "\<And>y ys. cont (\<lambda>x. f2 x y ys)"
240.205 - shows "cont (\<lambda>x. case l of [] \<Rightarrow> f1 x | y # ys \<Rightarrow> f2 x y ys)"
240.206 -using assms by (cases l) auto
240.207 -
240.208 -text {* Lemma for proving continuity of recursive list functions: *}
240.209 -
240.210 -lemma list_contI:
240.211 - fixes f :: "'a::cpo list \<Rightarrow> 'b::cpo"
240.212 - assumes f: "\<And>x xs. f (x # xs) = g x xs (f xs)"
240.213 - assumes g1: "\<And>xs y. cont (\<lambda>x. g x xs y)"
240.214 - assumes g2: "\<And>x y. cont (\<lambda>xs. g x xs y)"
240.215 - assumes g3: "\<And>x xs. cont (\<lambda>y. g x xs y)"
240.216 - shows "cont f"
240.217 -proof (rule contI2)
240.218 - obtain h where h: "\<And>x xs y. g x xs y = h\<cdot>x\<cdot>xs\<cdot>y"
240.219 - proof
240.220 - fix x xs y show "g x xs y = (\<Lambda> x xs y. g x xs y)\<cdot>x\<cdot>xs\<cdot>y"
240.221 - by (simp add: cont2cont_LAM g1 g2 g3)
240.222 - qed
240.223 - show mono: "monofun f"
240.224 - apply (rule monofunI)
240.225 - apply (erule list_below_induct)
240.226 - apply simp
240.227 - apply (simp add: f h monofun_cfun)
240.228 - done
240.229 - fix Y :: "nat \<Rightarrow> 'a list"
240.230 - assume "chain Y" thus "f (\<Squnion>i. Y i) \<sqsubseteq> (\<Squnion>i. f (Y i))"
240.231 - apply (induct rule: list_chain_induct)
240.232 - apply simp
240.233 - apply (simp add: lub_Cons f h)
240.234 - apply (simp add: contlub_cfun [symmetric] ch2ch_monofun [OF mono])
240.235 - apply (simp add: monofun_cfun)
240.236 - done
240.237 -qed
240.238 -
240.239 -text {* There are probably lots of other list operations that also
240.240 -deserve to have continuity lemmas. I'll add more as they are
240.241 -needed. *}
240.242 -
240.243 -subsection {* Using lists with fixrec *}
240.244 -
240.245 -definition
240.246 - match_Nil :: "'a::cpo list \<rightarrow> 'b match \<rightarrow> 'b match"
240.247 -where
240.248 - "match_Nil = (\<Lambda> xs k. case xs of [] \<Rightarrow> k | y # ys \<Rightarrow> Fixrec.fail)"
240.249 -
240.250 -definition
240.251 - match_Cons :: "'a::cpo list \<rightarrow> ('a \<rightarrow> 'a list \<rightarrow> 'b match) \<rightarrow> 'b match"
240.252 -where
240.253 - "match_Cons = (\<Lambda> xs k. case xs of [] \<Rightarrow> Fixrec.fail | y # ys \<Rightarrow> k\<cdot>y\<cdot>ys)"
240.254 -
240.255 -lemma match_Nil_simps [simp]:
240.256 - "match_Nil\<cdot>[]\<cdot>k = k"
240.257 - "match_Nil\<cdot>(x # xs)\<cdot>k = Fixrec.fail"
240.258 -unfolding match_Nil_def by simp_all
240.259 -
240.260 -lemma match_Cons_simps [simp]:
240.261 - "match_Cons\<cdot>[]\<cdot>k = Fixrec.fail"
240.262 - "match_Cons\<cdot>(x # xs)\<cdot>k = k\<cdot>x\<cdot>xs"
240.263 -unfolding match_Cons_def by simp_all
240.264 -
240.265 -setup {*
240.266 - Fixrec.add_matchers
240.267 - [ (@{const_name Nil}, @{const_name match_Nil}),
240.268 - (@{const_name Cons}, @{const_name match_Cons}) ]
240.269 -*}
240.270 -
240.271 -end
241.1 --- a/src/HOLCF/Library/ROOT.ML Sat Nov 27 14:34:54 2010 -0800
241.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
241.3 @@ -1,1 +0,0 @@
241.4 -use_thys ["HOLCF_Library"];
242.1 --- a/src/HOLCF/Library/Stream.thy Sat Nov 27 14:34:54 2010 -0800
242.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
242.3 @@ -1,967 +0,0 @@
242.4 -(* Title: HOLCF/ex/Stream.thy
242.5 - Author: Franz Regensburger, David von Oheimb, Borislav Gajanovic
242.6 -*)
242.7 -
242.8 -header {* General Stream domain *}
242.9 -
242.10 -theory Stream
242.11 -imports HOLCF Nat_Infinity
242.12 -begin
242.13 -
242.14 -default_sort pcpo
242.15 -
242.16 -domain (unsafe) 'a stream = scons (ft::'a) (lazy rt::"'a stream") (infixr "&&" 65)
242.17 -
242.18 -definition
242.19 - smap :: "('a \<rightarrow> 'b) \<rightarrow> 'a stream \<rightarrow> 'b stream" where
242.20 - "smap = fix\<cdot>(\<Lambda> h f s. case s of x && xs \<Rightarrow> f\<cdot>x && h\<cdot>f\<cdot>xs)"
242.21 -
242.22 -definition
242.23 - sfilter :: "('a \<rightarrow> tr) \<rightarrow> 'a stream \<rightarrow> 'a stream" where
242.24 - "sfilter = fix\<cdot>(\<Lambda> h p s. case s of x && xs \<Rightarrow>
242.25 - If p\<cdot>x then x && h\<cdot>p\<cdot>xs else h\<cdot>p\<cdot>xs)"
242.26 -
242.27 -definition
242.28 - slen :: "'a stream \<Rightarrow> inat" ("#_" [1000] 1000) where
242.29 - "#s = (if stream_finite s then Fin (LEAST n. stream_take n\<cdot>s = s) else \<infinity>)"
242.30 -
242.31 -
242.32 -(* concatenation *)
242.33 -
242.34 -definition
242.35 - i_rt :: "nat => 'a stream => 'a stream" where (* chops the first i elements *)
242.36 - "i_rt = (%i s. iterate i$rt$s)"
242.37 -
242.38 -definition
242.39 - i_th :: "nat => 'a stream => 'a" where (* the i-th element *)
242.40 - "i_th = (%i s. ft$(i_rt i s))"
242.41 -
242.42 -definition
242.43 - sconc :: "'a stream => 'a stream => 'a stream" (infixr "ooo" 65) where
242.44 - "s1 ooo s2 = (case #s1 of
242.45 - Fin n \<Rightarrow> (SOME s. (stream_take n$s=s1) & (i_rt n s = s2))
242.46 - | \<infinity> \<Rightarrow> s1)"
242.47 -
242.48 -primrec constr_sconc' :: "nat => 'a stream => 'a stream => 'a stream"
242.49 -where
242.50 - constr_sconc'_0: "constr_sconc' 0 s1 s2 = s2"
242.51 -| constr_sconc'_Suc: "constr_sconc' (Suc n) s1 s2 = ft$s1 &&
242.52 - constr_sconc' n (rt$s1) s2"
242.53 -
242.54 -definition
242.55 - constr_sconc :: "'a stream => 'a stream => 'a stream" where (* constructive *)
242.56 - "constr_sconc s1 s2 = (case #s1 of
242.57 - Fin n \<Rightarrow> constr_sconc' n s1 s2
242.58 - | \<infinity> \<Rightarrow> s1)"
242.59 -
242.60 -
242.61 -(* ----------------------------------------------------------------------- *)
242.62 -(* theorems about scons *)
242.63 -(* ----------------------------------------------------------------------- *)
242.64 -
242.65 -
242.66 -section "scons"
242.67 -
242.68 -lemma scons_eq_UU: "(a && s = UU) = (a = UU)"
242.69 -by simp
242.70 -
242.71 -lemma scons_not_empty: "[| a && x = UU; a ~= UU |] ==> R"
242.72 -by simp
242.73 -
242.74 -lemma stream_exhaust_eq: "(x ~= UU) = (EX a y. a ~= UU & x = a && y)"
242.75 -by (cases x, auto)
242.76 -
242.77 -lemma stream_neq_UU: "x~=UU ==> EX a a_s. x=a&&a_s & a~=UU"
242.78 -by (simp add: stream_exhaust_eq,auto)
242.79 -
242.80 -lemma stream_prefix:
242.81 - "[| a && s << t; a ~= UU |] ==> EX b tt. t = b && tt & b ~= UU & s << tt"
242.82 -by (cases t, auto)
242.83 -
242.84 -lemma stream_prefix':
242.85 - "b ~= UU ==> x << b && z =
242.86 - (x = UU | (EX a y. x = a && y & a ~= UU & a << b & y << z))"
242.87 -by (cases x, auto)
242.88 -
242.89 -
242.90 -(*
242.91 -lemma stream_prefix1: "[| x<<y; xs<<ys |] ==> x&&xs << y&&ys"
242.92 -by (insert stream_prefix' [of y "x&&xs" ys],force)
242.93 -*)
242.94 -
242.95 -lemma stream_flat_prefix:
242.96 - "[| x && xs << y && ys; (x::'a::flat) ~= UU|] ==> x = y & xs << ys"
242.97 -apply (case_tac "y=UU",auto)
242.98 -by (drule ax_flat,simp)
242.99 -
242.100 -
242.101 -
242.102 -
242.103 -(* ----------------------------------------------------------------------- *)
242.104 -(* theorems about stream_case *)
242.105 -(* ----------------------------------------------------------------------- *)
242.106 -
242.107 -section "stream_case"
242.108 -
242.109 -
242.110 -lemma stream_case_strictf: "stream_case$UU$s=UU"
242.111 -by (cases s, auto)
242.112 -
242.113 -
242.114 -
242.115 -(* ----------------------------------------------------------------------- *)
242.116 -(* theorems about ft and rt *)
242.117 -(* ----------------------------------------------------------------------- *)
242.118 -
242.119 -
242.120 -section "ft & rt"
242.121 -
242.122 -
242.123 -lemma ft_defin: "s~=UU ==> ft$s~=UU"
242.124 -by simp
242.125 -
242.126 -lemma rt_strict_rev: "rt$s~=UU ==> s~=UU"
242.127 -by auto
242.128 -
242.129 -lemma surjectiv_scons: "(ft$s)&&(rt$s)=s"
242.130 -by (cases s, auto)
242.131 -
242.132 -lemma monofun_rt_mult: "x << s ==> iterate i$rt$x << iterate i$rt$s"
242.133 -by (rule monofun_cfun_arg)
242.134 -
242.135 -
242.136 -
242.137 -(* ----------------------------------------------------------------------- *)
242.138 -(* theorems about stream_take *)
242.139 -(* ----------------------------------------------------------------------- *)
242.140 -
242.141 -
242.142 -section "stream_take"
242.143 -
242.144 -
242.145 -lemma stream_reach2: "(LUB i. stream_take i$s) = s"
242.146 -by (rule stream.reach)
242.147 -
242.148 -lemma chain_stream_take: "chain (%i. stream_take i$s)"
242.149 -by simp
242.150 -
242.151 -lemma stream_take_prefix [simp]: "stream_take n$s << s"
242.152 -apply (insert stream_reach2 [of s])
242.153 -apply (erule subst) back
242.154 -apply (rule is_ub_thelub)
242.155 -by (simp only: chain_stream_take)
242.156 -
242.157 -lemma stream_take_more [rule_format]:
242.158 - "ALL x. stream_take n$x = x --> stream_take (Suc n)$x = x"
242.159 -apply (induct_tac n,auto)
242.160 -apply (case_tac "x=UU",auto)
242.161 -by (drule stream_exhaust_eq [THEN iffD1],auto)
242.162 -
242.163 -lemma stream_take_lemma3 [rule_format]:
242.164 - "ALL x xs. x~=UU --> stream_take n$(x && xs) = x && xs --> stream_take n$xs=xs"
242.165 -apply (induct_tac n,clarsimp)
242.166 -(*apply (drule sym, erule scons_not_empty, simp)*)
242.167 -apply (clarify, rule stream_take_more)
242.168 -apply (erule_tac x="x" in allE)
242.169 -by (erule_tac x="xs" in allE,simp)
242.170 -
242.171 -lemma stream_take_lemma4:
242.172 - "ALL x xs. stream_take n$xs=xs --> stream_take (Suc n)$(x && xs) = x && xs"
242.173 -by auto
242.174 -
242.175 -lemma stream_take_idempotent [rule_format, simp]:
242.176 - "ALL s. stream_take n$(stream_take n$s) = stream_take n$s"
242.177 -apply (induct_tac n, auto)
242.178 -apply (case_tac "s=UU", auto)
242.179 -by (drule stream_exhaust_eq [THEN iffD1], auto)
242.180 -
242.181 -lemma stream_take_take_Suc [rule_format, simp]:
242.182 - "ALL s. stream_take n$(stream_take (Suc n)$s) =
242.183 - stream_take n$s"
242.184 -apply (induct_tac n, auto)
242.185 -apply (case_tac "s=UU", auto)
242.186 -by (drule stream_exhaust_eq [THEN iffD1], auto)
242.187 -
242.188 -lemma mono_stream_take_pred:
242.189 - "stream_take (Suc n)$s1 << stream_take (Suc n)$s2 ==>
242.190 - stream_take n$s1 << stream_take n$s2"
242.191 -by (insert monofun_cfun_arg [of "stream_take (Suc n)$s1"
242.192 - "stream_take (Suc n)$s2" "stream_take n"], auto)
242.193 -(*
242.194 -lemma mono_stream_take_pred:
242.195 - "stream_take (Suc n)$s1 << stream_take (Suc n)$s2 ==>
242.196 - stream_take n$s1 << stream_take n$s2"
242.197 -by (drule mono_stream_take [of _ _ n],simp)
242.198 -*)
242.199 -
242.200 -lemma stream_take_lemma10 [rule_format]:
242.201 - "ALL k<=n. stream_take n$s1 << stream_take n$s2
242.202 - --> stream_take k$s1 << stream_take k$s2"
242.203 -apply (induct_tac n,simp,clarsimp)
242.204 -apply (case_tac "k=Suc n",blast)
242.205 -apply (erule_tac x="k" in allE)
242.206 -by (drule mono_stream_take_pred,simp)
242.207 -
242.208 -lemma stream_take_le_mono : "k<=n ==> stream_take k$s1 << stream_take n$s1"
242.209 -apply (insert chain_stream_take [of s1])
242.210 -by (drule chain_mono,auto)
242.211 -
242.212 -lemma mono_stream_take: "s1 << s2 ==> stream_take n$s1 << stream_take n$s2"
242.213 -by (simp add: monofun_cfun_arg)
242.214 -
242.215 -(*
242.216 -lemma stream_take_prefix [simp]: "stream_take n$s << s"
242.217 -apply (subgoal_tac "s=(LUB n. stream_take n$s)")
242.218 - apply (erule ssubst, rule is_ub_thelub)
242.219 - apply (simp only: chain_stream_take)
242.220 -by (simp only: stream_reach2)
242.221 -*)
242.222 -
242.223 -lemma stream_take_take_less:"stream_take k$(stream_take n$s) << stream_take k$s"
242.224 -by (rule monofun_cfun_arg,auto)
242.225 -
242.226 -
242.227 -(* ------------------------------------------------------------------------- *)
242.228 -(* special induction rules *)
242.229 -(* ------------------------------------------------------------------------- *)
242.230 -
242.231 -
242.232 -section "induction"
242.233 -
242.234 -lemma stream_finite_ind:
242.235 - "[| stream_finite x; P UU; !!a s. [| a ~= UU; P s |] ==> P (a && s) |] ==> P x"
242.236 -apply (simp add: stream.finite_def,auto)
242.237 -apply (erule subst)
242.238 -by (drule stream.finite_induct [of P _ x], auto)
242.239 -
242.240 -lemma stream_finite_ind2:
242.241 -"[| P UU; !! x. x ~= UU ==> P (x && UU); !! y z s. [| y ~= UU; z ~= UU; P s |] ==> P (y && z && s )|] ==>
242.242 - !s. P (stream_take n$s)"
242.243 -apply (rule nat_less_induct [of _ n],auto)
242.244 -apply (case_tac n, auto)
242.245 -apply (case_tac nat, auto)
242.246 -apply (case_tac "s=UU",clarsimp)
242.247 -apply (drule stream_exhaust_eq [THEN iffD1],clarsimp)
242.248 -apply (case_tac "s=UU",clarsimp)
242.249 -apply (drule stream_exhaust_eq [THEN iffD1],clarsimp)
242.250 -apply (case_tac "y=UU",clarsimp)
242.251 -by (drule stream_exhaust_eq [THEN iffD1],clarsimp)
242.252 -
242.253 -lemma stream_ind2:
242.254 -"[| adm P; P UU; !!a. a ~= UU ==> P (a && UU); !!a b s. [| a ~= UU; b ~= UU; P s |] ==> P (a && b && s) |] ==> P x"
242.255 -apply (insert stream.reach [of x],erule subst)
242.256 -apply (erule admD, rule chain_stream_take)
242.257 -apply (insert stream_finite_ind2 [of P])
242.258 -by simp
242.259 -
242.260 -
242.261 -
242.262 -(* ----------------------------------------------------------------------- *)
242.263 -(* simplify use of coinduction *)
242.264 -(* ----------------------------------------------------------------------- *)
242.265 -
242.266 -
242.267 -section "coinduction"
242.268 -
242.269 -lemma stream_coind_lemma2: "!s1 s2. R s1 s2 --> ft$s1 = ft$s2 & R (rt$s1) (rt$s2) ==> stream_bisim R"
242.270 - apply (simp add: stream.bisim_def,clarsimp)
242.271 - apply (drule spec, drule spec, drule (1) mp)
242.272 - apply (case_tac "x", simp)
242.273 - apply (case_tac "y", simp)
242.274 -by auto
242.275 -
242.276 -
242.277 -
242.278 -(* ----------------------------------------------------------------------- *)
242.279 -(* theorems about stream_finite *)
242.280 -(* ----------------------------------------------------------------------- *)
242.281 -
242.282 -
242.283 -section "stream_finite"
242.284 -
242.285 -lemma stream_finite_UU [simp]: "stream_finite UU"
242.286 -by (simp add: stream.finite_def)
242.287 -
242.288 -lemma stream_finite_UU_rev: "~ stream_finite s ==> s ~= UU"
242.289 -by (auto simp add: stream.finite_def)
242.290 -
242.291 -lemma stream_finite_lemma1: "stream_finite xs ==> stream_finite (x && xs)"
242.292 -apply (simp add: stream.finite_def,auto)
242.293 -apply (rule_tac x="Suc n" in exI)
242.294 -by (simp add: stream_take_lemma4)
242.295 -
242.296 -lemma stream_finite_lemma2: "[| x ~= UU; stream_finite (x && xs) |] ==> stream_finite xs"
242.297 -apply (simp add: stream.finite_def, auto)
242.298 -apply (rule_tac x="n" in exI)
242.299 -by (erule stream_take_lemma3,simp)
242.300 -
242.301 -lemma stream_finite_rt_eq: "stream_finite (rt$s) = stream_finite s"
242.302 -apply (cases s, auto)
242.303 -apply (rule stream_finite_lemma1, simp)
242.304 -by (rule stream_finite_lemma2,simp)
242.305 -
242.306 -lemma stream_finite_less: "stream_finite s ==> !t. t<<s --> stream_finite t"
242.307 -apply (erule stream_finite_ind [of s], auto)
242.308 -apply (case_tac "t=UU", auto)
242.309 -apply (drule stream_exhaust_eq [THEN iffD1],auto)
242.310 -apply (erule_tac x="y" in allE, simp)
242.311 -by (rule stream_finite_lemma1, simp)
242.312 -
242.313 -lemma stream_take_finite [simp]: "stream_finite (stream_take n$s)"
242.314 -apply (simp add: stream.finite_def)
242.315 -by (rule_tac x="n" in exI,simp)
242.316 -
242.317 -lemma adm_not_stream_finite: "adm (%x. ~ stream_finite x)"
242.318 -apply (rule adm_upward)
242.319 -apply (erule contrapos_nn)
242.320 -apply (erule (1) stream_finite_less [rule_format])
242.321 -done
242.322 -
242.323 -
242.324 -
242.325 -(* ----------------------------------------------------------------------- *)
242.326 -(* theorems about stream length *)
242.327 -(* ----------------------------------------------------------------------- *)
242.328 -
242.329 -
242.330 -section "slen"
242.331 -
242.332 -lemma slen_empty [simp]: "#\<bottom> = 0"
242.333 -by (simp add: slen_def stream.finite_def zero_inat_def Least_equality)
242.334 -
242.335 -lemma slen_scons [simp]: "x ~= \<bottom> ==> #(x&&xs) = iSuc (#xs)"
242.336 -apply (case_tac "stream_finite (x && xs)")
242.337 -apply (simp add: slen_def, auto)
242.338 -apply (simp add: stream.finite_def, auto simp add: iSuc_Fin)
242.339 -apply (rule Least_Suc2, auto)
242.340 -(*apply (drule sym)*)
242.341 -(*apply (drule sym scons_eq_UU [THEN iffD1],simp)*)
242.342 -apply (erule stream_finite_lemma2, simp)
242.343 -apply (simp add: slen_def, auto)
242.344 -by (drule stream_finite_lemma1,auto)
242.345 -
242.346 -lemma slen_less_1_eq: "(#x < Fin (Suc 0)) = (x = \<bottom>)"
242.347 -by (cases x, auto simp add: Fin_0 iSuc_Fin[THEN sym])
242.348 -
242.349 -lemma slen_empty_eq: "(#x = 0) = (x = \<bottom>)"
242.350 -by (cases x, auto)
242.351 -
242.352 -lemma slen_scons_eq: "(Fin (Suc n) < #x) = (? a y. x = a && y & a ~= \<bottom> & Fin n < #y)"
242.353 -apply (auto, case_tac "x=UU",auto)
242.354 -apply (drule stream_exhaust_eq [THEN iffD1], auto)
242.355 -apply (case_tac "#y") apply simp_all
242.356 -apply (case_tac "#y") apply simp_all
242.357 -done
242.358 -
242.359 -lemma slen_iSuc: "#x = iSuc n --> (? a y. x = a&&y & a ~= \<bottom> & #y = n)"
242.360 -by (cases x, auto)
242.361 -
242.362 -lemma slen_stream_take_finite [simp]: "#(stream_take n$s) ~= \<infinity>"
242.363 -by (simp add: slen_def)
242.364 -
242.365 -lemma slen_scons_eq_rev: "(#x < Fin (Suc (Suc n))) = (!a y. x ~= a && y | a = \<bottom> | #y < Fin (Suc n))"
242.366 - apply (cases x, auto)
242.367 - apply (simp add: zero_inat_def)
242.368 - apply (case_tac "#stream") apply (simp_all add: iSuc_Fin)
242.369 - apply (case_tac "#stream") apply (simp_all add: iSuc_Fin)
242.370 -done
242.371 -
242.372 -lemma slen_take_lemma4 [rule_format]:
242.373 - "!s. stream_take n$s ~= s --> #(stream_take n$s) = Fin n"
242.374 -apply (induct n, auto simp add: Fin_0)
242.375 -apply (case_tac "s=UU", simp)
242.376 -by (drule stream_exhaust_eq [THEN iffD1], auto simp add: iSuc_Fin)
242.377 -
242.378 -(*
242.379 -lemma stream_take_idempotent [simp]:
242.380 - "stream_take n$(stream_take n$s) = stream_take n$s"
242.381 -apply (case_tac "stream_take n$s = s")
242.382 -apply (auto,insert slen_take_lemma4 [of n s]);
242.383 -by (auto,insert slen_take_lemma1 [of "stream_take n$s" n],simp)
242.384 -
242.385 -lemma stream_take_take_Suc [simp]: "stream_take n$(stream_take (Suc n)$s) =
242.386 - stream_take n$s"
242.387 -apply (simp add: po_eq_conv,auto)
242.388 - apply (simp add: stream_take_take_less)
242.389 -apply (subgoal_tac "stream_take n$s = stream_take n$(stream_take n$s)")
242.390 - apply (erule ssubst)
242.391 - apply (rule_tac monofun_cfun_arg)
242.392 - apply (insert chain_stream_take [of s])
242.393 -by (simp add: chain_def,simp)
242.394 -*)
242.395 -
242.396 -lemma slen_take_eq: "ALL x. (Fin n < #x) = (stream_take n\<cdot>x ~= x)"
242.397 -apply (induct_tac n, auto)
242.398 -apply (simp add: Fin_0, clarsimp)
242.399 -apply (drule not_sym)
242.400 -apply (drule slen_empty_eq [THEN iffD1], simp)
242.401 -apply (case_tac "x=UU", simp)
242.402 -apply (drule stream_exhaust_eq [THEN iffD1], clarsimp)
242.403 -apply (erule_tac x="y" in allE, auto)
242.404 -apply (simp_all add: not_less iSuc_Fin)
242.405 -apply (case_tac "#y") apply simp_all
242.406 -apply (case_tac "x=UU", simp)
242.407 -apply (drule stream_exhaust_eq [THEN iffD1], clarsimp)
242.408 -apply (erule_tac x="y" in allE, simp)
242.409 -apply (case_tac "#y") by simp_all
242.410 -
242.411 -lemma slen_take_eq_rev: "(#x <= Fin n) = (stream_take n\<cdot>x = x)"
242.412 -by (simp add: linorder_not_less [symmetric] slen_take_eq)
242.413 -
242.414 -lemma slen_take_lemma1: "#x = Fin n ==> stream_take n\<cdot>x = x"
242.415 -by (rule slen_take_eq_rev [THEN iffD1], auto)
242.416 -
242.417 -lemma slen_rt_mono: "#s2 <= #s1 ==> #(rt$s2) <= #(rt$s1)"
242.418 -apply (cases s1)
242.419 - by (cases s2, simp+)+
242.420 -
242.421 -lemma slen_take_lemma5: "#(stream_take n$s) <= Fin n"
242.422 -apply (case_tac "stream_take n$s = s")
242.423 - apply (simp add: slen_take_eq_rev)
242.424 -by (simp add: slen_take_lemma4)
242.425 -
242.426 -lemma slen_take_lemma2: "!x. ~stream_finite x --> #(stream_take i\<cdot>x) = Fin i"
242.427 -apply (simp add: stream.finite_def, auto)
242.428 -by (simp add: slen_take_lemma4)
242.429 -
242.430 -lemma slen_infinite: "stream_finite x = (#x ~= Infty)"
242.431 -by (simp add: slen_def)
242.432 -
242.433 -lemma slen_mono_lemma: "stream_finite s ==> ALL t. s << t --> #s <= #t"
242.434 -apply (erule stream_finite_ind [of s], auto)
242.435 -apply (case_tac "t=UU", auto)
242.436 -apply (drule stream_exhaust_eq [THEN iffD1], auto)
242.437 -done
242.438 -
242.439 -lemma slen_mono: "s << t ==> #s <= #t"
242.440 -apply (case_tac "stream_finite t")
242.441 -apply (frule stream_finite_less)
242.442 -apply (erule_tac x="s" in allE, simp)
242.443 -apply (drule slen_mono_lemma, auto)
242.444 -by (simp add: slen_def)
242.445 -
242.446 -lemma iterate_lemma: "F$(iterate n$F$x) = iterate n$F$(F$x)"
242.447 -by (insert iterate_Suc2 [of n F x], auto)
242.448 -
242.449 -lemma slen_rt_mult [rule_format]: "!x. Fin (i + j) <= #x --> Fin j <= #(iterate i$rt$x)"
242.450 -apply (induct i, auto)
242.451 -apply (case_tac "x=UU", auto simp add: zero_inat_def)
242.452 -apply (drule stream_exhaust_eq [THEN iffD1], auto)
242.453 -apply (erule_tac x="y" in allE, auto)
242.454 -apply (simp add: not_le) apply (case_tac "#y") apply (simp_all add: iSuc_Fin)
242.455 -by (simp add: iterate_lemma)
242.456 -
242.457 -lemma slen_take_lemma3 [rule_format]:
242.458 - "!(x::'a::flat stream) y. Fin n <= #x --> x << y --> stream_take n\<cdot>x = stream_take n\<cdot>y"
242.459 -apply (induct_tac n, auto)
242.460 -apply (case_tac "x=UU", auto)
242.461 -apply (simp add: zero_inat_def)
242.462 -apply (simp add: Suc_ile_eq)
242.463 -apply (case_tac "y=UU", clarsimp)
242.464 -apply (drule stream_exhaust_eq [THEN iffD1], clarsimp)+
242.465 -apply (erule_tac x="ya" in allE, simp)
242.466 -by (drule ax_flat, simp)
242.467 -
242.468 -lemma slen_strict_mono_lemma:
242.469 - "stream_finite t ==> !s. #(s::'a::flat stream) = #t & s << t --> s = t"
242.470 -apply (erule stream_finite_ind, auto)
242.471 -apply (case_tac "sa=UU", auto)
242.472 -apply (drule stream_exhaust_eq [THEN iffD1], clarsimp)
242.473 -by (drule ax_flat, simp)
242.474 -
242.475 -lemma slen_strict_mono: "[|stream_finite t; s ~= t; s << (t::'a::flat stream) |] ==> #s < #t"
242.476 -by (auto simp add: slen_mono less_le dest: slen_strict_mono_lemma)
242.477 -
242.478 -lemma stream_take_Suc_neq: "stream_take (Suc n)$s ~=s ==>
242.479 - stream_take n$s ~= stream_take (Suc n)$s"
242.480 -apply auto
242.481 -apply (subgoal_tac "stream_take n$s ~=s")
242.482 - apply (insert slen_take_lemma4 [of n s],auto)
242.483 -apply (cases s, simp)
242.484 -by (simp add: slen_take_lemma4 iSuc_Fin)
242.485 -
242.486 -(* ----------------------------------------------------------------------- *)
242.487 -(* theorems about smap *)
242.488 -(* ----------------------------------------------------------------------- *)
242.489 -
242.490 -
242.491 -section "smap"
242.492 -
242.493 -lemma smap_unfold: "smap = (\<Lambda> f t. case t of x&&xs \<Rightarrow> f$x && smap$f$xs)"
242.494 -by (insert smap_def [where 'a='a and 'b='b, THEN eq_reflection, THEN fix_eq2], auto)
242.495 -
242.496 -lemma smap_empty [simp]: "smap\<cdot>f\<cdot>\<bottom> = \<bottom>"
242.497 -by (subst smap_unfold, simp)
242.498 -
242.499 -lemma smap_scons [simp]: "x~=\<bottom> ==> smap\<cdot>f\<cdot>(x&&xs) = (f\<cdot>x)&&(smap\<cdot>f\<cdot>xs)"
242.500 -by (subst smap_unfold, force)
242.501 -
242.502 -
242.503 -
242.504 -(* ----------------------------------------------------------------------- *)
242.505 -(* theorems about sfilter *)
242.506 -(* ----------------------------------------------------------------------- *)
242.507 -
242.508 -section "sfilter"
242.509 -
242.510 -lemma sfilter_unfold:
242.511 - "sfilter = (\<Lambda> p s. case s of x && xs \<Rightarrow>
242.512 - If p\<cdot>x then x && sfilter\<cdot>p\<cdot>xs else sfilter\<cdot>p\<cdot>xs)"
242.513 -by (insert sfilter_def [where 'a='a, THEN eq_reflection, THEN fix_eq2], auto)
242.514 -
242.515 -lemma strict_sfilter: "sfilter\<cdot>\<bottom> = \<bottom>"
242.516 -apply (rule cfun_eqI)
242.517 -apply (subst sfilter_unfold, auto)
242.518 -apply (case_tac "x=UU", auto)
242.519 -by (drule stream_exhaust_eq [THEN iffD1], auto)
242.520 -
242.521 -lemma sfilter_empty [simp]: "sfilter\<cdot>f\<cdot>\<bottom> = \<bottom>"
242.522 -by (subst sfilter_unfold, force)
242.523 -
242.524 -lemma sfilter_scons [simp]:
242.525 - "x ~= \<bottom> ==> sfilter\<cdot>f\<cdot>(x && xs) =
242.526 - If f\<cdot>x then x && sfilter\<cdot>f\<cdot>xs else sfilter\<cdot>f\<cdot>xs"
242.527 -by (subst sfilter_unfold, force)
242.528 -
242.529 -
242.530 -(* ----------------------------------------------------------------------- *)
242.531 - section "i_rt"
242.532 -(* ----------------------------------------------------------------------- *)
242.533 -
242.534 -lemma i_rt_UU [simp]: "i_rt n UU = UU"
242.535 - by (induct n) (simp_all add: i_rt_def)
242.536 -
242.537 -lemma i_rt_0 [simp]: "i_rt 0 s = s"
242.538 -by (simp add: i_rt_def)
242.539 -
242.540 -lemma i_rt_Suc [simp]: "a ~= UU ==> i_rt (Suc n) (a&&s) = i_rt n s"
242.541 -by (simp add: i_rt_def iterate_Suc2 del: iterate_Suc)
242.542 -
242.543 -lemma i_rt_Suc_forw: "i_rt (Suc n) s = i_rt n (rt$s)"
242.544 -by (simp only: i_rt_def iterate_Suc2)
242.545 -
242.546 -lemma i_rt_Suc_back:"i_rt (Suc n) s = rt$(i_rt n s)"
242.547 -by (simp only: i_rt_def,auto)
242.548 -
242.549 -lemma i_rt_mono: "x << s ==> i_rt n x << i_rt n s"
242.550 -by (simp add: i_rt_def monofun_rt_mult)
242.551 -
242.552 -lemma i_rt_ij_lemma: "Fin (i + j) <= #x ==> Fin j <= #(i_rt i x)"
242.553 -by (simp add: i_rt_def slen_rt_mult)
242.554 -
242.555 -lemma slen_i_rt_mono: "#s2 <= #s1 ==> #(i_rt n s2) <= #(i_rt n s1)"
242.556 -apply (induct_tac n,auto)
242.557 -apply (simp add: i_rt_Suc_back)
242.558 -by (drule slen_rt_mono,simp)
242.559 -
242.560 -lemma i_rt_take_lemma1 [rule_format]: "ALL s. i_rt n (stream_take n$s) = UU"
242.561 -apply (induct_tac n)
242.562 - apply (simp add: i_rt_Suc_back,auto)
242.563 -apply (case_tac "s=UU",auto)
242.564 -by (drule stream_exhaust_eq [THEN iffD1],auto)
242.565 -
242.566 -lemma i_rt_slen: "(i_rt n s = UU) = (stream_take n$s = s)"
242.567 -apply auto
242.568 - apply (insert i_rt_ij_lemma [of n "Suc 0" s])
242.569 - apply (subgoal_tac "#(i_rt n s)=0")
242.570 - apply (case_tac "stream_take n$s = s",simp+)
242.571 - apply (insert slen_take_eq [rule_format,of n s],simp)
242.572 - apply (cases "#s") apply (simp_all add: zero_inat_def)
242.573 - apply (simp add: slen_take_eq)
242.574 - apply (cases "#s")
242.575 - using i_rt_take_lemma1 [of n s]
242.576 - apply (simp_all add: zero_inat_def)
242.577 - done
242.578 -
242.579 -lemma i_rt_lemma_slen: "#s=Fin n ==> i_rt n s = UU"
242.580 -by (simp add: i_rt_slen slen_take_lemma1)
242.581 -
242.582 -lemma stream_finite_i_rt [simp]: "stream_finite (i_rt n s) = stream_finite s"
242.583 -apply (induct_tac n, auto)
242.584 - apply (cases s, auto simp del: i_rt_Suc)
242.585 -by (simp add: i_rt_Suc_back stream_finite_rt_eq)+
242.586 -
242.587 -lemma take_i_rt_len_lemma: "ALL sl x j t. Fin sl = #x & n <= sl &
242.588 - #(stream_take n$x) = Fin t & #(i_rt n x)= Fin j
242.589 - --> Fin (j + t) = #x"
242.590 -apply (induct n, auto)
242.591 - apply (simp add: zero_inat_def)
242.592 -apply (case_tac "x=UU",auto)
242.593 - apply (simp add: zero_inat_def)
242.594 -apply (drule stream_exhaust_eq [THEN iffD1],clarsimp)
242.595 -apply (subgoal_tac "EX k. Fin k = #y",clarify)
242.596 - apply (erule_tac x="k" in allE)
242.597 - apply (erule_tac x="y" in allE,auto)
242.598 - apply (erule_tac x="THE p. Suc p = t" in allE,auto)
242.599 - apply (simp add: iSuc_def split: inat.splits)
242.600 - apply (simp add: iSuc_def split: inat.splits)
242.601 - apply (simp only: the_equality)
242.602 - apply (simp add: iSuc_def split: inat.splits)
242.603 - apply force
242.604 -apply (simp add: iSuc_def split: inat.splits)
242.605 -done
242.606 -
242.607 -lemma take_i_rt_len:
242.608 -"[| Fin sl = #x; n <= sl; #(stream_take n$x) = Fin t; #(i_rt n x) = Fin j |] ==>
242.609 - Fin (j + t) = #x"
242.610 -by (blast intro: take_i_rt_len_lemma [rule_format])
242.611 -
242.612 -
242.613 -(* ----------------------------------------------------------------------- *)
242.614 - section "i_th"
242.615 -(* ----------------------------------------------------------------------- *)
242.616 -
242.617 -lemma i_th_i_rt_step:
242.618 -"[| i_th n s1 << i_th n s2; i_rt (Suc n) s1 << i_rt (Suc n) s2 |] ==>
242.619 - i_rt n s1 << i_rt n s2"
242.620 -apply (simp add: i_th_def i_rt_Suc_back)
242.621 -apply (cases "i_rt n s1", simp)
242.622 -apply (cases "i_rt n s2", auto)
242.623 -done
242.624 -
242.625 -lemma i_th_stream_take_Suc [rule_format]:
242.626 - "ALL s. i_th n (stream_take (Suc n)$s) = i_th n s"
242.627 -apply (induct_tac n,auto)
242.628 - apply (simp add: i_th_def)
242.629 - apply (case_tac "s=UU",auto)
242.630 - apply (drule stream_exhaust_eq [THEN iffD1],auto)
242.631 -apply (case_tac "s=UU",simp add: i_th_def)
242.632 -apply (drule stream_exhaust_eq [THEN iffD1],auto)
242.633 -by (simp add: i_th_def i_rt_Suc_forw)
242.634 -
242.635 -lemma i_th_last: "i_th n s && UU = i_rt n (stream_take (Suc n)$s)"
242.636 -apply (insert surjectiv_scons [of "i_rt n (stream_take (Suc n)$s)"])
242.637 -apply (rule i_th_stream_take_Suc [THEN subst])
242.638 -apply (simp add: i_th_def i_rt_Suc_back [symmetric])
242.639 -by (simp add: i_rt_take_lemma1)
242.640 -
242.641 -lemma i_th_last_eq:
242.642 -"i_th n s1 = i_th n s2 ==> i_rt n (stream_take (Suc n)$s1) = i_rt n (stream_take (Suc n)$s2)"
242.643 -apply (insert i_th_last [of n s1])
242.644 -apply (insert i_th_last [of n s2])
242.645 -by auto
242.646 -
242.647 -lemma i_th_prefix_lemma:
242.648 -"[| k <= n; stream_take (Suc n)$s1 << stream_take (Suc n)$s2 |] ==>
242.649 - i_th k s1 << i_th k s2"
242.650 -apply (insert i_th_stream_take_Suc [of k s1, THEN sym])
242.651 -apply (insert i_th_stream_take_Suc [of k s2, THEN sym],auto)
242.652 -apply (simp add: i_th_def)
242.653 -apply (rule monofun_cfun, auto)
242.654 -apply (rule i_rt_mono)
242.655 -by (blast intro: stream_take_lemma10)
242.656 -
242.657 -lemma take_i_rt_prefix_lemma1:
242.658 - "stream_take (Suc n)$s1 << stream_take (Suc n)$s2 ==>
242.659 - i_rt (Suc n) s1 << i_rt (Suc n) s2 ==>
242.660 - i_rt n s1 << i_rt n s2 & stream_take n$s1 << stream_take n$s2"
242.661 -apply auto
242.662 - apply (insert i_th_prefix_lemma [of n n s1 s2])
242.663 - apply (rule i_th_i_rt_step,auto)
242.664 -by (drule mono_stream_take_pred,simp)
242.665 -
242.666 -lemma take_i_rt_prefix_lemma:
242.667 -"[| stream_take n$s1 << stream_take n$s2; i_rt n s1 << i_rt n s2 |] ==> s1 << s2"
242.668 -apply (case_tac "n=0",simp)
242.669 -apply (auto)
242.670 -apply (subgoal_tac "stream_take 0$s1 << stream_take 0$s2 &
242.671 - i_rt 0 s1 << i_rt 0 s2")
242.672 - defer 1
242.673 - apply (rule zero_induct,blast)
242.674 - apply (blast dest: take_i_rt_prefix_lemma1)
242.675 -by simp
242.676 -
242.677 -lemma streams_prefix_lemma: "(s1 << s2) =
242.678 - (stream_take n$s1 << stream_take n$s2 & i_rt n s1 << i_rt n s2)"
242.679 -apply auto
242.680 - apply (simp add: monofun_cfun_arg)
242.681 - apply (simp add: i_rt_mono)
242.682 -by (erule take_i_rt_prefix_lemma,simp)
242.683 -
242.684 -lemma streams_prefix_lemma1:
242.685 - "[| stream_take n$s1 = stream_take n$s2; i_rt n s1 = i_rt n s2 |] ==> s1 = s2"
242.686 -apply (simp add: po_eq_conv,auto)
242.687 - apply (insert streams_prefix_lemma)
242.688 - by blast+
242.689 -
242.690 -
242.691 -(* ----------------------------------------------------------------------- *)
242.692 - section "sconc"
242.693 -(* ----------------------------------------------------------------------- *)
242.694 -
242.695 -lemma UU_sconc [simp]: " UU ooo s = s "
242.696 -by (simp add: sconc_def zero_inat_def)
242.697 -
242.698 -lemma scons_neq_UU: "a~=UU ==> a && s ~=UU"
242.699 -by auto
242.700 -
242.701 -lemma singleton_sconc [rule_format, simp]: "x~=UU --> (x && UU) ooo y = x && y"
242.702 -apply (simp add: sconc_def zero_inat_def iSuc_def split: inat.splits, auto)
242.703 -apply (rule someI2_ex,auto)
242.704 - apply (rule_tac x="x && y" in exI,auto)
242.705 -apply (simp add: i_rt_Suc_forw)
242.706 -apply (case_tac "xa=UU",simp)
242.707 -by (drule stream_exhaust_eq [THEN iffD1],auto)
242.708 -
242.709 -lemma ex_sconc [rule_format]:
242.710 - "ALL k y. #x = Fin k --> (EX w. stream_take k$w = x & i_rt k w = y)"
242.711 -apply (case_tac "#x")
242.712 - apply (rule stream_finite_ind [of x],auto)
242.713 - apply (simp add: stream.finite_def)
242.714 - apply (drule slen_take_lemma1,blast)
242.715 - apply (simp_all add: zero_inat_def iSuc_def split: inat.splits)
242.716 -apply (erule_tac x="y" in allE,auto)
242.717 -by (rule_tac x="a && w" in exI,auto)
242.718 -
242.719 -lemma rt_sconc1: "Fin n = #x ==> i_rt n (x ooo y) = y"
242.720 -apply (simp add: sconc_def split: inat.splits, arith?,auto)
242.721 -apply (rule someI2_ex,auto)
242.722 -by (drule ex_sconc,simp)
242.723 -
242.724 -lemma sconc_inj2: "\<lbrakk>Fin n = #x; x ooo y = x ooo z\<rbrakk> \<Longrightarrow> y = z"
242.725 -apply (frule_tac y=y in rt_sconc1)
242.726 -by (auto elim: rt_sconc1)
242.727 -
242.728 -lemma sconc_UU [simp]:"s ooo UU = s"
242.729 -apply (case_tac "#s")
242.730 - apply (simp add: sconc_def)
242.731 - apply (rule someI2_ex)
242.732 - apply (rule_tac x="s" in exI)
242.733 - apply auto
242.734 - apply (drule slen_take_lemma1,auto)
242.735 - apply (simp add: i_rt_lemma_slen)
242.736 - apply (drule slen_take_lemma1,auto)
242.737 - apply (simp add: i_rt_slen)
242.738 -by (simp add: sconc_def)
242.739 -
242.740 -lemma stream_take_sconc [simp]: "Fin n = #x ==> stream_take n$(x ooo y) = x"
242.741 -apply (simp add: sconc_def)
242.742 -apply (cases "#x")
242.743 -apply auto
242.744 -apply (rule someI2_ex, auto)
242.745 -by (drule ex_sconc,simp)
242.746 -
242.747 -lemma scons_sconc [rule_format,simp]: "a~=UU --> (a && x) ooo y = a && x ooo y"
242.748 -apply (cases "#x",auto)
242.749 - apply (simp add: sconc_def iSuc_Fin)
242.750 - apply (rule someI2_ex)
242.751 - apply (drule ex_sconc, simp)
242.752 - apply (rule someI2_ex, auto)
242.753 - apply (simp add: i_rt_Suc_forw)
242.754 - apply (rule_tac x="a && x" in exI, auto)
242.755 - apply (case_tac "xa=UU",auto)
242.756 - apply (drule stream_exhaust_eq [THEN iffD1],auto)
242.757 - apply (drule streams_prefix_lemma1,simp+)
242.758 -by (simp add: sconc_def)
242.759 -
242.760 -lemma ft_sconc: "x ~= UU ==> ft$(x ooo y) = ft$x"
242.761 -by (cases x, auto)
242.762 -
242.763 -lemma sconc_assoc: "(x ooo y) ooo z = x ooo y ooo z"
242.764 -apply (case_tac "#x")
242.765 - apply (rule stream_finite_ind [of x],auto simp del: scons_sconc)
242.766 - apply (simp add: stream.finite_def del: scons_sconc)
242.767 - apply (drule slen_take_lemma1,auto simp del: scons_sconc)
242.768 - apply (case_tac "a = UU", auto)
242.769 -by (simp add: sconc_def)
242.770 -
242.771 -
242.772 -(* ----------------------------------------------------------------------- *)
242.773 -
242.774 -lemma cont_sconc_lemma1: "stream_finite x \<Longrightarrow> cont (\<lambda>y. x ooo y)"
242.775 -by (erule stream_finite_ind, simp_all)
242.776 -
242.777 -lemma cont_sconc_lemma2: "\<not> stream_finite x \<Longrightarrow> cont (\<lambda>y. x ooo y)"
242.778 -by (simp add: sconc_def slen_def)
242.779 -
242.780 -lemma cont_sconc: "cont (\<lambda>y. x ooo y)"
242.781 -apply (cases "stream_finite x")
242.782 -apply (erule cont_sconc_lemma1)
242.783 -apply (erule cont_sconc_lemma2)
242.784 -done
242.785 -
242.786 -lemma sconc_mono: "y << y' ==> x ooo y << x ooo y'"
242.787 -by (rule cont_sconc [THEN cont2mono, THEN monofunE])
242.788 -
242.789 -lemma sconc_mono1 [simp]: "x << x ooo y"
242.790 -by (rule sconc_mono [of UU, simplified])
242.791 -
242.792 -(* ----------------------------------------------------------------------- *)
242.793 -
242.794 -lemma empty_sconc [simp]: "(x ooo y = UU) = (x = UU & y = UU)"
242.795 -apply (case_tac "#x",auto)
242.796 - apply (insert sconc_mono1 [of x y])
242.797 - by auto
242.798 -
242.799 -(* ----------------------------------------------------------------------- *)
242.800 -
242.801 -lemma rt_sconc [rule_format, simp]: "s~=UU --> rt$(s ooo x) = rt$s ooo x"
242.802 -by (cases s, auto)
242.803 -
242.804 -lemma i_th_sconc_lemma [rule_format]:
242.805 - "ALL x y. Fin n < #x --> i_th n (x ooo y) = i_th n x"
242.806 -apply (induct_tac n, auto)
242.807 -apply (simp add: Fin_0 i_th_def)
242.808 -apply (simp add: slen_empty_eq ft_sconc)
242.809 -apply (simp add: i_th_def)
242.810 -apply (case_tac "x=UU",auto)
242.811 -apply (drule stream_exhaust_eq [THEN iffD1], auto)
242.812 -apply (erule_tac x="ya" in allE)
242.813 -apply (case_tac "#ya") by simp_all
242.814 -
242.815 -
242.816 -
242.817 -(* ----------------------------------------------------------------------- *)
242.818 -
242.819 -lemma sconc_lemma [rule_format, simp]: "ALL s. stream_take n$s ooo i_rt n s = s"
242.820 -apply (induct_tac n,auto)
242.821 -apply (case_tac "s=UU",auto)
242.822 -by (drule stream_exhaust_eq [THEN iffD1],auto)
242.823 -
242.824 -(* ----------------------------------------------------------------------- *)
242.825 - subsection "pointwise equality"
242.826 -(* ----------------------------------------------------------------------- *)
242.827 -
242.828 -lemma ex_last_stream_take_scons: "stream_take (Suc n)$s =
242.829 - stream_take n$s ooo i_rt n (stream_take (Suc n)$s)"
242.830 -by (insert sconc_lemma [of n "stream_take (Suc n)$s"],simp)
242.831 -
242.832 -lemma i_th_stream_take_eq:
242.833 -"!!n. ALL n. i_th n s1 = i_th n s2 ==> stream_take n$s1 = stream_take n$s2"
242.834 -apply (induct_tac n,auto)
242.835 -apply (subgoal_tac "stream_take (Suc na)$s1 =
242.836 - stream_take na$s1 ooo i_rt na (stream_take (Suc na)$s1)")
242.837 - apply (subgoal_tac "i_rt na (stream_take (Suc na)$s1) =
242.838 - i_rt na (stream_take (Suc na)$s2)")
242.839 - apply (subgoal_tac "stream_take (Suc na)$s2 =
242.840 - stream_take na$s2 ooo i_rt na (stream_take (Suc na)$s2)")
242.841 - apply (insert ex_last_stream_take_scons,simp)
242.842 - apply blast
242.843 - apply (erule_tac x="na" in allE)
242.844 - apply (insert i_th_last_eq [of _ s1 s2])
242.845 -by blast+
242.846 -
242.847 -lemma pointwise_eq_lemma[rule_format]: "ALL n. i_th n s1 = i_th n s2 ==> s1 = s2"
242.848 -by (insert i_th_stream_take_eq [THEN stream.take_lemma],blast)
242.849 -
242.850 -(* ----------------------------------------------------------------------- *)
242.851 - subsection "finiteness"
242.852 -(* ----------------------------------------------------------------------- *)
242.853 -
242.854 -lemma slen_sconc_finite1:
242.855 - "[| #(x ooo y) = Infty; Fin n = #x |] ==> #y = Infty"
242.856 -apply (case_tac "#y ~= Infty",auto)
242.857 -apply (drule_tac y=y in rt_sconc1)
242.858 -apply (insert stream_finite_i_rt [of n "x ooo y"])
242.859 -by (simp add: slen_infinite)
242.860 -
242.861 -lemma slen_sconc_infinite1: "#x=Infty ==> #(x ooo y) = Infty"
242.862 -by (simp add: sconc_def)
242.863 -
242.864 -lemma slen_sconc_infinite2: "#y=Infty ==> #(x ooo y) = Infty"
242.865 -apply (case_tac "#x")
242.866 - apply (simp add: sconc_def)
242.867 - apply (rule someI2_ex)
242.868 - apply (drule ex_sconc,auto)
242.869 - apply (erule contrapos_pp)
242.870 - apply (insert stream_finite_i_rt)
242.871 - apply (fastsimp simp add: slen_infinite,auto)
242.872 -by (simp add: sconc_def)
242.873 -
242.874 -lemma sconc_finite: "(#x~=Infty & #y~=Infty) = (#(x ooo y)~=Infty)"
242.875 -apply auto
242.876 - apply (metis not_Infty_eq slen_sconc_finite1)
242.877 - apply (metis not_Infty_eq slen_sconc_infinite1)
242.878 -apply (metis not_Infty_eq slen_sconc_infinite2)
242.879 -done
242.880 -
242.881 -(* ----------------------------------------------------------------------- *)
242.882 -
242.883 -lemma slen_sconc_mono3: "[| Fin n = #x; Fin k = #(x ooo y) |] ==> n <= k"
242.884 -apply (insert slen_mono [of "x" "x ooo y"])
242.885 -apply (cases "#x") apply simp_all
242.886 -apply (cases "#(x ooo y)") apply simp_all
242.887 -done
242.888 -
242.889 -(* ----------------------------------------------------------------------- *)
242.890 - subsection "finite slen"
242.891 -(* ----------------------------------------------------------------------- *)
242.892 -
242.893 -lemma slen_sconc: "[| Fin n = #x; Fin m = #y |] ==> #(x ooo y) = Fin (n + m)"
242.894 -apply (case_tac "#(x ooo y)")
242.895 - apply (frule_tac y=y in rt_sconc1)
242.896 - apply (insert take_i_rt_len [of "THE j. Fin j = #(x ooo y)" "x ooo y" n n m],simp)
242.897 - apply (insert slen_sconc_mono3 [of n x _ y],simp)
242.898 -by (insert sconc_finite [of x y],auto)
242.899 -
242.900 -(* ----------------------------------------------------------------------- *)
242.901 - subsection "flat prefix"
242.902 -(* ----------------------------------------------------------------------- *)
242.903 -
242.904 -lemma sconc_prefix: "(s1::'a::flat stream) << s2 ==> EX t. s1 ooo t = s2"
242.905 -apply (case_tac "#s1")
242.906 - apply (subgoal_tac "stream_take nat$s1 = stream_take nat$s2")
242.907 - apply (rule_tac x="i_rt nat s2" in exI)
242.908 - apply (simp add: sconc_def)
242.909 - apply (rule someI2_ex)
242.910 - apply (drule ex_sconc)
242.911 - apply (simp,clarsimp,drule streams_prefix_lemma1)
242.912 - apply (simp+,rule slen_take_lemma3 [of _ s1 s2])
242.913 - apply (simp+,rule_tac x="UU" in exI)
242.914 -apply (insert slen_take_lemma3 [of _ s1 s2])
242.915 -by (rule stream.take_lemma,simp)
242.916 -
242.917 -(* ----------------------------------------------------------------------- *)
242.918 - subsection "continuity"
242.919 -(* ----------------------------------------------------------------------- *)
242.920 -
242.921 -lemma chain_sconc: "chain S ==> chain (%i. (x ooo S i))"
242.922 -by (simp add: chain_def,auto simp add: sconc_mono)
242.923 -
242.924 -lemma chain_scons: "chain S ==> chain (%i. a && S i)"
242.925 -apply (simp add: chain_def,auto)
242.926 -by (rule monofun_cfun_arg,simp)
242.927 -
242.928 -lemma contlub_scons_lemma: "chain S ==> (LUB i. a && S i) = a && (LUB i. S i)"
242.929 -by (rule cont2contlubE [OF cont_Rep_cfun2, symmetric])
242.930 -
242.931 -lemma finite_lub_sconc: "chain Y ==> (stream_finite x) ==>
242.932 - (LUB i. x ooo Y i) = (x ooo (LUB i. Y i))"
242.933 -apply (rule stream_finite_ind [of x])
242.934 - apply (auto)
242.935 -apply (subgoal_tac "(LUB i. a && (s ooo Y i)) = a && (LUB i. s ooo Y i)")
242.936 - by (force,blast dest: contlub_scons_lemma chain_sconc)
242.937 -
242.938 -lemma contlub_sconc_lemma:
242.939 - "chain Y ==> (LUB i. x ooo Y i) = (x ooo (LUB i. Y i))"
242.940 -apply (case_tac "#x=Infty")
242.941 - apply (simp add: sconc_def)
242.942 -apply (drule finite_lub_sconc,auto simp add: slen_infinite)
242.943 -done
242.944 -
242.945 -lemma monofun_sconc: "monofun (%y. x ooo y)"
242.946 -by (simp add: monofun_def sconc_mono)
242.947 -
242.948 -
242.949 -(* ----------------------------------------------------------------------- *)
242.950 - section "constr_sconc"
242.951 -(* ----------------------------------------------------------------------- *)
242.952 -
242.953 -lemma constr_sconc_UUs [simp]: "constr_sconc UU s = s"
242.954 -by (simp add: constr_sconc_def zero_inat_def)
242.955 -
242.956 -lemma "x ooo y = constr_sconc x y"
242.957 -apply (case_tac "#x")
242.958 - apply (rule stream_finite_ind [of x],auto simp del: scons_sconc)
242.959 - defer 1
242.960 - apply (simp add: constr_sconc_def del: scons_sconc)
242.961 - apply (case_tac "#s")
242.962 - apply (simp add: iSuc_Fin)
242.963 - apply (case_tac "a=UU",auto simp del: scons_sconc)
242.964 - apply (simp)
242.965 - apply (simp add: sconc_def)
242.966 - apply (simp add: constr_sconc_def)
242.967 -apply (simp add: stream.finite_def)
242.968 -by (drule slen_take_lemma1,auto)
242.969 -
242.970 -end
243.1 --- a/src/HOLCF/Library/Sum_Cpo.thy Sat Nov 27 14:34:54 2010 -0800
243.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
243.3 @@ -1,292 +0,0 @@
243.4 -(* Title: HOLCF/Sum_Cpo.thy
243.5 - Author: Brian Huffman
243.6 -*)
243.7 -
243.8 -header {* The cpo of disjoint sums *}
243.9 -
243.10 -theory Sum_Cpo
243.11 -imports HOLCF
243.12 -begin
243.13 -
243.14 -subsection {* Ordering on sum type *}
243.15 -
243.16 -instantiation sum :: (below, below) below
243.17 -begin
243.18 -
243.19 -definition below_sum_def:
243.20 - "x \<sqsubseteq> y \<equiv> case x of
243.21 - Inl a \<Rightarrow> (case y of Inl b \<Rightarrow> a \<sqsubseteq> b | Inr b \<Rightarrow> False) |
243.22 - Inr a \<Rightarrow> (case y of Inl b \<Rightarrow> False | Inr b \<Rightarrow> a \<sqsubseteq> b)"
243.23 -
243.24 -instance ..
243.25 -end
243.26 -
243.27 -lemma Inl_below_Inl [simp]: "Inl x \<sqsubseteq> Inl y \<longleftrightarrow> x \<sqsubseteq> y"
243.28 -unfolding below_sum_def by simp
243.29 -
243.30 -lemma Inr_below_Inr [simp]: "Inr x \<sqsubseteq> Inr y \<longleftrightarrow> x \<sqsubseteq> y"
243.31 -unfolding below_sum_def by simp
243.32 -
243.33 -lemma Inl_below_Inr [simp]: "\<not> Inl x \<sqsubseteq> Inr y"
243.34 -unfolding below_sum_def by simp
243.35 -
243.36 -lemma Inr_below_Inl [simp]: "\<not> Inr x \<sqsubseteq> Inl y"
243.37 -unfolding below_sum_def by simp
243.38 -
243.39 -lemma Inl_mono: "x \<sqsubseteq> y \<Longrightarrow> Inl x \<sqsubseteq> Inl y"
243.40 -by simp
243.41 -
243.42 -lemma Inr_mono: "x \<sqsubseteq> y \<Longrightarrow> Inr x \<sqsubseteq> Inr y"
243.43 -by simp
243.44 -
243.45 -lemma Inl_belowE: "\<lbrakk>Inl a \<sqsubseteq> x; \<And>b. \<lbrakk>x = Inl b; a \<sqsubseteq> b\<rbrakk> \<Longrightarrow> R\<rbrakk> \<Longrightarrow> R"
243.46 -by (cases x, simp_all)
243.47 -
243.48 -lemma Inr_belowE: "\<lbrakk>Inr a \<sqsubseteq> x; \<And>b. \<lbrakk>x = Inr b; a \<sqsubseteq> b\<rbrakk> \<Longrightarrow> R\<rbrakk> \<Longrightarrow> R"
243.49 -by (cases x, simp_all)
243.50 -
243.51 -lemmas sum_below_elims = Inl_belowE Inr_belowE
243.52 -
243.53 -lemma sum_below_cases:
243.54 - "\<lbrakk>x \<sqsubseteq> y;
243.55 - \<And>a b. \<lbrakk>x = Inl a; y = Inl b; a \<sqsubseteq> b\<rbrakk> \<Longrightarrow> R;
243.56 - \<And>a b. \<lbrakk>x = Inr a; y = Inr b; a \<sqsubseteq> b\<rbrakk> \<Longrightarrow> R\<rbrakk>
243.57 - \<Longrightarrow> R"
243.58 -by (cases x, safe elim!: sum_below_elims, auto)
243.59 -
243.60 -subsection {* Sum type is a complete partial order *}
243.61 -
243.62 -instance sum :: (po, po) po
243.63 -proof
243.64 - fix x :: "'a + 'b"
243.65 - show "x \<sqsubseteq> x"
243.66 - by (induct x, simp_all)
243.67 -next
243.68 - fix x y :: "'a + 'b"
243.69 - assume "x \<sqsubseteq> y" and "y \<sqsubseteq> x" thus "x = y"
243.70 - by (induct x, auto elim!: sum_below_elims intro: below_antisym)
243.71 -next
243.72 - fix x y z :: "'a + 'b"
243.73 - assume "x \<sqsubseteq> y" and "y \<sqsubseteq> z" thus "x \<sqsubseteq> z"
243.74 - by (induct x, auto elim!: sum_below_elims intro: below_trans)
243.75 -qed
243.76 -
243.77 -lemma monofun_inv_Inl: "monofun (\<lambda>p. THE a. p = Inl a)"
243.78 -by (rule monofunI, erule sum_below_cases, simp_all)
243.79 -
243.80 -lemma monofun_inv_Inr: "monofun (\<lambda>p. THE b. p = Inr b)"
243.81 -by (rule monofunI, erule sum_below_cases, simp_all)
243.82 -
243.83 -lemma sum_chain_cases:
243.84 - assumes Y: "chain Y"
243.85 - assumes A: "\<And>A. \<lbrakk>chain A; Y = (\<lambda>i. Inl (A i))\<rbrakk> \<Longrightarrow> R"
243.86 - assumes B: "\<And>B. \<lbrakk>chain B; Y = (\<lambda>i. Inr (B i))\<rbrakk> \<Longrightarrow> R"
243.87 - shows "R"
243.88 - apply (cases "Y 0")
243.89 - apply (rule A)
243.90 - apply (rule ch2ch_monofun [OF monofun_inv_Inl Y])
243.91 - apply (rule ext)
243.92 - apply (cut_tac j=i in chain_mono [OF Y le0], simp)
243.93 - apply (erule Inl_belowE, simp)
243.94 - apply (rule B)
243.95 - apply (rule ch2ch_monofun [OF monofun_inv_Inr Y])
243.96 - apply (rule ext)
243.97 - apply (cut_tac j=i in chain_mono [OF Y le0], simp)
243.98 - apply (erule Inr_belowE, simp)
243.99 -done
243.100 -
243.101 -lemma is_lub_Inl: "range S <<| x \<Longrightarrow> range (\<lambda>i. Inl (S i)) <<| Inl x"
243.102 - apply (rule is_lubI)
243.103 - apply (rule ub_rangeI)
243.104 - apply (simp add: is_lub_rangeD1)
243.105 - apply (frule ub_rangeD [where i=arbitrary])
243.106 - apply (erule Inl_belowE, simp)
243.107 - apply (erule is_lubD2)
243.108 - apply (rule ub_rangeI)
243.109 - apply (drule ub_rangeD, simp)
243.110 -done
243.111 -
243.112 -lemma is_lub_Inr: "range S <<| x \<Longrightarrow> range (\<lambda>i. Inr (S i)) <<| Inr x"
243.113 - apply (rule is_lubI)
243.114 - apply (rule ub_rangeI)
243.115 - apply (simp add: is_lub_rangeD1)
243.116 - apply (frule ub_rangeD [where i=arbitrary])
243.117 - apply (erule Inr_belowE, simp)
243.118 - apply (erule is_lubD2)
243.119 - apply (rule ub_rangeI)
243.120 - apply (drule ub_rangeD, simp)
243.121 -done
243.122 -
243.123 -instance sum :: (cpo, cpo) cpo
243.124 - apply intro_classes
243.125 - apply (erule sum_chain_cases, safe)
243.126 - apply (rule exI)
243.127 - apply (rule is_lub_Inl)
243.128 - apply (erule cpo_lubI)
243.129 - apply (rule exI)
243.130 - apply (rule is_lub_Inr)
243.131 - apply (erule cpo_lubI)
243.132 -done
243.133 -
243.134 -subsection {* Continuity of \emph{Inl}, \emph{Inr}, and case function *}
243.135 -
243.136 -lemma cont_Inl: "cont Inl"
243.137 -by (intro contI is_lub_Inl cpo_lubI)
243.138 -
243.139 -lemma cont_Inr: "cont Inr"
243.140 -by (intro contI is_lub_Inr cpo_lubI)
243.141 -
243.142 -lemmas cont2cont_Inl [simp, cont2cont] = cont_compose [OF cont_Inl]
243.143 -lemmas cont2cont_Inr [simp, cont2cont] = cont_compose [OF cont_Inr]
243.144 -
243.145 -lemmas ch2ch_Inl [simp] = ch2ch_cont [OF cont_Inl]
243.146 -lemmas ch2ch_Inr [simp] = ch2ch_cont [OF cont_Inr]
243.147 -
243.148 -lemmas lub_Inl = cont2contlubE [OF cont_Inl, symmetric]
243.149 -lemmas lub_Inr = cont2contlubE [OF cont_Inr, symmetric]
243.150 -
243.151 -lemma cont_sum_case1:
243.152 - assumes f: "\<And>a. cont (\<lambda>x. f x a)"
243.153 - assumes g: "\<And>b. cont (\<lambda>x. g x b)"
243.154 - shows "cont (\<lambda>x. case y of Inl a \<Rightarrow> f x a | Inr b \<Rightarrow> g x b)"
243.155 -by (induct y, simp add: f, simp add: g)
243.156 -
243.157 -lemma cont_sum_case2: "\<lbrakk>cont f; cont g\<rbrakk> \<Longrightarrow> cont (sum_case f g)"
243.158 -apply (rule contI)
243.159 -apply (erule sum_chain_cases)
243.160 -apply (simp add: cont2contlubE [OF cont_Inl, symmetric] contE)
243.161 -apply (simp add: cont2contlubE [OF cont_Inr, symmetric] contE)
243.162 -done
243.163 -
243.164 -lemma cont2cont_sum_case:
243.165 - assumes f1: "\<And>a. cont (\<lambda>x. f x a)" and f2: "\<And>x. cont (\<lambda>a. f x a)"
243.166 - assumes g1: "\<And>b. cont (\<lambda>x. g x b)" and g2: "\<And>x. cont (\<lambda>b. g x b)"
243.167 - assumes h: "cont (\<lambda>x. h x)"
243.168 - shows "cont (\<lambda>x. case h x of Inl a \<Rightarrow> f x a | Inr b \<Rightarrow> g x b)"
243.169 -apply (rule cont_apply [OF h])
243.170 -apply (rule cont_sum_case2 [OF f2 g2])
243.171 -apply (rule cont_sum_case1 [OF f1 g1])
243.172 -done
243.173 -
243.174 -lemma cont2cont_sum_case' [simp, cont2cont]:
243.175 - assumes f: "cont (\<lambda>p. f (fst p) (snd p))"
243.176 - assumes g: "cont (\<lambda>p. g (fst p) (snd p))"
243.177 - assumes h: "cont (\<lambda>x. h x)"
243.178 - shows "cont (\<lambda>x. case h x of Inl a \<Rightarrow> f x a | Inr b \<Rightarrow> g x b)"
243.179 -using assms by (simp add: cont2cont_sum_case prod_cont_iff)
243.180 -
243.181 -subsection {* Compactness and chain-finiteness *}
243.182 -
243.183 -lemma compact_Inl: "compact a \<Longrightarrow> compact (Inl a)"
243.184 -apply (rule compactI2)
243.185 -apply (erule sum_chain_cases, safe)
243.186 -apply (simp add: lub_Inl)
243.187 -apply (erule (2) compactD2)
243.188 -apply (simp add: lub_Inr)
243.189 -done
243.190 -
243.191 -lemma compact_Inr: "compact a \<Longrightarrow> compact (Inr a)"
243.192 -apply (rule compactI2)
243.193 -apply (erule sum_chain_cases, safe)
243.194 -apply (simp add: lub_Inl)
243.195 -apply (simp add: lub_Inr)
243.196 -apply (erule (2) compactD2)
243.197 -done
243.198 -
243.199 -lemma compact_Inl_rev: "compact (Inl a) \<Longrightarrow> compact a"
243.200 -unfolding compact_def
243.201 -by (drule adm_subst [OF cont_Inl], simp)
243.202 -
243.203 -lemma compact_Inr_rev: "compact (Inr a) \<Longrightarrow> compact a"
243.204 -unfolding compact_def
243.205 -by (drule adm_subst [OF cont_Inr], simp)
243.206 -
243.207 -lemma compact_Inl_iff [simp]: "compact (Inl a) = compact a"
243.208 -by (safe elim!: compact_Inl compact_Inl_rev)
243.209 -
243.210 -lemma compact_Inr_iff [simp]: "compact (Inr a) = compact a"
243.211 -by (safe elim!: compact_Inr compact_Inr_rev)
243.212 -
243.213 -instance sum :: (chfin, chfin) chfin
243.214 -apply intro_classes
243.215 -apply (erule compact_imp_max_in_chain)
243.216 -apply (case_tac "\<Squnion>i. Y i", simp_all)
243.217 -done
243.218 -
243.219 -instance sum :: (discrete_cpo, discrete_cpo) discrete_cpo
243.220 -by intro_classes (simp add: below_sum_def split: sum.split)
243.221 -
243.222 -subsection {* Using sum types with fixrec *}
243.223 -
243.224 -definition
243.225 - "match_Inl = (\<Lambda> x k. case x of Inl a \<Rightarrow> k\<cdot>a | Inr b \<Rightarrow> Fixrec.fail)"
243.226 -
243.227 -definition
243.228 - "match_Inr = (\<Lambda> x k. case x of Inl a \<Rightarrow> Fixrec.fail | Inr b \<Rightarrow> k\<cdot>b)"
243.229 -
243.230 -lemma match_Inl_simps [simp]:
243.231 - "match_Inl\<cdot>(Inl a)\<cdot>k = k\<cdot>a"
243.232 - "match_Inl\<cdot>(Inr b)\<cdot>k = Fixrec.fail"
243.233 -unfolding match_Inl_def by simp_all
243.234 -
243.235 -lemma match_Inr_simps [simp]:
243.236 - "match_Inr\<cdot>(Inl a)\<cdot>k = Fixrec.fail"
243.237 - "match_Inr\<cdot>(Inr b)\<cdot>k = k\<cdot>b"
243.238 -unfolding match_Inr_def by simp_all
243.239 -
243.240 -setup {*
243.241 - Fixrec.add_matchers
243.242 - [ (@{const_name Inl}, @{const_name match_Inl}),
243.243 - (@{const_name Inr}, @{const_name match_Inr}) ]
243.244 -*}
243.245 -
243.246 -subsection {* Disjoint sum is a predomain *}
243.247 -
243.248 -definition
243.249 - "encode_sum_u =
243.250 - (\<Lambda>(up\<cdot>x). case x of Inl a \<Rightarrow> sinl\<cdot>(up\<cdot>a) | Inr b \<Rightarrow> sinr\<cdot>(up\<cdot>b))"
243.251 -
243.252 -definition
243.253 - "decode_sum_u = sscase\<cdot>(\<Lambda>(up\<cdot>a). up\<cdot>(Inl a))\<cdot>(\<Lambda>(up\<cdot>b). up\<cdot>(Inr b))"
243.254 -
243.255 -lemma decode_encode_sum_u [simp]: "decode_sum_u\<cdot>(encode_sum_u\<cdot>x) = x"
243.256 -unfolding decode_sum_u_def encode_sum_u_def
243.257 -by (case_tac x, simp, rename_tac y, case_tac y, simp_all)
243.258 -
243.259 -lemma encode_decode_sum_u [simp]: "encode_sum_u\<cdot>(decode_sum_u\<cdot>x) = x"
243.260 -unfolding decode_sum_u_def encode_sum_u_def
243.261 -apply (case_tac x, simp)
243.262 -apply (rename_tac a, case_tac a, simp, simp)
243.263 -apply (rename_tac b, case_tac b, simp, simp)
243.264 -done
243.265 -
243.266 -instantiation sum :: (predomain, predomain) predomain
243.267 -begin
243.268 -
243.269 -definition
243.270 - "liftemb = (udom_emb ssum_approx oo ssum_map\<cdot>emb\<cdot>emb) oo encode_sum_u"
243.271 -
243.272 -definition
243.273 - "liftprj =
243.274 - decode_sum_u oo (ssum_map\<cdot>prj\<cdot>prj oo udom_prj ssum_approx)"
243.275 -
243.276 -definition
243.277 - "liftdefl (t::('a + 'b) itself) = ssum_defl\<cdot>DEFL('a u)\<cdot>DEFL('b u)"
243.278 -
243.279 -instance proof
243.280 - show "ep_pair liftemb (liftprj :: udom \<rightarrow> ('a + 'b) u)"
243.281 - unfolding liftemb_sum_def liftprj_sum_def
243.282 - apply (rule ep_pair_comp)
243.283 - apply (rule ep_pair.intro, simp, simp)
243.284 - apply (rule ep_pair_comp)
243.285 - apply (intro ep_pair_ssum_map ep_pair_emb_prj)
243.286 - apply (rule ep_pair_udom [OF ssum_approx])
243.287 - done
243.288 - show "cast\<cdot>LIFTDEFL('a + 'b) = liftemb oo (liftprj :: udom \<rightarrow> ('a + 'b) u)"
243.289 - unfolding liftemb_sum_def liftprj_sum_def liftdefl_sum_def
243.290 - by (simp add: cast_ssum_defl cast_DEFL cfcomp1 ssum_map_map)
243.291 -qed
243.292 -
243.293 -end
243.294 -
243.295 -end
244.1 --- a/src/HOLCF/Lift.thy Sat Nov 27 14:34:54 2010 -0800
244.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
244.3 @@ -1,133 +0,0 @@
244.4 -(* Title: HOLCF/Lift.thy
244.5 - Author: Olaf Mueller
244.6 -*)
244.7 -
244.8 -header {* Lifting types of class type to flat pcpo's *}
244.9 -
244.10 -theory Lift
244.11 -imports Discrete Up
244.12 -begin
244.13 -
244.14 -default_sort type
244.15 -
244.16 -pcpodef (open) 'a lift = "UNIV :: 'a discr u set"
244.17 -by simp_all
244.18 -
244.19 -lemmas inst_lift_pcpo = Abs_lift_strict [symmetric]
244.20 -
244.21 -definition
244.22 - Def :: "'a \<Rightarrow> 'a lift" where
244.23 - "Def x = Abs_lift (up\<cdot>(Discr x))"
244.24 -
244.25 -subsection {* Lift as a datatype *}
244.26 -
244.27 -lemma lift_induct: "\<lbrakk>P \<bottom>; \<And>x. P (Def x)\<rbrakk> \<Longrightarrow> P y"
244.28 -apply (induct y)
244.29 -apply (rule_tac p=y in upE)
244.30 -apply (simp add: Abs_lift_strict)
244.31 -apply (case_tac x)
244.32 -apply (simp add: Def_def)
244.33 -done
244.34 -
244.35 -rep_datatype "\<bottom>\<Colon>'a lift" Def
244.36 - by (erule lift_induct) (simp_all add: Def_def Abs_lift_inject inst_lift_pcpo)
244.37 -
244.38 -lemmas lift_distinct1 = lift.distinct(1)
244.39 -lemmas lift_distinct2 = lift.distinct(2)
244.40 -lemmas Def_not_UU = lift.distinct(2)
244.41 -lemmas Def_inject = lift.inject
244.42 -
244.43 -
244.44 -text {* @{term UU} and @{term Def} *}
244.45 -
244.46 -lemma not_Undef_is_Def: "(x \<noteq> \<bottom>) = (\<exists>y. x = Def y)"
244.47 - by (cases x) simp_all
244.48 -
244.49 -lemma lift_definedE: "\<lbrakk>x \<noteq> \<bottom>; \<And>a. x = Def a \<Longrightarrow> R\<rbrakk> \<Longrightarrow> R"
244.50 - by (cases x) simp_all
244.51 -
244.52 -text {*
244.53 - For @{term "x ~= UU"} in assumptions @{text defined} replaces @{text
244.54 - x} by @{text "Def a"} in conclusion. *}
244.55 -
244.56 -method_setup defined = {*
244.57 - Scan.succeed (fn ctxt => SIMPLE_METHOD'
244.58 - (etac @{thm lift_definedE} THEN' asm_simp_tac (simpset_of ctxt)))
244.59 -*} ""
244.60 -
244.61 -lemma DefE: "Def x = \<bottom> \<Longrightarrow> R"
244.62 - by simp
244.63 -
244.64 -lemma DefE2: "\<lbrakk>x = Def s; x = \<bottom>\<rbrakk> \<Longrightarrow> R"
244.65 - by simp
244.66 -
244.67 -lemma Def_below_Def: "Def x \<sqsubseteq> Def y \<longleftrightarrow> x = y"
244.68 -by (simp add: below_lift_def Def_def Abs_lift_inverse)
244.69 -
244.70 -lemma Def_below_iff [simp]: "Def x \<sqsubseteq> y \<longleftrightarrow> Def x = y"
244.71 -by (induct y, simp, simp add: Def_below_Def)
244.72 -
244.73 -
244.74 -subsection {* Lift is flat *}
244.75 -
244.76 -instance lift :: (type) flat
244.77 -proof
244.78 - fix x y :: "'a lift"
244.79 - assume "x \<sqsubseteq> y" thus "x = \<bottom> \<or> x = y"
244.80 - by (induct x) auto
244.81 -qed
244.82 -
244.83 -subsection {* Continuity of @{const lift_case} *}
244.84 -
244.85 -lemma lift_case_eq: "lift_case \<bottom> f x = fup\<cdot>(\<Lambda> y. f (undiscr y))\<cdot>(Rep_lift x)"
244.86 -apply (induct x, unfold lift.cases)
244.87 -apply (simp add: Rep_lift_strict)
244.88 -apply (simp add: Def_def Abs_lift_inverse)
244.89 -done
244.90 -
244.91 -lemma cont2cont_lift_case [simp]:
244.92 - "\<lbrakk>\<And>y. cont (\<lambda>x. f x y); cont g\<rbrakk> \<Longrightarrow> cont (\<lambda>x. lift_case \<bottom> (f x) (g x))"
244.93 -unfolding lift_case_eq by (simp add: cont_Rep_lift [THEN cont_compose])
244.94 -
244.95 -subsection {* Further operations *}
244.96 -
244.97 -definition
244.98 - flift1 :: "('a \<Rightarrow> 'b::pcpo) \<Rightarrow> ('a lift \<rightarrow> 'b)" (binder "FLIFT " 10) where
244.99 - "flift1 = (\<lambda>f. (\<Lambda> x. lift_case \<bottom> f x))"
244.100 -
244.101 -translations
244.102 - "\<Lambda>(XCONST Def x). t" => "CONST flift1 (\<lambda>x. t)"
244.103 - "\<Lambda>(CONST Def x). FLIFT y. t" <= "FLIFT x y. t"
244.104 - "\<Lambda>(CONST Def x). t" <= "FLIFT x. t"
244.105 -
244.106 -definition
244.107 - flift2 :: "('a \<Rightarrow> 'b) \<Rightarrow> ('a lift \<rightarrow> 'b lift)" where
244.108 - "flift2 f = (FLIFT x. Def (f x))"
244.109 -
244.110 -lemma flift1_Def [simp]: "flift1 f\<cdot>(Def x) = (f x)"
244.111 -by (simp add: flift1_def)
244.112 -
244.113 -lemma flift2_Def [simp]: "flift2 f\<cdot>(Def x) = Def (f x)"
244.114 -by (simp add: flift2_def)
244.115 -
244.116 -lemma flift1_strict [simp]: "flift1 f\<cdot>\<bottom> = \<bottom>"
244.117 -by (simp add: flift1_def)
244.118 -
244.119 -lemma flift2_strict [simp]: "flift2 f\<cdot>\<bottom> = \<bottom>"
244.120 -by (simp add: flift2_def)
244.121 -
244.122 -lemma flift2_defined [simp]: "x \<noteq> \<bottom> \<Longrightarrow> (flift2 f)\<cdot>x \<noteq> \<bottom>"
244.123 -by (erule lift_definedE, simp)
244.124 -
244.125 -lemma flift2_bottom_iff [simp]: "(flift2 f\<cdot>x = \<bottom>) = (x = \<bottom>)"
244.126 -by (cases x, simp_all)
244.127 -
244.128 -lemma FLIFT_mono:
244.129 - "(\<And>x. f x \<sqsubseteq> g x) \<Longrightarrow> (FLIFT x. f x) \<sqsubseteq> (FLIFT x. g x)"
244.130 -by (rule cfun_belowI, case_tac x, simp_all)
244.131 -
244.132 -lemma cont2cont_flift1 [simp, cont2cont]:
244.133 - "\<lbrakk>\<And>y. cont (\<lambda>x. f x y)\<rbrakk> \<Longrightarrow> cont (\<lambda>x. FLIFT y. f x y)"
244.134 -by (simp add: flift1_def cont2cont_LAM)
244.135 -
244.136 -end
245.1 --- a/src/HOLCF/LowerPD.thy Sat Nov 27 14:34:54 2010 -0800
245.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
245.3 @@ -1,534 +0,0 @@
245.4 -(* Title: HOLCF/LowerPD.thy
245.5 - Author: Brian Huffman
245.6 -*)
245.7 -
245.8 -header {* Lower powerdomain *}
245.9 -
245.10 -theory LowerPD
245.11 -imports CompactBasis
245.12 -begin
245.13 -
245.14 -subsection {* Basis preorder *}
245.15 -
245.16 -definition
245.17 - lower_le :: "'a pd_basis \<Rightarrow> 'a pd_basis \<Rightarrow> bool" (infix "\<le>\<flat>" 50) where
245.18 - "lower_le = (\<lambda>u v. \<forall>x\<in>Rep_pd_basis u. \<exists>y\<in>Rep_pd_basis v. x \<sqsubseteq> y)"
245.19 -
245.20 -lemma lower_le_refl [simp]: "t \<le>\<flat> t"
245.21 -unfolding lower_le_def by fast
245.22 -
245.23 -lemma lower_le_trans: "\<lbrakk>t \<le>\<flat> u; u \<le>\<flat> v\<rbrakk> \<Longrightarrow> t \<le>\<flat> v"
245.24 -unfolding lower_le_def
245.25 -apply (rule ballI)
245.26 -apply (drule (1) bspec, erule bexE)
245.27 -apply (drule (1) bspec, erule bexE)
245.28 -apply (erule rev_bexI)
245.29 -apply (erule (1) below_trans)
245.30 -done
245.31 -
245.32 -interpretation lower_le: preorder lower_le
245.33 -by (rule preorder.intro, rule lower_le_refl, rule lower_le_trans)
245.34 -
245.35 -lemma lower_le_minimal [simp]: "PDUnit compact_bot \<le>\<flat> t"
245.36 -unfolding lower_le_def Rep_PDUnit
245.37 -by (simp, rule Rep_pd_basis_nonempty [folded ex_in_conv])
245.38 -
245.39 -lemma PDUnit_lower_mono: "x \<sqsubseteq> y \<Longrightarrow> PDUnit x \<le>\<flat> PDUnit y"
245.40 -unfolding lower_le_def Rep_PDUnit by fast
245.41 -
245.42 -lemma PDPlus_lower_mono: "\<lbrakk>s \<le>\<flat> t; u \<le>\<flat> v\<rbrakk> \<Longrightarrow> PDPlus s u \<le>\<flat> PDPlus t v"
245.43 -unfolding lower_le_def Rep_PDPlus by fast
245.44 -
245.45 -lemma PDPlus_lower_le: "t \<le>\<flat> PDPlus t u"
245.46 -unfolding lower_le_def Rep_PDPlus by fast
245.47 -
245.48 -lemma lower_le_PDUnit_PDUnit_iff [simp]:
245.49 - "(PDUnit a \<le>\<flat> PDUnit b) = (a \<sqsubseteq> b)"
245.50 -unfolding lower_le_def Rep_PDUnit by fast
245.51 -
245.52 -lemma lower_le_PDUnit_PDPlus_iff:
245.53 - "(PDUnit a \<le>\<flat> PDPlus t u) = (PDUnit a \<le>\<flat> t \<or> PDUnit a \<le>\<flat> u)"
245.54 -unfolding lower_le_def Rep_PDPlus Rep_PDUnit by fast
245.55 -
245.56 -lemma lower_le_PDPlus_iff: "(PDPlus t u \<le>\<flat> v) = (t \<le>\<flat> v \<and> u \<le>\<flat> v)"
245.57 -unfolding lower_le_def Rep_PDPlus by fast
245.58 -
245.59 -lemma lower_le_induct [induct set: lower_le]:
245.60 - assumes le: "t \<le>\<flat> u"
245.61 - assumes 1: "\<And>a b. a \<sqsubseteq> b \<Longrightarrow> P (PDUnit a) (PDUnit b)"
245.62 - assumes 2: "\<And>t u a. P (PDUnit a) t \<Longrightarrow> P (PDUnit a) (PDPlus t u)"
245.63 - assumes 3: "\<And>t u v. \<lbrakk>P t v; P u v\<rbrakk> \<Longrightarrow> P (PDPlus t u) v"
245.64 - shows "P t u"
245.65 -using le
245.66 -apply (induct t arbitrary: u rule: pd_basis_induct)
245.67 -apply (erule rev_mp)
245.68 -apply (induct_tac u rule: pd_basis_induct)
245.69 -apply (simp add: 1)
245.70 -apply (simp add: lower_le_PDUnit_PDPlus_iff)
245.71 -apply (simp add: 2)
245.72 -apply (subst PDPlus_commute)
245.73 -apply (simp add: 2)
245.74 -apply (simp add: lower_le_PDPlus_iff 3)
245.75 -done
245.76 -
245.77 -
245.78 -subsection {* Type definition *}
245.79 -
245.80 -typedef (open) 'a lower_pd =
245.81 - "{S::'a pd_basis set. lower_le.ideal S}"
245.82 -by (fast intro: lower_le.ideal_principal)
245.83 -
245.84 -instantiation lower_pd :: ("domain") below
245.85 -begin
245.86 -
245.87 -definition
245.88 - "x \<sqsubseteq> y \<longleftrightarrow> Rep_lower_pd x \<subseteq> Rep_lower_pd y"
245.89 -
245.90 -instance ..
245.91 -end
245.92 -
245.93 -instance lower_pd :: ("domain") po
245.94 -using type_definition_lower_pd below_lower_pd_def
245.95 -by (rule lower_le.typedef_ideal_po)
245.96 -
245.97 -instance lower_pd :: ("domain") cpo
245.98 -using type_definition_lower_pd below_lower_pd_def
245.99 -by (rule lower_le.typedef_ideal_cpo)
245.100 -
245.101 -definition
245.102 - lower_principal :: "'a pd_basis \<Rightarrow> 'a lower_pd" where
245.103 - "lower_principal t = Abs_lower_pd {u. u \<le>\<flat> t}"
245.104 -
245.105 -interpretation lower_pd:
245.106 - ideal_completion lower_le lower_principal Rep_lower_pd
245.107 -using type_definition_lower_pd below_lower_pd_def
245.108 -using lower_principal_def pd_basis_countable
245.109 -by (rule lower_le.typedef_ideal_completion)
245.110 -
245.111 -text {* Lower powerdomain is pointed *}
245.112 -
245.113 -lemma lower_pd_minimal: "lower_principal (PDUnit compact_bot) \<sqsubseteq> ys"
245.114 -by (induct ys rule: lower_pd.principal_induct, simp, simp)
245.115 -
245.116 -instance lower_pd :: ("domain") pcpo
245.117 -by intro_classes (fast intro: lower_pd_minimal)
245.118 -
245.119 -lemma inst_lower_pd_pcpo: "\<bottom> = lower_principal (PDUnit compact_bot)"
245.120 -by (rule lower_pd_minimal [THEN UU_I, symmetric])
245.121 -
245.122 -
245.123 -subsection {* Monadic unit and plus *}
245.124 -
245.125 -definition
245.126 - lower_unit :: "'a \<rightarrow> 'a lower_pd" where
245.127 - "lower_unit = compact_basis.basis_fun (\<lambda>a. lower_principal (PDUnit a))"
245.128 -
245.129 -definition
245.130 - lower_plus :: "'a lower_pd \<rightarrow> 'a lower_pd \<rightarrow> 'a lower_pd" where
245.131 - "lower_plus = lower_pd.basis_fun (\<lambda>t. lower_pd.basis_fun (\<lambda>u.
245.132 - lower_principal (PDPlus t u)))"
245.133 -
245.134 -abbreviation
245.135 - lower_add :: "'a lower_pd \<Rightarrow> 'a lower_pd \<Rightarrow> 'a lower_pd"
245.136 - (infixl "+\<flat>" 65) where
245.137 - "xs +\<flat> ys == lower_plus\<cdot>xs\<cdot>ys"
245.138 -
245.139 -syntax
245.140 - "_lower_pd" :: "args \<Rightarrow> 'a lower_pd" ("{_}\<flat>")
245.141 -
245.142 -translations
245.143 - "{x,xs}\<flat>" == "{x}\<flat> +\<flat> {xs}\<flat>"
245.144 - "{x}\<flat>" == "CONST lower_unit\<cdot>x"
245.145 -
245.146 -lemma lower_unit_Rep_compact_basis [simp]:
245.147 - "{Rep_compact_basis a}\<flat> = lower_principal (PDUnit a)"
245.148 -unfolding lower_unit_def
245.149 -by (simp add: compact_basis.basis_fun_principal PDUnit_lower_mono)
245.150 -
245.151 -lemma lower_plus_principal [simp]:
245.152 - "lower_principal t +\<flat> lower_principal u = lower_principal (PDPlus t u)"
245.153 -unfolding lower_plus_def
245.154 -by (simp add: lower_pd.basis_fun_principal
245.155 - lower_pd.basis_fun_mono PDPlus_lower_mono)
245.156 -
245.157 -interpretation lower_add: semilattice lower_add proof
245.158 - fix xs ys zs :: "'a lower_pd"
245.159 - show "(xs +\<flat> ys) +\<flat> zs = xs +\<flat> (ys +\<flat> zs)"
245.160 - apply (induct xs ys arbitrary: zs rule: lower_pd.principal_induct2, simp, simp)
245.161 - apply (rule_tac x=zs in lower_pd.principal_induct, simp)
245.162 - apply (simp add: PDPlus_assoc)
245.163 - done
245.164 - show "xs +\<flat> ys = ys +\<flat> xs"
245.165 - apply (induct xs ys rule: lower_pd.principal_induct2, simp, simp)
245.166 - apply (simp add: PDPlus_commute)
245.167 - done
245.168 - show "xs +\<flat> xs = xs"
245.169 - apply (induct xs rule: lower_pd.principal_induct, simp)
245.170 - apply (simp add: PDPlus_absorb)
245.171 - done
245.172 -qed
245.173 -
245.174 -lemmas lower_plus_assoc = lower_add.assoc
245.175 -lemmas lower_plus_commute = lower_add.commute
245.176 -lemmas lower_plus_absorb = lower_add.idem
245.177 -lemmas lower_plus_left_commute = lower_add.left_commute
245.178 -lemmas lower_plus_left_absorb = lower_add.left_idem
245.179 -
245.180 -text {* Useful for @{text "simp add: lower_plus_ac"} *}
245.181 -lemmas lower_plus_ac =
245.182 - lower_plus_assoc lower_plus_commute lower_plus_left_commute
245.183 -
245.184 -text {* Useful for @{text "simp only: lower_plus_aci"} *}
245.185 -lemmas lower_plus_aci =
245.186 - lower_plus_ac lower_plus_absorb lower_plus_left_absorb
245.187 -
245.188 -lemma lower_plus_below1: "xs \<sqsubseteq> xs +\<flat> ys"
245.189 -apply (induct xs ys rule: lower_pd.principal_induct2, simp, simp)
245.190 -apply (simp add: PDPlus_lower_le)
245.191 -done
245.192 -
245.193 -lemma lower_plus_below2: "ys \<sqsubseteq> xs +\<flat> ys"
245.194 -by (subst lower_plus_commute, rule lower_plus_below1)
245.195 -
245.196 -lemma lower_plus_least: "\<lbrakk>xs \<sqsubseteq> zs; ys \<sqsubseteq> zs\<rbrakk> \<Longrightarrow> xs +\<flat> ys \<sqsubseteq> zs"
245.197 -apply (subst lower_plus_absorb [of zs, symmetric])
245.198 -apply (erule (1) monofun_cfun [OF monofun_cfun_arg])
245.199 -done
245.200 -
245.201 -lemma lower_plus_below_iff [simp]:
245.202 - "xs +\<flat> ys \<sqsubseteq> zs \<longleftrightarrow> xs \<sqsubseteq> zs \<and> ys \<sqsubseteq> zs"
245.203 -apply safe
245.204 -apply (erule below_trans [OF lower_plus_below1])
245.205 -apply (erule below_trans [OF lower_plus_below2])
245.206 -apply (erule (1) lower_plus_least)
245.207 -done
245.208 -
245.209 -lemma lower_unit_below_plus_iff [simp]:
245.210 - "{x}\<flat> \<sqsubseteq> ys +\<flat> zs \<longleftrightarrow> {x}\<flat> \<sqsubseteq> ys \<or> {x}\<flat> \<sqsubseteq> zs"
245.211 -apply (induct x rule: compact_basis.principal_induct, simp)
245.212 -apply (induct ys rule: lower_pd.principal_induct, simp)
245.213 -apply (induct zs rule: lower_pd.principal_induct, simp)
245.214 -apply (simp add: lower_le_PDUnit_PDPlus_iff)
245.215 -done
245.216 -
245.217 -lemma lower_unit_below_iff [simp]: "{x}\<flat> \<sqsubseteq> {y}\<flat> \<longleftrightarrow> x \<sqsubseteq> y"
245.218 -apply (induct x rule: compact_basis.principal_induct, simp)
245.219 -apply (induct y rule: compact_basis.principal_induct, simp)
245.220 -apply simp
245.221 -done
245.222 -
245.223 -lemmas lower_pd_below_simps =
245.224 - lower_unit_below_iff
245.225 - lower_plus_below_iff
245.226 - lower_unit_below_plus_iff
245.227 -
245.228 -lemma lower_unit_eq_iff [simp]: "{x}\<flat> = {y}\<flat> \<longleftrightarrow> x = y"
245.229 -by (simp add: po_eq_conv)
245.230 -
245.231 -lemma lower_unit_strict [simp]: "{\<bottom>}\<flat> = \<bottom>"
245.232 -using lower_unit_Rep_compact_basis [of compact_bot]
245.233 -by (simp add: inst_lower_pd_pcpo)
245.234 -
245.235 -lemma lower_unit_bottom_iff [simp]: "{x}\<flat> = \<bottom> \<longleftrightarrow> x = \<bottom>"
245.236 -unfolding lower_unit_strict [symmetric] by (rule lower_unit_eq_iff)
245.237 -
245.238 -lemma lower_plus_bottom_iff [simp]:
245.239 - "xs +\<flat> ys = \<bottom> \<longleftrightarrow> xs = \<bottom> \<and> ys = \<bottom>"
245.240 -apply safe
245.241 -apply (rule UU_I, erule subst, rule lower_plus_below1)
245.242 -apply (rule UU_I, erule subst, rule lower_plus_below2)
245.243 -apply (rule lower_plus_absorb)
245.244 -done
245.245 -
245.246 -lemma lower_plus_strict1 [simp]: "\<bottom> +\<flat> ys = ys"
245.247 -apply (rule below_antisym [OF _ lower_plus_below2])
245.248 -apply (simp add: lower_plus_least)
245.249 -done
245.250 -
245.251 -lemma lower_plus_strict2 [simp]: "xs +\<flat> \<bottom> = xs"
245.252 -apply (rule below_antisym [OF _ lower_plus_below1])
245.253 -apply (simp add: lower_plus_least)
245.254 -done
245.255 -
245.256 -lemma compact_lower_unit: "compact x \<Longrightarrow> compact {x}\<flat>"
245.257 -by (auto dest!: compact_basis.compact_imp_principal)
245.258 -
245.259 -lemma compact_lower_unit_iff [simp]: "compact {x}\<flat> \<longleftrightarrow> compact x"
245.260 -apply (safe elim!: compact_lower_unit)
245.261 -apply (simp only: compact_def lower_unit_below_iff [symmetric])
245.262 -apply (erule adm_subst [OF cont_Rep_cfun2])
245.263 -done
245.264 -
245.265 -lemma compact_lower_plus [simp]:
245.266 - "\<lbrakk>compact xs; compact ys\<rbrakk> \<Longrightarrow> compact (xs +\<flat> ys)"
245.267 -by (auto dest!: lower_pd.compact_imp_principal)
245.268 -
245.269 -
245.270 -subsection {* Induction rules *}
245.271 -
245.272 -lemma lower_pd_induct1:
245.273 - assumes P: "adm P"
245.274 - assumes unit: "\<And>x. P {x}\<flat>"
245.275 - assumes insert:
245.276 - "\<And>x ys. \<lbrakk>P {x}\<flat>; P ys\<rbrakk> \<Longrightarrow> P ({x}\<flat> +\<flat> ys)"
245.277 - shows "P (xs::'a lower_pd)"
245.278 -apply (induct xs rule: lower_pd.principal_induct, rule P)
245.279 -apply (induct_tac a rule: pd_basis_induct1)
245.280 -apply (simp only: lower_unit_Rep_compact_basis [symmetric])
245.281 -apply (rule unit)
245.282 -apply (simp only: lower_unit_Rep_compact_basis [symmetric]
245.283 - lower_plus_principal [symmetric])
245.284 -apply (erule insert [OF unit])
245.285 -done
245.286 -
245.287 -lemma lower_pd_induct
245.288 - [case_names adm lower_unit lower_plus, induct type: lower_pd]:
245.289 - assumes P: "adm P"
245.290 - assumes unit: "\<And>x. P {x}\<flat>"
245.291 - assumes plus: "\<And>xs ys. \<lbrakk>P xs; P ys\<rbrakk> \<Longrightarrow> P (xs +\<flat> ys)"
245.292 - shows "P (xs::'a lower_pd)"
245.293 -apply (induct xs rule: lower_pd.principal_induct, rule P)
245.294 -apply (induct_tac a rule: pd_basis_induct)
245.295 -apply (simp only: lower_unit_Rep_compact_basis [symmetric] unit)
245.296 -apply (simp only: lower_plus_principal [symmetric] plus)
245.297 -done
245.298 -
245.299 -
245.300 -subsection {* Monadic bind *}
245.301 -
245.302 -definition
245.303 - lower_bind_basis ::
245.304 - "'a pd_basis \<Rightarrow> ('a \<rightarrow> 'b lower_pd) \<rightarrow> 'b lower_pd" where
245.305 - "lower_bind_basis = fold_pd
245.306 - (\<lambda>a. \<Lambda> f. f\<cdot>(Rep_compact_basis a))
245.307 - (\<lambda>x y. \<Lambda> f. x\<cdot>f +\<flat> y\<cdot>f)"
245.308 -
245.309 -lemma ACI_lower_bind:
245.310 - "class.ab_semigroup_idem_mult (\<lambda>x y. \<Lambda> f. x\<cdot>f +\<flat> y\<cdot>f)"
245.311 -apply unfold_locales
245.312 -apply (simp add: lower_plus_assoc)
245.313 -apply (simp add: lower_plus_commute)
245.314 -apply (simp add: eta_cfun)
245.315 -done
245.316 -
245.317 -lemma lower_bind_basis_simps [simp]:
245.318 - "lower_bind_basis (PDUnit a) =
245.319 - (\<Lambda> f. f\<cdot>(Rep_compact_basis a))"
245.320 - "lower_bind_basis (PDPlus t u) =
245.321 - (\<Lambda> f. lower_bind_basis t\<cdot>f +\<flat> lower_bind_basis u\<cdot>f)"
245.322 -unfolding lower_bind_basis_def
245.323 -apply -
245.324 -apply (rule fold_pd_PDUnit [OF ACI_lower_bind])
245.325 -apply (rule fold_pd_PDPlus [OF ACI_lower_bind])
245.326 -done
245.327 -
245.328 -lemma lower_bind_basis_mono:
245.329 - "t \<le>\<flat> u \<Longrightarrow> lower_bind_basis t \<sqsubseteq> lower_bind_basis u"
245.330 -unfolding cfun_below_iff
245.331 -apply (erule lower_le_induct, safe)
245.332 -apply (simp add: monofun_cfun)
245.333 -apply (simp add: rev_below_trans [OF lower_plus_below1])
245.334 -apply simp
245.335 -done
245.336 -
245.337 -definition
245.338 - lower_bind :: "'a lower_pd \<rightarrow> ('a \<rightarrow> 'b lower_pd) \<rightarrow> 'b lower_pd" where
245.339 - "lower_bind = lower_pd.basis_fun lower_bind_basis"
245.340 -
245.341 -lemma lower_bind_principal [simp]:
245.342 - "lower_bind\<cdot>(lower_principal t) = lower_bind_basis t"
245.343 -unfolding lower_bind_def
245.344 -apply (rule lower_pd.basis_fun_principal)
245.345 -apply (erule lower_bind_basis_mono)
245.346 -done
245.347 -
245.348 -lemma lower_bind_unit [simp]:
245.349 - "lower_bind\<cdot>{x}\<flat>\<cdot>f = f\<cdot>x"
245.350 -by (induct x rule: compact_basis.principal_induct, simp, simp)
245.351 -
245.352 -lemma lower_bind_plus [simp]:
245.353 - "lower_bind\<cdot>(xs +\<flat> ys)\<cdot>f = lower_bind\<cdot>xs\<cdot>f +\<flat> lower_bind\<cdot>ys\<cdot>f"
245.354 -by (induct xs ys rule: lower_pd.principal_induct2, simp, simp, simp)
245.355 -
245.356 -lemma lower_bind_strict [simp]: "lower_bind\<cdot>\<bottom>\<cdot>f = f\<cdot>\<bottom>"
245.357 -unfolding lower_unit_strict [symmetric] by (rule lower_bind_unit)
245.358 -
245.359 -lemma lower_bind_bind:
245.360 - "lower_bind\<cdot>(lower_bind\<cdot>xs\<cdot>f)\<cdot>g = lower_bind\<cdot>xs\<cdot>(\<Lambda> x. lower_bind\<cdot>(f\<cdot>x)\<cdot>g)"
245.361 -by (induct xs, simp_all)
245.362 -
245.363 -
245.364 -subsection {* Map *}
245.365 -
245.366 -definition
245.367 - lower_map :: "('a \<rightarrow> 'b) \<rightarrow> 'a lower_pd \<rightarrow> 'b lower_pd" where
245.368 - "lower_map = (\<Lambda> f xs. lower_bind\<cdot>xs\<cdot>(\<Lambda> x. {f\<cdot>x}\<flat>))"
245.369 -
245.370 -lemma lower_map_unit [simp]:
245.371 - "lower_map\<cdot>f\<cdot>{x}\<flat> = {f\<cdot>x}\<flat>"
245.372 -unfolding lower_map_def by simp
245.373 -
245.374 -lemma lower_map_plus [simp]:
245.375 - "lower_map\<cdot>f\<cdot>(xs +\<flat> ys) = lower_map\<cdot>f\<cdot>xs +\<flat> lower_map\<cdot>f\<cdot>ys"
245.376 -unfolding lower_map_def by simp
245.377 -
245.378 -lemma lower_map_bottom [simp]: "lower_map\<cdot>f\<cdot>\<bottom> = {f\<cdot>\<bottom>}\<flat>"
245.379 -unfolding lower_map_def by simp
245.380 -
245.381 -lemma lower_map_ident: "lower_map\<cdot>(\<Lambda> x. x)\<cdot>xs = xs"
245.382 -by (induct xs rule: lower_pd_induct, simp_all)
245.383 -
245.384 -lemma lower_map_ID: "lower_map\<cdot>ID = ID"
245.385 -by (simp add: cfun_eq_iff ID_def lower_map_ident)
245.386 -
245.387 -lemma lower_map_map:
245.388 - "lower_map\<cdot>f\<cdot>(lower_map\<cdot>g\<cdot>xs) = lower_map\<cdot>(\<Lambda> x. f\<cdot>(g\<cdot>x))\<cdot>xs"
245.389 -by (induct xs rule: lower_pd_induct, simp_all)
245.390 -
245.391 -lemma ep_pair_lower_map: "ep_pair e p \<Longrightarrow> ep_pair (lower_map\<cdot>e) (lower_map\<cdot>p)"
245.392 -apply default
245.393 -apply (induct_tac x rule: lower_pd_induct, simp_all add: ep_pair.e_inverse)
245.394 -apply (induct_tac y rule: lower_pd_induct)
245.395 -apply (simp_all add: ep_pair.e_p_below monofun_cfun del: lower_plus_below_iff)
245.396 -done
245.397 -
245.398 -lemma deflation_lower_map: "deflation d \<Longrightarrow> deflation (lower_map\<cdot>d)"
245.399 -apply default
245.400 -apply (induct_tac x rule: lower_pd_induct, simp_all add: deflation.idem)
245.401 -apply (induct_tac x rule: lower_pd_induct)
245.402 -apply (simp_all add: deflation.below monofun_cfun del: lower_plus_below_iff)
245.403 -done
245.404 -
245.405 -(* FIXME: long proof! *)
245.406 -lemma finite_deflation_lower_map:
245.407 - assumes "finite_deflation d" shows "finite_deflation (lower_map\<cdot>d)"
245.408 -proof (rule finite_deflation_intro)
245.409 - interpret d: finite_deflation d by fact
245.410 - have "deflation d" by fact
245.411 - thus "deflation (lower_map\<cdot>d)" by (rule deflation_lower_map)
245.412 - have "finite (range (\<lambda>x. d\<cdot>x))" by (rule d.finite_range)
245.413 - hence "finite (Rep_compact_basis -` range (\<lambda>x. d\<cdot>x))"
245.414 - by (rule finite_vimageI, simp add: inj_on_def Rep_compact_basis_inject)
245.415 - hence "finite (Pow (Rep_compact_basis -` range (\<lambda>x. d\<cdot>x)))" by simp
245.416 - hence "finite (Rep_pd_basis -` (Pow (Rep_compact_basis -` range (\<lambda>x. d\<cdot>x))))"
245.417 - by (rule finite_vimageI, simp add: inj_on_def Rep_pd_basis_inject)
245.418 - hence *: "finite (lower_principal ` Rep_pd_basis -` (Pow (Rep_compact_basis -` range (\<lambda>x. d\<cdot>x))))" by simp
245.419 - hence "finite (range (\<lambda>xs. lower_map\<cdot>d\<cdot>xs))"
245.420 - apply (rule rev_finite_subset)
245.421 - apply clarsimp
245.422 - apply (induct_tac xs rule: lower_pd.principal_induct)
245.423 - apply (simp add: adm_mem_finite *)
245.424 - apply (rename_tac t, induct_tac t rule: pd_basis_induct)
245.425 - apply (simp only: lower_unit_Rep_compact_basis [symmetric] lower_map_unit)
245.426 - apply simp
245.427 - apply (subgoal_tac "\<exists>b. d\<cdot>(Rep_compact_basis a) = Rep_compact_basis b")
245.428 - apply clarsimp
245.429 - apply (rule imageI)
245.430 - apply (rule vimageI2)
245.431 - apply (simp add: Rep_PDUnit)
245.432 - apply (rule range_eqI)
245.433 - apply (erule sym)
245.434 - apply (rule exI)
245.435 - apply (rule Abs_compact_basis_inverse [symmetric])
245.436 - apply (simp add: d.compact)
245.437 - apply (simp only: lower_plus_principal [symmetric] lower_map_plus)
245.438 - apply clarsimp
245.439 - apply (rule imageI)
245.440 - apply (rule vimageI2)
245.441 - apply (simp add: Rep_PDPlus)
245.442 - done
245.443 - thus "finite {xs. lower_map\<cdot>d\<cdot>xs = xs}"
245.444 - by (rule finite_range_imp_finite_fixes)
245.445 -qed
245.446 -
245.447 -subsection {* Lower powerdomain is a domain *}
245.448 -
245.449 -definition
245.450 - lower_approx :: "nat \<Rightarrow> udom lower_pd \<rightarrow> udom lower_pd"
245.451 -where
245.452 - "lower_approx = (\<lambda>i. lower_map\<cdot>(udom_approx i))"
245.453 -
245.454 -lemma lower_approx: "approx_chain lower_approx"
245.455 -using lower_map_ID finite_deflation_lower_map
245.456 -unfolding lower_approx_def by (rule approx_chain_lemma1)
245.457 -
245.458 -definition lower_defl :: "defl \<rightarrow> defl"
245.459 -where "lower_defl = defl_fun1 lower_approx lower_map"
245.460 -
245.461 -lemma cast_lower_defl:
245.462 - "cast\<cdot>(lower_defl\<cdot>A) =
245.463 - udom_emb lower_approx oo lower_map\<cdot>(cast\<cdot>A) oo udom_prj lower_approx"
245.464 -using lower_approx finite_deflation_lower_map
245.465 -unfolding lower_defl_def by (rule cast_defl_fun1)
245.466 -
245.467 -instantiation lower_pd :: ("domain") liftdomain
245.468 -begin
245.469 -
245.470 -definition
245.471 - "emb = udom_emb lower_approx oo lower_map\<cdot>emb"
245.472 -
245.473 -definition
245.474 - "prj = lower_map\<cdot>prj oo udom_prj lower_approx"
245.475 -
245.476 -definition
245.477 - "defl (t::'a lower_pd itself) = lower_defl\<cdot>DEFL('a)"
245.478 -
245.479 -definition
245.480 - "(liftemb :: 'a lower_pd u \<rightarrow> udom) = udom_emb u_approx oo u_map\<cdot>emb"
245.481 -
245.482 -definition
245.483 - "(liftprj :: udom \<rightarrow> 'a lower_pd u) = u_map\<cdot>prj oo udom_prj u_approx"
245.484 -
245.485 -definition
245.486 - "liftdefl (t::'a lower_pd itself) = u_defl\<cdot>DEFL('a lower_pd)"
245.487 -
245.488 -instance
245.489 -using liftemb_lower_pd_def liftprj_lower_pd_def liftdefl_lower_pd_def
245.490 -proof (rule liftdomain_class_intro)
245.491 - show "ep_pair emb (prj :: udom \<rightarrow> 'a lower_pd)"
245.492 - unfolding emb_lower_pd_def prj_lower_pd_def
245.493 - using ep_pair_udom [OF lower_approx]
245.494 - by (intro ep_pair_comp ep_pair_lower_map ep_pair_emb_prj)
245.495 -next
245.496 - show "cast\<cdot>DEFL('a lower_pd) = emb oo (prj :: udom \<rightarrow> 'a lower_pd)"
245.497 - unfolding emb_lower_pd_def prj_lower_pd_def defl_lower_pd_def cast_lower_defl
245.498 - by (simp add: cast_DEFL oo_def cfun_eq_iff lower_map_map)
245.499 -qed
245.500 -
245.501 -end
245.502 -
245.503 -lemma DEFL_lower: "DEFL('a lower_pd) = lower_defl\<cdot>DEFL('a)"
245.504 -by (rule defl_lower_pd_def)
245.505 -
245.506 -
245.507 -subsection {* Join *}
245.508 -
245.509 -definition
245.510 - lower_join :: "'a lower_pd lower_pd \<rightarrow> 'a lower_pd" where
245.511 - "lower_join = (\<Lambda> xss. lower_bind\<cdot>xss\<cdot>(\<Lambda> xs. xs))"
245.512 -
245.513 -lemma lower_join_unit [simp]:
245.514 - "lower_join\<cdot>{xs}\<flat> = xs"
245.515 -unfolding lower_join_def by simp
245.516 -
245.517 -lemma lower_join_plus [simp]:
245.518 - "lower_join\<cdot>(xss +\<flat> yss) = lower_join\<cdot>xss +\<flat> lower_join\<cdot>yss"
245.519 -unfolding lower_join_def by simp
245.520 -
245.521 -lemma lower_join_bottom [simp]: "lower_join\<cdot>\<bottom> = \<bottom>"
245.522 -unfolding lower_join_def by simp
245.523 -
245.524 -lemma lower_join_map_unit:
245.525 - "lower_join\<cdot>(lower_map\<cdot>lower_unit\<cdot>xs) = xs"
245.526 -by (induct xs rule: lower_pd_induct, simp_all)
245.527 -
245.528 -lemma lower_join_map_join:
245.529 - "lower_join\<cdot>(lower_map\<cdot>lower_join\<cdot>xsss) = lower_join\<cdot>(lower_join\<cdot>xsss)"
245.530 -by (induct xsss rule: lower_pd_induct, simp_all)
245.531 -
245.532 -lemma lower_join_map_map:
245.533 - "lower_join\<cdot>(lower_map\<cdot>(lower_map\<cdot>f)\<cdot>xss) =
245.534 - lower_map\<cdot>f\<cdot>(lower_join\<cdot>xss)"
245.535 -by (induct xss rule: lower_pd_induct, simp_all)
245.536 -
245.537 -end
246.1 --- a/src/HOLCF/Map_Functions.thy Sat Nov 27 14:34:54 2010 -0800
246.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
246.3 @@ -1,464 +0,0 @@
246.4 -(* Title: HOLCF/Map_Functions.thy
246.5 - Author: Brian Huffman
246.6 -*)
246.7 -
246.8 -header {* Map functions for various types *}
246.9 -
246.10 -theory Map_Functions
246.11 -imports Deflation
246.12 -begin
246.13 -
246.14 -subsection {* Map operator for continuous function space *}
246.15 -
246.16 -default_sort cpo
246.17 -
246.18 -definition
246.19 - cfun_map :: "('b \<rightarrow> 'a) \<rightarrow> ('c \<rightarrow> 'd) \<rightarrow> ('a \<rightarrow> 'c) \<rightarrow> ('b \<rightarrow> 'd)"
246.20 -where
246.21 - "cfun_map = (\<Lambda> a b f x. b\<cdot>(f\<cdot>(a\<cdot>x)))"
246.22 -
246.23 -lemma cfun_map_beta [simp]: "cfun_map\<cdot>a\<cdot>b\<cdot>f\<cdot>x = b\<cdot>(f\<cdot>(a\<cdot>x))"
246.24 -unfolding cfun_map_def by simp
246.25 -
246.26 -lemma cfun_map_ID: "cfun_map\<cdot>ID\<cdot>ID = ID"
246.27 -unfolding cfun_eq_iff by simp
246.28 -
246.29 -lemma cfun_map_map:
246.30 - "cfun_map\<cdot>f1\<cdot>g1\<cdot>(cfun_map\<cdot>f2\<cdot>g2\<cdot>p) =
246.31 - cfun_map\<cdot>(\<Lambda> x. f2\<cdot>(f1\<cdot>x))\<cdot>(\<Lambda> x. g1\<cdot>(g2\<cdot>x))\<cdot>p"
246.32 -by (rule cfun_eqI) simp
246.33 -
246.34 -lemma ep_pair_cfun_map:
246.35 - assumes "ep_pair e1 p1" and "ep_pair e2 p2"
246.36 - shows "ep_pair (cfun_map\<cdot>p1\<cdot>e2) (cfun_map\<cdot>e1\<cdot>p2)"
246.37 -proof
246.38 - interpret e1p1: ep_pair e1 p1 by fact
246.39 - interpret e2p2: ep_pair e2 p2 by fact
246.40 - fix f show "cfun_map\<cdot>e1\<cdot>p2\<cdot>(cfun_map\<cdot>p1\<cdot>e2\<cdot>f) = f"
246.41 - by (simp add: cfun_eq_iff)
246.42 - fix g show "cfun_map\<cdot>p1\<cdot>e2\<cdot>(cfun_map\<cdot>e1\<cdot>p2\<cdot>g) \<sqsubseteq> g"
246.43 - apply (rule cfun_belowI, simp)
246.44 - apply (rule below_trans [OF e2p2.e_p_below])
246.45 - apply (rule monofun_cfun_arg)
246.46 - apply (rule e1p1.e_p_below)
246.47 - done
246.48 -qed
246.49 -
246.50 -lemma deflation_cfun_map:
246.51 - assumes "deflation d1" and "deflation d2"
246.52 - shows "deflation (cfun_map\<cdot>d1\<cdot>d2)"
246.53 -proof
246.54 - interpret d1: deflation d1 by fact
246.55 - interpret d2: deflation d2 by fact
246.56 - fix f
246.57 - show "cfun_map\<cdot>d1\<cdot>d2\<cdot>(cfun_map\<cdot>d1\<cdot>d2\<cdot>f) = cfun_map\<cdot>d1\<cdot>d2\<cdot>f"
246.58 - by (simp add: cfun_eq_iff d1.idem d2.idem)
246.59 - show "cfun_map\<cdot>d1\<cdot>d2\<cdot>f \<sqsubseteq> f"
246.60 - apply (rule cfun_belowI, simp)
246.61 - apply (rule below_trans [OF d2.below])
246.62 - apply (rule monofun_cfun_arg)
246.63 - apply (rule d1.below)
246.64 - done
246.65 -qed
246.66 -
246.67 -lemma finite_range_cfun_map:
246.68 - assumes a: "finite (range (\<lambda>x. a\<cdot>x))"
246.69 - assumes b: "finite (range (\<lambda>y. b\<cdot>y))"
246.70 - shows "finite (range (\<lambda>f. cfun_map\<cdot>a\<cdot>b\<cdot>f))" (is "finite (range ?h)")
246.71 -proof (rule finite_imageD)
246.72 - let ?f = "\<lambda>g. range (\<lambda>x. (a\<cdot>x, g\<cdot>x))"
246.73 - show "finite (?f ` range ?h)"
246.74 - proof (rule finite_subset)
246.75 - let ?B = "Pow (range (\<lambda>x. a\<cdot>x) \<times> range (\<lambda>y. b\<cdot>y))"
246.76 - show "?f ` range ?h \<subseteq> ?B"
246.77 - by clarsimp
246.78 - show "finite ?B"
246.79 - by (simp add: a b)
246.80 - qed
246.81 - show "inj_on ?f (range ?h)"
246.82 - proof (rule inj_onI, rule cfun_eqI, clarsimp)
246.83 - fix x f g
246.84 - assume "range (\<lambda>x. (a\<cdot>x, b\<cdot>(f\<cdot>(a\<cdot>x)))) = range (\<lambda>x. (a\<cdot>x, b\<cdot>(g\<cdot>(a\<cdot>x))))"
246.85 - hence "range (\<lambda>x. (a\<cdot>x, b\<cdot>(f\<cdot>(a\<cdot>x)))) \<subseteq> range (\<lambda>x. (a\<cdot>x, b\<cdot>(g\<cdot>(a\<cdot>x))))"
246.86 - by (rule equalityD1)
246.87 - hence "(a\<cdot>x, b\<cdot>(f\<cdot>(a\<cdot>x))) \<in> range (\<lambda>x. (a\<cdot>x, b\<cdot>(g\<cdot>(a\<cdot>x))))"
246.88 - by (simp add: subset_eq)
246.89 - then obtain y where "(a\<cdot>x, b\<cdot>(f\<cdot>(a\<cdot>x))) = (a\<cdot>y, b\<cdot>(g\<cdot>(a\<cdot>y)))"
246.90 - by (rule rangeE)
246.91 - thus "b\<cdot>(f\<cdot>(a\<cdot>x)) = b\<cdot>(g\<cdot>(a\<cdot>x))"
246.92 - by clarsimp
246.93 - qed
246.94 -qed
246.95 -
246.96 -lemma finite_deflation_cfun_map:
246.97 - assumes "finite_deflation d1" and "finite_deflation d2"
246.98 - shows "finite_deflation (cfun_map\<cdot>d1\<cdot>d2)"
246.99 -proof (rule finite_deflation_intro)
246.100 - interpret d1: finite_deflation d1 by fact
246.101 - interpret d2: finite_deflation d2 by fact
246.102 - have "deflation d1" and "deflation d2" by fact+
246.103 - thus "deflation (cfun_map\<cdot>d1\<cdot>d2)" by (rule deflation_cfun_map)
246.104 - have "finite (range (\<lambda>f. cfun_map\<cdot>d1\<cdot>d2\<cdot>f))"
246.105 - using d1.finite_range d2.finite_range
246.106 - by (rule finite_range_cfun_map)
246.107 - thus "finite {f. cfun_map\<cdot>d1\<cdot>d2\<cdot>f = f}"
246.108 - by (rule finite_range_imp_finite_fixes)
246.109 -qed
246.110 -
246.111 -text {* Finite deflations are compact elements of the function space *}
246.112 -
246.113 -lemma finite_deflation_imp_compact: "finite_deflation d \<Longrightarrow> compact d"
246.114 -apply (frule finite_deflation_imp_deflation)
246.115 -apply (subgoal_tac "compact (cfun_map\<cdot>d\<cdot>d\<cdot>d)")
246.116 -apply (simp add: cfun_map_def deflation.idem eta_cfun)
246.117 -apply (rule finite_deflation.compact)
246.118 -apply (simp only: finite_deflation_cfun_map)
246.119 -done
246.120 -
246.121 -subsection {* Map operator for product type *}
246.122 -
246.123 -definition
246.124 - cprod_map :: "('a \<rightarrow> 'b) \<rightarrow> ('c \<rightarrow> 'd) \<rightarrow> 'a \<times> 'c \<rightarrow> 'b \<times> 'd"
246.125 -where
246.126 - "cprod_map = (\<Lambda> f g p. (f\<cdot>(fst p), g\<cdot>(snd p)))"
246.127 -
246.128 -lemma cprod_map_Pair [simp]: "cprod_map\<cdot>f\<cdot>g\<cdot>(x, y) = (f\<cdot>x, g\<cdot>y)"
246.129 -unfolding cprod_map_def by simp
246.130 -
246.131 -lemma cprod_map_ID: "cprod_map\<cdot>ID\<cdot>ID = ID"
246.132 -unfolding cfun_eq_iff by auto
246.133 -
246.134 -lemma cprod_map_map:
246.135 - "cprod_map\<cdot>f1\<cdot>g1\<cdot>(cprod_map\<cdot>f2\<cdot>g2\<cdot>p) =
246.136 - cprod_map\<cdot>(\<Lambda> x. f1\<cdot>(f2\<cdot>x))\<cdot>(\<Lambda> x. g1\<cdot>(g2\<cdot>x))\<cdot>p"
246.137 -by (induct p) simp
246.138 -
246.139 -lemma ep_pair_cprod_map:
246.140 - assumes "ep_pair e1 p1" and "ep_pair e2 p2"
246.141 - shows "ep_pair (cprod_map\<cdot>e1\<cdot>e2) (cprod_map\<cdot>p1\<cdot>p2)"
246.142 -proof
246.143 - interpret e1p1: ep_pair e1 p1 by fact
246.144 - interpret e2p2: ep_pair e2 p2 by fact
246.145 - fix x show "cprod_map\<cdot>p1\<cdot>p2\<cdot>(cprod_map\<cdot>e1\<cdot>e2\<cdot>x) = x"
246.146 - by (induct x) simp
246.147 - fix y show "cprod_map\<cdot>e1\<cdot>e2\<cdot>(cprod_map\<cdot>p1\<cdot>p2\<cdot>y) \<sqsubseteq> y"
246.148 - by (induct y) (simp add: e1p1.e_p_below e2p2.e_p_below)
246.149 -qed
246.150 -
246.151 -lemma deflation_cprod_map:
246.152 - assumes "deflation d1" and "deflation d2"
246.153 - shows "deflation (cprod_map\<cdot>d1\<cdot>d2)"
246.154 -proof
246.155 - interpret d1: deflation d1 by fact
246.156 - interpret d2: deflation d2 by fact
246.157 - fix x
246.158 - show "cprod_map\<cdot>d1\<cdot>d2\<cdot>(cprod_map\<cdot>d1\<cdot>d2\<cdot>x) = cprod_map\<cdot>d1\<cdot>d2\<cdot>x"
246.159 - by (induct x) (simp add: d1.idem d2.idem)
246.160 - show "cprod_map\<cdot>d1\<cdot>d2\<cdot>x \<sqsubseteq> x"
246.161 - by (induct x) (simp add: d1.below d2.below)
246.162 -qed
246.163 -
246.164 -lemma finite_deflation_cprod_map:
246.165 - assumes "finite_deflation d1" and "finite_deflation d2"
246.166 - shows "finite_deflation (cprod_map\<cdot>d1\<cdot>d2)"
246.167 -proof (rule finite_deflation_intro)
246.168 - interpret d1: finite_deflation d1 by fact
246.169 - interpret d2: finite_deflation d2 by fact
246.170 - have "deflation d1" and "deflation d2" by fact+
246.171 - thus "deflation (cprod_map\<cdot>d1\<cdot>d2)" by (rule deflation_cprod_map)
246.172 - have "{p. cprod_map\<cdot>d1\<cdot>d2\<cdot>p = p} \<subseteq> {x. d1\<cdot>x = x} \<times> {y. d2\<cdot>y = y}"
246.173 - by clarsimp
246.174 - thus "finite {p. cprod_map\<cdot>d1\<cdot>d2\<cdot>p = p}"
246.175 - by (rule finite_subset, simp add: d1.finite_fixes d2.finite_fixes)
246.176 -qed
246.177 -
246.178 -subsection {* Map function for lifted cpo *}
246.179 -
246.180 -definition
246.181 - u_map :: "('a \<rightarrow> 'b) \<rightarrow> 'a u \<rightarrow> 'b u"
246.182 -where
246.183 - "u_map = (\<Lambda> f. fup\<cdot>(up oo f))"
246.184 -
246.185 -lemma u_map_strict [simp]: "u_map\<cdot>f\<cdot>\<bottom> = \<bottom>"
246.186 -unfolding u_map_def by simp
246.187 -
246.188 -lemma u_map_up [simp]: "u_map\<cdot>f\<cdot>(up\<cdot>x) = up\<cdot>(f\<cdot>x)"
246.189 -unfolding u_map_def by simp
246.190 -
246.191 -lemma u_map_ID: "u_map\<cdot>ID = ID"
246.192 -unfolding u_map_def by (simp add: cfun_eq_iff eta_cfun)
246.193 -
246.194 -lemma u_map_map: "u_map\<cdot>f\<cdot>(u_map\<cdot>g\<cdot>p) = u_map\<cdot>(\<Lambda> x. f\<cdot>(g\<cdot>x))\<cdot>p"
246.195 -by (induct p) simp_all
246.196 -
246.197 -lemma ep_pair_u_map: "ep_pair e p \<Longrightarrow> ep_pair (u_map\<cdot>e) (u_map\<cdot>p)"
246.198 -apply default
246.199 -apply (case_tac x, simp, simp add: ep_pair.e_inverse)
246.200 -apply (case_tac y, simp, simp add: ep_pair.e_p_below)
246.201 -done
246.202 -
246.203 -lemma deflation_u_map: "deflation d \<Longrightarrow> deflation (u_map\<cdot>d)"
246.204 -apply default
246.205 -apply (case_tac x, simp, simp add: deflation.idem)
246.206 -apply (case_tac x, simp, simp add: deflation.below)
246.207 -done
246.208 -
246.209 -lemma finite_deflation_u_map:
246.210 - assumes "finite_deflation d" shows "finite_deflation (u_map\<cdot>d)"
246.211 -proof (rule finite_deflation_intro)
246.212 - interpret d: finite_deflation d by fact
246.213 - have "deflation d" by fact
246.214 - thus "deflation (u_map\<cdot>d)" by (rule deflation_u_map)
246.215 - have "{x. u_map\<cdot>d\<cdot>x = x} \<subseteq> insert \<bottom> ((\<lambda>x. up\<cdot>x) ` {x. d\<cdot>x = x})"
246.216 - by (rule subsetI, case_tac x, simp_all)
246.217 - thus "finite {x. u_map\<cdot>d\<cdot>x = x}"
246.218 - by (rule finite_subset, simp add: d.finite_fixes)
246.219 -qed
246.220 -
246.221 -subsection {* Map function for strict products *}
246.222 -
246.223 -default_sort pcpo
246.224 -
246.225 -definition
246.226 - sprod_map :: "('a \<rightarrow> 'b) \<rightarrow> ('c \<rightarrow> 'd) \<rightarrow> 'a \<otimes> 'c \<rightarrow> 'b \<otimes> 'd"
246.227 -where
246.228 - "sprod_map = (\<Lambda> f g. ssplit\<cdot>(\<Lambda> x y. (:f\<cdot>x, g\<cdot>y:)))"
246.229 -
246.230 -lemma sprod_map_strict [simp]: "sprod_map\<cdot>a\<cdot>b\<cdot>\<bottom> = \<bottom>"
246.231 -unfolding sprod_map_def by simp
246.232 -
246.233 -lemma sprod_map_spair [simp]:
246.234 - "x \<noteq> \<bottom> \<Longrightarrow> y \<noteq> \<bottom> \<Longrightarrow> sprod_map\<cdot>f\<cdot>g\<cdot>(:x, y:) = (:f\<cdot>x, g\<cdot>y:)"
246.235 -by (simp add: sprod_map_def)
246.236 -
246.237 -lemma sprod_map_spair':
246.238 - "f\<cdot>\<bottom> = \<bottom> \<Longrightarrow> g\<cdot>\<bottom> = \<bottom> \<Longrightarrow> sprod_map\<cdot>f\<cdot>g\<cdot>(:x, y:) = (:f\<cdot>x, g\<cdot>y:)"
246.239 -by (cases "x = \<bottom> \<or> y = \<bottom>") auto
246.240 -
246.241 -lemma sprod_map_ID: "sprod_map\<cdot>ID\<cdot>ID = ID"
246.242 -unfolding sprod_map_def by (simp add: cfun_eq_iff eta_cfun)
246.243 -
246.244 -lemma sprod_map_map:
246.245 - "\<lbrakk>f1\<cdot>\<bottom> = \<bottom>; g1\<cdot>\<bottom> = \<bottom>\<rbrakk> \<Longrightarrow>
246.246 - sprod_map\<cdot>f1\<cdot>g1\<cdot>(sprod_map\<cdot>f2\<cdot>g2\<cdot>p) =
246.247 - sprod_map\<cdot>(\<Lambda> x. f1\<cdot>(f2\<cdot>x))\<cdot>(\<Lambda> x. g1\<cdot>(g2\<cdot>x))\<cdot>p"
246.248 -apply (induct p, simp)
246.249 -apply (case_tac "f2\<cdot>x = \<bottom>", simp)
246.250 -apply (case_tac "g2\<cdot>y = \<bottom>", simp)
246.251 -apply simp
246.252 -done
246.253 -
246.254 -lemma ep_pair_sprod_map:
246.255 - assumes "ep_pair e1 p1" and "ep_pair e2 p2"
246.256 - shows "ep_pair (sprod_map\<cdot>e1\<cdot>e2) (sprod_map\<cdot>p1\<cdot>p2)"
246.257 -proof
246.258 - interpret e1p1: pcpo_ep_pair e1 p1 unfolding pcpo_ep_pair_def by fact
246.259 - interpret e2p2: pcpo_ep_pair e2 p2 unfolding pcpo_ep_pair_def by fact
246.260 - fix x show "sprod_map\<cdot>p1\<cdot>p2\<cdot>(sprod_map\<cdot>e1\<cdot>e2\<cdot>x) = x"
246.261 - by (induct x) simp_all
246.262 - fix y show "sprod_map\<cdot>e1\<cdot>e2\<cdot>(sprod_map\<cdot>p1\<cdot>p2\<cdot>y) \<sqsubseteq> y"
246.263 - apply (induct y, simp)
246.264 - apply (case_tac "p1\<cdot>x = \<bottom>", simp, case_tac "p2\<cdot>y = \<bottom>", simp)
246.265 - apply (simp add: monofun_cfun e1p1.e_p_below e2p2.e_p_below)
246.266 - done
246.267 -qed
246.268 -
246.269 -lemma deflation_sprod_map:
246.270 - assumes "deflation d1" and "deflation d2"
246.271 - shows "deflation (sprod_map\<cdot>d1\<cdot>d2)"
246.272 -proof
246.273 - interpret d1: deflation d1 by fact
246.274 - interpret d2: deflation d2 by fact
246.275 - fix x
246.276 - show "sprod_map\<cdot>d1\<cdot>d2\<cdot>(sprod_map\<cdot>d1\<cdot>d2\<cdot>x) = sprod_map\<cdot>d1\<cdot>d2\<cdot>x"
246.277 - apply (induct x, simp)
246.278 - apply (case_tac "d1\<cdot>x = \<bottom>", simp, case_tac "d2\<cdot>y = \<bottom>", simp)
246.279 - apply (simp add: d1.idem d2.idem)
246.280 - done
246.281 - show "sprod_map\<cdot>d1\<cdot>d2\<cdot>x \<sqsubseteq> x"
246.282 - apply (induct x, simp)
246.283 - apply (simp add: monofun_cfun d1.below d2.below)
246.284 - done
246.285 -qed
246.286 -
246.287 -lemma finite_deflation_sprod_map:
246.288 - assumes "finite_deflation d1" and "finite_deflation d2"
246.289 - shows "finite_deflation (sprod_map\<cdot>d1\<cdot>d2)"
246.290 -proof (rule finite_deflation_intro)
246.291 - interpret d1: finite_deflation d1 by fact
246.292 - interpret d2: finite_deflation d2 by fact
246.293 - have "deflation d1" and "deflation d2" by fact+
246.294 - thus "deflation (sprod_map\<cdot>d1\<cdot>d2)" by (rule deflation_sprod_map)
246.295 - have "{x. sprod_map\<cdot>d1\<cdot>d2\<cdot>x = x} \<subseteq> insert \<bottom>
246.296 - ((\<lambda>(x, y). (:x, y:)) ` ({x. d1\<cdot>x = x} \<times> {y. d2\<cdot>y = y}))"
246.297 - by (rule subsetI, case_tac x, auto simp add: spair_eq_iff)
246.298 - thus "finite {x. sprod_map\<cdot>d1\<cdot>d2\<cdot>x = x}"
246.299 - by (rule finite_subset, simp add: d1.finite_fixes d2.finite_fixes)
246.300 -qed
246.301 -
246.302 -subsection {* Map function for strict sums *}
246.303 -
246.304 -definition
246.305 - ssum_map :: "('a \<rightarrow> 'b) \<rightarrow> ('c \<rightarrow> 'd) \<rightarrow> 'a \<oplus> 'c \<rightarrow> 'b \<oplus> 'd"
246.306 -where
246.307 - "ssum_map = (\<Lambda> f g. sscase\<cdot>(sinl oo f)\<cdot>(sinr oo g))"
246.308 -
246.309 -lemma ssum_map_strict [simp]: "ssum_map\<cdot>f\<cdot>g\<cdot>\<bottom> = \<bottom>"
246.310 -unfolding ssum_map_def by simp
246.311 -
246.312 -lemma ssum_map_sinl [simp]: "x \<noteq> \<bottom> \<Longrightarrow> ssum_map\<cdot>f\<cdot>g\<cdot>(sinl\<cdot>x) = sinl\<cdot>(f\<cdot>x)"
246.313 -unfolding ssum_map_def by simp
246.314 -
246.315 -lemma ssum_map_sinr [simp]: "x \<noteq> \<bottom> \<Longrightarrow> ssum_map\<cdot>f\<cdot>g\<cdot>(sinr\<cdot>x) = sinr\<cdot>(g\<cdot>x)"
246.316 -unfolding ssum_map_def by simp
246.317 -
246.318 -lemma ssum_map_sinl': "f\<cdot>\<bottom> = \<bottom> \<Longrightarrow> ssum_map\<cdot>f\<cdot>g\<cdot>(sinl\<cdot>x) = sinl\<cdot>(f\<cdot>x)"
246.319 -by (cases "x = \<bottom>") simp_all
246.320 -
246.321 -lemma ssum_map_sinr': "g\<cdot>\<bottom> = \<bottom> \<Longrightarrow> ssum_map\<cdot>f\<cdot>g\<cdot>(sinr\<cdot>x) = sinr\<cdot>(g\<cdot>x)"
246.322 -by (cases "x = \<bottom>") simp_all
246.323 -
246.324 -lemma ssum_map_ID: "ssum_map\<cdot>ID\<cdot>ID = ID"
246.325 -unfolding ssum_map_def by (simp add: cfun_eq_iff eta_cfun)
246.326 -
246.327 -lemma ssum_map_map:
246.328 - "\<lbrakk>f1\<cdot>\<bottom> = \<bottom>; g1\<cdot>\<bottom> = \<bottom>\<rbrakk> \<Longrightarrow>
246.329 - ssum_map\<cdot>f1\<cdot>g1\<cdot>(ssum_map\<cdot>f2\<cdot>g2\<cdot>p) =
246.330 - ssum_map\<cdot>(\<Lambda> x. f1\<cdot>(f2\<cdot>x))\<cdot>(\<Lambda> x. g1\<cdot>(g2\<cdot>x))\<cdot>p"
246.331 -apply (induct p, simp)
246.332 -apply (case_tac "f2\<cdot>x = \<bottom>", simp, simp)
246.333 -apply (case_tac "g2\<cdot>y = \<bottom>", simp, simp)
246.334 -done
246.335 -
246.336 -lemma ep_pair_ssum_map:
246.337 - assumes "ep_pair e1 p1" and "ep_pair e2 p2"
246.338 - shows "ep_pair (ssum_map\<cdot>e1\<cdot>e2) (ssum_map\<cdot>p1\<cdot>p2)"
246.339 -proof
246.340 - interpret e1p1: pcpo_ep_pair e1 p1 unfolding pcpo_ep_pair_def by fact
246.341 - interpret e2p2: pcpo_ep_pair e2 p2 unfolding pcpo_ep_pair_def by fact
246.342 - fix x show "ssum_map\<cdot>p1\<cdot>p2\<cdot>(ssum_map\<cdot>e1\<cdot>e2\<cdot>x) = x"
246.343 - by (induct x) simp_all
246.344 - fix y show "ssum_map\<cdot>e1\<cdot>e2\<cdot>(ssum_map\<cdot>p1\<cdot>p2\<cdot>y) \<sqsubseteq> y"
246.345 - apply (induct y, simp)
246.346 - apply (case_tac "p1\<cdot>x = \<bottom>", simp, simp add: e1p1.e_p_below)
246.347 - apply (case_tac "p2\<cdot>y = \<bottom>", simp, simp add: e2p2.e_p_below)
246.348 - done
246.349 -qed
246.350 -
246.351 -lemma deflation_ssum_map:
246.352 - assumes "deflation d1" and "deflation d2"
246.353 - shows "deflation (ssum_map\<cdot>d1\<cdot>d2)"
246.354 -proof
246.355 - interpret d1: deflation d1 by fact
246.356 - interpret d2: deflation d2 by fact
246.357 - fix x
246.358 - show "ssum_map\<cdot>d1\<cdot>d2\<cdot>(ssum_map\<cdot>d1\<cdot>d2\<cdot>x) = ssum_map\<cdot>d1\<cdot>d2\<cdot>x"
246.359 - apply (induct x, simp)
246.360 - apply (case_tac "d1\<cdot>x = \<bottom>", simp, simp add: d1.idem)
246.361 - apply (case_tac "d2\<cdot>y = \<bottom>", simp, simp add: d2.idem)
246.362 - done
246.363 - show "ssum_map\<cdot>d1\<cdot>d2\<cdot>x \<sqsubseteq> x"
246.364 - apply (induct x, simp)
246.365 - apply (case_tac "d1\<cdot>x = \<bottom>", simp, simp add: d1.below)
246.366 - apply (case_tac "d2\<cdot>y = \<bottom>", simp, simp add: d2.below)
246.367 - done
246.368 -qed
246.369 -
246.370 -lemma finite_deflation_ssum_map:
246.371 - assumes "finite_deflation d1" and "finite_deflation d2"
246.372 - shows "finite_deflation (ssum_map\<cdot>d1\<cdot>d2)"
246.373 -proof (rule finite_deflation_intro)
246.374 - interpret d1: finite_deflation d1 by fact
246.375 - interpret d2: finite_deflation d2 by fact
246.376 - have "deflation d1" and "deflation d2" by fact+
246.377 - thus "deflation (ssum_map\<cdot>d1\<cdot>d2)" by (rule deflation_ssum_map)
246.378 - have "{x. ssum_map\<cdot>d1\<cdot>d2\<cdot>x = x} \<subseteq>
246.379 - (\<lambda>x. sinl\<cdot>x) ` {x. d1\<cdot>x = x} \<union>
246.380 - (\<lambda>x. sinr\<cdot>x) ` {x. d2\<cdot>x = x} \<union> {\<bottom>}"
246.381 - by (rule subsetI, case_tac x, simp_all)
246.382 - thus "finite {x. ssum_map\<cdot>d1\<cdot>d2\<cdot>x = x}"
246.383 - by (rule finite_subset, simp add: d1.finite_fixes d2.finite_fixes)
246.384 -qed
246.385 -
246.386 -subsection {* Map operator for strict function space *}
246.387 -
246.388 -definition
246.389 - sfun_map :: "('b \<rightarrow> 'a) \<rightarrow> ('c \<rightarrow> 'd) \<rightarrow> ('a \<rightarrow>! 'c) \<rightarrow> ('b \<rightarrow>! 'd)"
246.390 -where
246.391 - "sfun_map = (\<Lambda> a b. sfun_abs oo cfun_map\<cdot>a\<cdot>b oo sfun_rep)"
246.392 -
246.393 -lemma sfun_map_ID: "sfun_map\<cdot>ID\<cdot>ID = ID"
246.394 - unfolding sfun_map_def
246.395 - by (simp add: cfun_map_ID cfun_eq_iff)
246.396 -
246.397 -lemma sfun_map_map:
246.398 - assumes "f2\<cdot>\<bottom> = \<bottom>" and "g2\<cdot>\<bottom> = \<bottom>" shows
246.399 - "sfun_map\<cdot>f1\<cdot>g1\<cdot>(sfun_map\<cdot>f2\<cdot>g2\<cdot>p) =
246.400 - sfun_map\<cdot>(\<Lambda> x. f2\<cdot>(f1\<cdot>x))\<cdot>(\<Lambda> x. g1\<cdot>(g2\<cdot>x))\<cdot>p"
246.401 -unfolding sfun_map_def
246.402 -by (simp add: cfun_eq_iff strictify_cancel assms cfun_map_map)
246.403 -
246.404 -lemma ep_pair_sfun_map:
246.405 - assumes 1: "ep_pair e1 p1"
246.406 - assumes 2: "ep_pair e2 p2"
246.407 - shows "ep_pair (sfun_map\<cdot>p1\<cdot>e2) (sfun_map\<cdot>e1\<cdot>p2)"
246.408 -proof
246.409 - interpret e1p1: pcpo_ep_pair e1 p1
246.410 - unfolding pcpo_ep_pair_def by fact
246.411 - interpret e2p2: pcpo_ep_pair e2 p2
246.412 - unfolding pcpo_ep_pair_def by fact
246.413 - fix f show "sfun_map\<cdot>e1\<cdot>p2\<cdot>(sfun_map\<cdot>p1\<cdot>e2\<cdot>f) = f"
246.414 - unfolding sfun_map_def
246.415 - apply (simp add: sfun_eq_iff strictify_cancel)
246.416 - apply (rule ep_pair.e_inverse)
246.417 - apply (rule ep_pair_cfun_map [OF 1 2])
246.418 - done
246.419 - fix g show "sfun_map\<cdot>p1\<cdot>e2\<cdot>(sfun_map\<cdot>e1\<cdot>p2\<cdot>g) \<sqsubseteq> g"
246.420 - unfolding sfun_map_def
246.421 - apply (simp add: sfun_below_iff strictify_cancel)
246.422 - apply (rule ep_pair.e_p_below)
246.423 - apply (rule ep_pair_cfun_map [OF 1 2])
246.424 - done
246.425 -qed
246.426 -
246.427 -lemma deflation_sfun_map:
246.428 - assumes 1: "deflation d1"
246.429 - assumes 2: "deflation d2"
246.430 - shows "deflation (sfun_map\<cdot>d1\<cdot>d2)"
246.431 -apply (simp add: sfun_map_def)
246.432 -apply (rule deflation.intro)
246.433 -apply simp
246.434 -apply (subst strictify_cancel)
246.435 -apply (simp add: cfun_map_def deflation_strict 1 2)
246.436 -apply (simp add: cfun_map_def deflation.idem 1 2)
246.437 -apply (simp add: sfun_below_iff)
246.438 -apply (subst strictify_cancel)
246.439 -apply (simp add: cfun_map_def deflation_strict 1 2)
246.440 -apply (rule deflation.below)
246.441 -apply (rule deflation_cfun_map [OF 1 2])
246.442 -done
246.443 -
246.444 -lemma finite_deflation_sfun_map:
246.445 - assumes 1: "finite_deflation d1"
246.446 - assumes 2: "finite_deflation d2"
246.447 - shows "finite_deflation (sfun_map\<cdot>d1\<cdot>d2)"
246.448 -proof (intro finite_deflation_intro)
246.449 - interpret d1: finite_deflation d1 by fact
246.450 - interpret d2: finite_deflation d2 by fact
246.451 - have "deflation d1" and "deflation d2" by fact+
246.452 - thus "deflation (sfun_map\<cdot>d1\<cdot>d2)" by (rule deflation_sfun_map)
246.453 - from 1 2 have "finite_deflation (cfun_map\<cdot>d1\<cdot>d2)"
246.454 - by (rule finite_deflation_cfun_map)
246.455 - then have "finite {f. cfun_map\<cdot>d1\<cdot>d2\<cdot>f = f}"
246.456 - by (rule finite_deflation.finite_fixes)
246.457 - moreover have "inj (\<lambda>f. sfun_rep\<cdot>f)"
246.458 - by (rule inj_onI, simp add: sfun_eq_iff)
246.459 - ultimately have "finite ((\<lambda>f. sfun_rep\<cdot>f) -` {f. cfun_map\<cdot>d1\<cdot>d2\<cdot>f = f})"
246.460 - by (rule finite_vimageI)
246.461 - then show "finite {f. sfun_map\<cdot>d1\<cdot>d2\<cdot>f = f}"
246.462 - unfolding sfun_map_def sfun_eq_iff
246.463 - by (simp add: strictify_cancel
246.464 - deflation_strict `deflation d1` `deflation d2`)
246.465 -qed
246.466 -
246.467 -end
247.1 --- a/src/HOLCF/One.thy Sat Nov 27 14:34:54 2010 -0800
247.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
247.3 @@ -1,72 +0,0 @@
247.4 -(* Title: HOLCF/One.thy
247.5 - Author: Oscar Slotosch
247.6 -*)
247.7 -
247.8 -header {* The unit domain *}
247.9 -
247.10 -theory One
247.11 -imports Lift
247.12 -begin
247.13 -
247.14 -types one = "unit lift"
247.15 -translations
247.16 - (type) "one" <= (type) "unit lift"
247.17 -
247.18 -definition
247.19 - ONE :: "one"
247.20 -where
247.21 - "ONE == Def ()"
247.22 -
247.23 -text {* Exhaustion and Elimination for type @{typ one} *}
247.24 -
247.25 -lemma Exh_one: "t = \<bottom> \<or> t = ONE"
247.26 -unfolding ONE_def by (induct t) simp_all
247.27 -
247.28 -lemma oneE [case_names bottom ONE]: "\<lbrakk>p = \<bottom> \<Longrightarrow> Q; p = ONE \<Longrightarrow> Q\<rbrakk> \<Longrightarrow> Q"
247.29 -unfolding ONE_def by (induct p) simp_all
247.30 -
247.31 -lemma one_induct [case_names bottom ONE]: "\<lbrakk>P \<bottom>; P ONE\<rbrakk> \<Longrightarrow> P x"
247.32 -by (cases x rule: oneE) simp_all
247.33 -
247.34 -lemma dist_below_one [simp]: "\<not> ONE \<sqsubseteq> \<bottom>"
247.35 -unfolding ONE_def by simp
247.36 -
247.37 -lemma below_ONE [simp]: "x \<sqsubseteq> ONE"
247.38 -by (induct x rule: one_induct) simp_all
247.39 -
247.40 -lemma ONE_below_iff [simp]: "ONE \<sqsubseteq> x \<longleftrightarrow> x = ONE"
247.41 -by (induct x rule: one_induct) simp_all
247.42 -
247.43 -lemma ONE_defined [simp]: "ONE \<noteq> \<bottom>"
247.44 -unfolding ONE_def by simp
247.45 -
247.46 -lemma one_neq_iffs [simp]:
247.47 - "x \<noteq> ONE \<longleftrightarrow> x = \<bottom>"
247.48 - "ONE \<noteq> x \<longleftrightarrow> x = \<bottom>"
247.49 - "x \<noteq> \<bottom> \<longleftrightarrow> x = ONE"
247.50 - "\<bottom> \<noteq> x \<longleftrightarrow> x = ONE"
247.51 -by (induct x rule: one_induct) simp_all
247.52 -
247.53 -lemma compact_ONE: "compact ONE"
247.54 -by (rule compact_chfin)
247.55 -
247.56 -text {* Case analysis function for type @{typ one} *}
247.57 -
247.58 -definition
247.59 - one_case :: "'a::pcpo \<rightarrow> one \<rightarrow> 'a" where
247.60 - "one_case = (\<Lambda> a x. seq\<cdot>x\<cdot>a)"
247.61 -
247.62 -translations
247.63 - "case x of XCONST ONE \<Rightarrow> t" == "CONST one_case\<cdot>t\<cdot>x"
247.64 - "\<Lambda> (XCONST ONE). t" == "CONST one_case\<cdot>t"
247.65 -
247.66 -lemma one_case1 [simp]: "(case \<bottom> of ONE \<Rightarrow> t) = \<bottom>"
247.67 -by (simp add: one_case_def)
247.68 -
247.69 -lemma one_case2 [simp]: "(case ONE of ONE \<Rightarrow> t) = t"
247.70 -by (simp add: one_case_def)
247.71 -
247.72 -lemma one_case3 [simp]: "(case x of ONE \<Rightarrow> ONE) = x"
247.73 -by (induct x rule: one_induct) simp_all
247.74 -
247.75 -end
248.1 --- a/src/HOLCF/Pcpo.thy Sat Nov 27 14:34:54 2010 -0800
248.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
248.3 @@ -1,284 +0,0 @@
248.4 -(* Title: HOLCF/Pcpo.thy
248.5 - Author: Franz Regensburger
248.6 -*)
248.7 -
248.8 -header {* Classes cpo and pcpo *}
248.9 -
248.10 -theory Pcpo
248.11 -imports Porder
248.12 -begin
248.13 -
248.14 -subsection {* Complete partial orders *}
248.15 -
248.16 -text {* The class cpo of chain complete partial orders *}
248.17 -
248.18 -class cpo = po +
248.19 - assumes cpo: "chain S \<Longrightarrow> \<exists>x. range S <<| x"
248.20 -begin
248.21 -
248.22 -text {* in cpo's everthing equal to THE lub has lub properties for every chain *}
248.23 -
248.24 -lemma cpo_lubI: "chain S \<Longrightarrow> range S <<| (\<Squnion>i. S i)"
248.25 - by (fast dest: cpo elim: is_lub_lub)
248.26 -
248.27 -lemma thelubE: "\<lbrakk>chain S; (\<Squnion>i. S i) = l\<rbrakk> \<Longrightarrow> range S <<| l"
248.28 - by (blast dest: cpo intro: is_lub_lub)
248.29 -
248.30 -text {* Properties of the lub *}
248.31 -
248.32 -lemma is_ub_thelub: "chain S \<Longrightarrow> S x \<sqsubseteq> (\<Squnion>i. S i)"
248.33 - by (blast dest: cpo intro: is_lub_lub [THEN is_lub_rangeD1])
248.34 -
248.35 -lemma is_lub_thelub:
248.36 - "\<lbrakk>chain S; range S <| x\<rbrakk> \<Longrightarrow> (\<Squnion>i. S i) \<sqsubseteq> x"
248.37 - by (blast dest: cpo intro: is_lub_lub [THEN is_lubD2])
248.38 -
248.39 -lemma lub_below_iff: "chain S \<Longrightarrow> (\<Squnion>i. S i) \<sqsubseteq> x \<longleftrightarrow> (\<forall>i. S i \<sqsubseteq> x)"
248.40 - by (simp add: is_lub_below_iff [OF cpo_lubI] is_ub_def)
248.41 -
248.42 -lemma lub_below: "\<lbrakk>chain S; \<And>i. S i \<sqsubseteq> x\<rbrakk> \<Longrightarrow> (\<Squnion>i. S i) \<sqsubseteq> x"
248.43 - by (simp add: lub_below_iff)
248.44 -
248.45 -lemma below_lub: "\<lbrakk>chain S; x \<sqsubseteq> S i\<rbrakk> \<Longrightarrow> x \<sqsubseteq> (\<Squnion>i. S i)"
248.46 - by (erule below_trans, erule is_ub_thelub)
248.47 -
248.48 -lemma lub_range_mono:
248.49 - "\<lbrakk>range X \<subseteq> range Y; chain Y; chain X\<rbrakk>
248.50 - \<Longrightarrow> (\<Squnion>i. X i) \<sqsubseteq> (\<Squnion>i. Y i)"
248.51 -apply (erule lub_below)
248.52 -apply (subgoal_tac "\<exists>j. X i = Y j")
248.53 -apply clarsimp
248.54 -apply (erule is_ub_thelub)
248.55 -apply auto
248.56 -done
248.57 -
248.58 -lemma lub_range_shift:
248.59 - "chain Y \<Longrightarrow> (\<Squnion>i. Y (i + j)) = (\<Squnion>i. Y i)"
248.60 -apply (rule below_antisym)
248.61 -apply (rule lub_range_mono)
248.62 -apply fast
248.63 -apply assumption
248.64 -apply (erule chain_shift)
248.65 -apply (rule lub_below)
248.66 -apply assumption
248.67 -apply (rule_tac i="i" in below_lub)
248.68 -apply (erule chain_shift)
248.69 -apply (erule chain_mono)
248.70 -apply (rule le_add1)
248.71 -done
248.72 -
248.73 -lemma maxinch_is_thelub:
248.74 - "chain Y \<Longrightarrow> max_in_chain i Y = ((\<Squnion>i. Y i) = Y i)"
248.75 -apply (rule iffI)
248.76 -apply (fast intro!: lub_eqI lub_finch1)
248.77 -apply (unfold max_in_chain_def)
248.78 -apply (safe intro!: below_antisym)
248.79 -apply (fast elim!: chain_mono)
248.80 -apply (drule sym)
248.81 -apply (force elim!: is_ub_thelub)
248.82 -done
248.83 -
248.84 -text {* the @{text "\<sqsubseteq>"} relation between two chains is preserved by their lubs *}
248.85 -
248.86 -lemma lub_mono:
248.87 - "\<lbrakk>chain X; chain Y; \<And>i. X i \<sqsubseteq> Y i\<rbrakk>
248.88 - \<Longrightarrow> (\<Squnion>i. X i) \<sqsubseteq> (\<Squnion>i. Y i)"
248.89 -by (fast elim: lub_below below_lub)
248.90 -
248.91 -text {* the = relation between two chains is preserved by their lubs *}
248.92 -
248.93 -lemma lub_eq:
248.94 - "(\<And>i. X i = Y i) \<Longrightarrow> (\<Squnion>i. X i) = (\<Squnion>i. Y i)"
248.95 - by simp
248.96 -
248.97 -lemma ch2ch_lub:
248.98 - assumes 1: "\<And>j. chain (\<lambda>i. Y i j)"
248.99 - assumes 2: "\<And>i. chain (\<lambda>j. Y i j)"
248.100 - shows "chain (\<lambda>i. \<Squnion>j. Y i j)"
248.101 -apply (rule chainI)
248.102 -apply (rule lub_mono [OF 2 2])
248.103 -apply (rule chainE [OF 1])
248.104 -done
248.105 -
248.106 -lemma diag_lub:
248.107 - assumes 1: "\<And>j. chain (\<lambda>i. Y i j)"
248.108 - assumes 2: "\<And>i. chain (\<lambda>j. Y i j)"
248.109 - shows "(\<Squnion>i. \<Squnion>j. Y i j) = (\<Squnion>i. Y i i)"
248.110 -proof (rule below_antisym)
248.111 - have 3: "chain (\<lambda>i. Y i i)"
248.112 - apply (rule chainI)
248.113 - apply (rule below_trans)
248.114 - apply (rule chainE [OF 1])
248.115 - apply (rule chainE [OF 2])
248.116 - done
248.117 - have 4: "chain (\<lambda>i. \<Squnion>j. Y i j)"
248.118 - by (rule ch2ch_lub [OF 1 2])
248.119 - show "(\<Squnion>i. \<Squnion>j. Y i j) \<sqsubseteq> (\<Squnion>i. Y i i)"
248.120 - apply (rule lub_below [OF 4])
248.121 - apply (rule lub_below [OF 2])
248.122 - apply (rule below_lub [OF 3])
248.123 - apply (rule below_trans)
248.124 - apply (rule chain_mono [OF 1 le_maxI1])
248.125 - apply (rule chain_mono [OF 2 le_maxI2])
248.126 - done
248.127 - show "(\<Squnion>i. Y i i) \<sqsubseteq> (\<Squnion>i. \<Squnion>j. Y i j)"
248.128 - apply (rule lub_mono [OF 3 4])
248.129 - apply (rule is_ub_thelub [OF 2])
248.130 - done
248.131 -qed
248.132 -
248.133 -lemma ex_lub:
248.134 - assumes 1: "\<And>j. chain (\<lambda>i. Y i j)"
248.135 - assumes 2: "\<And>i. chain (\<lambda>j. Y i j)"
248.136 - shows "(\<Squnion>i. \<Squnion>j. Y i j) = (\<Squnion>j. \<Squnion>i. Y i j)"
248.137 - by (simp add: diag_lub 1 2)
248.138 -
248.139 -end
248.140 -
248.141 -subsection {* Pointed cpos *}
248.142 -
248.143 -text {* The class pcpo of pointed cpos *}
248.144 -
248.145 -class pcpo = cpo +
248.146 - assumes least: "\<exists>x. \<forall>y. x \<sqsubseteq> y"
248.147 -begin
248.148 -
248.149 -definition UU :: 'a where
248.150 - "UU = (THE x. \<forall>y. x \<sqsubseteq> y)"
248.151 -
248.152 -notation (xsymbols)
248.153 - UU ("\<bottom>")
248.154 -
248.155 -text {* derive the old rule minimal *}
248.156 -
248.157 -lemma UU_least: "\<forall>z. \<bottom> \<sqsubseteq> z"
248.158 -apply (unfold UU_def)
248.159 -apply (rule theI')
248.160 -apply (rule ex_ex1I)
248.161 -apply (rule least)
248.162 -apply (blast intro: below_antisym)
248.163 -done
248.164 -
248.165 -lemma minimal [iff]: "\<bottom> \<sqsubseteq> x"
248.166 -by (rule UU_least [THEN spec])
248.167 -
248.168 -end
248.169 -
248.170 -text {* Simproc to rewrite @{term "\<bottom> = x"} to @{term "x = \<bottom>"}. *}
248.171 -
248.172 -setup {*
248.173 - Reorient_Proc.add
248.174 - (fn Const(@{const_name UU}, _) => true | _ => false)
248.175 -*}
248.176 -
248.177 -simproc_setup reorient_bottom ("\<bottom> = x") = Reorient_Proc.proc
248.178 -
248.179 -context pcpo
248.180 -begin
248.181 -
248.182 -text {* useful lemmas about @{term \<bottom>} *}
248.183 -
248.184 -lemma below_UU_iff [simp]: "(x \<sqsubseteq> \<bottom>) = (x = \<bottom>)"
248.185 -by (simp add: po_eq_conv)
248.186 -
248.187 -lemma eq_UU_iff: "(x = \<bottom>) = (x \<sqsubseteq> \<bottom>)"
248.188 -by simp
248.189 -
248.190 -lemma UU_I: "x \<sqsubseteq> \<bottom> \<Longrightarrow> x = \<bottom>"
248.191 -by (subst eq_UU_iff)
248.192 -
248.193 -lemma lub_eq_bottom_iff: "chain Y \<Longrightarrow> (\<Squnion>i. Y i) = \<bottom> \<longleftrightarrow> (\<forall>i. Y i = \<bottom>)"
248.194 -by (simp only: eq_UU_iff lub_below_iff)
248.195 -
248.196 -lemma chain_UU_I: "\<lbrakk>chain Y; (\<Squnion>i. Y i) = \<bottom>\<rbrakk> \<Longrightarrow> \<forall>i. Y i = \<bottom>"
248.197 -by (simp add: lub_eq_bottom_iff)
248.198 -
248.199 -lemma chain_UU_I_inverse: "\<forall>i::nat. Y i = \<bottom> \<Longrightarrow> (\<Squnion>i. Y i) = \<bottom>"
248.200 -by simp
248.201 -
248.202 -lemma chain_UU_I_inverse2: "(\<Squnion>i. Y i) \<noteq> \<bottom> \<Longrightarrow> \<exists>i::nat. Y i \<noteq> \<bottom>"
248.203 - by (blast intro: chain_UU_I_inverse)
248.204 -
248.205 -lemma notUU_I: "\<lbrakk>x \<sqsubseteq> y; x \<noteq> \<bottom>\<rbrakk> \<Longrightarrow> y \<noteq> \<bottom>"
248.206 - by (blast intro: UU_I)
248.207 -
248.208 -end
248.209 -
248.210 -subsection {* Chain-finite and flat cpos *}
248.211 -
248.212 -text {* further useful classes for HOLCF domains *}
248.213 -
248.214 -class chfin = po +
248.215 - assumes chfin: "chain Y \<Longrightarrow> \<exists>n. max_in_chain n Y"
248.216 -begin
248.217 -
248.218 -subclass cpo
248.219 -apply default
248.220 -apply (frule chfin)
248.221 -apply (blast intro: lub_finch1)
248.222 -done
248.223 -
248.224 -lemma chfin2finch: "chain Y \<Longrightarrow> finite_chain Y"
248.225 - by (simp add: chfin finite_chain_def)
248.226 -
248.227 -end
248.228 -
248.229 -class flat = pcpo +
248.230 - assumes ax_flat: "x \<sqsubseteq> y \<Longrightarrow> x = \<bottom> \<or> x = y"
248.231 -begin
248.232 -
248.233 -subclass chfin
248.234 -apply default
248.235 -apply (unfold max_in_chain_def)
248.236 -apply (case_tac "\<forall>i. Y i = \<bottom>")
248.237 -apply simp
248.238 -apply simp
248.239 -apply (erule exE)
248.240 -apply (rule_tac x="i" in exI)
248.241 -apply clarify
248.242 -apply (blast dest: chain_mono ax_flat)
248.243 -done
248.244 -
248.245 -lemma flat_below_iff:
248.246 - shows "(x \<sqsubseteq> y) = (x = \<bottom> \<or> x = y)"
248.247 - by (safe dest!: ax_flat)
248.248 -
248.249 -lemma flat_eq: "a \<noteq> \<bottom> \<Longrightarrow> a \<sqsubseteq> b = (a = b)"
248.250 - by (safe dest!: ax_flat)
248.251 -
248.252 -end
248.253 -
248.254 -subsection {* Discrete cpos *}
248.255 -
248.256 -class discrete_cpo = below +
248.257 - assumes discrete_cpo [simp]: "x \<sqsubseteq> y \<longleftrightarrow> x = y"
248.258 -begin
248.259 -
248.260 -subclass po
248.261 -proof qed simp_all
248.262 -
248.263 -text {* In a discrete cpo, every chain is constant *}
248.264 -
248.265 -lemma discrete_chain_const:
248.266 - assumes S: "chain S"
248.267 - shows "\<exists>x. S = (\<lambda>i. x)"
248.268 -proof (intro exI ext)
248.269 - fix i :: nat
248.270 - have "S 0 \<sqsubseteq> S i" using S le0 by (rule chain_mono)
248.271 - hence "S 0 = S i" by simp
248.272 - thus "S i = S 0" by (rule sym)
248.273 -qed
248.274 -
248.275 -subclass chfin
248.276 -proof
248.277 - fix S :: "nat \<Rightarrow> 'a"
248.278 - assume S: "chain S"
248.279 - hence "\<exists>x. S = (\<lambda>i. x)" by (rule discrete_chain_const)
248.280 - hence "max_in_chain 0 S"
248.281 - unfolding max_in_chain_def by auto
248.282 - thus "\<exists>i. max_in_chain i S" ..
248.283 -qed
248.284 -
248.285 -end
248.286 -
248.287 -end
249.1 --- a/src/HOLCF/Plain_HOLCF.thy Sat Nov 27 14:34:54 2010 -0800
249.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
249.3 @@ -1,15 +0,0 @@
249.4 -(* Title: HOLCF/Plain_HOLCF.thy
249.5 - Author: Brian Huffman
249.6 -*)
249.7 -
249.8 -header {* Plain HOLCF *}
249.9 -
249.10 -theory Plain_HOLCF
249.11 -imports Cfun Sfun Cprod Sprod Ssum Up Discrete Lift One Tr Fix
249.12 -begin
249.13 -
249.14 -text {*
249.15 - Basic HOLCF concepts and types; does not include definition packages.
249.16 -*}
249.17 -
249.18 -end
250.1 --- a/src/HOLCF/Porder.thy Sat Nov 27 14:34:54 2010 -0800
250.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
250.3 @@ -1,336 +0,0 @@
250.4 -(* Title: HOLCF/Porder.thy
250.5 - Author: Franz Regensburger and Brian Huffman
250.6 -*)
250.7 -
250.8 -header {* Partial orders *}
250.9 -
250.10 -theory Porder
250.11 -imports Main
250.12 -begin
250.13 -
250.14 -subsection {* Type class for partial orders *}
250.15 -
250.16 -class below =
250.17 - fixes below :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
250.18 -begin
250.19 -
250.20 -notation
250.21 - below (infix "<<" 50)
250.22 -
250.23 -notation (xsymbols)
250.24 - below (infix "\<sqsubseteq>" 50)
250.25 -
250.26 -lemma below_eq_trans: "\<lbrakk>a \<sqsubseteq> b; b = c\<rbrakk> \<Longrightarrow> a \<sqsubseteq> c"
250.27 - by (rule subst)
250.28 -
250.29 -lemma eq_below_trans: "\<lbrakk>a = b; b \<sqsubseteq> c\<rbrakk> \<Longrightarrow> a \<sqsubseteq> c"
250.30 - by (rule ssubst)
250.31 -
250.32 -end
250.33 -
250.34 -class po = below +
250.35 - assumes below_refl [iff]: "x \<sqsubseteq> x"
250.36 - assumes below_trans: "x \<sqsubseteq> y \<Longrightarrow> y \<sqsubseteq> z \<Longrightarrow> x \<sqsubseteq> z"
250.37 - assumes below_antisym: "x \<sqsubseteq> y \<Longrightarrow> y \<sqsubseteq> x \<Longrightarrow> x = y"
250.38 -begin
250.39 -
250.40 -lemma eq_imp_below: "x = y \<Longrightarrow> x \<sqsubseteq> y"
250.41 - by simp
250.42 -
250.43 -lemma box_below: "a \<sqsubseteq> b \<Longrightarrow> c \<sqsubseteq> a \<Longrightarrow> b \<sqsubseteq> d \<Longrightarrow> c \<sqsubseteq> d"
250.44 - by (rule below_trans [OF below_trans])
250.45 -
250.46 -lemma po_eq_conv: "x = y \<longleftrightarrow> x \<sqsubseteq> y \<and> y \<sqsubseteq> x"
250.47 - by (fast intro!: below_antisym)
250.48 -
250.49 -lemma rev_below_trans: "y \<sqsubseteq> z \<Longrightarrow> x \<sqsubseteq> y \<Longrightarrow> x \<sqsubseteq> z"
250.50 - by (rule below_trans)
250.51 -
250.52 -lemma not_below2not_eq: "\<not> x \<sqsubseteq> y \<Longrightarrow> x \<noteq> y"
250.53 - by auto
250.54 -
250.55 -end
250.56 -
250.57 -lemmas HOLCF_trans_rules [trans] =
250.58 - below_trans
250.59 - below_antisym
250.60 - below_eq_trans
250.61 - eq_below_trans
250.62 -
250.63 -context po
250.64 -begin
250.65 -
250.66 -subsection {* Upper bounds *}
250.67 -
250.68 -definition is_ub :: "'a set \<Rightarrow> 'a \<Rightarrow> bool" (infix "<|" 55) where
250.69 - "S <| x \<longleftrightarrow> (\<forall>y\<in>S. y \<sqsubseteq> x)"
250.70 -
250.71 -lemma is_ubI: "(\<And>x. x \<in> S \<Longrightarrow> x \<sqsubseteq> u) \<Longrightarrow> S <| u"
250.72 - by (simp add: is_ub_def)
250.73 -
250.74 -lemma is_ubD: "\<lbrakk>S <| u; x \<in> S\<rbrakk> \<Longrightarrow> x \<sqsubseteq> u"
250.75 - by (simp add: is_ub_def)
250.76 -
250.77 -lemma ub_imageI: "(\<And>x. x \<in> S \<Longrightarrow> f x \<sqsubseteq> u) \<Longrightarrow> (\<lambda>x. f x) ` S <| u"
250.78 - unfolding is_ub_def by fast
250.79 -
250.80 -lemma ub_imageD: "\<lbrakk>f ` S <| u; x \<in> S\<rbrakk> \<Longrightarrow> f x \<sqsubseteq> u"
250.81 - unfolding is_ub_def by fast
250.82 -
250.83 -lemma ub_rangeI: "(\<And>i. S i \<sqsubseteq> x) \<Longrightarrow> range S <| x"
250.84 - unfolding is_ub_def by fast
250.85 -
250.86 -lemma ub_rangeD: "range S <| x \<Longrightarrow> S i \<sqsubseteq> x"
250.87 - unfolding is_ub_def by fast
250.88 -
250.89 -lemma is_ub_empty [simp]: "{} <| u"
250.90 - unfolding is_ub_def by fast
250.91 -
250.92 -lemma is_ub_insert [simp]: "(insert x A) <| y = (x \<sqsubseteq> y \<and> A <| y)"
250.93 - unfolding is_ub_def by fast
250.94 -
250.95 -lemma is_ub_upward: "\<lbrakk>S <| x; x \<sqsubseteq> y\<rbrakk> \<Longrightarrow> S <| y"
250.96 - unfolding is_ub_def by (fast intro: below_trans)
250.97 -
250.98 -subsection {* Least upper bounds *}
250.99 -
250.100 -definition is_lub :: "'a set \<Rightarrow> 'a \<Rightarrow> bool" (infix "<<|" 55) where
250.101 - "S <<| x \<longleftrightarrow> S <| x \<and> (\<forall>u. S <| u \<longrightarrow> x \<sqsubseteq> u)"
250.102 -
250.103 -definition lub :: "'a set \<Rightarrow> 'a" where
250.104 - "lub S = (THE x. S <<| x)"
250.105 -
250.106 -end
250.107 -
250.108 -syntax
250.109 - "_BLub" :: "[pttrn, 'a set, 'b] \<Rightarrow> 'b" ("(3LUB _:_./ _)" [0,0, 10] 10)
250.110 -
250.111 -syntax (xsymbols)
250.112 - "_BLub" :: "[pttrn, 'a set, 'b] \<Rightarrow> 'b" ("(3\<Squnion>_\<in>_./ _)" [0,0, 10] 10)
250.113 -
250.114 -translations
250.115 - "LUB x:A. t" == "CONST lub ((%x. t) ` A)"
250.116 -
250.117 -context po
250.118 -begin
250.119 -
250.120 -abbreviation
250.121 - Lub (binder "LUB " 10) where
250.122 - "LUB n. t n == lub (range t)"
250.123 -
250.124 -notation (xsymbols)
250.125 - Lub (binder "\<Squnion> " 10)
250.126 -
250.127 -text {* access to some definition as inference rule *}
250.128 -
250.129 -lemma is_lubD1: "S <<| x \<Longrightarrow> S <| x"
250.130 - unfolding is_lub_def by fast
250.131 -
250.132 -lemma is_lubD2: "\<lbrakk>S <<| x; S <| u\<rbrakk> \<Longrightarrow> x \<sqsubseteq> u"
250.133 - unfolding is_lub_def by fast
250.134 -
250.135 -lemma is_lubI: "\<lbrakk>S <| x; \<And>u. S <| u \<Longrightarrow> x \<sqsubseteq> u\<rbrakk> \<Longrightarrow> S <<| x"
250.136 - unfolding is_lub_def by fast
250.137 -
250.138 -lemma is_lub_below_iff: "S <<| x \<Longrightarrow> x \<sqsubseteq> u \<longleftrightarrow> S <| u"
250.139 - unfolding is_lub_def is_ub_def by (metis below_trans)
250.140 -
250.141 -text {* lubs are unique *}
250.142 -
250.143 -lemma is_lub_unique: "\<lbrakk>S <<| x; S <<| y\<rbrakk> \<Longrightarrow> x = y"
250.144 - unfolding is_lub_def is_ub_def by (blast intro: below_antisym)
250.145 -
250.146 -text {* technical lemmas about @{term lub} and @{term is_lub} *}
250.147 -
250.148 -lemma is_lub_lub: "M <<| x \<Longrightarrow> M <<| lub M"
250.149 - unfolding lub_def by (rule theI [OF _ is_lub_unique])
250.150 -
250.151 -lemma lub_eqI: "M <<| l \<Longrightarrow> lub M = l"
250.152 - by (rule is_lub_unique [OF is_lub_lub])
250.153 -
250.154 -lemma is_lub_singleton: "{x} <<| x"
250.155 - by (simp add: is_lub_def)
250.156 -
250.157 -lemma lub_singleton [simp]: "lub {x} = x"
250.158 - by (rule is_lub_singleton [THEN lub_eqI])
250.159 -
250.160 -lemma is_lub_bin: "x \<sqsubseteq> y \<Longrightarrow> {x, y} <<| y"
250.161 - by (simp add: is_lub_def)
250.162 -
250.163 -lemma lub_bin: "x \<sqsubseteq> y \<Longrightarrow> lub {x, y} = y"
250.164 - by (rule is_lub_bin [THEN lub_eqI])
250.165 -
250.166 -lemma is_lub_maximal: "\<lbrakk>S <| x; x \<in> S\<rbrakk> \<Longrightarrow> S <<| x"
250.167 - by (erule is_lubI, erule (1) is_ubD)
250.168 -
250.169 -lemma lub_maximal: "\<lbrakk>S <| x; x \<in> S\<rbrakk> \<Longrightarrow> lub S = x"
250.170 - by (rule is_lub_maximal [THEN lub_eqI])
250.171 -
250.172 -subsection {* Countable chains *}
250.173 -
250.174 -definition chain :: "(nat \<Rightarrow> 'a) \<Rightarrow> bool" where
250.175 - -- {* Here we use countable chains and I prefer to code them as functions! *}
250.176 - "chain Y = (\<forall>i. Y i \<sqsubseteq> Y (Suc i))"
250.177 -
250.178 -lemma chainI: "(\<And>i. Y i \<sqsubseteq> Y (Suc i)) \<Longrightarrow> chain Y"
250.179 - unfolding chain_def by fast
250.180 -
250.181 -lemma chainE: "chain Y \<Longrightarrow> Y i \<sqsubseteq> Y (Suc i)"
250.182 - unfolding chain_def by fast
250.183 -
250.184 -text {* chains are monotone functions *}
250.185 -
250.186 -lemma chain_mono_less: "\<lbrakk>chain Y; i < j\<rbrakk> \<Longrightarrow> Y i \<sqsubseteq> Y j"
250.187 - by (erule less_Suc_induct, erule chainE, erule below_trans)
250.188 -
250.189 -lemma chain_mono: "\<lbrakk>chain Y; i \<le> j\<rbrakk> \<Longrightarrow> Y i \<sqsubseteq> Y j"
250.190 - by (cases "i = j", simp, simp add: chain_mono_less)
250.191 -
250.192 -lemma chain_shift: "chain Y \<Longrightarrow> chain (\<lambda>i. Y (i + j))"
250.193 - by (rule chainI, simp, erule chainE)
250.194 -
250.195 -text {* technical lemmas about (least) upper bounds of chains *}
250.196 -
250.197 -lemma is_lub_rangeD1: "range S <<| x \<Longrightarrow> S i \<sqsubseteq> x"
250.198 - by (rule is_lubD1 [THEN ub_rangeD])
250.199 -
250.200 -lemma is_ub_range_shift:
250.201 - "chain S \<Longrightarrow> range (\<lambda>i. S (i + j)) <| x = range S <| x"
250.202 -apply (rule iffI)
250.203 -apply (rule ub_rangeI)
250.204 -apply (rule_tac y="S (i + j)" in below_trans)
250.205 -apply (erule chain_mono)
250.206 -apply (rule le_add1)
250.207 -apply (erule ub_rangeD)
250.208 -apply (rule ub_rangeI)
250.209 -apply (erule ub_rangeD)
250.210 -done
250.211 -
250.212 -lemma is_lub_range_shift:
250.213 - "chain S \<Longrightarrow> range (\<lambda>i. S (i + j)) <<| x = range S <<| x"
250.214 - by (simp add: is_lub_def is_ub_range_shift)
250.215 -
250.216 -text {* the lub of a constant chain is the constant *}
250.217 -
250.218 -lemma chain_const [simp]: "chain (\<lambda>i. c)"
250.219 - by (simp add: chainI)
250.220 -
250.221 -lemma is_lub_const: "range (\<lambda>x. c) <<| c"
250.222 -by (blast dest: ub_rangeD intro: is_lubI ub_rangeI)
250.223 -
250.224 -lemma lub_const [simp]: "(\<Squnion>i. c) = c"
250.225 - by (rule is_lub_const [THEN lub_eqI])
250.226 -
250.227 -subsection {* Finite chains *}
250.228 -
250.229 -definition max_in_chain :: "nat \<Rightarrow> (nat \<Rightarrow> 'a) \<Rightarrow> bool" where
250.230 - -- {* finite chains, needed for monotony of continuous functions *}
250.231 - "max_in_chain i C \<longleftrightarrow> (\<forall>j. i \<le> j \<longrightarrow> C i = C j)"
250.232 -
250.233 -definition finite_chain :: "(nat \<Rightarrow> 'a) \<Rightarrow> bool" where
250.234 - "finite_chain C = (chain C \<and> (\<exists>i. max_in_chain i C))"
250.235 -
250.236 -text {* results about finite chains *}
250.237 -
250.238 -lemma max_in_chainI: "(\<And>j. i \<le> j \<Longrightarrow> Y i = Y j) \<Longrightarrow> max_in_chain i Y"
250.239 - unfolding max_in_chain_def by fast
250.240 -
250.241 -lemma max_in_chainD: "\<lbrakk>max_in_chain i Y; i \<le> j\<rbrakk> \<Longrightarrow> Y i = Y j"
250.242 - unfolding max_in_chain_def by fast
250.243 -
250.244 -lemma finite_chainI:
250.245 - "\<lbrakk>chain C; max_in_chain i C\<rbrakk> \<Longrightarrow> finite_chain C"
250.246 - unfolding finite_chain_def by fast
250.247 -
250.248 -lemma finite_chainE:
250.249 - "\<lbrakk>finite_chain C; \<And>i. \<lbrakk>chain C; max_in_chain i C\<rbrakk> \<Longrightarrow> R\<rbrakk> \<Longrightarrow> R"
250.250 - unfolding finite_chain_def by fast
250.251 -
250.252 -lemma lub_finch1: "\<lbrakk>chain C; max_in_chain i C\<rbrakk> \<Longrightarrow> range C <<| C i"
250.253 -apply (rule is_lubI)
250.254 -apply (rule ub_rangeI, rename_tac j)
250.255 -apply (rule_tac x=i and y=j in linorder_le_cases)
250.256 -apply (drule (1) max_in_chainD, simp)
250.257 -apply (erule (1) chain_mono)
250.258 -apply (erule ub_rangeD)
250.259 -done
250.260 -
250.261 -lemma lub_finch2:
250.262 - "finite_chain C \<Longrightarrow> range C <<| C (LEAST i. max_in_chain i C)"
250.263 -apply (erule finite_chainE)
250.264 -apply (erule LeastI2 [where Q="\<lambda>i. range C <<| C i"])
250.265 -apply (erule (1) lub_finch1)
250.266 -done
250.267 -
250.268 -lemma finch_imp_finite_range: "finite_chain Y \<Longrightarrow> finite (range Y)"
250.269 - apply (erule finite_chainE)
250.270 - apply (rule_tac B="Y ` {..i}" in finite_subset)
250.271 - apply (rule subsetI)
250.272 - apply (erule rangeE, rename_tac j)
250.273 - apply (rule_tac x=i and y=j in linorder_le_cases)
250.274 - apply (subgoal_tac "Y j = Y i", simp)
250.275 - apply (simp add: max_in_chain_def)
250.276 - apply simp
250.277 - apply simp
250.278 -done
250.279 -
250.280 -lemma finite_range_has_max:
250.281 - fixes f :: "nat \<Rightarrow> 'a" and r :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
250.282 - assumes mono: "\<And>i j. i \<le> j \<Longrightarrow> r (f i) (f j)"
250.283 - assumes finite_range: "finite (range f)"
250.284 - shows "\<exists>k. \<forall>i. r (f i) (f k)"
250.285 -proof (intro exI allI)
250.286 - fix i :: nat
250.287 - let ?j = "LEAST k. f k = f i"
250.288 - let ?k = "Max ((\<lambda>x. LEAST k. f k = x) ` range f)"
250.289 - have "?j \<le> ?k"
250.290 - proof (rule Max_ge)
250.291 - show "finite ((\<lambda>x. LEAST k. f k = x) ` range f)"
250.292 - using finite_range by (rule finite_imageI)
250.293 - show "?j \<in> (\<lambda>x. LEAST k. f k = x) ` range f"
250.294 - by (intro imageI rangeI)
250.295 - qed
250.296 - hence "r (f ?j) (f ?k)"
250.297 - by (rule mono)
250.298 - also have "f ?j = f i"
250.299 - by (rule LeastI, rule refl)
250.300 - finally show "r (f i) (f ?k)" .
250.301 -qed
250.302 -
250.303 -lemma finite_range_imp_finch:
250.304 - "\<lbrakk>chain Y; finite (range Y)\<rbrakk> \<Longrightarrow> finite_chain Y"
250.305 - apply (subgoal_tac "\<exists>k. \<forall>i. Y i \<sqsubseteq> Y k")
250.306 - apply (erule exE)
250.307 - apply (rule finite_chainI, assumption)
250.308 - apply (rule max_in_chainI)
250.309 - apply (rule below_antisym)
250.310 - apply (erule (1) chain_mono)
250.311 - apply (erule spec)
250.312 - apply (rule finite_range_has_max)
250.313 - apply (erule (1) chain_mono)
250.314 - apply assumption
250.315 -done
250.316 -
250.317 -lemma bin_chain: "x \<sqsubseteq> y \<Longrightarrow> chain (\<lambda>i. if i=0 then x else y)"
250.318 - by (rule chainI, simp)
250.319 -
250.320 -lemma bin_chainmax:
250.321 - "x \<sqsubseteq> y \<Longrightarrow> max_in_chain (Suc 0) (\<lambda>i. if i=0 then x else y)"
250.322 - unfolding max_in_chain_def by simp
250.323 -
250.324 -lemma is_lub_bin_chain:
250.325 - "x \<sqsubseteq> y \<Longrightarrow> range (\<lambda>i::nat. if i=0 then x else y) <<| y"
250.326 -apply (frule bin_chain)
250.327 -apply (drule bin_chainmax)
250.328 -apply (drule (1) lub_finch1)
250.329 -apply simp
250.330 -done
250.331 -
250.332 -text {* the maximal element in a chain is its lub *}
250.333 -
250.334 -lemma lub_chain_maxelem: "\<lbrakk>Y i = c; \<forall>i. Y i \<sqsubseteq> c\<rbrakk> \<Longrightarrow> lub (range Y) = c"
250.335 - by (blast dest: ub_rangeD intro: lub_eqI is_lubI ub_rangeI)
250.336 -
250.337 -end
250.338 -
250.339 -end
251.1 --- a/src/HOLCF/Powerdomains.thy Sat Nov 27 14:34:54 2010 -0800
251.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
251.3 @@ -1,51 +0,0 @@
251.4 -(* Title: HOLCF/Powerdomains.thy
251.5 - Author: Brian Huffman
251.6 -*)
251.7 -
251.8 -header {* Powerdomains *}
251.9 -
251.10 -theory Powerdomains
251.11 -imports ConvexPD Domain
251.12 -begin
251.13 -
251.14 -lemma isodefl_upper:
251.15 - "isodefl d t \<Longrightarrow> isodefl (upper_map\<cdot>d) (upper_defl\<cdot>t)"
251.16 -apply (rule isodeflI)
251.17 -apply (simp add: cast_upper_defl cast_isodefl)
251.18 -apply (simp add: emb_upper_pd_def prj_upper_pd_def)
251.19 -apply (simp add: upper_map_map)
251.20 -done
251.21 -
251.22 -lemma isodefl_lower:
251.23 - "isodefl d t \<Longrightarrow> isodefl (lower_map\<cdot>d) (lower_defl\<cdot>t)"
251.24 -apply (rule isodeflI)
251.25 -apply (simp add: cast_lower_defl cast_isodefl)
251.26 -apply (simp add: emb_lower_pd_def prj_lower_pd_def)
251.27 -apply (simp add: lower_map_map)
251.28 -done
251.29 -
251.30 -lemma isodefl_convex:
251.31 - "isodefl d t \<Longrightarrow> isodefl (convex_map\<cdot>d) (convex_defl\<cdot>t)"
251.32 -apply (rule isodeflI)
251.33 -apply (simp add: cast_convex_defl cast_isodefl)
251.34 -apply (simp add: emb_convex_pd_def prj_convex_pd_def)
251.35 -apply (simp add: convex_map_map)
251.36 -done
251.37 -
251.38 -subsection {* Domain package setup for powerdomains *}
251.39 -
251.40 -lemmas [domain_defl_simps] = DEFL_upper DEFL_lower DEFL_convex
251.41 -lemmas [domain_map_ID] = upper_map_ID lower_map_ID convex_map_ID
251.42 -lemmas [domain_isodefl] = isodefl_upper isodefl_lower isodefl_convex
251.43 -
251.44 -lemmas [domain_deflation] =
251.45 - deflation_upper_map deflation_lower_map deflation_convex_map
251.46 -
251.47 -setup {*
251.48 - fold Domain_Take_Proofs.add_rec_type
251.49 - [(@{type_name "upper_pd"}, [true]),
251.50 - (@{type_name "lower_pd"}, [true]),
251.51 - (@{type_name "convex_pd"}, [true])]
251.52 -*}
251.53 -
251.54 -end
252.1 --- a/src/HOLCF/Product_Cpo.thy Sat Nov 27 14:34:54 2010 -0800
252.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
252.3 @@ -1,299 +0,0 @@
252.4 -(* Title: HOLCF/Product_Cpo.thy
252.5 - Author: Franz Regensburger
252.6 -*)
252.7 -
252.8 -header {* The cpo of cartesian products *}
252.9 -
252.10 -theory Product_Cpo
252.11 -imports Adm
252.12 -begin
252.13 -
252.14 -default_sort cpo
252.15 -
252.16 -subsection {* Unit type is a pcpo *}
252.17 -
252.18 -instantiation unit :: discrete_cpo
252.19 -begin
252.20 -
252.21 -definition
252.22 - below_unit_def [simp]: "x \<sqsubseteq> (y::unit) \<longleftrightarrow> True"
252.23 -
252.24 -instance proof
252.25 -qed simp
252.26 -
252.27 -end
252.28 -
252.29 -instance unit :: pcpo
252.30 -by intro_classes simp
252.31 -
252.32 -
252.33 -subsection {* Product type is a partial order *}
252.34 -
252.35 -instantiation prod :: (below, below) below
252.36 -begin
252.37 -
252.38 -definition
252.39 - below_prod_def: "(op \<sqsubseteq>) \<equiv> \<lambda>p1 p2. (fst p1 \<sqsubseteq> fst p2 \<and> snd p1 \<sqsubseteq> snd p2)"
252.40 -
252.41 -instance ..
252.42 -end
252.43 -
252.44 -instance prod :: (po, po) po
252.45 -proof
252.46 - fix x :: "'a \<times> 'b"
252.47 - show "x \<sqsubseteq> x"
252.48 - unfolding below_prod_def by simp
252.49 -next
252.50 - fix x y :: "'a \<times> 'b"
252.51 - assume "x \<sqsubseteq> y" "y \<sqsubseteq> x" thus "x = y"
252.52 - unfolding below_prod_def Pair_fst_snd_eq
252.53 - by (fast intro: below_antisym)
252.54 -next
252.55 - fix x y z :: "'a \<times> 'b"
252.56 - assume "x \<sqsubseteq> y" "y \<sqsubseteq> z" thus "x \<sqsubseteq> z"
252.57 - unfolding below_prod_def
252.58 - by (fast intro: below_trans)
252.59 -qed
252.60 -
252.61 -subsection {* Monotonicity of \emph{Pair}, \emph{fst}, \emph{snd} *}
252.62 -
252.63 -lemma prod_belowI: "\<lbrakk>fst p \<sqsubseteq> fst q; snd p \<sqsubseteq> snd q\<rbrakk> \<Longrightarrow> p \<sqsubseteq> q"
252.64 -unfolding below_prod_def by simp
252.65 -
252.66 -lemma Pair_below_iff [simp]: "(a, b) \<sqsubseteq> (c, d) \<longleftrightarrow> a \<sqsubseteq> c \<and> b \<sqsubseteq> d"
252.67 -unfolding below_prod_def by simp
252.68 -
252.69 -text {* Pair @{text "(_,_)"} is monotone in both arguments *}
252.70 -
252.71 -lemma monofun_pair1: "monofun (\<lambda>x. (x, y))"
252.72 -by (simp add: monofun_def)
252.73 -
252.74 -lemma monofun_pair2: "monofun (\<lambda>y. (x, y))"
252.75 -by (simp add: monofun_def)
252.76 -
252.77 -lemma monofun_pair:
252.78 - "\<lbrakk>x1 \<sqsubseteq> x2; y1 \<sqsubseteq> y2\<rbrakk> \<Longrightarrow> (x1, y1) \<sqsubseteq> (x2, y2)"
252.79 -by simp
252.80 -
252.81 -lemma ch2ch_Pair [simp]:
252.82 - "chain X \<Longrightarrow> chain Y \<Longrightarrow> chain (\<lambda>i. (X i, Y i))"
252.83 -by (rule chainI, simp add: chainE)
252.84 -
252.85 -text {* @{term fst} and @{term snd} are monotone *}
252.86 -
252.87 -lemma fst_monofun: "x \<sqsubseteq> y \<Longrightarrow> fst x \<sqsubseteq> fst y"
252.88 -unfolding below_prod_def by simp
252.89 -
252.90 -lemma snd_monofun: "x \<sqsubseteq> y \<Longrightarrow> snd x \<sqsubseteq> snd y"
252.91 -unfolding below_prod_def by simp
252.92 -
252.93 -lemma monofun_fst: "monofun fst"
252.94 -by (simp add: monofun_def below_prod_def)
252.95 -
252.96 -lemma monofun_snd: "monofun snd"
252.97 -by (simp add: monofun_def below_prod_def)
252.98 -
252.99 -lemmas ch2ch_fst [simp] = ch2ch_monofun [OF monofun_fst]
252.100 -
252.101 -lemmas ch2ch_snd [simp] = ch2ch_monofun [OF monofun_snd]
252.102 -
252.103 -lemma prod_chain_cases:
252.104 - assumes "chain Y"
252.105 - obtains A B
252.106 - where "chain A" and "chain B" and "Y = (\<lambda>i. (A i, B i))"
252.107 -proof
252.108 - from `chain Y` show "chain (\<lambda>i. fst (Y i))" by (rule ch2ch_fst)
252.109 - from `chain Y` show "chain (\<lambda>i. snd (Y i))" by (rule ch2ch_snd)
252.110 - show "Y = (\<lambda>i. (fst (Y i), snd (Y i)))" by simp
252.111 -qed
252.112 -
252.113 -subsection {* Product type is a cpo *}
252.114 -
252.115 -lemma is_lub_Pair:
252.116 - "\<lbrakk>range A <<| x; range B <<| y\<rbrakk> \<Longrightarrow> range (\<lambda>i. (A i, B i)) <<| (x, y)"
252.117 -unfolding is_lub_def is_ub_def ball_simps below_prod_def by simp
252.118 -
252.119 -lemma lub_Pair:
252.120 - "\<lbrakk>chain (A::nat \<Rightarrow> 'a::cpo); chain (B::nat \<Rightarrow> 'b::cpo)\<rbrakk>
252.121 - \<Longrightarrow> (\<Squnion>i. (A i, B i)) = (\<Squnion>i. A i, \<Squnion>i. B i)"
252.122 -by (fast intro: lub_eqI is_lub_Pair elim: thelubE)
252.123 -
252.124 -lemma is_lub_prod:
252.125 - fixes S :: "nat \<Rightarrow> ('a::cpo \<times> 'b::cpo)"
252.126 - assumes S: "chain S"
252.127 - shows "range S <<| (\<Squnion>i. fst (S i), \<Squnion>i. snd (S i))"
252.128 -using S by (auto elim: prod_chain_cases simp add: is_lub_Pair cpo_lubI)
252.129 -
252.130 -lemma lub_prod:
252.131 - "chain (S::nat \<Rightarrow> 'a::cpo \<times> 'b::cpo)
252.132 - \<Longrightarrow> (\<Squnion>i. S i) = (\<Squnion>i. fst (S i), \<Squnion>i. snd (S i))"
252.133 -by (rule is_lub_prod [THEN lub_eqI])
252.134 -
252.135 -instance prod :: (cpo, cpo) cpo
252.136 -proof
252.137 - fix S :: "nat \<Rightarrow> ('a \<times> 'b)"
252.138 - assume "chain S"
252.139 - hence "range S <<| (\<Squnion>i. fst (S i), \<Squnion>i. snd (S i))"
252.140 - by (rule is_lub_prod)
252.141 - thus "\<exists>x. range S <<| x" ..
252.142 -qed
252.143 -
252.144 -instance prod :: (discrete_cpo, discrete_cpo) discrete_cpo
252.145 -proof
252.146 - fix x y :: "'a \<times> 'b"
252.147 - show "x \<sqsubseteq> y \<longleftrightarrow> x = y"
252.148 - unfolding below_prod_def Pair_fst_snd_eq
252.149 - by simp
252.150 -qed
252.151 -
252.152 -subsection {* Product type is pointed *}
252.153 -
252.154 -lemma minimal_prod: "(\<bottom>, \<bottom>) \<sqsubseteq> p"
252.155 -by (simp add: below_prod_def)
252.156 -
252.157 -instance prod :: (pcpo, pcpo) pcpo
252.158 -by intro_classes (fast intro: minimal_prod)
252.159 -
252.160 -lemma inst_prod_pcpo: "\<bottom> = (\<bottom>, \<bottom>)"
252.161 -by (rule minimal_prod [THEN UU_I, symmetric])
252.162 -
252.163 -lemma Pair_bottom_iff [simp]: "(x, y) = \<bottom> \<longleftrightarrow> x = \<bottom> \<and> y = \<bottom>"
252.164 -unfolding inst_prod_pcpo by simp
252.165 -
252.166 -lemma fst_strict [simp]: "fst \<bottom> = \<bottom>"
252.167 -unfolding inst_prod_pcpo by (rule fst_conv)
252.168 -
252.169 -lemma snd_strict [simp]: "snd \<bottom> = \<bottom>"
252.170 -unfolding inst_prod_pcpo by (rule snd_conv)
252.171 -
252.172 -lemma Pair_strict [simp]: "(\<bottom>, \<bottom>) = \<bottom>"
252.173 -by simp
252.174 -
252.175 -lemma split_strict [simp]: "split f \<bottom> = f \<bottom> \<bottom>"
252.176 -unfolding split_def by simp
252.177 -
252.178 -subsection {* Continuity of \emph{Pair}, \emph{fst}, \emph{snd} *}
252.179 -
252.180 -lemma cont_pair1: "cont (\<lambda>x. (x, y))"
252.181 -apply (rule contI)
252.182 -apply (rule is_lub_Pair)
252.183 -apply (erule cpo_lubI)
252.184 -apply (rule is_lub_const)
252.185 -done
252.186 -
252.187 -lemma cont_pair2: "cont (\<lambda>y. (x, y))"
252.188 -apply (rule contI)
252.189 -apply (rule is_lub_Pair)
252.190 -apply (rule is_lub_const)
252.191 -apply (erule cpo_lubI)
252.192 -done
252.193 -
252.194 -lemma cont_fst: "cont fst"
252.195 -apply (rule contI)
252.196 -apply (simp add: lub_prod)
252.197 -apply (erule cpo_lubI [OF ch2ch_fst])
252.198 -done
252.199 -
252.200 -lemma cont_snd: "cont snd"
252.201 -apply (rule contI)
252.202 -apply (simp add: lub_prod)
252.203 -apply (erule cpo_lubI [OF ch2ch_snd])
252.204 -done
252.205 -
252.206 -lemma cont2cont_Pair [simp, cont2cont]:
252.207 - assumes f: "cont (\<lambda>x. f x)"
252.208 - assumes g: "cont (\<lambda>x. g x)"
252.209 - shows "cont (\<lambda>x. (f x, g x))"
252.210 -apply (rule cont_apply [OF f cont_pair1])
252.211 -apply (rule cont_apply [OF g cont_pair2])
252.212 -apply (rule cont_const)
252.213 -done
252.214 -
252.215 -lemmas cont2cont_fst [simp, cont2cont] = cont_compose [OF cont_fst]
252.216 -
252.217 -lemmas cont2cont_snd [simp, cont2cont] = cont_compose [OF cont_snd]
252.218 -
252.219 -lemma cont2cont_prod_case:
252.220 - assumes f1: "\<And>a b. cont (\<lambda>x. f x a b)"
252.221 - assumes f2: "\<And>x b. cont (\<lambda>a. f x a b)"
252.222 - assumes f3: "\<And>x a. cont (\<lambda>b. f x a b)"
252.223 - assumes g: "cont (\<lambda>x. g x)"
252.224 - shows "cont (\<lambda>x. case g x of (a, b) \<Rightarrow> f x a b)"
252.225 -unfolding split_def
252.226 -apply (rule cont_apply [OF g])
252.227 -apply (rule cont_apply [OF cont_fst f2])
252.228 -apply (rule cont_apply [OF cont_snd f3])
252.229 -apply (rule cont_const)
252.230 -apply (rule f1)
252.231 -done
252.232 -
252.233 -lemma prod_contI:
252.234 - assumes f1: "\<And>y. cont (\<lambda>x. f (x, y))"
252.235 - assumes f2: "\<And>x. cont (\<lambda>y. f (x, y))"
252.236 - shows "cont f"
252.237 -proof -
252.238 - have "cont (\<lambda>(x, y). f (x, y))"
252.239 - by (intro cont2cont_prod_case f1 f2 cont2cont)
252.240 - thus "cont f"
252.241 - by (simp only: split_eta)
252.242 -qed
252.243 -
252.244 -lemma prod_cont_iff:
252.245 - "cont f \<longleftrightarrow> (\<forall>y. cont (\<lambda>x. f (x, y))) \<and> (\<forall>x. cont (\<lambda>y. f (x, y)))"
252.246 -apply safe
252.247 -apply (erule cont_compose [OF _ cont_pair1])
252.248 -apply (erule cont_compose [OF _ cont_pair2])
252.249 -apply (simp only: prod_contI)
252.250 -done
252.251 -
252.252 -lemma cont2cont_prod_case' [simp, cont2cont]:
252.253 - assumes f: "cont (\<lambda>p. f (fst p) (fst (snd p)) (snd (snd p)))"
252.254 - assumes g: "cont (\<lambda>x. g x)"
252.255 - shows "cont (\<lambda>x. prod_case (f x) (g x))"
252.256 -using assms by (simp add: cont2cont_prod_case prod_cont_iff)
252.257 -
252.258 -text {* The simple version (due to Joachim Breitner) is needed if
252.259 - either element type of the pair is not a cpo. *}
252.260 -
252.261 -lemma cont2cont_split_simple [simp, cont2cont]:
252.262 - assumes "\<And>a b. cont (\<lambda>x. f x a b)"
252.263 - shows "cont (\<lambda>x. case p of (a, b) \<Rightarrow> f x a b)"
252.264 -using assms by (cases p) auto
252.265 -
252.266 -text {* Admissibility of predicates on product types. *}
252.267 -
252.268 -lemma adm_prod_case [simp]:
252.269 - assumes "adm (\<lambda>x. P x (fst (f x)) (snd (f x)))"
252.270 - shows "adm (\<lambda>x. case f x of (a, b) \<Rightarrow> P x a b)"
252.271 -unfolding prod_case_beta using assms .
252.272 -
252.273 -subsection {* Compactness and chain-finiteness *}
252.274 -
252.275 -lemma fst_below_iff: "fst (x::'a \<times> 'b) \<sqsubseteq> y \<longleftrightarrow> x \<sqsubseteq> (y, snd x)"
252.276 -unfolding below_prod_def by simp
252.277 -
252.278 -lemma snd_below_iff: "snd (x::'a \<times> 'b) \<sqsubseteq> y \<longleftrightarrow> x \<sqsubseteq> (fst x, y)"
252.279 -unfolding below_prod_def by simp
252.280 -
252.281 -lemma compact_fst: "compact x \<Longrightarrow> compact (fst x)"
252.282 -by (rule compactI, simp add: fst_below_iff)
252.283 -
252.284 -lemma compact_snd: "compact x \<Longrightarrow> compact (snd x)"
252.285 -by (rule compactI, simp add: snd_below_iff)
252.286 -
252.287 -lemma compact_Pair: "\<lbrakk>compact x; compact y\<rbrakk> \<Longrightarrow> compact (x, y)"
252.288 -by (rule compactI, simp add: below_prod_def)
252.289 -
252.290 -lemma compact_Pair_iff [simp]: "compact (x, y) \<longleftrightarrow> compact x \<and> compact y"
252.291 -apply (safe intro!: compact_Pair)
252.292 -apply (drule compact_fst, simp)
252.293 -apply (drule compact_snd, simp)
252.294 -done
252.295 -
252.296 -instance prod :: (chfin, chfin) chfin
252.297 -apply intro_classes
252.298 -apply (erule compact_imp_max_in_chain)
252.299 -apply (case_tac "\<Squnion>i. Y i", simp)
252.300 -done
252.301 -
252.302 -end
253.1 --- a/src/HOLCF/README.html Sat Nov 27 14:34:54 2010 -0800
253.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
253.3 @@ -1,45 +0,0 @@
253.4 -<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN" "http://www.w3.org/TR/html4/loose.dtd">
253.5 -
253.6 -<html>
253.7 -
253.8 -<head>
253.9 - <meta http-equiv="Content-Type" content="text/html; charset=iso-8859-1">
253.10 - <title>HOLCF/README</title>
253.11 -</head>
253.12 -
253.13 -<body>
253.14 -
253.15 -<h3>HOLCF: A higher-order version of LCF based on Isabelle/HOL</h3>
253.16 -
253.17 -HOLCF is the definitional extension of Church's Higher-Order Logic with
253.18 -Scott's Logic for Computable Functions that has been implemented in the
253.19 -theorem prover Isabelle. This results in a flexible setup for reasoning
253.20 -about functional programs. HOLCF supports standard domain theory (in particular
253.21 -fixpoint reasoning and recursive domain equations) but also coinductive
253.22 -arguments about lazy datatypes.
253.23 -
253.24 -<p>
253.25 -
253.26 -The most recent description of HOLCF is found here:
253.27 -
253.28 -<ul>
253.29 - <li><a href="/~nipkow/pubs/jfp99.html">HOLCF = HOL+LCF</a>
253.30 -</ul>
253.31 -
253.32 -A detailed description (in German) of the entire development can be found in:
253.33 -
253.34 -<ul>
253.35 - <li><a href="http://www4.informatik.tu-muenchen.de/publ/papers/Diss_Regensbu.pdf">HOLCF: eine konservative Erweiterung von HOL um LCF</a>, <br>
253.36 - Franz Regensburger.<br>
253.37 - Dissertation Technische Universität München.<br>
253.38 - Year: 1994.
253.39 -</ul>
253.40 -
253.41 -A short survey is available in:
253.42 -<ul>
253.43 - <li><a href="http://www4.informatik.tu-muenchen.de/publ/papers/Regensburger_HOLT1995.pdf">HOLCF: Higher Order Logic of Computable Functions</a><br>
253.44 -</ul>
253.45 -
253.46 -</body>
253.47 -
253.48 -</html>
254.1 --- a/src/HOLCF/ROOT.ML Sat Nov 27 14:34:54 2010 -0800
254.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
254.3 @@ -1,9 +0,0 @@
254.4 -(* Title: HOLCF/ROOT.ML
254.5 - Author: Franz Regensburger
254.6 -
254.7 -HOLCF -- a semantic extension of HOL by the LCF logic.
254.8 -*)
254.9 -
254.10 -no_document use_thys ["Nat_Bijection", "Countable"];
254.11 -
254.12 -use_thys ["Plain_HOLCF", "Fixrec", "HOLCF"];
255.1 --- a/src/HOLCF/Sfun.thy Sat Nov 27 14:34:54 2010 -0800
255.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
255.3 @@ -1,62 +0,0 @@
255.4 -(* Title: HOLCF/Sfun.thy
255.5 - Author: Brian Huffman
255.6 -*)
255.7 -
255.8 -header {* The Strict Function Type *}
255.9 -
255.10 -theory Sfun
255.11 -imports Cfun
255.12 -begin
255.13 -
255.14 -pcpodef (open) ('a, 'b) sfun (infixr "->!" 0)
255.15 - = "{f :: 'a \<rightarrow> 'b. f\<cdot>\<bottom> = \<bottom>}"
255.16 -by simp_all
255.17 -
255.18 -type_notation (xsymbols)
255.19 - sfun (infixr "\<rightarrow>!" 0)
255.20 -
255.21 -text {* TODO: Define nice syntax for abstraction, application. *}
255.22 -
255.23 -definition
255.24 - sfun_abs :: "('a \<rightarrow> 'b) \<rightarrow> ('a \<rightarrow>! 'b)"
255.25 -where
255.26 - "sfun_abs = (\<Lambda> f. Abs_sfun (strictify\<cdot>f))"
255.27 -
255.28 -definition
255.29 - sfun_rep :: "('a \<rightarrow>! 'b) \<rightarrow> 'a \<rightarrow> 'b"
255.30 -where
255.31 - "sfun_rep = (\<Lambda> f. Rep_sfun f)"
255.32 -
255.33 -lemma sfun_rep_beta: "sfun_rep\<cdot>f = Rep_sfun f"
255.34 - unfolding sfun_rep_def by (simp add: cont_Rep_sfun)
255.35 -
255.36 -lemma sfun_rep_strict1 [simp]: "sfun_rep\<cdot>\<bottom> = \<bottom>"
255.37 - unfolding sfun_rep_beta by (rule Rep_sfun_strict)
255.38 -
255.39 -lemma sfun_rep_strict2 [simp]: "sfun_rep\<cdot>f\<cdot>\<bottom> = \<bottom>"
255.40 - unfolding sfun_rep_beta by (rule Rep_sfun [simplified])
255.41 -
255.42 -lemma strictify_cancel: "f\<cdot>\<bottom> = \<bottom> \<Longrightarrow> strictify\<cdot>f = f"
255.43 - by (simp add: cfun_eq_iff strictify_conv_if)
255.44 -
255.45 -lemma sfun_abs_sfun_rep [simp]: "sfun_abs\<cdot>(sfun_rep\<cdot>f) = f"
255.46 - unfolding sfun_abs_def sfun_rep_def
255.47 - apply (simp add: cont_Abs_sfun cont_Rep_sfun)
255.48 - apply (simp add: Rep_sfun_inject [symmetric] Abs_sfun_inverse)
255.49 - apply (simp add: cfun_eq_iff strictify_conv_if)
255.50 - apply (simp add: Rep_sfun [simplified])
255.51 - done
255.52 -
255.53 -lemma sfun_rep_sfun_abs [simp]: "sfun_rep\<cdot>(sfun_abs\<cdot>f) = strictify\<cdot>f"
255.54 - unfolding sfun_abs_def sfun_rep_def
255.55 - apply (simp add: cont_Abs_sfun cont_Rep_sfun)
255.56 - apply (simp add: Abs_sfun_inverse)
255.57 - done
255.58 -
255.59 -lemma sfun_eq_iff: "f = g \<longleftrightarrow> sfun_rep\<cdot>f = sfun_rep\<cdot>g"
255.60 -by (simp add: sfun_rep_def cont_Rep_sfun Rep_sfun_inject)
255.61 -
255.62 -lemma sfun_below_iff: "f \<sqsubseteq> g \<longleftrightarrow> sfun_rep\<cdot>f \<sqsubseteq> sfun_rep\<cdot>g"
255.63 -by (simp add: sfun_rep_def cont_Rep_sfun below_sfun_def)
255.64 -
255.65 -end
256.1 --- a/src/HOLCF/Sprod.thy Sat Nov 27 14:34:54 2010 -0800
256.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
256.3 @@ -1,214 +0,0 @@
256.4 -(* Title: HOLCF/Sprod.thy
256.5 - Author: Franz Regensburger
256.6 - Author: Brian Huffman
256.7 -*)
256.8 -
256.9 -header {* The type of strict products *}
256.10 -
256.11 -theory Sprod
256.12 -imports Cfun
256.13 -begin
256.14 -
256.15 -default_sort pcpo
256.16 -
256.17 -subsection {* Definition of strict product type *}
256.18 -
256.19 -pcpodef ('a, 'b) sprod (infixr "**" 20) =
256.20 - "{p::'a \<times> 'b. p = \<bottom> \<or> (fst p \<noteq> \<bottom> \<and> snd p \<noteq> \<bottom>)}"
256.21 -by simp_all
256.22 -
256.23 -instance sprod :: ("{chfin,pcpo}", "{chfin,pcpo}") chfin
256.24 -by (rule typedef_chfin [OF type_definition_sprod below_sprod_def])
256.25 -
256.26 -type_notation (xsymbols)
256.27 - sprod ("(_ \<otimes>/ _)" [21,20] 20)
256.28 -type_notation (HTML output)
256.29 - sprod ("(_ \<otimes>/ _)" [21,20] 20)
256.30 -
256.31 -subsection {* Definitions of constants *}
256.32 -
256.33 -definition
256.34 - sfst :: "('a ** 'b) \<rightarrow> 'a" where
256.35 - "sfst = (\<Lambda> p. fst (Rep_sprod p))"
256.36 -
256.37 -definition
256.38 - ssnd :: "('a ** 'b) \<rightarrow> 'b" where
256.39 - "ssnd = (\<Lambda> p. snd (Rep_sprod p))"
256.40 -
256.41 -definition
256.42 - spair :: "'a \<rightarrow> 'b \<rightarrow> ('a ** 'b)" where
256.43 - "spair = (\<Lambda> a b. Abs_sprod (seq\<cdot>b\<cdot>a, seq\<cdot>a\<cdot>b))"
256.44 -
256.45 -definition
256.46 - ssplit :: "('a \<rightarrow> 'b \<rightarrow> 'c) \<rightarrow> ('a ** 'b) \<rightarrow> 'c" where
256.47 - "ssplit = (\<Lambda> f p. seq\<cdot>p\<cdot>(f\<cdot>(sfst\<cdot>p)\<cdot>(ssnd\<cdot>p)))"
256.48 -
256.49 -syntax
256.50 - "_stuple" :: "['a, args] => 'a ** 'b" ("(1'(:_,/ _:'))")
256.51 -translations
256.52 - "(:x, y, z:)" == "(:x, (:y, z:):)"
256.53 - "(:x, y:)" == "CONST spair\<cdot>x\<cdot>y"
256.54 -
256.55 -translations
256.56 - "\<Lambda>(CONST spair\<cdot>x\<cdot>y). t" == "CONST ssplit\<cdot>(\<Lambda> x y. t)"
256.57 -
256.58 -subsection {* Case analysis *}
256.59 -
256.60 -lemma spair_sprod: "(seq\<cdot>b\<cdot>a, seq\<cdot>a\<cdot>b) \<in> sprod"
256.61 -by (simp add: sprod_def seq_conv_if)
256.62 -
256.63 -lemma Rep_sprod_spair: "Rep_sprod (:a, b:) = (seq\<cdot>b\<cdot>a, seq\<cdot>a\<cdot>b)"
256.64 -by (simp add: spair_def cont_Abs_sprod Abs_sprod_inverse spair_sprod)
256.65 -
256.66 -lemmas Rep_sprod_simps =
256.67 - Rep_sprod_inject [symmetric] below_sprod_def
256.68 - Pair_fst_snd_eq below_prod_def
256.69 - Rep_sprod_strict Rep_sprod_spair
256.70 -
256.71 -lemma sprodE [case_names bottom spair, cases type: sprod]:
256.72 - obtains "p = \<bottom>" | x y where "p = (:x, y:)" and "x \<noteq> \<bottom>" and "y \<noteq> \<bottom>"
256.73 -using Rep_sprod [of p] by (auto simp add: sprod_def Rep_sprod_simps)
256.74 -
256.75 -lemma sprod_induct [case_names bottom spair, induct type: sprod]:
256.76 - "\<lbrakk>P \<bottom>; \<And>x y. \<lbrakk>x \<noteq> \<bottom>; y \<noteq> \<bottom>\<rbrakk> \<Longrightarrow> P (:x, y:)\<rbrakk> \<Longrightarrow> P x"
256.77 -by (cases x, simp_all)
256.78 -
256.79 -subsection {* Properties of \emph{spair} *}
256.80 -
256.81 -lemma spair_strict1 [simp]: "(:\<bottom>, y:) = \<bottom>"
256.82 -by (simp add: Rep_sprod_simps)
256.83 -
256.84 -lemma spair_strict2 [simp]: "(:x, \<bottom>:) = \<bottom>"
256.85 -by (simp add: Rep_sprod_simps)
256.86 -
256.87 -lemma spair_bottom_iff [simp]: "((:x, y:) = \<bottom>) = (x = \<bottom> \<or> y = \<bottom>)"
256.88 -by (simp add: Rep_sprod_simps seq_conv_if)
256.89 -
256.90 -lemma spair_below_iff:
256.91 - "((:a, b:) \<sqsubseteq> (:c, d:)) = (a = \<bottom> \<or> b = \<bottom> \<or> (a \<sqsubseteq> c \<and> b \<sqsubseteq> d))"
256.92 -by (simp add: Rep_sprod_simps seq_conv_if)
256.93 -
256.94 -lemma spair_eq_iff:
256.95 - "((:a, b:) = (:c, d:)) =
256.96 - (a = c \<and> b = d \<or> (a = \<bottom> \<or> b = \<bottom>) \<and> (c = \<bottom> \<or> d = \<bottom>))"
256.97 -by (simp add: Rep_sprod_simps seq_conv_if)
256.98 -
256.99 -lemma spair_strict: "x = \<bottom> \<or> y = \<bottom> \<Longrightarrow> (:x, y:) = \<bottom>"
256.100 -by simp
256.101 -
256.102 -lemma spair_strict_rev: "(:x, y:) \<noteq> \<bottom> \<Longrightarrow> x \<noteq> \<bottom> \<and> y \<noteq> \<bottom>"
256.103 -by simp
256.104 -
256.105 -lemma spair_defined: "\<lbrakk>x \<noteq> \<bottom>; y \<noteq> \<bottom>\<rbrakk> \<Longrightarrow> (:x, y:) \<noteq> \<bottom>"
256.106 -by simp
256.107 -
256.108 -lemma spair_defined_rev: "(:x, y:) = \<bottom> \<Longrightarrow> x = \<bottom> \<or> y = \<bottom>"
256.109 -by simp
256.110 -
256.111 -lemma spair_below:
256.112 - "\<lbrakk>x \<noteq> \<bottom>; y \<noteq> \<bottom>\<rbrakk> \<Longrightarrow> (:x, y:) \<sqsubseteq> (:a, b:) = (x \<sqsubseteq> a \<and> y \<sqsubseteq> b)"
256.113 -by (simp add: spair_below_iff)
256.114 -
256.115 -lemma spair_eq:
256.116 - "\<lbrakk>x \<noteq> \<bottom>; y \<noteq> \<bottom>\<rbrakk> \<Longrightarrow> ((:x, y:) = (:a, b:)) = (x = a \<and> y = b)"
256.117 -by (simp add: spair_eq_iff)
256.118 -
256.119 -lemma spair_inject:
256.120 - "\<lbrakk>x \<noteq> \<bottom>; y \<noteq> \<bottom>; (:x, y:) = (:a, b:)\<rbrakk> \<Longrightarrow> x = a \<and> y = b"
256.121 -by (rule spair_eq [THEN iffD1])
256.122 -
256.123 -lemma inst_sprod_pcpo2: "UU = (:UU,UU:)"
256.124 -by simp
256.125 -
256.126 -lemma sprodE2: "(\<And>x y. p = (:x, y:) \<Longrightarrow> Q) \<Longrightarrow> Q"
256.127 -by (cases p, simp only: inst_sprod_pcpo2, simp)
256.128 -
256.129 -subsection {* Properties of \emph{sfst} and \emph{ssnd} *}
256.130 -
256.131 -lemma sfst_strict [simp]: "sfst\<cdot>\<bottom> = \<bottom>"
256.132 -by (simp add: sfst_def cont_Rep_sprod Rep_sprod_strict)
256.133 -
256.134 -lemma ssnd_strict [simp]: "ssnd\<cdot>\<bottom> = \<bottom>"
256.135 -by (simp add: ssnd_def cont_Rep_sprod Rep_sprod_strict)
256.136 -
256.137 -lemma sfst_spair [simp]: "y \<noteq> \<bottom> \<Longrightarrow> sfst\<cdot>(:x, y:) = x"
256.138 -by (simp add: sfst_def cont_Rep_sprod Rep_sprod_spair)
256.139 -
256.140 -lemma ssnd_spair [simp]: "x \<noteq> \<bottom> \<Longrightarrow> ssnd\<cdot>(:x, y:) = y"
256.141 -by (simp add: ssnd_def cont_Rep_sprod Rep_sprod_spair)
256.142 -
256.143 -lemma sfst_bottom_iff [simp]: "(sfst\<cdot>p = \<bottom>) = (p = \<bottom>)"
256.144 -by (cases p, simp_all)
256.145 -
256.146 -lemma ssnd_bottom_iff [simp]: "(ssnd\<cdot>p = \<bottom>) = (p = \<bottom>)"
256.147 -by (cases p, simp_all)
256.148 -
256.149 -lemma sfst_defined: "p \<noteq> \<bottom> \<Longrightarrow> sfst\<cdot>p \<noteq> \<bottom>"
256.150 -by simp
256.151 -
256.152 -lemma ssnd_defined: "p \<noteq> \<bottom> \<Longrightarrow> ssnd\<cdot>p \<noteq> \<bottom>"
256.153 -by simp
256.154 -
256.155 -lemma spair_sfst_ssnd: "(:sfst\<cdot>p, ssnd\<cdot>p:) = p"
256.156 -by (cases p, simp_all)
256.157 -
256.158 -lemma below_sprod: "(x \<sqsubseteq> y) = (sfst\<cdot>x \<sqsubseteq> sfst\<cdot>y \<and> ssnd\<cdot>x \<sqsubseteq> ssnd\<cdot>y)"
256.159 -by (simp add: Rep_sprod_simps sfst_def ssnd_def cont_Rep_sprod)
256.160 -
256.161 -lemma eq_sprod: "(x = y) = (sfst\<cdot>x = sfst\<cdot>y \<and> ssnd\<cdot>x = ssnd\<cdot>y)"
256.162 -by (auto simp add: po_eq_conv below_sprod)
256.163 -
256.164 -lemma sfst_below_iff: "sfst\<cdot>x \<sqsubseteq> y \<longleftrightarrow> x \<sqsubseteq> (:y, ssnd\<cdot>x:)"
256.165 -apply (cases "x = \<bottom>", simp, cases "y = \<bottom>", simp)
256.166 -apply (simp add: below_sprod)
256.167 -done
256.168 -
256.169 -lemma ssnd_below_iff: "ssnd\<cdot>x \<sqsubseteq> y \<longleftrightarrow> x \<sqsubseteq> (:sfst\<cdot>x, y:)"
256.170 -apply (cases "x = \<bottom>", simp, cases "y = \<bottom>", simp)
256.171 -apply (simp add: below_sprod)
256.172 -done
256.173 -
256.174 -subsection {* Compactness *}
256.175 -
256.176 -lemma compact_sfst: "compact x \<Longrightarrow> compact (sfst\<cdot>x)"
256.177 -by (rule compactI, simp add: sfst_below_iff)
256.178 -
256.179 -lemma compact_ssnd: "compact x \<Longrightarrow> compact (ssnd\<cdot>x)"
256.180 -by (rule compactI, simp add: ssnd_below_iff)
256.181 -
256.182 -lemma compact_spair: "\<lbrakk>compact x; compact y\<rbrakk> \<Longrightarrow> compact (:x, y:)"
256.183 -by (rule compact_sprod, simp add: Rep_sprod_spair seq_conv_if)
256.184 -
256.185 -lemma compact_spair_iff:
256.186 - "compact (:x, y:) = (x = \<bottom> \<or> y = \<bottom> \<or> (compact x \<and> compact y))"
256.187 -apply (safe elim!: compact_spair)
256.188 -apply (drule compact_sfst, simp)
256.189 -apply (drule compact_ssnd, simp)
256.190 -apply simp
256.191 -apply simp
256.192 -done
256.193 -
256.194 -subsection {* Properties of \emph{ssplit} *}
256.195 -
256.196 -lemma ssplit1 [simp]: "ssplit\<cdot>f\<cdot>\<bottom> = \<bottom>"
256.197 -by (simp add: ssplit_def)
256.198 -
256.199 -lemma ssplit2 [simp]: "\<lbrakk>x \<noteq> \<bottom>; y \<noteq> \<bottom>\<rbrakk> \<Longrightarrow> ssplit\<cdot>f\<cdot>(:x, y:) = f\<cdot>x\<cdot>y"
256.200 -by (simp add: ssplit_def)
256.201 -
256.202 -lemma ssplit3 [simp]: "ssplit\<cdot>spair\<cdot>z = z"
256.203 -by (cases z, simp_all)
256.204 -
256.205 -subsection {* Strict product preserves flatness *}
256.206 -
256.207 -instance sprod :: (flat, flat) flat
256.208 -proof
256.209 - fix x y :: "'a \<otimes> 'b"
256.210 - assume "x \<sqsubseteq> y" thus "x = \<bottom> \<or> x = y"
256.211 - apply (induct x, simp)
256.212 - apply (induct y, simp)
256.213 - apply (simp add: spair_below_iff flat_below_iff)
256.214 - done
256.215 -qed
256.216 -
256.217 -end
257.1 --- a/src/HOLCF/Ssum.thy Sat Nov 27 14:34:54 2010 -0800
257.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
257.3 @@ -1,198 +0,0 @@
257.4 -(* Title: HOLCF/Ssum.thy
257.5 - Author: Franz Regensburger
257.6 - Author: Brian Huffman
257.7 -*)
257.8 -
257.9 -header {* The type of strict sums *}
257.10 -
257.11 -theory Ssum
257.12 -imports Tr
257.13 -begin
257.14 -
257.15 -default_sort pcpo
257.16 -
257.17 -subsection {* Definition of strict sum type *}
257.18 -
257.19 -pcpodef ('a, 'b) ssum (infixr "++" 10) =
257.20 - "{p :: tr \<times> ('a \<times> 'b). p = \<bottom> \<or>
257.21 - (fst p = TT \<and> fst (snd p) \<noteq> \<bottom> \<and> snd (snd p) = \<bottom>) \<or>
257.22 - (fst p = FF \<and> fst (snd p) = \<bottom> \<and> snd (snd p) \<noteq> \<bottom>) }"
257.23 -by simp_all
257.24 -
257.25 -instance ssum :: ("{chfin,pcpo}", "{chfin,pcpo}") chfin
257.26 -by (rule typedef_chfin [OF type_definition_ssum below_ssum_def])
257.27 -
257.28 -type_notation (xsymbols)
257.29 - ssum ("(_ \<oplus>/ _)" [21, 20] 20)
257.30 -type_notation (HTML output)
257.31 - ssum ("(_ \<oplus>/ _)" [21, 20] 20)
257.32 -
257.33 -
257.34 -subsection {* Definitions of constructors *}
257.35 -
257.36 -definition
257.37 - sinl :: "'a \<rightarrow> ('a ++ 'b)" where
257.38 - "sinl = (\<Lambda> a. Abs_ssum (seq\<cdot>a\<cdot>TT, a, \<bottom>))"
257.39 -
257.40 -definition
257.41 - sinr :: "'b \<rightarrow> ('a ++ 'b)" where
257.42 - "sinr = (\<Lambda> b. Abs_ssum (seq\<cdot>b\<cdot>FF, \<bottom>, b))"
257.43 -
257.44 -lemma sinl_ssum: "(seq\<cdot>a\<cdot>TT, a, \<bottom>) \<in> ssum"
257.45 -by (simp add: ssum_def seq_conv_if)
257.46 -
257.47 -lemma sinr_ssum: "(seq\<cdot>b\<cdot>FF, \<bottom>, b) \<in> ssum"
257.48 -by (simp add: ssum_def seq_conv_if)
257.49 -
257.50 -lemma Rep_ssum_sinl: "Rep_ssum (sinl\<cdot>a) = (seq\<cdot>a\<cdot>TT, a, \<bottom>)"
257.51 -by (simp add: sinl_def cont_Abs_ssum Abs_ssum_inverse sinl_ssum)
257.52 -
257.53 -lemma Rep_ssum_sinr: "Rep_ssum (sinr\<cdot>b) = (seq\<cdot>b\<cdot>FF, \<bottom>, b)"
257.54 -by (simp add: sinr_def cont_Abs_ssum Abs_ssum_inverse sinr_ssum)
257.55 -
257.56 -lemmas Rep_ssum_simps =
257.57 - Rep_ssum_inject [symmetric] below_ssum_def
257.58 - Pair_fst_snd_eq below_prod_def
257.59 - Rep_ssum_strict Rep_ssum_sinl Rep_ssum_sinr
257.60 -
257.61 -subsection {* Properties of \emph{sinl} and \emph{sinr} *}
257.62 -
257.63 -text {* Ordering *}
257.64 -
257.65 -lemma sinl_below [simp]: "(sinl\<cdot>x \<sqsubseteq> sinl\<cdot>y) = (x \<sqsubseteq> y)"
257.66 -by (simp add: Rep_ssum_simps seq_conv_if)
257.67 -
257.68 -lemma sinr_below [simp]: "(sinr\<cdot>x \<sqsubseteq> sinr\<cdot>y) = (x \<sqsubseteq> y)"
257.69 -by (simp add: Rep_ssum_simps seq_conv_if)
257.70 -
257.71 -lemma sinl_below_sinr [simp]: "(sinl\<cdot>x \<sqsubseteq> sinr\<cdot>y) = (x = \<bottom>)"
257.72 -by (simp add: Rep_ssum_simps seq_conv_if)
257.73 -
257.74 -lemma sinr_below_sinl [simp]: "(sinr\<cdot>x \<sqsubseteq> sinl\<cdot>y) = (x = \<bottom>)"
257.75 -by (simp add: Rep_ssum_simps seq_conv_if)
257.76 -
257.77 -text {* Equality *}
257.78 -
257.79 -lemma sinl_eq [simp]: "(sinl\<cdot>x = sinl\<cdot>y) = (x = y)"
257.80 -by (simp add: po_eq_conv)
257.81 -
257.82 -lemma sinr_eq [simp]: "(sinr\<cdot>x = sinr\<cdot>y) = (x = y)"
257.83 -by (simp add: po_eq_conv)
257.84 -
257.85 -lemma sinl_eq_sinr [simp]: "(sinl\<cdot>x = sinr\<cdot>y) = (x = \<bottom> \<and> y = \<bottom>)"
257.86 -by (subst po_eq_conv, simp)
257.87 -
257.88 -lemma sinr_eq_sinl [simp]: "(sinr\<cdot>x = sinl\<cdot>y) = (x = \<bottom> \<and> y = \<bottom>)"
257.89 -by (subst po_eq_conv, simp)
257.90 -
257.91 -lemma sinl_inject: "sinl\<cdot>x = sinl\<cdot>y \<Longrightarrow> x = y"
257.92 -by (rule sinl_eq [THEN iffD1])
257.93 -
257.94 -lemma sinr_inject: "sinr\<cdot>x = sinr\<cdot>y \<Longrightarrow> x = y"
257.95 -by (rule sinr_eq [THEN iffD1])
257.96 -
257.97 -text {* Strictness *}
257.98 -
257.99 -lemma sinl_strict [simp]: "sinl\<cdot>\<bottom> = \<bottom>"
257.100 -by (simp add: Rep_ssum_simps)
257.101 -
257.102 -lemma sinr_strict [simp]: "sinr\<cdot>\<bottom> = \<bottom>"
257.103 -by (simp add: Rep_ssum_simps)
257.104 -
257.105 -lemma sinl_bottom_iff [simp]: "(sinl\<cdot>x = \<bottom>) = (x = \<bottom>)"
257.106 -using sinl_eq [of "x" "\<bottom>"] by simp
257.107 -
257.108 -lemma sinr_bottom_iff [simp]: "(sinr\<cdot>x = \<bottom>) = (x = \<bottom>)"
257.109 -using sinr_eq [of "x" "\<bottom>"] by simp
257.110 -
257.111 -lemma sinl_defined: "x \<noteq> \<bottom> \<Longrightarrow> sinl\<cdot>x \<noteq> \<bottom>"
257.112 -by simp
257.113 -
257.114 -lemma sinr_defined: "x \<noteq> \<bottom> \<Longrightarrow> sinr\<cdot>x \<noteq> \<bottom>"
257.115 -by simp
257.116 -
257.117 -text {* Compactness *}
257.118 -
257.119 -lemma compact_sinl: "compact x \<Longrightarrow> compact (sinl\<cdot>x)"
257.120 -by (rule compact_ssum, simp add: Rep_ssum_sinl)
257.121 -
257.122 -lemma compact_sinr: "compact x \<Longrightarrow> compact (sinr\<cdot>x)"
257.123 -by (rule compact_ssum, simp add: Rep_ssum_sinr)
257.124 -
257.125 -lemma compact_sinlD: "compact (sinl\<cdot>x) \<Longrightarrow> compact x"
257.126 -unfolding compact_def
257.127 -by (drule adm_subst [OF cont_Rep_cfun2 [where f=sinl]], simp)
257.128 -
257.129 -lemma compact_sinrD: "compact (sinr\<cdot>x) \<Longrightarrow> compact x"
257.130 -unfolding compact_def
257.131 -by (drule adm_subst [OF cont_Rep_cfun2 [where f=sinr]], simp)
257.132 -
257.133 -lemma compact_sinl_iff [simp]: "compact (sinl\<cdot>x) = compact x"
257.134 -by (safe elim!: compact_sinl compact_sinlD)
257.135 -
257.136 -lemma compact_sinr_iff [simp]: "compact (sinr\<cdot>x) = compact x"
257.137 -by (safe elim!: compact_sinr compact_sinrD)
257.138 -
257.139 -subsection {* Case analysis *}
257.140 -
257.141 -lemma ssumE [case_names bottom sinl sinr, cases type: ssum]:
257.142 - obtains "p = \<bottom>"
257.143 - | x where "p = sinl\<cdot>x" and "x \<noteq> \<bottom>"
257.144 - | y where "p = sinr\<cdot>y" and "y \<noteq> \<bottom>"
257.145 -using Rep_ssum [of p] by (auto simp add: ssum_def Rep_ssum_simps)
257.146 -
257.147 -lemma ssum_induct [case_names bottom sinl sinr, induct type: ssum]:
257.148 - "\<lbrakk>P \<bottom>;
257.149 - \<And>x. x \<noteq> \<bottom> \<Longrightarrow> P (sinl\<cdot>x);
257.150 - \<And>y. y \<noteq> \<bottom> \<Longrightarrow> P (sinr\<cdot>y)\<rbrakk> \<Longrightarrow> P x"
257.151 -by (cases x, simp_all)
257.152 -
257.153 -lemma ssumE2 [case_names sinl sinr]:
257.154 - "\<lbrakk>\<And>x. p = sinl\<cdot>x \<Longrightarrow> Q; \<And>y. p = sinr\<cdot>y \<Longrightarrow> Q\<rbrakk> \<Longrightarrow> Q"
257.155 -by (cases p, simp only: sinl_strict [symmetric], simp, simp)
257.156 -
257.157 -lemma below_sinlD: "p \<sqsubseteq> sinl\<cdot>x \<Longrightarrow> \<exists>y. p = sinl\<cdot>y \<and> y \<sqsubseteq> x"
257.158 -by (cases p, rule_tac x="\<bottom>" in exI, simp_all)
257.159 -
257.160 -lemma below_sinrD: "p \<sqsubseteq> sinr\<cdot>x \<Longrightarrow> \<exists>y. p = sinr\<cdot>y \<and> y \<sqsubseteq> x"
257.161 -by (cases p, rule_tac x="\<bottom>" in exI, simp_all)
257.162 -
257.163 -subsection {* Case analysis combinator *}
257.164 -
257.165 -definition
257.166 - sscase :: "('a \<rightarrow> 'c) \<rightarrow> ('b \<rightarrow> 'c) \<rightarrow> ('a ++ 'b) \<rightarrow> 'c" where
257.167 - "sscase = (\<Lambda> f g s. (\<lambda>(t, x, y). If t then f\<cdot>x else g\<cdot>y) (Rep_ssum s))"
257.168 -
257.169 -translations
257.170 - "case s of XCONST sinl\<cdot>x \<Rightarrow> t1 | XCONST sinr\<cdot>y \<Rightarrow> t2" == "CONST sscase\<cdot>(\<Lambda> x. t1)\<cdot>(\<Lambda> y. t2)\<cdot>s"
257.171 -
257.172 -translations
257.173 - "\<Lambda>(XCONST sinl\<cdot>x). t" == "CONST sscase\<cdot>(\<Lambda> x. t)\<cdot>\<bottom>"
257.174 - "\<Lambda>(XCONST sinr\<cdot>y). t" == "CONST sscase\<cdot>\<bottom>\<cdot>(\<Lambda> y. t)"
257.175 -
257.176 -lemma beta_sscase:
257.177 - "sscase\<cdot>f\<cdot>g\<cdot>s = (\<lambda>(t, x, y). If t then f\<cdot>x else g\<cdot>y) (Rep_ssum s)"
257.178 -unfolding sscase_def by (simp add: cont_Rep_ssum [THEN cont_compose])
257.179 -
257.180 -lemma sscase1 [simp]: "sscase\<cdot>f\<cdot>g\<cdot>\<bottom> = \<bottom>"
257.181 -unfolding beta_sscase by (simp add: Rep_ssum_strict)
257.182 -
257.183 -lemma sscase2 [simp]: "x \<noteq> \<bottom> \<Longrightarrow> sscase\<cdot>f\<cdot>g\<cdot>(sinl\<cdot>x) = f\<cdot>x"
257.184 -unfolding beta_sscase by (simp add: Rep_ssum_sinl)
257.185 -
257.186 -lemma sscase3 [simp]: "y \<noteq> \<bottom> \<Longrightarrow> sscase\<cdot>f\<cdot>g\<cdot>(sinr\<cdot>y) = g\<cdot>y"
257.187 -unfolding beta_sscase by (simp add: Rep_ssum_sinr)
257.188 -
257.189 -lemma sscase4 [simp]: "sscase\<cdot>sinl\<cdot>sinr\<cdot>z = z"
257.190 -by (cases z, simp_all)
257.191 -
257.192 -subsection {* Strict sum preserves flatness *}
257.193 -
257.194 -instance ssum :: (flat, flat) flat
257.195 -apply (intro_classes, clarify)
257.196 -apply (case_tac x, simp)
257.197 -apply (case_tac y, simp_all add: flat_below_iff)
257.198 -apply (case_tac y, simp_all add: flat_below_iff)
257.199 -done
257.200 -
257.201 -end
258.1 --- a/src/HOLCF/Tools/Domain/domain.ML Sat Nov 27 14:34:54 2010 -0800
258.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
258.3 @@ -1,266 +0,0 @@
258.4 -(* Title: HOLCF/Tools/Domain/domain.ML
258.5 - Author: David von Oheimb
258.6 - Author: Brian Huffman
258.7 -
258.8 -Theory extender for domain command, including theory syntax.
258.9 -*)
258.10 -
258.11 -signature DOMAIN =
258.12 -sig
258.13 - val add_domain_cmd:
258.14 - ((string * string option) list * binding * mixfix *
258.15 - (binding * (bool * binding option * string) list * mixfix) list) list
258.16 - -> theory -> theory
258.17 -
258.18 - val add_domain:
258.19 - ((string * sort) list * binding * mixfix *
258.20 - (binding * (bool * binding option * typ) list * mixfix) list) list
258.21 - -> theory -> theory
258.22 -
258.23 - val add_new_domain_cmd:
258.24 - ((string * string option) list * binding * mixfix *
258.25 - (binding * (bool * binding option * string) list * mixfix) list) list
258.26 - -> theory -> theory
258.27 -
258.28 - val add_new_domain:
258.29 - ((string * sort) list * binding * mixfix *
258.30 - (binding * (bool * binding option * typ) list * mixfix) list) list
258.31 - -> theory -> theory
258.32 -end;
258.33 -
258.34 -structure Domain :> DOMAIN =
258.35 -struct
258.36 -
258.37 -open HOLCF_Library;
258.38 -
258.39 -fun first (x,_,_) = x;
258.40 -fun second (_,x,_) = x;
258.41 -fun third (_,_,x) = x;
258.42 -
258.43 -(* ----- calls for building new thy and thms -------------------------------- *)
258.44 -
258.45 -type info =
258.46 - Domain_Take_Proofs.iso_info list * Domain_Take_Proofs.take_induct_info;
258.47 -
258.48 -fun add_arity ((b, sorts, mx), sort) thy : theory =
258.49 - thy
258.50 - |> Sign.add_types [(b, length sorts, mx)]
258.51 - |> AxClass.axiomatize_arity (Sign.full_name thy b, sorts, sort);
258.52 -
258.53 -fun gen_add_domain
258.54 - (prep_sort : theory -> 'a -> sort)
258.55 - (prep_typ : theory -> (string * sort) list -> 'b -> typ)
258.56 - (add_isos : (binding * mixfix * (typ * typ)) list -> theory -> info * theory)
258.57 - (arg_sort : bool -> sort)
258.58 - (raw_specs : ((string * 'a) list * binding * mixfix *
258.59 - (binding * (bool * binding option * 'b) list * mixfix) list) list)
258.60 - (thy : theory) =
258.61 - let
258.62 - val dtnvs : (binding * typ list * mixfix) list =
258.63 - let
258.64 - fun prep_tvar (a, s) = TFree (a, prep_sort thy s);
258.65 - in
258.66 - map (fn (vs, dbind, mx, _) =>
258.67 - (dbind, map prep_tvar vs, mx)) raw_specs
258.68 - end;
258.69 -
258.70 - fun thy_arity (dbind, tvars, mx) =
258.71 - ((dbind, map (snd o dest_TFree) tvars, mx), arg_sort false);
258.72 -
258.73 - (* this theory is used just for parsing and error checking *)
258.74 - val tmp_thy = thy
258.75 - |> Theory.copy
258.76 - |> fold (add_arity o thy_arity) dtnvs;
258.77 -
258.78 - val dbinds : binding list =
258.79 - map (fn (_,dbind,_,_) => dbind) raw_specs;
258.80 - val raw_rhss :
258.81 - (binding * (bool * binding option * 'b) list * mixfix) list list =
258.82 - map (fn (_,_,_,cons) => cons) raw_specs;
258.83 - val dtnvs' : (string * typ list) list =
258.84 - map (fn (dbind, vs, mx) => (Sign.full_name thy dbind, vs)) dtnvs;
258.85 -
258.86 - val all_cons = map (Binding.name_of o first) (flat raw_rhss);
258.87 - val test_dupl_cons =
258.88 - case duplicates (op =) all_cons of
258.89 - [] => false | dups => error ("Duplicate constructors: "
258.90 - ^ commas_quote dups);
258.91 - val all_sels =
258.92 - (map Binding.name_of o map_filter second o maps second) (flat raw_rhss);
258.93 - val test_dupl_sels =
258.94 - case duplicates (op =) all_sels of
258.95 - [] => false | dups => error("Duplicate selectors: "^commas_quote dups);
258.96 -
258.97 - fun test_dupl_tvars s =
258.98 - case duplicates (op =) (map(fst o dest_TFree)s) of
258.99 - [] => false | dups => error("Duplicate type arguments: "
258.100 - ^commas_quote dups);
258.101 - val test_dupl_tvars' = exists test_dupl_tvars (map snd dtnvs');
258.102 -
258.103 - val sorts : (string * sort) list =
258.104 - let val all_sorts = map (map dest_TFree o snd) dtnvs';
258.105 - in
258.106 - case distinct (eq_set (op =)) all_sorts of
258.107 - [sorts] => sorts
258.108 - | _ => error "Mutually recursive domains must have same type parameters"
258.109 - end;
258.110 -
258.111 - (* a lazy argument may have an unpointed type *)
258.112 - (* unless the argument has a selector function *)
258.113 - fun check_pcpo (lazy, sel, T) =
258.114 - let val sort = arg_sort (lazy andalso is_none sel) in
258.115 - if Sign.of_sort tmp_thy (T, sort) then ()
258.116 - else error ("Constructor argument type is not of sort " ^
258.117 - Syntax.string_of_sort_global tmp_thy sort ^ ": " ^
258.118 - Syntax.string_of_typ_global tmp_thy T)
258.119 - end;
258.120 -
258.121 - (* test for free type variables, illegal sort constraints on rhs,
258.122 - non-pcpo-types and invalid use of recursive type;
258.123 - replace sorts in type variables on rhs *)
258.124 - val rec_tab = Domain_Take_Proofs.get_rec_tab thy;
258.125 - fun check_rec rec_ok (T as TFree (v,_)) =
258.126 - if AList.defined (op =) sorts v then T
258.127 - else error ("Free type variable " ^ quote v ^ " on rhs.")
258.128 - | check_rec rec_ok (T as Type (s, Ts)) =
258.129 - (case AList.lookup (op =) dtnvs' s of
258.130 - NONE =>
258.131 - let val rec_ok' = rec_ok andalso Symtab.defined rec_tab s;
258.132 - in Type (s, map (check_rec rec_ok') Ts) end
258.133 - | SOME typevars =>
258.134 - if typevars <> Ts
258.135 - then error ("Recursion of type " ^
258.136 - quote (Syntax.string_of_typ_global tmp_thy T) ^
258.137 - " with different arguments")
258.138 - else if rec_ok then T
258.139 - else error ("Illegal indirect recursion of type " ^
258.140 - quote (Syntax.string_of_typ_global tmp_thy T)))
258.141 - | check_rec rec_ok (TVar _) = error "extender:check_rec";
258.142 -
258.143 - fun prep_arg (lazy, sel, raw_T) =
258.144 - let
258.145 - val T = prep_typ tmp_thy sorts raw_T;
258.146 - val _ = check_rec true T;
258.147 - val _ = check_pcpo (lazy, sel, T);
258.148 - in (lazy, sel, T) end;
258.149 - fun prep_con (b, args, mx) = (b, map prep_arg args, mx);
258.150 - fun prep_rhs cons = map prep_con cons;
258.151 - val rhss : (binding * (bool * binding option * typ) list * mixfix) list list =
258.152 - map prep_rhs raw_rhss;
258.153 -
258.154 - fun mk_arg_typ (lazy, dest_opt, T) = if lazy then mk_upT T else T;
258.155 - fun mk_con_typ (bind, args, mx) =
258.156 - if null args then oneT else foldr1 mk_sprodT (map mk_arg_typ args);
258.157 - fun mk_rhs_typ cons = foldr1 mk_ssumT (map mk_con_typ cons);
258.158 -
258.159 - val absTs : typ list = map Type dtnvs';
258.160 - val repTs : typ list = map mk_rhs_typ rhss;
258.161 -
258.162 - val iso_spec : (binding * mixfix * (typ * typ)) list =
258.163 - map (fn ((dbind, _, mx), eq) => (dbind, mx, eq))
258.164 - (dtnvs ~~ (absTs ~~ repTs));
258.165 -
258.166 - val ((iso_infos, take_info), thy) = add_isos iso_spec thy;
258.167 -
258.168 - val (constr_infos, thy) =
258.169 - thy
258.170 - |> fold_map (fn ((dbind, cons), info) =>
258.171 - Domain_Constructors.add_domain_constructors dbind cons info)
258.172 - (dbinds ~~ rhss ~~ iso_infos);
258.173 -
258.174 - val (take_rews, thy) =
258.175 - Domain_Induction.comp_theorems
258.176 - dbinds take_info constr_infos thy;
258.177 - in
258.178 - thy
258.179 - end;
258.180 -
258.181 -fun define_isos (spec : (binding * mixfix * (typ * typ)) list) =
258.182 - let
258.183 - fun prep (dbind, mx, (lhsT, rhsT)) =
258.184 - let val (dname, vs) = dest_Type lhsT;
258.185 - in (map (fst o dest_TFree) vs, dbind, mx, rhsT, NONE) end;
258.186 - in
258.187 - Domain_Isomorphism.domain_isomorphism (map prep spec)
258.188 - end;
258.189 -
258.190 -fun pcpo_arg lazy = if lazy then @{sort cpo} else @{sort pcpo};
258.191 -fun rep_arg lazy = if lazy then @{sort predomain} else @{sort "domain"};
258.192 -
258.193 -fun read_sort thy (SOME s) = Syntax.read_sort_global thy s
258.194 - | read_sort thy NONE = Sign.defaultS thy;
258.195 -
258.196 -(* Adapted from src/HOL/Tools/Datatype/datatype_data.ML *)
258.197 -fun read_typ thy sorts str =
258.198 - let
258.199 - val ctxt = ProofContext.init_global thy
258.200 - |> fold (Variable.declare_typ o TFree) sorts;
258.201 - in Syntax.read_typ ctxt str end;
258.202 -
258.203 -fun cert_typ sign sorts raw_T =
258.204 - let
258.205 - val T = Type.no_tvars (Sign.certify_typ sign raw_T)
258.206 - handle TYPE (msg, _, _) => error msg;
258.207 - val sorts' = Term.add_tfreesT T sorts;
258.208 - val _ =
258.209 - case duplicates (op =) (map fst sorts') of
258.210 - [] => ()
258.211 - | dups => error ("Inconsistent sort constraints for " ^ commas dups)
258.212 - in T end;
258.213 -
258.214 -val add_domain =
258.215 - gen_add_domain (K I) cert_typ Domain_Axioms.add_axioms pcpo_arg;
258.216 -
258.217 -val add_new_domain =
258.218 - gen_add_domain (K I) cert_typ define_isos rep_arg;
258.219 -
258.220 -val add_domain_cmd =
258.221 - gen_add_domain read_sort read_typ Domain_Axioms.add_axioms pcpo_arg;
258.222 -
258.223 -val add_new_domain_cmd =
258.224 - gen_add_domain read_sort read_typ define_isos rep_arg;
258.225 -
258.226 -
258.227 -(** outer syntax **)
258.228 -
258.229 -val _ = Keyword.keyword "lazy";
258.230 -val _ = Keyword.keyword "unsafe";
258.231 -
258.232 -val dest_decl : (bool * binding option * string) parser =
258.233 - Parse.$$$ "(" |-- Scan.optional (Parse.$$$ "lazy" >> K true) false --
258.234 - (Parse.binding >> SOME) -- (Parse.$$$ "::" |-- Parse.typ) --| Parse.$$$ ")" >> Parse.triple1
258.235 - || Parse.$$$ "(" |-- Parse.$$$ "lazy" |-- Parse.typ --| Parse.$$$ ")"
258.236 - >> (fn t => (true,NONE,t))
258.237 - || Parse.typ >> (fn t => (false,NONE,t));
258.238 -
258.239 -val cons_decl =
258.240 - Parse.binding -- Scan.repeat dest_decl -- Parse.opt_mixfix;
258.241 -
258.242 -val domain_decl =
258.243 - (Parse.type_args_constrained -- Parse.binding -- Parse.opt_mixfix) --
258.244 - (Parse.$$$ "=" |-- Parse.enum1 "|" cons_decl);
258.245 -
258.246 -val domains_decl =
258.247 - Scan.optional (Parse.$$$ "(" |-- (Parse.$$$ "unsafe" >> K true) --| Parse.$$$ ")") false --
258.248 - Parse.and_list1 domain_decl;
258.249 -
258.250 -fun mk_domain
258.251 - (unsafe : bool,
258.252 - doms : ((((string * string option) list * binding) * mixfix) *
258.253 - ((binding * (bool * binding option * string) list) * mixfix) list) list ) =
258.254 - let
258.255 - val specs : ((string * string option) list * binding * mixfix *
258.256 - (binding * (bool * binding option * string) list * mixfix) list) list =
258.257 - map (fn (((vs, t), mx), cons) =>
258.258 - (vs, t, mx, map (fn ((c, ds), mx) => (c, ds, mx)) cons)) doms;
258.259 - in
258.260 - if unsafe
258.261 - then add_domain_cmd specs
258.262 - else add_new_domain_cmd specs
258.263 - end;
258.264 -
258.265 -val _ =
258.266 - Outer_Syntax.command "domain" "define recursive domains (HOLCF)"
258.267 - Keyword.thy_decl (domains_decl >> (Toplevel.theory o mk_domain));
258.268 -
258.269 -end;
259.1 --- a/src/HOLCF/Tools/Domain/domain_axioms.ML Sat Nov 27 14:34:54 2010 -0800
259.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
259.3 @@ -1,138 +0,0 @@
259.4 -(* Title: HOLCF/Tools/Domain/domain_axioms.ML
259.5 - Author: David von Oheimb
259.6 - Author: Brian Huffman
259.7 -
259.8 -Syntax generator for domain command.
259.9 -*)
259.10 -
259.11 -signature DOMAIN_AXIOMS =
259.12 -sig
259.13 - val axiomatize_isomorphism :
259.14 - binding * (typ * typ) ->
259.15 - theory -> Domain_Take_Proofs.iso_info * theory
259.16 -
259.17 - val axiomatize_lub_take :
259.18 - binding * term -> theory -> thm * theory
259.19 -
259.20 - val add_axioms :
259.21 - (binding * mixfix * (typ * typ)) list -> theory ->
259.22 - (Domain_Take_Proofs.iso_info list
259.23 - * Domain_Take_Proofs.take_induct_info) * theory
259.24 -end;
259.25 -
259.26 -
259.27 -structure Domain_Axioms : DOMAIN_AXIOMS =
259.28 -struct
259.29 -
259.30 -open HOLCF_Library;
259.31 -
259.32 -infixr 6 ->>;
259.33 -infix -->>;
259.34 -infix 9 `;
259.35 -
259.36 -fun axiomatize_isomorphism
259.37 - (dbind : binding, (lhsT, rhsT))
259.38 - (thy : theory)
259.39 - : Domain_Take_Proofs.iso_info * theory =
259.40 - let
259.41 - val abs_bind = Binding.suffix_name "_abs" dbind;
259.42 - val rep_bind = Binding.suffix_name "_rep" dbind;
259.43 -
259.44 - val (abs_const, thy) =
259.45 - Sign.declare_const ((abs_bind, rhsT ->> lhsT), NoSyn) thy;
259.46 - val (rep_const, thy) =
259.47 - Sign.declare_const ((rep_bind, lhsT ->> rhsT), NoSyn) thy;
259.48 -
259.49 - val x = Free ("x", lhsT);
259.50 - val y = Free ("y", rhsT);
259.51 -
259.52 - val abs_iso_eqn =
259.53 - Logic.all y (mk_trp (mk_eq (rep_const ` (abs_const ` y), y)));
259.54 - val rep_iso_eqn =
259.55 - Logic.all x (mk_trp (mk_eq (abs_const ` (rep_const ` x), x)));
259.56 -
259.57 - val abs_iso_bind = Binding.qualified true "abs_iso" dbind;
259.58 - val rep_iso_bind = Binding.qualified true "rep_iso" dbind;
259.59 -
259.60 - val (abs_iso_thm, thy) = Specification.axiom ((abs_iso_bind, []), abs_iso_eqn) thy;
259.61 - val (rep_iso_thm, thy) = Specification.axiom ((rep_iso_bind, []), rep_iso_eqn) thy;
259.62 -
259.63 - val result =
259.64 - {
259.65 - absT = lhsT,
259.66 - repT = rhsT,
259.67 - abs_const = abs_const,
259.68 - rep_const = rep_const,
259.69 - abs_inverse = Drule.export_without_context abs_iso_thm,
259.70 - rep_inverse = Drule.export_without_context rep_iso_thm
259.71 - };
259.72 - in
259.73 - (result, thy)
259.74 - end;
259.75 -
259.76 -fun axiomatize_lub_take
259.77 - (dbind : binding, take_const : term)
259.78 - (thy : theory)
259.79 - : thm * theory =
259.80 - let
259.81 - val i = Free ("i", natT);
259.82 - val T = (fst o dest_cfunT o range_type o fastype_of) take_const;
259.83 -
259.84 - val lub_take_eqn =
259.85 - mk_trp (mk_eq (mk_lub (lambda i (take_const $ i)), mk_ID T));
259.86 -
259.87 - val lub_take_bind = Binding.qualified true "lub_take" dbind;
259.88 -
259.89 - val (lub_take_thm, thy) = Specification.axiom ((lub_take_bind, []), lub_take_eqn) thy;
259.90 - in
259.91 - (lub_take_thm, thy)
259.92 - end;
259.93 -
259.94 -fun add_axioms
259.95 - (dom_eqns : (binding * mixfix * (typ * typ)) list)
259.96 - (thy : theory) =
259.97 - let
259.98 -
259.99 - val dbinds = map #1 dom_eqns;
259.100 -
259.101 - (* declare new types *)
259.102 - fun thy_type (dbind, mx, (lhsT, _)) =
259.103 - (dbind, (length o snd o dest_Type) lhsT, mx);
259.104 - val thy = Sign.add_types (map thy_type dom_eqns) thy;
259.105 -
259.106 - (* axiomatize type constructor arities *)
259.107 - fun thy_arity (_, _, (lhsT, _)) =
259.108 - let val (dname, tvars) = dest_Type lhsT;
259.109 - in (dname, map (snd o dest_TFree) tvars, @{sort pcpo}) end;
259.110 - val thy = fold (AxClass.axiomatize_arity o thy_arity) dom_eqns thy;
259.111 -
259.112 - (* declare and axiomatize abs/rep *)
259.113 - val (iso_infos, thy) =
259.114 - fold_map axiomatize_isomorphism
259.115 - (map (fn (dbind, _, eqn) => (dbind, eqn)) dom_eqns) thy;
259.116 -
259.117 - (* define take functions *)
259.118 - val (take_info, thy) =
259.119 - Domain_Take_Proofs.define_take_functions
259.120 - (dbinds ~~ iso_infos) thy;
259.121 -
259.122 - (* declare lub_take axioms *)
259.123 - val (lub_take_thms, thy) =
259.124 - fold_map axiomatize_lub_take
259.125 - (dbinds ~~ #take_consts take_info) thy;
259.126 -
259.127 - (* prove additional take theorems *)
259.128 - val (take_info2, thy) =
259.129 - Domain_Take_Proofs.add_lub_take_theorems
259.130 - (dbinds ~~ iso_infos) take_info lub_take_thms thy;
259.131 -
259.132 - (* define map functions *)
259.133 - val (map_info, thy) =
259.134 - Domain_Isomorphism.define_map_functions
259.135 - (dbinds ~~ iso_infos) thy;
259.136 -
259.137 - in
259.138 - ((iso_infos, take_info2), thy)
259.139 - end;
259.140 -
259.141 -end; (* struct *)
260.1 --- a/src/HOLCF/Tools/Domain/domain_constructors.ML Sat Nov 27 14:34:54 2010 -0800
260.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
260.3 @@ -1,975 +0,0 @@
260.4 -(* Title: HOLCF/Tools/Domain/domain_constructors.ML
260.5 - Author: Brian Huffman
260.6 -
260.7 -Defines constructor functions for a given domain isomorphism
260.8 -and proves related theorems.
260.9 -*)
260.10 -
260.11 -signature DOMAIN_CONSTRUCTORS =
260.12 -sig
260.13 - type constr_info =
260.14 - {
260.15 - iso_info : Domain_Take_Proofs.iso_info,
260.16 - con_specs : (term * (bool * typ) list) list,
260.17 - con_betas : thm list,
260.18 - nchotomy : thm,
260.19 - exhaust : thm,
260.20 - compacts : thm list,
260.21 - con_rews : thm list,
260.22 - inverts : thm list,
260.23 - injects : thm list,
260.24 - dist_les : thm list,
260.25 - dist_eqs : thm list,
260.26 - cases : thm list,
260.27 - sel_rews : thm list,
260.28 - dis_rews : thm list,
260.29 - match_rews : thm list
260.30 - }
260.31 - val add_domain_constructors :
260.32 - binding
260.33 - -> (binding * (bool * binding option * typ) list * mixfix) list
260.34 - -> Domain_Take_Proofs.iso_info
260.35 - -> theory
260.36 - -> constr_info * theory;
260.37 -end;
260.38 -
260.39 -
260.40 -structure Domain_Constructors :> DOMAIN_CONSTRUCTORS =
260.41 -struct
260.42 -
260.43 -open HOLCF_Library;
260.44 -
260.45 -infixr 6 ->>;
260.46 -infix -->>;
260.47 -infix 9 `;
260.48 -
260.49 -type constr_info =
260.50 - {
260.51 - iso_info : Domain_Take_Proofs.iso_info,
260.52 - con_specs : (term * (bool * typ) list) list,
260.53 - con_betas : thm list,
260.54 - nchotomy : thm,
260.55 - exhaust : thm,
260.56 - compacts : thm list,
260.57 - con_rews : thm list,
260.58 - inverts : thm list,
260.59 - injects : thm list,
260.60 - dist_les : thm list,
260.61 - dist_eqs : thm list,
260.62 - cases : thm list,
260.63 - sel_rews : thm list,
260.64 - dis_rews : thm list,
260.65 - match_rews : thm list
260.66 - }
260.67 -
260.68 -(************************** miscellaneous functions ***************************)
260.69 -
260.70 -val simple_ss = HOL_basic_ss addsimps simp_thms;
260.71 -
260.72 -val beta_rules =
260.73 - @{thms beta_cfun cont_id cont_const cont2cont_APP cont2cont_LAM'} @
260.74 - @{thms cont2cont_fst cont2cont_snd cont2cont_Pair};
260.75 -
260.76 -val beta_ss = HOL_basic_ss addsimps (simp_thms @ beta_rules);
260.77 -
260.78 -fun define_consts
260.79 - (specs : (binding * term * mixfix) list)
260.80 - (thy : theory)
260.81 - : (term list * thm list) * theory =
260.82 - let
260.83 - fun mk_decl (b, t, mx) = (b, fastype_of t, mx);
260.84 - val decls = map mk_decl specs;
260.85 - val thy = Cont_Consts.add_consts decls thy;
260.86 - fun mk_const (b, T, mx) = Const (Sign.full_name thy b, T);
260.87 - val consts = map mk_const decls;
260.88 - fun mk_def c (b, t, mx) =
260.89 - (Binding.suffix_name "_def" b, Logic.mk_equals (c, t));
260.90 - val defs = map2 mk_def consts specs;
260.91 - val (def_thms, thy) =
260.92 - Global_Theory.add_defs false (map Thm.no_attributes defs) thy;
260.93 - in
260.94 - ((consts, def_thms), thy)
260.95 - end;
260.96 -
260.97 -fun prove
260.98 - (thy : theory)
260.99 - (defs : thm list)
260.100 - (goal : term)
260.101 - (tacs : {prems: thm list, context: Proof.context} -> tactic list)
260.102 - : thm =
260.103 - let
260.104 - fun tac {prems, context} =
260.105 - rewrite_goals_tac defs THEN
260.106 - EVERY (tacs {prems = map (rewrite_rule defs) prems, context = context})
260.107 - in
260.108 - Goal.prove_global thy [] [] goal tac
260.109 - end;
260.110 -
260.111 -fun get_vars_avoiding
260.112 - (taken : string list)
260.113 - (args : (bool * typ) list)
260.114 - : (term list * term list) =
260.115 - let
260.116 - val Ts = map snd args;
260.117 - val ns = Name.variant_list taken (Datatype_Prop.make_tnames Ts);
260.118 - val vs = map Free (ns ~~ Ts);
260.119 - val nonlazy = map snd (filter_out (fst o fst) (args ~~ vs));
260.120 - in
260.121 - (vs, nonlazy)
260.122 - end;
260.123 -
260.124 -fun get_vars args = get_vars_avoiding [] args;
260.125 -
260.126 -(************** generating beta reduction rules from definitions **************)
260.127 -
260.128 -local
260.129 - fun arglist (Const _ $ Abs (s, T, t)) =
260.130 - let
260.131 - val arg = Free (s, T);
260.132 - val (args, body) = arglist (subst_bound (arg, t));
260.133 - in (arg :: args, body) end
260.134 - | arglist t = ([], t);
260.135 -in
260.136 - fun beta_of_def thy def_thm =
260.137 - let
260.138 - val (con, lam) = Logic.dest_equals (concl_of def_thm);
260.139 - val (args, rhs) = arglist lam;
260.140 - val lhs = list_ccomb (con, args);
260.141 - val goal = mk_equals (lhs, rhs);
260.142 - val cs = ContProc.cont_thms lam;
260.143 - val betas = map (fn c => mk_meta_eq (c RS @{thm beta_cfun})) cs;
260.144 - in
260.145 - prove thy (def_thm::betas) goal (K [rtac reflexive_thm 1])
260.146 - end;
260.147 -end;
260.148 -
260.149 -(******************************************************************************)
260.150 -(************* definitions and theorems for constructor functions *************)
260.151 -(******************************************************************************)
260.152 -
260.153 -fun add_constructors
260.154 - (spec : (binding * (bool * typ) list * mixfix) list)
260.155 - (abs_const : term)
260.156 - (iso_locale : thm)
260.157 - (thy : theory)
260.158 - =
260.159 - let
260.160 -
260.161 - (* get theorems about rep and abs *)
260.162 - val abs_strict = iso_locale RS @{thm iso.abs_strict};
260.163 -
260.164 - (* get types of type isomorphism *)
260.165 - val (rhsT, lhsT) = dest_cfunT (fastype_of abs_const);
260.166 -
260.167 - fun vars_of args =
260.168 - let
260.169 - val Ts = map snd args;
260.170 - val ns = Datatype_Prop.make_tnames Ts;
260.171 - in
260.172 - map Free (ns ~~ Ts)
260.173 - end;
260.174 -
260.175 - (* define constructor functions *)
260.176 - val ((con_consts, con_defs), thy) =
260.177 - let
260.178 - fun one_arg (lazy, T) var = if lazy then mk_up var else var;
260.179 - fun one_con (_,args,_) = mk_stuple (map2 one_arg args (vars_of args));
260.180 - fun mk_abs t = abs_const ` t;
260.181 - val rhss = map mk_abs (mk_sinjects (map one_con spec));
260.182 - fun mk_def (bind, args, mx) rhs =
260.183 - (bind, big_lambdas (vars_of args) rhs, mx);
260.184 - in
260.185 - define_consts (map2 mk_def spec rhss) thy
260.186 - end;
260.187 -
260.188 - (* prove beta reduction rules for constructors *)
260.189 - val con_betas = map (beta_of_def thy) con_defs;
260.190 -
260.191 - (* replace bindings with terms in constructor spec *)
260.192 - val spec' : (term * (bool * typ) list) list =
260.193 - let fun one_con con (b, args, mx) = (con, args);
260.194 - in map2 one_con con_consts spec end;
260.195 -
260.196 - (* prove exhaustiveness of constructors *)
260.197 - local
260.198 - fun arg2typ n (true, T) = (n+1, mk_upT (TVar (("'a", n), @{sort cpo})))
260.199 - | arg2typ n (false, T) = (n+1, TVar (("'a", n), @{sort pcpo}));
260.200 - fun args2typ n [] = (n, oneT)
260.201 - | args2typ n [arg] = arg2typ n arg
260.202 - | args2typ n (arg::args) =
260.203 - let
260.204 - val (n1, t1) = arg2typ n arg;
260.205 - val (n2, t2) = args2typ n1 args
260.206 - in (n2, mk_sprodT (t1, t2)) end;
260.207 - fun cons2typ n [] = (n, oneT)
260.208 - | cons2typ n [con] = args2typ n (snd con)
260.209 - | cons2typ n (con::cons) =
260.210 - let
260.211 - val (n1, t1) = args2typ n (snd con);
260.212 - val (n2, t2) = cons2typ n1 cons
260.213 - in (n2, mk_ssumT (t1, t2)) end;
260.214 - val ct = ctyp_of thy (snd (cons2typ 1 spec'));
260.215 - val thm1 = instantiate' [SOME ct] [] @{thm exh_start};
260.216 - val thm2 = rewrite_rule (map mk_meta_eq @{thms ex_bottom_iffs}) thm1;
260.217 - val thm3 = rewrite_rule [mk_meta_eq @{thm conj_assoc}] thm2;
260.218 -
260.219 - val y = Free ("y", lhsT);
260.220 - fun one_con (con, args) =
260.221 - let
260.222 - val (vs, nonlazy) = get_vars_avoiding ["y"] args;
260.223 - val eqn = mk_eq (y, list_ccomb (con, vs));
260.224 - val conj = foldr1 mk_conj (eqn :: map mk_defined nonlazy);
260.225 - in Library.foldr mk_ex (vs, conj) end;
260.226 - val goal = mk_trp (foldr1 mk_disj (mk_undef y :: map one_con spec'));
260.227 - (* first rules replace "y = UU \/ P" with "rep$y = UU \/ P" *)
260.228 - val tacs = [
260.229 - rtac (iso_locale RS @{thm iso.casedist_rule}) 1,
260.230 - rewrite_goals_tac [mk_meta_eq (iso_locale RS @{thm iso.iso_swap})],
260.231 - rtac thm3 1];
260.232 - in
260.233 - val nchotomy = prove thy con_betas goal (K tacs);
260.234 - val exhaust =
260.235 - (nchotomy RS @{thm exh_casedist0})
260.236 - |> rewrite_rule @{thms exh_casedists}
260.237 - |> Drule.zero_var_indexes;
260.238 - end;
260.239 -
260.240 - (* prove compactness rules for constructors *)
260.241 - val compacts =
260.242 - let
260.243 - val rules = @{thms compact_sinl compact_sinr compact_spair
260.244 - compact_up compact_ONE};
260.245 - val tacs =
260.246 - [rtac (iso_locale RS @{thm iso.compact_abs}) 1,
260.247 - REPEAT (resolve_tac rules 1 ORELSE atac 1)];
260.248 - fun con_compact (con, args) =
260.249 - let
260.250 - val vs = vars_of args;
260.251 - val con_app = list_ccomb (con, vs);
260.252 - val concl = mk_trp (mk_compact con_app);
260.253 - val assms = map (mk_trp o mk_compact) vs;
260.254 - val goal = Logic.list_implies (assms, concl);
260.255 - in
260.256 - prove thy con_betas goal (K tacs)
260.257 - end;
260.258 - in
260.259 - map con_compact spec'
260.260 - end;
260.261 -
260.262 - (* prove strictness rules for constructors *)
260.263 - local
260.264 - fun con_strict (con, args) =
260.265 - let
260.266 - val rules = abs_strict :: @{thms con_strict_rules};
260.267 - val (vs, nonlazy) = get_vars args;
260.268 - fun one_strict v' =
260.269 - let
260.270 - val UU = mk_bottom (fastype_of v');
260.271 - val vs' = map (fn v => if v = v' then UU else v) vs;
260.272 - val goal = mk_trp (mk_undef (list_ccomb (con, vs')));
260.273 - val tacs = [simp_tac (HOL_basic_ss addsimps rules) 1];
260.274 - in prove thy con_betas goal (K tacs) end;
260.275 - in map one_strict nonlazy end;
260.276 -
260.277 - fun con_defin (con, args) =
260.278 - let
260.279 - fun iff_disj (t, []) = HOLogic.mk_not t
260.280 - | iff_disj (t, ts) = mk_eq (t, foldr1 HOLogic.mk_disj ts);
260.281 - val (vs, nonlazy) = get_vars args;
260.282 - val lhs = mk_undef (list_ccomb (con, vs));
260.283 - val rhss = map mk_undef nonlazy;
260.284 - val goal = mk_trp (iff_disj (lhs, rhss));
260.285 - val rule1 = iso_locale RS @{thm iso.abs_bottom_iff};
260.286 - val rules = rule1 :: @{thms con_bottom_iff_rules};
260.287 - val tacs = [simp_tac (HOL_ss addsimps rules) 1];
260.288 - in prove thy con_betas goal (K tacs) end;
260.289 - in
260.290 - val con_stricts = maps con_strict spec';
260.291 - val con_defins = map con_defin spec';
260.292 - val con_rews = con_stricts @ con_defins;
260.293 - end;
260.294 -
260.295 - (* prove injectiveness of constructors *)
260.296 - local
260.297 - fun pgterm rel (con, args) =
260.298 - let
260.299 - fun prime (Free (n, T)) = Free (n^"'", T)
260.300 - | prime t = t;
260.301 - val (xs, nonlazy) = get_vars args;
260.302 - val ys = map prime xs;
260.303 - val lhs = rel (list_ccomb (con, xs), list_ccomb (con, ys));
260.304 - val rhs = foldr1 mk_conj (ListPair.map rel (xs, ys));
260.305 - val concl = mk_trp (mk_eq (lhs, rhs));
260.306 - val zs = case args of [_] => [] | _ => nonlazy;
260.307 - val assms = map (mk_trp o mk_defined) zs;
260.308 - val goal = Logic.list_implies (assms, concl);
260.309 - in prove thy con_betas goal end;
260.310 - val cons' = filter (fn (_, args) => not (null args)) spec';
260.311 - in
260.312 - val inverts =
260.313 - let
260.314 - val abs_below = iso_locale RS @{thm iso.abs_below};
260.315 - val rules1 = abs_below :: @{thms sinl_below sinr_below spair_below up_below};
260.316 - val rules2 = @{thms up_defined spair_defined ONE_defined}
260.317 - val rules = rules1 @ rules2;
260.318 - val tacs = [asm_simp_tac (simple_ss addsimps rules) 1];
260.319 - in map (fn c => pgterm mk_below c (K tacs)) cons' end;
260.320 - val injects =
260.321 - let
260.322 - val abs_eq = iso_locale RS @{thm iso.abs_eq};
260.323 - val rules1 = abs_eq :: @{thms sinl_eq sinr_eq spair_eq up_eq};
260.324 - val rules2 = @{thms up_defined spair_defined ONE_defined}
260.325 - val rules = rules1 @ rules2;
260.326 - val tacs = [asm_simp_tac (simple_ss addsimps rules) 1];
260.327 - in map (fn c => pgterm mk_eq c (K tacs)) cons' end;
260.328 - end;
260.329 -
260.330 - (* prove distinctness of constructors *)
260.331 - local
260.332 - fun map_dist (f : 'a -> 'a -> 'b) (xs : 'a list) : 'b list =
260.333 - flat (map_index (fn (i, x) => map (f x) (nth_drop i xs)) xs);
260.334 - fun prime (Free (n, T)) = Free (n^"'", T)
260.335 - | prime t = t;
260.336 - fun iff_disj (t, []) = mk_not t
260.337 - | iff_disj (t, ts) = mk_eq (t, foldr1 mk_disj ts);
260.338 - fun iff_disj2 (t, [], us) = mk_not t
260.339 - | iff_disj2 (t, ts, []) = mk_not t
260.340 - | iff_disj2 (t, ts, us) =
260.341 - mk_eq (t, mk_conj (foldr1 mk_disj ts, foldr1 mk_disj us));
260.342 - fun dist_le (con1, args1) (con2, args2) =
260.343 - let
260.344 - val (vs1, zs1) = get_vars args1;
260.345 - val (vs2, zs2) = get_vars args2 |> pairself (map prime);
260.346 - val lhs = mk_below (list_ccomb (con1, vs1), list_ccomb (con2, vs2));
260.347 - val rhss = map mk_undef zs1;
260.348 - val goal = mk_trp (iff_disj (lhs, rhss));
260.349 - val rule1 = iso_locale RS @{thm iso.abs_below};
260.350 - val rules = rule1 :: @{thms con_below_iff_rules};
260.351 - val tacs = [simp_tac (HOL_ss addsimps rules) 1];
260.352 - in prove thy con_betas goal (K tacs) end;
260.353 - fun dist_eq (con1, args1) (con2, args2) =
260.354 - let
260.355 - val (vs1, zs1) = get_vars args1;
260.356 - val (vs2, zs2) = get_vars args2 |> pairself (map prime);
260.357 - val lhs = mk_eq (list_ccomb (con1, vs1), list_ccomb (con2, vs2));
260.358 - val rhss1 = map mk_undef zs1;
260.359 - val rhss2 = map mk_undef zs2;
260.360 - val goal = mk_trp (iff_disj2 (lhs, rhss1, rhss2));
260.361 - val rule1 = iso_locale RS @{thm iso.abs_eq};
260.362 - val rules = rule1 :: @{thms con_eq_iff_rules};
260.363 - val tacs = [simp_tac (HOL_ss addsimps rules) 1];
260.364 - in prove thy con_betas goal (K tacs) end;
260.365 - in
260.366 - val dist_les = map_dist dist_le spec';
260.367 - val dist_eqs = map_dist dist_eq spec';
260.368 - end;
260.369 -
260.370 - val result =
260.371 - {
260.372 - con_consts = con_consts,
260.373 - con_betas = con_betas,
260.374 - nchotomy = nchotomy,
260.375 - exhaust = exhaust,
260.376 - compacts = compacts,
260.377 - con_rews = con_rews,
260.378 - inverts = inverts,
260.379 - injects = injects,
260.380 - dist_les = dist_les,
260.381 - dist_eqs = dist_eqs
260.382 - };
260.383 - in
260.384 - (result, thy)
260.385 - end;
260.386 -
260.387 -(******************************************************************************)
260.388 -(**************** definition and theorems for case combinator *****************)
260.389 -(******************************************************************************)
260.390 -
260.391 -fun add_case_combinator
260.392 - (spec : (term * (bool * typ) list) list)
260.393 - (lhsT : typ)
260.394 - (dbind : binding)
260.395 - (con_betas : thm list)
260.396 - (exhaust : thm)
260.397 - (iso_locale : thm)
260.398 - (rep_const : term)
260.399 - (thy : theory)
260.400 - : ((typ -> term) * thm list) * theory =
260.401 - let
260.402 -
260.403 - (* prove rep/abs rules *)
260.404 - val rep_strict = iso_locale RS @{thm iso.rep_strict};
260.405 - val abs_inverse = iso_locale RS @{thm iso.abs_iso};
260.406 -
260.407 - (* calculate function arguments of case combinator *)
260.408 - val tns = map fst (Term.add_tfreesT lhsT []);
260.409 - val resultT = TFree (Name.variant tns "'t", @{sort pcpo});
260.410 - fun fTs T = map (fn (_, args) => map snd args -->> T) spec;
260.411 - val fns = Datatype_Prop.indexify_names (map (K "f") spec);
260.412 - val fs = map Free (fns ~~ fTs resultT);
260.413 - fun caseT T = fTs T -->> (lhsT ->> T);
260.414 -
260.415 - (* definition of case combinator *)
260.416 - local
260.417 - val case_bind = Binding.suffix_name "_case" dbind;
260.418 - fun lambda_arg (lazy, v) t =
260.419 - (if lazy then mk_fup else I) (big_lambda v t);
260.420 - fun lambda_args [] t = mk_one_case t
260.421 - | lambda_args (x::[]) t = lambda_arg x t
260.422 - | lambda_args (x::xs) t = mk_ssplit (lambda_arg x (lambda_args xs t));
260.423 - fun one_con f (_, args) =
260.424 - let
260.425 - val Ts = map snd args;
260.426 - val ns = Name.variant_list fns (Datatype_Prop.make_tnames Ts);
260.427 - val vs = map Free (ns ~~ Ts);
260.428 - in
260.429 - lambda_args (map fst args ~~ vs) (list_ccomb (f, vs))
260.430 - end;
260.431 - fun mk_sscases [t] = mk_strictify t
260.432 - | mk_sscases ts = foldr1 mk_sscase ts;
260.433 - val body = mk_sscases (map2 one_con fs spec);
260.434 - val rhs = big_lambdas fs (mk_cfcomp (body, rep_const));
260.435 - val ((case_consts, case_defs), thy) =
260.436 - define_consts [(case_bind, rhs, NoSyn)] thy;
260.437 - val case_name = Sign.full_name thy case_bind;
260.438 - in
260.439 - val case_def = hd case_defs;
260.440 - fun case_const T = Const (case_name, caseT T);
260.441 - val case_app = list_ccomb (case_const resultT, fs);
260.442 - val thy = thy;
260.443 - end;
260.444 -
260.445 - (* define syntax for case combinator *)
260.446 - (* TODO: re-implement case syntax using a parse translation *)
260.447 - local
260.448 - open Syntax
260.449 - fun syntax c = Syntax.mark_const (fst (dest_Const c));
260.450 - fun xconst c = Long_Name.base_name (fst (dest_Const c));
260.451 - fun c_ast authentic con =
260.452 - Constant (if authentic then syntax con else xconst con);
260.453 - fun showint n = string_of_int (n+1);
260.454 - fun expvar n = Variable ("e" ^ showint n);
260.455 - fun argvar n (m, _) = Variable ("a" ^ showint n ^ "_" ^ showint m);
260.456 - fun argvars n args = map_index (argvar n) args;
260.457 - fun app s (l, r) = mk_appl (Constant s) [l, r];
260.458 - val cabs = app "_cabs";
260.459 - val capp = app @{const_syntax Rep_cfun};
260.460 - val capps = Library.foldl capp
260.461 - fun con1 authentic n (con,args) =
260.462 - Library.foldl capp (c_ast authentic con, argvars n args);
260.463 - fun case1 authentic (n, c) =
260.464 - app "_case1" (con1 authentic n c, expvar n);
260.465 - fun arg1 (n, (con,args)) = List.foldr cabs (expvar n) (argvars n args);
260.466 - fun when1 n (m, c) =
260.467 - if n = m then arg1 (n, c) else (Constant @{const_syntax UU});
260.468 - val case_constant = Constant (syntax (case_const dummyT));
260.469 - fun case_trans authentic =
260.470 - ParsePrintRule
260.471 - (app "_case_syntax"
260.472 - (Variable "x",
260.473 - foldr1 (app "_case2") (map_index (case1 authentic) spec)),
260.474 - capp (capps (case_constant, map_index arg1 spec), Variable "x"));
260.475 - fun one_abscon_trans authentic (n, c) =
260.476 - ParsePrintRule
260.477 - (cabs (con1 authentic n c, expvar n),
260.478 - capps (case_constant, map_index (when1 n) spec));
260.479 - fun abscon_trans authentic =
260.480 - map_index (one_abscon_trans authentic) spec;
260.481 - val trans_rules : ast Syntax.trrule list =
260.482 - case_trans false :: case_trans true ::
260.483 - abscon_trans false @ abscon_trans true;
260.484 - in
260.485 - val thy = Sign.add_trrules_i trans_rules thy;
260.486 - end;
260.487 -
260.488 - (* prove beta reduction rule for case combinator *)
260.489 - val case_beta = beta_of_def thy case_def;
260.490 -
260.491 - (* prove strictness of case combinator *)
260.492 - val case_strict =
260.493 - let
260.494 - val defs = case_beta :: map mk_meta_eq [rep_strict, @{thm cfcomp2}];
260.495 - val goal = mk_trp (mk_strict case_app);
260.496 - val rules = @{thms sscase1 ssplit1 strictify1 one_case1};
260.497 - val tacs = [resolve_tac rules 1];
260.498 - in prove thy defs goal (K tacs) end;
260.499 -
260.500 - (* prove rewrites for case combinator *)
260.501 - local
260.502 - fun one_case (con, args) f =
260.503 - let
260.504 - val (vs, nonlazy) = get_vars args;
260.505 - val assms = map (mk_trp o mk_defined) nonlazy;
260.506 - val lhs = case_app ` list_ccomb (con, vs);
260.507 - val rhs = list_ccomb (f, vs);
260.508 - val concl = mk_trp (mk_eq (lhs, rhs));
260.509 - val goal = Logic.list_implies (assms, concl);
260.510 - val defs = case_beta :: con_betas;
260.511 - val rules1 = @{thms strictify2 sscase2 sscase3 ssplit2 fup2 ID1};
260.512 - val rules2 = @{thms con_bottom_iff_rules};
260.513 - val rules3 = @{thms cfcomp2 one_case2};
260.514 - val rules = abs_inverse :: rules1 @ rules2 @ rules3;
260.515 - val tacs = [asm_simp_tac (beta_ss addsimps rules) 1];
260.516 - in prove thy defs goal (K tacs) end;
260.517 - in
260.518 - val case_apps = map2 one_case spec fs;
260.519 - end
260.520 -
260.521 - in
260.522 - ((case_const, case_strict :: case_apps), thy)
260.523 - end
260.524 -
260.525 -(******************************************************************************)
260.526 -(************** definitions and theorems for selector functions ***************)
260.527 -(******************************************************************************)
260.528 -
260.529 -fun add_selectors
260.530 - (spec : (term * (bool * binding option * typ) list) list)
260.531 - (rep_const : term)
260.532 - (abs_inv : thm)
260.533 - (rep_strict : thm)
260.534 - (rep_bottom_iff : thm)
260.535 - (con_betas : thm list)
260.536 - (thy : theory)
260.537 - : thm list * theory =
260.538 - let
260.539 -
260.540 - (* define selector functions *)
260.541 - val ((sel_consts, sel_defs), thy) =
260.542 - let
260.543 - fun rangeT s = snd (dest_cfunT (fastype_of s));
260.544 - fun mk_outl s = mk_cfcomp (from_sinl (dest_ssumT (rangeT s)), s);
260.545 - fun mk_outr s = mk_cfcomp (from_sinr (dest_ssumT (rangeT s)), s);
260.546 - fun mk_sfst s = mk_cfcomp (sfst_const (dest_sprodT (rangeT s)), s);
260.547 - fun mk_ssnd s = mk_cfcomp (ssnd_const (dest_sprodT (rangeT s)), s);
260.548 - fun mk_down s = mk_cfcomp (from_up (dest_upT (rangeT s)), s);
260.549 -
260.550 - fun sels_of_arg s (lazy, NONE, T) = []
260.551 - | sels_of_arg s (lazy, SOME b, T) =
260.552 - [(b, if lazy then mk_down s else s, NoSyn)];
260.553 - fun sels_of_args s [] = []
260.554 - | sels_of_args s (v :: []) = sels_of_arg s v
260.555 - | sels_of_args s (v :: vs) =
260.556 - sels_of_arg (mk_sfst s) v @ sels_of_args (mk_ssnd s) vs;
260.557 - fun sels_of_cons s [] = []
260.558 - | sels_of_cons s ((con, args) :: []) = sels_of_args s args
260.559 - | sels_of_cons s ((con, args) :: cs) =
260.560 - sels_of_args (mk_outl s) args @ sels_of_cons (mk_outr s) cs;
260.561 - val sel_eqns : (binding * term * mixfix) list =
260.562 - sels_of_cons rep_const spec;
260.563 - in
260.564 - define_consts sel_eqns thy
260.565 - end
260.566 -
260.567 - (* replace bindings with terms in constructor spec *)
260.568 - val spec2 : (term * (bool * term option * typ) list) list =
260.569 - let
260.570 - fun prep_arg (lazy, NONE, T) sels = ((lazy, NONE, T), sels)
260.571 - | prep_arg (lazy, SOME _, T) sels =
260.572 - ((lazy, SOME (hd sels), T), tl sels);
260.573 - fun prep_con (con, args) sels =
260.574 - apfst (pair con) (fold_map prep_arg args sels);
260.575 - in
260.576 - fst (fold_map prep_con spec sel_consts)
260.577 - end;
260.578 -
260.579 - (* prove selector strictness rules *)
260.580 - val sel_stricts : thm list =
260.581 - let
260.582 - val rules = rep_strict :: @{thms sel_strict_rules};
260.583 - val tacs = [simp_tac (HOL_basic_ss addsimps rules) 1];
260.584 - fun sel_strict sel =
260.585 - let
260.586 - val goal = mk_trp (mk_strict sel);
260.587 - in
260.588 - prove thy sel_defs goal (K tacs)
260.589 - end
260.590 - in
260.591 - map sel_strict sel_consts
260.592 - end
260.593 -
260.594 - (* prove selector application rules *)
260.595 - val sel_apps : thm list =
260.596 - let
260.597 - val defs = con_betas @ sel_defs;
260.598 - val rules = abs_inv :: @{thms sel_app_rules};
260.599 - val tacs = [asm_simp_tac (simple_ss addsimps rules) 1];
260.600 - fun sel_apps_of (i, (con, args: (bool * term option * typ) list)) =
260.601 - let
260.602 - val Ts : typ list = map #3 args;
260.603 - val ns : string list = Datatype_Prop.make_tnames Ts;
260.604 - val vs : term list = map Free (ns ~~ Ts);
260.605 - val con_app : term = list_ccomb (con, vs);
260.606 - val vs' : (bool * term) list = map #1 args ~~ vs;
260.607 - fun one_same (n, sel, T) =
260.608 - let
260.609 - val xs = map snd (filter_out fst (nth_drop n vs'));
260.610 - val assms = map (mk_trp o mk_defined) xs;
260.611 - val concl = mk_trp (mk_eq (sel ` con_app, nth vs n));
260.612 - val goal = Logic.list_implies (assms, concl);
260.613 - in
260.614 - prove thy defs goal (K tacs)
260.615 - end;
260.616 - fun one_diff (n, sel, T) =
260.617 - let
260.618 - val goal = mk_trp (mk_eq (sel ` con_app, mk_bottom T));
260.619 - in
260.620 - prove thy defs goal (K tacs)
260.621 - end;
260.622 - fun one_con (j, (_, args')) : thm list =
260.623 - let
260.624 - fun prep (i, (lazy, NONE, T)) = NONE
260.625 - | prep (i, (lazy, SOME sel, T)) = SOME (i, sel, T);
260.626 - val sels : (int * term * typ) list =
260.627 - map_filter prep (map_index I args');
260.628 - in
260.629 - if i = j
260.630 - then map one_same sels
260.631 - else map one_diff sels
260.632 - end
260.633 - in
260.634 - flat (map_index one_con spec2)
260.635 - end
260.636 - in
260.637 - flat (map_index sel_apps_of spec2)
260.638 - end
260.639 -
260.640 - (* prove selector definedness rules *)
260.641 - val sel_defins : thm list =
260.642 - let
260.643 - val rules = rep_bottom_iff :: @{thms sel_bottom_iff_rules};
260.644 - val tacs = [simp_tac (HOL_basic_ss addsimps rules) 1];
260.645 - fun sel_defin sel =
260.646 - let
260.647 - val (T, U) = dest_cfunT (fastype_of sel);
260.648 - val x = Free ("x", T);
260.649 - val lhs = mk_eq (sel ` x, mk_bottom U);
260.650 - val rhs = mk_eq (x, mk_bottom T);
260.651 - val goal = mk_trp (mk_eq (lhs, rhs));
260.652 - in
260.653 - prove thy sel_defs goal (K tacs)
260.654 - end
260.655 - fun one_arg (false, SOME sel, T) = SOME (sel_defin sel)
260.656 - | one_arg _ = NONE;
260.657 - in
260.658 - case spec2 of
260.659 - [(con, args)] => map_filter one_arg args
260.660 - | _ => []
260.661 - end;
260.662 -
260.663 - in
260.664 - (sel_stricts @ sel_defins @ sel_apps, thy)
260.665 - end
260.666 -
260.667 -(******************************************************************************)
260.668 -(************ definitions and theorems for discriminator functions ************)
260.669 -(******************************************************************************)
260.670 -
260.671 -fun add_discriminators
260.672 - (bindings : binding list)
260.673 - (spec : (term * (bool * typ) list) list)
260.674 - (lhsT : typ)
260.675 - (exhaust : thm)
260.676 - (case_const : typ -> term)
260.677 - (case_rews : thm list)
260.678 - (thy : theory) =
260.679 - let
260.680 -
260.681 - fun vars_of args =
260.682 - let
260.683 - val Ts = map snd args;
260.684 - val ns = Datatype_Prop.make_tnames Ts;
260.685 - in
260.686 - map Free (ns ~~ Ts)
260.687 - end;
260.688 -
260.689 - (* define discriminator functions *)
260.690 - local
260.691 - fun dis_fun i (j, (con, args)) =
260.692 - let
260.693 - val (vs, nonlazy) = get_vars args;
260.694 - val tr = if i = j then @{term TT} else @{term FF};
260.695 - in
260.696 - big_lambdas vs tr
260.697 - end;
260.698 - fun dis_eqn (i, bind) : binding * term * mixfix =
260.699 - let
260.700 - val dis_bind = Binding.prefix_name "is_" bind;
260.701 - val rhs = list_ccomb (case_const trT, map_index (dis_fun i) spec);
260.702 - in
260.703 - (dis_bind, rhs, NoSyn)
260.704 - end;
260.705 - in
260.706 - val ((dis_consts, dis_defs), thy) =
260.707 - define_consts (map_index dis_eqn bindings) thy
260.708 - end;
260.709 -
260.710 - (* prove discriminator strictness rules *)
260.711 - local
260.712 - fun dis_strict dis =
260.713 - let val goal = mk_trp (mk_strict dis);
260.714 - in prove thy dis_defs goal (K [rtac (hd case_rews) 1]) end;
260.715 - in
260.716 - val dis_stricts = map dis_strict dis_consts;
260.717 - end;
260.718 -
260.719 - (* prove discriminator/constructor rules *)
260.720 - local
260.721 - fun dis_app (i, dis) (j, (con, args)) =
260.722 - let
260.723 - val (vs, nonlazy) = get_vars args;
260.724 - val lhs = dis ` list_ccomb (con, vs);
260.725 - val rhs = if i = j then @{term TT} else @{term FF};
260.726 - val assms = map (mk_trp o mk_defined) nonlazy;
260.727 - val concl = mk_trp (mk_eq (lhs, rhs));
260.728 - val goal = Logic.list_implies (assms, concl);
260.729 - val tacs = [asm_simp_tac (beta_ss addsimps case_rews) 1];
260.730 - in prove thy dis_defs goal (K tacs) end;
260.731 - fun one_dis (i, dis) =
260.732 - map_index (dis_app (i, dis)) spec;
260.733 - in
260.734 - val dis_apps = flat (map_index one_dis dis_consts);
260.735 - end;
260.736 -
260.737 - (* prove discriminator definedness rules *)
260.738 - local
260.739 - fun dis_defin dis =
260.740 - let
260.741 - val x = Free ("x", lhsT);
260.742 - val simps = dis_apps @ @{thms dist_eq_tr};
260.743 - val tacs =
260.744 - [rtac @{thm iffI} 1,
260.745 - asm_simp_tac (HOL_basic_ss addsimps dis_stricts) 2,
260.746 - rtac exhaust 1, atac 1,
260.747 - DETERM_UNTIL_SOLVED (CHANGED
260.748 - (asm_full_simp_tac (simple_ss addsimps simps) 1))];
260.749 - val goal = mk_trp (mk_eq (mk_undef (dis ` x), mk_undef x));
260.750 - in prove thy [] goal (K tacs) end;
260.751 - in
260.752 - val dis_defins = map dis_defin dis_consts;
260.753 - end;
260.754 -
260.755 - in
260.756 - (dis_stricts @ dis_defins @ dis_apps, thy)
260.757 - end;
260.758 -
260.759 -(******************************************************************************)
260.760 -(*************** definitions and theorems for match combinators ***************)
260.761 -(******************************************************************************)
260.762 -
260.763 -fun add_match_combinators
260.764 - (bindings : binding list)
260.765 - (spec : (term * (bool * typ) list) list)
260.766 - (lhsT : typ)
260.767 - (exhaust : thm)
260.768 - (case_const : typ -> term)
260.769 - (case_rews : thm list)
260.770 - (thy : theory) =
260.771 - let
260.772 -
260.773 - (* get a fresh type variable for the result type *)
260.774 - val resultT : typ =
260.775 - let
260.776 - val ts : string list = map fst (Term.add_tfreesT lhsT []);
260.777 - val t : string = Name.variant ts "'t";
260.778 - in TFree (t, @{sort pcpo}) end;
260.779 -
260.780 - (* define match combinators *)
260.781 - local
260.782 - val x = Free ("x", lhsT);
260.783 - fun k args = Free ("k", map snd args -->> mk_matchT resultT);
260.784 - val fail = mk_fail resultT;
260.785 - fun mat_fun i (j, (con, args)) =
260.786 - let
260.787 - val (vs, nonlazy) = get_vars_avoiding ["x","k"] args;
260.788 - in
260.789 - if i = j then k args else big_lambdas vs fail
260.790 - end;
260.791 - fun mat_eqn (i, (bind, (con, args))) : binding * term * mixfix =
260.792 - let
260.793 - val mat_bind = Binding.prefix_name "match_" bind;
260.794 - val funs = map_index (mat_fun i) spec
260.795 - val body = list_ccomb (case_const (mk_matchT resultT), funs);
260.796 - val rhs = big_lambda x (big_lambda (k args) (body ` x));
260.797 - in
260.798 - (mat_bind, rhs, NoSyn)
260.799 - end;
260.800 - in
260.801 - val ((match_consts, match_defs), thy) =
260.802 - define_consts (map_index mat_eqn (bindings ~~ spec)) thy
260.803 - end;
260.804 -
260.805 - (* register match combinators with fixrec package *)
260.806 - local
260.807 - val con_names = map (fst o dest_Const o fst) spec;
260.808 - val mat_names = map (fst o dest_Const) match_consts;
260.809 - in
260.810 - val thy = Fixrec.add_matchers (con_names ~~ mat_names) thy;
260.811 - end;
260.812 -
260.813 - (* prove strictness of match combinators *)
260.814 - local
260.815 - fun match_strict mat =
260.816 - let
260.817 - val (T, (U, V)) = apsnd dest_cfunT (dest_cfunT (fastype_of mat));
260.818 - val k = Free ("k", U);
260.819 - val goal = mk_trp (mk_eq (mat ` mk_bottom T ` k, mk_bottom V));
260.820 - val tacs = [asm_simp_tac (beta_ss addsimps case_rews) 1];
260.821 - in prove thy match_defs goal (K tacs) end;
260.822 - in
260.823 - val match_stricts = map match_strict match_consts;
260.824 - end;
260.825 -
260.826 - (* prove match/constructor rules *)
260.827 - local
260.828 - val fail = mk_fail resultT;
260.829 - fun match_app (i, mat) (j, (con, args)) =
260.830 - let
260.831 - val (vs, nonlazy) = get_vars_avoiding ["k"] args;
260.832 - val (_, (kT, _)) = apsnd dest_cfunT (dest_cfunT (fastype_of mat));
260.833 - val k = Free ("k", kT);
260.834 - val lhs = mat ` list_ccomb (con, vs) ` k;
260.835 - val rhs = if i = j then list_ccomb (k, vs) else fail;
260.836 - val assms = map (mk_trp o mk_defined) nonlazy;
260.837 - val concl = mk_trp (mk_eq (lhs, rhs));
260.838 - val goal = Logic.list_implies (assms, concl);
260.839 - val tacs = [asm_simp_tac (beta_ss addsimps case_rews) 1];
260.840 - in prove thy match_defs goal (K tacs) end;
260.841 - fun one_match (i, mat) =
260.842 - map_index (match_app (i, mat)) spec;
260.843 - in
260.844 - val match_apps = flat (map_index one_match match_consts);
260.845 - end;
260.846 -
260.847 - in
260.848 - (match_stricts @ match_apps, thy)
260.849 - end;
260.850 -
260.851 -(******************************************************************************)
260.852 -(******************************* main function ********************************)
260.853 -(******************************************************************************)
260.854 -
260.855 -fun add_domain_constructors
260.856 - (dbind : binding)
260.857 - (spec : (binding * (bool * binding option * typ) list * mixfix) list)
260.858 - (iso_info : Domain_Take_Proofs.iso_info)
260.859 - (thy : theory) =
260.860 - let
260.861 - val dname = Binding.name_of dbind;
260.862 - val _ = writeln ("Proving isomorphism properties of domain "^dname^" ...");
260.863 -
260.864 - val bindings = map #1 spec;
260.865 -
260.866 - (* retrieve facts about rep/abs *)
260.867 - val lhsT = #absT iso_info;
260.868 - val {rep_const, abs_const, ...} = iso_info;
260.869 - val abs_iso_thm = #abs_inverse iso_info;
260.870 - val rep_iso_thm = #rep_inverse iso_info;
260.871 - val iso_locale = @{thm iso.intro} OF [abs_iso_thm, rep_iso_thm];
260.872 - val rep_strict = iso_locale RS @{thm iso.rep_strict};
260.873 - val abs_strict = iso_locale RS @{thm iso.abs_strict};
260.874 - val rep_bottom_iff = iso_locale RS @{thm iso.rep_bottom_iff};
260.875 - val abs_bottom_iff = iso_locale RS @{thm iso.abs_bottom_iff};
260.876 - val iso_rews = [abs_iso_thm, rep_iso_thm, abs_strict, rep_strict];
260.877 -
260.878 - (* qualify constants and theorems with domain name *)
260.879 - val thy = Sign.add_path dname thy;
260.880 -
260.881 - (* define constructor functions *)
260.882 - val (con_result, thy) =
260.883 - let
260.884 - fun prep_arg (lazy, sel, T) = (lazy, T);
260.885 - fun prep_con (b, args, mx) = (b, map prep_arg args, mx);
260.886 - val con_spec = map prep_con spec;
260.887 - in
260.888 - add_constructors con_spec abs_const iso_locale thy
260.889 - end;
260.890 - val {con_consts, con_betas, nchotomy, exhaust, compacts, con_rews,
260.891 - inverts, injects, dist_les, dist_eqs} = con_result;
260.892 -
260.893 - (* prepare constructor spec *)
260.894 - val con_specs : (term * (bool * typ) list) list =
260.895 - let
260.896 - fun prep_arg (lazy, sel, T) = (lazy, T);
260.897 - fun prep_con c (b, args, mx) = (c, map prep_arg args);
260.898 - in
260.899 - map2 prep_con con_consts spec
260.900 - end;
260.901 -
260.902 - (* define case combinator *)
260.903 - val ((case_const : typ -> term, cases : thm list), thy) =
260.904 - add_case_combinator con_specs lhsT dbind
260.905 - con_betas exhaust iso_locale rep_const thy
260.906 -
260.907 - (* define and prove theorems for selector functions *)
260.908 - val (sel_thms : thm list, thy : theory) =
260.909 - let
260.910 - val sel_spec : (term * (bool * binding option * typ) list) list =
260.911 - map2 (fn con => fn (b, args, mx) => (con, args)) con_consts spec;
260.912 - in
260.913 - add_selectors sel_spec rep_const
260.914 - abs_iso_thm rep_strict rep_bottom_iff con_betas thy
260.915 - end;
260.916 -
260.917 - (* define and prove theorems for discriminator functions *)
260.918 - val (dis_thms : thm list, thy : theory) =
260.919 - add_discriminators bindings con_specs lhsT
260.920 - exhaust case_const cases thy;
260.921 -
260.922 - (* define and prove theorems for match combinators *)
260.923 - val (match_thms : thm list, thy : theory) =
260.924 - add_match_combinators bindings con_specs lhsT
260.925 - exhaust case_const cases thy;
260.926 -
260.927 - (* restore original signature path *)
260.928 - val thy = Sign.parent_path thy;
260.929 -
260.930 - (* bind theorem names in global theory *)
260.931 - val (_, thy) =
260.932 - let
260.933 - fun qualified name = Binding.qualified true name dbind;
260.934 - val names = "bottom" :: map (fn (b,_,_) => Binding.name_of b) spec;
260.935 - val dname = fst (dest_Type lhsT);
260.936 - val simp = Simplifier.simp_add;
260.937 - val case_names = Rule_Cases.case_names names;
260.938 - val cases_type = Induct.cases_type dname;
260.939 - in
260.940 - Global_Theory.add_thmss [
260.941 - ((qualified "iso_rews" , iso_rews ), [simp]),
260.942 - ((qualified "nchotomy" , [nchotomy] ), []),
260.943 - ((qualified "exhaust" , [exhaust] ), [case_names, cases_type]),
260.944 - ((qualified "case_rews" , cases ), [simp]),
260.945 - ((qualified "compacts" , compacts ), [simp]),
260.946 - ((qualified "con_rews" , con_rews ), [simp]),
260.947 - ((qualified "sel_rews" , sel_thms ), [simp]),
260.948 - ((qualified "dis_rews" , dis_thms ), [simp]),
260.949 - ((qualified "dist_les" , dist_les ), [simp]),
260.950 - ((qualified "dist_eqs" , dist_eqs ), [simp]),
260.951 - ((qualified "inverts" , inverts ), [simp]),
260.952 - ((qualified "injects" , injects ), [simp]),
260.953 - ((qualified "match_rews", match_thms ), [simp])] thy
260.954 - end;
260.955 -
260.956 - val result =
260.957 - {
260.958 - iso_info = iso_info,
260.959 - con_specs = con_specs,
260.960 - con_betas = con_betas,
260.961 - nchotomy = nchotomy,
260.962 - exhaust = exhaust,
260.963 - compacts = compacts,
260.964 - con_rews = con_rews,
260.965 - inverts = inverts,
260.966 - injects = injects,
260.967 - dist_les = dist_les,
260.968 - dist_eqs = dist_eqs,
260.969 - cases = cases,
260.970 - sel_rews = sel_thms,
260.971 - dis_rews = dis_thms,
260.972 - match_rews = match_thms
260.973 - };
260.974 - in
260.975 - (result, thy)
260.976 - end;
260.977 -
260.978 -end;
261.1 --- a/src/HOLCF/Tools/Domain/domain_induction.ML Sat Nov 27 14:34:54 2010 -0800
261.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
261.3 @@ -1,439 +0,0 @@
261.4 -(* Title: HOLCF/Tools/Domain/domain_induction.ML
261.5 - Author: David von Oheimb
261.6 - Author: Brian Huffman
261.7 -
261.8 -Proofs of high-level (co)induction rules for domain command.
261.9 -*)
261.10 -
261.11 -signature DOMAIN_INDUCTION =
261.12 -sig
261.13 - val comp_theorems :
261.14 - binding list ->
261.15 - Domain_Take_Proofs.take_induct_info ->
261.16 - Domain_Constructors.constr_info list ->
261.17 - theory -> thm list * theory
261.18 -
261.19 - val quiet_mode: bool Unsynchronized.ref;
261.20 - val trace_domain: bool Unsynchronized.ref;
261.21 -end;
261.22 -
261.23 -structure Domain_Induction :> DOMAIN_INDUCTION =
261.24 -struct
261.25 -
261.26 -val quiet_mode = Unsynchronized.ref false;
261.27 -val trace_domain = Unsynchronized.ref false;
261.28 -
261.29 -fun message s = if !quiet_mode then () else writeln s;
261.30 -fun trace s = if !trace_domain then tracing s else ();
261.31 -
261.32 -open HOLCF_Library;
261.33 -
261.34 -(******************************************************************************)
261.35 -(***************************** proofs about take ******************************)
261.36 -(******************************************************************************)
261.37 -
261.38 -fun take_theorems
261.39 - (dbinds : binding list)
261.40 - (take_info : Domain_Take_Proofs.take_induct_info)
261.41 - (constr_infos : Domain_Constructors.constr_info list)
261.42 - (thy : theory) : thm list list * theory =
261.43 -let
261.44 - val {take_consts, take_Suc_thms, deflation_take_thms, ...} = take_info;
261.45 - val deflation_thms = Domain_Take_Proofs.get_deflation_thms thy;
261.46 -
261.47 - val n = Free ("n", @{typ nat});
261.48 - val n' = @{const Suc} $ n;
261.49 -
261.50 - local
261.51 - val newTs = map (#absT o #iso_info) constr_infos;
261.52 - val subs = newTs ~~ map (fn t => t $ n) take_consts;
261.53 - fun is_ID (Const (c, _)) = (c = @{const_name ID})
261.54 - | is_ID _ = false;
261.55 - in
261.56 - fun map_of_arg thy v T =
261.57 - let val m = Domain_Take_Proofs.map_of_typ thy subs T;
261.58 - in if is_ID m then v else mk_capply (m, v) end;
261.59 - end
261.60 -
261.61 - fun prove_take_apps
261.62 - ((dbind, take_const), constr_info) thy =
261.63 - let
261.64 - val {iso_info, con_specs, con_betas, ...} = constr_info;
261.65 - val {abs_inverse, ...} = iso_info;
261.66 - fun prove_take_app (con_const, args) =
261.67 - let
261.68 - val Ts = map snd args;
261.69 - val ns = Name.variant_list ["n"] (Datatype_Prop.make_tnames Ts);
261.70 - val vs = map Free (ns ~~ Ts);
261.71 - val lhs = mk_capply (take_const $ n', list_ccomb (con_const, vs));
261.72 - val rhs = list_ccomb (con_const, map2 (map_of_arg thy) vs Ts);
261.73 - val goal = mk_trp (mk_eq (lhs, rhs));
261.74 - val rules =
261.75 - [abs_inverse] @ con_betas @ @{thms take_con_rules}
261.76 - @ take_Suc_thms @ deflation_thms @ deflation_take_thms;
261.77 - val tac = simp_tac (HOL_basic_ss addsimps rules) 1;
261.78 - in
261.79 - Goal.prove_global thy [] [] goal (K tac)
261.80 - end;
261.81 - val take_apps = map prove_take_app con_specs;
261.82 - in
261.83 - yield_singleton Global_Theory.add_thmss
261.84 - ((Binding.qualified true "take_rews" dbind, take_apps),
261.85 - [Simplifier.simp_add]) thy
261.86 - end;
261.87 -in
261.88 - fold_map prove_take_apps
261.89 - (dbinds ~~ take_consts ~~ constr_infos) thy
261.90 -end;
261.91 -
261.92 -(******************************************************************************)
261.93 -(****************************** induction rules *******************************)
261.94 -(******************************************************************************)
261.95 -
261.96 -val case_UU_allI =
261.97 - @{lemma "(!!x. x ~= UU ==> P x) ==> P UU ==> ALL x. P x" by metis};
261.98 -
261.99 -fun prove_induction
261.100 - (comp_dbind : binding)
261.101 - (constr_infos : Domain_Constructors.constr_info list)
261.102 - (take_info : Domain_Take_Proofs.take_induct_info)
261.103 - (take_rews : thm list)
261.104 - (thy : theory) =
261.105 -let
261.106 - val comp_dname = Binding.name_of comp_dbind;
261.107 -
261.108 - val iso_infos = map #iso_info constr_infos;
261.109 - val exhausts = map #exhaust constr_infos;
261.110 - val con_rews = maps #con_rews constr_infos;
261.111 - val {take_consts, take_induct_thms, ...} = take_info;
261.112 -
261.113 - val newTs = map #absT iso_infos;
261.114 - val P_names = Datatype_Prop.indexify_names (map (K "P") newTs);
261.115 - val x_names = Datatype_Prop.indexify_names (map (K "x") newTs);
261.116 - val P_types = map (fn T => T --> HOLogic.boolT) newTs;
261.117 - val Ps = map Free (P_names ~~ P_types);
261.118 - val xs = map Free (x_names ~~ newTs);
261.119 - val n = Free ("n", HOLogic.natT);
261.120 -
261.121 - fun con_assm defined p (con, args) =
261.122 - let
261.123 - val Ts = map snd args;
261.124 - val ns = Name.variant_list P_names (Datatype_Prop.make_tnames Ts);
261.125 - val vs = map Free (ns ~~ Ts);
261.126 - val nonlazy = map snd (filter_out (fst o fst) (args ~~ vs));
261.127 - fun ind_hyp (v, T) t =
261.128 - case AList.lookup (op =) (newTs ~~ Ps) T of NONE => t
261.129 - | SOME p' => Logic.mk_implies (mk_trp (p' $ v), t);
261.130 - val t1 = mk_trp (p $ list_ccomb (con, vs));
261.131 - val t2 = fold_rev ind_hyp (vs ~~ Ts) t1;
261.132 - val t3 = Logic.list_implies (map (mk_trp o mk_defined) nonlazy, t2);
261.133 - in fold_rev Logic.all vs (if defined then t3 else t2) end;
261.134 - fun eq_assms ((p, T), cons) =
261.135 - mk_trp (p $ HOLCF_Library.mk_bottom T) :: map (con_assm true p) cons;
261.136 - val assms = maps eq_assms (Ps ~~ newTs ~~ map #con_specs constr_infos);
261.137 -
261.138 - val take_ss = HOL_ss addsimps (@{thm Rep_cfun_strict1} :: take_rews);
261.139 - fun quant_tac ctxt i = EVERY
261.140 - (map (fn name => res_inst_tac ctxt [(("x", 0), name)] spec i) x_names);
261.141 -
261.142 - (* FIXME: move this message to domain_take_proofs.ML *)
261.143 - val is_finite = #is_finite take_info;
261.144 - val _ = if is_finite
261.145 - then message ("Proving finiteness rule for domain "^comp_dname^" ...")
261.146 - else ();
261.147 -
261.148 - val _ = trace " Proving finite_ind...";
261.149 - val finite_ind =
261.150 - let
261.151 - val concls =
261.152 - map (fn ((P, t), x) => P $ mk_capply (t $ n, x))
261.153 - (Ps ~~ take_consts ~~ xs);
261.154 - val goal = mk_trp (foldr1 mk_conj concls);
261.155 -
261.156 - fun tacf {prems, context} =
261.157 - let
261.158 - (* Prove stronger prems, without definedness side conditions *)
261.159 - fun con_thm p (con, args) =
261.160 - let
261.161 - val subgoal = con_assm false p (con, args);
261.162 - val rules = prems @ con_rews @ simp_thms;
261.163 - val simplify = asm_simp_tac (HOL_basic_ss addsimps rules);
261.164 - fun arg_tac (lazy, _) =
261.165 - rtac (if lazy then allI else case_UU_allI) 1;
261.166 - val tacs =
261.167 - rewrite_goals_tac @{thms atomize_all atomize_imp} ::
261.168 - map arg_tac args @
261.169 - [REPEAT (rtac impI 1), ALLGOALS simplify];
261.170 - in
261.171 - Goal.prove context [] [] subgoal (K (EVERY tacs))
261.172 - end;
261.173 - fun eq_thms (p, cons) = map (con_thm p) cons;
261.174 - val conss = map #con_specs constr_infos;
261.175 - val prems' = maps eq_thms (Ps ~~ conss);
261.176 -
261.177 - val tacs1 = [
261.178 - quant_tac context 1,
261.179 - simp_tac HOL_ss 1,
261.180 - InductTacs.induct_tac context [[SOME "n"]] 1,
261.181 - simp_tac (take_ss addsimps prems) 1,
261.182 - TRY (safe_tac HOL_cs)];
261.183 - fun con_tac _ =
261.184 - asm_simp_tac take_ss 1 THEN
261.185 - (resolve_tac prems' THEN_ALL_NEW etac spec) 1;
261.186 - fun cases_tacs (cons, exhaust) =
261.187 - res_inst_tac context [(("y", 0), "x")] exhaust 1 ::
261.188 - asm_simp_tac (take_ss addsimps prems) 1 ::
261.189 - map con_tac cons;
261.190 - val tacs = tacs1 @ maps cases_tacs (conss ~~ exhausts)
261.191 - in
261.192 - EVERY (map DETERM tacs)
261.193 - end;
261.194 - in Goal.prove_global thy [] assms goal tacf end;
261.195 -
261.196 - val _ = trace " Proving ind...";
261.197 - val ind =
261.198 - let
261.199 - val concls = map (op $) (Ps ~~ xs);
261.200 - val goal = mk_trp (foldr1 mk_conj concls);
261.201 - val adms = if is_finite then [] else map (mk_trp o mk_adm) Ps;
261.202 - fun tacf {prems, context} =
261.203 - let
261.204 - fun finite_tac (take_induct, fin_ind) =
261.205 - rtac take_induct 1 THEN
261.206 - (if is_finite then all_tac else resolve_tac prems 1) THEN
261.207 - (rtac fin_ind THEN_ALL_NEW solve_tac prems) 1;
261.208 - val fin_inds = Project_Rule.projections context finite_ind;
261.209 - in
261.210 - TRY (safe_tac HOL_cs) THEN
261.211 - EVERY (map finite_tac (take_induct_thms ~~ fin_inds))
261.212 - end;
261.213 - in Goal.prove_global thy [] (adms @ assms) goal tacf end
261.214 -
261.215 - (* case names for induction rules *)
261.216 - val dnames = map (fst o dest_Type) newTs;
261.217 - val case_ns =
261.218 - let
261.219 - val adms =
261.220 - if is_finite then [] else
261.221 - if length dnames = 1 then ["adm"] else
261.222 - map (fn s => "adm_" ^ Long_Name.base_name s) dnames;
261.223 - val bottoms =
261.224 - if length dnames = 1 then ["bottom"] else
261.225 - map (fn s => "bottom_" ^ Long_Name.base_name s) dnames;
261.226 - fun one_eq bot constr_info =
261.227 - let fun name_of (c, args) = Long_Name.base_name (fst (dest_Const c));
261.228 - in bot :: map name_of (#con_specs constr_info) end;
261.229 - in adms @ flat (map2 one_eq bottoms constr_infos) end;
261.230 -
261.231 - val inducts = Project_Rule.projections (ProofContext.init_global thy) ind;
261.232 - fun ind_rule (dname, rule) =
261.233 - ((Binding.empty, rule),
261.234 - [Rule_Cases.case_names case_ns, Induct.induct_type dname]);
261.235 -
261.236 -in
261.237 - thy
261.238 - |> snd o Global_Theory.add_thms [
261.239 - ((Binding.qualified true "finite_induct" comp_dbind, finite_ind), []),
261.240 - ((Binding.qualified true "induct" comp_dbind, ind ), [])]
261.241 - |> (snd o Global_Theory.add_thms (map ind_rule (dnames ~~ inducts)))
261.242 -end; (* prove_induction *)
261.243 -
261.244 -(******************************************************************************)
261.245 -(************************ bisimulation and coinduction ************************)
261.246 -(******************************************************************************)
261.247 -
261.248 -fun prove_coinduction
261.249 - (comp_dbind : binding, dbinds : binding list)
261.250 - (constr_infos : Domain_Constructors.constr_info list)
261.251 - (take_info : Domain_Take_Proofs.take_induct_info)
261.252 - (take_rews : thm list list)
261.253 - (thy : theory) : theory =
261.254 -let
261.255 - val iso_infos = map #iso_info constr_infos;
261.256 - val newTs = map #absT iso_infos;
261.257 -
261.258 - val {take_consts, take_0_thms, take_lemma_thms, ...} = take_info;
261.259 -
261.260 - val R_names = Datatype_Prop.indexify_names (map (K "R") newTs);
261.261 - val R_types = map (fn T => T --> T --> boolT) newTs;
261.262 - val Rs = map Free (R_names ~~ R_types);
261.263 - val n = Free ("n", natT);
261.264 - val reserved = "x" :: "y" :: R_names;
261.265 -
261.266 - (* declare bisimulation predicate *)
261.267 - val bisim_bind = Binding.suffix_name "_bisim" comp_dbind;
261.268 - val bisim_type = R_types ---> boolT;
261.269 - val (bisim_const, thy) =
261.270 - Sign.declare_const ((bisim_bind, bisim_type), NoSyn) thy;
261.271 -
261.272 - (* define bisimulation predicate *)
261.273 - local
261.274 - fun one_con T (con, args) =
261.275 - let
261.276 - val Ts = map snd args;
261.277 - val ns1 = Name.variant_list reserved (Datatype_Prop.make_tnames Ts);
261.278 - val ns2 = map (fn n => n^"'") ns1;
261.279 - val vs1 = map Free (ns1 ~~ Ts);
261.280 - val vs2 = map Free (ns2 ~~ Ts);
261.281 - val eq1 = mk_eq (Free ("x", T), list_ccomb (con, vs1));
261.282 - val eq2 = mk_eq (Free ("y", T), list_ccomb (con, vs2));
261.283 - fun rel ((v1, v2), T) =
261.284 - case AList.lookup (op =) (newTs ~~ Rs) T of
261.285 - NONE => mk_eq (v1, v2) | SOME r => r $ v1 $ v2;
261.286 - val eqs = foldr1 mk_conj (map rel (vs1 ~~ vs2 ~~ Ts) @ [eq1, eq2]);
261.287 - in
261.288 - Library.foldr mk_ex (vs1 @ vs2, eqs)
261.289 - end;
261.290 - fun one_eq ((T, R), cons) =
261.291 - let
261.292 - val x = Free ("x", T);
261.293 - val y = Free ("y", T);
261.294 - val disj1 = mk_conj (mk_eq (x, mk_bottom T), mk_eq (y, mk_bottom T));
261.295 - val disjs = disj1 :: map (one_con T) cons;
261.296 - in
261.297 - mk_all (x, mk_all (y, mk_imp (R $ x $ y, foldr1 mk_disj disjs)))
261.298 - end;
261.299 - val conjs = map one_eq (newTs ~~ Rs ~~ map #con_specs constr_infos);
261.300 - val bisim_rhs = lambdas Rs (Library.foldr1 mk_conj conjs);
261.301 - val bisim_eqn = Logic.mk_equals (bisim_const, bisim_rhs);
261.302 - in
261.303 - val (bisim_def_thm, thy) = thy |>
261.304 - yield_singleton (Global_Theory.add_defs false)
261.305 - ((Binding.qualified true "bisim_def" comp_dbind, bisim_eqn), []);
261.306 - end (* local *)
261.307 -
261.308 - (* prove coinduction lemma *)
261.309 - val coind_lemma =
261.310 - let
261.311 - val assm = mk_trp (list_comb (bisim_const, Rs));
261.312 - fun one ((T, R), take_const) =
261.313 - let
261.314 - val x = Free ("x", T);
261.315 - val y = Free ("y", T);
261.316 - val lhs = mk_capply (take_const $ n, x);
261.317 - val rhs = mk_capply (take_const $ n, y);
261.318 - in
261.319 - mk_all (x, mk_all (y, mk_imp (R $ x $ y, mk_eq (lhs, rhs))))
261.320 - end;
261.321 - val goal =
261.322 - mk_trp (foldr1 mk_conj (map one (newTs ~~ Rs ~~ take_consts)));
261.323 - val rules = @{thm Rep_cfun_strict1} :: take_0_thms;
261.324 - fun tacf {prems, context} =
261.325 - let
261.326 - val prem' = rewrite_rule [bisim_def_thm] (hd prems);
261.327 - val prems' = Project_Rule.projections context prem';
261.328 - val dests = map (fn th => th RS spec RS spec RS mp) prems';
261.329 - fun one_tac (dest, rews) =
261.330 - dtac dest 1 THEN safe_tac HOL_cs THEN
261.331 - ALLGOALS (asm_simp_tac (HOL_basic_ss addsimps rews));
261.332 - in
261.333 - rtac @{thm nat.induct} 1 THEN
261.334 - simp_tac (HOL_ss addsimps rules) 1 THEN
261.335 - safe_tac HOL_cs THEN
261.336 - EVERY (map one_tac (dests ~~ take_rews))
261.337 - end
261.338 - in
261.339 - Goal.prove_global thy [] [assm] goal tacf
261.340 - end;
261.341 -
261.342 - (* prove individual coinduction rules *)
261.343 - fun prove_coind ((T, R), take_lemma) =
261.344 - let
261.345 - val x = Free ("x", T);
261.346 - val y = Free ("y", T);
261.347 - val assm1 = mk_trp (list_comb (bisim_const, Rs));
261.348 - val assm2 = mk_trp (R $ x $ y);
261.349 - val goal = mk_trp (mk_eq (x, y));
261.350 - fun tacf {prems, context} =
261.351 - let
261.352 - val rule = hd prems RS coind_lemma;
261.353 - in
261.354 - rtac take_lemma 1 THEN
261.355 - asm_simp_tac (HOL_basic_ss addsimps (rule :: prems)) 1
261.356 - end;
261.357 - in
261.358 - Goal.prove_global thy [] [assm1, assm2] goal tacf
261.359 - end;
261.360 - val coinds = map prove_coind (newTs ~~ Rs ~~ take_lemma_thms);
261.361 - val coind_binds = map (Binding.qualified true "coinduct") dbinds;
261.362 -
261.363 -in
261.364 - thy |> snd o Global_Theory.add_thms
261.365 - (map Thm.no_attributes (coind_binds ~~ coinds))
261.366 -end; (* let *)
261.367 -
261.368 -(******************************************************************************)
261.369 -(******************************* main function ********************************)
261.370 -(******************************************************************************)
261.371 -
261.372 -fun comp_theorems
261.373 - (dbinds : binding list)
261.374 - (take_info : Domain_Take_Proofs.take_induct_info)
261.375 - (constr_infos : Domain_Constructors.constr_info list)
261.376 - (thy : theory) =
261.377 -let
261.378 -
261.379 -val comp_dname = space_implode "_" (map Binding.name_of dbinds);
261.380 -val comp_dbind = Binding.name comp_dname;
261.381 -
261.382 -(* Test for emptiness *)
261.383 -(* FIXME: reimplement emptiness test
261.384 -local
261.385 - open Domain_Library;
261.386 - val dnames = map (fst o fst) eqs;
261.387 - val conss = map snd eqs;
261.388 - fun rec_to ns lazy_rec (n,cons) = forall (exists (fn arg =>
261.389 - is_rec arg andalso not (member (op =) ns (rec_of arg)) andalso
261.390 - ((rec_of arg = n andalso not (lazy_rec orelse is_lazy arg)) orelse
261.391 - rec_of arg <> n andalso rec_to (rec_of arg::ns)
261.392 - (lazy_rec orelse is_lazy arg) (n, (List.nth(conss,rec_of arg))))
261.393 - ) o snd) cons;
261.394 - fun warn (n,cons) =
261.395 - if rec_to [] false (n,cons)
261.396 - then (warning ("domain "^List.nth(dnames,n)^" is empty!"); true)
261.397 - else false;
261.398 -in
261.399 - val n__eqs = mapn (fn n => fn (_,cons) => (n,cons)) 0 eqs;
261.400 - val is_emptys = map warn n__eqs;
261.401 -end;
261.402 -*)
261.403 -
261.404 -(* Test for indirect recursion *)
261.405 -local
261.406 - val newTs = map (#absT o #iso_info) constr_infos;
261.407 - fun indirect_typ (Type (_, Ts)) =
261.408 - exists (fn T => member (op =) newTs T orelse indirect_typ T) Ts
261.409 - | indirect_typ _ = false;
261.410 - fun indirect_arg (_, T) = indirect_typ T;
261.411 - fun indirect_con (_, args) = exists indirect_arg args;
261.412 - fun indirect_eq cons = exists indirect_con cons;
261.413 -in
261.414 - val is_indirect = exists indirect_eq (map #con_specs constr_infos);
261.415 - val _ =
261.416 - if is_indirect
261.417 - then message "Indirect recursion detected, skipping proofs of (co)induction rules"
261.418 - else message ("Proving induction properties of domain "^comp_dname^" ...");
261.419 -end;
261.420 -
261.421 -(* theorems about take *)
261.422 -
261.423 -val (take_rewss, thy) =
261.424 - take_theorems dbinds take_info constr_infos thy;
261.425 -
261.426 -val {take_lemma_thms, take_0_thms, take_strict_thms, ...} = take_info;
261.427 -
261.428 -val take_rews = take_0_thms @ take_strict_thms @ flat take_rewss;
261.429 -
261.430 -(* prove induction rules, unless definition is indirect recursive *)
261.431 -val thy =
261.432 - if is_indirect then thy else
261.433 - prove_induction comp_dbind constr_infos take_info take_rews thy;
261.434 -
261.435 -val thy =
261.436 - if is_indirect then thy else
261.437 - prove_coinduction (comp_dbind, dbinds) constr_infos take_info take_rewss thy;
261.438 -
261.439 -in
261.440 - (take_rews, thy)
261.441 -end; (* let *)
261.442 -end; (* struct *)
262.1 --- a/src/HOLCF/Tools/Domain/domain_isomorphism.ML Sat Nov 27 14:34:54 2010 -0800
262.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
262.3 @@ -1,787 +0,0 @@
262.4 -(* Title: HOLCF/Tools/Domain/domain_isomorphism.ML
262.5 - Author: Brian Huffman
262.6 -
262.7 -Defines new types satisfying the given domain equations.
262.8 -*)
262.9 -
262.10 -signature DOMAIN_ISOMORPHISM =
262.11 -sig
262.12 - val domain_isomorphism :
262.13 - (string list * binding * mixfix * typ
262.14 - * (binding * binding) option) list ->
262.15 - theory ->
262.16 - (Domain_Take_Proofs.iso_info list
262.17 - * Domain_Take_Proofs.take_induct_info) * theory
262.18 -
262.19 - val define_map_functions :
262.20 - (binding * Domain_Take_Proofs.iso_info) list ->
262.21 - theory ->
262.22 - {
262.23 - map_consts : term list,
262.24 - map_apply_thms : thm list,
262.25 - map_unfold_thms : thm list,
262.26 - deflation_map_thms : thm list
262.27 - }
262.28 - * theory
262.29 -
262.30 - val domain_isomorphism_cmd :
262.31 - (string list * binding * mixfix * string * (binding * binding) option) list
262.32 - -> theory -> theory
262.33 -
262.34 - val setup : theory -> theory
262.35 -end;
262.36 -
262.37 -structure Domain_Isomorphism : DOMAIN_ISOMORPHISM =
262.38 -struct
262.39 -
262.40 -val beta_rules =
262.41 - @{thms beta_cfun cont_id cont_const cont2cont_APP cont2cont_LAM'} @
262.42 - @{thms cont2cont_fst cont2cont_snd cont2cont_Pair cont2cont_prod_case'};
262.43 -
262.44 -val beta_ss = HOL_basic_ss addsimps (simp_thms @ beta_rules);
262.45 -
262.46 -val beta_tac = simp_tac beta_ss;
262.47 -
262.48 -fun is_cpo thy T = Sign.of_sort thy (T, @{sort cpo});
262.49 -
262.50 -(******************************************************************************)
262.51 -(******************************** theory data *********************************)
262.52 -(******************************************************************************)
262.53 -
262.54 -structure RepData = Named_Thms
262.55 -(
262.56 - val name = "domain_defl_simps"
262.57 - val description = "theorems like DEFL('a t) = t_defl$DEFL('a)"
262.58 -)
262.59 -
262.60 -structure IsodeflData = Named_Thms
262.61 -(
262.62 - val name = "domain_isodefl"
262.63 - val description = "theorems like isodefl d t ==> isodefl (foo_map$d) (foo_defl$t)"
262.64 -);
262.65 -
262.66 -val setup = RepData.setup #> IsodeflData.setup
262.67 -
262.68 -
262.69 -(******************************************************************************)
262.70 -(************************** building types and terms **************************)
262.71 -(******************************************************************************)
262.72 -
262.73 -open HOLCF_Library;
262.74 -
262.75 -infixr 6 ->>;
262.76 -infixr -->>;
262.77 -
262.78 -val udomT = @{typ udom};
262.79 -val deflT = @{typ "defl"};
262.80 -
262.81 -fun mk_DEFL T =
262.82 - Const (@{const_name defl}, Term.itselfT T --> deflT) $ Logic.mk_type T;
262.83 -
262.84 -fun dest_DEFL (Const (@{const_name defl}, _) $ t) = Logic.dest_type t
262.85 - | dest_DEFL t = raise TERM ("dest_DEFL", [t]);
262.86 -
262.87 -fun mk_LIFTDEFL T =
262.88 - Const (@{const_name liftdefl}, Term.itselfT T --> deflT) $ Logic.mk_type T;
262.89 -
262.90 -fun dest_LIFTDEFL (Const (@{const_name liftdefl}, _) $ t) = Logic.dest_type t
262.91 - | dest_LIFTDEFL t = raise TERM ("dest_LIFTDEFL", [t]);
262.92 -
262.93 -fun mk_u_defl t = mk_capply (@{const "u_defl"}, t);
262.94 -
262.95 -fun mk_u_map t =
262.96 - let
262.97 - val (T, U) = dest_cfunT (fastype_of t);
262.98 - val u_map_type = (T ->> U) ->> (mk_upT T ->> mk_upT U);
262.99 - val u_map_const = Const (@{const_name u_map}, u_map_type);
262.100 - in
262.101 - mk_capply (u_map_const, t)
262.102 - end;
262.103 -
262.104 -fun emb_const T = Const (@{const_name emb}, T ->> udomT);
262.105 -fun prj_const T = Const (@{const_name prj}, udomT ->> T);
262.106 -fun coerce_const (T, U) = mk_cfcomp (prj_const U, emb_const T);
262.107 -
262.108 -fun isodefl_const T =
262.109 - Const (@{const_name isodefl}, (T ->> T) --> deflT --> HOLogic.boolT);
262.110 -
262.111 -fun mk_deflation t =
262.112 - Const (@{const_name deflation}, Term.fastype_of t --> boolT) $ t;
262.113 -
262.114 -(* splits a cterm into the right and lefthand sides of equality *)
262.115 -fun dest_eqs t = HOLogic.dest_eq (HOLogic.dest_Trueprop t);
262.116 -
262.117 -fun mk_eqs (t, u) = HOLogic.mk_Trueprop (HOLogic.mk_eq (t, u));
262.118 -
262.119 -(******************************************************************************)
262.120 -(****************************** isomorphism info ******************************)
262.121 -(******************************************************************************)
262.122 -
262.123 -fun deflation_abs_rep (info : Domain_Take_Proofs.iso_info) : thm =
262.124 - let
262.125 - val abs_iso = #abs_inverse info;
262.126 - val rep_iso = #rep_inverse info;
262.127 - val thm = @{thm deflation_abs_rep} OF [abs_iso, rep_iso];
262.128 - in
262.129 - Drule.zero_var_indexes thm
262.130 - end
262.131 -
262.132 -(******************************************************************************)
262.133 -(*************** fixed-point definitions and unfolding theorems ***************)
262.134 -(******************************************************************************)
262.135 -
262.136 -fun mk_projs [] t = []
262.137 - | mk_projs (x::[]) t = [(x, t)]
262.138 - | mk_projs (x::xs) t = (x, mk_fst t) :: mk_projs xs (mk_snd t);
262.139 -
262.140 -fun add_fixdefs
262.141 - (spec : (binding * term) list)
262.142 - (thy : theory) : (thm list * thm list) * theory =
262.143 - let
262.144 - val binds = map fst spec;
262.145 - val (lhss, rhss) = ListPair.unzip (map (dest_eqs o snd) spec);
262.146 - val functional = lambda_tuple lhss (mk_tuple rhss);
262.147 - val fixpoint = mk_fix (mk_cabs functional);
262.148 -
262.149 - (* project components of fixpoint *)
262.150 - val projs = mk_projs lhss fixpoint;
262.151 -
262.152 - (* convert parameters to lambda abstractions *)
262.153 - fun mk_eqn (lhs, rhs) =
262.154 - case lhs of
262.155 - Const (@{const_name Rep_cfun}, _) $ f $ (x as Free _) =>
262.156 - mk_eqn (f, big_lambda x rhs)
262.157 - | f $ Const (@{const_name TYPE}, T) =>
262.158 - mk_eqn (f, Abs ("t", T, rhs))
262.159 - | Const _ => Logic.mk_equals (lhs, rhs)
262.160 - | _ => raise TERM ("lhs not of correct form", [lhs, rhs]);
262.161 - val eqns = map mk_eqn projs;
262.162 -
262.163 - (* register constant definitions *)
262.164 - val (fixdef_thms, thy) =
262.165 - (Global_Theory.add_defs false o map Thm.no_attributes)
262.166 - (map (Binding.suffix_name "_def") binds ~~ eqns) thy;
262.167 -
262.168 - (* prove applied version of definitions *)
262.169 - fun prove_proj (lhs, rhs) =
262.170 - let
262.171 - val tac = rewrite_goals_tac fixdef_thms THEN beta_tac 1;
262.172 - val goal = Logic.mk_equals (lhs, rhs);
262.173 - in Goal.prove_global thy [] [] goal (K tac) end;
262.174 - val proj_thms = map prove_proj projs;
262.175 -
262.176 - (* mk_tuple lhss == fixpoint *)
262.177 - fun pair_equalI (thm1, thm2) = @{thm Pair_equalI} OF [thm1, thm2];
262.178 - val tuple_fixdef_thm = foldr1 pair_equalI proj_thms;
262.179 -
262.180 - val cont_thm =
262.181 - Goal.prove_global thy [] [] (mk_trp (mk_cont functional))
262.182 - (K (beta_tac 1));
262.183 - val tuple_unfold_thm =
262.184 - (@{thm def_cont_fix_eq} OF [tuple_fixdef_thm, cont_thm])
262.185 - |> Local_Defs.unfold (ProofContext.init_global thy) @{thms split_conv};
262.186 -
262.187 - fun mk_unfold_thms [] thm = []
262.188 - | mk_unfold_thms (n::[]) thm = [(n, thm)]
262.189 - | mk_unfold_thms (n::ns) thm = let
262.190 - val thmL = thm RS @{thm Pair_eqD1};
262.191 - val thmR = thm RS @{thm Pair_eqD2};
262.192 - in (n, thmL) :: mk_unfold_thms ns thmR end;
262.193 - val unfold_binds = map (Binding.suffix_name "_unfold") binds;
262.194 -
262.195 - (* register unfold theorems *)
262.196 - val (unfold_thms, thy) =
262.197 - (Global_Theory.add_thms o map (Thm.no_attributes o apsnd Drule.zero_var_indexes))
262.198 - (mk_unfold_thms unfold_binds tuple_unfold_thm) thy;
262.199 - in
262.200 - ((proj_thms, unfold_thms), thy)
262.201 - end;
262.202 -
262.203 -
262.204 -(******************************************************************************)
262.205 -(****************** deflation combinators and map functions *******************)
262.206 -(******************************************************************************)
262.207 -
262.208 -fun defl_of_typ
262.209 - (thy : theory)
262.210 - (tab1 : (typ * term) list)
262.211 - (tab2 : (typ * term) list)
262.212 - (T : typ) : term =
262.213 - let
262.214 - val defl_simps = RepData.get (ProofContext.init_global thy);
262.215 - val rules = map (Thm.concl_of #> HOLogic.dest_Trueprop #> HOLogic.dest_eq) defl_simps;
262.216 - val rules' = map (apfst mk_DEFL) tab1 @ map (apfst mk_LIFTDEFL) tab2;
262.217 - fun proc1 t =
262.218 - (case dest_DEFL t of
262.219 - TFree (a, _) => SOME (Free ("d" ^ Library.unprefix "'" a, deflT))
262.220 - | _ => NONE) handle TERM _ => NONE;
262.221 - fun proc2 t =
262.222 - (case dest_LIFTDEFL t of
262.223 - TFree (a, _) => SOME (Free ("p" ^ Library.unprefix "'" a, deflT))
262.224 - | _ => NONE) handle TERM _ => NONE;
262.225 - in
262.226 - Pattern.rewrite_term thy (rules @ rules') [proc1, proc2] (mk_DEFL T)
262.227 - end;
262.228 -
262.229 -(******************************************************************************)
262.230 -(********************* declaring definitions and theorems *********************)
262.231 -(******************************************************************************)
262.232 -
262.233 -fun define_const
262.234 - (bind : binding, rhs : term)
262.235 - (thy : theory)
262.236 - : (term * thm) * theory =
262.237 - let
262.238 - val typ = Term.fastype_of rhs;
262.239 - val (const, thy) = Sign.declare_const ((bind, typ), NoSyn) thy;
262.240 - val eqn = Logic.mk_equals (const, rhs);
262.241 - val def = Thm.no_attributes (Binding.suffix_name "_def" bind, eqn);
262.242 - val (def_thm, thy) = yield_singleton (Global_Theory.add_defs false) def thy;
262.243 - in
262.244 - ((const, def_thm), thy)
262.245 - end;
262.246 -
262.247 -fun add_qualified_thm name (dbind, thm) =
262.248 - yield_singleton Global_Theory.add_thms
262.249 - ((Binding.qualified true name dbind, thm), []);
262.250 -
262.251 -(******************************************************************************)
262.252 -(*************************** defining map functions ***************************)
262.253 -(******************************************************************************)
262.254 -
262.255 -fun define_map_functions
262.256 - (spec : (binding * Domain_Take_Proofs.iso_info) list)
262.257 - (thy : theory) =
262.258 - let
262.259 -
262.260 - (* retrieve components of spec *)
262.261 - val dbinds = map fst spec;
262.262 - val iso_infos = map snd spec;
262.263 - val dom_eqns = map (fn x => (#absT x, #repT x)) iso_infos;
262.264 - val rep_abs_consts = map (fn x => (#rep_const x, #abs_const x)) iso_infos;
262.265 -
262.266 - fun mapT (T as Type (_, Ts)) =
262.267 - (map (fn T => T ->> T) (filter (is_cpo thy) Ts)) -->> (T ->> T)
262.268 - | mapT T = T ->> T;
262.269 -
262.270 - (* declare map functions *)
262.271 - fun declare_map_const (tbind, (lhsT, rhsT)) thy =
262.272 - let
262.273 - val map_type = mapT lhsT;
262.274 - val map_bind = Binding.suffix_name "_map" tbind;
262.275 - in
262.276 - Sign.declare_const ((map_bind, map_type), NoSyn) thy
262.277 - end;
262.278 - val (map_consts, thy) = thy |>
262.279 - fold_map declare_map_const (dbinds ~~ dom_eqns);
262.280 -
262.281 - (* defining equations for map functions *)
262.282 - local
262.283 - fun unprime a = Library.unprefix "'" a;
262.284 - fun mapvar T = Free (unprime (fst (dest_TFree T)), T ->> T);
262.285 - fun map_lhs (map_const, lhsT) =
262.286 - (lhsT, list_ccomb (map_const, map mapvar (filter (is_cpo thy) (snd (dest_Type lhsT)))));
262.287 - val tab1 = map map_lhs (map_consts ~~ map fst dom_eqns);
262.288 - val Ts = (snd o dest_Type o fst o hd) dom_eqns;
262.289 - val tab = (Ts ~~ map mapvar Ts) @ tab1;
262.290 - fun mk_map_spec (((rep_const, abs_const), map_const), (lhsT, rhsT)) =
262.291 - let
262.292 - val lhs = Domain_Take_Proofs.map_of_typ thy tab lhsT;
262.293 - val body = Domain_Take_Proofs.map_of_typ thy tab rhsT;
262.294 - val rhs = mk_cfcomp (abs_const, mk_cfcomp (body, rep_const));
262.295 - in mk_eqs (lhs, rhs) end;
262.296 - in
262.297 - val map_specs =
262.298 - map mk_map_spec (rep_abs_consts ~~ map_consts ~~ dom_eqns);
262.299 - end;
262.300 -
262.301 - (* register recursive definition of map functions *)
262.302 - val map_binds = map (Binding.suffix_name "_map") dbinds;
262.303 - val ((map_apply_thms, map_unfold_thms), thy) =
262.304 - add_fixdefs (map_binds ~~ map_specs) thy;
262.305 -
262.306 - (* prove deflation theorems for map functions *)
262.307 - val deflation_abs_rep_thms = map deflation_abs_rep iso_infos;
262.308 - val deflation_map_thm =
262.309 - let
262.310 - fun unprime a = Library.unprefix "'" a;
262.311 - fun mk_f T = Free (unprime (fst (dest_TFree T)), T ->> T);
262.312 - fun mk_assm T = mk_trp (mk_deflation (mk_f T));
262.313 - fun mk_goal (map_const, (lhsT, rhsT)) =
262.314 - let
262.315 - val (_, Ts) = dest_Type lhsT;
262.316 - val map_term = list_ccomb (map_const, map mk_f (filter (is_cpo thy) Ts));
262.317 - in mk_deflation map_term end;
262.318 - val assms = (map mk_assm o filter (is_cpo thy) o snd o dest_Type o fst o hd) dom_eqns;
262.319 - val goals = map mk_goal (map_consts ~~ dom_eqns);
262.320 - val goal = mk_trp (foldr1 HOLogic.mk_conj goals);
262.321 - val start_thms =
262.322 - @{thm split_def} :: map_apply_thms;
262.323 - val adm_rules =
262.324 - @{thms adm_conj adm_subst [OF _ adm_deflation]
262.325 - cont2cont_fst cont2cont_snd cont_id};
262.326 - val bottom_rules =
262.327 - @{thms fst_strict snd_strict deflation_UU simp_thms};
262.328 - val deflation_rules =
262.329 - @{thms conjI deflation_ID}
262.330 - @ deflation_abs_rep_thms
262.331 - @ Domain_Take_Proofs.get_deflation_thms thy;
262.332 - in
262.333 - Goal.prove_global thy [] assms goal (fn {prems, ...} =>
262.334 - EVERY
262.335 - [simp_tac (HOL_basic_ss addsimps start_thms) 1,
262.336 - rtac @{thm fix_ind} 1,
262.337 - REPEAT (resolve_tac adm_rules 1),
262.338 - simp_tac (HOL_basic_ss addsimps bottom_rules) 1,
262.339 - simp_tac beta_ss 1,
262.340 - simp_tac (HOL_basic_ss addsimps @{thms fst_conv snd_conv}) 1,
262.341 - REPEAT (etac @{thm conjE} 1),
262.342 - REPEAT (resolve_tac (deflation_rules @ prems) 1 ORELSE atac 1)])
262.343 - end;
262.344 - fun conjuncts [] thm = []
262.345 - | conjuncts (n::[]) thm = [(n, thm)]
262.346 - | conjuncts (n::ns) thm = let
262.347 - val thmL = thm RS @{thm conjunct1};
262.348 - val thmR = thm RS @{thm conjunct2};
262.349 - in (n, thmL):: conjuncts ns thmR end;
262.350 - val deflation_map_binds = dbinds |>
262.351 - map (Binding.prefix_name "deflation_" o Binding.suffix_name "_map");
262.352 - val (deflation_map_thms, thy) = thy |>
262.353 - (Global_Theory.add_thms o map (Thm.no_attributes o apsnd Drule.zero_var_indexes))
262.354 - (conjuncts deflation_map_binds deflation_map_thm);
262.355 -
262.356 - (* register indirect recursion in theory data *)
262.357 - local
262.358 - fun register_map (dname, args) =
262.359 - Domain_Take_Proofs.add_rec_type (dname, args);
262.360 - val dnames = map (fst o dest_Type o fst) dom_eqns;
262.361 - val map_names = map (fst o dest_Const) map_consts;
262.362 - fun args (T, _) = case T of Type (_, Ts) => map (is_cpo thy) Ts | _ => [];
262.363 - val argss = map args dom_eqns;
262.364 - in
262.365 - val thy =
262.366 - fold register_map (dnames ~~ argss) thy;
262.367 - end;
262.368 -
262.369 - (* register deflation theorems *)
262.370 - val thy = fold Domain_Take_Proofs.add_deflation_thm deflation_map_thms thy;
262.371 -
262.372 - val result =
262.373 - {
262.374 - map_consts = map_consts,
262.375 - map_apply_thms = map_apply_thms,
262.376 - map_unfold_thms = map_unfold_thms,
262.377 - deflation_map_thms = deflation_map_thms
262.378 - }
262.379 - in
262.380 - (result, thy)
262.381 - end;
262.382 -
262.383 -(******************************************************************************)
262.384 -(******************************* main function ********************************)
262.385 -(******************************************************************************)
262.386 -
262.387 -fun read_typ thy str sorts =
262.388 - let
262.389 - val ctxt = ProofContext.init_global thy
262.390 - |> fold (Variable.declare_typ o TFree) sorts;
262.391 - val T = Syntax.read_typ ctxt str;
262.392 - in (T, Term.add_tfreesT T sorts) end;
262.393 -
262.394 -fun cert_typ sign raw_T sorts =
262.395 - let
262.396 - val T = Type.no_tvars (Sign.certify_typ sign raw_T)
262.397 - handle TYPE (msg, _, _) => error msg;
262.398 - val sorts' = Term.add_tfreesT T sorts;
262.399 - val _ =
262.400 - case duplicates (op =) (map fst sorts') of
262.401 - [] => ()
262.402 - | dups => error ("Inconsistent sort constraints for " ^ commas dups)
262.403 - in (T, sorts') end;
262.404 -
262.405 -fun gen_domain_isomorphism
262.406 - (prep_typ: theory -> 'a -> (string * sort) list -> typ * (string * sort) list)
262.407 - (doms_raw: (string list * binding * mixfix * 'a * (binding * binding) option) list)
262.408 - (thy: theory)
262.409 - : (Domain_Take_Proofs.iso_info list
262.410 - * Domain_Take_Proofs.take_induct_info) * theory =
262.411 - let
262.412 - val _ = Theory.requires thy "Domain" "domain isomorphisms";
262.413 -
262.414 - (* this theory is used just for parsing *)
262.415 - val tmp_thy = thy |>
262.416 - Theory.copy |>
262.417 - Sign.add_types (map (fn (tvs, tbind, mx, _, morphs) =>
262.418 - (tbind, length tvs, mx)) doms_raw);
262.419 -
262.420 - fun prep_dom thy (vs, t, mx, typ_raw, morphs) sorts =
262.421 - let val (typ, sorts') = prep_typ thy typ_raw sorts
262.422 - in ((vs, t, mx, typ, morphs), sorts') end;
262.423 -
262.424 - val (doms : (string list * binding * mixfix * typ * (binding * binding) option) list,
262.425 - sorts : (string * sort) list) =
262.426 - fold_map (prep_dom tmp_thy) doms_raw [];
262.427 -
262.428 - (* lookup function for sorts of type variables *)
262.429 - fun the_sort v = the (AList.lookup (op =) sorts v);
262.430 -
262.431 - (* declare arities in temporary theory *)
262.432 - val tmp_thy =
262.433 - let
262.434 - fun arity (vs, tbind, mx, _, _) =
262.435 - (Sign.full_name thy tbind, map the_sort vs, @{sort "domain"});
262.436 - in
262.437 - fold AxClass.axiomatize_arity (map arity doms) tmp_thy
262.438 - end;
262.439 -
262.440 - (* check bifiniteness of right-hand sides *)
262.441 - fun check_rhs (vs, tbind, mx, rhs, morphs) =
262.442 - if Sign.of_sort tmp_thy (rhs, @{sort "domain"}) then ()
262.443 - else error ("Type not of sort domain: " ^
262.444 - quote (Syntax.string_of_typ_global tmp_thy rhs));
262.445 - val _ = map check_rhs doms;
262.446 -
262.447 - (* domain equations *)
262.448 - fun mk_dom_eqn (vs, tbind, mx, rhs, morphs) =
262.449 - let fun arg v = TFree (v, the_sort v);
262.450 - in (Type (Sign.full_name tmp_thy tbind, map arg vs), rhs) end;
262.451 - val dom_eqns = map mk_dom_eqn doms;
262.452 -
262.453 - (* check for valid type parameters *)
262.454 - val (tyvars, _, _, _, _) = hd doms;
262.455 - val new_doms = map (fn (tvs, tname, mx, _, _) =>
262.456 - let val full_tname = Sign.full_name tmp_thy tname
262.457 - in
262.458 - (case duplicates (op =) tvs of
262.459 - [] =>
262.460 - if eq_set (op =) (tyvars, tvs) then (full_tname, tvs)
262.461 - else error ("Mutually recursive domains must have same type parameters")
262.462 - | dups => error ("Duplicate parameter(s) for domain " ^ quote (Binding.str_of tname) ^
262.463 - " : " ^ commas dups))
262.464 - end) doms;
262.465 - val dbinds = map (fn (_, dbind, _, _, _) => dbind) doms;
262.466 - val morphs = map (fn (_, _, _, _, morphs) => morphs) doms;
262.467 -
262.468 - (* determine deflation combinator arguments *)
262.469 - val lhsTs : typ list = map fst dom_eqns;
262.470 - val defl_rec = Free ("t", mk_tupleT (map (K deflT) lhsTs));
262.471 - val defl_recs = mk_projs lhsTs defl_rec;
262.472 - val defl_recs' = map (apsnd mk_u_defl) defl_recs;
262.473 - fun defl_body (_, _, _, rhsT, _) =
262.474 - defl_of_typ tmp_thy defl_recs defl_recs' rhsT;
262.475 - val functional = Term.lambda defl_rec (mk_tuple (map defl_body doms));
262.476 -
262.477 - val tfrees = map fst (Term.add_tfrees functional []);
262.478 - val frees = map fst (Term.add_frees functional []);
262.479 - fun get_defl_flags (vs, _, _, _, _) =
262.480 - let
262.481 - fun argT v = TFree (v, the_sort v);
262.482 - fun mk_d v = "d" ^ Library.unprefix "'" v;
262.483 - fun mk_p v = "p" ^ Library.unprefix "'" v;
262.484 - val args = maps (fn v => [(mk_d v, mk_DEFL (argT v)), (mk_p v, mk_LIFTDEFL (argT v))]) vs;
262.485 - val typeTs = map argT (filter (member (op =) tfrees) vs);
262.486 - val defl_args = map snd (filter (member (op =) frees o fst) args);
262.487 - in
262.488 - (typeTs, defl_args)
262.489 - end;
262.490 - val defl_flagss = map get_defl_flags doms;
262.491 -
262.492 - (* declare deflation combinator constants *)
262.493 - fun declare_defl_const ((typeTs, defl_args), (_, tbind, _, _, _)) thy =
262.494 - let
262.495 - val defl_bind = Binding.suffix_name "_defl" tbind;
262.496 - val defl_type =
262.497 - map Term.itselfT typeTs ---> map (K deflT) defl_args -->> deflT;
262.498 - in
262.499 - Sign.declare_const ((defl_bind, defl_type), NoSyn) thy
262.500 - end;
262.501 - val (defl_consts, thy) =
262.502 - fold_map declare_defl_const (defl_flagss ~~ doms) thy;
262.503 -
262.504 - (* defining equations for type combinators *)
262.505 - fun mk_defl_term (defl_const, (typeTs, defl_args)) =
262.506 - let
262.507 - val type_args = map Logic.mk_type typeTs;
262.508 - in
262.509 - list_ccomb (list_comb (defl_const, type_args), defl_args)
262.510 - end;
262.511 - val defl_terms = map mk_defl_term (defl_consts ~~ defl_flagss);
262.512 - val defl_tab = map fst dom_eqns ~~ defl_terms;
262.513 - val defl_tab' = map fst dom_eqns ~~ map mk_u_defl defl_terms;
262.514 - fun mk_defl_spec (lhsT, rhsT) =
262.515 - mk_eqs (defl_of_typ tmp_thy defl_tab defl_tab' lhsT,
262.516 - defl_of_typ tmp_thy defl_tab defl_tab' rhsT);
262.517 - val defl_specs = map mk_defl_spec dom_eqns;
262.518 -
262.519 - (* register recursive definition of deflation combinators *)
262.520 - val defl_binds = map (Binding.suffix_name "_defl") dbinds;
262.521 - val ((defl_apply_thms, defl_unfold_thms), thy) =
262.522 - add_fixdefs (defl_binds ~~ defl_specs) thy;
262.523 -
262.524 - (* define types using deflation combinators *)
262.525 - fun make_repdef ((vs, tbind, mx, _, _), defl) thy =
262.526 - let
262.527 - val spec = (tbind, map (rpair dummyS) vs, mx);
262.528 - val ((_, _, _, {DEFL, liftemb_def, liftprj_def, ...}), thy) =
262.529 - Domaindef.add_domaindef false NONE spec defl NONE thy;
262.530 - (* declare domain_defl_simps rules *)
262.531 - val thy = Context.theory_map (RepData.add_thm DEFL) thy;
262.532 - in
262.533 - (DEFL, thy)
262.534 - end;
262.535 - val (DEFL_thms, thy) = fold_map make_repdef (doms ~~ defl_terms) thy;
262.536 -
262.537 - (* prove DEFL equations *)
262.538 - fun mk_DEFL_eq_thm (lhsT, rhsT) =
262.539 - let
262.540 - val goal = mk_eqs (mk_DEFL lhsT, mk_DEFL rhsT);
262.541 - val DEFL_simps = RepData.get (ProofContext.init_global thy);
262.542 - val tac =
262.543 - rewrite_goals_tac (map mk_meta_eq DEFL_simps)
262.544 - THEN TRY (resolve_tac defl_unfold_thms 1);
262.545 - in
262.546 - Goal.prove_global thy [] [] goal (K tac)
262.547 - end;
262.548 - val DEFL_eq_thms = map mk_DEFL_eq_thm dom_eqns;
262.549 -
262.550 - (* register DEFL equations *)
262.551 - val DEFL_eq_binds = map (Binding.prefix_name "DEFL_eq_") dbinds;
262.552 - val (_, thy) = thy |>
262.553 - (Global_Theory.add_thms o map Thm.no_attributes)
262.554 - (DEFL_eq_binds ~~ DEFL_eq_thms);
262.555 -
262.556 - (* define rep/abs functions *)
262.557 - fun mk_rep_abs ((tbind, morphs), (lhsT, rhsT)) thy =
262.558 - let
262.559 - val rep_bind = Binding.suffix_name "_rep" tbind;
262.560 - val abs_bind = Binding.suffix_name "_abs" tbind;
262.561 - val ((rep_const, rep_def), thy) =
262.562 - define_const (rep_bind, coerce_const (lhsT, rhsT)) thy;
262.563 - val ((abs_const, abs_def), thy) =
262.564 - define_const (abs_bind, coerce_const (rhsT, lhsT)) thy;
262.565 - in
262.566 - (((rep_const, abs_const), (rep_def, abs_def)), thy)
262.567 - end;
262.568 - val ((rep_abs_consts, rep_abs_defs), thy) = thy
262.569 - |> fold_map mk_rep_abs (dbinds ~~ morphs ~~ dom_eqns)
262.570 - |>> ListPair.unzip;
262.571 -
262.572 - (* prove isomorphism and isodefl rules *)
262.573 - fun mk_iso_thms ((tbind, DEFL_eq), (rep_def, abs_def)) thy =
262.574 - let
262.575 - fun make thm =
262.576 - Drule.zero_var_indexes (thm OF [DEFL_eq, abs_def, rep_def]);
262.577 - val rep_iso_thm = make @{thm domain_rep_iso};
262.578 - val abs_iso_thm = make @{thm domain_abs_iso};
262.579 - val isodefl_thm = make @{thm isodefl_abs_rep};
262.580 - val thy = thy
262.581 - |> snd o add_qualified_thm "rep_iso" (tbind, rep_iso_thm)
262.582 - |> snd o add_qualified_thm "abs_iso" (tbind, abs_iso_thm)
262.583 - |> snd o add_qualified_thm "isodefl_abs_rep" (tbind, isodefl_thm);
262.584 - in
262.585 - (((rep_iso_thm, abs_iso_thm), isodefl_thm), thy)
262.586 - end;
262.587 - val ((iso_thms, isodefl_abs_rep_thms), thy) =
262.588 - thy
262.589 - |> fold_map mk_iso_thms (dbinds ~~ DEFL_eq_thms ~~ rep_abs_defs)
262.590 - |>> ListPair.unzip;
262.591 -
262.592 - (* collect info about rep/abs *)
262.593 - val iso_infos : Domain_Take_Proofs.iso_info list =
262.594 - let
262.595 - fun mk_info (((lhsT, rhsT), (repC, absC)), (rep_iso, abs_iso)) =
262.596 - {
262.597 - repT = rhsT,
262.598 - absT = lhsT,
262.599 - rep_const = repC,
262.600 - abs_const = absC,
262.601 - rep_inverse = rep_iso,
262.602 - abs_inverse = abs_iso
262.603 - };
262.604 - in
262.605 - map mk_info (dom_eqns ~~ rep_abs_consts ~~ iso_thms)
262.606 - end
262.607 -
262.608 - (* definitions and proofs related to map functions *)
262.609 - val (map_info, thy) =
262.610 - define_map_functions (dbinds ~~ iso_infos) thy;
262.611 - val { map_consts, map_apply_thms, map_unfold_thms,
262.612 - deflation_map_thms } = map_info;
262.613 -
262.614 - (* prove isodefl rules for map functions *)
262.615 - val isodefl_thm =
262.616 - let
262.617 - fun unprime a = Library.unprefix "'" a;
262.618 - fun mk_d T = Free ("d" ^ unprime (fst (dest_TFree T)), deflT);
262.619 - fun mk_p T = Free ("p" ^ unprime (fst (dest_TFree T)), deflT);
262.620 - fun mk_f T = Free ("f" ^ unprime (fst (dest_TFree T)), T ->> T);
262.621 - fun mk_assm t =
262.622 - case try dest_LIFTDEFL t of
262.623 - SOME T => mk_trp (isodefl_const (mk_upT T) $ mk_u_map (mk_f T) $ mk_p T)
262.624 - | NONE =>
262.625 - let val T = dest_DEFL t
262.626 - in mk_trp (isodefl_const T $ mk_f T $ mk_d T) end;
262.627 - fun mk_goal (map_const, (T, rhsT)) =
262.628 - let
262.629 - val (_, Ts) = dest_Type T;
262.630 - val map_term = list_ccomb (map_const, map mk_f (filter (is_cpo thy) Ts));
262.631 - val defl_term = defl_of_typ thy (Ts ~~ map mk_d Ts) (Ts ~~ map mk_p Ts) T;
262.632 - in isodefl_const T $ map_term $ defl_term end;
262.633 - val assms = (map mk_assm o snd o hd) defl_flagss;
262.634 - val goals = map mk_goal (map_consts ~~ dom_eqns);
262.635 - val goal = mk_trp (foldr1 HOLogic.mk_conj goals);
262.636 - val start_thms =
262.637 - @{thm split_def} :: defl_apply_thms @ map_apply_thms;
262.638 - val adm_rules =
262.639 - @{thms adm_conj adm_isodefl cont2cont_fst cont2cont_snd cont_id};
262.640 - val bottom_rules =
262.641 - @{thms fst_strict snd_strict isodefl_bottom simp_thms};
262.642 - val map_ID_thms = Domain_Take_Proofs.get_map_ID_thms thy;
262.643 - val map_ID_simps = map (fn th => th RS sym) map_ID_thms;
262.644 - val isodefl_rules =
262.645 - @{thms conjI isodefl_ID_DEFL isodefl_LIFTDEFL}
262.646 - @ isodefl_abs_rep_thms
262.647 - @ IsodeflData.get (ProofContext.init_global thy);
262.648 - in
262.649 - Goal.prove_global thy [] assms goal (fn {prems, ...} =>
262.650 - EVERY
262.651 - [simp_tac (HOL_basic_ss addsimps start_thms) 1,
262.652 - (* FIXME: how reliable is unification here? *)
262.653 - (* Maybe I should instantiate the rule. *)
262.654 - rtac @{thm parallel_fix_ind} 1,
262.655 - REPEAT (resolve_tac adm_rules 1),
262.656 - simp_tac (HOL_basic_ss addsimps bottom_rules) 1,
262.657 - simp_tac beta_ss 1,
262.658 - simp_tac (HOL_basic_ss addsimps @{thms fst_conv snd_conv}) 1,
262.659 - simp_tac (HOL_basic_ss addsimps map_ID_simps) 1,
262.660 - REPEAT (etac @{thm conjE} 1),
262.661 - REPEAT (resolve_tac (isodefl_rules @ prems) 1 ORELSE atac 1)])
262.662 - end;
262.663 - val isodefl_binds = map (Binding.prefix_name "isodefl_") dbinds;
262.664 - fun conjuncts [] thm = []
262.665 - | conjuncts (n::[]) thm = [(n, thm)]
262.666 - | conjuncts (n::ns) thm = let
262.667 - val thmL = thm RS @{thm conjunct1};
262.668 - val thmR = thm RS @{thm conjunct2};
262.669 - in (n, thmL):: conjuncts ns thmR end;
262.670 - val (isodefl_thms, thy) = thy |>
262.671 - (Global_Theory.add_thms o map (Thm.no_attributes o apsnd Drule.zero_var_indexes))
262.672 - (conjuncts isodefl_binds isodefl_thm);
262.673 - val thy = fold (Context.theory_map o IsodeflData.add_thm) isodefl_thms thy;
262.674 -
262.675 - (* prove map_ID theorems *)
262.676 - fun prove_map_ID_thm
262.677 - (((map_const, (lhsT, _)), DEFL_thm), isodefl_thm) =
262.678 - let
262.679 - val Ts = snd (dest_Type lhsT);
262.680 - fun is_cpo T = Sign.of_sort thy (T, @{sort cpo});
262.681 - val lhs = list_ccomb (map_const, map mk_ID (filter is_cpo Ts));
262.682 - val goal = mk_eqs (lhs, mk_ID lhsT);
262.683 - val tac = EVERY
262.684 - [rtac @{thm isodefl_DEFL_imp_ID} 1,
262.685 - stac DEFL_thm 1,
262.686 - rtac isodefl_thm 1,
262.687 - REPEAT (resolve_tac @{thms isodefl_ID_DEFL isodefl_LIFTDEFL} 1)];
262.688 - in
262.689 - Goal.prove_global thy [] [] goal (K tac)
262.690 - end;
262.691 - val map_ID_binds = map (Binding.suffix_name "_map_ID") dbinds;
262.692 - val map_ID_thms =
262.693 - map prove_map_ID_thm
262.694 - (map_consts ~~ dom_eqns ~~ DEFL_thms ~~ isodefl_thms);
262.695 - val (_, thy) = thy |>
262.696 - (Global_Theory.add_thms o map (rpair [Domain_Take_Proofs.map_ID_add]))
262.697 - (map_ID_binds ~~ map_ID_thms);
262.698 -
262.699 - (* definitions and proofs related to take functions *)
262.700 - val (take_info, thy) =
262.701 - Domain_Take_Proofs.define_take_functions
262.702 - (dbinds ~~ iso_infos) thy;
262.703 - val { take_consts, chain_take_thms, take_0_thms, take_Suc_thms, ...} =
262.704 - take_info;
262.705 -
262.706 - (* least-upper-bound lemma for take functions *)
262.707 - val lub_take_lemma =
262.708 - let
262.709 - val lhs = mk_tuple (map mk_lub take_consts);
262.710 - fun is_cpo T = Sign.of_sort thy (T, @{sort cpo});
262.711 - fun mk_map_ID (map_const, (lhsT, rhsT)) =
262.712 - list_ccomb (map_const, map mk_ID (filter is_cpo (snd (dest_Type lhsT))));
262.713 - val rhs = mk_tuple (map mk_map_ID (map_consts ~~ dom_eqns));
262.714 - val goal = mk_trp (mk_eq (lhs, rhs));
262.715 - val map_ID_thms = Domain_Take_Proofs.get_map_ID_thms thy;
262.716 - val start_rules =
262.717 - @{thms lub_Pair [symmetric] ch2ch_Pair} @ chain_take_thms
262.718 - @ @{thms pair_collapse split_def}
262.719 - @ map_apply_thms @ map_ID_thms;
262.720 - val rules0 =
262.721 - @{thms iterate_0 Pair_strict} @ take_0_thms;
262.722 - val rules1 =
262.723 - @{thms iterate_Suc Pair_fst_snd_eq fst_conv snd_conv}
262.724 - @ take_Suc_thms;
262.725 - val tac =
262.726 - EVERY
262.727 - [simp_tac (HOL_basic_ss addsimps start_rules) 1,
262.728 - simp_tac (HOL_basic_ss addsimps @{thms fix_def2}) 1,
262.729 - rtac @{thm lub_eq} 1,
262.730 - rtac @{thm nat.induct} 1,
262.731 - simp_tac (HOL_basic_ss addsimps rules0) 1,
262.732 - asm_full_simp_tac (beta_ss addsimps rules1) 1];
262.733 - in
262.734 - Goal.prove_global thy [] [] goal (K tac)
262.735 - end;
262.736 -
262.737 - (* prove lub of take equals ID *)
262.738 - fun prove_lub_take (((dbind, take_const), map_ID_thm), (lhsT, rhsT)) thy =
262.739 - let
262.740 - val n = Free ("n", natT);
262.741 - val goal = mk_eqs (mk_lub (lambda n (take_const $ n)), mk_ID lhsT);
262.742 - val tac =
262.743 - EVERY
262.744 - [rtac @{thm trans} 1, rtac map_ID_thm 2,
262.745 - cut_facts_tac [lub_take_lemma] 1,
262.746 - REPEAT (etac @{thm Pair_inject} 1), atac 1];
262.747 - val lub_take_thm = Goal.prove_global thy [] [] goal (K tac);
262.748 - in
262.749 - add_qualified_thm "lub_take" (dbind, lub_take_thm) thy
262.750 - end;
262.751 - val (lub_take_thms, thy) =
262.752 - fold_map prove_lub_take
262.753 - (dbinds ~~ take_consts ~~ map_ID_thms ~~ dom_eqns) thy;
262.754 -
262.755 - (* prove additional take theorems *)
262.756 - val (take_info2, thy) =
262.757 - Domain_Take_Proofs.add_lub_take_theorems
262.758 - (dbinds ~~ iso_infos) take_info lub_take_thms thy;
262.759 - in
262.760 - ((iso_infos, take_info2), thy)
262.761 - end;
262.762 -
262.763 -val domain_isomorphism = gen_domain_isomorphism cert_typ;
262.764 -val domain_isomorphism_cmd = snd oo gen_domain_isomorphism read_typ;
262.765 -
262.766 -(******************************************************************************)
262.767 -(******************************** outer syntax ********************************)
262.768 -(******************************************************************************)
262.769 -
262.770 -local
262.771 -
262.772 -val parse_domain_iso :
262.773 - (string list * binding * mixfix * string * (binding * binding) option)
262.774 - parser =
262.775 - (Parse.type_args -- Parse.binding -- Parse.opt_mixfix -- (Parse.$$$ "=" |-- Parse.typ) --
262.776 - Scan.option (Parse.$$$ "morphisms" |-- Parse.!!! (Parse.binding -- Parse.binding)))
262.777 - >> (fn ((((vs, t), mx), rhs), morphs) => (vs, t, mx, rhs, morphs));
262.778 -
262.779 -val parse_domain_isos = Parse.and_list1 parse_domain_iso;
262.780 -
262.781 -in
262.782 -
262.783 -val _ =
262.784 - Outer_Syntax.command "domain_isomorphism" "define domain isomorphisms (HOLCF)"
262.785 - Keyword.thy_decl
262.786 - (parse_domain_isos >> (Toplevel.theory o domain_isomorphism_cmd));
262.787 -
262.788 -end;
262.789 -
262.790 -end;
263.1 --- a/src/HOLCF/Tools/Domain/domain_take_proofs.ML Sat Nov 27 14:34:54 2010 -0800
263.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
263.3 @@ -1,609 +0,0 @@
263.4 -(* Title: HOLCF/Tools/Domain/domain_take_proofs.ML
263.5 - Author: Brian Huffman
263.6 -
263.7 -Defines take functions for the given domain equation
263.8 -and proves related theorems.
263.9 -*)
263.10 -
263.11 -signature DOMAIN_TAKE_PROOFS =
263.12 -sig
263.13 - type iso_info =
263.14 - {
263.15 - absT : typ,
263.16 - repT : typ,
263.17 - abs_const : term,
263.18 - rep_const : term,
263.19 - abs_inverse : thm,
263.20 - rep_inverse : thm
263.21 - }
263.22 - type take_info =
263.23 - {
263.24 - take_consts : term list,
263.25 - take_defs : thm list,
263.26 - chain_take_thms : thm list,
263.27 - take_0_thms : thm list,
263.28 - take_Suc_thms : thm list,
263.29 - deflation_take_thms : thm list,
263.30 - take_strict_thms : thm list,
263.31 - finite_consts : term list,
263.32 - finite_defs : thm list
263.33 - }
263.34 - type take_induct_info =
263.35 - {
263.36 - take_consts : term list,
263.37 - take_defs : thm list,
263.38 - chain_take_thms : thm list,
263.39 - take_0_thms : thm list,
263.40 - take_Suc_thms : thm list,
263.41 - deflation_take_thms : thm list,
263.42 - take_strict_thms : thm list,
263.43 - finite_consts : term list,
263.44 - finite_defs : thm list,
263.45 - lub_take_thms : thm list,
263.46 - reach_thms : thm list,
263.47 - take_lemma_thms : thm list,
263.48 - is_finite : bool,
263.49 - take_induct_thms : thm list
263.50 - }
263.51 - val define_take_functions :
263.52 - (binding * iso_info) list -> theory -> take_info * theory
263.53 -
263.54 - val add_lub_take_theorems :
263.55 - (binding * iso_info) list -> take_info -> thm list ->
263.56 - theory -> take_induct_info * theory
263.57 -
263.58 - val map_of_typ :
263.59 - theory -> (typ * term) list -> typ -> term
263.60 -
263.61 - val add_rec_type : (string * bool list) -> theory -> theory
263.62 - val get_rec_tab : theory -> (bool list) Symtab.table
263.63 - val add_deflation_thm : thm -> theory -> theory
263.64 - val get_deflation_thms : theory -> thm list
263.65 - val map_ID_add : attribute
263.66 - val get_map_ID_thms : theory -> thm list
263.67 - val setup : theory -> theory
263.68 -end;
263.69 -
263.70 -structure Domain_Take_Proofs : DOMAIN_TAKE_PROOFS =
263.71 -struct
263.72 -
263.73 -type iso_info =
263.74 - {
263.75 - absT : typ,
263.76 - repT : typ,
263.77 - abs_const : term,
263.78 - rep_const : term,
263.79 - abs_inverse : thm,
263.80 - rep_inverse : thm
263.81 - };
263.82 -
263.83 -type take_info =
263.84 - { take_consts : term list,
263.85 - take_defs : thm list,
263.86 - chain_take_thms : thm list,
263.87 - take_0_thms : thm list,
263.88 - take_Suc_thms : thm list,
263.89 - deflation_take_thms : thm list,
263.90 - take_strict_thms : thm list,
263.91 - finite_consts : term list,
263.92 - finite_defs : thm list
263.93 - };
263.94 -
263.95 -type take_induct_info =
263.96 - {
263.97 - take_consts : term list,
263.98 - take_defs : thm list,
263.99 - chain_take_thms : thm list,
263.100 - take_0_thms : thm list,
263.101 - take_Suc_thms : thm list,
263.102 - deflation_take_thms : thm list,
263.103 - take_strict_thms : thm list,
263.104 - finite_consts : term list,
263.105 - finite_defs : thm list,
263.106 - lub_take_thms : thm list,
263.107 - reach_thms : thm list,
263.108 - take_lemma_thms : thm list,
263.109 - is_finite : bool,
263.110 - take_induct_thms : thm list
263.111 - };
263.112 -
263.113 -val beta_rules =
263.114 - @{thms beta_cfun cont_id cont_const cont2cont_APP cont2cont_LAM'} @
263.115 - @{thms cont2cont_fst cont2cont_snd cont2cont_Pair};
263.116 -
263.117 -val beta_ss = HOL_basic_ss addsimps (simp_thms @ beta_rules);
263.118 -
263.119 -val beta_tac = simp_tac beta_ss;
263.120 -
263.121 -(******************************************************************************)
263.122 -(******************************** theory data *********************************)
263.123 -(******************************************************************************)
263.124 -
263.125 -structure Rec_Data = Theory_Data
263.126 -(
263.127 - (* list indicates which type arguments allow indirect recursion *)
263.128 - type T = (bool list) Symtab.table;
263.129 - val empty = Symtab.empty;
263.130 - val extend = I;
263.131 - fun merge data = Symtab.merge (K true) data;
263.132 -);
263.133 -
263.134 -structure DeflMapData = Named_Thms
263.135 -(
263.136 - val name = "domain_deflation"
263.137 - val description = "theorems like deflation a ==> deflation (foo_map$a)"
263.138 -);
263.139 -
263.140 -structure Map_Id_Data = Named_Thms
263.141 -(
263.142 - val name = "domain_map_ID"
263.143 - val description = "theorems like foo_map$ID = ID"
263.144 -);
263.145 -
263.146 -fun add_rec_type (tname, bs) =
263.147 - Rec_Data.map (Symtab.insert (K true) (tname, bs));
263.148 -
263.149 -fun add_deflation_thm thm =
263.150 - Context.theory_map (DeflMapData.add_thm thm);
263.151 -
263.152 -val get_rec_tab = Rec_Data.get;
263.153 -fun get_deflation_thms thy = DeflMapData.get (ProofContext.init_global thy);
263.154 -
263.155 -val map_ID_add = Map_Id_Data.add;
263.156 -val get_map_ID_thms = Map_Id_Data.get o ProofContext.init_global;
263.157 -
263.158 -val setup = DeflMapData.setup #> Map_Id_Data.setup;
263.159 -
263.160 -(******************************************************************************)
263.161 -(************************** building types and terms **************************)
263.162 -(******************************************************************************)
263.163 -
263.164 -open HOLCF_Library;
263.165 -
263.166 -infixr 6 ->>;
263.167 -infix -->>;
263.168 -infix 9 `;
263.169 -
263.170 -fun mapT (T as Type (_, Ts)) =
263.171 - (map (fn T => T ->> T) Ts) -->> (T ->> T)
263.172 - | mapT T = T ->> T;
263.173 -
263.174 -fun mk_deflation t =
263.175 - Const (@{const_name deflation}, Term.fastype_of t --> boolT) $ t;
263.176 -
263.177 -fun mk_eqs (t, u) = HOLogic.mk_Trueprop (HOLogic.mk_eq (t, u));
263.178 -
263.179 -(******************************************************************************)
263.180 -(****************************** isomorphism info ******************************)
263.181 -(******************************************************************************)
263.182 -
263.183 -fun deflation_abs_rep (info : iso_info) : thm =
263.184 - let
263.185 - val abs_iso = #abs_inverse info;
263.186 - val rep_iso = #rep_inverse info;
263.187 - val thm = @{thm deflation_abs_rep} OF [abs_iso, rep_iso];
263.188 - in
263.189 - Drule.zero_var_indexes thm
263.190 - end
263.191 -
263.192 -(******************************************************************************)
263.193 -(********************* building map functions over types **********************)
263.194 -(******************************************************************************)
263.195 -
263.196 -fun map_of_typ (thy : theory) (sub : (typ * term) list) (T : typ) : term =
263.197 - let
263.198 - val thms = get_map_ID_thms thy;
263.199 - val rules = map (Thm.concl_of #> HOLogic.dest_Trueprop #> HOLogic.dest_eq) thms;
263.200 - val rules' = map (apfst mk_ID) sub @ map swap rules;
263.201 - in
263.202 - mk_ID T
263.203 - |> Pattern.rewrite_term thy rules' []
263.204 - |> Pattern.rewrite_term thy rules []
263.205 - end;
263.206 -
263.207 -(******************************************************************************)
263.208 -(********************* declaring definitions and theorems *********************)
263.209 -(******************************************************************************)
263.210 -
263.211 -fun add_qualified_def name (dbind, eqn) =
263.212 - yield_singleton (Global_Theory.add_defs false)
263.213 - ((Binding.qualified true name dbind, eqn), []);
263.214 -
263.215 -fun add_qualified_thm name (dbind, thm) =
263.216 - yield_singleton Global_Theory.add_thms
263.217 - ((Binding.qualified true name dbind, thm), []);
263.218 -
263.219 -fun add_qualified_simp_thm name (dbind, thm) =
263.220 - yield_singleton Global_Theory.add_thms
263.221 - ((Binding.qualified true name dbind, thm), [Simplifier.simp_add]);
263.222 -
263.223 -(******************************************************************************)
263.224 -(************************** defining take functions ***************************)
263.225 -(******************************************************************************)
263.226 -
263.227 -fun define_take_functions
263.228 - (spec : (binding * iso_info) list)
263.229 - (thy : theory) =
263.230 - let
263.231 -
263.232 - (* retrieve components of spec *)
263.233 - val dbinds = map fst spec;
263.234 - val iso_infos = map snd spec;
263.235 - val dom_eqns = map (fn x => (#absT x, #repT x)) iso_infos;
263.236 - val rep_abs_consts = map (fn x => (#rep_const x, #abs_const x)) iso_infos;
263.237 -
263.238 - fun mk_projs [] t = []
263.239 - | mk_projs (x::[]) t = [(x, t)]
263.240 - | mk_projs (x::xs) t = (x, mk_fst t) :: mk_projs xs (mk_snd t);
263.241 -
263.242 - fun mk_cfcomp2 ((rep_const, abs_const), f) =
263.243 - mk_cfcomp (abs_const, mk_cfcomp (f, rep_const));
263.244 -
263.245 - (* define take functional *)
263.246 - val newTs : typ list = map fst dom_eqns;
263.247 - val copy_arg_type = mk_tupleT (map (fn T => T ->> T) newTs);
263.248 - val copy_arg = Free ("f", copy_arg_type);
263.249 - val copy_args = map snd (mk_projs dbinds copy_arg);
263.250 - fun one_copy_rhs (rep_abs, (lhsT, rhsT)) =
263.251 - let
263.252 - val body = map_of_typ thy (newTs ~~ copy_args) rhsT;
263.253 - in
263.254 - mk_cfcomp2 (rep_abs, body)
263.255 - end;
263.256 - val take_functional =
263.257 - big_lambda copy_arg
263.258 - (mk_tuple (map one_copy_rhs (rep_abs_consts ~~ dom_eqns)));
263.259 - val take_rhss =
263.260 - let
263.261 - val n = Free ("n", HOLogic.natT);
263.262 - val rhs = mk_iterate (n, take_functional);
263.263 - in
263.264 - map (lambda n o snd) (mk_projs dbinds rhs)
263.265 - end;
263.266 -
263.267 - (* define take constants *)
263.268 - fun define_take_const ((dbind, take_rhs), (lhsT, rhsT)) thy =
263.269 - let
263.270 - val take_type = HOLogic.natT --> lhsT ->> lhsT;
263.271 - val take_bind = Binding.suffix_name "_take" dbind;
263.272 - val (take_const, thy) =
263.273 - Sign.declare_const ((take_bind, take_type), NoSyn) thy;
263.274 - val take_eqn = Logic.mk_equals (take_const, take_rhs);
263.275 - val (take_def_thm, thy) =
263.276 - add_qualified_def "take_def" (dbind, take_eqn) thy;
263.277 - in ((take_const, take_def_thm), thy) end;
263.278 - val ((take_consts, take_defs), thy) = thy
263.279 - |> fold_map define_take_const (dbinds ~~ take_rhss ~~ dom_eqns)
263.280 - |>> ListPair.unzip;
263.281 -
263.282 - (* prove chain_take lemmas *)
263.283 - fun prove_chain_take (take_const, dbind) thy =
263.284 - let
263.285 - val goal = mk_trp (mk_chain take_const);
263.286 - val rules = take_defs @ @{thms chain_iterate ch2ch_fst ch2ch_snd};
263.287 - val tac = simp_tac (HOL_basic_ss addsimps rules) 1;
263.288 - val thm = Goal.prove_global thy [] [] goal (K tac);
263.289 - in
263.290 - add_qualified_simp_thm "chain_take" (dbind, thm) thy
263.291 - end;
263.292 - val (chain_take_thms, thy) =
263.293 - fold_map prove_chain_take (take_consts ~~ dbinds) thy;
263.294 -
263.295 - (* prove take_0 lemmas *)
263.296 - fun prove_take_0 ((take_const, dbind), (lhsT, rhsT)) thy =
263.297 - let
263.298 - val lhs = take_const $ @{term "0::nat"};
263.299 - val goal = mk_eqs (lhs, mk_bottom (lhsT ->> lhsT));
263.300 - val rules = take_defs @ @{thms iterate_0 fst_strict snd_strict};
263.301 - val tac = simp_tac (HOL_basic_ss addsimps rules) 1;
263.302 - val take_0_thm = Goal.prove_global thy [] [] goal (K tac);
263.303 - in
263.304 - add_qualified_simp_thm "take_0" (dbind, take_0_thm) thy
263.305 - end;
263.306 - val (take_0_thms, thy) =
263.307 - fold_map prove_take_0 (take_consts ~~ dbinds ~~ dom_eqns) thy;
263.308 -
263.309 - (* prove take_Suc lemmas *)
263.310 - val n = Free ("n", natT);
263.311 - val take_is = map (fn t => t $ n) take_consts;
263.312 - fun prove_take_Suc
263.313 - (((take_const, rep_abs), dbind), (lhsT, rhsT)) thy =
263.314 - let
263.315 - val lhs = take_const $ (@{term Suc} $ n);
263.316 - val body = map_of_typ thy (newTs ~~ take_is) rhsT;
263.317 - val rhs = mk_cfcomp2 (rep_abs, body);
263.318 - val goal = mk_eqs (lhs, rhs);
263.319 - val simps = @{thms iterate_Suc fst_conv snd_conv}
263.320 - val rules = take_defs @ simps;
263.321 - val tac = simp_tac (beta_ss addsimps rules) 1;
263.322 - val take_Suc_thm = Goal.prove_global thy [] [] goal (K tac);
263.323 - in
263.324 - add_qualified_thm "take_Suc" (dbind, take_Suc_thm) thy
263.325 - end;
263.326 - val (take_Suc_thms, thy) =
263.327 - fold_map prove_take_Suc
263.328 - (take_consts ~~ rep_abs_consts ~~ dbinds ~~ dom_eqns) thy;
263.329 -
263.330 - (* prove deflation theorems for take functions *)
263.331 - val deflation_abs_rep_thms = map deflation_abs_rep iso_infos;
263.332 - val deflation_take_thm =
263.333 - let
263.334 - val n = Free ("n", natT);
263.335 - fun mk_goal take_const = mk_deflation (take_const $ n);
263.336 - val goal = mk_trp (foldr1 mk_conj (map mk_goal take_consts));
263.337 - val adm_rules =
263.338 - @{thms adm_conj adm_subst [OF _ adm_deflation]
263.339 - cont2cont_fst cont2cont_snd cont_id};
263.340 - val bottom_rules =
263.341 - take_0_thms @ @{thms deflation_UU simp_thms};
263.342 - val deflation_rules =
263.343 - @{thms conjI deflation_ID}
263.344 - @ deflation_abs_rep_thms
263.345 - @ get_deflation_thms thy;
263.346 - in
263.347 - Goal.prove_global thy [] [] goal (fn _ =>
263.348 - EVERY
263.349 - [rtac @{thm nat.induct} 1,
263.350 - simp_tac (HOL_basic_ss addsimps bottom_rules) 1,
263.351 - asm_simp_tac (HOL_basic_ss addsimps take_Suc_thms) 1,
263.352 - REPEAT (etac @{thm conjE} 1
263.353 - ORELSE resolve_tac deflation_rules 1
263.354 - ORELSE atac 1)])
263.355 - end;
263.356 - fun conjuncts [] thm = []
263.357 - | conjuncts (n::[]) thm = [(n, thm)]
263.358 - | conjuncts (n::ns) thm = let
263.359 - val thmL = thm RS @{thm conjunct1};
263.360 - val thmR = thm RS @{thm conjunct2};
263.361 - in (n, thmL):: conjuncts ns thmR end;
263.362 - val (deflation_take_thms, thy) =
263.363 - fold_map (add_qualified_thm "deflation_take")
263.364 - (map (apsnd Drule.zero_var_indexes)
263.365 - (conjuncts dbinds deflation_take_thm)) thy;
263.366 -
263.367 - (* prove strictness of take functions *)
263.368 - fun prove_take_strict (deflation_take, dbind) thy =
263.369 - let
263.370 - val take_strict_thm =
263.371 - Drule.zero_var_indexes
263.372 - (@{thm deflation_strict} OF [deflation_take]);
263.373 - in
263.374 - add_qualified_simp_thm "take_strict" (dbind, take_strict_thm) thy
263.375 - end;
263.376 - val (take_strict_thms, thy) =
263.377 - fold_map prove_take_strict
263.378 - (deflation_take_thms ~~ dbinds) thy;
263.379 -
263.380 - (* prove take/take rules *)
263.381 - fun prove_take_take ((chain_take, deflation_take), dbind) thy =
263.382 - let
263.383 - val take_take_thm =
263.384 - Drule.zero_var_indexes
263.385 - (@{thm deflation_chain_min} OF [chain_take, deflation_take]);
263.386 - in
263.387 - add_qualified_thm "take_take" (dbind, take_take_thm) thy
263.388 - end;
263.389 - val (take_take_thms, thy) =
263.390 - fold_map prove_take_take
263.391 - (chain_take_thms ~~ deflation_take_thms ~~ dbinds) thy;
263.392 -
263.393 - (* prove take_below rules *)
263.394 - fun prove_take_below (deflation_take, dbind) thy =
263.395 - let
263.396 - val take_below_thm =
263.397 - Drule.zero_var_indexes
263.398 - (@{thm deflation.below} OF [deflation_take]);
263.399 - in
263.400 - add_qualified_thm "take_below" (dbind, take_below_thm) thy
263.401 - end;
263.402 - val (take_below_thms, thy) =
263.403 - fold_map prove_take_below
263.404 - (deflation_take_thms ~~ dbinds) thy;
263.405 -
263.406 - (* define finiteness predicates *)
263.407 - fun define_finite_const ((dbind, take_const), (lhsT, rhsT)) thy =
263.408 - let
263.409 - val finite_type = lhsT --> boolT;
263.410 - val finite_bind = Binding.suffix_name "_finite" dbind;
263.411 - val (finite_const, thy) =
263.412 - Sign.declare_const ((finite_bind, finite_type), NoSyn) thy;
263.413 - val x = Free ("x", lhsT);
263.414 - val n = Free ("n", natT);
263.415 - val finite_rhs =
263.416 - lambda x (HOLogic.exists_const natT $
263.417 - (lambda n (mk_eq (mk_capply (take_const $ n, x), x))));
263.418 - val finite_eqn = Logic.mk_equals (finite_const, finite_rhs);
263.419 - val (finite_def_thm, thy) =
263.420 - add_qualified_def "finite_def" (dbind, finite_eqn) thy;
263.421 - in ((finite_const, finite_def_thm), thy) end;
263.422 - val ((finite_consts, finite_defs), thy) = thy
263.423 - |> fold_map define_finite_const (dbinds ~~ take_consts ~~ dom_eqns)
263.424 - |>> ListPair.unzip;
263.425 -
263.426 - val result =
263.427 - {
263.428 - take_consts = take_consts,
263.429 - take_defs = take_defs,
263.430 - chain_take_thms = chain_take_thms,
263.431 - take_0_thms = take_0_thms,
263.432 - take_Suc_thms = take_Suc_thms,
263.433 - deflation_take_thms = deflation_take_thms,
263.434 - take_strict_thms = take_strict_thms,
263.435 - finite_consts = finite_consts,
263.436 - finite_defs = finite_defs
263.437 - };
263.438 -
263.439 - in
263.440 - (result, thy)
263.441 - end;
263.442 -
263.443 -fun prove_finite_take_induct
263.444 - (spec : (binding * iso_info) list)
263.445 - (take_info : take_info)
263.446 - (lub_take_thms : thm list)
263.447 - (thy : theory) =
263.448 - let
263.449 - val dbinds = map fst spec;
263.450 - val iso_infos = map snd spec;
263.451 - val absTs = map #absT iso_infos;
263.452 - val {take_consts, ...} = take_info;
263.453 - val {chain_take_thms, take_0_thms, take_Suc_thms, ...} = take_info;
263.454 - val {finite_consts, finite_defs, ...} = take_info;
263.455 -
263.456 - val decisive_lemma =
263.457 - let
263.458 - fun iso_locale (info : iso_info) =
263.459 - @{thm iso.intro} OF [#abs_inverse info, #rep_inverse info];
263.460 - val iso_locale_thms = map iso_locale iso_infos;
263.461 - val decisive_abs_rep_thms =
263.462 - map (fn x => @{thm decisive_abs_rep} OF [x]) iso_locale_thms;
263.463 - val n = Free ("n", @{typ nat});
263.464 - fun mk_decisive t =
263.465 - Const (@{const_name decisive}, fastype_of t --> boolT) $ t;
263.466 - fun f take_const = mk_decisive (take_const $ n);
263.467 - val goal = mk_trp (foldr1 mk_conj (map f take_consts));
263.468 - val rules0 = @{thm decisive_bottom} :: take_0_thms;
263.469 - val rules1 =
263.470 - take_Suc_thms @ decisive_abs_rep_thms
263.471 - @ @{thms decisive_ID decisive_ssum_map decisive_sprod_map};
263.472 - val tac = EVERY [
263.473 - rtac @{thm nat.induct} 1,
263.474 - simp_tac (HOL_ss addsimps rules0) 1,
263.475 - asm_simp_tac (HOL_ss addsimps rules1) 1];
263.476 - in Goal.prove_global thy [] [] goal (K tac) end;
263.477 - fun conjuncts 1 thm = [thm]
263.478 - | conjuncts n thm = let
263.479 - val thmL = thm RS @{thm conjunct1};
263.480 - val thmR = thm RS @{thm conjunct2};
263.481 - in thmL :: conjuncts (n-1) thmR end;
263.482 - val decisive_thms = conjuncts (length spec) decisive_lemma;
263.483 -
263.484 - fun prove_finite_thm (absT, finite_const) =
263.485 - let
263.486 - val goal = mk_trp (finite_const $ Free ("x", absT));
263.487 - val tac =
263.488 - EVERY [
263.489 - rewrite_goals_tac finite_defs,
263.490 - rtac @{thm lub_ID_finite} 1,
263.491 - resolve_tac chain_take_thms 1,
263.492 - resolve_tac lub_take_thms 1,
263.493 - resolve_tac decisive_thms 1];
263.494 - in
263.495 - Goal.prove_global thy [] [] goal (K tac)
263.496 - end;
263.497 - val finite_thms =
263.498 - map prove_finite_thm (absTs ~~ finite_consts);
263.499 -
263.500 - fun prove_take_induct ((ch_take, lub_take), decisive) =
263.501 - Drule.export_without_context
263.502 - (@{thm lub_ID_finite_take_induct} OF [ch_take, lub_take, decisive]);
263.503 - val take_induct_thms =
263.504 - map prove_take_induct
263.505 - (chain_take_thms ~~ lub_take_thms ~~ decisive_thms);
263.506 -
263.507 - val thy = thy
263.508 - |> fold (snd oo add_qualified_thm "finite")
263.509 - (dbinds ~~ finite_thms)
263.510 - |> fold (snd oo add_qualified_thm "take_induct")
263.511 - (dbinds ~~ take_induct_thms);
263.512 - in
263.513 - ((finite_thms, take_induct_thms), thy)
263.514 - end;
263.515 -
263.516 -fun add_lub_take_theorems
263.517 - (spec : (binding * iso_info) list)
263.518 - (take_info : take_info)
263.519 - (lub_take_thms : thm list)
263.520 - (thy : theory) =
263.521 - let
263.522 -
263.523 - (* retrieve components of spec *)
263.524 - val dbinds = map fst spec;
263.525 - val iso_infos = map snd spec;
263.526 - val absTs = map #absT iso_infos;
263.527 - val repTs = map #repT iso_infos;
263.528 - val {take_consts, take_0_thms, take_Suc_thms, ...} = take_info;
263.529 - val {chain_take_thms, deflation_take_thms, ...} = take_info;
263.530 -
263.531 - (* prove take lemmas *)
263.532 - fun prove_take_lemma ((chain_take, lub_take), dbind) thy =
263.533 - let
263.534 - val take_lemma =
263.535 - Drule.export_without_context
263.536 - (@{thm lub_ID_take_lemma} OF [chain_take, lub_take]);
263.537 - in
263.538 - add_qualified_thm "take_lemma" (dbind, take_lemma) thy
263.539 - end;
263.540 - val (take_lemma_thms, thy) =
263.541 - fold_map prove_take_lemma
263.542 - (chain_take_thms ~~ lub_take_thms ~~ dbinds) thy;
263.543 -
263.544 - (* prove reach lemmas *)
263.545 - fun prove_reach_lemma ((chain_take, lub_take), dbind) thy =
263.546 - let
263.547 - val thm =
263.548 - Drule.zero_var_indexes
263.549 - (@{thm lub_ID_reach} OF [chain_take, lub_take]);
263.550 - in
263.551 - add_qualified_thm "reach" (dbind, thm) thy
263.552 - end;
263.553 - val (reach_thms, thy) =
263.554 - fold_map prove_reach_lemma
263.555 - (chain_take_thms ~~ lub_take_thms ~~ dbinds) thy;
263.556 -
263.557 - (* test for finiteness of domain definitions *)
263.558 - local
263.559 - val types = [@{type_name ssum}, @{type_name sprod}];
263.560 - fun finite d T = if member (op =) absTs T then d else finite' d T
263.561 - and finite' d (Type (c, Ts)) =
263.562 - let val d' = d andalso member (op =) types c;
263.563 - in forall (finite d') Ts end
263.564 - | finite' d _ = true;
263.565 - in
263.566 - val is_finite = forall (finite true) repTs;
263.567 - end;
263.568 -
263.569 - val ((finite_thms, take_induct_thms), thy) =
263.570 - if is_finite
263.571 - then
263.572 - let
263.573 - val ((finites, take_inducts), thy) =
263.574 - prove_finite_take_induct spec take_info lub_take_thms thy;
263.575 - in
263.576 - ((SOME finites, take_inducts), thy)
263.577 - end
263.578 - else
263.579 - let
263.580 - fun prove_take_induct (chain_take, lub_take) =
263.581 - Drule.zero_var_indexes
263.582 - (@{thm lub_ID_take_induct} OF [chain_take, lub_take]);
263.583 - val take_inducts =
263.584 - map prove_take_induct (chain_take_thms ~~ lub_take_thms);
263.585 - val thy = fold (snd oo add_qualified_thm "take_induct")
263.586 - (dbinds ~~ take_inducts) thy;
263.587 - in
263.588 - ((NONE, take_inducts), thy)
263.589 - end;
263.590 -
263.591 - val result =
263.592 - {
263.593 - take_consts = #take_consts take_info,
263.594 - take_defs = #take_defs take_info,
263.595 - chain_take_thms = #chain_take_thms take_info,
263.596 - take_0_thms = #take_0_thms take_info,
263.597 - take_Suc_thms = #take_Suc_thms take_info,
263.598 - deflation_take_thms = #deflation_take_thms take_info,
263.599 - take_strict_thms = #take_strict_thms take_info,
263.600 - finite_consts = #finite_consts take_info,
263.601 - finite_defs = #finite_defs take_info,
263.602 - lub_take_thms = lub_take_thms,
263.603 - reach_thms = reach_thms,
263.604 - take_lemma_thms = take_lemma_thms,
263.605 - is_finite = is_finite,
263.606 - take_induct_thms = take_induct_thms
263.607 - };
263.608 - in
263.609 - (result, thy)
263.610 - end;
263.611 -
263.612 -end;
264.1 --- a/src/HOLCF/Tools/cont_consts.ML Sat Nov 27 14:34:54 2010 -0800
264.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
264.3 @@ -1,93 +0,0 @@
264.4 -(* Title: HOLCF/Tools/cont_consts.ML
264.5 - Author: Tobias Mayr, David von Oheimb, and Markus Wenzel
264.6 -
264.7 -HOLCF version of consts: handle continuous function types in mixfix
264.8 -syntax.
264.9 -*)
264.10 -
264.11 -signature CONT_CONSTS =
264.12 -sig
264.13 - val add_consts: (binding * typ * mixfix) list -> theory -> theory
264.14 - val add_consts_cmd: (binding * string * mixfix) list -> theory -> theory
264.15 -end;
264.16 -
264.17 -structure Cont_Consts: CONT_CONSTS =
264.18 -struct
264.19 -
264.20 -
264.21 -(* misc utils *)
264.22 -
264.23 -fun change_arrow 0 T = T
264.24 - | change_arrow n (Type (_, [S, T])) = Type ("fun", [S, change_arrow (n - 1) T])
264.25 - | change_arrow _ T = raise TYPE ("cont_consts: change_arrow", [T], []);
264.26 -
264.27 -fun trans_rules name2 name1 n mx =
264.28 - let
264.29 - val vnames = Name.invents Name.context "a" n;
264.30 - val extra_parse_rule = Syntax.ParseRule (Constant name2, Constant name1);
264.31 - in
264.32 - [Syntax.ParsePrintRule
264.33 - (Syntax.mk_appl (Constant name2) (map Variable vnames),
264.34 - fold (fn a => fn t => Syntax.mk_appl (Constant @{const_syntax Rep_cfun}) [t, Variable a])
264.35 - vnames (Constant name1))] @
264.36 - (case mx of
264.37 - Infix _ => [extra_parse_rule]
264.38 - | Infixl _ => [extra_parse_rule]
264.39 - | Infixr _ => [extra_parse_rule]
264.40 - | _ => [])
264.41 - end;
264.42 -
264.43 -
264.44 -(* transforming infix/mixfix declarations of constants with type ...->...
264.45 - a declaration of such a constant is transformed to a normal declaration with
264.46 - an internal name, the same type, and nofix. Additionally, a purely syntactic
264.47 - declaration with the original name, type ...=>..., and the original mixfix
264.48 - is generated and connected to the other declaration via some translation.
264.49 -*)
264.50 -fun transform thy (c, T, mx) =
264.51 - let
264.52 - fun syntax b = Syntax.mark_const (Sign.full_bname thy b);
264.53 - val c1 = Binding.name_of c;
264.54 - val c2 = c1 ^ "_cont_syntax";
264.55 - val n = Syntax.mixfix_args mx;
264.56 - in
264.57 - ((c, T, NoSyn),
264.58 - (Binding.name c2, change_arrow n T, mx),
264.59 - trans_rules (syntax c2) (syntax c1) n mx)
264.60 - end;
264.61 -
264.62 -fun cfun_arity (Type (n, [_, T])) = if n = @{type_name cfun} then 1 + cfun_arity T else 0
264.63 - | cfun_arity _ = 0;
264.64 -
264.65 -fun is_contconst (_, _, NoSyn) = false
264.66 - | is_contconst (_, _, Binder _) = false (* FIXME ? *)
264.67 - | is_contconst (c, T, mx) =
264.68 - let
264.69 - val n = Syntax.mixfix_args mx handle ERROR msg =>
264.70 - cat_error msg ("in mixfix annotation for " ^ quote (Binding.str_of c));
264.71 - in cfun_arity T >= n end;
264.72 -
264.73 -
264.74 -(* add_consts *)
264.75 -
264.76 -local
264.77 -
264.78 -fun gen_add_consts prep_typ raw_decls thy =
264.79 - let
264.80 - val decls = map (fn (c, T, mx) => (c, prep_typ thy T, mx)) raw_decls;
264.81 - val (contconst_decls, normal_decls) = List.partition is_contconst decls;
264.82 - val transformed_decls = map (transform thy) contconst_decls;
264.83 - in
264.84 - thy
264.85 - |> Sign.add_consts_i (normal_decls @ map #1 transformed_decls @ map #2 transformed_decls)
264.86 - |> Sign.add_trrules_i (maps #3 transformed_decls)
264.87 - end;
264.88 -
264.89 -in
264.90 -
264.91 -val add_consts = gen_add_consts Sign.certify_typ;
264.92 -val add_consts_cmd = gen_add_consts Syntax.read_typ_global;
264.93 -
264.94 -end;
264.95 -
264.96 -end;
265.1 --- a/src/HOLCF/Tools/cont_proc.ML Sat Nov 27 14:34:54 2010 -0800
265.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
265.3 @@ -1,136 +0,0 @@
265.4 -(* Title: HOLCF/Tools/cont_proc.ML
265.5 - Author: Brian Huffman
265.6 -*)
265.7 -
265.8 -signature CONT_PROC =
265.9 -sig
265.10 - val is_lcf_term: term -> bool
265.11 - val cont_thms: term -> thm list
265.12 - val all_cont_thms: term -> thm list
265.13 - val cont_tac: int -> tactic
265.14 - val cont_proc: theory -> simproc
265.15 - val setup: theory -> theory
265.16 -end;
265.17 -
265.18 -structure ContProc :> CONT_PROC =
265.19 -struct
265.20 -
265.21 -(** theory context references **)
265.22 -
265.23 -val cont_K = @{thm cont_const};
265.24 -val cont_I = @{thm cont_id};
265.25 -val cont_A = @{thm cont2cont_APP};
265.26 -val cont_L = @{thm cont2cont_LAM};
265.27 -val cont_R = @{thm cont_Rep_cfun2};
265.28 -
265.29 -(* checks whether a term contains no dangling bound variables *)
265.30 -fun is_closed_term t = not (Term.loose_bvar (t, 0));
265.31 -
265.32 -(* checks whether a term is written entirely in the LCF sublanguage *)
265.33 -fun is_lcf_term (Const (@{const_name Rep_cfun}, _) $ t $ u) =
265.34 - is_lcf_term t andalso is_lcf_term u
265.35 - | is_lcf_term (Const (@{const_name Abs_cfun}, _) $ Abs (_, _, t)) =
265.36 - is_lcf_term t
265.37 - | is_lcf_term (Const (@{const_name Abs_cfun}, _) $ t) =
265.38 - is_lcf_term (Term.incr_boundvars 1 t $ Bound 0)
265.39 - | is_lcf_term (Bound _) = true
265.40 - | is_lcf_term t = is_closed_term t;
265.41 -
265.42 -(*
265.43 - efficiently generates a cont thm for every LAM abstraction in a term,
265.44 - using forward proof and reusing common subgoals
265.45 -*)
265.46 -local
265.47 - fun var 0 = [SOME cont_I]
265.48 - | var n = NONE :: var (n-1);
265.49 -
265.50 - fun k NONE = cont_K
265.51 - | k (SOME x) = x;
265.52 -
265.53 - fun ap NONE NONE = NONE
265.54 - | ap x y = SOME (k y RS (k x RS cont_A));
265.55 -
265.56 - fun zip [] [] = []
265.57 - | zip [] (y::ys) = (ap NONE y ) :: zip [] ys
265.58 - | zip (x::xs) [] = (ap x NONE) :: zip xs []
265.59 - | zip (x::xs) (y::ys) = (ap x y ) :: zip xs ys
265.60 -
265.61 - fun lam [] = ([], cont_K)
265.62 - | lam (x::ys) =
265.63 - let
265.64 - (* should use "close_derivation" for thms that are used multiple times *)
265.65 - (* it seems to allow for sharing in explicit proof objects *)
265.66 - val x' = Thm.close_derivation (k x);
265.67 - val Lx = x' RS cont_L;
265.68 - in (map (fn y => SOME (k y RS Lx)) ys, x') end;
265.69 -
265.70 - (* first list: cont thm for each dangling bound variable *)
265.71 - (* second list: cont thm for each LAM in t *)
265.72 - (* if b = false, only return cont thm for outermost LAMs *)
265.73 - fun cont_thms1 b (Const (@{const_name Rep_cfun}, _) $ f $ t) =
265.74 - let
265.75 - val (cs1,ls1) = cont_thms1 b f;
265.76 - val (cs2,ls2) = cont_thms1 b t;
265.77 - in (zip cs1 cs2, if b then ls1 @ ls2 else []) end
265.78 - | cont_thms1 b (Const (@{const_name Abs_cfun}, _) $ Abs (_, _, t)) =
265.79 - let
265.80 - val (cs, ls) = cont_thms1 b t;
265.81 - val (cs', l) = lam cs;
265.82 - in (cs', l::ls) end
265.83 - | cont_thms1 b (Const (@{const_name Abs_cfun}, _) $ t) =
265.84 - let
265.85 - val t' = Term.incr_boundvars 1 t $ Bound 0;
265.86 - val (cs, ls) = cont_thms1 b t';
265.87 - val (cs', l) = lam cs;
265.88 - in (cs', l::ls) end
265.89 - | cont_thms1 _ (Bound n) = (var n, [])
265.90 - | cont_thms1 _ _ = ([], []);
265.91 -in
265.92 - (* precondition: is_lcf_term t = true *)
265.93 - fun cont_thms t = snd (cont_thms1 false t);
265.94 - fun all_cont_thms t = snd (cont_thms1 true t);
265.95 -end;
265.96 -
265.97 -(*
265.98 - Given the term "cont f", the procedure tries to construct the
265.99 - theorem "cont f == True". If this theorem cannot be completely
265.100 - solved by the introduction rules, then the procedure returns a
265.101 - conditional rewrite rule with the unsolved subgoals as premises.
265.102 -*)
265.103 -
265.104 -val cont_tac =
265.105 - let
265.106 - val rules = [cont_K, cont_I, cont_R, cont_A, cont_L];
265.107 -
265.108 - fun new_cont_tac f' i =
265.109 - case all_cont_thms f' of
265.110 - [] => no_tac
265.111 - | (c::cs) => rtac c i;
265.112 -
265.113 - fun cont_tac_of_term (Const (@{const_name cont}, _) $ f) =
265.114 - let
265.115 - val f' = Const (@{const_name Abs_cfun}, dummyT) $ f;
265.116 - in
265.117 - if is_lcf_term f'
265.118 - then new_cont_tac f'
265.119 - else REPEAT_ALL_NEW (resolve_tac rules)
265.120 - end
265.121 - | cont_tac_of_term _ = K no_tac;
265.122 - in
265.123 - SUBGOAL (fn (t, i) =>
265.124 - cont_tac_of_term (HOLogic.dest_Trueprop t) i)
265.125 - end;
265.126 -
265.127 -local
265.128 - fun solve_cont thy _ t =
265.129 - let
265.130 - val tr = instantiate' [] [SOME (cterm_of thy t)] Eq_TrueI;
265.131 - in Option.map fst (Seq.pull (cont_tac 1 tr)) end
265.132 -in
265.133 - fun cont_proc thy =
265.134 - Simplifier.simproc_global thy "cont_proc" ["cont f"] solve_cont;
265.135 -end;
265.136 -
265.137 -fun setup thy = Simplifier.map_simpset (fn ss => ss addsimprocs [cont_proc thy]) thy;
265.138 -
265.139 -end;
266.1 --- a/src/HOLCF/Tools/cpodef.ML Sat Nov 27 14:34:54 2010 -0800
266.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
266.3 @@ -1,383 +0,0 @@
266.4 -(* Title: HOLCF/Tools/cpodef.ML
266.5 - Author: Brian Huffman
266.6 -
266.7 -Primitive domain definitions for HOLCF, similar to Gordon/HOL-style
266.8 -typedef (see also ~~/src/HOL/Tools/typedef.ML).
266.9 -*)
266.10 -
266.11 -signature CPODEF =
266.12 -sig
266.13 - type cpo_info =
266.14 - { below_def: thm, adm: thm, cont_Rep: thm, cont_Abs: thm,
266.15 - is_lub: thm, lub: thm, compact: thm }
266.16 - type pcpo_info =
266.17 - { Rep_strict: thm, Abs_strict: thm, Rep_bottom_iff: thm, Abs_bottom_iff: thm,
266.18 - Rep_defined: thm, Abs_defined: thm }
266.19 -
266.20 - val add_podef: bool -> binding option -> binding * (string * sort) list * mixfix ->
266.21 - term -> (binding * binding) option -> tactic -> theory ->
266.22 - (Typedef.info * thm) * theory
266.23 - val add_cpodef: bool -> binding option -> binding * (string * sort) list * mixfix ->
266.24 - term -> (binding * binding) option -> tactic * tactic -> theory ->
266.25 - (Typedef.info * cpo_info) * theory
266.26 - val add_pcpodef: bool -> binding option -> binding * (string * sort) list * mixfix ->
266.27 - term -> (binding * binding) option -> tactic * tactic -> theory ->
266.28 - (Typedef.info * cpo_info * pcpo_info) * theory
266.29 -
266.30 - val cpodef_proof: (bool * binding)
266.31 - * (binding * (string * sort) list * mixfix) * term
266.32 - * (binding * binding) option -> theory -> Proof.state
266.33 - val cpodef_proof_cmd: (bool * binding)
266.34 - * (binding * (string * string option) list * mixfix) * string
266.35 - * (binding * binding) option -> theory -> Proof.state
266.36 - val pcpodef_proof: (bool * binding)
266.37 - * (binding * (string * sort) list * mixfix) * term
266.38 - * (binding * binding) option -> theory -> Proof.state
266.39 - val pcpodef_proof_cmd: (bool * binding)
266.40 - * (binding * (string * string option) list * mixfix) * string
266.41 - * (binding * binding) option -> theory -> Proof.state
266.42 -end;
266.43 -
266.44 -structure Cpodef :> CPODEF =
266.45 -struct
266.46 -
266.47 -(** type definitions **)
266.48 -
266.49 -type cpo_info =
266.50 - { below_def: thm, adm: thm, cont_Rep: thm, cont_Abs: thm,
266.51 - is_lub: thm, lub: thm, compact: thm }
266.52 -
266.53 -type pcpo_info =
266.54 - { Rep_strict: thm, Abs_strict: thm, Rep_bottom_iff: thm, Abs_bottom_iff: thm,
266.55 - Rep_defined: thm, Abs_defined: thm }
266.56 -
266.57 -(* building terms *)
266.58 -
266.59 -fun adm_const T = Const (@{const_name adm}, (T --> HOLogic.boolT) --> HOLogic.boolT);
266.60 -fun mk_adm (x, T, P) = adm_const T $ absfree (x, T, P);
266.61 -
266.62 -fun below_const T = Const (@{const_name below}, T --> T --> HOLogic.boolT);
266.63 -
266.64 -(* manipulating theorems *)
266.65 -
266.66 -fun fold_adm_mem thm NONE = thm
266.67 - | fold_adm_mem thm (SOME set_def) =
266.68 - let val rule = @{lemma "A == B ==> adm (%x. x : B) ==> adm (%x. x : A)" by simp}
266.69 - in rule OF [set_def, thm] end;
266.70 -
266.71 -fun fold_UU_mem thm NONE = thm
266.72 - | fold_UU_mem thm (SOME set_def) =
266.73 - let val rule = @{lemma "A == B ==> UU : B ==> UU : A" by simp}
266.74 - in rule OF [set_def, thm] end;
266.75 -
266.76 -(* proving class instances *)
266.77 -
266.78 -fun prove_cpo
266.79 - (name: binding)
266.80 - (newT: typ)
266.81 - (Rep_name: binding, Abs_name: binding)
266.82 - (type_definition: thm) (* type_definition Rep Abs A *)
266.83 - (set_def: thm option) (* A == set *)
266.84 - (below_def: thm) (* op << == %x y. Rep x << Rep y *)
266.85 - (admissible: thm) (* adm (%x. x : set) *)
266.86 - (thy: theory)
266.87 - =
266.88 - let
266.89 - val admissible' = fold_adm_mem admissible set_def;
266.90 - val cpo_thms = map (Thm.transfer thy) [type_definition, below_def, admissible'];
266.91 - val (full_tname, Ts) = dest_Type newT;
266.92 - val lhs_sorts = map (snd o dest_TFree) Ts;
266.93 - val tac = Tactic.rtac (@{thm typedef_cpo} OF cpo_thms) 1;
266.94 - val thy = AxClass.prove_arity (full_tname, lhs_sorts, @{sort cpo}) tac thy;
266.95 - (* transfer thms so that they will know about the new cpo instance *)
266.96 - val cpo_thms' = map (Thm.transfer thy) cpo_thms;
266.97 - fun make thm = Drule.zero_var_indexes (thm OF cpo_thms');
266.98 - val cont_Rep = make @{thm typedef_cont_Rep};
266.99 - val cont_Abs = make @{thm typedef_cont_Abs};
266.100 - val is_lub = make @{thm typedef_is_lub};
266.101 - val lub = make @{thm typedef_lub};
266.102 - val compact = make @{thm typedef_compact};
266.103 - val (_, thy) =
266.104 - thy
266.105 - |> Sign.add_path (Binding.name_of name)
266.106 - |> Global_Theory.add_thms
266.107 - ([((Binding.prefix_name "adm_" name, admissible'), []),
266.108 - ((Binding.prefix_name "cont_" Rep_name, cont_Rep ), []),
266.109 - ((Binding.prefix_name "cont_" Abs_name, cont_Abs ), []),
266.110 - ((Binding.prefix_name "is_lub_" name, is_lub ), []),
266.111 - ((Binding.prefix_name "lub_" name, lub ), []),
266.112 - ((Binding.prefix_name "compact_" name, compact ), [])])
266.113 - ||> Sign.parent_path;
266.114 - val cpo_info : cpo_info =
266.115 - { below_def = below_def, adm = admissible', cont_Rep = cont_Rep,
266.116 - cont_Abs = cont_Abs, is_lub = is_lub, lub = lub, compact = compact };
266.117 - in
266.118 - (cpo_info, thy)
266.119 - end;
266.120 -
266.121 -fun prove_pcpo
266.122 - (name: binding)
266.123 - (newT: typ)
266.124 - (Rep_name: binding, Abs_name: binding)
266.125 - (type_definition: thm) (* type_definition Rep Abs A *)
266.126 - (set_def: thm option) (* A == set *)
266.127 - (below_def: thm) (* op << == %x y. Rep x << Rep y *)
266.128 - (UU_mem: thm) (* UU : set *)
266.129 - (thy: theory)
266.130 - =
266.131 - let
266.132 - val UU_mem' = fold_UU_mem UU_mem set_def;
266.133 - val pcpo_thms = map (Thm.transfer thy) [type_definition, below_def, UU_mem'];
266.134 - val (full_tname, Ts) = dest_Type newT;
266.135 - val lhs_sorts = map (snd o dest_TFree) Ts;
266.136 - val tac = Tactic.rtac (@{thm typedef_pcpo} OF pcpo_thms) 1;
266.137 - val thy = AxClass.prove_arity (full_tname, lhs_sorts, @{sort pcpo}) tac thy;
266.138 - val pcpo_thms' = map (Thm.transfer thy) pcpo_thms;
266.139 - fun make thm = Drule.zero_var_indexes (thm OF pcpo_thms');
266.140 - val Rep_strict = make @{thm typedef_Rep_strict};
266.141 - val Abs_strict = make @{thm typedef_Abs_strict};
266.142 - val Rep_bottom_iff = make @{thm typedef_Rep_bottom_iff};
266.143 - val Abs_bottom_iff = make @{thm typedef_Abs_bottom_iff};
266.144 - val Rep_defined = make @{thm typedef_Rep_defined};
266.145 - val Abs_defined = make @{thm typedef_Abs_defined};
266.146 - val (_, thy) =
266.147 - thy
266.148 - |> Sign.add_path (Binding.name_of name)
266.149 - |> Global_Theory.add_thms
266.150 - ([((Binding.suffix_name "_strict" Rep_name, Rep_strict), []),
266.151 - ((Binding.suffix_name "_strict" Abs_name, Abs_strict), []),
266.152 - ((Binding.suffix_name "_bottom_iff" Rep_name, Rep_bottom_iff), []),
266.153 - ((Binding.suffix_name "_bottom_iff" Abs_name, Abs_bottom_iff), []),
266.154 - ((Binding.suffix_name "_defined" Rep_name, Rep_defined), []),
266.155 - ((Binding.suffix_name "_defined" Abs_name, Abs_defined), [])])
266.156 - ||> Sign.parent_path;
266.157 - val pcpo_info =
266.158 - { Rep_strict = Rep_strict, Abs_strict = Abs_strict,
266.159 - Rep_bottom_iff = Rep_bottom_iff, Abs_bottom_iff = Abs_bottom_iff,
266.160 - Rep_defined = Rep_defined, Abs_defined = Abs_defined };
266.161 - in
266.162 - (pcpo_info, thy)
266.163 - end;
266.164 -
266.165 -(* prepare_cpodef *)
266.166 -
266.167 -fun declare_type_name a =
266.168 - Variable.declare_constraints (Logic.mk_type (TFree (a, dummyS)));
266.169 -
266.170 -fun prepare prep_term name (tname, raw_args, mx) raw_set opt_morphs thy =
266.171 - let
266.172 - val _ = Theory.requires thy "Cpodef" "cpodefs";
266.173 -
266.174 - (*rhs*)
266.175 - val tmp_ctxt =
266.176 - ProofContext.init_global thy
266.177 - |> fold (Variable.declare_typ o TFree) raw_args;
266.178 - val set = prep_term tmp_ctxt raw_set;
266.179 - val tmp_ctxt' = tmp_ctxt |> Variable.declare_term set;
266.180 -
266.181 - val setT = Term.fastype_of set;
266.182 - val oldT = HOLogic.dest_setT setT handle TYPE _ =>
266.183 - error ("Not a set type: " ^ quote (Syntax.string_of_typ tmp_ctxt setT));
266.184 -
266.185 - (*lhs*)
266.186 - val lhs_tfrees = map (ProofContext.check_tfree tmp_ctxt') raw_args;
266.187 - val full_tname = Sign.full_name thy tname;
266.188 - val newT = Type (full_tname, map TFree lhs_tfrees);
266.189 -
266.190 - val morphs = opt_morphs
266.191 - |> the_default (Binding.prefix_name "Rep_" name, Binding.prefix_name "Abs_" name);
266.192 - in
266.193 - (newT, oldT, set, morphs)
266.194 - end
266.195 -
266.196 -fun add_podef def opt_name typ set opt_morphs tac thy =
266.197 - let
266.198 - val name = the_default (#1 typ) opt_name;
266.199 - val ((full_tname, info as ({Rep_name, ...}, {type_definition, set_def, ...})), thy2) = thy
266.200 - |> Typedef.add_typedef_global def opt_name typ set opt_morphs tac;
266.201 - val oldT = #rep_type (#1 info);
266.202 - val newT = #abs_type (#1 info);
266.203 - val lhs_tfrees = map dest_TFree (snd (dest_Type newT));
266.204 -
266.205 - val RepC = Const (Rep_name, newT --> oldT);
266.206 - val below_eqn = Logic.mk_equals (below_const newT,
266.207 - Abs ("x", newT, Abs ("y", newT, below_const oldT $ (RepC $ Bound 1) $ (RepC $ Bound 0))));
266.208 - val lthy3 = thy2
266.209 - |> Class.instantiation ([full_tname], lhs_tfrees, @{sort po});
266.210 - val ((_, (_, below_ldef)), lthy4) = lthy3
266.211 - |> Specification.definition (NONE,
266.212 - ((Binding.prefix_name "below_" (Binding.suffix_name "_def" name), []), below_eqn));
266.213 - val ctxt_thy = ProofContext.init_global (ProofContext.theory_of lthy4);
266.214 - val below_def = singleton (ProofContext.export lthy4 ctxt_thy) below_ldef;
266.215 - val thy5 = lthy4
266.216 - |> Class.prove_instantiation_instance
266.217 - (K (Tactic.rtac (@{thm typedef_po} OF [type_definition, below_def]) 1))
266.218 - |> Local_Theory.exit_global;
266.219 - in ((info, below_def), thy5) end;
266.220 -
266.221 -fun prepare_cpodef
266.222 - (prep_term: Proof.context -> 'a -> term)
266.223 - (def: bool)
266.224 - (name: binding)
266.225 - (typ: binding * (string * sort) list * mixfix)
266.226 - (raw_set: 'a)
266.227 - (opt_morphs: (binding * binding) option)
266.228 - (thy: theory)
266.229 - : term * term * (thm -> thm -> theory -> (Typedef.info * cpo_info) * theory) =
266.230 - let
266.231 - val (newT, oldT, set, morphs as (Rep_name, Abs_name)) =
266.232 - prepare prep_term name typ raw_set opt_morphs thy;
266.233 -
266.234 - val goal_nonempty =
266.235 - HOLogic.mk_Trueprop (HOLogic.mk_exists ("x", oldT, HOLogic.mk_mem (Free ("x", oldT), set)));
266.236 - val goal_admissible =
266.237 - HOLogic.mk_Trueprop (mk_adm ("x", oldT, HOLogic.mk_mem (Free ("x", oldT), set)));
266.238 -
266.239 - fun cpodef_result nonempty admissible thy =
266.240 - let
266.241 - val ((info as (_, {type_definition, set_def, ...}), below_def), thy2) = thy
266.242 - |> add_podef def (SOME name) typ set opt_morphs (Tactic.rtac nonempty 1);
266.243 - val (cpo_info, thy3) = thy2
266.244 - |> prove_cpo name newT morphs type_definition set_def below_def admissible;
266.245 - in
266.246 - ((info, cpo_info), thy3)
266.247 - end;
266.248 - in
266.249 - (goal_nonempty, goal_admissible, cpodef_result)
266.250 - end
266.251 - handle ERROR msg =>
266.252 - cat_error msg ("The error(s) above occurred in cpodef " ^ quote (Binding.str_of name));
266.253 -
266.254 -fun prepare_pcpodef
266.255 - (prep_term: Proof.context -> 'a -> term)
266.256 - (def: bool)
266.257 - (name: binding)
266.258 - (typ: binding * (string * sort) list * mixfix)
266.259 - (raw_set: 'a)
266.260 - (opt_morphs: (binding * binding) option)
266.261 - (thy: theory)
266.262 - : term * term * (thm -> thm -> theory -> (Typedef.info * cpo_info * pcpo_info) * theory) =
266.263 - let
266.264 - val (newT, oldT, set, morphs as (Rep_name, Abs_name)) =
266.265 - prepare prep_term name typ raw_set opt_morphs thy;
266.266 -
266.267 - val goal_UU_mem =
266.268 - HOLogic.mk_Trueprop (HOLogic.mk_mem (Const (@{const_name UU}, oldT), set));
266.269 -
266.270 - val goal_admissible =
266.271 - HOLogic.mk_Trueprop (mk_adm ("x", oldT, HOLogic.mk_mem (Free ("x", oldT), set)));
266.272 -
266.273 - fun pcpodef_result UU_mem admissible thy =
266.274 - let
266.275 - val tac = Tactic.rtac exI 1 THEN Tactic.rtac UU_mem 1;
266.276 - val ((info as (_, {type_definition, set_def, ...}), below_def), thy2) = thy
266.277 - |> add_podef def (SOME name) typ set opt_morphs tac;
266.278 - val (cpo_info, thy3) = thy2
266.279 - |> prove_cpo name newT morphs type_definition set_def below_def admissible;
266.280 - val (pcpo_info, thy4) = thy3
266.281 - |> prove_pcpo name newT morphs type_definition set_def below_def UU_mem;
266.282 - in
266.283 - ((info, cpo_info, pcpo_info), thy4)
266.284 - end;
266.285 - in
266.286 - (goal_UU_mem, goal_admissible, pcpodef_result)
266.287 - end
266.288 - handle ERROR msg =>
266.289 - cat_error msg ("The error(s) above occurred in pcpodef " ^ quote (Binding.str_of name));
266.290 -
266.291 -
266.292 -(* tactic interface *)
266.293 -
266.294 -fun add_cpodef def opt_name typ set opt_morphs (tac1, tac2) thy =
266.295 - let
266.296 - val name = the_default (#1 typ) opt_name;
266.297 - val (goal1, goal2, cpodef_result) =
266.298 - prepare_cpodef Syntax.check_term def name typ set opt_morphs thy;
266.299 - val thm1 = Goal.prove_global thy [] [] goal1 (K tac1)
266.300 - handle ERROR msg => cat_error msg
266.301 - ("Failed to prove non-emptiness of " ^ quote (Syntax.string_of_term_global thy set));
266.302 - val thm2 = Goal.prove_global thy [] [] goal2 (K tac2)
266.303 - handle ERROR msg => cat_error msg
266.304 - ("Failed to prove admissibility of " ^ quote (Syntax.string_of_term_global thy set));
266.305 - in cpodef_result thm1 thm2 thy end;
266.306 -
266.307 -fun add_pcpodef def opt_name typ set opt_morphs (tac1, tac2) thy =
266.308 - let
266.309 - val name = the_default (#1 typ) opt_name;
266.310 - val (goal1, goal2, pcpodef_result) =
266.311 - prepare_pcpodef Syntax.check_term def name typ set opt_morphs thy;
266.312 - val thm1 = Goal.prove_global thy [] [] goal1 (K tac1)
266.313 - handle ERROR msg => cat_error msg
266.314 - ("Failed to prove non-emptiness of " ^ quote (Syntax.string_of_term_global thy set));
266.315 - val thm2 = Goal.prove_global thy [] [] goal2 (K tac2)
266.316 - handle ERROR msg => cat_error msg
266.317 - ("Failed to prove admissibility of " ^ quote (Syntax.string_of_term_global thy set));
266.318 - in pcpodef_result thm1 thm2 thy end;
266.319 -
266.320 -
266.321 -(* proof interface *)
266.322 -
266.323 -local
266.324 -
266.325 -fun gen_cpodef_proof prep_term prep_constraint
266.326 - ((def, name), (b, raw_args, mx), set, opt_morphs) thy =
266.327 - let
266.328 - val ctxt = ProofContext.init_global thy;
266.329 - val args = map (apsnd (prep_constraint ctxt)) raw_args;
266.330 - val (goal1, goal2, make_result) =
266.331 - prepare_cpodef prep_term def name (b, args, mx) set opt_morphs thy;
266.332 - fun after_qed [[th1, th2]] = ProofContext.background_theory (snd o make_result th1 th2)
266.333 - | after_qed _ = raise Fail "cpodef_proof";
266.334 - in Proof.theorem NONE after_qed [[(goal1, []), (goal2, [])]] ctxt end;
266.335 -
266.336 -fun gen_pcpodef_proof prep_term prep_constraint
266.337 - ((def, name), (b, raw_args, mx), set, opt_morphs) thy =
266.338 - let
266.339 - val ctxt = ProofContext.init_global thy;
266.340 - val args = map (apsnd (prep_constraint ctxt)) raw_args;
266.341 - val (goal1, goal2, make_result) =
266.342 - prepare_pcpodef prep_term def name (b, args, mx) set opt_morphs thy;
266.343 - fun after_qed [[th1, th2]] = ProofContext.background_theory (snd o make_result th1 th2)
266.344 - | after_qed _ = raise Fail "pcpodef_proof";
266.345 - in Proof.theorem NONE after_qed [[(goal1, []), (goal2, [])]] ctxt end;
266.346 -
266.347 -in
266.348 -
266.349 -fun cpodef_proof x = gen_cpodef_proof Syntax.check_term (K I) x;
266.350 -fun cpodef_proof_cmd x = gen_cpodef_proof Syntax.read_term Typedecl.read_constraint x;
266.351 -
266.352 -fun pcpodef_proof x = gen_pcpodef_proof Syntax.check_term (K I) x;
266.353 -fun pcpodef_proof_cmd x = gen_pcpodef_proof Syntax.read_term Typedecl.read_constraint x;
266.354 -
266.355 -end;
266.356 -
266.357 -
266.358 -
266.359 -(** outer syntax **)
266.360 -
266.361 -val typedef_proof_decl =
266.362 - Scan.optional (Parse.$$$ "(" |--
266.363 - ((Parse.$$$ "open" >> K false) -- Scan.option Parse.binding ||
266.364 - Parse.binding >> (fn s => (true, SOME s)))
266.365 - --| Parse.$$$ ")") (true, NONE) --
266.366 - (Parse.type_args_constrained -- Parse.binding) -- Parse.opt_mixfix --
266.367 - (Parse.$$$ "=" |-- Parse.term) --
266.368 - Scan.option (Parse.$$$ "morphisms" |-- Parse.!!! (Parse.binding -- Parse.binding));
266.369 -
266.370 -fun mk_pcpodef_proof pcpo ((((((def, opt_name), (args, t)), mx), A), morphs)) =
266.371 - (if pcpo then pcpodef_proof_cmd else cpodef_proof_cmd)
266.372 - ((def, the_default t opt_name), (t, args, mx), A, morphs);
266.373 -
266.374 -val _ =
266.375 - Outer_Syntax.command "pcpodef" "HOLCF type definition (requires admissibility proof)"
266.376 - Keyword.thy_goal
266.377 - (typedef_proof_decl >>
266.378 - (Toplevel.print oo (Toplevel.theory_to_proof o mk_pcpodef_proof true)));
266.379 -
266.380 -val _ =
266.381 - Outer_Syntax.command "cpodef" "HOLCF type definition (requires admissibility proof)"
266.382 - Keyword.thy_goal
266.383 - (typedef_proof_decl >>
266.384 - (Toplevel.print oo (Toplevel.theory_to_proof o mk_pcpodef_proof false)));
266.385 -
266.386 -end;
267.1 --- a/src/HOLCF/Tools/domaindef.ML Sat Nov 27 14:34:54 2010 -0800
267.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
267.3 @@ -1,236 +0,0 @@
267.4 -(* Title: HOLCF/Tools/repdef.ML
267.5 - Author: Brian Huffman
267.6 -
267.7 -Defining representable domains using algebraic deflations.
267.8 -*)
267.9 -
267.10 -signature DOMAINDEF =
267.11 -sig
267.12 - type rep_info =
267.13 - {
267.14 - emb_def : thm,
267.15 - prj_def : thm,
267.16 - defl_def : thm,
267.17 - liftemb_def : thm,
267.18 - liftprj_def : thm,
267.19 - liftdefl_def : thm,
267.20 - DEFL : thm
267.21 - }
267.22 -
267.23 - val add_domaindef: bool -> binding option -> binding * (string * sort) list * mixfix ->
267.24 - term -> (binding * binding) option -> theory ->
267.25 - (Typedef.info * Cpodef.cpo_info * Cpodef.pcpo_info * rep_info) * theory
267.26 -
267.27 - val domaindef_cmd: (bool * binding) * (binding * (string * string option) list * mixfix) * string
267.28 - * (binding * binding) option -> theory -> theory
267.29 -end;
267.30 -
267.31 -structure Domaindef :> DOMAINDEF =
267.32 -struct
267.33 -
267.34 -open HOLCF_Library;
267.35 -
267.36 -infixr 6 ->>;
267.37 -infix -->>;
267.38 -
267.39 -(** type definitions **)
267.40 -
267.41 -type rep_info =
267.42 - {
267.43 - emb_def : thm,
267.44 - prj_def : thm,
267.45 - defl_def : thm,
267.46 - liftemb_def : thm,
267.47 - liftprj_def : thm,
267.48 - liftdefl_def : thm,
267.49 - DEFL : thm
267.50 - };
267.51 -
267.52 -(* building types and terms *)
267.53 -
267.54 -val udomT = @{typ udom};
267.55 -val deflT = @{typ defl};
267.56 -fun emb_const T = Const (@{const_name emb}, T ->> udomT);
267.57 -fun prj_const T = Const (@{const_name prj}, udomT ->> T);
267.58 -fun defl_const T = Const (@{const_name defl}, Term.itselfT T --> deflT);
267.59 -fun liftemb_const T = Const (@{const_name liftemb}, mk_upT T ->> udomT);
267.60 -fun liftprj_const T = Const (@{const_name liftprj}, udomT ->> mk_upT T);
267.61 -fun liftdefl_const T = Const (@{const_name liftdefl}, Term.itselfT T --> deflT);
267.62 -
267.63 -fun mk_u_map t =
267.64 - let
267.65 - val (T, U) = dest_cfunT (fastype_of t);
267.66 - val u_map_type = (T ->> U) ->> (mk_upT T ->> mk_upT U);
267.67 - val u_map_const = Const (@{const_name u_map}, u_map_type);
267.68 - in
267.69 - mk_capply (u_map_const, t)
267.70 - end;
267.71 -
267.72 -fun mk_cast (t, x) =
267.73 - capply_const (udomT, udomT)
267.74 - $ (capply_const (deflT, udomT ->> udomT) $ @{const cast} $ t)
267.75 - $ x;
267.76 -
267.77 -(* manipulating theorems *)
267.78 -
267.79 -(* proving class instances *)
267.80 -
267.81 -fun declare_type_name a =
267.82 - Variable.declare_constraints (Logic.mk_type (TFree (a, dummyS)));
267.83 -
267.84 -fun gen_add_domaindef
267.85 - (prep_term: Proof.context -> 'a -> term)
267.86 - (def: bool)
267.87 - (name: binding)
267.88 - (typ as (tname, raw_args, mx) : binding * (string * sort) list * mixfix)
267.89 - (raw_defl: 'a)
267.90 - (opt_morphs: (binding * binding) option)
267.91 - (thy: theory)
267.92 - : (Typedef.info * Cpodef.cpo_info * Cpodef.pcpo_info * rep_info) * theory =
267.93 - let
267.94 - val _ = Theory.requires thy "Domain" "domaindefs";
267.95 -
267.96 - (*rhs*)
267.97 - val tmp_ctxt =
267.98 - ProofContext.init_global thy
267.99 - |> fold (Variable.declare_typ o TFree) raw_args;
267.100 - val defl = prep_term tmp_ctxt raw_defl;
267.101 - val tmp_ctxt = tmp_ctxt |> Variable.declare_constraints defl;
267.102 -
267.103 - val deflT = Term.fastype_of defl;
267.104 - val _ = if deflT = @{typ "defl"} then ()
267.105 - else error ("Not type defl: " ^ quote (Syntax.string_of_typ tmp_ctxt deflT));
267.106 -
267.107 - (*lhs*)
267.108 - val lhs_tfrees = map (ProofContext.check_tfree tmp_ctxt) raw_args;
267.109 - val lhs_sorts = map snd lhs_tfrees;
267.110 - val full_tname = Sign.full_name thy tname;
267.111 - val newT = Type (full_tname, map TFree lhs_tfrees);
267.112 -
267.113 - (*morphisms*)
267.114 - val morphs = opt_morphs
267.115 - |> the_default (Binding.prefix_name "Rep_" name, Binding.prefix_name "Abs_" name);
267.116 -
267.117 - (*set*)
267.118 - val set = @{const defl_set} $ defl;
267.119 -
267.120 - (*pcpodef*)
267.121 - val tac1 = rtac @{thm defl_set_bottom} 1;
267.122 - val tac2 = rtac @{thm adm_defl_set} 1;
267.123 - val ((info, cpo_info, pcpo_info), thy) = thy
267.124 - |> Cpodef.add_pcpodef def (SOME name) typ set (SOME morphs) (tac1, tac2);
267.125 -
267.126 - (*definitions*)
267.127 - val Rep_const = Const (#Rep_name (#1 info), newT --> udomT);
267.128 - val Abs_const = Const (#Abs_name (#1 info), udomT --> newT);
267.129 - val emb_eqn = Logic.mk_equals (emb_const newT, cabs_const (newT, udomT) $ Rep_const);
267.130 - val prj_eqn = Logic.mk_equals (prj_const newT, cabs_const (udomT, newT) $
267.131 - Abs ("x", udomT, Abs_const $ mk_cast (defl, Bound 0)));
267.132 - val defl_eqn = Logic.mk_equals (defl_const newT,
267.133 - Abs ("x", Term.itselfT newT, defl));
267.134 - val liftemb_eqn =
267.135 - Logic.mk_equals (liftemb_const newT,
267.136 - mk_cfcomp (@{term "udom_emb u_approx"}, mk_u_map (emb_const newT)));
267.137 - val liftprj_eqn =
267.138 - Logic.mk_equals (liftprj_const newT,
267.139 - mk_cfcomp (mk_u_map (prj_const newT), @{term "udom_prj u_approx"}));
267.140 - val liftdefl_eqn =
267.141 - Logic.mk_equals (liftdefl_const newT,
267.142 - Abs ("t", Term.itselfT newT,
267.143 - mk_capply (@{const u_defl}, defl_const newT $ Logic.mk_type newT)));
267.144 -
267.145 - val name_def = Binding.suffix_name "_def" name;
267.146 - val emb_bind = (Binding.prefix_name "emb_" name_def, []);
267.147 - val prj_bind = (Binding.prefix_name "prj_" name_def, []);
267.148 - val defl_bind = (Binding.prefix_name "defl_" name_def, []);
267.149 - val liftemb_bind = (Binding.prefix_name "liftemb_" name_def, []);
267.150 - val liftprj_bind = (Binding.prefix_name "liftprj_" name_def, []);
267.151 - val liftdefl_bind = (Binding.prefix_name "liftdefl_" name_def, []);
267.152 -
267.153 - (*instantiate class rep*)
267.154 - val lthy = thy
267.155 - |> Class.instantiation ([full_tname], lhs_tfrees, @{sort liftdomain});
267.156 - val ((_, (_, emb_ldef)), lthy) =
267.157 - Specification.definition (NONE, (emb_bind, emb_eqn)) lthy;
267.158 - val ((_, (_, prj_ldef)), lthy) =
267.159 - Specification.definition (NONE, (prj_bind, prj_eqn)) lthy;
267.160 - val ((_, (_, defl_ldef)), lthy) =
267.161 - Specification.definition (NONE, (defl_bind, defl_eqn)) lthy;
267.162 - val ((_, (_, liftemb_ldef)), lthy) =
267.163 - Specification.definition (NONE, (liftemb_bind, liftemb_eqn)) lthy;
267.164 - val ((_, (_, liftprj_ldef)), lthy) =
267.165 - Specification.definition (NONE, (liftprj_bind, liftprj_eqn)) lthy;
267.166 - val ((_, (_, liftdefl_ldef)), lthy) =
267.167 - Specification.definition (NONE, (liftdefl_bind, liftdefl_eqn)) lthy;
267.168 - val ctxt_thy = ProofContext.init_global (ProofContext.theory_of lthy);
267.169 - val emb_def = singleton (ProofContext.export lthy ctxt_thy) emb_ldef;
267.170 - val prj_def = singleton (ProofContext.export lthy ctxt_thy) prj_ldef;
267.171 - val defl_def = singleton (ProofContext.export lthy ctxt_thy) defl_ldef;
267.172 - val liftemb_def = singleton (ProofContext.export lthy ctxt_thy) liftemb_ldef;
267.173 - val liftprj_def = singleton (ProofContext.export lthy ctxt_thy) liftprj_ldef;
267.174 - val liftdefl_def = singleton (ProofContext.export lthy ctxt_thy) liftdefl_ldef;
267.175 - val type_definition_thm =
267.176 - MetaSimplifier.rewrite_rule
267.177 - (the_list (#set_def (#2 info)))
267.178 - (#type_definition (#2 info));
267.179 - val typedef_thms =
267.180 - [type_definition_thm, #below_def cpo_info, emb_def, prj_def, defl_def,
267.181 - liftemb_def, liftprj_def, liftdefl_def];
267.182 - val thy = lthy
267.183 - |> Class.prove_instantiation_instance
267.184 - (K (Tactic.rtac (@{thm typedef_liftdomain_class} OF typedef_thms) 1))
267.185 - |> Local_Theory.exit_global;
267.186 -
267.187 - (*other theorems*)
267.188 - val defl_thm' = Thm.transfer thy defl_def;
267.189 - val (DEFL_thm, thy) = thy
267.190 - |> Sign.add_path (Binding.name_of name)
267.191 - |> Global_Theory.add_thm
267.192 - ((Binding.prefix_name "DEFL_" name,
267.193 - Drule.zero_var_indexes (@{thm typedef_DEFL} OF [defl_thm'])), [])
267.194 - ||> Sign.restore_naming thy;
267.195 -
267.196 - val rep_info =
267.197 - { emb_def = emb_def, prj_def = prj_def, defl_def = defl_def,
267.198 - liftemb_def = liftemb_def, liftprj_def = liftprj_def,
267.199 - liftdefl_def = liftdefl_def, DEFL = DEFL_thm };
267.200 - in
267.201 - ((info, cpo_info, pcpo_info, rep_info), thy)
267.202 - end
267.203 - handle ERROR msg =>
267.204 - cat_error msg ("The error(s) above occurred in domaindef " ^ quote (Binding.str_of name));
267.205 -
267.206 -fun add_domaindef def opt_name typ defl opt_morphs thy =
267.207 - let
267.208 - val name = the_default (#1 typ) opt_name;
267.209 - in
267.210 - gen_add_domaindef Syntax.check_term def name typ defl opt_morphs thy
267.211 - end;
267.212 -
267.213 -fun domaindef_cmd ((def, name), (b, raw_args, mx), A, morphs) thy =
267.214 - let
267.215 - val ctxt = ProofContext.init_global thy;
267.216 - val args = map (apsnd (Typedecl.read_constraint ctxt)) raw_args;
267.217 - in snd (gen_add_domaindef Syntax.read_term def name (b, args, mx) A morphs thy) end;
267.218 -
267.219 -
267.220 -(** outer syntax **)
267.221 -
267.222 -val domaindef_decl =
267.223 - Scan.optional (Parse.$$$ "(" |--
267.224 - ((Parse.$$$ "open" >> K false) -- Scan.option Parse.binding ||
267.225 - Parse.binding >> (fn s => (true, SOME s)))
267.226 - --| Parse.$$$ ")") (true, NONE) --
267.227 - (Parse.type_args_constrained -- Parse.binding) --
267.228 - Parse.opt_mixfix -- (Parse.$$$ "=" |-- Parse.term) --
267.229 - Scan.option (Parse.$$$ "morphisms" |-- Parse.!!! (Parse.binding -- Parse.binding));
267.230 -
267.231 -fun mk_domaindef ((((((def, opt_name), (args, t)), mx), A), morphs)) =
267.232 - domaindef_cmd ((def, the_default t opt_name), (t, args, mx), A, morphs);
267.233 -
267.234 -val _ =
267.235 - Outer_Syntax.command "domaindef" "HOLCF definition of domains from deflations" Keyword.thy_decl
267.236 - (domaindef_decl >>
267.237 - (Toplevel.print oo (Toplevel.theory o mk_domaindef)));
267.238 -
267.239 -end;
268.1 --- a/src/HOLCF/Tools/fixrec.ML Sat Nov 27 14:34:54 2010 -0800
268.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
268.3 @@ -1,417 +0,0 @@
268.4 -(* Title: HOLCF/Tools/fixrec.ML
268.5 - Author: Amber Telfer and Brian Huffman
268.6 -
268.7 -Recursive function definition package for HOLCF.
268.8 -*)
268.9 -
268.10 -signature FIXREC =
268.11 -sig
268.12 - val add_fixrec: (binding * typ option * mixfix) list
268.13 - -> (bool * (Attrib.binding * term)) list -> local_theory -> local_theory
268.14 - val add_fixrec_cmd: (binding * string option * mixfix) list
268.15 - -> (bool * (Attrib.binding * string)) list -> local_theory -> local_theory
268.16 - val add_matchers: (string * string) list -> theory -> theory
268.17 - val fixrec_simp_tac: Proof.context -> int -> tactic
268.18 - val setup: theory -> theory
268.19 -end;
268.20 -
268.21 -structure Fixrec :> FIXREC =
268.22 -struct
268.23 -
268.24 -open HOLCF_Library;
268.25 -
268.26 -infixr 6 ->>;
268.27 -infix -->>;
268.28 -infix 9 `;
268.29 -
268.30 -val def_cont_fix_eq = @{thm def_cont_fix_eq};
268.31 -val def_cont_fix_ind = @{thm def_cont_fix_ind};
268.32 -
268.33 -fun fixrec_err s = error ("fixrec definition error:\n" ^ s);
268.34 -fun fixrec_eq_err thy s eq =
268.35 - fixrec_err (s ^ "\nin\n" ^ quote (Syntax.string_of_term_global thy eq));
268.36 -
268.37 -(*************************************************************************)
268.38 -(***************************** building types ****************************)
268.39 -(*************************************************************************)
268.40 -
268.41 -local
268.42 -
268.43 -fun binder_cfun (Type(@{type_name cfun},[T, U])) = T :: binder_cfun U
268.44 - | binder_cfun (Type(@{type_name "fun"},[T, U])) = T :: binder_cfun U
268.45 - | binder_cfun _ = [];
268.46 -
268.47 -fun body_cfun (Type(@{type_name cfun},[T, U])) = body_cfun U
268.48 - | body_cfun (Type(@{type_name "fun"},[T, U])) = body_cfun U
268.49 - | body_cfun T = T;
268.50 -
268.51 -fun strip_cfun T : typ list * typ =
268.52 - (binder_cfun T, body_cfun T);
268.53 -
268.54 -in
268.55 -
268.56 -fun matcherT (T, U) =
268.57 - body_cfun T ->> (binder_cfun T -->> U) ->> U;
268.58 -
268.59 -end
268.60 -
268.61 -(*************************************************************************)
268.62 -(***************************** building terms ****************************)
268.63 -(*************************************************************************)
268.64 -
268.65 -val mk_trp = HOLogic.mk_Trueprop;
268.66 -
268.67 -(* splits a cterm into the right and lefthand sides of equality *)
268.68 -fun dest_eqs t = HOLogic.dest_eq (HOLogic.dest_Trueprop t);
268.69 -
268.70 -(* similar to Thm.head_of, but for continuous application *)
268.71 -fun chead_of (Const(@{const_name Rep_cfun},_)$f$t) = chead_of f
268.72 - | chead_of u = u;
268.73 -
268.74 -infix 0 ==; val (op ==) = Logic.mk_equals;
268.75 -infix 1 ===; val (op ===) = HOLogic.mk_eq;
268.76 -
268.77 -fun mk_mplus (t, u) =
268.78 - let val mT = Term.fastype_of t
268.79 - in Const(@{const_name Fixrec.mplus}, mT ->> mT ->> mT) ` t ` u end;
268.80 -
268.81 -fun mk_run t =
268.82 - let
268.83 - val mT = Term.fastype_of t
268.84 - val T = dest_matchT mT
268.85 - val run = Const(@{const_name Fixrec.run}, mT ->> T)
268.86 - in
268.87 - case t of
268.88 - Const(@{const_name Rep_cfun}, _) $
268.89 - Const(@{const_name Fixrec.succeed}, _) $ u => u
268.90 - | _ => run ` t
268.91 - end;
268.92 -
268.93 -
268.94 -(*************************************************************************)
268.95 -(************* fixed-point definitions and unfolding theorems ************)
268.96 -(*************************************************************************)
268.97 -
268.98 -structure FixrecUnfoldData = Generic_Data
268.99 -(
268.100 - type T = thm Symtab.table;
268.101 - val empty = Symtab.empty;
268.102 - val extend = I;
268.103 - fun merge data : T = Symtab.merge (K true) data;
268.104 -);
268.105 -
268.106 -local
268.107 -
268.108 -fun name_of (Const (n, T)) = n
268.109 - | name_of (Free (n, T)) = n
268.110 - | name_of t = raise TERM ("Fixrec.add_unfold: lhs not a constant", [t]);
268.111 -
268.112 -val lhs_name =
268.113 - name_of o head_of o fst o HOLogic.dest_eq o HOLogic.dest_Trueprop o prop_of;
268.114 -
268.115 -in
268.116 -
268.117 -val add_unfold : attribute =
268.118 - Thm.declaration_attribute
268.119 - (fn th => FixrecUnfoldData.map (Symtab.insert (K true) (lhs_name th, th)));
268.120 -
268.121 -end
268.122 -
268.123 -fun add_fixdefs
268.124 - (fixes : ((binding * typ) * mixfix) list)
268.125 - (spec : (Attrib.binding * term) list)
268.126 - (lthy : local_theory) =
268.127 - let
268.128 - val thy = ProofContext.theory_of lthy;
268.129 - val names = map (Binding.name_of o fst o fst) fixes;
268.130 - val all_names = space_implode "_" names;
268.131 - val (lhss, rhss) = ListPair.unzip (map (dest_eqs o snd) spec);
268.132 - val functional = lambda_tuple lhss (mk_tuple rhss);
268.133 - val fixpoint = mk_fix (mk_cabs functional);
268.134 -
268.135 - val cont_thm =
268.136 - let
268.137 - val prop = mk_trp (mk_cont functional);
268.138 - fun err _ = error (
268.139 - "Continuity proof failed; please check that cont2cont rules\n" ^
268.140 - "or simp rules are configured for all non-HOLCF constants.\n" ^
268.141 - "The error occurred for the goal statement:\n" ^
268.142 - Syntax.string_of_term lthy prop);
268.143 - val rules = Cont2ContData.get lthy;
268.144 - val fast_tac = SOLVED' (REPEAT_ALL_NEW (match_tac rules));
268.145 - val slow_tac = SOLVED' (simp_tac (simpset_of lthy));
268.146 - val tac = fast_tac 1 ORELSE slow_tac 1 ORELSE err;
268.147 - in
268.148 - Goal.prove lthy [] [] prop (K tac)
268.149 - end;
268.150 -
268.151 - fun one_def (l as Free(n,_)) r =
268.152 - let val b = Long_Name.base_name n
268.153 - in ((Binding.name (b^"_def"), []), r) end
268.154 - | one_def _ _ = fixrec_err "fixdefs: lhs not of correct form";
268.155 - fun defs [] _ = []
268.156 - | defs (l::[]) r = [one_def l r]
268.157 - | defs (l::ls) r = one_def l (mk_fst r) :: defs ls (mk_snd r);
268.158 - val fixdefs = defs lhss fixpoint;
268.159 - val (fixdef_thms : (term * (string * thm)) list, lthy) = lthy
268.160 - |> fold_map Local_Theory.define (map (apfst fst) fixes ~~ fixdefs);
268.161 - fun pair_equalI (thm1, thm2) = @{thm Pair_equalI} OF [thm1, thm2];
268.162 - val tuple_fixdef_thm = foldr1 pair_equalI (map (snd o snd) fixdef_thms);
268.163 - val P = Var (("P", 0), map Term.fastype_of lhss ---> HOLogic.boolT);
268.164 - val predicate = lambda_tuple lhss (list_comb (P, lhss));
268.165 - val tuple_induct_thm = (def_cont_fix_ind OF [tuple_fixdef_thm, cont_thm])
268.166 - |> Drule.instantiate' [] [SOME (Thm.cterm_of thy predicate)]
268.167 - |> Local_Defs.unfold lthy @{thms split_paired_all split_conv split_strict};
268.168 - val tuple_unfold_thm = (def_cont_fix_eq OF [tuple_fixdef_thm, cont_thm])
268.169 - |> Local_Defs.unfold lthy @{thms split_conv};
268.170 - fun unfolds [] thm = []
268.171 - | unfolds (n::[]) thm = [(n, thm)]
268.172 - | unfolds (n::ns) thm = let
268.173 - val thmL = thm RS @{thm Pair_eqD1};
268.174 - val thmR = thm RS @{thm Pair_eqD2};
268.175 - in (n, thmL) :: unfolds ns thmR end;
268.176 - val unfold_thms = unfolds names tuple_unfold_thm;
268.177 - val induct_note : Attrib.binding * Thm.thm list =
268.178 - let
268.179 - val thm_name = Binding.qualify true all_names (Binding.name "induct");
268.180 - in
268.181 - ((thm_name, []), [tuple_induct_thm])
268.182 - end;
268.183 - fun unfold_note (name, thm) : Attrib.binding * Thm.thm list =
268.184 - let
268.185 - val thm_name = Binding.qualify true name (Binding.name "unfold");
268.186 - val src = Attrib.internal (K add_unfold);
268.187 - in
268.188 - ((thm_name, [src]), [thm])
268.189 - end;
268.190 - val (thmss, lthy) = lthy
268.191 - |> fold_map Local_Theory.note (induct_note :: map unfold_note unfold_thms);
268.192 - in
268.193 - (lthy, names, fixdef_thms, map snd unfold_thms)
268.194 - end;
268.195 -
268.196 -(*************************************************************************)
268.197 -(*********** monadic notation and pattern matching compilation ***********)
268.198 -(*************************************************************************)
268.199 -
268.200 -structure FixrecMatchData = Theory_Data
268.201 -(
268.202 - type T = string Symtab.table;
268.203 - val empty = Symtab.empty;
268.204 - val extend = I;
268.205 - fun merge data = Symtab.merge (K true) data;
268.206 -);
268.207 -
268.208 -(* associate match functions with pattern constants *)
268.209 -fun add_matchers ms = FixrecMatchData.map (fold Symtab.update ms);
268.210 -
268.211 -fun taken_names (t : term) : bstring list =
268.212 - let
268.213 - fun taken (Const(a,_), bs) = insert (op =) (Long_Name.base_name a) bs
268.214 - | taken (Free(a,_) , bs) = insert (op =) a bs
268.215 - | taken (f $ u , bs) = taken (f, taken (u, bs))
268.216 - | taken (Abs(a,_,t), bs) = taken (t, insert (op =) a bs)
268.217 - | taken (_ , bs) = bs;
268.218 - in
268.219 - taken (t, [])
268.220 - end;
268.221 -
268.222 -(* builds a monadic term for matching a pattern *)
268.223 -(* returns (rhs, free variable, used varnames) *)
268.224 -fun compile_pat match_name pat rhs taken =
268.225 - let
268.226 - fun comp_pat p rhs taken =
268.227 - if is_Free p then (rhs, p, taken)
268.228 - else comp_con (fastype_of p) p rhs [] taken
268.229 - (* compiles a monadic term for a constructor pattern *)
268.230 - and comp_con T p rhs vs taken =
268.231 - case p of
268.232 - Const(@{const_name Rep_cfun},_) $ f $ x =>
268.233 - let val (rhs', v, taken') = comp_pat x rhs taken
268.234 - in comp_con T f rhs' (v::vs) taken' end
268.235 - | f $ x =>
268.236 - let val (rhs', v, taken') = comp_pat x rhs taken
268.237 - in comp_con T f rhs' (v::vs) taken' end
268.238 - | Const (c, cT) =>
268.239 - let
268.240 - val n = Name.variant taken "v"
268.241 - val v = Free(n, T)
268.242 - val m = Const(match_name c, matcherT (cT, fastype_of rhs))
268.243 - val k = big_lambdas vs rhs
268.244 - in
268.245 - (m`v`k, v, n::taken)
268.246 - end
268.247 - | _ => raise TERM ("fixrec: invalid pattern ", [p])
268.248 - in
268.249 - comp_pat pat rhs taken
268.250 - end;
268.251 -
268.252 -(* builds a monadic term for matching a function definition pattern *)
268.253 -(* returns (constant, (vars, matcher)) *)
268.254 -fun compile_lhs match_name pat rhs vs taken =
268.255 - case pat of
268.256 - Const(@{const_name Rep_cfun}, _) $ f $ x =>
268.257 - let val (rhs', v, taken') = compile_pat match_name x rhs taken;
268.258 - in compile_lhs match_name f rhs' (v::vs) taken' end
268.259 - | Free(_,_) => (pat, (vs, rhs))
268.260 - | Const(_,_) => (pat, (vs, rhs))
268.261 - | _ => fixrec_err ("invalid function pattern: "
268.262 - ^ ML_Syntax.print_term pat);
268.263 -
268.264 -fun strip_alls t =
268.265 - if Logic.is_all t then strip_alls (snd (Logic.dest_all t)) else t;
268.266 -
268.267 -fun compile_eq match_name eq =
268.268 - let
268.269 - val (lhs,rhs) = dest_eqs (Logic.strip_imp_concl (strip_alls eq));
268.270 - in
268.271 - compile_lhs match_name lhs (mk_succeed rhs) [] (taken_names eq)
268.272 - end;
268.273 -
268.274 -(* this is the pattern-matching compiler function *)
268.275 -fun compile_eqs match_name eqs =
268.276 - let
268.277 - val (consts, matchers) =
268.278 - ListPair.unzip (map (compile_eq match_name) eqs);
268.279 - val const =
268.280 - case distinct (op =) consts of
268.281 - [n] => n
268.282 - | _ => fixrec_err "all equations in block must define the same function";
268.283 - val vars =
268.284 - case distinct (op = o pairself length) (map fst matchers) of
268.285 - [vars] => vars
268.286 - | _ => fixrec_err "all equations in block must have the same arity";
268.287 - (* rename so all matchers use same free variables *)
268.288 - fun rename (vs, t) = Term.subst_free (filter_out (op =) (vs ~~ vars)) t;
268.289 - val rhs = big_lambdas vars (mk_run (foldr1 mk_mplus (map rename matchers)));
268.290 - in
268.291 - mk_trp (const === rhs)
268.292 - end;
268.293 -
268.294 -(*************************************************************************)
268.295 -(********************** Proving associated theorems **********************)
268.296 -(*************************************************************************)
268.297 -
268.298 -fun eta_tac i = CONVERSION Thm.eta_conversion i;
268.299 -
268.300 -fun fixrec_simp_tac ctxt =
268.301 - let
268.302 - val tab = FixrecUnfoldData.get (Context.Proof ctxt);
268.303 - val ss = Simplifier.simpset_of ctxt;
268.304 - fun concl t =
268.305 - if Logic.is_all t then concl (snd (Logic.dest_all t))
268.306 - else HOLogic.dest_Trueprop (Logic.strip_imp_concl t);
268.307 - fun tac (t, i) =
268.308 - let
268.309 - val (c, T) =
268.310 - (dest_Const o head_of o chead_of o fst o HOLogic.dest_eq o concl) t;
268.311 - val unfold_thm = the (Symtab.lookup tab c);
268.312 - val rule = unfold_thm RS @{thm ssubst_lhs};
268.313 - in
268.314 - CHANGED (rtac rule i THEN eta_tac i THEN asm_simp_tac ss i)
268.315 - end
268.316 - in
268.317 - SUBGOAL (fn ti => the_default no_tac (try tac ti))
268.318 - end;
268.319 -
268.320 -(* proves a block of pattern matching equations as theorems, using unfold *)
268.321 -fun make_simps ctxt (unfold_thm, eqns : (Attrib.binding * term) list) =
268.322 - let
268.323 - val ss = Simplifier.simpset_of ctxt;
268.324 - val rule = unfold_thm RS @{thm ssubst_lhs};
268.325 - val tac = rtac rule 1 THEN eta_tac 1 THEN asm_simp_tac ss 1;
268.326 - fun prove_term t = Goal.prove ctxt [] [] t (K tac);
268.327 - fun prove_eqn (bind, eqn_t) = (bind, prove_term eqn_t);
268.328 - in
268.329 - map prove_eqn eqns
268.330 - end;
268.331 -
268.332 -(*************************************************************************)
268.333 -(************************* Main fixrec function **************************)
268.334 -(*************************************************************************)
268.335 -
268.336 -local
268.337 -(* code adapted from HOL/Tools/primrec.ML *)
268.338 -
268.339 -fun gen_fixrec
268.340 - prep_spec
268.341 - (raw_fixes : (binding * 'a option * mixfix) list)
268.342 - (raw_spec' : (bool * (Attrib.binding * 'b)) list)
268.343 - (lthy : local_theory) =
268.344 - let
268.345 - val (skips, raw_spec) = ListPair.unzip raw_spec';
268.346 - val (fixes : ((binding * typ) * mixfix) list,
268.347 - spec : (Attrib.binding * term) list) =
268.348 - fst (prep_spec raw_fixes raw_spec lthy);
268.349 - val chead_of_spec =
268.350 - chead_of o fst o dest_eqs o Logic.strip_imp_concl o strip_alls o snd;
268.351 - fun name_of (Free (n, _)) = n
268.352 - | name_of t = fixrec_err ("unknown term");
268.353 - val all_names = map (name_of o chead_of_spec) spec;
268.354 - val names = distinct (op =) all_names;
268.355 - fun block_of_name n =
268.356 - map_filter
268.357 - (fn (m,eq) => if m = n then SOME eq else NONE)
268.358 - (all_names ~~ (spec ~~ skips));
268.359 - val blocks = map block_of_name names;
268.360 -
268.361 - val matcher_tab = FixrecMatchData.get (ProofContext.theory_of lthy);
268.362 - fun match_name c =
268.363 - case Symtab.lookup matcher_tab c of SOME m => m
268.364 - | NONE => fixrec_err ("unknown pattern constructor: " ^ c);
268.365 -
268.366 - val matches = map (compile_eqs match_name) (map (map (snd o fst)) blocks);
268.367 - val spec' = map (pair Attrib.empty_binding) matches;
268.368 - val (lthy, cnames, fixdef_thms, unfold_thms) =
268.369 - add_fixdefs fixes spec' lthy;
268.370 -
268.371 - val blocks' = map (map fst o filter_out snd) blocks;
268.372 - val simps : (Attrib.binding * thm) list list =
268.373 - map (make_simps lthy) (unfold_thms ~~ blocks');
268.374 - fun mk_bind n : Attrib.binding =
268.375 - (Binding.qualify true n (Binding.name "simps"),
268.376 - [Attrib.internal (K Simplifier.simp_add)]);
268.377 - val simps1 : (Attrib.binding * thm list) list =
268.378 - map (fn (n,xs) => (mk_bind n, map snd xs)) (names ~~ simps);
268.379 - val simps2 : (Attrib.binding * thm list) list =
268.380 - map (apsnd (fn thm => [thm])) (flat simps);
268.381 - val (_, lthy) = lthy
268.382 - |> fold_map Local_Theory.note (simps1 @ simps2);
268.383 - in
268.384 - lthy
268.385 - end;
268.386 -
268.387 -in
268.388 -
268.389 -val add_fixrec = gen_fixrec Specification.check_spec;
268.390 -val add_fixrec_cmd = gen_fixrec Specification.read_spec;
268.391 -
268.392 -end; (* local *)
268.393 -
268.394 -
268.395 -(*************************************************************************)
268.396 -(******************************** Parsers ********************************)
268.397 -(*************************************************************************)
268.398 -
268.399 -val opt_thm_name' : (bool * Attrib.binding) parser =
268.400 - Parse.$$$ "(" -- Parse.$$$ "unchecked" -- Parse.$$$ ")" >> K (true, Attrib.empty_binding)
268.401 - || Parse_Spec.opt_thm_name ":" >> pair false;
268.402 -
268.403 -val spec' : (bool * (Attrib.binding * string)) parser =
268.404 - opt_thm_name' -- Parse.prop >> (fn ((a, b), c) => (a, (b, c)));
268.405 -
268.406 -val alt_specs' : (bool * (Attrib.binding * string)) list parser =
268.407 - let val unexpected = Scan.ahead (Parse.name || Parse.$$$ "[" || Parse.$$$ "(");
268.408 - in Parse.enum1 "|" (spec' --| Scan.option (unexpected -- Parse.!!! (Parse.$$$ "|"))) end;
268.409 -
268.410 -val _ =
268.411 - Outer_Syntax.local_theory "fixrec" "define recursive functions (HOLCF)" Keyword.thy_decl
268.412 - (Parse.fixes -- (Parse.where_ |-- Parse.!!! alt_specs')
268.413 - >> (fn (fixes, specs) => add_fixrec_cmd fixes specs));
268.414 -
268.415 -val setup =
268.416 - Method.setup @{binding fixrec_simp}
268.417 - (Scan.succeed (SIMPLE_METHOD' o fixrec_simp_tac))
268.418 - "pattern prover for fixrec constants";
268.419 -
268.420 -end;
269.1 --- a/src/HOLCF/Tools/holcf_library.ML Sat Nov 27 14:34:54 2010 -0800
269.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
269.3 @@ -1,289 +0,0 @@
269.4 -(* Title: HOLCF/Tools/holcf_library.ML
269.5 - Author: Brian Huffman
269.6 -
269.7 -Functions for constructing HOLCF types and terms.
269.8 -*)
269.9 -
269.10 -structure HOLCF_Library =
269.11 -struct
269.12 -
269.13 -infixr 6 ->>;
269.14 -infixr -->>;
269.15 -infix 9 `;
269.16 -
269.17 -(*** Operations from Isabelle/HOL ***)
269.18 -
269.19 -val boolT = HOLogic.boolT;
269.20 -val natT = HOLogic.natT;
269.21 -
269.22 -val mk_equals = Logic.mk_equals;
269.23 -val mk_eq = HOLogic.mk_eq;
269.24 -val mk_trp = HOLogic.mk_Trueprop;
269.25 -val mk_fst = HOLogic.mk_fst;
269.26 -val mk_snd = HOLogic.mk_snd;
269.27 -val mk_not = HOLogic.mk_not;
269.28 -val mk_conj = HOLogic.mk_conj;
269.29 -val mk_disj = HOLogic.mk_disj;
269.30 -val mk_imp = HOLogic.mk_imp;
269.31 -
269.32 -fun mk_ex (x, t) = HOLogic.exists_const (fastype_of x) $ Term.lambda x t;
269.33 -fun mk_all (x, t) = HOLogic.all_const (fastype_of x) $ Term.lambda x t;
269.34 -
269.35 -
269.36 -(*** Basic HOLCF concepts ***)
269.37 -
269.38 -fun mk_bottom T = Const (@{const_name UU}, T);
269.39 -
269.40 -fun below_const T = Const (@{const_name below}, [T, T] ---> boolT);
269.41 -fun mk_below (t, u) = below_const (fastype_of t) $ t $ u;
269.42 -
269.43 -fun mk_undef t = mk_eq (t, mk_bottom (fastype_of t));
269.44 -
269.45 -fun mk_defined t = mk_not (mk_undef t);
269.46 -
269.47 -fun mk_adm t =
269.48 - Const (@{const_name adm}, fastype_of t --> boolT) $ t;
269.49 -
269.50 -fun mk_compact t =
269.51 - Const (@{const_name compact}, fastype_of t --> boolT) $ t;
269.52 -
269.53 -fun mk_cont t =
269.54 - Const (@{const_name cont}, fastype_of t --> boolT) $ t;
269.55 -
269.56 -fun mk_chain t =
269.57 - Const (@{const_name chain}, Term.fastype_of t --> boolT) $ t;
269.58 -
269.59 -fun mk_lub t =
269.60 - let
269.61 - val T = Term.range_type (Term.fastype_of t);
269.62 - val lub_const = Const (@{const_name lub}, (T --> boolT) --> T);
269.63 - val UNIV_const = @{term "UNIV :: nat set"};
269.64 - val image_type = (natT --> T) --> (natT --> boolT) --> T --> boolT;
269.65 - val image_const = Const (@{const_name image}, image_type);
269.66 - in
269.67 - lub_const $ (image_const $ t $ UNIV_const)
269.68 - end;
269.69 -
269.70 -
269.71 -(*** Continuous function space ***)
269.72 -
269.73 -fun mk_cfunT (T, U) = Type(@{type_name cfun}, [T, U]);
269.74 -
269.75 -val (op ->>) = mk_cfunT;
269.76 -val (op -->>) = Library.foldr mk_cfunT;
269.77 -
269.78 -fun dest_cfunT (Type(@{type_name cfun}, [T, U])) = (T, U)
269.79 - | dest_cfunT T = raise TYPE ("dest_cfunT", [T], []);
269.80 -
269.81 -fun capply_const (S, T) =
269.82 - Const(@{const_name Rep_cfun}, (S ->> T) --> (S --> T));
269.83 -
269.84 -fun cabs_const (S, T) =
269.85 - Const(@{const_name Abs_cfun}, (S --> T) --> (S ->> T));
269.86 -
269.87 -fun mk_cabs t =
269.88 - let val T = fastype_of t
269.89 - in cabs_const (Term.domain_type T, Term.range_type T) $ t end
269.90 -
269.91 -(* builds the expression (% v1 v2 .. vn. rhs) *)
269.92 -fun lambdas [] rhs = rhs
269.93 - | lambdas (v::vs) rhs = Term.lambda v (lambdas vs rhs);
269.94 -
269.95 -(* builds the expression (LAM v. rhs) *)
269.96 -fun big_lambda v rhs =
269.97 - cabs_const (fastype_of v, fastype_of rhs) $ Term.lambda v rhs;
269.98 -
269.99 -(* builds the expression (LAM v1 v2 .. vn. rhs) *)
269.100 -fun big_lambdas [] rhs = rhs
269.101 - | big_lambdas (v::vs) rhs = big_lambda v (big_lambdas vs rhs);
269.102 -
269.103 -fun mk_capply (t, u) =
269.104 - let val (S, T) =
269.105 - case fastype_of t of
269.106 - Type(@{type_name cfun}, [S, T]) => (S, T)
269.107 - | _ => raise TERM ("mk_capply " ^ ML_Syntax.print_list ML_Syntax.print_term [t, u], [t, u]);
269.108 - in capply_const (S, T) $ t $ u end;
269.109 -
269.110 -val (op `) = mk_capply;
269.111 -
269.112 -val list_ccomb : term * term list -> term = Library.foldl mk_capply;
269.113 -
269.114 -fun mk_ID T = Const (@{const_name ID}, T ->> T);
269.115 -
269.116 -fun cfcomp_const (T, U, V) =
269.117 - Const (@{const_name cfcomp}, (U ->> V) ->> (T ->> U) ->> (T ->> V));
269.118 -
269.119 -fun mk_cfcomp (f, g) =
269.120 - let
269.121 - val (U, V) = dest_cfunT (fastype_of f);
269.122 - val (T, U') = dest_cfunT (fastype_of g);
269.123 - in
269.124 - if U = U'
269.125 - then mk_capply (mk_capply (cfcomp_const (T, U, V), f), g)
269.126 - else raise TYPE ("mk_cfcomp", [U, U'], [f, g])
269.127 - end;
269.128 -
269.129 -fun strictify_const T = Const (@{const_name strictify}, T ->> T);
269.130 -fun mk_strictify t = strictify_const (fastype_of t) ` t;
269.131 -
269.132 -fun mk_strict t =
269.133 - let val (T, U) = dest_cfunT (fastype_of t);
269.134 - in mk_eq (t ` mk_bottom T, mk_bottom U) end;
269.135 -
269.136 -
269.137 -(*** Product type ***)
269.138 -
269.139 -val mk_prodT = HOLogic.mk_prodT
269.140 -
269.141 -fun mk_tupleT [] = HOLogic.unitT
269.142 - | mk_tupleT [T] = T
269.143 - | mk_tupleT (T :: Ts) = mk_prodT (T, mk_tupleT Ts);
269.144 -
269.145 -(* builds the expression (v1,v2,..,vn) *)
269.146 -fun mk_tuple [] = HOLogic.unit
269.147 - | mk_tuple (t::[]) = t
269.148 - | mk_tuple (t::ts) = HOLogic.mk_prod (t, mk_tuple ts);
269.149 -
269.150 -(* builds the expression (%(v1,v2,..,vn). rhs) *)
269.151 -fun lambda_tuple [] rhs = Term.lambda (Free("unit", HOLogic.unitT)) rhs
269.152 - | lambda_tuple (v::[]) rhs = Term.lambda v rhs
269.153 - | lambda_tuple (v::vs) rhs =
269.154 - HOLogic.mk_split (Term.lambda v (lambda_tuple vs rhs));
269.155 -
269.156 -
269.157 -(*** Lifted cpo type ***)
269.158 -
269.159 -fun mk_upT T = Type(@{type_name "u"}, [T]);
269.160 -
269.161 -fun dest_upT (Type(@{type_name "u"}, [T])) = T
269.162 - | dest_upT T = raise TYPE ("dest_upT", [T], []);
269.163 -
269.164 -fun up_const T = Const(@{const_name up}, T ->> mk_upT T);
269.165 -
269.166 -fun mk_up t = up_const (fastype_of t) ` t;
269.167 -
269.168 -fun fup_const (T, U) =
269.169 - Const(@{const_name fup}, (T ->> U) ->> mk_upT T ->> U);
269.170 -
269.171 -fun mk_fup t = fup_const (dest_cfunT (fastype_of t)) ` t;
269.172 -
269.173 -fun from_up T = fup_const (T, T) ` mk_ID T;
269.174 -
269.175 -
269.176 -(*** Lifted unit type ***)
269.177 -
269.178 -val oneT = @{typ "one"};
269.179 -
269.180 -fun one_case_const T = Const (@{const_name one_case}, T ->> oneT ->> T);
269.181 -fun mk_one_case t = one_case_const (fastype_of t) ` t;
269.182 -
269.183 -
269.184 -(*** Strict product type ***)
269.185 -
269.186 -fun mk_sprodT (T, U) = Type(@{type_name sprod}, [T, U]);
269.187 -
269.188 -fun dest_sprodT (Type(@{type_name sprod}, [T, U])) = (T, U)
269.189 - | dest_sprodT T = raise TYPE ("dest_sprodT", [T], []);
269.190 -
269.191 -fun spair_const (T, U) =
269.192 - Const(@{const_name spair}, T ->> U ->> mk_sprodT (T, U));
269.193 -
269.194 -(* builds the expression (:t, u:) *)
269.195 -fun mk_spair (t, u) =
269.196 - spair_const (fastype_of t, fastype_of u) ` t ` u;
269.197 -
269.198 -(* builds the expression (:t1,t2,..,tn:) *)
269.199 -fun mk_stuple [] = @{term "ONE"}
269.200 - | mk_stuple (t::[]) = t
269.201 - | mk_stuple (t::ts) = mk_spair (t, mk_stuple ts);
269.202 -
269.203 -fun sfst_const (T, U) =
269.204 - Const(@{const_name sfst}, mk_sprodT (T, U) ->> T);
269.205 -
269.206 -fun ssnd_const (T, U) =
269.207 - Const(@{const_name ssnd}, mk_sprodT (T, U) ->> U);
269.208 -
269.209 -fun ssplit_const (T, U, V) =
269.210 - Const (@{const_name ssplit}, (T ->> U ->> V) ->> mk_sprodT (T, U) ->> V);
269.211 -
269.212 -fun mk_ssplit t =
269.213 - let val (T, (U, V)) = apsnd dest_cfunT (dest_cfunT (fastype_of t));
269.214 - in ssplit_const (T, U, V) ` t end;
269.215 -
269.216 -
269.217 -(*** Strict sum type ***)
269.218 -
269.219 -fun mk_ssumT (T, U) = Type(@{type_name ssum}, [T, U]);
269.220 -
269.221 -fun dest_ssumT (Type(@{type_name ssum}, [T, U])) = (T, U)
269.222 - | dest_ssumT T = raise TYPE ("dest_ssumT", [T], []);
269.223 -
269.224 -fun sinl_const (T, U) = Const(@{const_name sinl}, T ->> mk_ssumT (T, U));
269.225 -fun sinr_const (T, U) = Const(@{const_name sinr}, U ->> mk_ssumT (T, U));
269.226 -
269.227 -(* builds the list [sinl(t1), sinl(sinr(t2)), ... sinr(...sinr(tn))] *)
269.228 -fun mk_sinjects ts =
269.229 - let
269.230 - val Ts = map fastype_of ts;
269.231 - fun combine (t, T) (us, U) =
269.232 - let
269.233 - val v = sinl_const (T, U) ` t;
269.234 - val vs = map (fn u => sinr_const (T, U) ` u) us;
269.235 - in
269.236 - (v::vs, mk_ssumT (T, U))
269.237 - end
269.238 - fun inj [] = raise Fail "mk_sinjects: empty list"
269.239 - | inj ((t, T)::[]) = ([t], T)
269.240 - | inj ((t, T)::ts) = combine (t, T) (inj ts);
269.241 - in
269.242 - fst (inj (ts ~~ Ts))
269.243 - end;
269.244 -
269.245 -fun sscase_const (T, U, V) =
269.246 - Const(@{const_name sscase},
269.247 - (T ->> V) ->> (U ->> V) ->> mk_ssumT (T, U) ->> V);
269.248 -
269.249 -fun mk_sscase (t, u) =
269.250 - let val (T, V) = dest_cfunT (fastype_of t);
269.251 - val (U, V) = dest_cfunT (fastype_of u);
269.252 - in sscase_const (T, U, V) ` t ` u end;
269.253 -
269.254 -fun from_sinl (T, U) =
269.255 - sscase_const (T, U, T) ` mk_ID T ` mk_bottom (U ->> T);
269.256 -
269.257 -fun from_sinr (T, U) =
269.258 - sscase_const (T, U, U) ` mk_bottom (T ->> U) ` mk_ID U;
269.259 -
269.260 -
269.261 -(*** pattern match monad type ***)
269.262 -
269.263 -fun mk_matchT T = Type (@{type_name "match"}, [T]);
269.264 -
269.265 -fun dest_matchT (Type(@{type_name "match"}, [T])) = T
269.266 - | dest_matchT T = raise TYPE ("dest_matchT", [T], []);
269.267 -
269.268 -fun mk_fail T = Const (@{const_name "Fixrec.fail"}, mk_matchT T);
269.269 -
269.270 -fun succeed_const T = Const (@{const_name "Fixrec.succeed"}, T ->> mk_matchT T);
269.271 -fun mk_succeed t = succeed_const (fastype_of t) ` t;
269.272 -
269.273 -
269.274 -(*** lifted boolean type ***)
269.275 -
269.276 -val trT = @{typ "tr"};
269.277 -
269.278 -
269.279 -(*** theory of fixed points ***)
269.280 -
269.281 -fun mk_fix t =
269.282 - let val (T, _) = dest_cfunT (fastype_of t)
269.283 - in mk_capply (Const(@{const_name fix}, (T ->> T) ->> T), t) end;
269.284 -
269.285 -fun iterate_const T =
269.286 - Const (@{const_name iterate}, natT --> (T ->> T) ->> (T ->> T));
269.287 -
269.288 -fun mk_iterate (n, f) =
269.289 - let val (T, _) = dest_cfunT (Term.fastype_of f);
269.290 - in (iterate_const T $ n) ` f ` mk_bottom T end;
269.291 -
269.292 -end;
270.1 --- a/src/HOLCF/Tr.thy Sat Nov 27 14:34:54 2010 -0800
270.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
270.3 @@ -1,199 +0,0 @@
270.4 -(* Title: HOLCF/Tr.thy
270.5 - Author: Franz Regensburger
270.6 -*)
270.7 -
270.8 -header {* The type of lifted booleans *}
270.9 -
270.10 -theory Tr
270.11 -imports Lift
270.12 -begin
270.13 -
270.14 -subsection {* Type definition and constructors *}
270.15 -
270.16 -types
270.17 - tr = "bool lift"
270.18 -
270.19 -translations
270.20 - (type) "tr" <= (type) "bool lift"
270.21 -
270.22 -definition
270.23 - TT :: "tr" where
270.24 - "TT = Def True"
270.25 -
270.26 -definition
270.27 - FF :: "tr" where
270.28 - "FF = Def False"
270.29 -
270.30 -text {* Exhaustion and Elimination for type @{typ tr} *}
270.31 -
270.32 -lemma Exh_tr: "t = \<bottom> \<or> t = TT \<or> t = FF"
270.33 -unfolding FF_def TT_def by (induct t) auto
270.34 -
270.35 -lemma trE [case_names bottom TT FF]:
270.36 - "\<lbrakk>p = \<bottom> \<Longrightarrow> Q; p = TT \<Longrightarrow> Q; p = FF \<Longrightarrow> Q\<rbrakk> \<Longrightarrow> Q"
270.37 -unfolding FF_def TT_def by (induct p) auto
270.38 -
270.39 -lemma tr_induct [case_names bottom TT FF]:
270.40 - "\<lbrakk>P \<bottom>; P TT; P FF\<rbrakk> \<Longrightarrow> P x"
270.41 -by (cases x rule: trE) simp_all
270.42 -
270.43 -text {* distinctness for type @{typ tr} *}
270.44 -
270.45 -lemma dist_below_tr [simp]:
270.46 - "\<not> TT \<sqsubseteq> \<bottom>" "\<not> FF \<sqsubseteq> \<bottom>" "\<not> TT \<sqsubseteq> FF" "\<not> FF \<sqsubseteq> TT"
270.47 -unfolding TT_def FF_def by simp_all
270.48 -
270.49 -lemma dist_eq_tr [simp]:
270.50 - "TT \<noteq> \<bottom>" "FF \<noteq> \<bottom>" "TT \<noteq> FF" "\<bottom> \<noteq> TT" "\<bottom> \<noteq> FF" "FF \<noteq> TT"
270.51 -unfolding TT_def FF_def by simp_all
270.52 -
270.53 -lemma TT_below_iff [simp]: "TT \<sqsubseteq> x \<longleftrightarrow> x = TT"
270.54 -by (induct x rule: tr_induct) simp_all
270.55 -
270.56 -lemma FF_below_iff [simp]: "FF \<sqsubseteq> x \<longleftrightarrow> x = FF"
270.57 -by (induct x rule: tr_induct) simp_all
270.58 -
270.59 -lemma not_below_TT_iff [simp]: "\<not> (x \<sqsubseteq> TT) \<longleftrightarrow> x = FF"
270.60 -by (induct x rule: tr_induct) simp_all
270.61 -
270.62 -lemma not_below_FF_iff [simp]: "\<not> (x \<sqsubseteq> FF) \<longleftrightarrow> x = TT"
270.63 -by (induct x rule: tr_induct) simp_all
270.64 -
270.65 -
270.66 -subsection {* Case analysis *}
270.67 -
270.68 -default_sort pcpo
270.69 -
270.70 -definition tr_case :: "'a \<rightarrow> 'a \<rightarrow> tr \<rightarrow> 'a" where
270.71 - "tr_case = (\<Lambda> t e (Def b). if b then t else e)"
270.72 -
270.73 -abbreviation
270.74 - cifte_syn :: "[tr, 'c, 'c] \<Rightarrow> 'c" ("(If (_)/ then (_)/ else (_))" [0, 0, 60] 60)
270.75 -where
270.76 - "If b then e1 else e2 == tr_case\<cdot>e1\<cdot>e2\<cdot>b"
270.77 -
270.78 -translations
270.79 - "\<Lambda> (XCONST TT). t" == "CONST tr_case\<cdot>t\<cdot>\<bottom>"
270.80 - "\<Lambda> (XCONST FF). t" == "CONST tr_case\<cdot>\<bottom>\<cdot>t"
270.81 -
270.82 -lemma ifte_thms [simp]:
270.83 - "If \<bottom> then e1 else e2 = \<bottom>"
270.84 - "If FF then e1 else e2 = e2"
270.85 - "If TT then e1 else e2 = e1"
270.86 -by (simp_all add: tr_case_def TT_def FF_def)
270.87 -
270.88 -
270.89 -subsection {* Boolean connectives *}
270.90 -
270.91 -definition
270.92 - trand :: "tr \<rightarrow> tr \<rightarrow> tr" where
270.93 - andalso_def: "trand = (\<Lambda> x y. If x then y else FF)"
270.94 -abbreviation
270.95 - andalso_syn :: "tr \<Rightarrow> tr \<Rightarrow> tr" ("_ andalso _" [36,35] 35) where
270.96 - "x andalso y == trand\<cdot>x\<cdot>y"
270.97 -
270.98 -definition
270.99 - tror :: "tr \<rightarrow> tr \<rightarrow> tr" where
270.100 - orelse_def: "tror = (\<Lambda> x y. If x then TT else y)"
270.101 -abbreviation
270.102 - orelse_syn :: "tr \<Rightarrow> tr \<Rightarrow> tr" ("_ orelse _" [31,30] 30) where
270.103 - "x orelse y == tror\<cdot>x\<cdot>y"
270.104 -
270.105 -definition
270.106 - neg :: "tr \<rightarrow> tr" where
270.107 - "neg = flift2 Not"
270.108 -
270.109 -definition
270.110 - If2 :: "[tr, 'c, 'c] \<Rightarrow> 'c" where
270.111 - "If2 Q x y = (If Q then x else y)"
270.112 -
270.113 -text {* tactic for tr-thms with case split *}
270.114 -
270.115 -lemmas tr_defs = andalso_def orelse_def neg_def tr_case_def TT_def FF_def
270.116 -
270.117 -text {* lemmas about andalso, orelse, neg and if *}
270.118 -
270.119 -lemma andalso_thms [simp]:
270.120 - "(TT andalso y) = y"
270.121 - "(FF andalso y) = FF"
270.122 - "(\<bottom> andalso y) = \<bottom>"
270.123 - "(y andalso TT) = y"
270.124 - "(y andalso y) = y"
270.125 -apply (unfold andalso_def, simp_all)
270.126 -apply (cases y rule: trE, simp_all)
270.127 -apply (cases y rule: trE, simp_all)
270.128 -done
270.129 -
270.130 -lemma orelse_thms [simp]:
270.131 - "(TT orelse y) = TT"
270.132 - "(FF orelse y) = y"
270.133 - "(\<bottom> orelse y) = \<bottom>"
270.134 - "(y orelse FF) = y"
270.135 - "(y orelse y) = y"
270.136 -apply (unfold orelse_def, simp_all)
270.137 -apply (cases y rule: trE, simp_all)
270.138 -apply (cases y rule: trE, simp_all)
270.139 -done
270.140 -
270.141 -lemma neg_thms [simp]:
270.142 - "neg\<cdot>TT = FF"
270.143 - "neg\<cdot>FF = TT"
270.144 - "neg\<cdot>\<bottom> = \<bottom>"
270.145 -by (simp_all add: neg_def TT_def FF_def)
270.146 -
270.147 -text {* split-tac for If via If2 because the constant has to be a constant *}
270.148 -
270.149 -lemma split_If2:
270.150 - "P (If2 Q x y) = ((Q = \<bottom> \<longrightarrow> P \<bottom>) \<and> (Q = TT \<longrightarrow> P x) \<and> (Q = FF \<longrightarrow> P y))"
270.151 -apply (unfold If2_def)
270.152 -apply (rule_tac p = "Q" in trE)
270.153 -apply (simp_all)
270.154 -done
270.155 -
270.156 -ML {*
270.157 -val split_If_tac =
270.158 - simp_tac (HOL_basic_ss addsimps [@{thm If2_def} RS sym])
270.159 - THEN' (split_tac [@{thm split_If2}])
270.160 -*}
270.161 -
270.162 -subsection "Rewriting of HOLCF operations to HOL functions"
270.163 -
270.164 -lemma andalso_or:
270.165 - "t \<noteq> \<bottom> \<Longrightarrow> ((t andalso s) = FF) = (t = FF \<or> s = FF)"
270.166 -apply (rule_tac p = "t" in trE)
270.167 -apply simp_all
270.168 -done
270.169 -
270.170 -lemma andalso_and:
270.171 - "t \<noteq> \<bottom> \<Longrightarrow> ((t andalso s) \<noteq> FF) = (t \<noteq> FF \<and> s \<noteq> FF)"
270.172 -apply (rule_tac p = "t" in trE)
270.173 -apply simp_all
270.174 -done
270.175 -
270.176 -lemma Def_bool1 [simp]: "(Def x \<noteq> FF) = x"
270.177 -by (simp add: FF_def)
270.178 -
270.179 -lemma Def_bool2 [simp]: "(Def x = FF) = (\<not> x)"
270.180 -by (simp add: FF_def)
270.181 -
270.182 -lemma Def_bool3 [simp]: "(Def x = TT) = x"
270.183 -by (simp add: TT_def)
270.184 -
270.185 -lemma Def_bool4 [simp]: "(Def x \<noteq> TT) = (\<not> x)"
270.186 -by (simp add: TT_def)
270.187 -
270.188 -lemma If_and_if:
270.189 - "(If Def P then A else B) = (if P then A else B)"
270.190 -apply (rule_tac p = "Def P" in trE)
270.191 -apply (auto simp add: TT_def[symmetric] FF_def[symmetric])
270.192 -done
270.193 -
270.194 -subsection {* Compactness *}
270.195 -
270.196 -lemma compact_TT: "compact TT"
270.197 -by (rule compact_chfin)
270.198 -
270.199 -lemma compact_FF: "compact FF"
270.200 -by (rule compact_chfin)
270.201 -
270.202 -end
271.1 --- a/src/HOLCF/Tutorial/Domain_ex.thy Sat Nov 27 14:34:54 2010 -0800
271.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
271.3 @@ -1,201 +0,0 @@
271.4 -(* Title: HOLCF/ex/Domain_ex.thy
271.5 - Author: Brian Huffman
271.6 -*)
271.7 -
271.8 -header {* Domain package examples *}
271.9 -
271.10 -theory Domain_ex
271.11 -imports HOLCF
271.12 -begin
271.13 -
271.14 -text {* Domain constructors are strict by default. *}
271.15 -
271.16 -domain d1 = d1a | d1b "d1" "d1"
271.17 -
271.18 -lemma "d1b\<cdot>\<bottom>\<cdot>y = \<bottom>" by simp
271.19 -
271.20 -text {* Constructors can be made lazy using the @{text "lazy"} keyword. *}
271.21 -
271.22 -domain d2 = d2a | d2b (lazy "d2")
271.23 -
271.24 -lemma "d2b\<cdot>x \<noteq> \<bottom>" by simp
271.25 -
271.26 -text {* Strict and lazy arguments may be mixed arbitrarily. *}
271.27 -
271.28 -domain d3 = d3a | d3b (lazy "d2") "d2"
271.29 -
271.30 -lemma "P (d3b\<cdot>x\<cdot>y = \<bottom>) \<longleftrightarrow> P (y = \<bottom>)" by simp
271.31 -
271.32 -text {* Selectors can be used with strict or lazy constructor arguments. *}
271.33 -
271.34 -domain d4 = d4a | d4b (lazy d4b_left :: "d2") (d4b_right :: "d2")
271.35 -
271.36 -lemma "y \<noteq> \<bottom> \<Longrightarrow> d4b_left\<cdot>(d4b\<cdot>x\<cdot>y) = x" by simp
271.37 -
271.38 -text {* Mixfix declarations can be given for data constructors. *}
271.39 -
271.40 -domain d5 = d5a | d5b (lazy "d5") "d5" (infixl ":#:" 70)
271.41 -
271.42 -lemma "d5a \<noteq> x :#: y :#: z" by simp
271.43 -
271.44 -text {* Mixfix declarations can also be given for type constructors. *}
271.45 -
271.46 -domain ('a, 'b) lazypair (infixl ":*:" 25) =
271.47 - lpair (lazy lfst :: 'a) (lazy lsnd :: 'b) (infixl ":*:" 75)
271.48 -
271.49 -lemma "\<forall>p::('a :*: 'b). p \<sqsubseteq> lfst\<cdot>p :*: lsnd\<cdot>p"
271.50 -by (rule allI, case_tac p, simp_all)
271.51 -
271.52 -text {* Non-recursive constructor arguments can have arbitrary types. *}
271.53 -
271.54 -domain ('a, 'b) d6 = d6 "int lift" "'a \<oplus> 'b u" (lazy "('a :*: 'b) \<times> ('b \<rightarrow> 'a)")
271.55 -
271.56 -text {*
271.57 - Indirect recusion is allowed for sums, products, lifting, and the
271.58 - continuous function space. However, the domain package does not
271.59 - generate an induction rule in terms of the constructors.
271.60 -*}
271.61 -
271.62 -domain 'a d7 = d7a "'a d7 \<oplus> int lift" | d7b "'a \<otimes> 'a d7" | d7c (lazy "'a d7 \<rightarrow> 'a")
271.63 - -- "Indirect recursion detected, skipping proofs of (co)induction rules"
271.64 -
271.65 -text {* Note that @{text d7.induct} is absent. *}
271.66 -
271.67 -text {*
271.68 - Indirect recursion is also allowed using previously-defined datatypes.
271.69 -*}
271.70 -
271.71 -domain 'a slist = SNil | SCons 'a "'a slist"
271.72 -
271.73 -domain 'a stree = STip | SBranch "'a stree slist"
271.74 -
271.75 -text {* Mutually-recursive datatypes can be defined using the @{text "and"} keyword. *}
271.76 -
271.77 -domain d8 = d8a | d8b "d9" and d9 = d9a | d9b (lazy "d8")
271.78 -
271.79 -text {* Non-regular recursion is not allowed. *}
271.80 -(*
271.81 -domain ('a, 'b) altlist = ANil | ACons 'a "('b, 'a) altlist"
271.82 - -- "illegal direct recursion with different arguments"
271.83 -domain 'a nest = Nest1 'a | Nest2 "'a nest nest"
271.84 - -- "illegal direct recursion with different arguments"
271.85 -*)
271.86 -
271.87 -text {*
271.88 - Mutually-recursive datatypes must have all the same type arguments,
271.89 - not necessarily in the same order.
271.90 -*}
271.91 -
271.92 -domain ('a, 'b) list1 = Nil1 | Cons1 'a "('b, 'a) list2"
271.93 - and ('b, 'a) list2 = Nil2 | Cons2 'b "('a, 'b) list1"
271.94 -
271.95 -text {* Induction rules for flat datatypes have no admissibility side-condition. *}
271.96 -
271.97 -domain 'a flattree = Tip | Branch "'a flattree" "'a flattree"
271.98 -
271.99 -lemma "\<lbrakk>P \<bottom>; P Tip; \<And>x y. \<lbrakk>x \<noteq> \<bottom>; y \<noteq> \<bottom>; P x; P y\<rbrakk> \<Longrightarrow> P (Branch\<cdot>x\<cdot>y)\<rbrakk> \<Longrightarrow> P x"
271.100 -by (rule flattree.induct) -- "no admissibility requirement"
271.101 -
271.102 -text {* Trivial datatypes will produce a warning message. *}
271.103 -
271.104 -domain triv = Triv triv triv
271.105 - -- "domain @{text Domain_ex.triv} is empty!"
271.106 -
271.107 -lemma "(x::triv) = \<bottom>" by (induct x, simp_all)
271.108 -
271.109 -text {* Lazy constructor arguments may have unpointed types. *}
271.110 -
271.111 -domain natlist = nnil | ncons (lazy "nat discr") natlist
271.112 -
271.113 -text {* Class constraints may be given for type parameters on the LHS. *}
271.114 -
271.115 -domain ('a::predomain) box = Box (lazy 'a)
271.116 -
271.117 -domain ('a::countable) stream = snil | scons (lazy "'a discr") "'a stream"
271.118 -
271.119 -
271.120 -subsection {* Generated constants and theorems *}
271.121 -
271.122 -domain 'a tree = Leaf (lazy 'a) | Node (left :: "'a tree") (right :: "'a tree")
271.123 -
271.124 -lemmas tree_abs_bottom_iff =
271.125 - iso.abs_bottom_iff [OF iso.intro [OF tree.abs_iso tree.rep_iso]]
271.126 -
271.127 -text {* Rules about ismorphism *}
271.128 -term tree_rep
271.129 -term tree_abs
271.130 -thm tree.rep_iso
271.131 -thm tree.abs_iso
271.132 -thm tree.iso_rews
271.133 -
271.134 -text {* Rules about constructors *}
271.135 -term Leaf
271.136 -term Node
271.137 -thm Leaf_def Node_def
271.138 -thm tree.nchotomy
271.139 -thm tree.exhaust
271.140 -thm tree.compacts
271.141 -thm tree.con_rews
271.142 -thm tree.dist_les
271.143 -thm tree.dist_eqs
271.144 -thm tree.inverts
271.145 -thm tree.injects
271.146 -
271.147 -text {* Rules about case combinator *}
271.148 -term tree_case
271.149 -thm tree.tree_case_def
271.150 -thm tree.case_rews
271.151 -
271.152 -text {* Rules about selectors *}
271.153 -term left
271.154 -term right
271.155 -thm tree.sel_rews
271.156 -
271.157 -text {* Rules about discriminators *}
271.158 -term is_Leaf
271.159 -term is_Node
271.160 -thm tree.dis_rews
271.161 -
271.162 -text {* Rules about monadic pattern match combinators *}
271.163 -term match_Leaf
271.164 -term match_Node
271.165 -thm tree.match_rews
271.166 -
271.167 -text {* Rules about take function *}
271.168 -term tree_take
271.169 -thm tree.take_def
271.170 -thm tree.take_0
271.171 -thm tree.take_Suc
271.172 -thm tree.take_rews
271.173 -thm tree.chain_take
271.174 -thm tree.take_take
271.175 -thm tree.deflation_take
271.176 -thm tree.take_below
271.177 -thm tree.take_lemma
271.178 -thm tree.lub_take
271.179 -thm tree.reach
271.180 -thm tree.finite_induct
271.181 -
271.182 -text {* Rules about finiteness predicate *}
271.183 -term tree_finite
271.184 -thm tree.finite_def
271.185 -thm tree.finite (* only generated for flat datatypes *)
271.186 -
271.187 -text {* Rules about bisimulation predicate *}
271.188 -term tree_bisim
271.189 -thm tree.bisim_def
271.190 -thm tree.coinduct
271.191 -
271.192 -text {* Induction rule *}
271.193 -thm tree.induct
271.194 -
271.195 -
271.196 -subsection {* Known bugs *}
271.197 -
271.198 -text {* Declaring a mixfix with spaces causes some strange parse errors. *}
271.199 -(*
271.200 -domain xx = xx ("x y")
271.201 - -- "Inner syntax error: unexpected end of input"
271.202 -*)
271.203 -
271.204 -end
272.1 --- a/src/HOLCF/Tutorial/Fixrec_ex.thy Sat Nov 27 14:34:54 2010 -0800
272.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
272.3 @@ -1,245 +0,0 @@
272.4 -(* Title: HOLCF/ex/Fixrec_ex.thy
272.5 - Author: Brian Huffman
272.6 -*)
272.7 -
272.8 -header {* Fixrec package examples *}
272.9 -
272.10 -theory Fixrec_ex
272.11 -imports HOLCF
272.12 -begin
272.13 -
272.14 -subsection {* Basic @{text fixrec} examples *}
272.15 -
272.16 -text {*
272.17 - Fixrec patterns can mention any constructor defined by the domain
272.18 - package, as well as any of the following built-in constructors:
272.19 - Pair, spair, sinl, sinr, up, ONE, TT, FF.
272.20 -*}
272.21 -
272.22 -text {* Typical usage is with lazy constructors. *}
272.23 -
272.24 -fixrec down :: "'a u \<rightarrow> 'a"
272.25 -where "down\<cdot>(up\<cdot>x) = x"
272.26 -
272.27 -text {* With strict constructors, rewrite rules may require side conditions. *}
272.28 -
272.29 -fixrec from_sinl :: "'a \<oplus> 'b \<rightarrow> 'a"
272.30 -where "x \<noteq> \<bottom> \<Longrightarrow> from_sinl\<cdot>(sinl\<cdot>x) = x"
272.31 -
272.32 -text {* Lifting can turn a strict constructor into a lazy one. *}
272.33 -
272.34 -fixrec from_sinl_up :: "'a u \<oplus> 'b \<rightarrow> 'a"
272.35 -where "from_sinl_up\<cdot>(sinl\<cdot>(up\<cdot>x)) = x"
272.36 -
272.37 -text {* Fixrec also works with the HOL pair constructor. *}
272.38 -
272.39 -fixrec down2 :: "'a u \<times> 'b u \<rightarrow> 'a \<times> 'b"
272.40 -where "down2\<cdot>(up\<cdot>x, up\<cdot>y) = (x, y)"
272.41 -
272.42 -
272.43 -subsection {* Examples using @{text fixrec_simp} *}
272.44 -
272.45 -text {* A type of lazy lists. *}
272.46 -
272.47 -domain 'a llist = lNil | lCons (lazy 'a) (lazy "'a llist")
272.48 -
272.49 -text {* A zip function for lazy lists. *}
272.50 -
272.51 -text {* Notice that the patterns are not exhaustive. *}
272.52 -
272.53 -fixrec
272.54 - lzip :: "'a llist \<rightarrow> 'b llist \<rightarrow> ('a \<times> 'b) llist"
272.55 -where
272.56 - "lzip\<cdot>(lCons\<cdot>x\<cdot>xs)\<cdot>(lCons\<cdot>y\<cdot>ys) = lCons\<cdot>(x, y)\<cdot>(lzip\<cdot>xs\<cdot>ys)"
272.57 -| "lzip\<cdot>lNil\<cdot>lNil = lNil"
272.58 -
272.59 -text {* @{text fixrec_simp} is useful for producing strictness theorems. *}
272.60 -text {* Note that pattern matching is done in left-to-right order. *}
272.61 -
272.62 -lemma lzip_stricts [simp]:
272.63 - "lzip\<cdot>\<bottom>\<cdot>ys = \<bottom>"
272.64 - "lzip\<cdot>lNil\<cdot>\<bottom> = \<bottom>"
272.65 - "lzip\<cdot>(lCons\<cdot>x\<cdot>xs)\<cdot>\<bottom> = \<bottom>"
272.66 -by fixrec_simp+
272.67 -
272.68 -text {* @{text fixrec_simp} can also produce rules for missing cases. *}
272.69 -
272.70 -lemma lzip_undefs [simp]:
272.71 - "lzip\<cdot>lNil\<cdot>(lCons\<cdot>y\<cdot>ys) = \<bottom>"
272.72 - "lzip\<cdot>(lCons\<cdot>x\<cdot>xs)\<cdot>lNil = \<bottom>"
272.73 -by fixrec_simp+
272.74 -
272.75 -
272.76 -subsection {* Pattern matching with bottoms *}
272.77 -
272.78 -text {*
272.79 - As an alternative to using @{text fixrec_simp}, it is also possible
272.80 - to use bottom as a constructor pattern. When using a bottom
272.81 - pattern, the right-hand-side must also be bottom; otherwise, @{text
272.82 - fixrec} will not be able to prove the equation.
272.83 -*}
272.84 -
272.85 -fixrec
272.86 - from_sinr_up :: "'a \<oplus> 'b\<^sub>\<bottom> \<rightarrow> 'b"
272.87 -where
272.88 - "from_sinr_up\<cdot>\<bottom> = \<bottom>"
272.89 -| "from_sinr_up\<cdot>(sinr\<cdot>(up\<cdot>x)) = x"
272.90 -
272.91 -text {*
272.92 - If the function is already strict in that argument, then the bottom
272.93 - pattern does not change the meaning of the function. For example,
272.94 - in the definition of @{term from_sinr_up}, the first equation is
272.95 - actually redundant, and could have been proven separately by
272.96 - @{text fixrec_simp}.
272.97 -*}
272.98 -
272.99 -text {*
272.100 - A bottom pattern can also be used to make a function strict in a
272.101 - certain argument, similar to a bang-pattern in Haskell.
272.102 -*}
272.103 -
272.104 -fixrec
272.105 - seq :: "'a \<rightarrow> 'b \<rightarrow> 'b"
272.106 -where
272.107 - "seq\<cdot>\<bottom>\<cdot>y = \<bottom>"
272.108 -| "x \<noteq> \<bottom> \<Longrightarrow> seq\<cdot>x\<cdot>y = y"
272.109 -
272.110 -
272.111 -subsection {* Skipping proofs of rewrite rules *}
272.112 -
272.113 -text {* Another zip function for lazy lists. *}
272.114 -
272.115 -text {*
272.116 - Notice that this version has overlapping patterns.
272.117 - The second equation cannot be proved as a theorem
272.118 - because it only applies when the first pattern fails.
272.119 -*}
272.120 -
272.121 -fixrec
272.122 - lzip2 :: "'a llist \<rightarrow> 'b llist \<rightarrow> ('a \<times> 'b) llist"
272.123 -where
272.124 - "lzip2\<cdot>(lCons\<cdot>x\<cdot>xs)\<cdot>(lCons\<cdot>y\<cdot>ys) = lCons\<cdot>(x, y)\<cdot>(lzip2\<cdot>xs\<cdot>ys)"
272.125 -| (unchecked) "lzip2\<cdot>xs\<cdot>ys = lNil"
272.126 -
272.127 -text {*
272.128 - Usually fixrec tries to prove all equations as theorems.
272.129 - The "unchecked" option overrides this behavior, so fixrec
272.130 - does not attempt to prove that particular equation.
272.131 -*}
272.132 -
272.133 -text {* Simp rules can be generated later using @{text fixrec_simp}. *}
272.134 -
272.135 -lemma lzip2_simps [simp]:
272.136 - "lzip2\<cdot>(lCons\<cdot>x\<cdot>xs)\<cdot>lNil = lNil"
272.137 - "lzip2\<cdot>lNil\<cdot>(lCons\<cdot>y\<cdot>ys) = lNil"
272.138 - "lzip2\<cdot>lNil\<cdot>lNil = lNil"
272.139 -by fixrec_simp+
272.140 -
272.141 -lemma lzip2_stricts [simp]:
272.142 - "lzip2\<cdot>\<bottom>\<cdot>ys = \<bottom>"
272.143 - "lzip2\<cdot>(lCons\<cdot>x\<cdot>xs)\<cdot>\<bottom> = \<bottom>"
272.144 -by fixrec_simp+
272.145 -
272.146 -
272.147 -subsection {* Mutual recursion with @{text fixrec} *}
272.148 -
272.149 -text {* Tree and forest types. *}
272.150 -
272.151 -domain 'a tree = Leaf (lazy 'a) | Branch (lazy "'a forest")
272.152 -and 'a forest = Empty | Trees (lazy "'a tree") "'a forest"
272.153 -
272.154 -text {*
272.155 - To define mutually recursive functions, give multiple type signatures
272.156 - separated by the keyword @{text "and"}.
272.157 -*}
272.158 -
272.159 -fixrec
272.160 - map_tree :: "('a \<rightarrow> 'b) \<rightarrow> ('a tree \<rightarrow> 'b tree)"
272.161 -and
272.162 - map_forest :: "('a \<rightarrow> 'b) \<rightarrow> ('a forest \<rightarrow> 'b forest)"
272.163 -where
272.164 - "map_tree\<cdot>f\<cdot>(Leaf\<cdot>x) = Leaf\<cdot>(f\<cdot>x)"
272.165 -| "map_tree\<cdot>f\<cdot>(Branch\<cdot>ts) = Branch\<cdot>(map_forest\<cdot>f\<cdot>ts)"
272.166 -| "map_forest\<cdot>f\<cdot>Empty = Empty"
272.167 -| "ts \<noteq> \<bottom> \<Longrightarrow>
272.168 - map_forest\<cdot>f\<cdot>(Trees\<cdot>t\<cdot>ts) = Trees\<cdot>(map_tree\<cdot>f\<cdot>t)\<cdot>(map_forest\<cdot>f\<cdot>ts)"
272.169 -
272.170 -lemma map_tree_strict [simp]: "map_tree\<cdot>f\<cdot>\<bottom> = \<bottom>"
272.171 -by fixrec_simp
272.172 -
272.173 -lemma map_forest_strict [simp]: "map_forest\<cdot>f\<cdot>\<bottom> = \<bottom>"
272.174 -by fixrec_simp
272.175 -
272.176 -(*
272.177 - Theorems generated:
272.178 - @{text map_tree_def} @{thm map_tree_def}
272.179 - @{text map_forest_def} @{thm map_forest_def}
272.180 - @{text map_tree.unfold} @{thm map_tree.unfold}
272.181 - @{text map_forest.unfold} @{thm map_forest.unfold}
272.182 - @{text map_tree.simps} @{thm map_tree.simps}
272.183 - @{text map_forest.simps} @{thm map_forest.simps}
272.184 - @{text map_tree_map_forest.induct} @{thm map_tree_map_forest.induct}
272.185 -*)
272.186 -
272.187 -
272.188 -subsection {* Looping simp rules *}
272.189 -
272.190 -text {*
272.191 - The defining equations of a fixrec definition are declared as simp
272.192 - rules by default. In some cases, especially for constants with no
272.193 - arguments or functions with variable patterns, the defining
272.194 - equations may cause the simplifier to loop. In these cases it will
272.195 - be necessary to use a @{text "[simp del]"} declaration.
272.196 -*}
272.197 -
272.198 -fixrec
272.199 - repeat :: "'a \<rightarrow> 'a llist"
272.200 -where
272.201 - [simp del]: "repeat\<cdot>x = lCons\<cdot>x\<cdot>(repeat\<cdot>x)"
272.202 -
272.203 -text {*
272.204 - We can derive other non-looping simp rules for @{const repeat} by
272.205 - using the @{text subst} method with the @{text repeat.simps} rule.
272.206 -*}
272.207 -
272.208 -lemma repeat_simps [simp]:
272.209 - "repeat\<cdot>x \<noteq> \<bottom>"
272.210 - "repeat\<cdot>x \<noteq> lNil"
272.211 - "repeat\<cdot>x = lCons\<cdot>y\<cdot>ys \<longleftrightarrow> x = y \<and> repeat\<cdot>x = ys"
272.212 -by (subst repeat.simps, simp)+
272.213 -
272.214 -lemma llist_case_repeat [simp]:
272.215 - "llist_case\<cdot>z\<cdot>f\<cdot>(repeat\<cdot>x) = f\<cdot>x\<cdot>(repeat\<cdot>x)"
272.216 -by (subst repeat.simps, simp)
272.217 -
272.218 -text {*
272.219 - For mutually-recursive constants, looping might only occur if all
272.220 - equations are in the simpset at the same time. In such cases it may
272.221 - only be necessary to declare @{text "[simp del]"} on one equation.
272.222 -*}
272.223 -
272.224 -fixrec
272.225 - inf_tree :: "'a tree" and inf_forest :: "'a forest"
272.226 -where
272.227 - [simp del]: "inf_tree = Branch\<cdot>inf_forest"
272.228 -| "inf_forest = Trees\<cdot>inf_tree\<cdot>(Trees\<cdot>inf_tree\<cdot>Empty)"
272.229 -
272.230 -
272.231 -subsection {* Using @{text fixrec} inside locales *}
272.232 -
272.233 -locale test =
272.234 - fixes foo :: "'a \<rightarrow> 'a"
272.235 - assumes foo_strict: "foo\<cdot>\<bottom> = \<bottom>"
272.236 -begin
272.237 -
272.238 -fixrec
272.239 - bar :: "'a u \<rightarrow> 'a"
272.240 -where
272.241 - "bar\<cdot>(up\<cdot>x) = foo\<cdot>x"
272.242 -
272.243 -lemma bar_strict: "bar\<cdot>\<bottom> = \<bottom>"
272.244 -by fixrec_simp
272.245 -
272.246 -end
272.247 -
272.248 -end
273.1 --- a/src/HOLCF/Tutorial/New_Domain.thy Sat Nov 27 14:34:54 2010 -0800
273.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
273.3 @@ -1,90 +0,0 @@
273.4 -(* Title: HOLCF/ex/New_Domain.thy
273.5 - Author: Brian Huffman
273.6 -*)
273.7 -
273.8 -header {* Definitional domain package *}
273.9 -
273.10 -theory New_Domain
273.11 -imports HOLCF
273.12 -begin
273.13 -
273.14 -text {*
273.15 - UPDATE: The definitional back-end is now the default mode of the domain
273.16 - package. This file should be merged with @{text Domain_ex.thy}.
273.17 -*}
273.18 -
273.19 -text {*
273.20 - Provided that @{text domain} is the default sort, the @{text new_domain}
273.21 - package should work with any type definition supported by the old
273.22 - domain package.
273.23 -*}
273.24 -
273.25 -domain 'a llist = LNil | LCons (lazy 'a) (lazy "'a llist")
273.26 -
273.27 -text {*
273.28 - The difference is that the new domain package is completely
273.29 - definitional, and does not generate any axioms. The following type
273.30 - and constant definitions are not produced by the old domain package.
273.31 -*}
273.32 -
273.33 -thm type_definition_llist
273.34 -thm llist_abs_def llist_rep_def
273.35 -
273.36 -text {*
273.37 - The new domain package also adds support for indirect recursion with
273.38 - user-defined datatypes. This definition of a tree datatype uses
273.39 - indirect recursion through the lazy list type constructor.
273.40 -*}
273.41 -
273.42 -domain 'a ltree = Leaf (lazy 'a) | Branch (lazy "'a ltree llist")
273.43 -
273.44 -text {*
273.45 - For indirect-recursive definitions, the domain package is not able to
273.46 - generate a high-level induction rule. (It produces a warning
273.47 - message instead.) The low-level reach lemma (now proved as a
273.48 - theorem, no longer generated as an axiom) can be used to derive
273.49 - other induction rules.
273.50 -*}
273.51 -
273.52 -thm ltree.reach
273.53 -
273.54 -text {*
273.55 - The definition of the take function uses map functions associated with
273.56 - each type constructor involved in the definition. A map function
273.57 - for the lazy list type has been generated by the new domain package.
273.58 -*}
273.59 -
273.60 -thm ltree.take_rews
273.61 -thm llist_map_def
273.62 -
273.63 -lemma ltree_induct:
273.64 - fixes P :: "'a ltree \<Rightarrow> bool"
273.65 - assumes adm: "adm P"
273.66 - assumes bot: "P \<bottom>"
273.67 - assumes Leaf: "\<And>x. P (Leaf\<cdot>x)"
273.68 - assumes Branch: "\<And>f l. \<forall>x. P (f\<cdot>x) \<Longrightarrow> P (Branch\<cdot>(llist_map\<cdot>f\<cdot>l))"
273.69 - shows "P x"
273.70 -proof -
273.71 - have "P (\<Squnion>i. ltree_take i\<cdot>x)"
273.72 - using adm
273.73 - proof (rule admD)
273.74 - fix i
273.75 - show "P (ltree_take i\<cdot>x)"
273.76 - proof (induct i arbitrary: x)
273.77 - case (0 x)
273.78 - show "P (ltree_take 0\<cdot>x)" by (simp add: bot)
273.79 - next
273.80 - case (Suc n x)
273.81 - show "P (ltree_take (Suc n)\<cdot>x)"
273.82 - apply (cases x)
273.83 - apply (simp add: bot)
273.84 - apply (simp add: Leaf)
273.85 - apply (simp add: Branch Suc)
273.86 - done
273.87 - qed
273.88 - qed (simp add: ltree.chain_take)
273.89 - thus ?thesis
273.90 - by (simp add: ltree.reach)
273.91 -qed
273.92 -
273.93 -end
274.1 --- a/src/HOLCF/Tutorial/ROOT.ML Sat Nov 27 14:34:54 2010 -0800
274.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
274.3 @@ -1,1 +0,0 @@
274.4 -use_thys ["Domain_ex", "Fixrec_ex", "New_Domain"];
275.1 --- a/src/HOLCF/Tutorial/document/root.tex Sat Nov 27 14:34:54 2010 -0800
275.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
275.3 @@ -1,29 +0,0 @@
275.4 -
275.5 -% HOLCF/document/root.tex
275.6 -
275.7 -\documentclass[11pt,a4paper]{article}
275.8 -\usepackage{graphicx,isabelle,isabellesym,latexsym}
275.9 -\usepackage[only,bigsqcap]{stmaryrd}
275.10 -\usepackage[latin1]{inputenc}
275.11 -\usepackage{pdfsetup}
275.12 -
275.13 -\urlstyle{rm}
275.14 -%\isabellestyle{it}
275.15 -\pagestyle{myheadings}
275.16 -
275.17 -\begin{document}
275.18 -
275.19 -\title{Isabelle/HOLCF Tutorial}
275.20 -\maketitle
275.21 -
275.22 -\tableofcontents
275.23 -
275.24 -%\newpage
275.25 -
275.26 -%\renewcommand{\isamarkupheader}[1]%
275.27 -%{\section{\isabellecontext: #1}\markright{THEORY~``\isabellecontext''}}
275.28 -
275.29 -\parindent 0pt\parskip 0.5ex
275.30 -\input{session}
275.31 -
275.32 -\end{document}
276.1 --- a/src/HOLCF/Universal.thy Sat Nov 27 14:34:54 2010 -0800
276.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
276.3 @@ -1,1014 +0,0 @@
276.4 -(* Title: HOLCF/Universal.thy
276.5 - Author: Brian Huffman
276.6 -*)
276.7 -
276.8 -header {* A universal bifinite domain *}
276.9 -
276.10 -theory Universal
276.11 -imports Completion Deflation Nat_Bijection
276.12 -begin
276.13 -
276.14 -subsection {* Basis for universal domain *}
276.15 -
276.16 -subsubsection {* Basis datatype *}
276.17 -
276.18 -types ubasis = nat
276.19 -
276.20 -definition
276.21 - node :: "nat \<Rightarrow> ubasis \<Rightarrow> ubasis set \<Rightarrow> ubasis"
276.22 -where
276.23 - "node i a S = Suc (prod_encode (i, prod_encode (a, set_encode S)))"
276.24 -
276.25 -lemma node_not_0 [simp]: "node i a S \<noteq> 0"
276.26 -unfolding node_def by simp
276.27 -
276.28 -lemma node_gt_0 [simp]: "0 < node i a S"
276.29 -unfolding node_def by simp
276.30 -
276.31 -lemma node_inject [simp]:
276.32 - "\<lbrakk>finite S; finite T\<rbrakk>
276.33 - \<Longrightarrow> node i a S = node j b T \<longleftrightarrow> i = j \<and> a = b \<and> S = T"
276.34 -unfolding node_def by (simp add: prod_encode_eq set_encode_eq)
276.35 -
276.36 -lemma node_gt0: "i < node i a S"
276.37 -unfolding node_def less_Suc_eq_le
276.38 -by (rule le_prod_encode_1)
276.39 -
276.40 -lemma node_gt1: "a < node i a S"
276.41 -unfolding node_def less_Suc_eq_le
276.42 -by (rule order_trans [OF le_prod_encode_1 le_prod_encode_2])
276.43 -
276.44 -lemma nat_less_power2: "n < 2^n"
276.45 -by (induct n) simp_all
276.46 -
276.47 -lemma node_gt2: "\<lbrakk>finite S; b \<in> S\<rbrakk> \<Longrightarrow> b < node i a S"
276.48 -unfolding node_def less_Suc_eq_le set_encode_def
276.49 -apply (rule order_trans [OF _ le_prod_encode_2])
276.50 -apply (rule order_trans [OF _ le_prod_encode_2])
276.51 -apply (rule order_trans [where y="setsum (op ^ 2) {b}"])
276.52 -apply (simp add: nat_less_power2 [THEN order_less_imp_le])
276.53 -apply (erule setsum_mono2, simp, simp)
276.54 -done
276.55 -
276.56 -lemma eq_prod_encode_pairI:
276.57 - "\<lbrakk>fst (prod_decode x) = a; snd (prod_decode x) = b\<rbrakk> \<Longrightarrow> x = prod_encode (a, b)"
276.58 -by (erule subst, erule subst, simp)
276.59 -
276.60 -lemma node_cases:
276.61 - assumes 1: "x = 0 \<Longrightarrow> P"
276.62 - assumes 2: "\<And>i a S. \<lbrakk>finite S; x = node i a S\<rbrakk> \<Longrightarrow> P"
276.63 - shows "P"
276.64 - apply (cases x)
276.65 - apply (erule 1)
276.66 - apply (rule 2)
276.67 - apply (rule finite_set_decode)
276.68 - apply (simp add: node_def)
276.69 - apply (rule eq_prod_encode_pairI [OF refl])
276.70 - apply (rule eq_prod_encode_pairI [OF refl refl])
276.71 -done
276.72 -
276.73 -lemma node_induct:
276.74 - assumes 1: "P 0"
276.75 - assumes 2: "\<And>i a S. \<lbrakk>P a; finite S; \<forall>b\<in>S. P b\<rbrakk> \<Longrightarrow> P (node i a S)"
276.76 - shows "P x"
276.77 - apply (induct x rule: nat_less_induct)
276.78 - apply (case_tac n rule: node_cases)
276.79 - apply (simp add: 1)
276.80 - apply (simp add: 2 node_gt1 node_gt2)
276.81 -done
276.82 -
276.83 -subsubsection {* Basis ordering *}
276.84 -
276.85 -inductive
276.86 - ubasis_le :: "nat \<Rightarrow> nat \<Rightarrow> bool"
276.87 -where
276.88 - ubasis_le_refl: "ubasis_le a a"
276.89 -| ubasis_le_trans:
276.90 - "\<lbrakk>ubasis_le a b; ubasis_le b c\<rbrakk> \<Longrightarrow> ubasis_le a c"
276.91 -| ubasis_le_lower:
276.92 - "finite S \<Longrightarrow> ubasis_le a (node i a S)"
276.93 -| ubasis_le_upper:
276.94 - "\<lbrakk>finite S; b \<in> S; ubasis_le a b\<rbrakk> \<Longrightarrow> ubasis_le (node i a S) b"
276.95 -
276.96 -lemma ubasis_le_minimal: "ubasis_le 0 x"
276.97 -apply (induct x rule: node_induct)
276.98 -apply (rule ubasis_le_refl)
276.99 -apply (erule ubasis_le_trans)
276.100 -apply (erule ubasis_le_lower)
276.101 -done
276.102 -
276.103 -interpretation udom: preorder ubasis_le
276.104 -apply default
276.105 -apply (rule ubasis_le_refl)
276.106 -apply (erule (1) ubasis_le_trans)
276.107 -done
276.108 -
276.109 -subsubsection {* Generic take function *}
276.110 -
276.111 -function
276.112 - ubasis_until :: "(ubasis \<Rightarrow> bool) \<Rightarrow> ubasis \<Rightarrow> ubasis"
276.113 -where
276.114 - "ubasis_until P 0 = 0"
276.115 -| "finite S \<Longrightarrow> ubasis_until P (node i a S) =
276.116 - (if P (node i a S) then node i a S else ubasis_until P a)"
276.117 - apply clarify
276.118 - apply (rule_tac x=b in node_cases)
276.119 - apply simp
276.120 - apply simp
276.121 - apply fast
276.122 - apply simp
276.123 - apply simp
276.124 - apply simp
276.125 -done
276.126 -
276.127 -termination ubasis_until
276.128 -apply (relation "measure snd")
276.129 -apply (rule wf_measure)
276.130 -apply (simp add: node_gt1)
276.131 -done
276.132 -
276.133 -lemma ubasis_until: "P 0 \<Longrightarrow> P (ubasis_until P x)"
276.134 -by (induct x rule: node_induct) simp_all
276.135 -
276.136 -lemma ubasis_until': "0 < ubasis_until P x \<Longrightarrow> P (ubasis_until P x)"
276.137 -by (induct x rule: node_induct) auto
276.138 -
276.139 -lemma ubasis_until_same: "P x \<Longrightarrow> ubasis_until P x = x"
276.140 -by (induct x rule: node_induct) simp_all
276.141 -
276.142 -lemma ubasis_until_idem:
276.143 - "P 0 \<Longrightarrow> ubasis_until P (ubasis_until P x) = ubasis_until P x"
276.144 -by (rule ubasis_until_same [OF ubasis_until])
276.145 -
276.146 -lemma ubasis_until_0:
276.147 - "\<forall>x. x \<noteq> 0 \<longrightarrow> \<not> P x \<Longrightarrow> ubasis_until P x = 0"
276.148 -by (induct x rule: node_induct) simp_all
276.149 -
276.150 -lemma ubasis_until_less: "ubasis_le (ubasis_until P x) x"
276.151 -apply (induct x rule: node_induct)
276.152 -apply (simp add: ubasis_le_refl)
276.153 -apply (simp add: ubasis_le_refl)
276.154 -apply (rule impI)
276.155 -apply (erule ubasis_le_trans)
276.156 -apply (erule ubasis_le_lower)
276.157 -done
276.158 -
276.159 -lemma ubasis_until_chain:
276.160 - assumes PQ: "\<And>x. P x \<Longrightarrow> Q x"
276.161 - shows "ubasis_le (ubasis_until P x) (ubasis_until Q x)"
276.162 -apply (induct x rule: node_induct)
276.163 -apply (simp add: ubasis_le_refl)
276.164 -apply (simp add: ubasis_le_refl)
276.165 -apply (simp add: PQ)
276.166 -apply clarify
276.167 -apply (rule ubasis_le_trans)
276.168 -apply (rule ubasis_until_less)
276.169 -apply (erule ubasis_le_lower)
276.170 -done
276.171 -
276.172 -lemma ubasis_until_mono:
276.173 - assumes "\<And>i a S b. \<lbrakk>finite S; P (node i a S); b \<in> S; ubasis_le a b\<rbrakk> \<Longrightarrow> P b"
276.174 - shows "ubasis_le a b \<Longrightarrow> ubasis_le (ubasis_until P a) (ubasis_until P b)"
276.175 -proof (induct set: ubasis_le)
276.176 - case (ubasis_le_refl a) show ?case by (rule ubasis_le.ubasis_le_refl)
276.177 -next
276.178 - case (ubasis_le_trans a b c) thus ?case by - (rule ubasis_le.ubasis_le_trans)
276.179 -next
276.180 - case (ubasis_le_lower S a i) thus ?case
276.181 - apply (clarsimp simp add: ubasis_le_refl)
276.182 - apply (rule ubasis_le_trans [OF ubasis_until_less])
276.183 - apply (erule ubasis_le.ubasis_le_lower)
276.184 - done
276.185 -next
276.186 - case (ubasis_le_upper S b a i) thus ?case
276.187 - apply clarsimp
276.188 - apply (subst ubasis_until_same)
276.189 - apply (erule (3) prems)
276.190 - apply (erule (2) ubasis_le.ubasis_le_upper)
276.191 - done
276.192 -qed
276.193 -
276.194 -lemma finite_range_ubasis_until:
276.195 - "finite {x. P x} \<Longrightarrow> finite (range (ubasis_until P))"
276.196 -apply (rule finite_subset [where B="insert 0 {x. P x}"])
276.197 -apply (clarsimp simp add: ubasis_until')
276.198 -apply simp
276.199 -done
276.200 -
276.201 -
276.202 -subsection {* Defining the universal domain by ideal completion *}
276.203 -
276.204 -typedef (open) udom = "{S. udom.ideal S}"
276.205 -by (fast intro: udom.ideal_principal)
276.206 -
276.207 -instantiation udom :: below
276.208 -begin
276.209 -
276.210 -definition
276.211 - "x \<sqsubseteq> y \<longleftrightarrow> Rep_udom x \<subseteq> Rep_udom y"
276.212 -
276.213 -instance ..
276.214 -end
276.215 -
276.216 -instance udom :: po
276.217 -using type_definition_udom below_udom_def
276.218 -by (rule udom.typedef_ideal_po)
276.219 -
276.220 -instance udom :: cpo
276.221 -using type_definition_udom below_udom_def
276.222 -by (rule udom.typedef_ideal_cpo)
276.223 -
276.224 -definition
276.225 - udom_principal :: "nat \<Rightarrow> udom" where
276.226 - "udom_principal t = Abs_udom {u. ubasis_le u t}"
276.227 -
276.228 -lemma ubasis_countable: "\<exists>f::ubasis \<Rightarrow> nat. inj f"
276.229 -by (rule exI, rule inj_on_id)
276.230 -
276.231 -interpretation udom:
276.232 - ideal_completion ubasis_le udom_principal Rep_udom
276.233 -using type_definition_udom below_udom_def
276.234 -using udom_principal_def ubasis_countable
276.235 -by (rule udom.typedef_ideal_completion)
276.236 -
276.237 -text {* Universal domain is pointed *}
276.238 -
276.239 -lemma udom_minimal: "udom_principal 0 \<sqsubseteq> x"
276.240 -apply (induct x rule: udom.principal_induct)
276.241 -apply (simp, simp add: ubasis_le_minimal)
276.242 -done
276.243 -
276.244 -instance udom :: pcpo
276.245 -by intro_classes (fast intro: udom_minimal)
276.246 -
276.247 -lemma inst_udom_pcpo: "\<bottom> = udom_principal 0"
276.248 -by (rule udom_minimal [THEN UU_I, symmetric])
276.249 -
276.250 -
276.251 -subsection {* Compact bases of domains *}
276.252 -
276.253 -typedef (open) 'a compact_basis = "{x::'a::pcpo. compact x}"
276.254 -by auto
276.255 -
276.256 -lemma compact_Rep_compact_basis: "compact (Rep_compact_basis a)"
276.257 -by (rule Rep_compact_basis [unfolded mem_Collect_eq])
276.258 -
276.259 -instantiation compact_basis :: (pcpo) below
276.260 -begin
276.261 -
276.262 -definition
276.263 - compact_le_def:
276.264 - "(op \<sqsubseteq>) \<equiv> (\<lambda>x y. Rep_compact_basis x \<sqsubseteq> Rep_compact_basis y)"
276.265 -
276.266 -instance ..
276.267 -end
276.268 -
276.269 -instance compact_basis :: (pcpo) po
276.270 -using type_definition_compact_basis compact_le_def
276.271 -by (rule typedef_po)
276.272 -
276.273 -definition
276.274 - approximants :: "'a \<Rightarrow> 'a compact_basis set" where
276.275 - "approximants = (\<lambda>x. {a. Rep_compact_basis a \<sqsubseteq> x})"
276.276 -
276.277 -definition
276.278 - compact_bot :: "'a::pcpo compact_basis" where
276.279 - "compact_bot = Abs_compact_basis \<bottom>"
276.280 -
276.281 -lemma Rep_compact_bot [simp]: "Rep_compact_basis compact_bot = \<bottom>"
276.282 -unfolding compact_bot_def by (simp add: Abs_compact_basis_inverse)
276.283 -
276.284 -lemma compact_bot_minimal [simp]: "compact_bot \<sqsubseteq> a"
276.285 -unfolding compact_le_def Rep_compact_bot by simp
276.286 -
276.287 -
276.288 -subsection {* Universality of \emph{udom} *}
276.289 -
276.290 -text {* We use a locale to parameterize the construction over a chain
276.291 -of approx functions on the type to be embedded. *}
276.292 -
276.293 -locale approx_chain =
276.294 - fixes approx :: "nat \<Rightarrow> 'a::pcpo \<rightarrow> 'a"
276.295 - assumes chain_approx [simp]: "chain (\<lambda>i. approx i)"
276.296 - assumes lub_approx [simp]: "(\<Squnion>i. approx i) = ID"
276.297 - assumes finite_deflation_approx: "\<And>i. finite_deflation (approx i)"
276.298 -begin
276.299 -
276.300 -subsubsection {* Choosing a maximal element from a finite set *}
276.301 -
276.302 -lemma finite_has_maximal:
276.303 - fixes A :: "'a compact_basis set"
276.304 - shows "\<lbrakk>finite A; A \<noteq> {}\<rbrakk> \<Longrightarrow> \<exists>x\<in>A. \<forall>y\<in>A. x \<sqsubseteq> y \<longrightarrow> x = y"
276.305 -proof (induct rule: finite_ne_induct)
276.306 - case (singleton x)
276.307 - show ?case by simp
276.308 -next
276.309 - case (insert a A)
276.310 - from `\<exists>x\<in>A. \<forall>y\<in>A. x \<sqsubseteq> y \<longrightarrow> x = y`
276.311 - obtain x where x: "x \<in> A"
276.312 - and x_eq: "\<And>y. \<lbrakk>y \<in> A; x \<sqsubseteq> y\<rbrakk> \<Longrightarrow> x = y" by fast
276.313 - show ?case
276.314 - proof (intro bexI ballI impI)
276.315 - fix y
276.316 - assume "y \<in> insert a A" and "(if x \<sqsubseteq> a then a else x) \<sqsubseteq> y"
276.317 - thus "(if x \<sqsubseteq> a then a else x) = y"
276.318 - apply auto
276.319 - apply (frule (1) below_trans)
276.320 - apply (frule (1) x_eq)
276.321 - apply (rule below_antisym, assumption)
276.322 - apply simp
276.323 - apply (erule (1) x_eq)
276.324 - done
276.325 - next
276.326 - show "(if x \<sqsubseteq> a then a else x) \<in> insert a A"
276.327 - by (simp add: x)
276.328 - qed
276.329 -qed
276.330 -
276.331 -definition
276.332 - choose :: "'a compact_basis set \<Rightarrow> 'a compact_basis"
276.333 -where
276.334 - "choose A = (SOME x. x \<in> {x\<in>A. \<forall>y\<in>A. x \<sqsubseteq> y \<longrightarrow> x = y})"
276.335 -
276.336 -lemma choose_lemma:
276.337 - "\<lbrakk>finite A; A \<noteq> {}\<rbrakk> \<Longrightarrow> choose A \<in> {x\<in>A. \<forall>y\<in>A. x \<sqsubseteq> y \<longrightarrow> x = y}"
276.338 -unfolding choose_def
276.339 -apply (rule someI_ex)
276.340 -apply (frule (1) finite_has_maximal, fast)
276.341 -done
276.342 -
276.343 -lemma maximal_choose:
276.344 - "\<lbrakk>finite A; y \<in> A; choose A \<sqsubseteq> y\<rbrakk> \<Longrightarrow> choose A = y"
276.345 -apply (cases "A = {}", simp)
276.346 -apply (frule (1) choose_lemma, simp)
276.347 -done
276.348 -
276.349 -lemma choose_in: "\<lbrakk>finite A; A \<noteq> {}\<rbrakk> \<Longrightarrow> choose A \<in> A"
276.350 -by (frule (1) choose_lemma, simp)
276.351 -
276.352 -function
276.353 - choose_pos :: "'a compact_basis set \<Rightarrow> 'a compact_basis \<Rightarrow> nat"
276.354 -where
276.355 - "choose_pos A x =
276.356 - (if finite A \<and> x \<in> A \<and> x \<noteq> choose A
276.357 - then Suc (choose_pos (A - {choose A}) x) else 0)"
276.358 -by auto
276.359 -
276.360 -termination choose_pos
276.361 -apply (relation "measure (card \<circ> fst)", simp)
276.362 -apply clarsimp
276.363 -apply (rule card_Diff1_less)
276.364 -apply assumption
276.365 -apply (erule choose_in)
276.366 -apply clarsimp
276.367 -done
276.368 -
276.369 -declare choose_pos.simps [simp del]
276.370 -
276.371 -lemma choose_pos_choose: "finite A \<Longrightarrow> choose_pos A (choose A) = 0"
276.372 -by (simp add: choose_pos.simps)
276.373 -
276.374 -lemma inj_on_choose_pos [OF refl]:
276.375 - "\<lbrakk>card A = n; finite A\<rbrakk> \<Longrightarrow> inj_on (choose_pos A) A"
276.376 - apply (induct n arbitrary: A)
276.377 - apply simp
276.378 - apply (case_tac "A = {}", simp)
276.379 - apply (frule (1) choose_in)
276.380 - apply (rule inj_onI)
276.381 - apply (drule_tac x="A - {choose A}" in meta_spec, simp)
276.382 - apply (simp add: choose_pos.simps)
276.383 - apply (simp split: split_if_asm)
276.384 - apply (erule (1) inj_onD, simp, simp)
276.385 -done
276.386 -
276.387 -lemma choose_pos_bounded [OF refl]:
276.388 - "\<lbrakk>card A = n; finite A; x \<in> A\<rbrakk> \<Longrightarrow> choose_pos A x < n"
276.389 -apply (induct n arbitrary: A)
276.390 -apply simp
276.391 - apply (case_tac "A = {}", simp)
276.392 - apply (frule (1) choose_in)
276.393 -apply (subst choose_pos.simps)
276.394 -apply simp
276.395 -done
276.396 -
276.397 -lemma choose_pos_lessD:
276.398 - "\<lbrakk>choose_pos A x < choose_pos A y; finite A; x \<in> A; y \<in> A\<rbrakk> \<Longrightarrow> \<not> x \<sqsubseteq> y"
276.399 - apply (induct A x arbitrary: y rule: choose_pos.induct)
276.400 - apply simp
276.401 - apply (case_tac "x = choose A")
276.402 - apply simp
276.403 - apply (rule notI)
276.404 - apply (frule (2) maximal_choose)
276.405 - apply simp
276.406 - apply (case_tac "y = choose A")
276.407 - apply (simp add: choose_pos_choose)
276.408 - apply (drule_tac x=y in meta_spec)
276.409 - apply simp
276.410 - apply (erule meta_mp)
276.411 - apply (simp add: choose_pos.simps)
276.412 -done
276.413 -
276.414 -subsubsection {* Properties of approx function *}
276.415 -
276.416 -lemma deflation_approx: "deflation (approx i)"
276.417 -using finite_deflation_approx by (rule finite_deflation_imp_deflation)
276.418 -
276.419 -lemma approx_idem: "approx i\<cdot>(approx i\<cdot>x) = approx i\<cdot>x"
276.420 -using deflation_approx by (rule deflation.idem)
276.421 -
276.422 -lemma approx_below: "approx i\<cdot>x \<sqsubseteq> x"
276.423 -using deflation_approx by (rule deflation.below)
276.424 -
276.425 -lemma finite_range_approx: "finite (range (\<lambda>x. approx i\<cdot>x))"
276.426 -apply (rule finite_deflation.finite_range)
276.427 -apply (rule finite_deflation_approx)
276.428 -done
276.429 -
276.430 -lemma compact_approx: "compact (approx n\<cdot>x)"
276.431 -apply (rule finite_deflation.compact)
276.432 -apply (rule finite_deflation_approx)
276.433 -done
276.434 -
276.435 -lemma compact_eq_approx: "compact x \<Longrightarrow> \<exists>i. approx i\<cdot>x = x"
276.436 -by (rule admD2, simp_all)
276.437 -
276.438 -subsubsection {* Compact basis take function *}
276.439 -
276.440 -primrec
276.441 - cb_take :: "nat \<Rightarrow> 'a compact_basis \<Rightarrow> 'a compact_basis" where
276.442 - "cb_take 0 = (\<lambda>x. compact_bot)"
276.443 -| "cb_take (Suc n) = (\<lambda>a. Abs_compact_basis (approx n\<cdot>(Rep_compact_basis a)))"
276.444 -
276.445 -declare cb_take.simps [simp del]
276.446 -
276.447 -lemma cb_take_zero [simp]: "cb_take 0 a = compact_bot"
276.448 -by (simp only: cb_take.simps)
276.449 -
276.450 -lemma Rep_cb_take:
276.451 - "Rep_compact_basis (cb_take (Suc n) a) = approx n\<cdot>(Rep_compact_basis a)"
276.452 -by (simp add: Abs_compact_basis_inverse cb_take.simps(2) compact_approx)
276.453 -
276.454 -lemmas approx_Rep_compact_basis = Rep_cb_take [symmetric]
276.455 -
276.456 -lemma cb_take_covers: "\<exists>n. cb_take n x = x"
276.457 -apply (subgoal_tac "\<exists>n. cb_take (Suc n) x = x", fast)
276.458 -apply (simp add: Rep_compact_basis_inject [symmetric])
276.459 -apply (simp add: Rep_cb_take)
276.460 -apply (rule compact_eq_approx)
276.461 -apply (rule compact_Rep_compact_basis)
276.462 -done
276.463 -
276.464 -lemma cb_take_less: "cb_take n x \<sqsubseteq> x"
276.465 -unfolding compact_le_def
276.466 -by (cases n, simp, simp add: Rep_cb_take approx_below)
276.467 -
276.468 -lemma cb_take_idem: "cb_take n (cb_take n x) = cb_take n x"
276.469 -unfolding Rep_compact_basis_inject [symmetric]
276.470 -by (cases n, simp, simp add: Rep_cb_take approx_idem)
276.471 -
276.472 -lemma cb_take_mono: "x \<sqsubseteq> y \<Longrightarrow> cb_take n x \<sqsubseteq> cb_take n y"
276.473 -unfolding compact_le_def
276.474 -by (cases n, simp, simp add: Rep_cb_take monofun_cfun_arg)
276.475 -
276.476 -lemma cb_take_chain_le: "m \<le> n \<Longrightarrow> cb_take m x \<sqsubseteq> cb_take n x"
276.477 -unfolding compact_le_def
276.478 -apply (cases m, simp, cases n, simp)
276.479 -apply (simp add: Rep_cb_take, rule chain_mono, simp, simp)
276.480 -done
276.481 -
276.482 -lemma finite_range_cb_take: "finite (range (cb_take n))"
276.483 -apply (cases n)
276.484 -apply (subgoal_tac "range (cb_take 0) = {compact_bot}", simp, force)
276.485 -apply (rule finite_imageD [where f="Rep_compact_basis"])
276.486 -apply (rule finite_subset [where B="range (\<lambda>x. approx (n - 1)\<cdot>x)"])
276.487 -apply (clarsimp simp add: Rep_cb_take)
276.488 -apply (rule finite_range_approx)
276.489 -apply (rule inj_onI, simp add: Rep_compact_basis_inject)
276.490 -done
276.491 -
276.492 -subsubsection {* Rank of basis elements *}
276.493 -
276.494 -definition
276.495 - rank :: "'a compact_basis \<Rightarrow> nat"
276.496 -where
276.497 - "rank x = (LEAST n. cb_take n x = x)"
276.498 -
276.499 -lemma compact_approx_rank: "cb_take (rank x) x = x"
276.500 -unfolding rank_def
276.501 -apply (rule LeastI_ex)
276.502 -apply (rule cb_take_covers)
276.503 -done
276.504 -
276.505 -lemma rank_leD: "rank x \<le> n \<Longrightarrow> cb_take n x = x"
276.506 -apply (rule below_antisym [OF cb_take_less])
276.507 -apply (subst compact_approx_rank [symmetric])
276.508 -apply (erule cb_take_chain_le)
276.509 -done
276.510 -
276.511 -lemma rank_leI: "cb_take n x = x \<Longrightarrow> rank x \<le> n"
276.512 -unfolding rank_def by (rule Least_le)
276.513 -
276.514 -lemma rank_le_iff: "rank x \<le> n \<longleftrightarrow> cb_take n x = x"
276.515 -by (rule iffI [OF rank_leD rank_leI])
276.516 -
276.517 -lemma rank_compact_bot [simp]: "rank compact_bot = 0"
276.518 -using rank_leI [of 0 compact_bot] by simp
276.519 -
276.520 -lemma rank_eq_0_iff [simp]: "rank x = 0 \<longleftrightarrow> x = compact_bot"
276.521 -using rank_le_iff [of x 0] by auto
276.522 -
276.523 -definition
276.524 - rank_le :: "'a compact_basis \<Rightarrow> 'a compact_basis set"
276.525 -where
276.526 - "rank_le x = {y. rank y \<le> rank x}"
276.527 -
276.528 -definition
276.529 - rank_lt :: "'a compact_basis \<Rightarrow> 'a compact_basis set"
276.530 -where
276.531 - "rank_lt x = {y. rank y < rank x}"
276.532 -
276.533 -definition
276.534 - rank_eq :: "'a compact_basis \<Rightarrow> 'a compact_basis set"
276.535 -where
276.536 - "rank_eq x = {y. rank y = rank x}"
276.537 -
276.538 -lemma rank_eq_cong: "rank x = rank y \<Longrightarrow> rank_eq x = rank_eq y"
276.539 -unfolding rank_eq_def by simp
276.540 -
276.541 -lemma rank_lt_cong: "rank x = rank y \<Longrightarrow> rank_lt x = rank_lt y"
276.542 -unfolding rank_lt_def by simp
276.543 -
276.544 -lemma rank_eq_subset: "rank_eq x \<subseteq> rank_le x"
276.545 -unfolding rank_eq_def rank_le_def by auto
276.546 -
276.547 -lemma rank_lt_subset: "rank_lt x \<subseteq> rank_le x"
276.548 -unfolding rank_lt_def rank_le_def by auto
276.549 -
276.550 -lemma finite_rank_le: "finite (rank_le x)"
276.551 -unfolding rank_le_def
276.552 -apply (rule finite_subset [where B="range (cb_take (rank x))"])
276.553 -apply clarify
276.554 -apply (rule range_eqI)
276.555 -apply (erule rank_leD [symmetric])
276.556 -apply (rule finite_range_cb_take)
276.557 -done
276.558 -
276.559 -lemma finite_rank_eq: "finite (rank_eq x)"
276.560 -by (rule finite_subset [OF rank_eq_subset finite_rank_le])
276.561 -
276.562 -lemma finite_rank_lt: "finite (rank_lt x)"
276.563 -by (rule finite_subset [OF rank_lt_subset finite_rank_le])
276.564 -
276.565 -lemma rank_lt_Int_rank_eq: "rank_lt x \<inter> rank_eq x = {}"
276.566 -unfolding rank_lt_def rank_eq_def rank_le_def by auto
276.567 -
276.568 -lemma rank_lt_Un_rank_eq: "rank_lt x \<union> rank_eq x = rank_le x"
276.569 -unfolding rank_lt_def rank_eq_def rank_le_def by auto
276.570 -
276.571 -subsubsection {* Sequencing basis elements *}
276.572 -
276.573 -definition
276.574 - place :: "'a compact_basis \<Rightarrow> nat"
276.575 -where
276.576 - "place x = card (rank_lt x) + choose_pos (rank_eq x) x"
276.577 -
276.578 -lemma place_bounded: "place x < card (rank_le x)"
276.579 -unfolding place_def
276.580 - apply (rule ord_less_eq_trans)
276.581 - apply (rule add_strict_left_mono)
276.582 - apply (rule choose_pos_bounded)
276.583 - apply (rule finite_rank_eq)
276.584 - apply (simp add: rank_eq_def)
276.585 - apply (subst card_Un_disjoint [symmetric])
276.586 - apply (rule finite_rank_lt)
276.587 - apply (rule finite_rank_eq)
276.588 - apply (rule rank_lt_Int_rank_eq)
276.589 - apply (simp add: rank_lt_Un_rank_eq)
276.590 -done
276.591 -
276.592 -lemma place_ge: "card (rank_lt x) \<le> place x"
276.593 -unfolding place_def by simp
276.594 -
276.595 -lemma place_rank_mono:
276.596 - fixes x y :: "'a compact_basis"
276.597 - shows "rank x < rank y \<Longrightarrow> place x < place y"
276.598 -apply (rule less_le_trans [OF place_bounded])
276.599 -apply (rule order_trans [OF _ place_ge])
276.600 -apply (rule card_mono)
276.601 -apply (rule finite_rank_lt)
276.602 -apply (simp add: rank_le_def rank_lt_def subset_eq)
276.603 -done
276.604 -
276.605 -lemma place_eqD: "place x = place y \<Longrightarrow> x = y"
276.606 - apply (rule linorder_cases [where x="rank x" and y="rank y"])
276.607 - apply (drule place_rank_mono, simp)
276.608 - apply (simp add: place_def)
276.609 - apply (rule inj_on_choose_pos [where A="rank_eq x", THEN inj_onD])
276.610 - apply (rule finite_rank_eq)
276.611 - apply (simp cong: rank_lt_cong rank_eq_cong)
276.612 - apply (simp add: rank_eq_def)
276.613 - apply (simp add: rank_eq_def)
276.614 - apply (drule place_rank_mono, simp)
276.615 -done
276.616 -
276.617 -lemma inj_place: "inj place"
276.618 -by (rule inj_onI, erule place_eqD)
276.619 -
276.620 -subsubsection {* Embedding and projection on basis elements *}
276.621 -
276.622 -definition
276.623 - sub :: "'a compact_basis \<Rightarrow> 'a compact_basis"
276.624 -where
276.625 - "sub x = (case rank x of 0 \<Rightarrow> compact_bot | Suc k \<Rightarrow> cb_take k x)"
276.626 -
276.627 -lemma rank_sub_less: "x \<noteq> compact_bot \<Longrightarrow> rank (sub x) < rank x"
276.628 -unfolding sub_def
276.629 -apply (cases "rank x", simp)
276.630 -apply (simp add: less_Suc_eq_le)
276.631 -apply (rule rank_leI)
276.632 -apply (rule cb_take_idem)
276.633 -done
276.634 -
276.635 -lemma place_sub_less: "x \<noteq> compact_bot \<Longrightarrow> place (sub x) < place x"
276.636 -apply (rule place_rank_mono)
276.637 -apply (erule rank_sub_less)
276.638 -done
276.639 -
276.640 -lemma sub_below: "sub x \<sqsubseteq> x"
276.641 -unfolding sub_def by (cases "rank x", simp_all add: cb_take_less)
276.642 -
276.643 -lemma rank_less_imp_below_sub: "\<lbrakk>x \<sqsubseteq> y; rank x < rank y\<rbrakk> \<Longrightarrow> x \<sqsubseteq> sub y"
276.644 -unfolding sub_def
276.645 -apply (cases "rank y", simp)
276.646 -apply (simp add: less_Suc_eq_le)
276.647 -apply (subgoal_tac "cb_take nat x \<sqsubseteq> cb_take nat y")
276.648 -apply (simp add: rank_leD)
276.649 -apply (erule cb_take_mono)
276.650 -done
276.651 -
276.652 -function
276.653 - basis_emb :: "'a compact_basis \<Rightarrow> ubasis"
276.654 -where
276.655 - "basis_emb x = (if x = compact_bot then 0 else
276.656 - node (place x) (basis_emb (sub x))
276.657 - (basis_emb ` {y. place y < place x \<and> x \<sqsubseteq> y}))"
276.658 -by auto
276.659 -
276.660 -termination basis_emb
276.661 -apply (relation "measure place", simp)
276.662 -apply (simp add: place_sub_less)
276.663 -apply simp
276.664 -done
276.665 -
276.666 -declare basis_emb.simps [simp del]
276.667 -
276.668 -lemma basis_emb_compact_bot [simp]: "basis_emb compact_bot = 0"
276.669 -by (simp add: basis_emb.simps)
276.670 -
276.671 -lemma fin1: "finite {y. place y < place x \<and> x \<sqsubseteq> y}"
276.672 -apply (subst Collect_conj_eq)
276.673 -apply (rule finite_Int)
276.674 -apply (rule disjI1)
276.675 -apply (subgoal_tac "finite (place -` {n. n < place x})", simp)
276.676 -apply (rule finite_vimageI [OF _ inj_place])
276.677 -apply (simp add: lessThan_def [symmetric])
276.678 -done
276.679 -
276.680 -lemma fin2: "finite (basis_emb ` {y. place y < place x \<and> x \<sqsubseteq> y})"
276.681 -by (rule finite_imageI [OF fin1])
276.682 -
276.683 -lemma rank_place_mono:
276.684 - "\<lbrakk>place x < place y; x \<sqsubseteq> y\<rbrakk> \<Longrightarrow> rank x < rank y"
276.685 -apply (rule linorder_cases, assumption)
276.686 -apply (simp add: place_def cong: rank_lt_cong rank_eq_cong)
276.687 -apply (drule choose_pos_lessD)
276.688 -apply (rule finite_rank_eq)
276.689 -apply (simp add: rank_eq_def)
276.690 -apply (simp add: rank_eq_def)
276.691 -apply simp
276.692 -apply (drule place_rank_mono, simp)
276.693 -done
276.694 -
276.695 -lemma basis_emb_mono:
276.696 - "x \<sqsubseteq> y \<Longrightarrow> ubasis_le (basis_emb x) (basis_emb y)"
276.697 -proof (induct "max (place x) (place y)" arbitrary: x y rule: less_induct)
276.698 - case less
276.699 - show ?case proof (rule linorder_cases)
276.700 - assume "place x < place y"
276.701 - then have "rank x < rank y"
276.702 - using `x \<sqsubseteq> y` by (rule rank_place_mono)
276.703 - with `place x < place y` show ?case
276.704 - apply (case_tac "y = compact_bot", simp)
276.705 - apply (simp add: basis_emb.simps [of y])
276.706 - apply (rule ubasis_le_trans [OF _ ubasis_le_lower [OF fin2]])
276.707 - apply (rule less)
276.708 - apply (simp add: less_max_iff_disj)
276.709 - apply (erule place_sub_less)
276.710 - apply (erule rank_less_imp_below_sub [OF `x \<sqsubseteq> y`])
276.711 - done
276.712 - next
276.713 - assume "place x = place y"
276.714 - hence "x = y" by (rule place_eqD)
276.715 - thus ?case by (simp add: ubasis_le_refl)
276.716 - next
276.717 - assume "place x > place y"
276.718 - with `x \<sqsubseteq> y` show ?case
276.719 - apply (case_tac "x = compact_bot", simp add: ubasis_le_minimal)
276.720 - apply (simp add: basis_emb.simps [of x])
276.721 - apply (rule ubasis_le_upper [OF fin2], simp)
276.722 - apply (rule less)
276.723 - apply (simp add: less_max_iff_disj)
276.724 - apply (erule place_sub_less)
276.725 - apply (erule rev_below_trans)
276.726 - apply (rule sub_below)
276.727 - done
276.728 - qed
276.729 -qed
276.730 -
276.731 -lemma inj_basis_emb: "inj basis_emb"
276.732 - apply (rule inj_onI)
276.733 - apply (case_tac "x = compact_bot")
276.734 - apply (case_tac [!] "y = compact_bot")
276.735 - apply simp
276.736 - apply (simp add: basis_emb.simps)
276.737 - apply (simp add: basis_emb.simps)
276.738 - apply (simp add: basis_emb.simps)
276.739 - apply (simp add: fin2 inj_eq [OF inj_place])
276.740 -done
276.741 -
276.742 -definition
276.743 - basis_prj :: "ubasis \<Rightarrow> 'a compact_basis"
276.744 -where
276.745 - "basis_prj x = inv basis_emb
276.746 - (ubasis_until (\<lambda>x. x \<in> range (basis_emb :: 'a compact_basis \<Rightarrow> ubasis)) x)"
276.747 -
276.748 -lemma basis_prj_basis_emb: "\<And>x. basis_prj (basis_emb x) = x"
276.749 -unfolding basis_prj_def
276.750 - apply (subst ubasis_until_same)
276.751 - apply (rule rangeI)
276.752 - apply (rule inv_f_f)
276.753 - apply (rule inj_basis_emb)
276.754 -done
276.755 -
276.756 -lemma basis_prj_node:
276.757 - "\<lbrakk>finite S; node i a S \<notin> range (basis_emb :: 'a compact_basis \<Rightarrow> nat)\<rbrakk>
276.758 - \<Longrightarrow> basis_prj (node i a S) = (basis_prj a :: 'a compact_basis)"
276.759 -unfolding basis_prj_def by simp
276.760 -
276.761 -lemma basis_prj_0: "basis_prj 0 = compact_bot"
276.762 -apply (subst basis_emb_compact_bot [symmetric])
276.763 -apply (rule basis_prj_basis_emb)
276.764 -done
276.765 -
276.766 -lemma node_eq_basis_emb_iff:
276.767 - "finite S \<Longrightarrow> node i a S = basis_emb x \<longleftrightarrow>
276.768 - x \<noteq> compact_bot \<and> i = place x \<and> a = basis_emb (sub x) \<and>
276.769 - S = basis_emb ` {y. place y < place x \<and> x \<sqsubseteq> y}"
276.770 -apply (cases "x = compact_bot", simp)
276.771 -apply (simp add: basis_emb.simps [of x])
276.772 -apply (simp add: fin2)
276.773 -done
276.774 -
276.775 -lemma basis_prj_mono: "ubasis_le a b \<Longrightarrow> basis_prj a \<sqsubseteq> basis_prj b"
276.776 -proof (induct a b rule: ubasis_le.induct)
276.777 - case (ubasis_le_refl a) show ?case by (rule below_refl)
276.778 -next
276.779 - case (ubasis_le_trans a b c) thus ?case by - (rule below_trans)
276.780 -next
276.781 - case (ubasis_le_lower S a i) thus ?case
276.782 - apply (cases "node i a S \<in> range (basis_emb :: 'a compact_basis \<Rightarrow> nat)")
276.783 - apply (erule rangeE, rename_tac x)
276.784 - apply (simp add: basis_prj_basis_emb)
276.785 - apply (simp add: node_eq_basis_emb_iff)
276.786 - apply (simp add: basis_prj_basis_emb)
276.787 - apply (rule sub_below)
276.788 - apply (simp add: basis_prj_node)
276.789 - done
276.790 -next
276.791 - case (ubasis_le_upper S b a i) thus ?case
276.792 - apply (cases "node i a S \<in> range (basis_emb :: 'a compact_basis \<Rightarrow> nat)")
276.793 - apply (erule rangeE, rename_tac x)
276.794 - apply (simp add: basis_prj_basis_emb)
276.795 - apply (clarsimp simp add: node_eq_basis_emb_iff)
276.796 - apply (simp add: basis_prj_basis_emb)
276.797 - apply (simp add: basis_prj_node)
276.798 - done
276.799 -qed
276.800 -
276.801 -lemma basis_emb_prj_less: "ubasis_le (basis_emb (basis_prj x)) x"
276.802 -unfolding basis_prj_def
276.803 - apply (subst f_inv_into_f [where f=basis_emb])
276.804 - apply (rule ubasis_until)
276.805 - apply (rule range_eqI [where x=compact_bot])
276.806 - apply simp
276.807 - apply (rule ubasis_until_less)
276.808 -done
276.809 -
276.810 -end
276.811 -
276.812 -sublocale approx_chain \<subseteq> compact_basis!:
276.813 - ideal_completion below Rep_compact_basis
276.814 - "approximants :: 'a \<Rightarrow> 'a compact_basis set"
276.815 -proof
276.816 - fix w :: "'a"
276.817 - show "below.ideal (approximants w)"
276.818 - proof (rule below.idealI)
276.819 - show "\<exists>x. x \<in> approximants w"
276.820 - unfolding approximants_def
276.821 - apply (rule_tac x="Abs_compact_basis (approx 0\<cdot>w)" in exI)
276.822 - apply (simp add: Abs_compact_basis_inverse approx_below compact_approx)
276.823 - done
276.824 - next
276.825 - fix x y :: "'a compact_basis"
276.826 - assume "x \<in> approximants w" "y \<in> approximants w"
276.827 - thus "\<exists>z \<in> approximants w. x \<sqsubseteq> z \<and> y \<sqsubseteq> z"
276.828 - unfolding approximants_def
276.829 - apply simp
276.830 - apply (cut_tac a=x in compact_Rep_compact_basis)
276.831 - apply (cut_tac a=y in compact_Rep_compact_basis)
276.832 - apply (drule compact_eq_approx)
276.833 - apply (drule compact_eq_approx)
276.834 - apply (clarify, rename_tac i j)
276.835 - apply (rule_tac x="Abs_compact_basis (approx (max i j)\<cdot>w)" in exI)
276.836 - apply (simp add: compact_le_def)
276.837 - apply (simp add: Abs_compact_basis_inverse approx_below compact_approx)
276.838 - apply (erule subst, erule subst)
276.839 - apply (simp add: monofun_cfun chain_mono [OF chain_approx])
276.840 - done
276.841 - next
276.842 - fix x y :: "'a compact_basis"
276.843 - assume "x \<sqsubseteq> y" "y \<in> approximants w" thus "x \<in> approximants w"
276.844 - unfolding approximants_def
276.845 - apply simp
276.846 - apply (simp add: compact_le_def)
276.847 - apply (erule (1) below_trans)
276.848 - done
276.849 - qed
276.850 -next
276.851 - fix Y :: "nat \<Rightarrow> 'a"
276.852 - assume Y: "chain Y"
276.853 - show "approximants (\<Squnion>i. Y i) = (\<Union>i. approximants (Y i))"
276.854 - unfolding approximants_def
276.855 - apply safe
276.856 - apply (simp add: compactD2 [OF compact_Rep_compact_basis Y])
276.857 - apply (erule below_lub [OF Y])
276.858 - done
276.859 -next
276.860 - fix a :: "'a compact_basis"
276.861 - show "approximants (Rep_compact_basis a) = {b. b \<sqsubseteq> a}"
276.862 - unfolding approximants_def compact_le_def ..
276.863 -next
276.864 - fix x y :: "'a"
276.865 - assume "approximants x \<subseteq> approximants y" thus "x \<sqsubseteq> y"
276.866 - apply (subgoal_tac "(\<Squnion>i. approx i\<cdot>x) \<sqsubseteq> y")
276.867 - apply (simp add: lub_distribs)
276.868 - apply (rule admD, simp, simp)
276.869 - apply (drule_tac c="Abs_compact_basis (approx i\<cdot>x)" in subsetD)
276.870 - apply (simp add: approximants_def Abs_compact_basis_inverse
276.871 - approx_below compact_approx)
276.872 - apply (simp add: approximants_def Abs_compact_basis_inverse compact_approx)
276.873 - done
276.874 -next
276.875 - show "\<exists>f::'a compact_basis \<Rightarrow> nat. inj f"
276.876 - by (rule exI, rule inj_place)
276.877 -qed
276.878 -
276.879 -subsubsection {* EP-pair from any bifinite domain into \emph{udom} *}
276.880 -
276.881 -context approx_chain begin
276.882 -
276.883 -definition
276.884 - udom_emb :: "'a \<rightarrow> udom"
276.885 -where
276.886 - "udom_emb = compact_basis.basis_fun (\<lambda>x. udom_principal (basis_emb x))"
276.887 -
276.888 -definition
276.889 - udom_prj :: "udom \<rightarrow> 'a"
276.890 -where
276.891 - "udom_prj = udom.basis_fun (\<lambda>x. Rep_compact_basis (basis_prj x))"
276.892 -
276.893 -lemma udom_emb_principal:
276.894 - "udom_emb\<cdot>(Rep_compact_basis x) = udom_principal (basis_emb x)"
276.895 -unfolding udom_emb_def
276.896 -apply (rule compact_basis.basis_fun_principal)
276.897 -apply (rule udom.principal_mono)
276.898 -apply (erule basis_emb_mono)
276.899 -done
276.900 -
276.901 -lemma udom_prj_principal:
276.902 - "udom_prj\<cdot>(udom_principal x) = Rep_compact_basis (basis_prj x)"
276.903 -unfolding udom_prj_def
276.904 -apply (rule udom.basis_fun_principal)
276.905 -apply (rule compact_basis.principal_mono)
276.906 -apply (erule basis_prj_mono)
276.907 -done
276.908 -
276.909 -lemma ep_pair_udom: "ep_pair udom_emb udom_prj"
276.910 - apply default
276.911 - apply (rule compact_basis.principal_induct, simp)
276.912 - apply (simp add: udom_emb_principal udom_prj_principal)
276.913 - apply (simp add: basis_prj_basis_emb)
276.914 - apply (rule udom.principal_induct, simp)
276.915 - apply (simp add: udom_emb_principal udom_prj_principal)
276.916 - apply (rule basis_emb_prj_less)
276.917 -done
276.918 -
276.919 -end
276.920 -
276.921 -abbreviation "udom_emb \<equiv> approx_chain.udom_emb"
276.922 -abbreviation "udom_prj \<equiv> approx_chain.udom_prj"
276.923 -
276.924 -lemmas ep_pair_udom = approx_chain.ep_pair_udom
276.925 -
276.926 -subsection {* Chain of approx functions for type \emph{udom} *}
276.927 -
276.928 -definition
276.929 - udom_approx :: "nat \<Rightarrow> udom \<rightarrow> udom"
276.930 -where
276.931 - "udom_approx i =
276.932 - udom.basis_fun (\<lambda>x. udom_principal (ubasis_until (\<lambda>y. y \<le> i) x))"
276.933 -
276.934 -lemma udom_approx_mono:
276.935 - "ubasis_le a b \<Longrightarrow>
276.936 - udom_principal (ubasis_until (\<lambda>y. y \<le> i) a) \<sqsubseteq>
276.937 - udom_principal (ubasis_until (\<lambda>y. y \<le> i) b)"
276.938 -apply (rule udom.principal_mono)
276.939 -apply (rule ubasis_until_mono)
276.940 -apply (frule (2) order_less_le_trans [OF node_gt2])
276.941 -apply (erule order_less_imp_le)
276.942 -apply assumption
276.943 -done
276.944 -
276.945 -lemma adm_mem_finite: "\<lbrakk>cont f; finite S\<rbrakk> \<Longrightarrow> adm (\<lambda>x. f x \<in> S)"
276.946 -by (erule adm_subst, induct set: finite, simp_all)
276.947 -
276.948 -lemma udom_approx_principal:
276.949 - "udom_approx i\<cdot>(udom_principal x) =
276.950 - udom_principal (ubasis_until (\<lambda>y. y \<le> i) x)"
276.951 -unfolding udom_approx_def
276.952 -apply (rule udom.basis_fun_principal)
276.953 -apply (erule udom_approx_mono)
276.954 -done
276.955 -
276.956 -lemma finite_deflation_udom_approx: "finite_deflation (udom_approx i)"
276.957 -proof
276.958 - fix x show "udom_approx i\<cdot>(udom_approx i\<cdot>x) = udom_approx i\<cdot>x"
276.959 - by (induct x rule: udom.principal_induct, simp)
276.960 - (simp add: udom_approx_principal ubasis_until_idem)
276.961 -next
276.962 - fix x show "udom_approx i\<cdot>x \<sqsubseteq> x"
276.963 - by (induct x rule: udom.principal_induct, simp)
276.964 - (simp add: udom_approx_principal ubasis_until_less)
276.965 -next
276.966 - have *: "finite (range (\<lambda>x. udom_principal (ubasis_until (\<lambda>y. y \<le> i) x)))"
276.967 - apply (subst range_composition [where f=udom_principal])
276.968 - apply (simp add: finite_range_ubasis_until)
276.969 - done
276.970 - show "finite {x. udom_approx i\<cdot>x = x}"
276.971 - apply (rule finite_range_imp_finite_fixes)
276.972 - apply (rule rev_finite_subset [OF *])
276.973 - apply (clarsimp, rename_tac x)
276.974 - apply (induct_tac x rule: udom.principal_induct)
276.975 - apply (simp add: adm_mem_finite *)
276.976 - apply (simp add: udom_approx_principal)
276.977 - done
276.978 -qed
276.979 -
276.980 -interpretation udom_approx: finite_deflation "udom_approx i"
276.981 -by (rule finite_deflation_udom_approx)
276.982 -
276.983 -lemma chain_udom_approx [simp]: "chain (\<lambda>i. udom_approx i)"
276.984 -unfolding udom_approx_def
276.985 -apply (rule chainI)
276.986 -apply (rule udom.basis_fun_mono)
276.987 -apply (erule udom_approx_mono)
276.988 -apply (erule udom_approx_mono)
276.989 -apply (rule udom.principal_mono)
276.990 -apply (rule ubasis_until_chain, simp)
276.991 -done
276.992 -
276.993 -lemma lub_udom_approx [simp]: "(\<Squnion>i. udom_approx i) = ID"
276.994 -apply (rule cfun_eqI, simp add: contlub_cfun_fun)
276.995 -apply (rule below_antisym)
276.996 -apply (rule lub_below)
276.997 -apply (simp)
276.998 -apply (rule udom_approx.below)
276.999 -apply (rule_tac x=x in udom.principal_induct)
276.1000 -apply (simp add: lub_distribs)
276.1001 -apply (rule_tac i=a in below_lub)
276.1002 -apply simp
276.1003 -apply (simp add: udom_approx_principal)
276.1004 -apply (simp add: ubasis_until_same ubasis_le_refl)
276.1005 -done
276.1006 -
276.1007 -lemma udom_approx: "approx_chain udom_approx"
276.1008 -proof
276.1009 - show "chain (\<lambda>i. udom_approx i)"
276.1010 - by (rule chain_udom_approx)
276.1011 - show "(\<Squnion>i. udom_approx i) = ID"
276.1012 - by (rule lub_udom_approx)
276.1013 -qed
276.1014 -
276.1015 -hide_const (open) node
276.1016 -
276.1017 -end
277.1 --- a/src/HOLCF/Up.thy Sat Nov 27 14:34:54 2010 -0800
277.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
277.3 @@ -1,263 +0,0 @@
277.4 -(* Title: HOLCF/Up.thy
277.5 - Author: Franz Regensburger
277.6 - Author: Brian Huffman
277.7 -*)
277.8 -
277.9 -header {* The type of lifted values *}
277.10 -
277.11 -theory Up
277.12 -imports Cfun
277.13 -begin
277.14 -
277.15 -default_sort cpo
277.16 -
277.17 -subsection {* Definition of new type for lifting *}
277.18 -
277.19 -datatype 'a u = Ibottom | Iup 'a
277.20 -
277.21 -type_notation (xsymbols)
277.22 - u ("(_\<^sub>\<bottom>)" [1000] 999)
277.23 -
277.24 -primrec Ifup :: "('a \<rightarrow> 'b::pcpo) \<Rightarrow> 'a u \<Rightarrow> 'b" where
277.25 - "Ifup f Ibottom = \<bottom>"
277.26 - | "Ifup f (Iup x) = f\<cdot>x"
277.27 -
277.28 -subsection {* Ordering on lifted cpo *}
277.29 -
277.30 -instantiation u :: (cpo) below
277.31 -begin
277.32 -
277.33 -definition
277.34 - below_up_def:
277.35 - "(op \<sqsubseteq>) \<equiv> (\<lambda>x y. case x of Ibottom \<Rightarrow> True | Iup a \<Rightarrow>
277.36 - (case y of Ibottom \<Rightarrow> False | Iup b \<Rightarrow> a \<sqsubseteq> b))"
277.37 -
277.38 -instance ..
277.39 -end
277.40 -
277.41 -lemma minimal_up [iff]: "Ibottom \<sqsubseteq> z"
277.42 -by (simp add: below_up_def)
277.43 -
277.44 -lemma not_Iup_below [iff]: "\<not> Iup x \<sqsubseteq> Ibottom"
277.45 -by (simp add: below_up_def)
277.46 -
277.47 -lemma Iup_below [iff]: "(Iup x \<sqsubseteq> Iup y) = (x \<sqsubseteq> y)"
277.48 -by (simp add: below_up_def)
277.49 -
277.50 -subsection {* Lifted cpo is a partial order *}
277.51 -
277.52 -instance u :: (cpo) po
277.53 -proof
277.54 - fix x :: "'a u"
277.55 - show "x \<sqsubseteq> x"
277.56 - unfolding below_up_def by (simp split: u.split)
277.57 -next
277.58 - fix x y :: "'a u"
277.59 - assume "x \<sqsubseteq> y" "y \<sqsubseteq> x" thus "x = y"
277.60 - unfolding below_up_def
277.61 - by (auto split: u.split_asm intro: below_antisym)
277.62 -next
277.63 - fix x y z :: "'a u"
277.64 - assume "x \<sqsubseteq> y" "y \<sqsubseteq> z" thus "x \<sqsubseteq> z"
277.65 - unfolding below_up_def
277.66 - by (auto split: u.split_asm intro: below_trans)
277.67 -qed
277.68 -
277.69 -subsection {* Lifted cpo is a cpo *}
277.70 -
277.71 -lemma is_lub_Iup:
277.72 - "range S <<| x \<Longrightarrow> range (\<lambda>i. Iup (S i)) <<| Iup x"
277.73 -unfolding is_lub_def is_ub_def ball_simps
277.74 -by (auto simp add: below_up_def split: u.split)
277.75 -
277.76 -lemma up_chain_lemma:
277.77 - assumes Y: "chain Y" obtains "\<forall>i. Y i = Ibottom"
277.78 - | A k where "\<forall>i. Iup (A i) = Y (i + k)" and "chain A" and "range Y <<| Iup (\<Squnion>i. A i)"
277.79 -proof (cases "\<exists>k. Y k \<noteq> Ibottom")
277.80 - case True
277.81 - then obtain k where k: "Y k \<noteq> Ibottom" ..
277.82 - def A \<equiv> "\<lambda>i. THE a. Iup a = Y (i + k)"
277.83 - have Iup_A: "\<forall>i. Iup (A i) = Y (i + k)"
277.84 - proof
277.85 - fix i :: nat
277.86 - from Y le_add2 have "Y k \<sqsubseteq> Y (i + k)" by (rule chain_mono)
277.87 - with k have "Y (i + k) \<noteq> Ibottom" by (cases "Y k", auto)
277.88 - thus "Iup (A i) = Y (i + k)"
277.89 - by (cases "Y (i + k)", simp_all add: A_def)
277.90 - qed
277.91 - from Y have chain_A: "chain A"
277.92 - unfolding chain_def Iup_below [symmetric]
277.93 - by (simp add: Iup_A)
277.94 - hence "range A <<| (\<Squnion>i. A i)"
277.95 - by (rule cpo_lubI)
277.96 - hence "range (\<lambda>i. Iup (A i)) <<| Iup (\<Squnion>i. A i)"
277.97 - by (rule is_lub_Iup)
277.98 - hence "range (\<lambda>i. Y (i + k)) <<| Iup (\<Squnion>i. A i)"
277.99 - by (simp only: Iup_A)
277.100 - hence "range (\<lambda>i. Y i) <<| Iup (\<Squnion>i. A i)"
277.101 - by (simp only: is_lub_range_shift [OF Y])
277.102 - with Iup_A chain_A show ?thesis ..
277.103 -next
277.104 - case False
277.105 - then have "\<forall>i. Y i = Ibottom" by simp
277.106 - then show ?thesis ..
277.107 -qed
277.108 -
277.109 -instance u :: (cpo) cpo
277.110 -proof
277.111 - fix S :: "nat \<Rightarrow> 'a u"
277.112 - assume S: "chain S"
277.113 - thus "\<exists>x. range (\<lambda>i. S i) <<| x"
277.114 - proof (rule up_chain_lemma)
277.115 - assume "\<forall>i. S i = Ibottom"
277.116 - hence "range (\<lambda>i. S i) <<| Ibottom"
277.117 - by (simp add: is_lub_const)
277.118 - thus ?thesis ..
277.119 - next
277.120 - fix A :: "nat \<Rightarrow> 'a"
277.121 - assume "range S <<| Iup (\<Squnion>i. A i)"
277.122 - thus ?thesis ..
277.123 - qed
277.124 -qed
277.125 -
277.126 -subsection {* Lifted cpo is pointed *}
277.127 -
277.128 -instance u :: (cpo) pcpo
277.129 -by intro_classes fast
277.130 -
277.131 -text {* for compatibility with old HOLCF-Version *}
277.132 -lemma inst_up_pcpo: "\<bottom> = Ibottom"
277.133 -by (rule minimal_up [THEN UU_I, symmetric])
277.134 -
277.135 -subsection {* Continuity of \emph{Iup} and \emph{Ifup} *}
277.136 -
277.137 -text {* continuity for @{term Iup} *}
277.138 -
277.139 -lemma cont_Iup: "cont Iup"
277.140 -apply (rule contI)
277.141 -apply (rule is_lub_Iup)
277.142 -apply (erule cpo_lubI)
277.143 -done
277.144 -
277.145 -text {* continuity for @{term Ifup} *}
277.146 -
277.147 -lemma cont_Ifup1: "cont (\<lambda>f. Ifup f x)"
277.148 -by (induct x, simp_all)
277.149 -
277.150 -lemma monofun_Ifup2: "monofun (\<lambda>x. Ifup f x)"
277.151 -apply (rule monofunI)
277.152 -apply (case_tac x, simp)
277.153 -apply (case_tac y, simp)
277.154 -apply (simp add: monofun_cfun_arg)
277.155 -done
277.156 -
277.157 -lemma cont_Ifup2: "cont (\<lambda>x. Ifup f x)"
277.158 -proof (rule contI2)
277.159 - fix Y assume Y: "chain Y" and Y': "chain (\<lambda>i. Ifup f (Y i))"
277.160 - from Y show "Ifup f (\<Squnion>i. Y i) \<sqsubseteq> (\<Squnion>i. Ifup f (Y i))"
277.161 - proof (rule up_chain_lemma)
277.162 - fix A and k
277.163 - assume A: "\<forall>i. Iup (A i) = Y (i + k)"
277.164 - assume "chain A" and "range Y <<| Iup (\<Squnion>i. A i)"
277.165 - hence "Ifup f (\<Squnion>i. Y i) = (\<Squnion>i. Ifup f (Iup (A i)))"
277.166 - by (simp add: lub_eqI contlub_cfun_arg)
277.167 - also have "\<dots> = (\<Squnion>i. Ifup f (Y (i + k)))"
277.168 - by (simp add: A)
277.169 - also have "\<dots> = (\<Squnion>i. Ifup f (Y i))"
277.170 - using Y' by (rule lub_range_shift)
277.171 - finally show ?thesis by simp
277.172 - qed simp
277.173 -qed (rule monofun_Ifup2)
277.174 -
277.175 -subsection {* Continuous versions of constants *}
277.176 -
277.177 -definition
277.178 - up :: "'a \<rightarrow> 'a u" where
277.179 - "up = (\<Lambda> x. Iup x)"
277.180 -
277.181 -definition
277.182 - fup :: "('a \<rightarrow> 'b::pcpo) \<rightarrow> 'a u \<rightarrow> 'b" where
277.183 - "fup = (\<Lambda> f p. Ifup f p)"
277.184 -
277.185 -translations
277.186 - "case l of XCONST up\<cdot>x \<Rightarrow> t" == "CONST fup\<cdot>(\<Lambda> x. t)\<cdot>l"
277.187 - "\<Lambda>(XCONST up\<cdot>x). t" == "CONST fup\<cdot>(\<Lambda> x. t)"
277.188 -
277.189 -text {* continuous versions of lemmas for @{typ "('a)u"} *}
277.190 -
277.191 -lemma Exh_Up: "z = \<bottom> \<or> (\<exists>x. z = up\<cdot>x)"
277.192 -apply (induct z)
277.193 -apply (simp add: inst_up_pcpo)
277.194 -apply (simp add: up_def cont_Iup)
277.195 -done
277.196 -
277.197 -lemma up_eq [simp]: "(up\<cdot>x = up\<cdot>y) = (x = y)"
277.198 -by (simp add: up_def cont_Iup)
277.199 -
277.200 -lemma up_inject: "up\<cdot>x = up\<cdot>y \<Longrightarrow> x = y"
277.201 -by simp
277.202 -
277.203 -lemma up_defined [simp]: "up\<cdot>x \<noteq> \<bottom>"
277.204 -by (simp add: up_def cont_Iup inst_up_pcpo)
277.205 -
277.206 -lemma not_up_less_UU: "\<not> up\<cdot>x \<sqsubseteq> \<bottom>"
277.207 -by simp (* FIXME: remove? *)
277.208 -
277.209 -lemma up_below [simp]: "up\<cdot>x \<sqsubseteq> up\<cdot>y \<longleftrightarrow> x \<sqsubseteq> y"
277.210 -by (simp add: up_def cont_Iup)
277.211 -
277.212 -lemma upE [case_names bottom up, cases type: u]:
277.213 - "\<lbrakk>p = \<bottom> \<Longrightarrow> Q; \<And>x. p = up\<cdot>x \<Longrightarrow> Q\<rbrakk> \<Longrightarrow> Q"
277.214 -apply (cases p)
277.215 -apply (simp add: inst_up_pcpo)
277.216 -apply (simp add: up_def cont_Iup)
277.217 -done
277.218 -
277.219 -lemma up_induct [case_names bottom up, induct type: u]:
277.220 - "\<lbrakk>P \<bottom>; \<And>x. P (up\<cdot>x)\<rbrakk> \<Longrightarrow> P x"
277.221 -by (cases x, simp_all)
277.222 -
277.223 -text {* lifting preserves chain-finiteness *}
277.224 -
277.225 -lemma up_chain_cases:
277.226 - assumes Y: "chain Y" obtains "\<forall>i. Y i = \<bottom>"
277.227 - | A k where "\<forall>i. up\<cdot>(A i) = Y (i + k)" and "chain A" and "(\<Squnion>i. Y i) = up\<cdot>(\<Squnion>i. A i)"
277.228 -apply (rule up_chain_lemma [OF Y])
277.229 -apply (simp_all add: inst_up_pcpo up_def cont_Iup lub_eqI)
277.230 -done
277.231 -
277.232 -lemma compact_up: "compact x \<Longrightarrow> compact (up\<cdot>x)"
277.233 -apply (rule compactI2)
277.234 -apply (erule up_chain_cases)
277.235 -apply simp
277.236 -apply (drule (1) compactD2, simp)
277.237 -apply (erule exE)
277.238 -apply (drule_tac f="up" and x="x" in monofun_cfun_arg)
277.239 -apply (simp, erule exI)
277.240 -done
277.241 -
277.242 -lemma compact_upD: "compact (up\<cdot>x) \<Longrightarrow> compact x"
277.243 -unfolding compact_def
277.244 -by (drule adm_subst [OF cont_Rep_cfun2 [where f=up]], simp)
277.245 -
277.246 -lemma compact_up_iff [simp]: "compact (up\<cdot>x) = compact x"
277.247 -by (safe elim!: compact_up compact_upD)
277.248 -
277.249 -instance u :: (chfin) chfin
277.250 -apply intro_classes
277.251 -apply (erule compact_imp_max_in_chain)
277.252 -apply (rule_tac p="\<Squnion>i. Y i" in upE, simp_all)
277.253 -done
277.254 -
277.255 -text {* properties of fup *}
277.256 -
277.257 -lemma fup1 [simp]: "fup\<cdot>f\<cdot>\<bottom> = \<bottom>"
277.258 -by (simp add: fup_def cont_Ifup1 cont_Ifup2 inst_up_pcpo cont2cont_LAM)
277.259 -
277.260 -lemma fup2 [simp]: "fup\<cdot>f\<cdot>(up\<cdot>x) = f\<cdot>x"
277.261 -by (simp add: up_def fup_def cont_Iup cont_Ifup1 cont_Ifup2 cont2cont_LAM)
277.262 -
277.263 -lemma fup3 [simp]: "fup\<cdot>up\<cdot>x = x"
277.264 -by (cases x, simp_all)
277.265 -
277.266 -end
278.1 --- a/src/HOLCF/UpperPD.thy Sat Nov 27 14:34:54 2010 -0800
278.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
278.3 @@ -1,529 +0,0 @@
278.4 -(* Title: HOLCF/UpperPD.thy
278.5 - Author: Brian Huffman
278.6 -*)
278.7 -
278.8 -header {* Upper powerdomain *}
278.9 -
278.10 -theory UpperPD
278.11 -imports CompactBasis
278.12 -begin
278.13 -
278.14 -subsection {* Basis preorder *}
278.15 -
278.16 -definition
278.17 - upper_le :: "'a pd_basis \<Rightarrow> 'a pd_basis \<Rightarrow> bool" (infix "\<le>\<sharp>" 50) where
278.18 - "upper_le = (\<lambda>u v. \<forall>y\<in>Rep_pd_basis v. \<exists>x\<in>Rep_pd_basis u. x \<sqsubseteq> y)"
278.19 -
278.20 -lemma upper_le_refl [simp]: "t \<le>\<sharp> t"
278.21 -unfolding upper_le_def by fast
278.22 -
278.23 -lemma upper_le_trans: "\<lbrakk>t \<le>\<sharp> u; u \<le>\<sharp> v\<rbrakk> \<Longrightarrow> t \<le>\<sharp> v"
278.24 -unfolding upper_le_def
278.25 -apply (rule ballI)
278.26 -apply (drule (1) bspec, erule bexE)
278.27 -apply (drule (1) bspec, erule bexE)
278.28 -apply (erule rev_bexI)
278.29 -apply (erule (1) below_trans)
278.30 -done
278.31 -
278.32 -interpretation upper_le: preorder upper_le
278.33 -by (rule preorder.intro, rule upper_le_refl, rule upper_le_trans)
278.34 -
278.35 -lemma upper_le_minimal [simp]: "PDUnit compact_bot \<le>\<sharp> t"
278.36 -unfolding upper_le_def Rep_PDUnit by simp
278.37 -
278.38 -lemma PDUnit_upper_mono: "x \<sqsubseteq> y \<Longrightarrow> PDUnit x \<le>\<sharp> PDUnit y"
278.39 -unfolding upper_le_def Rep_PDUnit by simp
278.40 -
278.41 -lemma PDPlus_upper_mono: "\<lbrakk>s \<le>\<sharp> t; u \<le>\<sharp> v\<rbrakk> \<Longrightarrow> PDPlus s u \<le>\<sharp> PDPlus t v"
278.42 -unfolding upper_le_def Rep_PDPlus by fast
278.43 -
278.44 -lemma PDPlus_upper_le: "PDPlus t u \<le>\<sharp> t"
278.45 -unfolding upper_le_def Rep_PDPlus by fast
278.46 -
278.47 -lemma upper_le_PDUnit_PDUnit_iff [simp]:
278.48 - "(PDUnit a \<le>\<sharp> PDUnit b) = (a \<sqsubseteq> b)"
278.49 -unfolding upper_le_def Rep_PDUnit by fast
278.50 -
278.51 -lemma upper_le_PDPlus_PDUnit_iff:
278.52 - "(PDPlus t u \<le>\<sharp> PDUnit a) = (t \<le>\<sharp> PDUnit a \<or> u \<le>\<sharp> PDUnit a)"
278.53 -unfolding upper_le_def Rep_PDPlus Rep_PDUnit by fast
278.54 -
278.55 -lemma upper_le_PDPlus_iff: "(t \<le>\<sharp> PDPlus u v) = (t \<le>\<sharp> u \<and> t \<le>\<sharp> v)"
278.56 -unfolding upper_le_def Rep_PDPlus by fast
278.57 -
278.58 -lemma upper_le_induct [induct set: upper_le]:
278.59 - assumes le: "t \<le>\<sharp> u"
278.60 - assumes 1: "\<And>a b. a \<sqsubseteq> b \<Longrightarrow> P (PDUnit a) (PDUnit b)"
278.61 - assumes 2: "\<And>t u a. P t (PDUnit a) \<Longrightarrow> P (PDPlus t u) (PDUnit a)"
278.62 - assumes 3: "\<And>t u v. \<lbrakk>P t u; P t v\<rbrakk> \<Longrightarrow> P t (PDPlus u v)"
278.63 - shows "P t u"
278.64 -using le apply (induct u arbitrary: t rule: pd_basis_induct)
278.65 -apply (erule rev_mp)
278.66 -apply (induct_tac t rule: pd_basis_induct)
278.67 -apply (simp add: 1)
278.68 -apply (simp add: upper_le_PDPlus_PDUnit_iff)
278.69 -apply (simp add: 2)
278.70 -apply (subst PDPlus_commute)
278.71 -apply (simp add: 2)
278.72 -apply (simp add: upper_le_PDPlus_iff 3)
278.73 -done
278.74 -
278.75 -
278.76 -subsection {* Type definition *}
278.77 -
278.78 -typedef (open) 'a upper_pd =
278.79 - "{S::'a pd_basis set. upper_le.ideal S}"
278.80 -by (fast intro: upper_le.ideal_principal)
278.81 -
278.82 -instantiation upper_pd :: ("domain") below
278.83 -begin
278.84 -
278.85 -definition
278.86 - "x \<sqsubseteq> y \<longleftrightarrow> Rep_upper_pd x \<subseteq> Rep_upper_pd y"
278.87 -
278.88 -instance ..
278.89 -end
278.90 -
278.91 -instance upper_pd :: ("domain") po
278.92 -using type_definition_upper_pd below_upper_pd_def
278.93 -by (rule upper_le.typedef_ideal_po)
278.94 -
278.95 -instance upper_pd :: ("domain") cpo
278.96 -using type_definition_upper_pd below_upper_pd_def
278.97 -by (rule upper_le.typedef_ideal_cpo)
278.98 -
278.99 -definition
278.100 - upper_principal :: "'a pd_basis \<Rightarrow> 'a upper_pd" where
278.101 - "upper_principal t = Abs_upper_pd {u. u \<le>\<sharp> t}"
278.102 -
278.103 -interpretation upper_pd:
278.104 - ideal_completion upper_le upper_principal Rep_upper_pd
278.105 -using type_definition_upper_pd below_upper_pd_def
278.106 -using upper_principal_def pd_basis_countable
278.107 -by (rule upper_le.typedef_ideal_completion)
278.108 -
278.109 -text {* Upper powerdomain is pointed *}
278.110 -
278.111 -lemma upper_pd_minimal: "upper_principal (PDUnit compact_bot) \<sqsubseteq> ys"
278.112 -by (induct ys rule: upper_pd.principal_induct, simp, simp)
278.113 -
278.114 -instance upper_pd :: ("domain") pcpo
278.115 -by intro_classes (fast intro: upper_pd_minimal)
278.116 -
278.117 -lemma inst_upper_pd_pcpo: "\<bottom> = upper_principal (PDUnit compact_bot)"
278.118 -by (rule upper_pd_minimal [THEN UU_I, symmetric])
278.119 -
278.120 -
278.121 -subsection {* Monadic unit and plus *}
278.122 -
278.123 -definition
278.124 - upper_unit :: "'a \<rightarrow> 'a upper_pd" where
278.125 - "upper_unit = compact_basis.basis_fun (\<lambda>a. upper_principal (PDUnit a))"
278.126 -
278.127 -definition
278.128 - upper_plus :: "'a upper_pd \<rightarrow> 'a upper_pd \<rightarrow> 'a upper_pd" where
278.129 - "upper_plus = upper_pd.basis_fun (\<lambda>t. upper_pd.basis_fun (\<lambda>u.
278.130 - upper_principal (PDPlus t u)))"
278.131 -
278.132 -abbreviation
278.133 - upper_add :: "'a upper_pd \<Rightarrow> 'a upper_pd \<Rightarrow> 'a upper_pd"
278.134 - (infixl "+\<sharp>" 65) where
278.135 - "xs +\<sharp> ys == upper_plus\<cdot>xs\<cdot>ys"
278.136 -
278.137 -syntax
278.138 - "_upper_pd" :: "args \<Rightarrow> 'a upper_pd" ("{_}\<sharp>")
278.139 -
278.140 -translations
278.141 - "{x,xs}\<sharp>" == "{x}\<sharp> +\<sharp> {xs}\<sharp>"
278.142 - "{x}\<sharp>" == "CONST upper_unit\<cdot>x"
278.143 -
278.144 -lemma upper_unit_Rep_compact_basis [simp]:
278.145 - "{Rep_compact_basis a}\<sharp> = upper_principal (PDUnit a)"
278.146 -unfolding upper_unit_def
278.147 -by (simp add: compact_basis.basis_fun_principal PDUnit_upper_mono)
278.148 -
278.149 -lemma upper_plus_principal [simp]:
278.150 - "upper_principal t +\<sharp> upper_principal u = upper_principal (PDPlus t u)"
278.151 -unfolding upper_plus_def
278.152 -by (simp add: upper_pd.basis_fun_principal
278.153 - upper_pd.basis_fun_mono PDPlus_upper_mono)
278.154 -
278.155 -interpretation upper_add: semilattice upper_add proof
278.156 - fix xs ys zs :: "'a upper_pd"
278.157 - show "(xs +\<sharp> ys) +\<sharp> zs = xs +\<sharp> (ys +\<sharp> zs)"
278.158 - apply (induct xs ys arbitrary: zs rule: upper_pd.principal_induct2, simp, simp)
278.159 - apply (rule_tac x=zs in upper_pd.principal_induct, simp)
278.160 - apply (simp add: PDPlus_assoc)
278.161 - done
278.162 - show "xs +\<sharp> ys = ys +\<sharp> xs"
278.163 - apply (induct xs ys rule: upper_pd.principal_induct2, simp, simp)
278.164 - apply (simp add: PDPlus_commute)
278.165 - done
278.166 - show "xs +\<sharp> xs = xs"
278.167 - apply (induct xs rule: upper_pd.principal_induct, simp)
278.168 - apply (simp add: PDPlus_absorb)
278.169 - done
278.170 -qed
278.171 -
278.172 -lemmas upper_plus_assoc = upper_add.assoc
278.173 -lemmas upper_plus_commute = upper_add.commute
278.174 -lemmas upper_plus_absorb = upper_add.idem
278.175 -lemmas upper_plus_left_commute = upper_add.left_commute
278.176 -lemmas upper_plus_left_absorb = upper_add.left_idem
278.177 -
278.178 -text {* Useful for @{text "simp add: upper_plus_ac"} *}
278.179 -lemmas upper_plus_ac =
278.180 - upper_plus_assoc upper_plus_commute upper_plus_left_commute
278.181 -
278.182 -text {* Useful for @{text "simp only: upper_plus_aci"} *}
278.183 -lemmas upper_plus_aci =
278.184 - upper_plus_ac upper_plus_absorb upper_plus_left_absorb
278.185 -
278.186 -lemma upper_plus_below1: "xs +\<sharp> ys \<sqsubseteq> xs"
278.187 -apply (induct xs ys rule: upper_pd.principal_induct2, simp, simp)
278.188 -apply (simp add: PDPlus_upper_le)
278.189 -done
278.190 -
278.191 -lemma upper_plus_below2: "xs +\<sharp> ys \<sqsubseteq> ys"
278.192 -by (subst upper_plus_commute, rule upper_plus_below1)
278.193 -
278.194 -lemma upper_plus_greatest: "\<lbrakk>xs \<sqsubseteq> ys; xs \<sqsubseteq> zs\<rbrakk> \<Longrightarrow> xs \<sqsubseteq> ys +\<sharp> zs"
278.195 -apply (subst upper_plus_absorb [of xs, symmetric])
278.196 -apply (erule (1) monofun_cfun [OF monofun_cfun_arg])
278.197 -done
278.198 -
278.199 -lemma upper_below_plus_iff [simp]:
278.200 - "xs \<sqsubseteq> ys +\<sharp> zs \<longleftrightarrow> xs \<sqsubseteq> ys \<and> xs \<sqsubseteq> zs"
278.201 -apply safe
278.202 -apply (erule below_trans [OF _ upper_plus_below1])
278.203 -apply (erule below_trans [OF _ upper_plus_below2])
278.204 -apply (erule (1) upper_plus_greatest)
278.205 -done
278.206 -
278.207 -lemma upper_plus_below_unit_iff [simp]:
278.208 - "xs +\<sharp> ys \<sqsubseteq> {z}\<sharp> \<longleftrightarrow> xs \<sqsubseteq> {z}\<sharp> \<or> ys \<sqsubseteq> {z}\<sharp>"
278.209 -apply (induct xs rule: upper_pd.principal_induct, simp)
278.210 -apply (induct ys rule: upper_pd.principal_induct, simp)
278.211 -apply (induct z rule: compact_basis.principal_induct, simp)
278.212 -apply (simp add: upper_le_PDPlus_PDUnit_iff)
278.213 -done
278.214 -
278.215 -lemma upper_unit_below_iff [simp]: "{x}\<sharp> \<sqsubseteq> {y}\<sharp> \<longleftrightarrow> x \<sqsubseteq> y"
278.216 -apply (induct x rule: compact_basis.principal_induct, simp)
278.217 -apply (induct y rule: compact_basis.principal_induct, simp)
278.218 -apply simp
278.219 -done
278.220 -
278.221 -lemmas upper_pd_below_simps =
278.222 - upper_unit_below_iff
278.223 - upper_below_plus_iff
278.224 - upper_plus_below_unit_iff
278.225 -
278.226 -lemma upper_unit_eq_iff [simp]: "{x}\<sharp> = {y}\<sharp> \<longleftrightarrow> x = y"
278.227 -unfolding po_eq_conv by simp
278.228 -
278.229 -lemma upper_unit_strict [simp]: "{\<bottom>}\<sharp> = \<bottom>"
278.230 -using upper_unit_Rep_compact_basis [of compact_bot]
278.231 -by (simp add: inst_upper_pd_pcpo)
278.232 -
278.233 -lemma upper_plus_strict1 [simp]: "\<bottom> +\<sharp> ys = \<bottom>"
278.234 -by (rule UU_I, rule upper_plus_below1)
278.235 -
278.236 -lemma upper_plus_strict2 [simp]: "xs +\<sharp> \<bottom> = \<bottom>"
278.237 -by (rule UU_I, rule upper_plus_below2)
278.238 -
278.239 -lemma upper_unit_bottom_iff [simp]: "{x}\<sharp> = \<bottom> \<longleftrightarrow> x = \<bottom>"
278.240 -unfolding upper_unit_strict [symmetric] by (rule upper_unit_eq_iff)
278.241 -
278.242 -lemma upper_plus_bottom_iff [simp]:
278.243 - "xs +\<sharp> ys = \<bottom> \<longleftrightarrow> xs = \<bottom> \<or> ys = \<bottom>"
278.244 -apply (rule iffI)
278.245 -apply (erule rev_mp)
278.246 -apply (rule upper_pd.principal_induct2 [where x=xs and y=ys], simp, simp)
278.247 -apply (simp add: inst_upper_pd_pcpo upper_pd.principal_eq_iff
278.248 - upper_le_PDPlus_PDUnit_iff)
278.249 -apply auto
278.250 -done
278.251 -
278.252 -lemma compact_upper_unit: "compact x \<Longrightarrow> compact {x}\<sharp>"
278.253 -by (auto dest!: compact_basis.compact_imp_principal)
278.254 -
278.255 -lemma compact_upper_unit_iff [simp]: "compact {x}\<sharp> \<longleftrightarrow> compact x"
278.256 -apply (safe elim!: compact_upper_unit)
278.257 -apply (simp only: compact_def upper_unit_below_iff [symmetric])
278.258 -apply (erule adm_subst [OF cont_Rep_cfun2])
278.259 -done
278.260 -
278.261 -lemma compact_upper_plus [simp]:
278.262 - "\<lbrakk>compact xs; compact ys\<rbrakk> \<Longrightarrow> compact (xs +\<sharp> ys)"
278.263 -by (auto dest!: upper_pd.compact_imp_principal)
278.264 -
278.265 -
278.266 -subsection {* Induction rules *}
278.267 -
278.268 -lemma upper_pd_induct1:
278.269 - assumes P: "adm P"
278.270 - assumes unit: "\<And>x. P {x}\<sharp>"
278.271 - assumes insert: "\<And>x ys. \<lbrakk>P {x}\<sharp>; P ys\<rbrakk> \<Longrightarrow> P ({x}\<sharp> +\<sharp> ys)"
278.272 - shows "P (xs::'a upper_pd)"
278.273 -apply (induct xs rule: upper_pd.principal_induct, rule P)
278.274 -apply (induct_tac a rule: pd_basis_induct1)
278.275 -apply (simp only: upper_unit_Rep_compact_basis [symmetric])
278.276 -apply (rule unit)
278.277 -apply (simp only: upper_unit_Rep_compact_basis [symmetric]
278.278 - upper_plus_principal [symmetric])
278.279 -apply (erule insert [OF unit])
278.280 -done
278.281 -
278.282 -lemma upper_pd_induct
278.283 - [case_names adm upper_unit upper_plus, induct type: upper_pd]:
278.284 - assumes P: "adm P"
278.285 - assumes unit: "\<And>x. P {x}\<sharp>"
278.286 - assumes plus: "\<And>xs ys. \<lbrakk>P xs; P ys\<rbrakk> \<Longrightarrow> P (xs +\<sharp> ys)"
278.287 - shows "P (xs::'a upper_pd)"
278.288 -apply (induct xs rule: upper_pd.principal_induct, rule P)
278.289 -apply (induct_tac a rule: pd_basis_induct)
278.290 -apply (simp only: upper_unit_Rep_compact_basis [symmetric] unit)
278.291 -apply (simp only: upper_plus_principal [symmetric] plus)
278.292 -done
278.293 -
278.294 -
278.295 -subsection {* Monadic bind *}
278.296 -
278.297 -definition
278.298 - upper_bind_basis ::
278.299 - "'a pd_basis \<Rightarrow> ('a \<rightarrow> 'b upper_pd) \<rightarrow> 'b upper_pd" where
278.300 - "upper_bind_basis = fold_pd
278.301 - (\<lambda>a. \<Lambda> f. f\<cdot>(Rep_compact_basis a))
278.302 - (\<lambda>x y. \<Lambda> f. x\<cdot>f +\<sharp> y\<cdot>f)"
278.303 -
278.304 -lemma ACI_upper_bind:
278.305 - "class.ab_semigroup_idem_mult (\<lambda>x y. \<Lambda> f. x\<cdot>f +\<sharp> y\<cdot>f)"
278.306 -apply unfold_locales
278.307 -apply (simp add: upper_plus_assoc)
278.308 -apply (simp add: upper_plus_commute)
278.309 -apply (simp add: eta_cfun)
278.310 -done
278.311 -
278.312 -lemma upper_bind_basis_simps [simp]:
278.313 - "upper_bind_basis (PDUnit a) =
278.314 - (\<Lambda> f. f\<cdot>(Rep_compact_basis a))"
278.315 - "upper_bind_basis (PDPlus t u) =
278.316 - (\<Lambda> f. upper_bind_basis t\<cdot>f +\<sharp> upper_bind_basis u\<cdot>f)"
278.317 -unfolding upper_bind_basis_def
278.318 -apply -
278.319 -apply (rule fold_pd_PDUnit [OF ACI_upper_bind])
278.320 -apply (rule fold_pd_PDPlus [OF ACI_upper_bind])
278.321 -done
278.322 -
278.323 -lemma upper_bind_basis_mono:
278.324 - "t \<le>\<sharp> u \<Longrightarrow> upper_bind_basis t \<sqsubseteq> upper_bind_basis u"
278.325 -unfolding cfun_below_iff
278.326 -apply (erule upper_le_induct, safe)
278.327 -apply (simp add: monofun_cfun)
278.328 -apply (simp add: below_trans [OF upper_plus_below1])
278.329 -apply simp
278.330 -done
278.331 -
278.332 -definition
278.333 - upper_bind :: "'a upper_pd \<rightarrow> ('a \<rightarrow> 'b upper_pd) \<rightarrow> 'b upper_pd" where
278.334 - "upper_bind = upper_pd.basis_fun upper_bind_basis"
278.335 -
278.336 -lemma upper_bind_principal [simp]:
278.337 - "upper_bind\<cdot>(upper_principal t) = upper_bind_basis t"
278.338 -unfolding upper_bind_def
278.339 -apply (rule upper_pd.basis_fun_principal)
278.340 -apply (erule upper_bind_basis_mono)
278.341 -done
278.342 -
278.343 -lemma upper_bind_unit [simp]:
278.344 - "upper_bind\<cdot>{x}\<sharp>\<cdot>f = f\<cdot>x"
278.345 -by (induct x rule: compact_basis.principal_induct, simp, simp)
278.346 -
278.347 -lemma upper_bind_plus [simp]:
278.348 - "upper_bind\<cdot>(xs +\<sharp> ys)\<cdot>f = upper_bind\<cdot>xs\<cdot>f +\<sharp> upper_bind\<cdot>ys\<cdot>f"
278.349 -by (induct xs ys rule: upper_pd.principal_induct2, simp, simp, simp)
278.350 -
278.351 -lemma upper_bind_strict [simp]: "upper_bind\<cdot>\<bottom>\<cdot>f = f\<cdot>\<bottom>"
278.352 -unfolding upper_unit_strict [symmetric] by (rule upper_bind_unit)
278.353 -
278.354 -lemma upper_bind_bind:
278.355 - "upper_bind\<cdot>(upper_bind\<cdot>xs\<cdot>f)\<cdot>g = upper_bind\<cdot>xs\<cdot>(\<Lambda> x. upper_bind\<cdot>(f\<cdot>x)\<cdot>g)"
278.356 -by (induct xs, simp_all)
278.357 -
278.358 -
278.359 -subsection {* Map *}
278.360 -
278.361 -definition
278.362 - upper_map :: "('a \<rightarrow> 'b) \<rightarrow> 'a upper_pd \<rightarrow> 'b upper_pd" where
278.363 - "upper_map = (\<Lambda> f xs. upper_bind\<cdot>xs\<cdot>(\<Lambda> x. {f\<cdot>x}\<sharp>))"
278.364 -
278.365 -lemma upper_map_unit [simp]:
278.366 - "upper_map\<cdot>f\<cdot>{x}\<sharp> = {f\<cdot>x}\<sharp>"
278.367 -unfolding upper_map_def by simp
278.368 -
278.369 -lemma upper_map_plus [simp]:
278.370 - "upper_map\<cdot>f\<cdot>(xs +\<sharp> ys) = upper_map\<cdot>f\<cdot>xs +\<sharp> upper_map\<cdot>f\<cdot>ys"
278.371 -unfolding upper_map_def by simp
278.372 -
278.373 -lemma upper_map_bottom [simp]: "upper_map\<cdot>f\<cdot>\<bottom> = {f\<cdot>\<bottom>}\<sharp>"
278.374 -unfolding upper_map_def by simp
278.375 -
278.376 -lemma upper_map_ident: "upper_map\<cdot>(\<Lambda> x. x)\<cdot>xs = xs"
278.377 -by (induct xs rule: upper_pd_induct, simp_all)
278.378 -
278.379 -lemma upper_map_ID: "upper_map\<cdot>ID = ID"
278.380 -by (simp add: cfun_eq_iff ID_def upper_map_ident)
278.381 -
278.382 -lemma upper_map_map:
278.383 - "upper_map\<cdot>f\<cdot>(upper_map\<cdot>g\<cdot>xs) = upper_map\<cdot>(\<Lambda> x. f\<cdot>(g\<cdot>x))\<cdot>xs"
278.384 -by (induct xs rule: upper_pd_induct, simp_all)
278.385 -
278.386 -lemma ep_pair_upper_map: "ep_pair e p \<Longrightarrow> ep_pair (upper_map\<cdot>e) (upper_map\<cdot>p)"
278.387 -apply default
278.388 -apply (induct_tac x rule: upper_pd_induct, simp_all add: ep_pair.e_inverse)
278.389 -apply (induct_tac y rule: upper_pd_induct)
278.390 -apply (simp_all add: ep_pair.e_p_below monofun_cfun del: upper_below_plus_iff)
278.391 -done
278.392 -
278.393 -lemma deflation_upper_map: "deflation d \<Longrightarrow> deflation (upper_map\<cdot>d)"
278.394 -apply default
278.395 -apply (induct_tac x rule: upper_pd_induct, simp_all add: deflation.idem)
278.396 -apply (induct_tac x rule: upper_pd_induct)
278.397 -apply (simp_all add: deflation.below monofun_cfun del: upper_below_plus_iff)
278.398 -done
278.399 -
278.400 -(* FIXME: long proof! *)
278.401 -lemma finite_deflation_upper_map:
278.402 - assumes "finite_deflation d" shows "finite_deflation (upper_map\<cdot>d)"
278.403 -proof (rule finite_deflation_intro)
278.404 - interpret d: finite_deflation d by fact
278.405 - have "deflation d" by fact
278.406 - thus "deflation (upper_map\<cdot>d)" by (rule deflation_upper_map)
278.407 - have "finite (range (\<lambda>x. d\<cdot>x))" by (rule d.finite_range)
278.408 - hence "finite (Rep_compact_basis -` range (\<lambda>x. d\<cdot>x))"
278.409 - by (rule finite_vimageI, simp add: inj_on_def Rep_compact_basis_inject)
278.410 - hence "finite (Pow (Rep_compact_basis -` range (\<lambda>x. d\<cdot>x)))" by simp
278.411 - hence "finite (Rep_pd_basis -` (Pow (Rep_compact_basis -` range (\<lambda>x. d\<cdot>x))))"
278.412 - by (rule finite_vimageI, simp add: inj_on_def Rep_pd_basis_inject)
278.413 - hence *: "finite (upper_principal ` Rep_pd_basis -` (Pow (Rep_compact_basis -` range (\<lambda>x. d\<cdot>x))))" by simp
278.414 - hence "finite (range (\<lambda>xs. upper_map\<cdot>d\<cdot>xs))"
278.415 - apply (rule rev_finite_subset)
278.416 - apply clarsimp
278.417 - apply (induct_tac xs rule: upper_pd.principal_induct)
278.418 - apply (simp add: adm_mem_finite *)
278.419 - apply (rename_tac t, induct_tac t rule: pd_basis_induct)
278.420 - apply (simp only: upper_unit_Rep_compact_basis [symmetric] upper_map_unit)
278.421 - apply simp
278.422 - apply (subgoal_tac "\<exists>b. d\<cdot>(Rep_compact_basis a) = Rep_compact_basis b")
278.423 - apply clarsimp
278.424 - apply (rule imageI)
278.425 - apply (rule vimageI2)
278.426 - apply (simp add: Rep_PDUnit)
278.427 - apply (rule range_eqI)
278.428 - apply (erule sym)
278.429 - apply (rule exI)
278.430 - apply (rule Abs_compact_basis_inverse [symmetric])
278.431 - apply (simp add: d.compact)
278.432 - apply (simp only: upper_plus_principal [symmetric] upper_map_plus)
278.433 - apply clarsimp
278.434 - apply (rule imageI)
278.435 - apply (rule vimageI2)
278.436 - apply (simp add: Rep_PDPlus)
278.437 - done
278.438 - thus "finite {xs. upper_map\<cdot>d\<cdot>xs = xs}"
278.439 - by (rule finite_range_imp_finite_fixes)
278.440 -qed
278.441 -
278.442 -subsection {* Upper powerdomain is a domain *}
278.443 -
278.444 -definition
278.445 - upper_approx :: "nat \<Rightarrow> udom upper_pd \<rightarrow> udom upper_pd"
278.446 -where
278.447 - "upper_approx = (\<lambda>i. upper_map\<cdot>(udom_approx i))"
278.448 -
278.449 -lemma upper_approx: "approx_chain upper_approx"
278.450 -using upper_map_ID finite_deflation_upper_map
278.451 -unfolding upper_approx_def by (rule approx_chain_lemma1)
278.452 -
278.453 -definition upper_defl :: "defl \<rightarrow> defl"
278.454 -where "upper_defl = defl_fun1 upper_approx upper_map"
278.455 -
278.456 -lemma cast_upper_defl:
278.457 - "cast\<cdot>(upper_defl\<cdot>A) =
278.458 - udom_emb upper_approx oo upper_map\<cdot>(cast\<cdot>A) oo udom_prj upper_approx"
278.459 -using upper_approx finite_deflation_upper_map
278.460 -unfolding upper_defl_def by (rule cast_defl_fun1)
278.461 -
278.462 -instantiation upper_pd :: ("domain") liftdomain
278.463 -begin
278.464 -
278.465 -definition
278.466 - "emb = udom_emb upper_approx oo upper_map\<cdot>emb"
278.467 -
278.468 -definition
278.469 - "prj = upper_map\<cdot>prj oo udom_prj upper_approx"
278.470 -
278.471 -definition
278.472 - "defl (t::'a upper_pd itself) = upper_defl\<cdot>DEFL('a)"
278.473 -
278.474 -definition
278.475 - "(liftemb :: 'a upper_pd u \<rightarrow> udom) = udom_emb u_approx oo u_map\<cdot>emb"
278.476 -
278.477 -definition
278.478 - "(liftprj :: udom \<rightarrow> 'a upper_pd u) = u_map\<cdot>prj oo udom_prj u_approx"
278.479 -
278.480 -definition
278.481 - "liftdefl (t::'a upper_pd itself) = u_defl\<cdot>DEFL('a upper_pd)"
278.482 -
278.483 -instance
278.484 -using liftemb_upper_pd_def liftprj_upper_pd_def liftdefl_upper_pd_def
278.485 -proof (rule liftdomain_class_intro)
278.486 - show "ep_pair emb (prj :: udom \<rightarrow> 'a upper_pd)"
278.487 - unfolding emb_upper_pd_def prj_upper_pd_def
278.488 - using ep_pair_udom [OF upper_approx]
278.489 - by (intro ep_pair_comp ep_pair_upper_map ep_pair_emb_prj)
278.490 -next
278.491 - show "cast\<cdot>DEFL('a upper_pd) = emb oo (prj :: udom \<rightarrow> 'a upper_pd)"
278.492 - unfolding emb_upper_pd_def prj_upper_pd_def defl_upper_pd_def cast_upper_defl
278.493 - by (simp add: cast_DEFL oo_def cfun_eq_iff upper_map_map)
278.494 -qed
278.495 -
278.496 -end
278.497 -
278.498 -lemma DEFL_upper: "DEFL('a upper_pd) = upper_defl\<cdot>DEFL('a)"
278.499 -by (rule defl_upper_pd_def)
278.500 -
278.501 -
278.502 -subsection {* Join *}
278.503 -
278.504 -definition
278.505 - upper_join :: "'a upper_pd upper_pd \<rightarrow> 'a upper_pd" where
278.506 - "upper_join = (\<Lambda> xss. upper_bind\<cdot>xss\<cdot>(\<Lambda> xs. xs))"
278.507 -
278.508 -lemma upper_join_unit [simp]:
278.509 - "upper_join\<cdot>{xs}\<sharp> = xs"
278.510 -unfolding upper_join_def by simp
278.511 -
278.512 -lemma upper_join_plus [simp]:
278.513 - "upper_join\<cdot>(xss +\<sharp> yss) = upper_join\<cdot>xss +\<sharp> upper_join\<cdot>yss"
278.514 -unfolding upper_join_def by simp
278.515 -
278.516 -lemma upper_join_bottom [simp]: "upper_join\<cdot>\<bottom> = \<bottom>"
278.517 -unfolding upper_join_def by simp
278.518 -
278.519 -lemma upper_join_map_unit:
278.520 - "upper_join\<cdot>(upper_map\<cdot>upper_unit\<cdot>xs) = xs"
278.521 -by (induct xs rule: upper_pd_induct, simp_all)
278.522 -
278.523 -lemma upper_join_map_join:
278.524 - "upper_join\<cdot>(upper_map\<cdot>upper_join\<cdot>xsss) = upper_join\<cdot>(upper_join\<cdot>xsss)"
278.525 -by (induct xsss rule: upper_pd_induct, simp_all)
278.526 -
278.527 -lemma upper_join_map_map:
278.528 - "upper_join\<cdot>(upper_map\<cdot>(upper_map\<cdot>f)\<cdot>xss) =
278.529 - upper_map\<cdot>f\<cdot>(upper_join\<cdot>xss)"
278.530 -by (induct xss rule: upper_pd_induct, simp_all)
278.531 -
278.532 -end
279.1 --- a/src/HOLCF/document/root.tex Sat Nov 27 14:34:54 2010 -0800
279.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
279.3 @@ -1,35 +0,0 @@
279.4 -
279.5 -% HOLCF/document/root.tex
279.6 -
279.7 -\documentclass[11pt,a4paper]{article}
279.8 -\usepackage{graphicx,isabelle,isabellesym,latexsym}
279.9 -\usepackage[only,bigsqcap]{stmaryrd}
279.10 -\usepackage[latin1]{inputenc}
279.11 -\usepackage{pdfsetup}
279.12 -
279.13 -\urlstyle{rm}
279.14 -\isabellestyle{it}
279.15 -\pagestyle{myheadings}
279.16 -\newcommand{\isasymas}{\textsf{as}}
279.17 -\newcommand{\isasymlazy}{\isamath{\sim}}
279.18 -
279.19 -\begin{document}
279.20 -
279.21 -\title{Isabelle/HOLCF --- Higher-Order Logic of Computable Functions}
279.22 -\maketitle
279.23 -
279.24 -\tableofcontents
279.25 -
279.26 -\begin{center}
279.27 - \includegraphics[scale=0.45]{session_graph}
279.28 -\end{center}
279.29 -
279.30 -\newpage
279.31 -
279.32 -\renewcommand{\isamarkupheader}[1]%
279.33 -{\section{\isabellecontext: #1}\markright{THEORY~``\isabellecontext''}}
279.34 -
279.35 -\parindent 0pt\parskip 0.5ex
279.36 -\input{session}
279.37 -
279.38 -\end{document}
280.1 --- a/src/HOLCF/ex/Dagstuhl.thy Sat Nov 27 14:34:54 2010 -0800
280.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
280.3 @@ -1,92 +0,0 @@
280.4 -theory Dagstuhl
280.5 -imports Stream
280.6 -begin
280.7 -
280.8 -axiomatization
280.9 - y :: "'a"
280.10 -
280.11 -definition
280.12 - YS :: "'a stream" where
280.13 - "YS = fix$(LAM x. y && x)"
280.14 -
280.15 -definition
280.16 - YYS :: "'a stream" where
280.17 - "YYS = fix$(LAM z. y && y && z)"
280.18 -
280.19 -lemma YS_def2: "YS = y && YS"
280.20 - apply (rule trans)
280.21 - apply (rule fix_eq2)
280.22 - apply (rule YS_def [THEN eq_reflection])
280.23 - apply (rule beta_cfun)
280.24 - apply simp
280.25 - done
280.26 -
280.27 -lemma YYS_def2: "YYS = y && y && YYS"
280.28 - apply (rule trans)
280.29 - apply (rule fix_eq2)
280.30 - apply (rule YYS_def [THEN eq_reflection])
280.31 - apply (rule beta_cfun)
280.32 - apply simp
280.33 - done
280.34 -
280.35 -
280.36 -lemma lemma3: "YYS << y && YYS"
280.37 - apply (rule YYS_def [THEN eq_reflection, THEN def_fix_ind])
280.38 - apply simp_all
280.39 - apply (rule monofun_cfun_arg)
280.40 - apply (rule monofun_cfun_arg)
280.41 - apply assumption
280.42 - done
280.43 -
280.44 -lemma lemma4: "y && YYS << YYS"
280.45 - apply (subst YYS_def2)
280.46 - back
280.47 - apply (rule monofun_cfun_arg)
280.48 - apply (rule lemma3)
280.49 - done
280.50 -
280.51 -lemma lemma5: "y && YYS = YYS"
280.52 - apply (rule below_antisym)
280.53 - apply (rule lemma4)
280.54 - apply (rule lemma3)
280.55 - done
280.56 -
280.57 -lemma wir_moel: "YS = YYS"
280.58 - apply (rule stream.take_lemma)
280.59 - apply (induct_tac n)
280.60 - apply (simp (no_asm))
280.61 - apply (subst YS_def2)
280.62 - apply (subst YYS_def2)
280.63 - apply simp
280.64 - apply (rule lemma5 [symmetric, THEN subst])
280.65 - apply (rule refl)
280.66 - done
280.67 -
280.68 -(* ------------------------------------------------------------------------ *)
280.69 -(* Zweite L"osung: Bernhard Möller *)
280.70 -(* statt Beweis von wir_moel "uber take_lemma beidseitige Inclusion *)
280.71 -(* verwendet lemma5 *)
280.72 -(* ------------------------------------------------------------------------ *)
280.73 -
280.74 -lemma lemma6: "YYS << YS"
280.75 - apply (unfold YYS_def)
280.76 - apply (rule fix_least)
280.77 - apply (subst beta_cfun)
280.78 - apply simp
280.79 - apply (simp add: YS_def2 [symmetric])
280.80 - done
280.81 -
280.82 -lemma lemma7: "YS << YYS"
280.83 - apply (rule YS_def [THEN eq_reflection, THEN def_fix_ind])
280.84 - apply simp_all
280.85 - apply (subst lemma5 [symmetric])
280.86 - apply (erule monofun_cfun_arg)
280.87 - done
280.88 -
280.89 -lemma wir_moel': "YS = YYS"
280.90 - apply (rule below_antisym)
280.91 - apply (rule lemma7)
280.92 - apply (rule lemma6)
280.93 - done
280.94 -
280.95 -end
281.1 --- a/src/HOLCF/ex/Dnat.thy Sat Nov 27 14:34:54 2010 -0800
281.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
281.3 @@ -1,72 +0,0 @@
281.4 -(* Title: HOLCF/Dnat.thy
281.5 - Author: Franz Regensburger
281.6 -
281.7 -Theory for the domain of natural numbers dnat = one ++ dnat
281.8 -*)
281.9 -
281.10 -theory Dnat
281.11 -imports HOLCF
281.12 -begin
281.13 -
281.14 -domain dnat = dzero | dsucc (dpred :: dnat)
281.15 -
281.16 -definition
281.17 - iterator :: "dnat -> ('a -> 'a) -> 'a -> 'a" where
281.18 - "iterator = fix $ (LAM h n f x.
281.19 - case n of dzero => x
281.20 - | dsucc $ m => f $ (h $ m $ f $ x))"
281.21 -
281.22 -text {*
281.23 - \medskip Expand fixed point properties.
281.24 -*}
281.25 -
281.26 -lemma iterator_def2:
281.27 - "iterator = (LAM n f x. case n of dzero => x | dsucc$m => f$(iterator$m$f$x))"
281.28 - apply (rule trans)
281.29 - apply (rule fix_eq2)
281.30 - apply (rule iterator_def [THEN eq_reflection])
281.31 - apply (rule beta_cfun)
281.32 - apply simp
281.33 - done
281.34 -
281.35 -text {* \medskip Recursive properties. *}
281.36 -
281.37 -lemma iterator1: "iterator $ UU $ f $ x = UU"
281.38 - apply (subst iterator_def2)
281.39 - apply simp
281.40 - done
281.41 -
281.42 -lemma iterator2: "iterator $ dzero $ f $ x = x"
281.43 - apply (subst iterator_def2)
281.44 - apply simp
281.45 - done
281.46 -
281.47 -lemma iterator3: "n ~= UU ==> iterator $ (dsucc $ n) $ f $ x = f $ (iterator $ n $ f $ x)"
281.48 - apply (rule trans)
281.49 - apply (subst iterator_def2)
281.50 - apply simp
281.51 - apply (rule refl)
281.52 - done
281.53 -
281.54 -lemmas iterator_rews = iterator1 iterator2 iterator3
281.55 -
281.56 -lemma dnat_flat: "ALL x y::dnat. x<<y --> x=UU | x=y"
281.57 - apply (rule allI)
281.58 - apply (induct_tac x)
281.59 - apply fast
281.60 - apply (rule allI)
281.61 - apply (case_tac y)
281.62 - apply simp
281.63 - apply simp
281.64 - apply simp
281.65 - apply (rule allI)
281.66 - apply (case_tac y)
281.67 - apply (fast intro!: UU_I)
281.68 - apply (thin_tac "ALL y. dnat << y --> dnat = UU | dnat = y")
281.69 - apply simp
281.70 - apply (simp (no_asm_simp))
281.71 - apply (drule_tac x="dnata" in spec)
281.72 - apply simp
281.73 - done
281.74 -
281.75 -end
282.1 --- a/src/HOLCF/ex/Domain_Proofs.thy Sat Nov 27 14:34:54 2010 -0800
282.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
282.3 @@ -1,501 +0,0 @@
282.4 -(* Title: HOLCF/ex/Domain_Proofs.thy
282.5 - Author: Brian Huffman
282.6 -*)
282.7 -
282.8 -header {* Internal domain package proofs done manually *}
282.9 -
282.10 -theory Domain_Proofs
282.11 -imports HOLCF
282.12 -begin
282.13 -
282.14 -(*
282.15 -
282.16 -The definitions and proofs below are for the following recursive
282.17 -datatypes:
282.18 -
282.19 -domain 'a foo = Foo1 | Foo2 (lazy 'a) (lazy "'a bar")
282.20 - and 'a bar = Bar (lazy "'a baz \<rightarrow> tr")
282.21 - and 'a baz = Baz (lazy "'a foo convex_pd \<rightarrow> tr")
282.22 -
282.23 -TODO: add another type parameter that is strict,
282.24 -to show the different handling of LIFTDEFL vs. DEFL.
282.25 -
282.26 -*)
282.27 -
282.28 -(********************************************************************)
282.29 -
282.30 -subsection {* Step 1: Define the new type combinators *}
282.31 -
282.32 -text {* Start with the one-step non-recursive version *}
282.33 -
282.34 -definition
282.35 - foo_bar_baz_deflF ::
282.36 - "defl \<rightarrow> defl \<times> defl \<times> defl \<rightarrow> defl \<times> defl \<times> defl"
282.37 -where
282.38 - "foo_bar_baz_deflF = (\<Lambda> a. Abs_cfun (\<lambda>(t1, t2, t3).
282.39 - ( ssum_defl\<cdot>DEFL(one)\<cdot>(sprod_defl\<cdot>a\<cdot>(u_defl\<cdot>t2))
282.40 - , u_defl\<cdot>(sfun_defl\<cdot>(u_defl\<cdot>t3)\<cdot>DEFL(tr))
282.41 - , u_defl\<cdot>(sfun_defl\<cdot>(u_defl\<cdot>(convex_defl\<cdot>t1))\<cdot>DEFL(tr)))))"
282.42 -
282.43 -lemma foo_bar_baz_deflF_beta:
282.44 - "foo_bar_baz_deflF\<cdot>a\<cdot>t =
282.45 - ( ssum_defl\<cdot>DEFL(one)\<cdot>(sprod_defl\<cdot>a\<cdot>(u_defl\<cdot>(fst (snd t))))
282.46 - , u_defl\<cdot>(sfun_defl\<cdot>(u_defl\<cdot>(snd (snd t)))\<cdot>DEFL(tr))
282.47 - , u_defl\<cdot>(sfun_defl\<cdot>(u_defl\<cdot>(convex_defl\<cdot>(fst t)))\<cdot>DEFL(tr)))"
282.48 -unfolding foo_bar_baz_deflF_def
282.49 -by (simp add: split_def)
282.50 -
282.51 -text {* Individual type combinators are projected from the fixed point. *}
282.52 -
282.53 -definition foo_defl :: "defl \<rightarrow> defl"
282.54 -where "foo_defl = (\<Lambda> a. fst (fix\<cdot>(foo_bar_baz_deflF\<cdot>a)))"
282.55 -
282.56 -definition bar_defl :: "defl \<rightarrow> defl"
282.57 -where "bar_defl = (\<Lambda> a. fst (snd (fix\<cdot>(foo_bar_baz_deflF\<cdot>a))))"
282.58 -
282.59 -definition baz_defl :: "defl \<rightarrow> defl"
282.60 -where "baz_defl = (\<Lambda> a. snd (snd (fix\<cdot>(foo_bar_baz_deflF\<cdot>a))))"
282.61 -
282.62 -lemma defl_apply_thms:
282.63 - "foo_defl\<cdot>a = fst (fix\<cdot>(foo_bar_baz_deflF\<cdot>a))"
282.64 - "bar_defl\<cdot>a = fst (snd (fix\<cdot>(foo_bar_baz_deflF\<cdot>a)))"
282.65 - "baz_defl\<cdot>a = snd (snd (fix\<cdot>(foo_bar_baz_deflF\<cdot>a)))"
282.66 -unfolding foo_defl_def bar_defl_def baz_defl_def by simp_all
282.67 -
282.68 -text {* Unfold rules for each combinator. *}
282.69 -
282.70 -lemma foo_defl_unfold:
282.71 - "foo_defl\<cdot>a = ssum_defl\<cdot>DEFL(one)\<cdot>(sprod_defl\<cdot>a\<cdot>(u_defl\<cdot>(bar_defl\<cdot>a)))"
282.72 -unfolding defl_apply_thms by (subst fix_eq, simp add: foo_bar_baz_deflF_beta)
282.73 -
282.74 -lemma bar_defl_unfold: "bar_defl\<cdot>a = u_defl\<cdot>(sfun_defl\<cdot>(u_defl\<cdot>(baz_defl\<cdot>a))\<cdot>DEFL(tr))"
282.75 -unfolding defl_apply_thms by (subst fix_eq, simp add: foo_bar_baz_deflF_beta)
282.76 -
282.77 -lemma baz_defl_unfold: "baz_defl\<cdot>a = u_defl\<cdot>(sfun_defl\<cdot>(u_defl\<cdot>(convex_defl\<cdot>(foo_defl\<cdot>a)))\<cdot>DEFL(tr))"
282.78 -unfolding defl_apply_thms by (subst fix_eq, simp add: foo_bar_baz_deflF_beta)
282.79 -
282.80 -text "The automation for the previous steps will be quite similar to
282.81 -how the fixrec package works."
282.82 -
282.83 -(********************************************************************)
282.84 -
282.85 -subsection {* Step 2: Define types, prove class instances *}
282.86 -
282.87 -text {* Use @{text pcpodef} with the appropriate type combinator. *}
282.88 -
282.89 -pcpodef (open) 'a foo = "defl_set (foo_defl\<cdot>LIFTDEFL('a))"
282.90 -by (rule defl_set_bottom, rule adm_defl_set)
282.91 -
282.92 -pcpodef (open) 'a bar = "defl_set (bar_defl\<cdot>LIFTDEFL('a))"
282.93 -by (rule defl_set_bottom, rule adm_defl_set)
282.94 -
282.95 -pcpodef (open) 'a baz = "defl_set (baz_defl\<cdot>LIFTDEFL('a))"
282.96 -by (rule defl_set_bottom, rule adm_defl_set)
282.97 -
282.98 -text {* Prove rep instance using lemma @{text typedef_rep_class}. *}
282.99 -
282.100 -instantiation foo :: ("domain") liftdomain
282.101 -begin
282.102 -
282.103 -definition emb_foo :: "'a foo \<rightarrow> udom"
282.104 -where "emb_foo \<equiv> (\<Lambda> x. Rep_foo x)"
282.105 -
282.106 -definition prj_foo :: "udom \<rightarrow> 'a foo"
282.107 -where "prj_foo \<equiv> (\<Lambda> y. Abs_foo (cast\<cdot>(foo_defl\<cdot>LIFTDEFL('a))\<cdot>y))"
282.108 -
282.109 -definition defl_foo :: "'a foo itself \<Rightarrow> defl"
282.110 -where "defl_foo \<equiv> \<lambda>a. foo_defl\<cdot>LIFTDEFL('a)"
282.111 -
282.112 -definition
282.113 - "(liftemb :: 'a foo u \<rightarrow> udom) \<equiv> udom_emb u_approx oo u_map\<cdot>emb"
282.114 -
282.115 -definition
282.116 - "(liftprj :: udom \<rightarrow> 'a foo u) \<equiv> u_map\<cdot>prj oo udom_prj u_approx"
282.117 -
282.118 -definition
282.119 - "liftdefl \<equiv> \<lambda>(t::'a foo itself). u_defl\<cdot>DEFL('a foo)"
282.120 -
282.121 -instance
282.122 -apply (rule typedef_liftdomain_class)
282.123 -apply (rule type_definition_foo)
282.124 -apply (rule below_foo_def)
282.125 -apply (rule emb_foo_def)
282.126 -apply (rule prj_foo_def)
282.127 -apply (rule defl_foo_def)
282.128 -apply (rule liftemb_foo_def)
282.129 -apply (rule liftprj_foo_def)
282.130 -apply (rule liftdefl_foo_def)
282.131 -done
282.132 -
282.133 -end
282.134 -
282.135 -instantiation bar :: ("domain") liftdomain
282.136 -begin
282.137 -
282.138 -definition emb_bar :: "'a bar \<rightarrow> udom"
282.139 -where "emb_bar \<equiv> (\<Lambda> x. Rep_bar x)"
282.140 -
282.141 -definition prj_bar :: "udom \<rightarrow> 'a bar"
282.142 -where "prj_bar \<equiv> (\<Lambda> y. Abs_bar (cast\<cdot>(bar_defl\<cdot>LIFTDEFL('a))\<cdot>y))"
282.143 -
282.144 -definition defl_bar :: "'a bar itself \<Rightarrow> defl"
282.145 -where "defl_bar \<equiv> \<lambda>a. bar_defl\<cdot>LIFTDEFL('a)"
282.146 -
282.147 -definition
282.148 - "(liftemb :: 'a bar u \<rightarrow> udom) \<equiv> udom_emb u_approx oo u_map\<cdot>emb"
282.149 -
282.150 -definition
282.151 - "(liftprj :: udom \<rightarrow> 'a bar u) \<equiv> u_map\<cdot>prj oo udom_prj u_approx"
282.152 -
282.153 -definition
282.154 - "liftdefl \<equiv> \<lambda>(t::'a bar itself). u_defl\<cdot>DEFL('a bar)"
282.155 -
282.156 -instance
282.157 -apply (rule typedef_liftdomain_class)
282.158 -apply (rule type_definition_bar)
282.159 -apply (rule below_bar_def)
282.160 -apply (rule emb_bar_def)
282.161 -apply (rule prj_bar_def)
282.162 -apply (rule defl_bar_def)
282.163 -apply (rule liftemb_bar_def)
282.164 -apply (rule liftprj_bar_def)
282.165 -apply (rule liftdefl_bar_def)
282.166 -done
282.167 -
282.168 -end
282.169 -
282.170 -instantiation baz :: ("domain") liftdomain
282.171 -begin
282.172 -
282.173 -definition emb_baz :: "'a baz \<rightarrow> udom"
282.174 -where "emb_baz \<equiv> (\<Lambda> x. Rep_baz x)"
282.175 -
282.176 -definition prj_baz :: "udom \<rightarrow> 'a baz"
282.177 -where "prj_baz \<equiv> (\<Lambda> y. Abs_baz (cast\<cdot>(baz_defl\<cdot>LIFTDEFL('a))\<cdot>y))"
282.178 -
282.179 -definition defl_baz :: "'a baz itself \<Rightarrow> defl"
282.180 -where "defl_baz \<equiv> \<lambda>a. baz_defl\<cdot>LIFTDEFL('a)"
282.181 -
282.182 -definition
282.183 - "(liftemb :: 'a baz u \<rightarrow> udom) \<equiv> udom_emb u_approx oo u_map\<cdot>emb"
282.184 -
282.185 -definition
282.186 - "(liftprj :: udom \<rightarrow> 'a baz u) \<equiv> u_map\<cdot>prj oo udom_prj u_approx"
282.187 -
282.188 -definition
282.189 - "liftdefl \<equiv> \<lambda>(t::'a baz itself). u_defl\<cdot>DEFL('a baz)"
282.190 -
282.191 -instance
282.192 -apply (rule typedef_liftdomain_class)
282.193 -apply (rule type_definition_baz)
282.194 -apply (rule below_baz_def)
282.195 -apply (rule emb_baz_def)
282.196 -apply (rule prj_baz_def)
282.197 -apply (rule defl_baz_def)
282.198 -apply (rule liftemb_baz_def)
282.199 -apply (rule liftprj_baz_def)
282.200 -apply (rule liftdefl_baz_def)
282.201 -done
282.202 -
282.203 -end
282.204 -
282.205 -text {* Prove DEFL rules using lemma @{text typedef_DEFL}. *}
282.206 -
282.207 -lemma DEFL_foo: "DEFL('a foo) = foo_defl\<cdot>LIFTDEFL('a)"
282.208 -apply (rule typedef_DEFL)
282.209 -apply (rule defl_foo_def)
282.210 -done
282.211 -
282.212 -lemma DEFL_bar: "DEFL('a bar) = bar_defl\<cdot>LIFTDEFL('a)"
282.213 -apply (rule typedef_DEFL)
282.214 -apply (rule defl_bar_def)
282.215 -done
282.216 -
282.217 -lemma DEFL_baz: "DEFL('a baz) = baz_defl\<cdot>LIFTDEFL('a)"
282.218 -apply (rule typedef_DEFL)
282.219 -apply (rule defl_baz_def)
282.220 -done
282.221 -
282.222 -text {* Prove DEFL equations using type combinator unfold lemmas. *}
282.223 -
282.224 -lemma DEFL_foo': "DEFL('a foo) = DEFL(one \<oplus> 'a\<^sub>\<bottom> \<otimes> ('a bar)\<^sub>\<bottom>)"
282.225 -unfolding DEFL_foo DEFL_bar DEFL_baz domain_defl_simps
282.226 -by (rule foo_defl_unfold)
282.227 -
282.228 -lemma DEFL_bar': "DEFL('a bar) = DEFL(('a baz \<rightarrow> tr)\<^sub>\<bottom>)"
282.229 -unfolding DEFL_foo DEFL_bar DEFL_baz domain_defl_simps
282.230 -by (rule bar_defl_unfold)
282.231 -
282.232 -lemma DEFL_baz': "DEFL('a baz) = DEFL(('a foo convex_pd \<rightarrow> tr)\<^sub>\<bottom>)"
282.233 -unfolding DEFL_foo DEFL_bar DEFL_baz domain_defl_simps
282.234 -by (rule baz_defl_unfold)
282.235 -
282.236 -(********************************************************************)
282.237 -
282.238 -subsection {* Step 3: Define rep and abs functions *}
282.239 -
282.240 -text {* Define them all using @{text prj} and @{text emb}! *}
282.241 -
282.242 -definition foo_rep :: "'a foo \<rightarrow> one \<oplus> ('a\<^sub>\<bottom> \<otimes> ('a bar)\<^sub>\<bottom>)"
282.243 -where "foo_rep \<equiv> prj oo emb"
282.244 -
282.245 -definition foo_abs :: "one \<oplus> ('a\<^sub>\<bottom> \<otimes> ('a bar)\<^sub>\<bottom>) \<rightarrow> 'a foo"
282.246 -where "foo_abs \<equiv> prj oo emb"
282.247 -
282.248 -definition bar_rep :: "'a bar \<rightarrow> ('a baz \<rightarrow> tr)\<^sub>\<bottom>"
282.249 -where "bar_rep \<equiv> prj oo emb"
282.250 -
282.251 -definition bar_abs :: "('a baz \<rightarrow> tr)\<^sub>\<bottom> \<rightarrow> 'a bar"
282.252 -where "bar_abs \<equiv> prj oo emb"
282.253 -
282.254 -definition baz_rep :: "'a baz \<rightarrow> ('a foo convex_pd \<rightarrow> tr)\<^sub>\<bottom>"
282.255 -where "baz_rep \<equiv> prj oo emb"
282.256 -
282.257 -definition baz_abs :: "('a foo convex_pd \<rightarrow> tr)\<^sub>\<bottom> \<rightarrow> 'a baz"
282.258 -where "baz_abs \<equiv> prj oo emb"
282.259 -
282.260 -text {* Prove isomorphism rules. *}
282.261 -
282.262 -lemma foo_abs_iso: "foo_rep\<cdot>(foo_abs\<cdot>x) = x"
282.263 -by (rule domain_abs_iso [OF DEFL_foo' foo_abs_def foo_rep_def])
282.264 -
282.265 -lemma foo_rep_iso: "foo_abs\<cdot>(foo_rep\<cdot>x) = x"
282.266 -by (rule domain_rep_iso [OF DEFL_foo' foo_abs_def foo_rep_def])
282.267 -
282.268 -lemma bar_abs_iso: "bar_rep\<cdot>(bar_abs\<cdot>x) = x"
282.269 -by (rule domain_abs_iso [OF DEFL_bar' bar_abs_def bar_rep_def])
282.270 -
282.271 -lemma bar_rep_iso: "bar_abs\<cdot>(bar_rep\<cdot>x) = x"
282.272 -by (rule domain_rep_iso [OF DEFL_bar' bar_abs_def bar_rep_def])
282.273 -
282.274 -lemma baz_abs_iso: "baz_rep\<cdot>(baz_abs\<cdot>x) = x"
282.275 -by (rule domain_abs_iso [OF DEFL_baz' baz_abs_def baz_rep_def])
282.276 -
282.277 -lemma baz_rep_iso: "baz_abs\<cdot>(baz_rep\<cdot>x) = x"
282.278 -by (rule domain_rep_iso [OF DEFL_baz' baz_abs_def baz_rep_def])
282.279 -
282.280 -text {* Prove isodefl rules using @{text isodefl_coerce}. *}
282.281 -
282.282 -lemma isodefl_foo_abs:
282.283 - "isodefl d t \<Longrightarrow> isodefl (foo_abs oo d oo foo_rep) t"
282.284 -by (rule isodefl_abs_rep [OF DEFL_foo' foo_abs_def foo_rep_def])
282.285 -
282.286 -lemma isodefl_bar_abs:
282.287 - "isodefl d t \<Longrightarrow> isodefl (bar_abs oo d oo bar_rep) t"
282.288 -by (rule isodefl_abs_rep [OF DEFL_bar' bar_abs_def bar_rep_def])
282.289 -
282.290 -lemma isodefl_baz_abs:
282.291 - "isodefl d t \<Longrightarrow> isodefl (baz_abs oo d oo baz_rep) t"
282.292 -by (rule isodefl_abs_rep [OF DEFL_baz' baz_abs_def baz_rep_def])
282.293 -
282.294 -(********************************************************************)
282.295 -
282.296 -subsection {* Step 4: Define map functions, prove isodefl property *}
282.297 -
282.298 -text {* Start with the one-step non-recursive version. *}
282.299 -
282.300 -text {* Note that the type of the map function depends on which
282.301 -variables are used in positive and negative positions. *}
282.302 -
282.303 -definition
282.304 - foo_bar_baz_mapF ::
282.305 - "('a \<rightarrow> 'b) \<rightarrow>
282.306 - ('a foo \<rightarrow> 'b foo) \<times> ('a bar \<rightarrow> 'b bar) \<times> ('b baz \<rightarrow> 'a baz) \<rightarrow>
282.307 - ('a foo \<rightarrow> 'b foo) \<times> ('a bar \<rightarrow> 'b bar) \<times> ('b baz \<rightarrow> 'a baz)"
282.308 -where
282.309 - "foo_bar_baz_mapF = (\<Lambda> f. Abs_cfun (\<lambda>(d1, d2, d3).
282.310 - (
282.311 - foo_abs oo
282.312 - ssum_map\<cdot>ID\<cdot>(sprod_map\<cdot>(u_map\<cdot>f)\<cdot>(u_map\<cdot>d2))
282.313 - oo foo_rep
282.314 - ,
282.315 - bar_abs oo u_map\<cdot>(cfun_map\<cdot>d3\<cdot>ID) oo bar_rep
282.316 - ,
282.317 - baz_abs oo u_map\<cdot>(cfun_map\<cdot>(convex_map\<cdot>d1)\<cdot>ID) oo baz_rep
282.318 - )))"
282.319 -
282.320 -lemma foo_bar_baz_mapF_beta:
282.321 - "foo_bar_baz_mapF\<cdot>f\<cdot>d =
282.322 - (
282.323 - foo_abs oo
282.324 - ssum_map\<cdot>ID\<cdot>(sprod_map\<cdot>(u_map\<cdot>f)\<cdot>(u_map\<cdot>(fst (snd d))))
282.325 - oo foo_rep
282.326 - ,
282.327 - bar_abs oo u_map\<cdot>(cfun_map\<cdot>(snd (snd d))\<cdot>ID) oo bar_rep
282.328 - ,
282.329 - baz_abs oo u_map\<cdot>(cfun_map\<cdot>(convex_map\<cdot>(fst d))\<cdot>ID) oo baz_rep
282.330 - )"
282.331 -unfolding foo_bar_baz_mapF_def
282.332 -by (simp add: split_def)
282.333 -
282.334 -text {* Individual map functions are projected from the fixed point. *}
282.335 -
282.336 -definition foo_map :: "('a \<rightarrow> 'b) \<rightarrow> ('a foo \<rightarrow> 'b foo)"
282.337 -where "foo_map = (\<Lambda> f. fst (fix\<cdot>(foo_bar_baz_mapF\<cdot>f)))"
282.338 -
282.339 -definition bar_map :: "('a \<rightarrow> 'b) \<rightarrow> ('a bar \<rightarrow> 'b bar)"
282.340 -where "bar_map = (\<Lambda> f. fst (snd (fix\<cdot>(foo_bar_baz_mapF\<cdot>f))))"
282.341 -
282.342 -definition baz_map :: "('a \<rightarrow> 'b) \<rightarrow> ('b baz \<rightarrow> 'a baz)"
282.343 -where "baz_map = (\<Lambda> f. snd (snd (fix\<cdot>(foo_bar_baz_mapF\<cdot>f))))"
282.344 -
282.345 -lemma map_apply_thms:
282.346 - "foo_map\<cdot>f = fst (fix\<cdot>(foo_bar_baz_mapF\<cdot>f))"
282.347 - "bar_map\<cdot>f = fst (snd (fix\<cdot>(foo_bar_baz_mapF\<cdot>f)))"
282.348 - "baz_map\<cdot>f = snd (snd (fix\<cdot>(foo_bar_baz_mapF\<cdot>f)))"
282.349 -unfolding foo_map_def bar_map_def baz_map_def by simp_all
282.350 -
282.351 -text {* Prove isodefl rules for all map functions simultaneously. *}
282.352 -
282.353 -lemma isodefl_foo_bar_baz:
282.354 - assumes isodefl_d: "isodefl (u_map\<cdot>d) t"
282.355 - shows
282.356 - "isodefl (foo_map\<cdot>d) (foo_defl\<cdot>t) \<and>
282.357 - isodefl (bar_map\<cdot>d) (bar_defl\<cdot>t) \<and>
282.358 - isodefl (baz_map\<cdot>d) (baz_defl\<cdot>t)"
282.359 -unfolding map_apply_thms defl_apply_thms
282.360 - apply (rule parallel_fix_ind)
282.361 - apply (intro adm_conj adm_isodefl cont2cont_fst cont2cont_snd cont_id)
282.362 - apply (simp only: fst_strict snd_strict isodefl_bottom simp_thms)
282.363 - apply (simp only: foo_bar_baz_mapF_beta
282.364 - foo_bar_baz_deflF_beta
282.365 - fst_conv snd_conv)
282.366 - apply (elim conjE)
282.367 - apply (intro
282.368 - conjI
282.369 - isodefl_foo_abs
282.370 - isodefl_bar_abs
282.371 - isodefl_baz_abs
282.372 - domain_isodefl
282.373 - isodefl_ID_DEFL isodefl_LIFTDEFL
282.374 - isodefl_d
282.375 - )
282.376 - apply assumption+
282.377 -done
282.378 -
282.379 -lemmas isodefl_foo = isodefl_foo_bar_baz [THEN conjunct1]
282.380 -lemmas isodefl_bar = isodefl_foo_bar_baz [THEN conjunct2, THEN conjunct1]
282.381 -lemmas isodefl_baz = isodefl_foo_bar_baz [THEN conjunct2, THEN conjunct2]
282.382 -
282.383 -text {* Prove map ID lemmas, using isodefl_DEFL_imp_ID *}
282.384 -
282.385 -lemma foo_map_ID: "foo_map\<cdot>ID = ID"
282.386 -apply (rule isodefl_DEFL_imp_ID)
282.387 -apply (subst DEFL_foo)
282.388 -apply (rule isodefl_foo)
282.389 -apply (rule isodefl_LIFTDEFL)
282.390 -done
282.391 -
282.392 -lemma bar_map_ID: "bar_map\<cdot>ID = ID"
282.393 -apply (rule isodefl_DEFL_imp_ID)
282.394 -apply (subst DEFL_bar)
282.395 -apply (rule isodefl_bar)
282.396 -apply (rule isodefl_LIFTDEFL)
282.397 -done
282.398 -
282.399 -lemma baz_map_ID: "baz_map\<cdot>ID = ID"
282.400 -apply (rule isodefl_DEFL_imp_ID)
282.401 -apply (subst DEFL_baz)
282.402 -apply (rule isodefl_baz)
282.403 -apply (rule isodefl_LIFTDEFL)
282.404 -done
282.405 -
282.406 -(********************************************************************)
282.407 -
282.408 -subsection {* Step 5: Define take functions, prove lub-take lemmas *}
282.409 -
282.410 -definition
282.411 - foo_bar_baz_takeF ::
282.412 - "('a foo \<rightarrow> 'a foo) \<times> ('a bar \<rightarrow> 'a bar) \<times> ('a baz \<rightarrow> 'a baz) \<rightarrow>
282.413 - ('a foo \<rightarrow> 'a foo) \<times> ('a bar \<rightarrow> 'a bar) \<times> ('a baz \<rightarrow> 'a baz)"
282.414 -where
282.415 - "foo_bar_baz_takeF = (\<Lambda> p.
282.416 - ( foo_abs oo
282.417 - ssum_map\<cdot>ID\<cdot>(sprod_map\<cdot>(u_map\<cdot>ID)\<cdot>(u_map\<cdot>(fst (snd p))))
282.418 - oo foo_rep
282.419 - , bar_abs oo
282.420 - u_map\<cdot>(cfun_map\<cdot>(snd (snd p))\<cdot>ID) oo bar_rep
282.421 - , baz_abs oo
282.422 - u_map\<cdot>(cfun_map\<cdot>(convex_map\<cdot>(fst p))\<cdot>ID) oo baz_rep
282.423 - ))"
282.424 -
282.425 -lemma foo_bar_baz_takeF_beta:
282.426 - "foo_bar_baz_takeF\<cdot>p =
282.427 - ( foo_abs oo
282.428 - ssum_map\<cdot>ID\<cdot>(sprod_map\<cdot>(u_map\<cdot>ID)\<cdot>(u_map\<cdot>(fst (snd p))))
282.429 - oo foo_rep
282.430 - , bar_abs oo
282.431 - u_map\<cdot>(cfun_map\<cdot>(snd (snd p))\<cdot>ID) oo bar_rep
282.432 - , baz_abs oo
282.433 - u_map\<cdot>(cfun_map\<cdot>(convex_map\<cdot>(fst p))\<cdot>ID) oo baz_rep
282.434 - )"
282.435 -unfolding foo_bar_baz_takeF_def by (rule beta_cfun, simp)
282.436 -
282.437 -definition
282.438 - foo_take :: "nat \<Rightarrow> 'a foo \<rightarrow> 'a foo"
282.439 -where
282.440 - "foo_take = (\<lambda>n. fst (iterate n\<cdot>foo_bar_baz_takeF\<cdot>\<bottom>))"
282.441 -
282.442 -definition
282.443 - bar_take :: "nat \<Rightarrow> 'a bar \<rightarrow> 'a bar"
282.444 -where
282.445 - "bar_take = (\<lambda>n. fst (snd (iterate n\<cdot>foo_bar_baz_takeF\<cdot>\<bottom>)))"
282.446 -
282.447 -definition
282.448 - baz_take :: "nat \<Rightarrow> 'a baz \<rightarrow> 'a baz"
282.449 -where
282.450 - "baz_take = (\<lambda>n. snd (snd (iterate n\<cdot>foo_bar_baz_takeF\<cdot>\<bottom>)))"
282.451 -
282.452 -lemma chain_take_thms: "chain foo_take" "chain bar_take" "chain baz_take"
282.453 -unfolding foo_take_def bar_take_def baz_take_def
282.454 -by (intro ch2ch_fst ch2ch_snd chain_iterate)+
282.455 -
282.456 -lemma take_0_thms: "foo_take 0 = \<bottom>" "bar_take 0 = \<bottom>" "baz_take 0 = \<bottom>"
282.457 -unfolding foo_take_def bar_take_def baz_take_def
282.458 -by (simp only: iterate_0 fst_strict snd_strict)+
282.459 -
282.460 -lemma take_Suc_thms:
282.461 - "foo_take (Suc n) =
282.462 - foo_abs oo ssum_map\<cdot>ID\<cdot>(sprod_map\<cdot>(u_map\<cdot>ID)\<cdot>(u_map\<cdot>(bar_take n))) oo foo_rep"
282.463 - "bar_take (Suc n) =
282.464 - bar_abs oo u_map\<cdot>(cfun_map\<cdot>(baz_take n)\<cdot>ID) oo bar_rep"
282.465 - "baz_take (Suc n) =
282.466 - baz_abs oo u_map\<cdot>(cfun_map\<cdot>(convex_map\<cdot>(foo_take n))\<cdot>ID) oo baz_rep"
282.467 -unfolding foo_take_def bar_take_def baz_take_def
282.468 -by (simp only: iterate_Suc foo_bar_baz_takeF_beta fst_conv snd_conv)+
282.469 -
282.470 -lemma lub_take_lemma:
282.471 - "(\<Squnion>n. foo_take n, \<Squnion>n. bar_take n, \<Squnion>n. baz_take n)
282.472 - = (foo_map\<cdot>(ID::'a \<rightarrow> 'a), bar_map\<cdot>(ID::'a \<rightarrow> 'a), baz_map\<cdot>(ID::'a \<rightarrow> 'a))"
282.473 -apply (simp only: lub_Pair [symmetric] ch2ch_Pair chain_take_thms)
282.474 -apply (simp only: map_apply_thms pair_collapse)
282.475 -apply (simp only: fix_def2)
282.476 -apply (rule lub_eq)
282.477 -apply (rule nat.induct)
282.478 -apply (simp only: iterate_0 Pair_strict take_0_thms)
282.479 -apply (simp only: iterate_Suc Pair_fst_snd_eq fst_conv snd_conv
282.480 - foo_bar_baz_mapF_beta take_Suc_thms simp_thms)
282.481 -done
282.482 -
282.483 -lemma lub_foo_take: "(\<Squnion>n. foo_take n) = ID"
282.484 -apply (rule trans [OF _ foo_map_ID])
282.485 -using lub_take_lemma
282.486 -apply (elim Pair_inject)
282.487 -apply assumption
282.488 -done
282.489 -
282.490 -lemma lub_bar_take: "(\<Squnion>n. bar_take n) = ID"
282.491 -apply (rule trans [OF _ bar_map_ID])
282.492 -using lub_take_lemma
282.493 -apply (elim Pair_inject)
282.494 -apply assumption
282.495 -done
282.496 -
282.497 -lemma lub_baz_take: "(\<Squnion>n. baz_take n) = ID"
282.498 -apply (rule trans [OF _ baz_map_ID])
282.499 -using lub_take_lemma
282.500 -apply (elim Pair_inject)
282.501 -apply assumption
282.502 -done
282.503 -
282.504 -end
283.1 --- a/src/HOLCF/ex/Fix2.thy Sat Nov 27 14:34:54 2010 -0800
283.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
283.3 @@ -1,32 +0,0 @@
283.4 -(* Title: HOLCF/ex/Fix2.thy
283.5 - Author: Franz Regensburger
283.6 -
283.7 -Show that fix is the unique least fixed-point operator.
283.8 -From axioms gix1_def,gix2_def it follows that fix = gix
283.9 -*)
283.10 -
283.11 -theory Fix2
283.12 -imports HOLCF
283.13 -begin
283.14 -
283.15 -axiomatization
283.16 - gix :: "('a->'a)->'a" where
283.17 - gix1_def: "F$(gix$F) = gix$F" and
283.18 - gix2_def: "F$y=y ==> gix$F << y"
283.19 -
283.20 -
283.21 -lemma lemma1: "fix = gix"
283.22 -apply (rule cfun_eqI)
283.23 -apply (rule below_antisym)
283.24 -apply (rule fix_least)
283.25 -apply (rule gix1_def)
283.26 -apply (rule gix2_def)
283.27 -apply (rule fix_eq [symmetric])
283.28 -done
283.29 -
283.30 -lemma lemma2: "gix$F=lub(range(%i. iterate i$F$UU))"
283.31 -apply (rule lemma1 [THEN subst])
283.32 -apply (rule fix_def2)
283.33 -done
283.34 -
283.35 -end
284.1 --- a/src/HOLCF/ex/Focus_ex.thy Sat Nov 27 14:34:54 2010 -0800
284.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
284.3 @@ -1,258 +0,0 @@
284.4 -(* Specification of the following loop back device
284.5 -
284.6 -
284.7 - g
284.8 - --------------------
284.9 - | ------- |
284.10 - x | | | | y
284.11 - ------|---->| |------| ----->
284.12 - | z | f | z |
284.13 - | -->| |--- |
284.14 - | | | | | |
284.15 - | | ------- | |
284.16 - | | | |
284.17 - | <-------------- |
284.18 - | |
284.19 - --------------------
284.20 -
284.21 -
284.22 -First step: Notation in Agent Network Description Language (ANDL)
284.23 ------------------------------------------------------------------
284.24 -
284.25 -agent f
284.26 - input channel i1:'b i2: ('b,'c) tc
284.27 - output channel o1:'c o2: ('b,'c) tc
284.28 -is
284.29 - Rf(i1,i2,o1,o2) (left open in the example)
284.30 -end f
284.31 -
284.32 -agent g
284.33 - input channel x:'b
284.34 - output channel y:'c
284.35 -is network
284.36 - (y,z) = f$(x,z)
284.37 -end network
284.38 -end g
284.39 -
284.40 -
284.41 -Remark: the type of the feedback depends at most on the types of the input and
284.42 - output of g. (No type miracles inside g)
284.43 -
284.44 -Second step: Translation of ANDL specification to HOLCF Specification
284.45 ----------------------------------------------------------------------
284.46 -
284.47 -Specification of agent f ist translated to predicate is_f
284.48 -
284.49 -is_f :: ('b stream * ('b,'c) tc stream ->
284.50 - 'c stream * ('b,'c) tc stream) => bool
284.51 -
284.52 -is_f f = !i1 i2 o1 o2.
284.53 - f$(i1,i2) = (o1,o2) --> Rf(i1,i2,o1,o2)
284.54 -
284.55 -Specification of agent g is translated to predicate is_g which uses
284.56 -predicate is_net_g
284.57 -
284.58 -is_net_g :: ('b stream * ('b,'c) tc stream -> 'c stream * ('b,'c) tc stream) =>
284.59 - 'b stream => 'c stream => bool
284.60 -
284.61 -is_net_g f x y =
284.62 - ? z. (y,z) = f$(x,z) &
284.63 - !oy hz. (oy,hz) = f$(x,hz) --> z << hz
284.64 -
284.65 -
284.66 -is_g :: ('b stream -> 'c stream) => bool
284.67 -
284.68 -is_g g = ? f. is_f f & (!x y. g$x = y --> is_net_g f x y
284.69 -
284.70 -Third step: (show conservativity)
284.71 ------------
284.72 -
284.73 -Suppose we have a model for the theory TH1 which contains the axiom
284.74 -
284.75 - ? f. is_f f
284.76 -
284.77 -In this case there is also a model for the theory TH2 that enriches TH1 by
284.78 -axiom
284.79 -
284.80 - ? g. is_g g
284.81 -
284.82 -The result is proved by showing that there is a definitional extension
284.83 -that extends TH1 by a definition of g.
284.84 -
284.85 -
284.86 -We define:
284.87 -
284.88 -def_g g =
284.89 - (? f. is_f f &
284.90 - g = (LAM x. fst (f$(x,fix$(LAM k. snd (f$(x,k)))))) )
284.91 -
284.92 -Now we prove:
284.93 -
284.94 - (? f. is_f f ) --> (? g. is_g g)
284.95 -
284.96 -using the theorems
284.97 -
284.98 -loopback_eq) def_g = is_g (real work)
284.99 -
284.100 -L1) (? f. is_f f ) --> (? g. def_g g) (trivial)
284.101 -
284.102 -*)
284.103 -
284.104 -theory Focus_ex
284.105 -imports Stream
284.106 -begin
284.107 -
284.108 -typedecl ('a, 'b) tc
284.109 -arities tc:: (pcpo, pcpo) pcpo
284.110 -
284.111 -axiomatization
284.112 - Rf :: "('b stream * ('b,'c) tc stream * 'c stream * ('b,'c) tc stream) => bool"
284.113 -
284.114 -definition
284.115 - is_f :: "('b stream * ('b,'c) tc stream -> 'c stream * ('b,'c) tc stream) => bool" where
284.116 - "is_f f = (!i1 i2 o1 o2. f$(i1,i2) = (o1,o2) --> Rf(i1,i2,o1,o2))"
284.117 -
284.118 -definition
284.119 - is_net_g :: "('b stream *('b,'c) tc stream -> 'c stream * ('b,'c) tc stream) =>
284.120 - 'b stream => 'c stream => bool" where
284.121 - "is_net_g f x y == (? z.
284.122 - (y,z) = f$(x,z) &
284.123 - (!oy hz. (oy,hz) = f$(x,hz) --> z << hz))"
284.124 -
284.125 -definition
284.126 - is_g :: "('b stream -> 'c stream) => bool" where
284.127 - "is_g g == (? f. is_f f & (!x y. g$x = y --> is_net_g f x y))"
284.128 -
284.129 -definition
284.130 - def_g :: "('b stream -> 'c stream) => bool" where
284.131 - "def_g g == (? f. is_f f & g = (LAM x. fst (f$(x,fix$(LAM k. snd (f$(x,k)))))))"
284.132 -
284.133 -
284.134 -(* first some logical trading *)
284.135 -
284.136 -lemma lemma1:
284.137 -"is_g(g) =
284.138 - (? f. is_f(f) & (!x.(? z. (g$x,z) = f$(x,z) &
284.139 - (! w y. (y,w) = f$(x,w) --> z << w))))"
284.140 -apply (simp add: is_g_def is_net_g_def)
284.141 -apply fast
284.142 -done
284.143 -
284.144 -lemma lemma2:
284.145 -"(? f. is_f(f) & (!x. (? z. (g$x,z) = f$(x,z) &
284.146 - (!w y. (y,w) = f$(x,w) --> z << w))))
284.147 - =
284.148 - (? f. is_f(f) & (!x. ? z.
284.149 - g$x = fst (f$(x,z)) &
284.150 - z = snd (f$(x,z)) &
284.151 - (! w y. (y,w) = f$(x,w) --> z << w)))"
284.152 -apply (rule iffI)
284.153 -apply (erule exE)
284.154 -apply (rule_tac x = "f" in exI)
284.155 -apply (erule conjE)+
284.156 -apply (erule conjI)
284.157 -apply (intro strip)
284.158 -apply (erule allE)
284.159 -apply (erule exE)
284.160 -apply (rule_tac x = "z" in exI)
284.161 -apply (erule conjE)+
284.162 -apply (rule conjI)
284.163 -apply (rule_tac [2] conjI)
284.164 -prefer 3 apply (assumption)
284.165 -apply (drule sym)
284.166 -apply (simp)
284.167 -apply (drule sym)
284.168 -apply (simp)
284.169 -apply (erule exE)
284.170 -apply (rule_tac x = "f" in exI)
284.171 -apply (erule conjE)+
284.172 -apply (erule conjI)
284.173 -apply (intro strip)
284.174 -apply (erule allE)
284.175 -apply (erule exE)
284.176 -apply (rule_tac x = "z" in exI)
284.177 -apply (erule conjE)+
284.178 -apply (rule conjI)
284.179 -prefer 2 apply (assumption)
284.180 -apply (rule prod_eqI)
284.181 -apply simp
284.182 -apply simp
284.183 -done
284.184 -
284.185 -lemma lemma3: "def_g(g) --> is_g(g)"
284.186 -apply (tactic {* simp_tac (HOL_ss addsimps [@{thm def_g_def}, @{thm lemma1}, @{thm lemma2}]) 1 *})
284.187 -apply (rule impI)
284.188 -apply (erule exE)
284.189 -apply (rule_tac x = "f" in exI)
284.190 -apply (erule conjE)+
284.191 -apply (erule conjI)
284.192 -apply (intro strip)
284.193 -apply (rule_tac x = "fix$ (LAM k. snd (f$(x,k)))" in exI)
284.194 -apply (rule conjI)
284.195 - apply (simp)
284.196 - apply (rule prod_eqI, simp, simp)
284.197 - apply (rule trans)
284.198 - apply (rule fix_eq)
284.199 - apply (simp (no_asm))
284.200 -apply (intro strip)
284.201 -apply (rule fix_least)
284.202 -apply (simp (no_asm))
284.203 -apply (erule exE)
284.204 -apply (drule sym)
284.205 -back
284.206 -apply simp
284.207 -done
284.208 -
284.209 -lemma lemma4: "is_g(g) --> def_g(g)"
284.210 -apply (tactic {* simp_tac (HOL_ss delsimps (@{thms HOL.ex_simps} @ @{thms HOL.all_simps})
284.211 - addsimps [@{thm lemma1}, @{thm lemma2}, @{thm def_g_def}]) 1 *})
284.212 -apply (rule impI)
284.213 -apply (erule exE)
284.214 -apply (rule_tac x = "f" in exI)
284.215 -apply (erule conjE)+
284.216 -apply (erule conjI)
284.217 -apply (rule cfun_eqI)
284.218 -apply (erule_tac x = "x" in allE)
284.219 -apply (erule exE)
284.220 -apply (erule conjE)+
284.221 -apply (subgoal_tac "fix$ (LAM k. snd (f$(x, k))) = z")
284.222 - apply simp
284.223 -apply (subgoal_tac "! w y. f$(x, w) = (y, w) --> z << w")
284.224 -apply (rule fix_eqI)
284.225 -apply simp
284.226 -apply (subgoal_tac "f$(x, za) = (fst (f$(x,za)) ,za)")
284.227 -apply fast
284.228 -apply (rule prod_eqI, simp, simp)
284.229 -apply (intro strip)
284.230 -apply (erule allE)+
284.231 -apply (erule mp)
284.232 -apply (erule sym)
284.233 -done
284.234 -
284.235 -(* now we assemble the result *)
284.236 -
284.237 -lemma loopback_eq: "def_g = is_g"
284.238 -apply (rule ext)
284.239 -apply (rule iffI)
284.240 -apply (erule lemma3 [THEN mp])
284.241 -apply (erule lemma4 [THEN mp])
284.242 -done
284.243 -
284.244 -lemma L2:
284.245 -"(? f.
284.246 - is_f(f::'b stream * ('b,'c) tc stream -> 'c stream * ('b,'c) tc stream))
284.247 - -->
284.248 - (? g. def_g(g::'b stream -> 'c stream ))"
284.249 -apply (simp add: def_g_def)
284.250 -done
284.251 -
284.252 -theorem conservative_loopback:
284.253 -"(? f.
284.254 - is_f(f::'b stream * ('b,'c) tc stream -> 'c stream * ('b,'c) tc stream))
284.255 - -->
284.256 - (? g. is_g(g::'b stream -> 'c stream ))"
284.257 -apply (rule loopback_eq [THEN subst])
284.258 -apply (rule L2)
284.259 -done
284.260 -
284.261 -end
285.1 --- a/src/HOLCF/ex/Hoare.thy Sat Nov 27 14:34:54 2010 -0800
285.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
285.3 @@ -1,425 +0,0 @@
285.4 -(* Title: HOLCF/ex/hoare.thy
285.5 - Author: Franz Regensburger
285.6 -
285.7 -Theory for an example by C.A.R. Hoare
285.8 -
285.9 -p x = if b1 x
285.10 - then p (g x)
285.11 - else x fi
285.12 -
285.13 -q x = if b1 x orelse b2 x
285.14 - then q (g x)
285.15 - else x fi
285.16 -
285.17 -Prove: for all b1 b2 g .
285.18 - q o p = q
285.19 -
285.20 -In order to get a nice notation we fix the functions b1,b2 and g in the
285.21 -signature of this example
285.22 -
285.23 -*)
285.24 -
285.25 -theory Hoare
285.26 -imports HOLCF
285.27 -begin
285.28 -
285.29 -axiomatization
285.30 - b1 :: "'a -> tr" and
285.31 - b2 :: "'a -> tr" and
285.32 - g :: "'a -> 'a"
285.33 -
285.34 -definition
285.35 - p :: "'a -> 'a" where
285.36 - "p = fix$(LAM f. LAM x. If b1$x then f$(g$x) else x)"
285.37 -
285.38 -definition
285.39 - q :: "'a -> 'a" where
285.40 - "q = fix$(LAM f. LAM x. If b1$x orelse b2$x then f$(g$x) else x)"
285.41 -
285.42 -
285.43 -(* --------- pure HOLCF logic, some little lemmas ------ *)
285.44 -
285.45 -lemma hoare_lemma2: "b~=TT ==> b=FF | b=UU"
285.46 -apply (rule Exh_tr [THEN disjE])
285.47 -apply blast+
285.48 -done
285.49 -
285.50 -lemma hoare_lemma3: " (ALL k. b1$(iterate k$g$x) = TT) | (EX k. b1$(iterate k$g$x)~=TT)"
285.51 -apply blast
285.52 -done
285.53 -
285.54 -lemma hoare_lemma4: "(EX k. b1$(iterate k$g$x) ~= TT) ==>
285.55 - EX k. b1$(iterate k$g$x) = FF | b1$(iterate k$g$x) = UU"
285.56 -apply (erule exE)
285.57 -apply (rule exI)
285.58 -apply (rule hoare_lemma2)
285.59 -apply assumption
285.60 -done
285.61 -
285.62 -lemma hoare_lemma5: "[|(EX k. b1$(iterate k$g$x) ~= TT);
285.63 - k=Least(%n. b1$(iterate n$g$x) ~= TT)|] ==>
285.64 - b1$(iterate k$g$x)=FF | b1$(iterate k$g$x)=UU"
285.65 -apply hypsubst
285.66 -apply (rule hoare_lemma2)
285.67 -apply (erule exE)
285.68 -apply (erule LeastI)
285.69 -done
285.70 -
285.71 -lemma hoare_lemma6: "b=UU ==> b~=TT"
285.72 -apply hypsubst
285.73 -apply (rule dist_eq_tr)
285.74 -done
285.75 -
285.76 -lemma hoare_lemma7: "b=FF ==> b~=TT"
285.77 -apply hypsubst
285.78 -apply (rule dist_eq_tr)
285.79 -done
285.80 -
285.81 -lemma hoare_lemma8: "[|(EX k. b1$(iterate k$g$x) ~= TT);
285.82 - k=Least(%n. b1$(iterate n$g$x) ~= TT)|] ==>
285.83 - ALL m. m < k --> b1$(iterate m$g$x)=TT"
285.84 -apply hypsubst
285.85 -apply (erule exE)
285.86 -apply (intro strip)
285.87 -apply (rule_tac p = "b1$ (iterate m$g$x) " in trE)
285.88 -prefer 2 apply (assumption)
285.89 -apply (rule le_less_trans [THEN less_irrefl [THEN notE]])
285.90 -prefer 2 apply (assumption)
285.91 -apply (rule Least_le)
285.92 -apply (erule hoare_lemma6)
285.93 -apply (rule le_less_trans [THEN less_irrefl [THEN notE]])
285.94 -prefer 2 apply (assumption)
285.95 -apply (rule Least_le)
285.96 -apply (erule hoare_lemma7)
285.97 -done
285.98 -
285.99 -
285.100 -lemma hoare_lemma28: "f$(y::'a)=(UU::tr) ==> f$UU = UU"
285.101 -by (rule strictI)
285.102 -
285.103 -
285.104 -(* ----- access to definitions ----- *)
285.105 -
285.106 -lemma p_def3: "p$x = If b1$x then p$(g$x) else x"
285.107 -apply (rule trans)
285.108 -apply (rule p_def [THEN eq_reflection, THEN fix_eq3])
285.109 -apply simp
285.110 -done
285.111 -
285.112 -lemma q_def3: "q$x = If b1$x orelse b2$x then q$(g$x) else x"
285.113 -apply (rule trans)
285.114 -apply (rule q_def [THEN eq_reflection, THEN fix_eq3])
285.115 -apply simp
285.116 -done
285.117 -
285.118 -(** --------- proofs about iterations of p and q ---------- **)
285.119 -
285.120 -lemma hoare_lemma9: "(ALL m. m< Suc k --> b1$(iterate m$g$x)=TT) -->
285.121 - p$(iterate k$g$x)=p$x"
285.122 -apply (induct_tac k)
285.123 -apply (simp (no_asm))
285.124 -apply (simp (no_asm))
285.125 -apply (intro strip)
285.126 -apply (rule_tac s = "p$ (iterate n$g$x) " in trans)
285.127 -apply (rule trans)
285.128 -apply (rule_tac [2] p_def3 [symmetric])
285.129 -apply (rule_tac s = "TT" and t = "b1$ (iterate n$g$x) " in ssubst)
285.130 -apply (rule mp)
285.131 -apply (erule spec)
285.132 -apply (simp (no_asm) add: less_Suc_eq)
285.133 -apply simp
285.134 -apply (erule mp)
285.135 -apply (intro strip)
285.136 -apply (rule mp)
285.137 -apply (erule spec)
285.138 -apply (erule less_trans)
285.139 -apply simp
285.140 -done
285.141 -
285.142 -lemma hoare_lemma24: "(ALL m. m< Suc k --> b1$(iterate m$g$x)=TT) -->
285.143 - q$(iterate k$g$x)=q$x"
285.144 -apply (induct_tac k)
285.145 -apply (simp (no_asm))
285.146 -apply (simp (no_asm) add: less_Suc_eq)
285.147 -apply (intro strip)
285.148 -apply (rule_tac s = "q$ (iterate n$g$x) " in trans)
285.149 -apply (rule trans)
285.150 -apply (rule_tac [2] q_def3 [symmetric])
285.151 -apply (rule_tac s = "TT" and t = "b1$ (iterate n$g$x) " in ssubst)
285.152 -apply blast
285.153 -apply simp
285.154 -apply (erule mp)
285.155 -apply (intro strip)
285.156 -apply (fast dest!: less_Suc_eq [THEN iffD1])
285.157 -done
285.158 -
285.159 -(* -------- results about p for case (EX k. b1$(iterate k$g$x)~=TT) ------- *)
285.160 -
285.161 -thm hoare_lemma8 [THEN hoare_lemma9 [THEN mp], standard]
285.162 -
285.163 -lemma hoare_lemma10:
285.164 - "EX k. b1$(iterate k$g$x) ~= TT
285.165 - ==> Suc k = (LEAST n. b1$(iterate n$g$x) ~= TT) ==> p$(iterate k$g$x) = p$x"
285.166 - by (rule hoare_lemma8 [THEN hoare_lemma9 [THEN mp]])
285.167 -
285.168 -lemma hoare_lemma11: "(EX n. b1$(iterate n$g$x) ~= TT) ==>
285.169 - k=(LEAST n. b1$(iterate n$g$x) ~= TT) & b1$(iterate k$g$x)=FF
285.170 - --> p$x = iterate k$g$x"
285.171 -apply (case_tac "k")
285.172 -apply hypsubst
285.173 -apply (simp (no_asm))
285.174 -apply (intro strip)
285.175 -apply (erule conjE)
285.176 -apply (rule trans)
285.177 -apply (rule p_def3)
285.178 -apply simp
285.179 -apply hypsubst
285.180 -apply (intro strip)
285.181 -apply (erule conjE)
285.182 -apply (rule trans)
285.183 -apply (erule hoare_lemma10 [symmetric])
285.184 -apply assumption
285.185 -apply (rule trans)
285.186 -apply (rule p_def3)
285.187 -apply (rule_tac s = "TT" and t = "b1$ (iterate nat$g$x) " in ssubst)
285.188 -apply (rule hoare_lemma8 [THEN spec, THEN mp])
285.189 -apply assumption
285.190 -apply assumption
285.191 -apply (simp (no_asm))
285.192 -apply (simp (no_asm))
285.193 -apply (rule trans)
285.194 -apply (rule p_def3)
285.195 -apply (simp (no_asm) del: iterate_Suc add: iterate_Suc [symmetric])
285.196 -apply (erule_tac s = "FF" in ssubst)
285.197 -apply simp
285.198 -done
285.199 -
285.200 -lemma hoare_lemma12: "(EX n. b1$(iterate n$g$x) ~= TT) ==>
285.201 - k=Least(%n. b1$(iterate n$g$x)~=TT) & b1$(iterate k$g$x)=UU
285.202 - --> p$x = UU"
285.203 -apply (case_tac "k")
285.204 -apply hypsubst
285.205 -apply (simp (no_asm))
285.206 -apply (intro strip)
285.207 -apply (erule conjE)
285.208 -apply (rule trans)
285.209 -apply (rule p_def3)
285.210 -apply simp
285.211 -apply hypsubst
285.212 -apply (simp (no_asm))
285.213 -apply (intro strip)
285.214 -apply (erule conjE)
285.215 -apply (rule trans)
285.216 -apply (rule hoare_lemma10 [symmetric])
285.217 -apply assumption
285.218 -apply assumption
285.219 -apply (rule trans)
285.220 -apply (rule p_def3)
285.221 -apply (rule_tac s = "TT" and t = "b1$ (iterate nat$g$x) " in ssubst)
285.222 -apply (rule hoare_lemma8 [THEN spec, THEN mp])
285.223 -apply assumption
285.224 -apply assumption
285.225 -apply (simp (no_asm))
285.226 -apply (simp)
285.227 -apply (rule trans)
285.228 -apply (rule p_def3)
285.229 -apply simp
285.230 -done
285.231 -
285.232 -(* -------- results about p for case (ALL k. b1$(iterate k$g$x)=TT) ------- *)
285.233 -
285.234 -lemma fernpass_lemma: "(ALL k. b1$(iterate k$g$x)=TT) ==> ALL k. p$(iterate k$g$x) = UU"
285.235 -apply (rule p_def [THEN eq_reflection, THEN def_fix_ind])
285.236 -apply simp
285.237 -apply simp
285.238 -apply (simp (no_asm))
285.239 -apply (rule allI)
285.240 -apply (rule_tac s = "TT" and t = "b1$ (iterate k$g$x) " in ssubst)
285.241 -apply (erule spec)
285.242 -apply (simp)
285.243 -apply (rule iterate_Suc [THEN subst])
285.244 -apply (erule spec)
285.245 -done
285.246 -
285.247 -lemma hoare_lemma16: "(ALL k. b1$(iterate k$g$x)=TT) ==> p$x = UU"
285.248 -apply (rule_tac F1 = "g" and t = "x" in iterate_0 [THEN subst])
285.249 -apply (erule fernpass_lemma [THEN spec])
285.250 -done
285.251 -
285.252 -(* -------- results about q for case (ALL k. b1$(iterate k$g$x)=TT) ------- *)
285.253 -
285.254 -lemma hoare_lemma17: "(ALL k. b1$(iterate k$g$x)=TT) ==> ALL k. q$(iterate k$g$x) = UU"
285.255 -apply (rule q_def [THEN eq_reflection, THEN def_fix_ind])
285.256 -apply simp
285.257 -apply simp
285.258 -apply (rule allI)
285.259 -apply (simp (no_asm))
285.260 -apply (rule_tac s = "TT" and t = "b1$ (iterate k$g$x) " in ssubst)
285.261 -apply (erule spec)
285.262 -apply (simp)
285.263 -apply (rule iterate_Suc [THEN subst])
285.264 -apply (erule spec)
285.265 -done
285.266 -
285.267 -lemma hoare_lemma18: "(ALL k. b1$(iterate k$g$x)=TT) ==> q$x = UU"
285.268 -apply (rule_tac F1 = "g" and t = "x" in iterate_0 [THEN subst])
285.269 -apply (erule hoare_lemma17 [THEN spec])
285.270 -done
285.271 -
285.272 -lemma hoare_lemma19:
285.273 - "(ALL k. (b1::'a->tr)$(iterate k$g$x)=TT) ==> b1$(UU::'a) = UU | (ALL y. b1$(y::'a)=TT)"
285.274 -apply (rule flat_codom)
285.275 -apply (rule_tac t = "x1" in iterate_0 [THEN subst])
285.276 -apply (erule spec)
285.277 -done
285.278 -
285.279 -lemma hoare_lemma20: "(ALL y. b1$(y::'a)=TT) ==> ALL k. q$(iterate k$g$(x::'a)) = UU"
285.280 -apply (rule q_def [THEN eq_reflection, THEN def_fix_ind])
285.281 -apply simp
285.282 -apply simp
285.283 -apply (rule allI)
285.284 -apply (simp (no_asm))
285.285 -apply (rule_tac s = "TT" and t = "b1$ (iterate k$g$ (x::'a))" in ssubst)
285.286 -apply (erule spec)
285.287 -apply (simp)
285.288 -apply (rule iterate_Suc [THEN subst])
285.289 -apply (erule spec)
285.290 -done
285.291 -
285.292 -lemma hoare_lemma21: "(ALL y. b1$(y::'a)=TT) ==> q$(x::'a) = UU"
285.293 -apply (rule_tac F1 = "g" and t = "x" in iterate_0 [THEN subst])
285.294 -apply (erule hoare_lemma20 [THEN spec])
285.295 -done
285.296 -
285.297 -lemma hoare_lemma22: "b1$(UU::'a)=UU ==> q$(UU::'a) = UU"
285.298 -apply (subst q_def3)
285.299 -apply simp
285.300 -done
285.301 -
285.302 -(* -------- results about q for case (EX k. b1$(iterate k$g$x) ~= TT) ------- *)
285.303 -
285.304 -lemma hoare_lemma25: "EX k. b1$(iterate k$g$x) ~= TT
285.305 - ==> Suc k = (LEAST n. b1$(iterate n$g$x) ~= TT) ==> q$(iterate k$g$x) = q$x"
285.306 - by (rule hoare_lemma8 [THEN hoare_lemma24 [THEN mp]])
285.307 -
285.308 -lemma hoare_lemma26: "(EX n. b1$(iterate n$g$x)~=TT) ==>
285.309 - k=Least(%n. b1$(iterate n$g$x) ~= TT) & b1$(iterate k$g$x) =FF
285.310 - --> q$x = q$(iterate k$g$x)"
285.311 -apply (case_tac "k")
285.312 -apply hypsubst
285.313 -apply (intro strip)
285.314 -apply (simp (no_asm))
285.315 -apply hypsubst
285.316 -apply (intro strip)
285.317 -apply (erule conjE)
285.318 -apply (rule trans)
285.319 -apply (rule hoare_lemma25 [symmetric])
285.320 -apply assumption
285.321 -apply assumption
285.322 -apply (rule trans)
285.323 -apply (rule q_def3)
285.324 -apply (rule_tac s = "TT" and t = "b1$ (iterate nat$g$x) " in ssubst)
285.325 -apply (rule hoare_lemma8 [THEN spec, THEN mp])
285.326 -apply assumption
285.327 -apply assumption
285.328 -apply (simp (no_asm))
285.329 -apply (simp (no_asm))
285.330 -done
285.331 -
285.332 -
285.333 -lemma hoare_lemma27: "(EX n. b1$(iterate n$g$x) ~= TT) ==>
285.334 - k=Least(%n. b1$(iterate n$g$x)~=TT) & b1$(iterate k$g$x)=UU
285.335 - --> q$x = UU"
285.336 -apply (case_tac "k")
285.337 -apply hypsubst
285.338 -apply (simp (no_asm))
285.339 -apply (intro strip)
285.340 -apply (erule conjE)
285.341 -apply (subst q_def3)
285.342 -apply (simp)
285.343 -apply hypsubst
285.344 -apply (simp (no_asm))
285.345 -apply (intro strip)
285.346 -apply (erule conjE)
285.347 -apply (rule trans)
285.348 -apply (rule hoare_lemma25 [symmetric])
285.349 -apply assumption
285.350 -apply assumption
285.351 -apply (rule trans)
285.352 -apply (rule q_def3)
285.353 -apply (rule_tac s = "TT" and t = "b1$ (iterate nat$g$x) " in ssubst)
285.354 -apply (rule hoare_lemma8 [THEN spec, THEN mp])
285.355 -apply assumption
285.356 -apply assumption
285.357 -apply (simp (no_asm))
285.358 -apply (simp)
285.359 -apply (rule trans)
285.360 -apply (rule q_def3)
285.361 -apply (simp)
285.362 -done
285.363 -
285.364 -(* ------- (ALL k. b1$(iterate k$g$x)=TT) ==> q o p = q ----- *)
285.365 -
285.366 -lemma hoare_lemma23: "(ALL k. b1$(iterate k$g$x)=TT) ==> q$(p$x) = q$x"
285.367 -apply (subst hoare_lemma16)
285.368 -apply assumption
285.369 -apply (rule hoare_lemma19 [THEN disjE])
285.370 -apply assumption
285.371 -apply (simplesubst hoare_lemma18)
285.372 -apply assumption
285.373 -apply (simplesubst hoare_lemma22)
285.374 -apply assumption
285.375 -apply (rule refl)
285.376 -apply (simplesubst hoare_lemma21)
285.377 -apply assumption
285.378 -apply (simplesubst hoare_lemma21)
285.379 -apply assumption
285.380 -apply (rule refl)
285.381 -done
285.382 -
285.383 -(* ------------ EX k. b1~(iterate k$g$x) ~= TT ==> q o p = q ----- *)
285.384 -
285.385 -lemma hoare_lemma29: "EX k. b1$(iterate k$g$x) ~= TT ==> q$(p$x) = q$x"
285.386 -apply (rule hoare_lemma5 [THEN disjE])
285.387 -apply assumption
285.388 -apply (rule refl)
285.389 -apply (subst hoare_lemma11 [THEN mp])
285.390 -apply assumption
285.391 -apply (rule conjI)
285.392 -apply (rule refl)
285.393 -apply assumption
285.394 -apply (rule hoare_lemma26 [THEN mp, THEN subst])
285.395 -apply assumption
285.396 -apply (rule conjI)
285.397 -apply (rule refl)
285.398 -apply assumption
285.399 -apply (rule refl)
285.400 -apply (subst hoare_lemma12 [THEN mp])
285.401 -apply assumption
285.402 -apply (rule conjI)
285.403 -apply (rule refl)
285.404 -apply assumption
285.405 -apply (subst hoare_lemma22)
285.406 -apply (subst hoare_lemma28)
285.407 -apply assumption
285.408 -apply (rule refl)
285.409 -apply (rule sym)
285.410 -apply (subst hoare_lemma27 [THEN mp])
285.411 -apply assumption
285.412 -apply (rule conjI)
285.413 -apply (rule refl)
285.414 -apply assumption
285.415 -apply (rule refl)
285.416 -done
285.417 -
285.418 -(* ------ the main proof q o p = q ------ *)
285.419 -
285.420 -theorem hoare_main: "q oo p = q"
285.421 -apply (rule cfun_eqI)
285.422 -apply (subst cfcomp2)
285.423 -apply (rule hoare_lemma3 [THEN disjE])
285.424 -apply (erule hoare_lemma23)
285.425 -apply (erule hoare_lemma29)
285.426 -done
285.427 -
285.428 -end
286.1 --- a/src/HOLCF/ex/Letrec.thy Sat Nov 27 14:34:54 2010 -0800
286.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
286.3 @@ -1,37 +0,0 @@
286.4 -(* Title: HOLCF/ex/Letrec.thy
286.5 - Author: Brian Huffman
286.6 -*)
286.7 -
286.8 -header {* Recursive let bindings *}
286.9 -
286.10 -theory Letrec
286.11 -imports HOLCF
286.12 -begin
286.13 -
286.14 -default_sort pcpo
286.15 -
286.16 -definition
286.17 - CLetrec :: "('a \<rightarrow> 'a \<times> 'b) \<rightarrow> 'b" where
286.18 - "CLetrec = (\<Lambda> F. snd (F\<cdot>(\<mu> x. fst (F\<cdot>x))))"
286.19 -
286.20 -nonterminals
286.21 - recbinds recbindt recbind
286.22 -
286.23 -syntax
286.24 - "_recbind" :: "['a, 'a] \<Rightarrow> recbind" ("(2_ =/ _)" 10)
286.25 - "" :: "recbind \<Rightarrow> recbindt" ("_")
286.26 - "_recbindt" :: "[recbind, recbindt] \<Rightarrow> recbindt" ("_,/ _")
286.27 - "" :: "recbindt \<Rightarrow> recbinds" ("_")
286.28 - "_recbinds" :: "[recbindt, recbinds] \<Rightarrow> recbinds" ("_;/ _")
286.29 - "_Letrec" :: "[recbinds, 'a] \<Rightarrow> 'a" ("(Letrec (_)/ in (_))" 10)
286.30 -
286.31 -translations
286.32 - (recbindt) "x = a, (y,ys) = (b,bs)" == (recbindt) "(x,y,ys) = (a,b,bs)"
286.33 - (recbindt) "x = a, y = b" == (recbindt) "(x,y) = (a,b)"
286.34 -
286.35 -translations
286.36 - "_Letrec (_recbinds b bs) e" == "_Letrec b (_Letrec bs e)"
286.37 - "Letrec xs = a in (e,es)" == "CONST CLetrec\<cdot>(\<Lambda> xs. (a,e,es))"
286.38 - "Letrec xs = a in e" == "CONST CLetrec\<cdot>(\<Lambda> xs. (a,e))"
286.39 -
286.40 -end
287.1 --- a/src/HOLCF/ex/Loop.thy Sat Nov 27 14:34:54 2010 -0800
287.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
287.3 @@ -1,200 +0,0 @@
287.4 -(* Title: HOLCF/ex/Loop.thy
287.5 - Author: Franz Regensburger
287.6 -*)
287.7 -
287.8 -header {* Theory for a loop primitive like while *}
287.9 -
287.10 -theory Loop
287.11 -imports HOLCF
287.12 -begin
287.13 -
287.14 -definition
287.15 - step :: "('a -> tr)->('a -> 'a)->'a->'a" where
287.16 - "step = (LAM b g x. If b$x then g$x else x)"
287.17 -
287.18 -definition
287.19 - while :: "('a -> tr)->('a -> 'a)->'a->'a" where
287.20 - "while = (LAM b g. fix$(LAM f x. If b$x then f$(g$x) else x))"
287.21 -
287.22 -(* ------------------------------------------------------------------------- *)
287.23 -(* access to definitions *)
287.24 -(* ------------------------------------------------------------------------- *)
287.25 -
287.26 -
287.27 -lemma step_def2: "step$b$g$x = If b$x then g$x else x"
287.28 -apply (unfold step_def)
287.29 -apply simp
287.30 -done
287.31 -
287.32 -lemma while_def2: "while$b$g = fix$(LAM f x. If b$x then f$(g$x) else x)"
287.33 -apply (unfold while_def)
287.34 -apply simp
287.35 -done
287.36 -
287.37 -
287.38 -(* ------------------------------------------------------------------------- *)
287.39 -(* rekursive properties of while *)
287.40 -(* ------------------------------------------------------------------------- *)
287.41 -
287.42 -lemma while_unfold: "while$b$g$x = If b$x then while$b$g$(g$x) else x"
287.43 -apply (rule trans)
287.44 -apply (rule while_def2 [THEN fix_eq5])
287.45 -apply simp
287.46 -done
287.47 -
287.48 -lemma while_unfold2: "ALL x. while$b$g$x = while$b$g$(iterate k$(step$b$g)$x)"
287.49 -apply (induct_tac k)
287.50 -apply simp
287.51 -apply (rule allI)
287.52 -apply (rule trans)
287.53 -apply (rule while_unfold)
287.54 -apply (subst iterate_Suc2)
287.55 -apply (rule trans)
287.56 -apply (erule_tac [2] spec)
287.57 -apply (subst step_def2)
287.58 -apply (rule_tac p = "b$x" in trE)
287.59 -apply simp
287.60 -apply (subst while_unfold)
287.61 -apply (rule_tac s = "UU" and t = "b$UU" in ssubst)
287.62 -apply (erule strictI)
287.63 -apply simp
287.64 -apply simp
287.65 -apply simp
287.66 -apply (subst while_unfold)
287.67 -apply simp
287.68 -done
287.69 -
287.70 -lemma while_unfold3: "while$b$g$x = while$b$g$(step$b$g$x)"
287.71 -apply (rule_tac s = "while$b$g$ (iterate (Suc 0) $ (step$b$g) $x) " in trans)
287.72 -apply (rule while_unfold2 [THEN spec])
287.73 -apply simp
287.74 -done
287.75 -
287.76 -
287.77 -(* ------------------------------------------------------------------------- *)
287.78 -(* properties of while and iterations *)
287.79 -(* ------------------------------------------------------------------------- *)
287.80 -
287.81 -lemma loop_lemma1: "[| EX y. b$y=FF; iterate k$(step$b$g)$x = UU |]
287.82 - ==>iterate(Suc k)$(step$b$g)$x=UU"
287.83 -apply (simp (no_asm))
287.84 -apply (rule trans)
287.85 -apply (rule step_def2)
287.86 -apply simp
287.87 -apply (erule exE)
287.88 -apply (erule flat_codom [THEN disjE])
287.89 -apply simp_all
287.90 -done
287.91 -
287.92 -lemma loop_lemma2: "[|EX y. b$y=FF;iterate (Suc k)$(step$b$g)$x ~=UU |]==>
287.93 - iterate k$(step$b$g)$x ~=UU"
287.94 -apply (blast intro: loop_lemma1)
287.95 -done
287.96 -
287.97 -lemma loop_lemma3 [rule_format (no_asm)]:
287.98 - "[| ALL x. INV x & b$x=TT & g$x~=UU --> INV (g$x);
287.99 - EX y. b$y=FF; INV x |]
287.100 - ==> iterate k$(step$b$g)$x ~=UU --> INV (iterate k$(step$b$g)$x)"
287.101 -apply (induct_tac "k")
287.102 -apply (simp (no_asm_simp))
287.103 -apply (intro strip)
287.104 -apply (simp (no_asm) add: step_def2)
287.105 -apply (rule_tac p = "b$ (iterate n$ (step$b$g) $x) " in trE)
287.106 -apply (erule notE)
287.107 -apply (simp add: step_def2)
287.108 -apply (simp (no_asm_simp))
287.109 -apply (rule mp)
287.110 -apply (erule spec)
287.111 -apply (simp (no_asm_simp) del: iterate_Suc add: loop_lemma2)
287.112 -apply (rule_tac s = "iterate (Suc n) $ (step$b$g) $x"
287.113 - and t = "g$ (iterate n$ (step$b$g) $x) " in ssubst)
287.114 -prefer 2 apply (assumption)
287.115 -apply (simp add: step_def2)
287.116 -apply (drule (1) loop_lemma2, simp)
287.117 -done
287.118 -
287.119 -lemma loop_lemma4 [rule_format]:
287.120 - "ALL x. b$(iterate k$(step$b$g)$x)=FF --> while$b$g$x= iterate k$(step$b$g)$x"
287.121 -apply (induct_tac k)
287.122 -apply (simp (no_asm))
287.123 -apply (intro strip)
287.124 -apply (simplesubst while_unfold)
287.125 -apply simp
287.126 -apply (rule allI)
287.127 -apply (simplesubst iterate_Suc2)
287.128 -apply (intro strip)
287.129 -apply (rule trans)
287.130 -apply (rule while_unfold3)
287.131 -apply simp
287.132 -done
287.133 -
287.134 -lemma loop_lemma5 [rule_format (no_asm)]:
287.135 - "ALL k. b$(iterate k$(step$b$g)$x) ~= FF ==>
287.136 - ALL m. while$b$g$(iterate m$(step$b$g)$x)=UU"
287.137 -apply (simplesubst while_def2)
287.138 -apply (rule fix_ind)
287.139 -apply simp
287.140 -apply simp
287.141 -apply (rule allI)
287.142 -apply (simp (no_asm))
287.143 -apply (rule_tac p = "b$ (iterate m$ (step$b$g) $x) " in trE)
287.144 -apply (simp (no_asm_simp))
287.145 -apply (simp (no_asm_simp))
287.146 -apply (rule_tac s = "xa$ (iterate (Suc m) $ (step$b$g) $x) " in trans)
287.147 -apply (erule_tac [2] spec)
287.148 -apply (rule cfun_arg_cong)
287.149 -apply (rule trans)
287.150 -apply (rule_tac [2] iterate_Suc [symmetric])
287.151 -apply (simp add: step_def2)
287.152 -apply blast
287.153 -done
287.154 -
287.155 -lemma loop_lemma6: "ALL k. b$(iterate k$(step$b$g)$x) ~= FF ==> while$b$g$x=UU"
287.156 -apply (rule_tac t = "x" in iterate_0 [THEN subst])
287.157 -apply (erule loop_lemma5)
287.158 -done
287.159 -
287.160 -lemma loop_lemma7: "while$b$g$x ~= UU ==> EX k. b$(iterate k$(step$b$g)$x) = FF"
287.161 -apply (blast intro: loop_lemma6)
287.162 -done
287.163 -
287.164 -
287.165 -(* ------------------------------------------------------------------------- *)
287.166 -(* an invariant rule for loops *)
287.167 -(* ------------------------------------------------------------------------- *)
287.168 -
287.169 -lemma loop_inv2:
287.170 -"[| (ALL y. INV y & b$y=TT & g$y ~= UU --> INV (g$y));
287.171 - (ALL y. INV y & b$y=FF --> Q y);
287.172 - INV x; while$b$g$x~=UU |] ==> Q (while$b$g$x)"
287.173 -apply (rule_tac P = "%k. b$ (iterate k$ (step$b$g) $x) =FF" in exE)
287.174 -apply (erule loop_lemma7)
287.175 -apply (simplesubst loop_lemma4)
287.176 -apply assumption
287.177 -apply (drule spec, erule mp)
287.178 -apply (rule conjI)
287.179 -prefer 2 apply (assumption)
287.180 -apply (rule loop_lemma3)
287.181 -apply assumption
287.182 -apply (blast intro: loop_lemma6)
287.183 -apply assumption
287.184 -apply (rotate_tac -1)
287.185 -apply (simp add: loop_lemma4)
287.186 -done
287.187 -
287.188 -lemma loop_inv:
287.189 - assumes premP: "P(x)"
287.190 - and premI: "!!y. P y ==> INV y"
287.191 - and premTT: "!!y. [| INV y; b$y=TT; g$y~=UU|] ==> INV (g$y)"
287.192 - and premFF: "!!y. [| INV y; b$y=FF|] ==> Q y"
287.193 - and premW: "while$b$g$x ~= UU"
287.194 - shows "Q (while$b$g$x)"
287.195 -apply (rule loop_inv2)
287.196 -apply (rule_tac [3] premP [THEN premI])
287.197 -apply (rule_tac [3] premW)
287.198 -apply (blast intro: premTT)
287.199 -apply (blast intro: premFF)
287.200 -done
287.201 -
287.202 -end
287.203 -
288.1 --- a/src/HOLCF/ex/Pattern_Match.thy Sat Nov 27 14:34:54 2010 -0800
288.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
288.3 @@ -1,609 +0,0 @@
288.4 -(* Title: HOLCF/ex/Pattern_Match.thy
288.5 - Author: Brian Huffman
288.6 -*)
288.7 -
288.8 -header {* An experimental pattern-matching notation *}
288.9 -
288.10 -theory Pattern_Match
288.11 -imports HOLCF
288.12 -begin
288.13 -
288.14 -default_sort pcpo
288.15 -
288.16 -text {* FIXME: Find a proper way to un-hide constants. *}
288.17 -
288.18 -abbreviation fail :: "'a match"
288.19 -where "fail \<equiv> Fixrec.fail"
288.20 -
288.21 -abbreviation succeed :: "'a \<rightarrow> 'a match"
288.22 -where "succeed \<equiv> Fixrec.succeed"
288.23 -
288.24 -abbreviation run :: "'a match \<rightarrow> 'a"
288.25 -where "run \<equiv> Fixrec.run"
288.26 -
288.27 -subsection {* Fatbar combinator *}
288.28 -
288.29 -definition
288.30 - fatbar :: "('a \<rightarrow> 'b match) \<rightarrow> ('a \<rightarrow> 'b match) \<rightarrow> ('a \<rightarrow> 'b match)" where
288.31 - "fatbar = (\<Lambda> a b x. a\<cdot>x +++ b\<cdot>x)"
288.32 -
288.33 -abbreviation
288.34 - fatbar_syn :: "['a \<rightarrow> 'b match, 'a \<rightarrow> 'b match] \<Rightarrow> 'a \<rightarrow> 'b match" (infixr "\<parallel>" 60) where
288.35 - "m1 \<parallel> m2 == fatbar\<cdot>m1\<cdot>m2"
288.36 -
288.37 -lemma fatbar1: "m\<cdot>x = \<bottom> \<Longrightarrow> (m \<parallel> ms)\<cdot>x = \<bottom>"
288.38 -by (simp add: fatbar_def)
288.39 -
288.40 -lemma fatbar2: "m\<cdot>x = fail \<Longrightarrow> (m \<parallel> ms)\<cdot>x = ms\<cdot>x"
288.41 -by (simp add: fatbar_def)
288.42 -
288.43 -lemma fatbar3: "m\<cdot>x = succeed\<cdot>y \<Longrightarrow> (m \<parallel> ms)\<cdot>x = succeed\<cdot>y"
288.44 -by (simp add: fatbar_def)
288.45 -
288.46 -lemmas fatbar_simps = fatbar1 fatbar2 fatbar3
288.47 -
288.48 -lemma run_fatbar1: "m\<cdot>x = \<bottom> \<Longrightarrow> run\<cdot>((m \<parallel> ms)\<cdot>x) = \<bottom>"
288.49 -by (simp add: fatbar_def)
288.50 -
288.51 -lemma run_fatbar2: "m\<cdot>x = fail \<Longrightarrow> run\<cdot>((m \<parallel> ms)\<cdot>x) = run\<cdot>(ms\<cdot>x)"
288.52 -by (simp add: fatbar_def)
288.53 -
288.54 -lemma run_fatbar3: "m\<cdot>x = succeed\<cdot>y \<Longrightarrow> run\<cdot>((m \<parallel> ms)\<cdot>x) = y"
288.55 -by (simp add: fatbar_def)
288.56 -
288.57 -lemmas run_fatbar_simps [simp] = run_fatbar1 run_fatbar2 run_fatbar3
288.58 -
288.59 -subsection {* Bind operator for match monad *}
288.60 -
288.61 -definition match_bind :: "'a match \<rightarrow> ('a \<rightarrow> 'b match) \<rightarrow> 'b match" where
288.62 - "match_bind = (\<Lambda> m k. sscase\<cdot>(\<Lambda> _. fail)\<cdot>(fup\<cdot>k)\<cdot>(Rep_match m))"
288.63 -
288.64 -lemma match_bind_simps [simp]:
288.65 - "match_bind\<cdot>\<bottom>\<cdot>k = \<bottom>"
288.66 - "match_bind\<cdot>fail\<cdot>k = fail"
288.67 - "match_bind\<cdot>(succeed\<cdot>x)\<cdot>k = k\<cdot>x"
288.68 -unfolding match_bind_def fail_def succeed_def
288.69 -by (simp_all add: cont2cont_Rep_match cont_Abs_match
288.70 - Rep_match_strict Abs_match_inverse)
288.71 -
288.72 -subsection {* Case branch combinator *}
288.73 -
288.74 -definition
288.75 - branch :: "('a \<rightarrow> 'b match) \<Rightarrow> ('b \<rightarrow> 'c) \<rightarrow> ('a \<rightarrow> 'c match)" where
288.76 - "branch p \<equiv> \<Lambda> r x. match_bind\<cdot>(p\<cdot>x)\<cdot>(\<Lambda> y. succeed\<cdot>(r\<cdot>y))"
288.77 -
288.78 -lemma branch_simps:
288.79 - "p\<cdot>x = \<bottom> \<Longrightarrow> branch p\<cdot>r\<cdot>x = \<bottom>"
288.80 - "p\<cdot>x = fail \<Longrightarrow> branch p\<cdot>r\<cdot>x = fail"
288.81 - "p\<cdot>x = succeed\<cdot>y \<Longrightarrow> branch p\<cdot>r\<cdot>x = succeed\<cdot>(r\<cdot>y)"
288.82 -by (simp_all add: branch_def)
288.83 -
288.84 -lemma branch_succeed [simp]: "branch succeed\<cdot>r\<cdot>x = succeed\<cdot>(r\<cdot>x)"
288.85 -by (simp add: branch_def)
288.86 -
288.87 -subsection {* Cases operator *}
288.88 -
288.89 -definition
288.90 - cases :: "'a match \<rightarrow> 'a::pcpo" where
288.91 - "cases = Fixrec.run"
288.92 -
288.93 -text {* rewrite rules for cases *}
288.94 -
288.95 -lemma cases_strict [simp]: "cases\<cdot>\<bottom> = \<bottom>"
288.96 -by (simp add: cases_def)
288.97 -
288.98 -lemma cases_fail [simp]: "cases\<cdot>fail = \<bottom>"
288.99 -by (simp add: cases_def)
288.100 -
288.101 -lemma cases_succeed [simp]: "cases\<cdot>(succeed\<cdot>x) = x"
288.102 -by (simp add: cases_def)
288.103 -
288.104 -subsection {* Case syntax *}
288.105 -
288.106 -nonterminals
288.107 - Case_syn Cases_syn
288.108 -
288.109 -syntax
288.110 - "_Case_syntax":: "['a, Cases_syn] => 'b" ("(Case _ of/ _)" 10)
288.111 - "_Case1" :: "['a, 'b] => Case_syn" ("(2_ =>/ _)" 10)
288.112 - "" :: "Case_syn => Cases_syn" ("_")
288.113 - "_Case2" :: "[Case_syn, Cases_syn] => Cases_syn" ("_/ | _")
288.114 -
288.115 -syntax (xsymbols)
288.116 - "_Case1" :: "['a, 'b] => Case_syn" ("(2_ \<Rightarrow>/ _)" 10)
288.117 -
288.118 -translations
288.119 - "_Case_syntax x ms" == "CONST cases\<cdot>(ms\<cdot>x)"
288.120 - "_Case2 m ms" == "m \<parallel> ms"
288.121 -
288.122 -text {* Parsing Case expressions *}
288.123 -
288.124 -syntax
288.125 - "_pat" :: "'a"
288.126 - "_variable" :: "'a"
288.127 - "_noargs" :: "'a"
288.128 -
288.129 -translations
288.130 - "_Case1 p r" => "CONST branch (_pat p)\<cdot>(_variable p r)"
288.131 - "_variable (_args x y) r" => "CONST csplit\<cdot>(_variable x (_variable y r))"
288.132 - "_variable _noargs r" => "CONST unit_when\<cdot>r"
288.133 -
288.134 -parse_translation {*
288.135 -(* rewrite (_pat x) => (succeed) *)
288.136 -(* rewrite (_variable x t) => (Abs_cfun (%x. t)) *)
288.137 - [(@{syntax_const "_pat"}, fn _ => Syntax.const @{const_syntax Fixrec.succeed}),
288.138 - mk_binder_tr (@{syntax_const "_variable"}, @{const_syntax Abs_cfun})];
288.139 -*}
288.140 -
288.141 -text {* Printing Case expressions *}
288.142 -
288.143 -syntax
288.144 - "_match" :: "'a"
288.145 -
288.146 -print_translation {*
288.147 - let
288.148 - fun dest_LAM (Const (@{const_syntax Rep_cfun},_) $ Const (@{const_syntax unit_when},_) $ t) =
288.149 - (Syntax.const @{syntax_const "_noargs"}, t)
288.150 - | dest_LAM (Const (@{const_syntax Rep_cfun},_) $ Const (@{const_syntax csplit},_) $ t) =
288.151 - let
288.152 - val (v1, t1) = dest_LAM t;
288.153 - val (v2, t2) = dest_LAM t1;
288.154 - in (Syntax.const @{syntax_const "_args"} $ v1 $ v2, t2) end
288.155 - | dest_LAM (Const (@{const_syntax Abs_cfun},_) $ t) =
288.156 - let
288.157 - val abs =
288.158 - case t of Abs abs => abs
288.159 - | _ => ("x", dummyT, incr_boundvars 1 t $ Bound 0);
288.160 - val (x, t') = atomic_abs_tr' abs;
288.161 - in (Syntax.const @{syntax_const "_variable"} $ x, t') end
288.162 - | dest_LAM _ = raise Match; (* too few vars: abort translation *)
288.163 -
288.164 - fun Case1_tr' [Const(@{const_syntax branch},_) $ p, r] =
288.165 - let val (v, t) = dest_LAM r in
288.166 - Syntax.const @{syntax_const "_Case1"} $
288.167 - (Syntax.const @{syntax_const "_match"} $ p $ v) $ t
288.168 - end;
288.169 -
288.170 - in [(@{const_syntax Rep_cfun}, Case1_tr')] end;
288.171 -*}
288.172 -
288.173 -translations
288.174 - "x" <= "_match (CONST succeed) (_variable x)"
288.175 -
288.176 -
288.177 -subsection {* Pattern combinators for data constructors *}
288.178 -
288.179 -types ('a, 'b) pat = "'a \<rightarrow> 'b match"
288.180 -
288.181 -definition
288.182 - cpair_pat :: "('a, 'c) pat \<Rightarrow> ('b, 'd) pat \<Rightarrow> ('a \<times> 'b, 'c \<times> 'd) pat" where
288.183 - "cpair_pat p1 p2 = (\<Lambda>(x, y).
288.184 - match_bind\<cdot>(p1\<cdot>x)\<cdot>(\<Lambda> a. match_bind\<cdot>(p2\<cdot>y)\<cdot>(\<Lambda> b. succeed\<cdot>(a, b))))"
288.185 -
288.186 -definition
288.187 - spair_pat ::
288.188 - "('a, 'c) pat \<Rightarrow> ('b, 'd) pat \<Rightarrow> ('a::pcpo \<otimes> 'b::pcpo, 'c \<times> 'd) pat" where
288.189 - "spair_pat p1 p2 = (\<Lambda>(:x, y:). cpair_pat p1 p2\<cdot>(x, y))"
288.190 -
288.191 -definition
288.192 - sinl_pat :: "('a, 'c) pat \<Rightarrow> ('a::pcpo \<oplus> 'b::pcpo, 'c) pat" where
288.193 - "sinl_pat p = sscase\<cdot>p\<cdot>(\<Lambda> x. fail)"
288.194 -
288.195 -definition
288.196 - sinr_pat :: "('b, 'c) pat \<Rightarrow> ('a::pcpo \<oplus> 'b::pcpo, 'c) pat" where
288.197 - "sinr_pat p = sscase\<cdot>(\<Lambda> x. fail)\<cdot>p"
288.198 -
288.199 -definition
288.200 - up_pat :: "('a, 'b) pat \<Rightarrow> ('a u, 'b) pat" where
288.201 - "up_pat p = fup\<cdot>p"
288.202 -
288.203 -definition
288.204 - TT_pat :: "(tr, unit) pat" where
288.205 - "TT_pat = (\<Lambda> b. If b then succeed\<cdot>() else fail)"
288.206 -
288.207 -definition
288.208 - FF_pat :: "(tr, unit) pat" where
288.209 - "FF_pat = (\<Lambda> b. If b then fail else succeed\<cdot>())"
288.210 -
288.211 -definition
288.212 - ONE_pat :: "(one, unit) pat" where
288.213 - "ONE_pat = (\<Lambda> ONE. succeed\<cdot>())"
288.214 -
288.215 -text {* Parse translations (patterns) *}
288.216 -translations
288.217 - "_pat (XCONST Pair x y)" => "CONST cpair_pat (_pat x) (_pat y)"
288.218 - "_pat (XCONST spair\<cdot>x\<cdot>y)" => "CONST spair_pat (_pat x) (_pat y)"
288.219 - "_pat (XCONST sinl\<cdot>x)" => "CONST sinl_pat (_pat x)"
288.220 - "_pat (XCONST sinr\<cdot>x)" => "CONST sinr_pat (_pat x)"
288.221 - "_pat (XCONST up\<cdot>x)" => "CONST up_pat (_pat x)"
288.222 - "_pat (XCONST TT)" => "CONST TT_pat"
288.223 - "_pat (XCONST FF)" => "CONST FF_pat"
288.224 - "_pat (XCONST ONE)" => "CONST ONE_pat"
288.225 -
288.226 -text {* CONST version is also needed for constructors with special syntax *}
288.227 -translations
288.228 - "_pat (CONST Pair x y)" => "CONST cpair_pat (_pat x) (_pat y)"
288.229 - "_pat (CONST spair\<cdot>x\<cdot>y)" => "CONST spair_pat (_pat x) (_pat y)"
288.230 -
288.231 -text {* Parse translations (variables) *}
288.232 -translations
288.233 - "_variable (XCONST Pair x y) r" => "_variable (_args x y) r"
288.234 - "_variable (XCONST spair\<cdot>x\<cdot>y) r" => "_variable (_args x y) r"
288.235 - "_variable (XCONST sinl\<cdot>x) r" => "_variable x r"
288.236 - "_variable (XCONST sinr\<cdot>x) r" => "_variable x r"
288.237 - "_variable (XCONST up\<cdot>x) r" => "_variable x r"
288.238 - "_variable (XCONST TT) r" => "_variable _noargs r"
288.239 - "_variable (XCONST FF) r" => "_variable _noargs r"
288.240 - "_variable (XCONST ONE) r" => "_variable _noargs r"
288.241 -
288.242 -translations
288.243 - "_variable (CONST Pair x y) r" => "_variable (_args x y) r"
288.244 - "_variable (CONST spair\<cdot>x\<cdot>y) r" => "_variable (_args x y) r"
288.245 -
288.246 -text {* Print translations *}
288.247 -translations
288.248 - "CONST Pair (_match p1 v1) (_match p2 v2)"
288.249 - <= "_match (CONST cpair_pat p1 p2) (_args v1 v2)"
288.250 - "CONST spair\<cdot>(_match p1 v1)\<cdot>(_match p2 v2)"
288.251 - <= "_match (CONST spair_pat p1 p2) (_args v1 v2)"
288.252 - "CONST sinl\<cdot>(_match p1 v1)" <= "_match (CONST sinl_pat p1) v1"
288.253 - "CONST sinr\<cdot>(_match p1 v1)" <= "_match (CONST sinr_pat p1) v1"
288.254 - "CONST up\<cdot>(_match p1 v1)" <= "_match (CONST up_pat p1) v1"
288.255 - "CONST TT" <= "_match (CONST TT_pat) _noargs"
288.256 - "CONST FF" <= "_match (CONST FF_pat) _noargs"
288.257 - "CONST ONE" <= "_match (CONST ONE_pat) _noargs"
288.258 -
288.259 -lemma cpair_pat1:
288.260 - "branch p\<cdot>r\<cdot>x = \<bottom> \<Longrightarrow> branch (cpair_pat p q)\<cdot>(csplit\<cdot>r)\<cdot>(x, y) = \<bottom>"
288.261 -apply (simp add: branch_def cpair_pat_def)
288.262 -apply (cases "p\<cdot>x", simp_all)
288.263 -done
288.264 -
288.265 -lemma cpair_pat2:
288.266 - "branch p\<cdot>r\<cdot>x = fail \<Longrightarrow> branch (cpair_pat p q)\<cdot>(csplit\<cdot>r)\<cdot>(x, y) = fail"
288.267 -apply (simp add: branch_def cpair_pat_def)
288.268 -apply (cases "p\<cdot>x", simp_all)
288.269 -done
288.270 -
288.271 -lemma cpair_pat3:
288.272 - "branch p\<cdot>r\<cdot>x = succeed\<cdot>s \<Longrightarrow>
288.273 - branch (cpair_pat p q)\<cdot>(csplit\<cdot>r)\<cdot>(x, y) = branch q\<cdot>s\<cdot>y"
288.274 -apply (simp add: branch_def cpair_pat_def)
288.275 -apply (cases "p\<cdot>x", simp_all)
288.276 -apply (cases "q\<cdot>y", simp_all)
288.277 -done
288.278 -
288.279 -lemmas cpair_pat [simp] =
288.280 - cpair_pat1 cpair_pat2 cpair_pat3
288.281 -
288.282 -lemma spair_pat [simp]:
288.283 - "branch (spair_pat p1 p2)\<cdot>r\<cdot>\<bottom> = \<bottom>"
288.284 - "\<lbrakk>x \<noteq> \<bottom>; y \<noteq> \<bottom>\<rbrakk>
288.285 - \<Longrightarrow> branch (spair_pat p1 p2)\<cdot>r\<cdot>(:x, y:) =
288.286 - branch (cpair_pat p1 p2)\<cdot>r\<cdot>(x, y)"
288.287 -by (simp_all add: branch_def spair_pat_def)
288.288 -
288.289 -lemma sinl_pat [simp]:
288.290 - "branch (sinl_pat p)\<cdot>r\<cdot>\<bottom> = \<bottom>"
288.291 - "x \<noteq> \<bottom> \<Longrightarrow> branch (sinl_pat p)\<cdot>r\<cdot>(sinl\<cdot>x) = branch p\<cdot>r\<cdot>x"
288.292 - "y \<noteq> \<bottom> \<Longrightarrow> branch (sinl_pat p)\<cdot>r\<cdot>(sinr\<cdot>y) = fail"
288.293 -by (simp_all add: branch_def sinl_pat_def)
288.294 -
288.295 -lemma sinr_pat [simp]:
288.296 - "branch (sinr_pat p)\<cdot>r\<cdot>\<bottom> = \<bottom>"
288.297 - "x \<noteq> \<bottom> \<Longrightarrow> branch (sinr_pat p)\<cdot>r\<cdot>(sinl\<cdot>x) = fail"
288.298 - "y \<noteq> \<bottom> \<Longrightarrow> branch (sinr_pat p)\<cdot>r\<cdot>(sinr\<cdot>y) = branch p\<cdot>r\<cdot>y"
288.299 -by (simp_all add: branch_def sinr_pat_def)
288.300 -
288.301 -lemma up_pat [simp]:
288.302 - "branch (up_pat p)\<cdot>r\<cdot>\<bottom> = \<bottom>"
288.303 - "branch (up_pat p)\<cdot>r\<cdot>(up\<cdot>x) = branch p\<cdot>r\<cdot>x"
288.304 -by (simp_all add: branch_def up_pat_def)
288.305 -
288.306 -lemma TT_pat [simp]:
288.307 - "branch TT_pat\<cdot>(unit_when\<cdot>r)\<cdot>\<bottom> = \<bottom>"
288.308 - "branch TT_pat\<cdot>(unit_when\<cdot>r)\<cdot>TT = succeed\<cdot>r"
288.309 - "branch TT_pat\<cdot>(unit_when\<cdot>r)\<cdot>FF = fail"
288.310 -by (simp_all add: branch_def TT_pat_def)
288.311 -
288.312 -lemma FF_pat [simp]:
288.313 - "branch FF_pat\<cdot>(unit_when\<cdot>r)\<cdot>\<bottom> = \<bottom>"
288.314 - "branch FF_pat\<cdot>(unit_when\<cdot>r)\<cdot>TT = fail"
288.315 - "branch FF_pat\<cdot>(unit_when\<cdot>r)\<cdot>FF = succeed\<cdot>r"
288.316 -by (simp_all add: branch_def FF_pat_def)
288.317 -
288.318 -lemma ONE_pat [simp]:
288.319 - "branch ONE_pat\<cdot>(unit_when\<cdot>r)\<cdot>\<bottom> = \<bottom>"
288.320 - "branch ONE_pat\<cdot>(unit_when\<cdot>r)\<cdot>ONE = succeed\<cdot>r"
288.321 -by (simp_all add: branch_def ONE_pat_def)
288.322 -
288.323 -
288.324 -subsection {* Wildcards, as-patterns, and lazy patterns *}
288.325 -
288.326 -definition
288.327 - wild_pat :: "'a \<rightarrow> unit match" where
288.328 - "wild_pat = (\<Lambda> x. succeed\<cdot>())"
288.329 -
288.330 -definition
288.331 - as_pat :: "('a \<rightarrow> 'b match) \<Rightarrow> 'a \<rightarrow> ('a \<times> 'b) match" where
288.332 - "as_pat p = (\<Lambda> x. match_bind\<cdot>(p\<cdot>x)\<cdot>(\<Lambda> a. succeed\<cdot>(x, a)))"
288.333 -
288.334 -definition
288.335 - lazy_pat :: "('a \<rightarrow> 'b::pcpo match) \<Rightarrow> ('a \<rightarrow> 'b match)" where
288.336 - "lazy_pat p = (\<Lambda> x. succeed\<cdot>(cases\<cdot>(p\<cdot>x)))"
288.337 -
288.338 -text {* Parse translations (patterns) *}
288.339 -translations
288.340 - "_pat _" => "CONST wild_pat"
288.341 -
288.342 -text {* Parse translations (variables) *}
288.343 -translations
288.344 - "_variable _ r" => "_variable _noargs r"
288.345 -
288.346 -text {* Print translations *}
288.347 -translations
288.348 - "_" <= "_match (CONST wild_pat) _noargs"
288.349 -
288.350 -lemma wild_pat [simp]: "branch wild_pat\<cdot>(unit_when\<cdot>r)\<cdot>x = succeed\<cdot>r"
288.351 -by (simp add: branch_def wild_pat_def)
288.352 -
288.353 -lemma as_pat [simp]:
288.354 - "branch (as_pat p)\<cdot>(csplit\<cdot>r)\<cdot>x = branch p\<cdot>(r\<cdot>x)\<cdot>x"
288.355 -apply (simp add: branch_def as_pat_def)
288.356 -apply (cases "p\<cdot>x", simp_all)
288.357 -done
288.358 -
288.359 -lemma lazy_pat [simp]:
288.360 - "branch p\<cdot>r\<cdot>x = \<bottom> \<Longrightarrow> branch (lazy_pat p)\<cdot>r\<cdot>x = succeed\<cdot>(r\<cdot>\<bottom>)"
288.361 - "branch p\<cdot>r\<cdot>x = fail \<Longrightarrow> branch (lazy_pat p)\<cdot>r\<cdot>x = succeed\<cdot>(r\<cdot>\<bottom>)"
288.362 - "branch p\<cdot>r\<cdot>x = succeed\<cdot>s \<Longrightarrow> branch (lazy_pat p)\<cdot>r\<cdot>x = succeed\<cdot>s"
288.363 -apply (simp_all add: branch_def lazy_pat_def)
288.364 -apply (cases "p\<cdot>x", simp_all)+
288.365 -done
288.366 -
288.367 -subsection {* Examples *}
288.368 -
288.369 -term "Case t of (:up\<cdot>(sinl\<cdot>x), sinr\<cdot>y:) \<Rightarrow> (x, y)"
288.370 -
288.371 -term "\<Lambda> t. Case t of up\<cdot>(sinl\<cdot>a) \<Rightarrow> a | up\<cdot>(sinr\<cdot>b) \<Rightarrow> b"
288.372 -
288.373 -term "\<Lambda> t. Case t of (:up\<cdot>(sinl\<cdot>_), sinr\<cdot>x:) \<Rightarrow> x"
288.374 -
288.375 -subsection {* ML code for generating definitions *}
288.376 -
288.377 -ML {*
288.378 -local open HOLCF_Library in
288.379 -
288.380 -infixr 6 ->>;
288.381 -infix 9 ` ;
288.382 -
288.383 -val beta_rules =
288.384 - @{thms beta_cfun cont_id cont_const cont2cont_APP cont2cont_LAM'} @
288.385 - @{thms cont2cont_fst cont2cont_snd cont2cont_Pair};
288.386 -
288.387 -val beta_ss = HOL_basic_ss addsimps (simp_thms @ beta_rules);
288.388 -
288.389 -fun define_consts
288.390 - (specs : (binding * term * mixfix) list)
288.391 - (thy : theory)
288.392 - : (term list * thm list) * theory =
288.393 - let
288.394 - fun mk_decl (b, t, mx) = (b, fastype_of t, mx);
288.395 - val decls = map mk_decl specs;
288.396 - val thy = Cont_Consts.add_consts decls thy;
288.397 - fun mk_const (b, T, mx) = Const (Sign.full_name thy b, T);
288.398 - val consts = map mk_const decls;
288.399 - fun mk_def c (b, t, mx) =
288.400 - (Binding.suffix_name "_def" b, Logic.mk_equals (c, t));
288.401 - val defs = map2 mk_def consts specs;
288.402 - val (def_thms, thy) =
288.403 - Global_Theory.add_defs false (map Thm.no_attributes defs) thy;
288.404 - in
288.405 - ((consts, def_thms), thy)
288.406 - end;
288.407 -
288.408 -fun prove
288.409 - (thy : theory)
288.410 - (defs : thm list)
288.411 - (goal : term)
288.412 - (tacs : {prems: thm list, context: Proof.context} -> tactic list)
288.413 - : thm =
288.414 - let
288.415 - fun tac {prems, context} =
288.416 - rewrite_goals_tac defs THEN
288.417 - EVERY (tacs {prems = map (rewrite_rule defs) prems, context = context})
288.418 - in
288.419 - Goal.prove_global thy [] [] goal tac
288.420 - end;
288.421 -
288.422 -fun get_vars_avoiding
288.423 - (taken : string list)
288.424 - (args : (bool * typ) list)
288.425 - : (term list * term list) =
288.426 - let
288.427 - val Ts = map snd args;
288.428 - val ns = Name.variant_list taken (Datatype_Prop.make_tnames Ts);
288.429 - val vs = map Free (ns ~~ Ts);
288.430 - val nonlazy = map snd (filter_out (fst o fst) (args ~~ vs));
288.431 - in
288.432 - (vs, nonlazy)
288.433 - end;
288.434 -
288.435 -(******************************************************************************)
288.436 -(************** definitions and theorems for pattern combinators **************)
288.437 -(******************************************************************************)
288.438 -
288.439 -fun add_pattern_combinators
288.440 - (bindings : binding list)
288.441 - (spec : (term * (bool * typ) list) list)
288.442 - (lhsT : typ)
288.443 - (exhaust : thm)
288.444 - (case_const : typ -> term)
288.445 - (case_rews : thm list)
288.446 - (thy : theory) =
288.447 - let
288.448 -
288.449 - (* utility functions *)
288.450 - fun mk_pair_pat (p1, p2) =
288.451 - let
288.452 - val T1 = fastype_of p1;
288.453 - val T2 = fastype_of p2;
288.454 - val (U1, V1) = apsnd dest_matchT (dest_cfunT T1);
288.455 - val (U2, V2) = apsnd dest_matchT (dest_cfunT T2);
288.456 - val pat_typ = [T1, T2] --->
288.457 - (mk_prodT (U1, U2) ->> mk_matchT (mk_prodT (V1, V2)));
288.458 - val pat_const = Const (@{const_name cpair_pat}, pat_typ);
288.459 - in
288.460 - pat_const $ p1 $ p2
288.461 - end;
288.462 - fun mk_tuple_pat [] = succeed_const HOLogic.unitT
288.463 - | mk_tuple_pat ps = foldr1 mk_pair_pat ps;
288.464 - fun branch_const (T,U,V) =
288.465 - Const (@{const_name branch},
288.466 - (T ->> mk_matchT U) --> (U ->> V) ->> T ->> mk_matchT V);
288.467 -
288.468 - (* define pattern combinators *)
288.469 - local
288.470 - val tns = map (fst o dest_TFree) (snd (dest_Type lhsT));
288.471 -
288.472 - fun pat_eqn (i, (bind, (con, args))) : binding * term * mixfix =
288.473 - let
288.474 - val pat_bind = Binding.suffix_name "_pat" bind;
288.475 - val Ts = map snd args;
288.476 - val Vs =
288.477 - (map (K "'t") args)
288.478 - |> Datatype_Prop.indexify_names
288.479 - |> Name.variant_list tns
288.480 - |> map (fn t => TFree (t, @{sort pcpo}));
288.481 - val patNs = Datatype_Prop.indexify_names (map (K "pat") args);
288.482 - val patTs = map2 (fn T => fn V => T ->> mk_matchT V) Ts Vs;
288.483 - val pats = map Free (patNs ~~ patTs);
288.484 - val fail = mk_fail (mk_tupleT Vs);
288.485 - val (vs, nonlazy) = get_vars_avoiding patNs args;
288.486 - val rhs = big_lambdas vs (mk_tuple_pat pats ` mk_tuple vs);
288.487 - fun one_fun (j, (_, args')) =
288.488 - let
288.489 - val (vs', nonlazy) = get_vars_avoiding patNs args';
288.490 - in if i = j then rhs else big_lambdas vs' fail end;
288.491 - val funs = map_index one_fun spec;
288.492 - val body = list_ccomb (case_const (mk_matchT (mk_tupleT Vs)), funs);
288.493 - in
288.494 - (pat_bind, lambdas pats body, NoSyn)
288.495 - end;
288.496 - in
288.497 - val ((pat_consts, pat_defs), thy) =
288.498 - define_consts (map_index pat_eqn (bindings ~~ spec)) thy
288.499 - end;
288.500 -
288.501 - (* syntax translations for pattern combinators *)
288.502 - local
288.503 - open Syntax
288.504 - fun syntax c = Syntax.mark_const (fst (dest_Const c));
288.505 - fun app s (l, r) = Syntax.mk_appl (Constant s) [l, r];
288.506 - val capp = app @{const_syntax Rep_cfun};
288.507 - val capps = Library.foldl capp
288.508 -
288.509 - fun app_var x = Syntax.mk_appl (Constant "_variable") [x, Variable "rhs"];
288.510 - fun app_pat x = Syntax.mk_appl (Constant "_pat") [x];
288.511 - fun args_list [] = Constant "_noargs"
288.512 - | args_list xs = foldr1 (app "_args") xs;
288.513 - fun one_case_trans (pat, (con, args)) =
288.514 - let
288.515 - val cname = Constant (syntax con);
288.516 - val pname = Constant (syntax pat);
288.517 - val ns = 1 upto length args;
288.518 - val xs = map (fn n => Variable ("x"^(string_of_int n))) ns;
288.519 - val ps = map (fn n => Variable ("p"^(string_of_int n))) ns;
288.520 - val vs = map (fn n => Variable ("v"^(string_of_int n))) ns;
288.521 - in
288.522 - [ParseRule (app_pat (capps (cname, xs)),
288.523 - mk_appl pname (map app_pat xs)),
288.524 - ParseRule (app_var (capps (cname, xs)),
288.525 - app_var (args_list xs)),
288.526 - PrintRule (capps (cname, ListPair.map (app "_match") (ps,vs)),
288.527 - app "_match" (mk_appl pname ps, args_list vs))]
288.528 - end;
288.529 - val trans_rules : Syntax.ast Syntax.trrule list =
288.530 - maps one_case_trans (pat_consts ~~ spec);
288.531 - in
288.532 - val thy = Sign.add_trrules_i trans_rules thy;
288.533 - end;
288.534 -
288.535 - (* prove strictness and reduction rules of pattern combinators *)
288.536 - local
288.537 - val tns = map (fst o dest_TFree) (snd (dest_Type lhsT));
288.538 - val rn = Name.variant tns "'r";
288.539 - val R = TFree (rn, @{sort pcpo});
288.540 - fun pat_lhs (pat, args) =
288.541 - let
288.542 - val Ts = map snd args;
288.543 - val Vs =
288.544 - (map (K "'t") args)
288.545 - |> Datatype_Prop.indexify_names
288.546 - |> Name.variant_list (rn::tns)
288.547 - |> map (fn t => TFree (t, @{sort pcpo}));
288.548 - val patNs = Datatype_Prop.indexify_names (map (K "pat") args);
288.549 - val patTs = map2 (fn T => fn V => T ->> mk_matchT V) Ts Vs;
288.550 - val pats = map Free (patNs ~~ patTs);
288.551 - val k = Free ("rhs", mk_tupleT Vs ->> R);
288.552 - val branch1 = branch_const (lhsT, mk_tupleT Vs, R);
288.553 - val fun1 = (branch1 $ list_comb (pat, pats)) ` k;
288.554 - val branch2 = branch_const (mk_tupleT Ts, mk_tupleT Vs, R);
288.555 - val fun2 = (branch2 $ mk_tuple_pat pats) ` k;
288.556 - val taken = "rhs" :: patNs;
288.557 - in (fun1, fun2, taken) end;
288.558 - fun pat_strict (pat, (con, args)) =
288.559 - let
288.560 - val (fun1, fun2, taken) = pat_lhs (pat, args);
288.561 - val defs = @{thm branch_def} :: pat_defs;
288.562 - val goal = mk_trp (mk_strict fun1);
288.563 - val rules = @{thms match_bind_simps} @ case_rews;
288.564 - val tacs = [simp_tac (beta_ss addsimps rules) 1];
288.565 - in prove thy defs goal (K tacs) end;
288.566 - fun pat_apps (i, (pat, (con, args))) =
288.567 - let
288.568 - val (fun1, fun2, taken) = pat_lhs (pat, args);
288.569 - fun pat_app (j, (con', args')) =
288.570 - let
288.571 - val (vs, nonlazy) = get_vars_avoiding taken args';
288.572 - val con_app = list_ccomb (con', vs);
288.573 - val assms = map (mk_trp o mk_defined) nonlazy;
288.574 - val rhs = if i = j then fun2 ` mk_tuple vs else mk_fail R;
288.575 - val concl = mk_trp (mk_eq (fun1 ` con_app, rhs));
288.576 - val goal = Logic.list_implies (assms, concl);
288.577 - val defs = @{thm branch_def} :: pat_defs;
288.578 - val rules = @{thms match_bind_simps} @ case_rews;
288.579 - val tacs = [asm_simp_tac (beta_ss addsimps rules) 1];
288.580 - in prove thy defs goal (K tacs) end;
288.581 - in map_index pat_app spec end;
288.582 - in
288.583 - val pat_stricts = map pat_strict (pat_consts ~~ spec);
288.584 - val pat_apps = flat (map_index pat_apps (pat_consts ~~ spec));
288.585 - end;
288.586 -
288.587 - in
288.588 - (pat_stricts @ pat_apps, thy)
288.589 - end
288.590 -
288.591 -end
288.592 -*}
288.593 -
288.594 -(*
288.595 -Cut from HOLCF/Tools/domain_constructors.ML
288.596 -in function add_domain_constructors:
288.597 -
288.598 - ( * define and prove theorems for pattern combinators * )
288.599 - val (pat_thms : thm list, thy : theory) =
288.600 - let
288.601 - val bindings = map #1 spec;
288.602 - fun prep_arg (lazy, sel, T) = (lazy, T);
288.603 - fun prep_con c (b, args, mx) = (c, map prep_arg args);
288.604 - val pat_spec = map2 prep_con con_consts spec;
288.605 - in
288.606 - add_pattern_combinators bindings pat_spec lhsT
288.607 - exhaust case_const cases thy
288.608 - end
288.609 -
288.610 -*)
288.611 -
288.612 -end
289.1 --- a/src/HOLCF/ex/Powerdomain_ex.thy Sat Nov 27 14:34:54 2010 -0800
289.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
289.3 @@ -1,113 +0,0 @@
289.4 -(* Title: HOLCF/ex/Powerdomain_ex.thy
289.5 - Author: Brian Huffman
289.6 -*)
289.7 -
289.8 -header {* Powerdomain examples *}
289.9 -
289.10 -theory Powerdomain_ex
289.11 -imports HOLCF
289.12 -begin
289.13 -
289.14 -subsection {* Monadic sorting example *}
289.15 -
289.16 -domain ordering = LT | EQ | GT
289.17 -
289.18 -definition
289.19 - compare :: "int lift \<rightarrow> int lift \<rightarrow> ordering" where
289.20 - "compare = (FLIFT x y. if x < y then LT else if x = y then EQ else GT)"
289.21 -
289.22 -definition
289.23 - is_le :: "int lift \<rightarrow> int lift \<rightarrow> tr" where
289.24 - "is_le = (\<Lambda> x y. case compare\<cdot>x\<cdot>y of LT \<Rightarrow> TT | EQ \<Rightarrow> TT | GT \<Rightarrow> FF)"
289.25 -
289.26 -definition
289.27 - is_less :: "int lift \<rightarrow> int lift \<rightarrow> tr" where
289.28 - "is_less = (\<Lambda> x y. case compare\<cdot>x\<cdot>y of LT \<Rightarrow> TT | EQ \<Rightarrow> FF | GT \<Rightarrow> FF)"
289.29 -
289.30 -definition
289.31 - r1 :: "(int lift \<times> 'a) \<rightarrow> (int lift \<times> 'a) \<rightarrow> tr convex_pd" where
289.32 - "r1 = (\<Lambda> (x,_) (y,_). case compare\<cdot>x\<cdot>y of
289.33 - LT \<Rightarrow> {TT}\<natural> |
289.34 - EQ \<Rightarrow> {TT, FF}\<natural> |
289.35 - GT \<Rightarrow> {FF}\<natural>)"
289.36 -
289.37 -definition
289.38 - r2 :: "(int lift \<times> 'a) \<rightarrow> (int lift \<times> 'a) \<rightarrow> tr convex_pd" where
289.39 - "r2 = (\<Lambda> (x,_) (y,_). {is_le\<cdot>x\<cdot>y, is_less\<cdot>x\<cdot>y}\<natural>)"
289.40 -
289.41 -lemma r1_r2: "r1\<cdot>(x,a)\<cdot>(y,b) = (r2\<cdot>(x,a)\<cdot>(y,b) :: tr convex_pd)"
289.42 -apply (simp add: r1_def r2_def)
289.43 -apply (simp add: is_le_def is_less_def)
289.44 -apply (cases "compare\<cdot>x\<cdot>y")
289.45 -apply simp_all
289.46 -done
289.47 -
289.48 -
289.49 -subsection {* Picking a leaf from a tree *}
289.50 -
289.51 -domain 'a tree =
289.52 - Node (lazy "'a tree") (lazy "'a tree") |
289.53 - Leaf (lazy "'a")
289.54 -
289.55 -fixrec
289.56 - mirror :: "'a tree \<rightarrow> 'a tree"
289.57 -where
289.58 - mirror_Leaf: "mirror\<cdot>(Leaf\<cdot>a) = Leaf\<cdot>a"
289.59 -| mirror_Node: "mirror\<cdot>(Node\<cdot>l\<cdot>r) = Node\<cdot>(mirror\<cdot>r)\<cdot>(mirror\<cdot>l)"
289.60 -
289.61 -lemma mirror_strict [simp]: "mirror\<cdot>\<bottom> = \<bottom>"
289.62 -by fixrec_simp
289.63 -
289.64 -fixrec
289.65 - pick :: "'a tree \<rightarrow> 'a convex_pd"
289.66 -where
289.67 - pick_Leaf: "pick\<cdot>(Leaf\<cdot>a) = {a}\<natural>"
289.68 -| pick_Node: "pick\<cdot>(Node\<cdot>l\<cdot>r) = pick\<cdot>l +\<natural> pick\<cdot>r"
289.69 -
289.70 -lemma pick_strict [simp]: "pick\<cdot>\<bottom> = \<bottom>"
289.71 -by fixrec_simp
289.72 -
289.73 -lemma pick_mirror: "pick\<cdot>(mirror\<cdot>t) = pick\<cdot>t"
289.74 -by (induct t) (simp_all add: convex_plus_ac)
289.75 -
289.76 -fixrec tree1 :: "int lift tree"
289.77 -where "tree1 = Node\<cdot>(Node\<cdot>(Leaf\<cdot>(Def 1))\<cdot>(Leaf\<cdot>(Def 2)))
289.78 - \<cdot>(Node\<cdot>(Leaf\<cdot>(Def 3))\<cdot>(Leaf\<cdot>(Def 4)))"
289.79 -
289.80 -fixrec tree2 :: "int lift tree"
289.81 -where "tree2 = Node\<cdot>(Node\<cdot>(Leaf\<cdot>(Def 1))\<cdot>(Leaf\<cdot>(Def 2)))
289.82 - \<cdot>(Node\<cdot>\<bottom>\<cdot>(Leaf\<cdot>(Def 4)))"
289.83 -
289.84 -fixrec tree3 :: "int lift tree"
289.85 -where "tree3 = Node\<cdot>(Node\<cdot>(Leaf\<cdot>(Def 1))\<cdot>tree3)
289.86 - \<cdot>(Node\<cdot>(Leaf\<cdot>(Def 3))\<cdot>(Leaf\<cdot>(Def 4)))"
289.87 -
289.88 -declare tree1.simps tree2.simps tree3.simps [simp del]
289.89 -
289.90 -lemma pick_tree1:
289.91 - "pick\<cdot>tree1 = {Def 1, Def 2, Def 3, Def 4}\<natural>"
289.92 -apply (subst tree1.simps)
289.93 -apply simp
289.94 -apply (simp add: convex_plus_ac)
289.95 -done
289.96 -
289.97 -lemma pick_tree2:
289.98 - "pick\<cdot>tree2 = {Def 1, Def 2, \<bottom>, Def 4}\<natural>"
289.99 -apply (subst tree2.simps)
289.100 -apply simp
289.101 -apply (simp add: convex_plus_ac)
289.102 -done
289.103 -
289.104 -lemma pick_tree3:
289.105 - "pick\<cdot>tree3 = {Def 1, \<bottom>, Def 3, Def 4}\<natural>"
289.106 -apply (subst tree3.simps)
289.107 -apply simp
289.108 -apply (induct rule: tree3.induct)
289.109 -apply simp
289.110 -apply simp
289.111 -apply (simp add: convex_plus_ac)
289.112 -apply simp
289.113 -apply (simp add: convex_plus_ac)
289.114 -done
289.115 -
289.116 -end
290.1 --- a/src/HOLCF/ex/ROOT.ML Sat Nov 27 14:34:54 2010 -0800
290.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
290.3 @@ -1,9 +0,0 @@
290.4 -(* Title: HOLCF/ex/ROOT.ML
290.5 -
290.6 -Misc HOLCF examples.
290.7 -*)
290.8 -
290.9 -use_thys ["Dnat", "Dagstuhl", "Focus_ex", "Fix2", "Hoare",
290.10 - "Loop", "Powerdomain_ex", "Domain_Proofs",
290.11 - "Letrec",
290.12 - "Pattern_Match"];
291.1 --- a/src/HOLCF/ex/hoare.txt Sat Nov 27 14:34:54 2010 -0800
291.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
291.3 @@ -1,97 +0,0 @@
291.4 -Proves about loops and tail-recursive functions
291.5 -===============================================
291.6 -
291.7 -Problem A
291.8 -
291.9 -P = while B1 do S od
291.10 -Q = while B1 or B2 do S od
291.11 -
291.12 -Prove P;Q = Q (provided B1, B2 have no side effects)
291.13 -
291.14 -------
291.15 -
291.16 -Looking at the denotational semantics of while, we get
291.17 -
291.18 -Problem B
291.19 -
291.20 -[|B1|]:State->Bool
291.21 -[|B2|]:State->Bool
291.22 -[|S |]:State->State
291.23 -f :State->State
291.24 -
291.25 -p = fix LAM f.LAM x. if [| B1 |] x then f([| S |] x) else x fi
291.26 -q = fix LAM f.LAM x. if [| B1 |] x orelse [|b2 |] x then f([| S |] x) else x fi
291.27 -
291.28 -Prove q o p = q rsp. ALL x.q(p(x))=q(x)
291.29 -
291.30 -Remark: 1. Bool is the three-valued domain {UU,FF,TT} since tests B1 and B2 may
291.31 - not terminate.
291.32 - 2. orelse is the sequential or like in ML
291.33 -
291.34 -----------
291.35 -
291.36 -If we abstract over the structure of stores we get
291.37 -
291.38 -Problem C
291.39 -
291.40 -b1:'a -> Bool
291.41 -b2:'a -> Bool
291.42 -g :'a ->'a
291.43 -h :'a ->'a
291.44 -
291.45 -p = fix LAM h.LAM x. if b1(x) then h(g(x)) else x fi
291.46 -q = fix LAM h.LAM x. if b1(x) orelse b2(x) then h(g(x)) else x fi
291.47 -
291.48 -where g is an abstraction of [| S |]
291.49 -
291.50 -Prove q o p = q
291.51 -
291.52 -Remark: there are no restrictions wrt. definedness or strictness for any of
291.53 - the involved functions.
291.54 -
291.55 -----------
291.56 -
291.57 -In a functional programming language the problem reads as follows:
291.58 -
291.59 -p(x) = if b1(x)
291.60 - then p(g(x))
291.61 - else x fi
291.62 -
291.63 -q(x) = if b1(x) orelse b2(x)
291.64 - then q(g(x))
291.65 - else x fi
291.66 -
291.67 -
291.68 -Prove: q o p = q
291.69 -
291.70 -
291.71 --------------
291.72 -
291.73 -In you like to test the problem in ML (bad guy) you have to introduce
291.74 -formal parameters for b1,b2 and g.
291.75 -
291.76 -fun p b1 g x = if b1(x)
291.77 - then p b1 g (g(x))
291.78 - else x;
291.79 -
291.80 -
291.81 -fun q b1 b2 g x = if b1(x) orelse b2(x)
291.82 - then q b1 b2 g (g(x))
291.83 - else x;
291.84 -
291.85 -Prove: for all b1 b2 g .
291.86 - (q b1 b2 g) o (p b1 g) = (q b1 b2 g)
291.87 -
291.88 -===========
291.89 -
291.90 -It took 4 person-days to formulate and prove the problem C in the
291.91 -Isabelle logic HOLCF. The formalisation was done by conservative extension and
291.92 -all proof principles where derived from pure HOLCF.
291.93 -
291.94 -
291.95 -
291.96 -
291.97 -
291.98 -
291.99 -
291.100 -