--- a/Admin/components/main Wed Dec 11 13:44:16 2024 +0100
+++ b/Admin/components/main Wed Dec 11 13:44:35 2024 +0100
@@ -4,7 +4,7 @@
bib2xhtml-20190409
csdp-6.1.1
cvc4-1.8
-e-3.0.03-1
+e-3.1
easychair-3.5
eptcs-1.7.0
flatlaf-2.6
--- a/NEWS Wed Dec 11 13:44:16 2024 +0100
+++ b/NEWS Wed Dec 11 13:44:35 2024 +0100
@@ -106,6 +106,7 @@
unbundle no abs_syntax
unbundle no floor_ceiling_syntax
unbundle no uminus_syntax
+ unbundle no binomial_syntax
unbundle no funcset_syntax
This is more robust than individual 'no_syntax' / 'no_notation'
--- a/src/HOL/Binomial.thy Wed Dec 11 13:44:16 2024 +0100
+++ b/src/HOL/Binomial.thy Wed Dec 11 13:44:35 2024 +0100
@@ -18,8 +18,13 @@
text \<open>Combinatorial definition\<close>
-definition binomial :: "nat \<Rightarrow> nat \<Rightarrow> nat" (infix \<open>choose\<close> 64)
- where "n choose k = card {K\<in>Pow {0..<n}. card K = k}"
+definition binomial :: "nat \<Rightarrow> nat \<Rightarrow> nat"
+ where "binomial n k = card {K\<in>Pow {0..<n}. card K = k}"
+
+open_bundle binomial_syntax
+begin
+notation binomial (infix \<open>choose\<close> 64)
+end
lemma binomial_right_mono:
assumes "m \<le> n" shows "m choose k \<le> n choose k"
--- a/src/HOL/HOLCF/Adm.thy Wed Dec 11 13:44:16 2024 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,179 +0,0 @@
-(* Title: HOL/HOLCF/Adm.thy
- Author: Franz Regensburger and Brian Huffman
-*)
-
-section \<open>Admissibility and compactness\<close>
-
-theory Adm
- imports Cont
-begin
-
-default_sort cpo
-
-subsection \<open>Definitions\<close>
-
-definition adm :: "('a::cpo \<Rightarrow> bool) \<Rightarrow> bool"
- where "adm P \<longleftrightarrow> (\<forall>Y. chain Y \<longrightarrow> (\<forall>i. P (Y i)) \<longrightarrow> P (\<Squnion>i. Y i))"
-
-lemma admI: "(\<And>Y. \<lbrakk>chain Y; \<forall>i. P (Y i)\<rbrakk> \<Longrightarrow> P (\<Squnion>i. Y i)) \<Longrightarrow> adm P"
- unfolding adm_def by fast
-
-lemma admD: "adm P \<Longrightarrow> chain Y \<Longrightarrow> (\<And>i. P (Y i)) \<Longrightarrow> P (\<Squnion>i. Y i)"
- unfolding adm_def by fast
-
-lemma admD2: "adm (\<lambda>x. \<not> P x) \<Longrightarrow> chain Y \<Longrightarrow> P (\<Squnion>i. Y i) \<Longrightarrow> \<exists>i. P (Y i)"
- unfolding adm_def by fast
-
-lemma triv_admI: "\<forall>x. P x \<Longrightarrow> adm P"
- by (rule admI) (erule spec)
-
-
-subsection \<open>Admissibility on chain-finite types\<close>
-
-text \<open>For chain-finite (easy) types every formula is admissible.\<close>
-
-lemma adm_chfin [simp]: "adm P"
- for P :: "'a::chfin \<Rightarrow> bool"
- by (rule admI, frule chfin, auto simp add: maxinch_is_thelub)
-
-
-subsection \<open>Admissibility of special formulae and propagation\<close>
-
-lemma adm_const [simp]: "adm (\<lambda>x. t)"
- by (rule admI, simp)
-
-lemma adm_conj [simp]: "adm (\<lambda>x. P x) \<Longrightarrow> adm (\<lambda>x. Q x) \<Longrightarrow> adm (\<lambda>x. P x \<and> Q x)"
- by (fast intro: admI elim: admD)
-
-lemma adm_all [simp]: "(\<And>y. adm (\<lambda>x. P x y)) \<Longrightarrow> adm (\<lambda>x. \<forall>y. P x y)"
- by (fast intro: admI elim: admD)
-
-lemma adm_ball [simp]: "(\<And>y. y \<in> A \<Longrightarrow> adm (\<lambda>x. P x y)) \<Longrightarrow> adm (\<lambda>x. \<forall>y\<in>A. P x y)"
- by (fast intro: admI elim: admD)
-
-text \<open>Admissibility for disjunction is hard to prove. It requires 2 lemmas.\<close>
-
-lemma adm_disj_lemma1:
- assumes adm: "adm P"
- assumes chain: "chain Y"
- assumes P: "\<forall>i. \<exists>j\<ge>i. P (Y j)"
- shows "P (\<Squnion>i. Y i)"
-proof -
- define f where "f i = (LEAST j. i \<le> j \<and> P (Y j))" for i
- have chain': "chain (\<lambda>i. Y (f i))"
- unfolding f_def
- apply (rule chainI)
- apply (rule chain_mono [OF chain])
- apply (rule Least_le)
- apply (rule LeastI2_ex)
- apply (simp_all add: P)
- done
- have f1: "\<And>i. i \<le> f i" and f2: "\<And>i. P (Y (f i))"
- using LeastI_ex [OF P [rule_format]] by (simp_all add: f_def)
- have lub_eq: "(\<Squnion>i. Y i) = (\<Squnion>i. Y (f i))"
- apply (rule below_antisym)
- apply (rule lub_mono [OF chain chain'])
- apply (rule chain_mono [OF chain f1])
- apply (rule lub_range_mono [OF _ chain chain'])
- apply clarsimp
- done
- show "P (\<Squnion>i. Y i)"
- unfolding lub_eq using adm chain' f2 by (rule admD)
-qed
-
-lemma adm_disj_lemma2: "\<forall>n::nat. P n \<or> Q n \<Longrightarrow> (\<forall>i. \<exists>j\<ge>i. P j) \<or> (\<forall>i. \<exists>j\<ge>i. Q j)"
- apply (erule contrapos_pp)
- apply (clarsimp, rename_tac a b)
- apply (rule_tac x="max a b" in exI)
- apply simp
- done
-
-lemma adm_disj [simp]: "adm (\<lambda>x. P x) \<Longrightarrow> adm (\<lambda>x. Q x) \<Longrightarrow> adm (\<lambda>x. P x \<or> Q x)"
- apply (rule admI)
- apply (erule adm_disj_lemma2 [THEN disjE])
- apply (erule (2) adm_disj_lemma1 [THEN disjI1])
- apply (erule (2) adm_disj_lemma1 [THEN disjI2])
- done
-
-lemma adm_imp [simp]: "adm (\<lambda>x. \<not> P x) \<Longrightarrow> adm (\<lambda>x. Q x) \<Longrightarrow> adm (\<lambda>x. P x \<longrightarrow> Q x)"
- by (subst imp_conv_disj) (rule adm_disj)
-
-lemma adm_iff [simp]: "adm (\<lambda>x. P x \<longrightarrow> Q x) \<Longrightarrow> adm (\<lambda>x. Q x \<longrightarrow> P x) \<Longrightarrow> adm (\<lambda>x. P x \<longleftrightarrow> Q x)"
- by (subst iff_conv_conj_imp) (rule adm_conj)
-
-text \<open>admissibility and continuity\<close>
-
-lemma adm_below [simp]: "cont (\<lambda>x. u x) \<Longrightarrow> cont (\<lambda>x. v x) \<Longrightarrow> adm (\<lambda>x. u x \<sqsubseteq> v x)"
- by (simp add: adm_def cont2contlubE lub_mono ch2ch_cont)
-
-lemma adm_eq [simp]: "cont (\<lambda>x. u x) \<Longrightarrow> cont (\<lambda>x. v x) \<Longrightarrow> adm (\<lambda>x. u x = v x)"
- by (simp add: po_eq_conv)
-
-lemma adm_subst: "cont (\<lambda>x. t x) \<Longrightarrow> adm P \<Longrightarrow> adm (\<lambda>x. P (t x))"
- by (simp add: adm_def cont2contlubE ch2ch_cont)
-
-lemma adm_not_below [simp]: "cont (\<lambda>x. t x) \<Longrightarrow> adm (\<lambda>x. t x \<notsqsubseteq> u)"
- by (rule admI) (simp add: cont2contlubE ch2ch_cont lub_below_iff)
-
-
-subsection \<open>Compactness\<close>
-
-definition compact :: "'a::cpo \<Rightarrow> bool"
- where "compact k = adm (\<lambda>x. k \<notsqsubseteq> x)"
-
-lemma compactI: "adm (\<lambda>x. k \<notsqsubseteq> x) \<Longrightarrow> compact k"
- unfolding compact_def .
-
-lemma compactD: "compact k \<Longrightarrow> adm (\<lambda>x. k \<notsqsubseteq> x)"
- unfolding compact_def .
-
-lemma compactI2: "(\<And>Y. \<lbrakk>chain Y; x \<sqsubseteq> (\<Squnion>i. Y i)\<rbrakk> \<Longrightarrow> \<exists>i. x \<sqsubseteq> Y i) \<Longrightarrow> compact x"
- unfolding compact_def adm_def by fast
-
-lemma compactD2: "compact x \<Longrightarrow> chain Y \<Longrightarrow> x \<sqsubseteq> (\<Squnion>i. Y i) \<Longrightarrow> \<exists>i. x \<sqsubseteq> Y i"
- unfolding compact_def adm_def by fast
-
-lemma compact_below_lub_iff: "compact x \<Longrightarrow> chain Y \<Longrightarrow> x \<sqsubseteq> (\<Squnion>i. Y i) \<longleftrightarrow> (\<exists>i. x \<sqsubseteq> Y i)"
- by (fast intro: compactD2 elim: below_lub)
-
-lemma compact_chfin [simp]: "compact x"
- for x :: "'a::chfin"
- by (rule compactI [OF adm_chfin])
-
-lemma compact_imp_max_in_chain: "chain Y \<Longrightarrow> compact (\<Squnion>i. Y i) \<Longrightarrow> \<exists>i. max_in_chain i Y"
- apply (drule (1) compactD2, simp)
- apply (erule exE, rule_tac x=i in exI)
- apply (rule max_in_chainI)
- apply (rule below_antisym)
- apply (erule (1) chain_mono)
- apply (erule (1) below_trans [OF is_ub_thelub])
- done
-
-text \<open>admissibility and compactness\<close>
-
-lemma adm_compact_not_below [simp]:
- "compact k \<Longrightarrow> cont (\<lambda>x. t x) \<Longrightarrow> adm (\<lambda>x. k \<notsqsubseteq> t x)"
- unfolding compact_def by (rule adm_subst)
-
-lemma adm_neq_compact [simp]: "compact k \<Longrightarrow> cont (\<lambda>x. t x) \<Longrightarrow> adm (\<lambda>x. t x \<noteq> k)"
- by (simp add: po_eq_conv)
-
-lemma adm_compact_neq [simp]: "compact k \<Longrightarrow> cont (\<lambda>x. t x) \<Longrightarrow> adm (\<lambda>x. k \<noteq> t x)"
- by (simp add: po_eq_conv)
-
-lemma compact_bottom [simp, intro]: "compact \<bottom>"
- by (rule compactI) simp
-
-text \<open>Any upward-closed predicate is admissible.\<close>
-
-lemma adm_upward:
- assumes P: "\<And>x y. \<lbrakk>P x; x \<sqsubseteq> y\<rbrakk> \<Longrightarrow> P y"
- shows "adm P"
- by (rule admI, drule spec, erule P, erule is_ub_thelub)
-
-lemmas adm_lemmas =
- adm_const adm_conj adm_all adm_ball adm_disj adm_imp adm_iff
- adm_below adm_eq adm_not_below
- adm_compact_not_below adm_compact_neq adm_neq_compact
-
-end
--- a/src/HOL/HOLCF/Algebraic.thy Wed Dec 11 13:44:16 2024 +0100
+++ b/src/HOL/HOLCF/Algebraic.thy Wed Dec 11 13:44:35 2024 +0100
@@ -10,6 +10,7 @@
default_sort bifinite
+
subsection \<open>Type constructor for finite deflations\<close>
typedef 'a fin_defl = "{d::'a \<rightarrow> 'a. finite_deflation d}"
@@ -72,6 +73,7 @@
using finite_deflation_Rep_fin_defl
by (rule finite_deflation_imp_compact)
+
subsection \<open>Defining algebraic deflations by ideal completion\<close>
typedef 'a defl = "{S::'a fin_defl set. below.ideal S}"
@@ -147,6 +149,7 @@
lemma inst_defl_pcpo: "\<bottom> = defl_principal (Abs_fin_defl \<bottom>)"
by (rule defl_minimal [THEN bottomI, symmetric])
+
subsection \<open>Applying algebraic deflations\<close>
definition
@@ -215,6 +218,7 @@
lemma cast_strict2 [simp]: "cast\<cdot>A\<cdot>\<bottom> = \<bottom>"
by (rule cast.below [THEN bottomI])
+
subsection \<open>Deflation combinators\<close>
definition
--- a/src/HOL/HOLCF/Bifinite.thy Wed Dec 11 13:44:16 2024 +0100
+++ b/src/HOL/HOLCF/Bifinite.thy Wed Dec 11 13:44:35 2024 +0100
@@ -10,6 +10,7 @@
default_sort cpo
+
subsection \<open>Chains of finite deflations\<close>
locale approx_chain =
@@ -43,6 +44,7 @@
end
+
subsection \<open>Omega-profinite and bifinite domains\<close>
class bifinite = pcpo +
@@ -51,6 +53,7 @@
class profinite = cpo +
assumes profinite: "\<exists>(a::nat \<Rightarrow> 'a\<^sub>\<bottom> \<rightarrow> 'a\<^sub>\<bottom>). approx_chain a"
+
subsection \<open>Building approx chains\<close>
lemma approx_chain_iso:
@@ -155,6 +158,7 @@
using chain_discr_approx lub_discr_approx finite_deflation_discr_approx
by (rule approx_chain.intro)
+
subsection \<open>Class instance proofs\<close>
instance bifinite \<subseteq> profinite
--- a/src/HOL/HOLCF/Cfun.thy Wed Dec 11 13:44:16 2024 +0100
+++ b/src/HOL/HOLCF/Cfun.thy Wed Dec 11 13:44:35 2024 +0100
@@ -6,7 +6,7 @@
section \<open>The type of continuous functions\<close>
theory Cfun
- imports Cpodef Fun_Cpo Product_Cpo
+ imports Cpodef
begin
default_sort cpo
--- a/src/HOL/HOLCF/Compact_Basis.thy Wed Dec 11 13:44:16 2024 +0100
+++ b/src/HOL/HOLCF/Compact_Basis.thy Wed Dec 11 13:44:35 2024 +0100
@@ -10,6 +10,7 @@
default_sort bifinite
+
subsection \<open>A compact basis for powerdomains\<close>
definition "pd_basis = {S::'a compact_basis set. finite S \<and> S \<noteq> {}}"
@@ -40,6 +41,7 @@
(* FIXME: why doesn't ".." or "by (rule exI)" work? *)
qed
+
subsection \<open>Unit and plus constructors\<close>
definition
@@ -91,6 +93,7 @@
apply (rule PDUnit, erule PDPlus [OF PDUnit])
done
+
subsection \<open>Fold operator\<close>
definition
--- a/src/HOL/HOLCF/Completion.thy Wed Dec 11 13:44:16 2024 +0100
+++ b/src/HOL/HOLCF/Completion.thy Wed Dec 11 13:44:35 2024 +0100
@@ -128,6 +128,7 @@
apply (erule (1) below_trans)
done
+
subsection \<open>Lemmas about least upper bounds\<close>
lemma is_ub_thelub_ex: "\<lbrakk>\<exists>u. S <<| u; x \<in> S\<rbrakk> \<Longrightarrow> x \<sqsubseteq> lub S"
@@ -184,6 +185,7 @@
"\<forall>i. Y i \<preceq> Y (Suc i) \<Longrightarrow> chain (\<lambda>i. principal (Y i))"
by (simp add: chainI principal_mono)
+
subsubsection \<open>Principal ideals approximate all elements\<close>
lemma compact_principal [simp]: "compact (principal a)"
@@ -296,6 +298,7 @@
apply (drule (2) admD2, fast, simp)
done
+
subsection \<open>Defining functions in terms of basis elements\<close>
definition
--- a/src/HOL/HOLCF/Cont.thy Wed Dec 11 13:44:16 2024 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,223 +0,0 @@
-(* Title: HOL/HOLCF/Cont.thy
- Author: Franz Regensburger
- Author: Brian Huffman
-*)
-
-section \<open>Continuity and monotonicity\<close>
-
-theory Cont
- imports Pcpo
-begin
-
-text \<open>
- Now we change the default class! Form now on all untyped type variables are
- of default class po
-\<close>
-
-default_sort po
-
-subsection \<open>Definitions\<close>
-
-definition monofun :: "('a \<Rightarrow> 'b) \<Rightarrow> bool" \<comment> \<open>monotonicity\<close>
- where "monofun f \<longleftrightarrow> (\<forall>x y. x \<sqsubseteq> y \<longrightarrow> f x \<sqsubseteq> f y)"
-
-definition cont :: "('a::cpo \<Rightarrow> 'b::cpo) \<Rightarrow> bool"
- where "cont f = (\<forall>Y. chain Y \<longrightarrow> range (\<lambda>i. f (Y i)) <<| f (\<Squnion>i. Y i))"
-
-lemma contI: "(\<And>Y. chain Y \<Longrightarrow> range (\<lambda>i. f (Y i)) <<| f (\<Squnion>i. Y i)) \<Longrightarrow> cont f"
- by (simp add: cont_def)
-
-lemma contE: "cont f \<Longrightarrow> chain Y \<Longrightarrow> range (\<lambda>i. f (Y i)) <<| f (\<Squnion>i. Y i)"
- by (simp add: cont_def)
-
-lemma monofunI: "(\<And>x y. x \<sqsubseteq> y \<Longrightarrow> f x \<sqsubseteq> f y) \<Longrightarrow> monofun f"
- by (simp add: monofun_def)
-
-lemma monofunE: "monofun f \<Longrightarrow> x \<sqsubseteq> y \<Longrightarrow> f x \<sqsubseteq> f y"
- by (simp add: monofun_def)
-
-
-subsection \<open>Equivalence of alternate definition\<close>
-
-text \<open>monotone functions map chains to chains\<close>
-
-lemma ch2ch_monofun: "monofun f \<Longrightarrow> chain Y \<Longrightarrow> chain (\<lambda>i. f (Y i))"
- apply (rule chainI)
- apply (erule monofunE)
- apply (erule chainE)
- done
-
-text \<open>monotone functions map upper bound to upper bounds\<close>
-
-lemma ub2ub_monofun: "monofun f \<Longrightarrow> range Y <| u \<Longrightarrow> range (\<lambda>i. f (Y i)) <| f u"
- apply (rule ub_rangeI)
- apply (erule monofunE)
- apply (erule ub_rangeD)
- done
-
-text \<open>a lemma about binary chains\<close>
-
-lemma binchain_cont: "cont f \<Longrightarrow> x \<sqsubseteq> y \<Longrightarrow> range (\<lambda>i::nat. f (if i = 0 then x else y)) <<| f y"
- apply (subgoal_tac "f (\<Squnion>i::nat. if i = 0 then x else y) = f y")
- apply (erule subst)
- apply (erule contE)
- apply (erule bin_chain)
- apply (rule_tac f=f in arg_cong)
- apply (erule is_lub_bin_chain [THEN lub_eqI])
- done
-
-text \<open>continuity implies monotonicity\<close>
-
-lemma cont2mono: "cont f \<Longrightarrow> monofun f"
- apply (rule monofunI)
- apply (drule (1) binchain_cont)
- apply (drule_tac i=0 in is_lub_rangeD1)
- apply simp
- done
-
-lemmas cont2monofunE = cont2mono [THEN monofunE]
-
-lemmas ch2ch_cont = cont2mono [THEN ch2ch_monofun]
-
-text \<open>continuity implies preservation of lubs\<close>
-
-lemma cont2contlubE: "cont f \<Longrightarrow> chain Y \<Longrightarrow> f (\<Squnion>i. Y i) = (\<Squnion>i. f (Y i))"
- apply (rule lub_eqI [symmetric])
- apply (erule (1) contE)
- done
-
-lemma contI2:
- fixes f :: "'a::cpo \<Rightarrow> 'b::cpo"
- assumes mono: "monofun f"
- assumes below: "\<And>Y. \<lbrakk>chain Y; chain (\<lambda>i. f (Y i))\<rbrakk> \<Longrightarrow> f (\<Squnion>i. Y i) \<sqsubseteq> (\<Squnion>i. f (Y i))"
- shows "cont f"
-proof (rule contI)
- fix Y :: "nat \<Rightarrow> 'a"
- assume Y: "chain Y"
- with mono have fY: "chain (\<lambda>i. f (Y i))"
- by (rule ch2ch_monofun)
- have "(\<Squnion>i. f (Y i)) = f (\<Squnion>i. Y i)"
- apply (rule below_antisym)
- apply (rule lub_below [OF fY])
- apply (rule monofunE [OF mono])
- apply (rule is_ub_thelub [OF Y])
- apply (rule below [OF Y fY])
- done
- with fY show "range (\<lambda>i. f (Y i)) <<| f (\<Squnion>i. Y i)"
- by (rule thelubE)
-qed
-
-
-subsection \<open>Collection of continuity rules\<close>
-
-named_theorems cont2cont "continuity intro rule"
-
-
-subsection \<open>Continuity of basic functions\<close>
-
-text \<open>The identity function is continuous\<close>
-
-lemma cont_id [simp, cont2cont]: "cont (\<lambda>x. x)"
- apply (rule contI)
- apply (erule cpo_lubI)
- done
-
-text \<open>constant functions are continuous\<close>
-
-lemma cont_const [simp, cont2cont]: "cont (\<lambda>x. c)"
- using is_lub_const by (rule contI)
-
-text \<open>application of functions is continuous\<close>
-
-lemma cont_apply:
- fixes f :: "'a::cpo \<Rightarrow> 'b::cpo \<Rightarrow> 'c::cpo" and t :: "'a \<Rightarrow> 'b"
- assumes 1: "cont (\<lambda>x. t x)"
- assumes 2: "\<And>x. cont (\<lambda>y. f x y)"
- assumes 3: "\<And>y. cont (\<lambda>x. f x y)"
- shows "cont (\<lambda>x. (f x) (t x))"
-proof (rule contI2 [OF monofunI])
- fix x y :: "'a"
- assume "x \<sqsubseteq> y"
- then show "f x (t x) \<sqsubseteq> f y (t y)"
- by (auto intro: cont2monofunE [OF 1]
- cont2monofunE [OF 2]
- cont2monofunE [OF 3]
- below_trans)
-next
- fix Y :: "nat \<Rightarrow> 'a"
- assume "chain Y"
- then show "f (\<Squnion>i. Y i) (t (\<Squnion>i. Y i)) \<sqsubseteq> (\<Squnion>i. f (Y i) (t (Y i)))"
- by (simp only: cont2contlubE [OF 1] ch2ch_cont [OF 1]
- cont2contlubE [OF 2] ch2ch_cont [OF 2]
- cont2contlubE [OF 3] ch2ch_cont [OF 3]
- diag_lub below_refl)
-qed
-
-lemma cont_compose: "cont c \<Longrightarrow> cont (\<lambda>x. f x) \<Longrightarrow> cont (\<lambda>x. c (f x))"
- by (rule cont_apply [OF _ _ cont_const])
-
-text \<open>Least upper bounds preserve continuity\<close>
-
-lemma cont2cont_lub [simp]:
- assumes chain: "\<And>x. chain (\<lambda>i. F i x)"
- and cont: "\<And>i. cont (\<lambda>x. F i x)"
- shows "cont (\<lambda>x. \<Squnion>i. F i x)"
- apply (rule contI2)
- apply (simp add: monofunI cont2monofunE [OF cont] lub_mono chain)
- apply (simp add: cont2contlubE [OF cont])
- apply (simp add: diag_lub ch2ch_cont [OF cont] chain)
- done
-
-text \<open>if-then-else is continuous\<close>
-
-lemma cont_if [simp, cont2cont]: "cont f \<Longrightarrow> cont g \<Longrightarrow> cont (\<lambda>x. if b then f x else g x)"
- by (induct b) simp_all
-
-
-subsection \<open>Finite chains and flat pcpos\<close>
-
-text \<open>Monotone functions map finite chains to finite chains.\<close>
-
-lemma monofun_finch2finch: "monofun f \<Longrightarrow> finite_chain Y \<Longrightarrow> finite_chain (\<lambda>n. f (Y n))"
- by (force simp add: finite_chain_def ch2ch_monofun max_in_chain_def)
-
-text \<open>The same holds for continuous functions.\<close>
-
-lemma cont_finch2finch: "cont f \<Longrightarrow> finite_chain Y \<Longrightarrow> finite_chain (\<lambda>n. f (Y n))"
- by (rule cont2mono [THEN monofun_finch2finch])
-
-text \<open>All monotone functions with chain-finite domain are continuous.\<close>
-
-lemma chfindom_monofun2cont: "monofun f \<Longrightarrow> cont f"
- for f :: "'a::chfin \<Rightarrow> 'b::cpo"
- apply (erule contI2)
- apply (frule chfin2finch)
- apply (clarsimp simp add: finite_chain_def)
- apply (subgoal_tac "max_in_chain i (\<lambda>i. f (Y i))")
- apply (simp add: maxinch_is_thelub ch2ch_monofun)
- apply (force simp add: max_in_chain_def)
- done
-
-text \<open>All strict functions with flat domain are continuous.\<close>
-
-lemma flatdom_strict2mono: "f \<bottom> = \<bottom> \<Longrightarrow> monofun f"
- for f :: "'a::flat \<Rightarrow> 'b::pcpo"
- apply (rule monofunI)
- apply (drule ax_flat)
- apply auto
- done
-
-lemma flatdom_strict2cont: "f \<bottom> = \<bottom> \<Longrightarrow> cont f"
- for f :: "'a::flat \<Rightarrow> 'b::pcpo"
- by (rule flatdom_strict2mono [THEN chfindom_monofun2cont])
-
-text \<open>All functions with discrete domain are continuous.\<close>
-
-lemma cont_discrete_cpo [simp, cont2cont]: "cont f"
- for f :: "'a::discrete_cpo \<Rightarrow> 'b::cpo"
- apply (rule contI)
- apply (drule discrete_chain_const, clarify)
- apply simp
- done
-
-end
--- a/src/HOL/HOLCF/ConvexPD.thy Wed Dec 11 13:44:16 2024 +0100
+++ b/src/HOL/HOLCF/ConvexPD.thy Wed Dec 11 13:44:35 2024 +0100
@@ -466,6 +466,7 @@
by (rule finite_range_imp_finite_fixes)
qed
+
subsection \<open>Convex powerdomain is bifinite\<close>
lemma approx_chain_convex_map:
@@ -481,6 +482,7 @@
by (fast intro!: approx_chain_convex_map)
qed
+
subsection \<open>Join\<close>
definition
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/HOLCF/Cpo.thy Wed Dec 11 13:44:35 2024 +0100
@@ -0,0 +1,1438 @@
+(* Title: HOL/HOLCF/Cpo.thy
+ Author: Franz Regensburger
+ Author: Tobias Nipkow
+ Author: Brian Huffman
+
+Foundations of HOLCF: complete partial orders etc.
+*)
+
+theory Cpo
+ imports Main
+begin
+
+section \<open>Partial orders\<close>
+
+declare [[typedef_overloaded]]
+
+
+subsection \<open>Type class for partial orders\<close>
+
+class below =
+ fixes below :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
+begin
+
+notation (ASCII)
+ below (infix \<open><<\<close> 50)
+
+notation
+ below (infix \<open>\<sqsubseteq>\<close> 50)
+
+abbreviation not_below :: "'a \<Rightarrow> 'a \<Rightarrow> bool" (infix \<open>\<notsqsubseteq>\<close> 50)
+ where "not_below x y \<equiv> \<not> below x y"
+
+notation (ASCII)
+ not_below (infix \<open>~<<\<close> 50)
+
+lemma below_eq_trans: "a \<sqsubseteq> b \<Longrightarrow> b = c \<Longrightarrow> a \<sqsubseteq> c"
+ by (rule subst)
+
+lemma eq_below_trans: "a = b \<Longrightarrow> b \<sqsubseteq> c \<Longrightarrow> a \<sqsubseteq> c"
+ by (rule ssubst)
+
+end
+
+class po = below +
+ assumes below_refl [iff]: "x \<sqsubseteq> x"
+ assumes below_trans: "x \<sqsubseteq> y \<Longrightarrow> y \<sqsubseteq> z \<Longrightarrow> x \<sqsubseteq> z"
+ assumes below_antisym: "x \<sqsubseteq> y \<Longrightarrow> y \<sqsubseteq> x \<Longrightarrow> x = y"
+begin
+
+lemma eq_imp_below: "x = y \<Longrightarrow> x \<sqsubseteq> y"
+ by simp
+
+lemma box_below: "a \<sqsubseteq> b \<Longrightarrow> c \<sqsubseteq> a \<Longrightarrow> b \<sqsubseteq> d \<Longrightarrow> c \<sqsubseteq> d"
+ by (rule below_trans [OF below_trans])
+
+lemma po_eq_conv: "x = y \<longleftrightarrow> x \<sqsubseteq> y \<and> y \<sqsubseteq> x"
+ by (fast intro!: below_antisym)
+
+lemma rev_below_trans: "y \<sqsubseteq> z \<Longrightarrow> x \<sqsubseteq> y \<Longrightarrow> x \<sqsubseteq> z"
+ by (rule below_trans)
+
+lemma not_below2not_eq: "x \<notsqsubseteq> y \<Longrightarrow> x \<noteq> y"
+ by auto
+
+end
+
+lemmas HOLCF_trans_rules [trans] =
+ below_trans
+ below_antisym
+ below_eq_trans
+ eq_below_trans
+
+context po
+begin
+
+subsection \<open>Upper bounds\<close>
+
+definition is_ub :: "'a set \<Rightarrow> 'a \<Rightarrow> bool" (infix \<open><|\<close> 55)
+ where "S <| x \<longleftrightarrow> (\<forall>y\<in>S. y \<sqsubseteq> x)"
+
+lemma is_ubI: "(\<And>x. x \<in> S \<Longrightarrow> x \<sqsubseteq> u) \<Longrightarrow> S <| u"
+ by (simp add: is_ub_def)
+
+lemma is_ubD: "\<lbrakk>S <| u; x \<in> S\<rbrakk> \<Longrightarrow> x \<sqsubseteq> u"
+ by (simp add: is_ub_def)
+
+lemma ub_imageI: "(\<And>x. x \<in> S \<Longrightarrow> f x \<sqsubseteq> u) \<Longrightarrow> (\<lambda>x. f x) ` S <| u"
+ unfolding is_ub_def by fast
+
+lemma ub_imageD: "\<lbrakk>f ` S <| u; x \<in> S\<rbrakk> \<Longrightarrow> f x \<sqsubseteq> u"
+ unfolding is_ub_def by fast
+
+lemma ub_rangeI: "(\<And>i. S i \<sqsubseteq> x) \<Longrightarrow> range S <| x"
+ unfolding is_ub_def by fast
+
+lemma ub_rangeD: "range S <| x \<Longrightarrow> S i \<sqsubseteq> x"
+ unfolding is_ub_def by fast
+
+lemma is_ub_empty [simp]: "{} <| u"
+ unfolding is_ub_def by fast
+
+lemma is_ub_insert [simp]: "(insert x A) <| y = (x \<sqsubseteq> y \<and> A <| y)"
+ unfolding is_ub_def by fast
+
+lemma is_ub_upward: "\<lbrakk>S <| x; x \<sqsubseteq> y\<rbrakk> \<Longrightarrow> S <| y"
+ unfolding is_ub_def by (fast intro: below_trans)
+
+
+subsection \<open>Least upper bounds\<close>
+
+definition is_lub :: "'a set \<Rightarrow> 'a \<Rightarrow> bool" (infix \<open><<|\<close> 55)
+ where "S <<| x \<longleftrightarrow> S <| x \<and> (\<forall>u. S <| u \<longrightarrow> x \<sqsubseteq> u)"
+
+definition lub :: "'a set \<Rightarrow> 'a"
+ where "lub S = (THE x. S <<| x)"
+
+end
+
+syntax (ASCII)
+ "_BLub" :: "[pttrn, 'a set, 'b] \<Rightarrow> 'b" (\<open>(\<open>indent=3 notation=\<open>binder LUB\<close>\<close>LUB _:_./ _)\<close> [0,0, 10] 10)
+
+syntax
+ "_BLub" :: "[pttrn, 'a set, 'b] \<Rightarrow> 'b" (\<open>(\<open>indent=3 notation=\<open>binder \<Squnion>\<close>\<close>\<Squnion>_\<in>_./ _)\<close> [0,0, 10] 10)
+
+syntax_consts
+ "_BLub" \<rightleftharpoons> lub
+
+translations
+ "LUB x:A. t" \<rightleftharpoons> "CONST lub ((\<lambda>x. t) ` A)"
+
+context po
+begin
+
+abbreviation Lub (binder \<open>\<Squnion>\<close> 10)
+ where "\<Squnion>n. t n \<equiv> lub (range t)"
+
+notation (ASCII)
+ Lub (binder \<open>LUB \<close> 10)
+
+text \<open>access to some definition as inference rule\<close>
+
+lemma is_lubD1: "S <<| x \<Longrightarrow> S <| x"
+ unfolding is_lub_def by fast
+
+lemma is_lubD2: "\<lbrakk>S <<| x; S <| u\<rbrakk> \<Longrightarrow> x \<sqsubseteq> u"
+ unfolding is_lub_def by fast
+
+lemma is_lubI: "\<lbrakk>S <| x; \<And>u. S <| u \<Longrightarrow> x \<sqsubseteq> u\<rbrakk> \<Longrightarrow> S <<| x"
+ unfolding is_lub_def by fast
+
+lemma is_lub_below_iff: "S <<| x \<Longrightarrow> x \<sqsubseteq> u \<longleftrightarrow> S <| u"
+ unfolding is_lub_def is_ub_def by (metis below_trans)
+
+text \<open>lubs are unique\<close>
+
+lemma is_lub_unique: "S <<| x \<Longrightarrow> S <<| y \<Longrightarrow> x = y"
+ unfolding is_lub_def is_ub_def by (blast intro: below_antisym)
+
+text \<open>technical lemmas about \<^term>\<open>lub\<close> and \<^term>\<open>is_lub\<close>\<close>
+
+lemma is_lub_lub: "M <<| x \<Longrightarrow> M <<| lub M"
+ unfolding lub_def by (rule theI [OF _ is_lub_unique])
+
+lemma lub_eqI: "M <<| l \<Longrightarrow> lub M = l"
+ by (rule is_lub_unique [OF is_lub_lub])
+
+lemma is_lub_singleton [simp]: "{x} <<| x"
+ by (simp add: is_lub_def)
+
+lemma lub_singleton [simp]: "lub {x} = x"
+ by (rule is_lub_singleton [THEN lub_eqI])
+
+lemma is_lub_bin: "x \<sqsubseteq> y \<Longrightarrow> {x, y} <<| y"
+ by (simp add: is_lub_def)
+
+lemma lub_bin: "x \<sqsubseteq> y \<Longrightarrow> lub {x, y} = y"
+ by (rule is_lub_bin [THEN lub_eqI])
+
+lemma is_lub_maximal: "S <| x \<Longrightarrow> x \<in> S \<Longrightarrow> S <<| x"
+ by (erule is_lubI, erule (1) is_ubD)
+
+lemma lub_maximal: "S <| x \<Longrightarrow> x \<in> S \<Longrightarrow> lub S = x"
+ by (rule is_lub_maximal [THEN lub_eqI])
+
+
+subsection \<open>Countable chains\<close>
+
+definition chain :: "(nat \<Rightarrow> 'a) \<Rightarrow> bool"
+ where \<comment> \<open>Here we use countable chains and I prefer to code them as functions!\<close>
+ "chain Y = (\<forall>i. Y i \<sqsubseteq> Y (Suc i))"
+
+lemma chainI: "(\<And>i. Y i \<sqsubseteq> Y (Suc i)) \<Longrightarrow> chain Y"
+ unfolding chain_def by fast
+
+lemma chainE: "chain Y \<Longrightarrow> Y i \<sqsubseteq> Y (Suc i)"
+ unfolding chain_def by fast
+
+text \<open>chains are monotone functions\<close>
+
+lemma chain_mono_less: "chain Y \<Longrightarrow> i < j \<Longrightarrow> Y i \<sqsubseteq> Y j"
+ by (erule less_Suc_induct, erule chainE, erule below_trans)
+
+lemma chain_mono: "chain Y \<Longrightarrow> i \<le> j \<Longrightarrow> Y i \<sqsubseteq> Y j"
+ by (cases "i = j") (simp_all add: chain_mono_less)
+
+lemma chain_shift: "chain Y \<Longrightarrow> chain (\<lambda>i. Y (i + j))"
+ by (rule chainI, simp, erule chainE)
+
+text \<open>technical lemmas about (least) upper bounds of chains\<close>
+
+lemma is_lub_rangeD1: "range S <<| x \<Longrightarrow> S i \<sqsubseteq> x"
+ by (rule is_lubD1 [THEN ub_rangeD])
+
+lemma is_ub_range_shift: "chain S \<Longrightarrow> range (\<lambda>i. S (i + j)) <| x = range S <| x"
+ apply (rule iffI)
+ apply (rule ub_rangeI)
+ apply (rule_tac y="S (i + j)" in below_trans)
+ apply (erule chain_mono)
+ apply (rule le_add1)
+ apply (erule ub_rangeD)
+ apply (rule ub_rangeI)
+ apply (erule ub_rangeD)
+ done
+
+lemma is_lub_range_shift: "chain S \<Longrightarrow> range (\<lambda>i. S (i + j)) <<| x = range S <<| x"
+ by (simp add: is_lub_def is_ub_range_shift)
+
+text \<open>the lub of a constant chain is the constant\<close>
+
+lemma chain_const [simp]: "chain (\<lambda>i. c)"
+ by (simp add: chainI)
+
+lemma is_lub_const: "range (\<lambda>x. c) <<| c"
+by (blast dest: ub_rangeD intro: is_lubI ub_rangeI)
+
+lemma lub_const [simp]: "(\<Squnion>i. c) = c"
+ by (rule is_lub_const [THEN lub_eqI])
+
+
+subsection \<open>Finite chains\<close>
+
+definition max_in_chain :: "nat \<Rightarrow> (nat \<Rightarrow> 'a) \<Rightarrow> bool"
+ where \<comment> \<open>finite chains, needed for monotony of continuous functions\<close>
+ "max_in_chain i C \<longleftrightarrow> (\<forall>j. i \<le> j \<longrightarrow> C i = C j)"
+
+definition finite_chain :: "(nat \<Rightarrow> 'a) \<Rightarrow> bool"
+ where "finite_chain C = (chain C \<and> (\<exists>i. max_in_chain i C))"
+
+text \<open>results about finite chains\<close>
+
+lemma max_in_chainI: "(\<And>j. i \<le> j \<Longrightarrow> Y i = Y j) \<Longrightarrow> max_in_chain i Y"
+ unfolding max_in_chain_def by fast
+
+lemma max_in_chainD: "max_in_chain i Y \<Longrightarrow> i \<le> j \<Longrightarrow> Y i = Y j"
+ unfolding max_in_chain_def by fast
+
+lemma finite_chainI: "chain C \<Longrightarrow> max_in_chain i C \<Longrightarrow> finite_chain C"
+ unfolding finite_chain_def by fast
+
+lemma finite_chainE: "\<lbrakk>finite_chain C; \<And>i. \<lbrakk>chain C; max_in_chain i C\<rbrakk> \<Longrightarrow> R\<rbrakk> \<Longrightarrow> R"
+ unfolding finite_chain_def by fast
+
+lemma lub_finch1: "chain C \<Longrightarrow> max_in_chain i C \<Longrightarrow> range C <<| C i"
+ apply (rule is_lubI)
+ apply (rule ub_rangeI, rename_tac j)
+ apply (rule_tac x=i and y=j in linorder_le_cases)
+ apply (drule (1) max_in_chainD, simp)
+ apply (erule (1) chain_mono)
+ apply (erule ub_rangeD)
+ done
+
+lemma lub_finch2: "finite_chain C \<Longrightarrow> range C <<| C (LEAST i. max_in_chain i C)"
+ apply (erule finite_chainE)
+ apply (erule LeastI2 [where Q="\<lambda>i. range C <<| C i"])
+ apply (erule (1) lub_finch1)
+ done
+
+lemma finch_imp_finite_range: "finite_chain Y \<Longrightarrow> finite (range Y)"
+ apply (erule finite_chainE)
+ apply (rule_tac B="Y ` {..i}" in finite_subset)
+ apply (rule subsetI)
+ apply (erule rangeE, rename_tac j)
+ apply (rule_tac x=i and y=j in linorder_le_cases)
+ apply (subgoal_tac "Y j = Y i", simp)
+ apply (simp add: max_in_chain_def)
+ apply simp
+ apply simp
+ done
+
+lemma finite_range_has_max:
+ fixes f :: "nat \<Rightarrow> 'a"
+ and r :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
+ assumes mono: "\<And>i j. i \<le> j \<Longrightarrow> r (f i) (f j)"
+ assumes finite_range: "finite (range f)"
+ shows "\<exists>k. \<forall>i. r (f i) (f k)"
+proof (intro exI allI)
+ fix i :: nat
+ let ?j = "LEAST k. f k = f i"
+ let ?k = "Max ((\<lambda>x. LEAST k. f k = x) ` range f)"
+ have "?j \<le> ?k"
+ proof (rule Max_ge)
+ show "finite ((\<lambda>x. LEAST k. f k = x) ` range f)"
+ using finite_range by (rule finite_imageI)
+ show "?j \<in> (\<lambda>x. LEAST k. f k = x) ` range f"
+ by (intro imageI rangeI)
+ qed
+ hence "r (f ?j) (f ?k)"
+ by (rule mono)
+ also have "f ?j = f i"
+ by (rule LeastI, rule refl)
+ finally show "r (f i) (f ?k)" .
+qed
+
+lemma finite_range_imp_finch: "chain Y \<Longrightarrow> finite (range Y) \<Longrightarrow> finite_chain Y"
+ apply (subgoal_tac "\<exists>k. \<forall>i. Y i \<sqsubseteq> Y k")
+ apply (erule exE)
+ apply (rule finite_chainI, assumption)
+ apply (rule max_in_chainI)
+ apply (rule below_antisym)
+ apply (erule (1) chain_mono)
+ apply (erule spec)
+ apply (rule finite_range_has_max)
+ apply (erule (1) chain_mono)
+ apply assumption
+ done
+
+lemma bin_chain: "x \<sqsubseteq> y \<Longrightarrow> chain (\<lambda>i. if i=0 then x else y)"
+ by (rule chainI) simp
+
+lemma bin_chainmax: "x \<sqsubseteq> y \<Longrightarrow> max_in_chain (Suc 0) (\<lambda>i. if i=0 then x else y)"
+ by (simp add: max_in_chain_def)
+
+lemma is_lub_bin_chain: "x \<sqsubseteq> y \<Longrightarrow> range (\<lambda>i::nat. if i=0 then x else y) <<| y"
+ apply (frule bin_chain)
+ apply (drule bin_chainmax)
+ apply (drule (1) lub_finch1)
+ apply simp
+ done
+
+text \<open>the maximal element in a chain is its lub\<close>
+
+lemma lub_chain_maxelem: "Y i = c \<Longrightarrow> \<forall>i. Y i \<sqsubseteq> c \<Longrightarrow> lub (range Y) = c"
+ by (blast dest: ub_rangeD intro: lub_eqI is_lubI ub_rangeI)
+
+end
+
+
+section \<open>Classes cpo and pcpo\<close>
+
+subsection \<open>Complete partial orders\<close>
+
+text \<open>The class cpo of chain complete partial orders\<close>
+
+class cpo = po +
+ assumes cpo: "chain S \<Longrightarrow> \<exists>x. range S <<| x"
+begin
+
+text \<open>in cpo's everthing equal to THE lub has lub properties for every chain\<close>
+
+lemma cpo_lubI: "chain S \<Longrightarrow> range S <<| (\<Squnion>i. S i)"
+ by (fast dest: cpo elim: is_lub_lub)
+
+lemma thelubE: "\<lbrakk>chain S; (\<Squnion>i. S i) = l\<rbrakk> \<Longrightarrow> range S <<| l"
+ by (blast dest: cpo intro: is_lub_lub)
+
+text \<open>Properties of the lub\<close>
+
+lemma is_ub_thelub: "chain S \<Longrightarrow> S x \<sqsubseteq> (\<Squnion>i. S i)"
+ by (blast dest: cpo intro: is_lub_lub [THEN is_lub_rangeD1])
+
+lemma is_lub_thelub: "\<lbrakk>chain S; range S <| x\<rbrakk> \<Longrightarrow> (\<Squnion>i. S i) \<sqsubseteq> x"
+ by (blast dest: cpo intro: is_lub_lub [THEN is_lubD2])
+
+lemma lub_below_iff: "chain S \<Longrightarrow> (\<Squnion>i. S i) \<sqsubseteq> x \<longleftrightarrow> (\<forall>i. S i \<sqsubseteq> x)"
+ by (simp add: is_lub_below_iff [OF cpo_lubI] is_ub_def)
+
+lemma lub_below: "\<lbrakk>chain S; \<And>i. S i \<sqsubseteq> x\<rbrakk> \<Longrightarrow> (\<Squnion>i. S i) \<sqsubseteq> x"
+ by (simp add: lub_below_iff)
+
+lemma below_lub: "\<lbrakk>chain S; x \<sqsubseteq> S i\<rbrakk> \<Longrightarrow> x \<sqsubseteq> (\<Squnion>i. S i)"
+ by (erule below_trans, erule is_ub_thelub)
+
+lemma lub_range_mono: "\<lbrakk>range X \<subseteq> range Y; chain Y; chain X\<rbrakk> \<Longrightarrow> (\<Squnion>i. X i) \<sqsubseteq> (\<Squnion>i. Y i)"
+ apply (erule lub_below)
+ apply (subgoal_tac "\<exists>j. X i = Y j")
+ apply clarsimp
+ apply (erule is_ub_thelub)
+ apply auto
+ done
+
+lemma lub_range_shift: "chain Y \<Longrightarrow> (\<Squnion>i. Y (i + j)) = (\<Squnion>i. Y i)"
+ apply (rule below_antisym)
+ apply (rule lub_range_mono)
+ apply fast
+ apply assumption
+ apply (erule chain_shift)
+ apply (rule lub_below)
+ apply assumption
+ apply (rule_tac i="i" in below_lub)
+ apply (erule chain_shift)
+ apply (erule chain_mono)
+ apply (rule le_add1)
+ done
+
+lemma maxinch_is_thelub: "chain Y \<Longrightarrow> max_in_chain i Y = ((\<Squnion>i. Y i) = Y i)"
+ apply (rule iffI)
+ apply (fast intro!: lub_eqI lub_finch1)
+ apply (unfold max_in_chain_def)
+ apply (safe intro!: below_antisym)
+ apply (fast elim!: chain_mono)
+ apply (drule sym)
+ apply (force elim!: is_ub_thelub)
+ done
+
+text \<open>the \<open>\<sqsubseteq>\<close> relation between two chains is preserved by their lubs\<close>
+
+lemma lub_mono: "\<lbrakk>chain X; chain Y; \<And>i. X i \<sqsubseteq> Y i\<rbrakk> \<Longrightarrow> (\<Squnion>i. X i) \<sqsubseteq> (\<Squnion>i. Y i)"
+ by (fast elim: lub_below below_lub)
+
+text \<open>the = relation between two chains is preserved by their lubs\<close>
+
+lemma lub_eq: "(\<And>i. X i = Y i) \<Longrightarrow> (\<Squnion>i. X i) = (\<Squnion>i. Y i)"
+ by simp
+
+lemma ch2ch_lub:
+ assumes 1: "\<And>j. chain (\<lambda>i. Y i j)"
+ assumes 2: "\<And>i. chain (\<lambda>j. Y i j)"
+ shows "chain (\<lambda>i. \<Squnion>j. Y i j)"
+ apply (rule chainI)
+ apply (rule lub_mono [OF 2 2])
+ apply (rule chainE [OF 1])
+ done
+
+lemma diag_lub:
+ assumes 1: "\<And>j. chain (\<lambda>i. Y i j)"
+ assumes 2: "\<And>i. chain (\<lambda>j. Y i j)"
+ shows "(\<Squnion>i. \<Squnion>j. Y i j) = (\<Squnion>i. Y i i)"
+proof (rule below_antisym)
+ have 3: "chain (\<lambda>i. Y i i)"
+ apply (rule chainI)
+ apply (rule below_trans)
+ apply (rule chainE [OF 1])
+ apply (rule chainE [OF 2])
+ done
+ have 4: "chain (\<lambda>i. \<Squnion>j. Y i j)"
+ by (rule ch2ch_lub [OF 1 2])
+ show "(\<Squnion>i. \<Squnion>j. Y i j) \<sqsubseteq> (\<Squnion>i. Y i i)"
+ apply (rule lub_below [OF 4])
+ apply (rule lub_below [OF 2])
+ apply (rule below_lub [OF 3])
+ apply (rule below_trans)
+ apply (rule chain_mono [OF 1 max.cobounded1])
+ apply (rule chain_mono [OF 2 max.cobounded2])
+ done
+ show "(\<Squnion>i. Y i i) \<sqsubseteq> (\<Squnion>i. \<Squnion>j. Y i j)"
+ apply (rule lub_mono [OF 3 4])
+ apply (rule is_ub_thelub [OF 2])
+ done
+qed
+
+lemma ex_lub:
+ assumes 1: "\<And>j. chain (\<lambda>i. Y i j)"
+ assumes 2: "\<And>i. chain (\<lambda>j. Y i j)"
+ shows "(\<Squnion>i. \<Squnion>j. Y i j) = (\<Squnion>j. \<Squnion>i. Y i j)"
+ by (simp add: diag_lub 1 2)
+
+end
+
+
+subsection \<open>Pointed cpos\<close>
+
+text \<open>The class pcpo of pointed cpos\<close>
+
+class pcpo = cpo +
+ assumes least: "\<exists>x. \<forall>y. x \<sqsubseteq> y"
+begin
+
+definition bottom :: "'a" (\<open>\<bottom>\<close>)
+ where "bottom = (THE x. \<forall>y. x \<sqsubseteq> y)"
+
+lemma minimal [iff]: "\<bottom> \<sqsubseteq> x"
+ unfolding bottom_def
+ apply (rule the1I2)
+ apply (rule ex_ex1I)
+ apply (rule least)
+ apply (blast intro: below_antisym)
+ apply simp
+ done
+
+end
+
+text \<open>Old "UU" syntax:\<close>
+abbreviation (input) "UU \<equiv> bottom"
+
+text \<open>Simproc to rewrite \<^term>\<open>\<bottom> = x\<close> to \<^term>\<open>x = \<bottom>\<close>.\<close>
+setup \<open>Reorient_Proc.add (fn \<^Const_>\<open>bottom _\<close> => true | _ => false)\<close>
+simproc_setup reorient_bottom ("\<bottom> = x") = \<open>K Reorient_Proc.proc\<close>
+
+text \<open>useful lemmas about \<^term>\<open>\<bottom>\<close>\<close>
+
+lemma below_bottom_iff [simp]: "x \<sqsubseteq> \<bottom> \<longleftrightarrow> x = \<bottom>"
+ by (simp add: po_eq_conv)
+
+lemma eq_bottom_iff: "x = \<bottom> \<longleftrightarrow> x \<sqsubseteq> \<bottom>"
+ by simp
+
+lemma bottomI: "x \<sqsubseteq> \<bottom> \<Longrightarrow> x = \<bottom>"
+ by (subst eq_bottom_iff)
+
+lemma lub_eq_bottom_iff: "chain Y \<Longrightarrow> (\<Squnion>i. Y i) = \<bottom> \<longleftrightarrow> (\<forall>i. Y i = \<bottom>)"
+ by (simp only: eq_bottom_iff lub_below_iff)
+
+
+subsection \<open>Chain-finite and flat cpos\<close>
+
+text \<open>further useful classes for HOLCF domains\<close>
+
+class chfin = po +
+ assumes chfin: "chain Y \<Longrightarrow> \<exists>n. max_in_chain n Y"
+begin
+
+subclass cpo
+ apply standard
+ apply (frule chfin)
+ apply (blast intro: lub_finch1)
+ done
+
+lemma chfin2finch: "chain Y \<Longrightarrow> finite_chain Y"
+ by (simp add: chfin finite_chain_def)
+
+end
+
+class flat = pcpo +
+ assumes ax_flat: "x \<sqsubseteq> y \<Longrightarrow> x = \<bottom> \<or> x = y"
+begin
+
+subclass chfin
+proof
+ fix Y
+ assume *: "chain Y"
+ show "\<exists>n. max_in_chain n Y"
+ apply (unfold max_in_chain_def)
+ apply (cases "\<forall>i. Y i = \<bottom>")
+ apply simp
+ apply simp
+ apply (erule exE)
+ apply (rule_tac x="i" in exI)
+ apply clarify
+ using * apply (blast dest: chain_mono ax_flat)
+ done
+qed
+
+lemma flat_below_iff: "x \<sqsubseteq> y \<longleftrightarrow> x = \<bottom> \<or> x = y"
+ by (safe dest!: ax_flat)
+
+lemma flat_eq: "a \<noteq> \<bottom> \<Longrightarrow> a \<sqsubseteq> b = (a = b)"
+ by (safe dest!: ax_flat)
+
+end
+
+
+subsection \<open>Discrete cpos\<close>
+
+class discrete_cpo = below +
+ assumes discrete_cpo [simp]: "x \<sqsubseteq> y \<longleftrightarrow> x = y"
+begin
+
+subclass po
+ by standard simp_all
+
+text \<open>In a discrete cpo, every chain is constant\<close>
+
+lemma discrete_chain_const:
+ assumes S: "chain S"
+ shows "\<exists>x. S = (\<lambda>i. x)"
+proof (intro exI ext)
+ fix i :: nat
+ from S le0 have "S 0 \<sqsubseteq> S i" by (rule chain_mono)
+ then have "S 0 = S i" by simp
+ then show "S i = S 0" by (rule sym)
+qed
+
+subclass chfin
+proof
+ fix S :: "nat \<Rightarrow> 'a"
+ assume S: "chain S"
+ then have "\<exists>x. S = (\<lambda>i. x)"
+ by (rule discrete_chain_const)
+ then have "max_in_chain 0 S"
+ by (auto simp: max_in_chain_def)
+ then show "\<exists>i. max_in_chain i S" ..
+qed
+
+end
+
+
+section \<open>Continuity and monotonicity\<close>
+
+subsection \<open>Definitions\<close>
+
+definition monofun :: "('a::po \<Rightarrow> 'b::po) \<Rightarrow> bool" \<comment> \<open>monotonicity\<close>
+ where "monofun f \<longleftrightarrow> (\<forall>x y. x \<sqsubseteq> y \<longrightarrow> f x \<sqsubseteq> f y)"
+
+definition cont :: "('a::cpo \<Rightarrow> 'b::cpo) \<Rightarrow> bool"
+ where "cont f = (\<forall>Y. chain Y \<longrightarrow> range (\<lambda>i. f (Y i)) <<| f (\<Squnion>i. Y i))"
+
+lemma contI: "(\<And>Y. chain Y \<Longrightarrow> range (\<lambda>i. f (Y i)) <<| f (\<Squnion>i. Y i)) \<Longrightarrow> cont f"
+ by (simp add: cont_def)
+
+lemma contE: "cont f \<Longrightarrow> chain Y \<Longrightarrow> range (\<lambda>i. f (Y i)) <<| f (\<Squnion>i. Y i)"
+ by (simp add: cont_def)
+
+lemma monofunI: "(\<And>x y. x \<sqsubseteq> y \<Longrightarrow> f x \<sqsubseteq> f y) \<Longrightarrow> monofun f"
+ by (simp add: monofun_def)
+
+lemma monofunE: "monofun f \<Longrightarrow> x \<sqsubseteq> y \<Longrightarrow> f x \<sqsubseteq> f y"
+ by (simp add: monofun_def)
+
+
+subsection \<open>Equivalence of alternate definition\<close>
+
+text \<open>monotone functions map chains to chains\<close>
+
+lemma ch2ch_monofun: "monofun f \<Longrightarrow> chain Y \<Longrightarrow> chain (\<lambda>i. f (Y i))"
+ apply (rule chainI)
+ apply (erule monofunE)
+ apply (erule chainE)
+ done
+
+text \<open>monotone functions map upper bound to upper bounds\<close>
+
+lemma ub2ub_monofun: "monofun f \<Longrightarrow> range Y <| u \<Longrightarrow> range (\<lambda>i. f (Y i)) <| f u"
+ apply (rule ub_rangeI)
+ apply (erule monofunE)
+ apply (erule ub_rangeD)
+ done
+
+text \<open>a lemma about binary chains\<close>
+
+lemma binchain_cont: "cont f \<Longrightarrow> x \<sqsubseteq> y \<Longrightarrow> range (\<lambda>i::nat. f (if i = 0 then x else y)) <<| f y"
+ apply (subgoal_tac "f (\<Squnion>i::nat. if i = 0 then x else y) = f y")
+ apply (erule subst)
+ apply (erule contE)
+ apply (erule bin_chain)
+ apply (rule_tac f=f in arg_cong)
+ apply (erule is_lub_bin_chain [THEN lub_eqI])
+ done
+
+text \<open>continuity implies monotonicity\<close>
+
+lemma cont2mono: "cont f \<Longrightarrow> monofun f"
+ apply (rule monofunI)
+ apply (drule (1) binchain_cont)
+ apply (drule_tac i=0 in is_lub_rangeD1)
+ apply simp
+ done
+
+lemmas cont2monofunE = cont2mono [THEN monofunE]
+
+lemmas ch2ch_cont = cont2mono [THEN ch2ch_monofun]
+
+text \<open>continuity implies preservation of lubs\<close>
+
+lemma cont2contlubE: "cont f \<Longrightarrow> chain Y \<Longrightarrow> f (\<Squnion>i. Y i) = (\<Squnion>i. f (Y i))"
+ apply (rule lub_eqI [symmetric])
+ apply (erule (1) contE)
+ done
+
+lemma contI2:
+ fixes f :: "'a::cpo \<Rightarrow> 'b::cpo"
+ assumes mono: "monofun f"
+ assumes below: "\<And>Y. \<lbrakk>chain Y; chain (\<lambda>i. f (Y i))\<rbrakk> \<Longrightarrow> f (\<Squnion>i. Y i) \<sqsubseteq> (\<Squnion>i. f (Y i))"
+ shows "cont f"
+proof (rule contI)
+ fix Y :: "nat \<Rightarrow> 'a"
+ assume Y: "chain Y"
+ with mono have fY: "chain (\<lambda>i. f (Y i))"
+ by (rule ch2ch_monofun)
+ have "(\<Squnion>i. f (Y i)) = f (\<Squnion>i. Y i)"
+ apply (rule below_antisym)
+ apply (rule lub_below [OF fY])
+ apply (rule monofunE [OF mono])
+ apply (rule is_ub_thelub [OF Y])
+ apply (rule below [OF Y fY])
+ done
+ with fY show "range (\<lambda>i. f (Y i)) <<| f (\<Squnion>i. Y i)"
+ by (rule thelubE)
+qed
+
+
+subsection \<open>Collection of continuity rules\<close>
+
+named_theorems cont2cont "continuity intro rule"
+
+
+subsection \<open>Continuity of basic functions\<close>
+
+text \<open>The identity function is continuous\<close>
+
+lemma cont_id [simp, cont2cont]: "cont (\<lambda>x. x)"
+ apply (rule contI)
+ apply (erule cpo_lubI)
+ done
+
+text \<open>constant functions are continuous\<close>
+
+lemma cont_const [simp, cont2cont]: "cont (\<lambda>x. c)"
+ using is_lub_const by (rule contI)
+
+text \<open>application of functions is continuous\<close>
+
+lemma cont_apply:
+ fixes f :: "'a::cpo \<Rightarrow> 'b::cpo \<Rightarrow> 'c::cpo" and t :: "'a \<Rightarrow> 'b"
+ assumes 1: "cont (\<lambda>x. t x)"
+ assumes 2: "\<And>x. cont (\<lambda>y. f x y)"
+ assumes 3: "\<And>y. cont (\<lambda>x. f x y)"
+ shows "cont (\<lambda>x. (f x) (t x))"
+proof (rule contI2 [OF monofunI])
+ fix x y :: "'a"
+ assume "x \<sqsubseteq> y"
+ then show "f x (t x) \<sqsubseteq> f y (t y)"
+ by (auto intro: cont2monofunE [OF 1]
+ cont2monofunE [OF 2]
+ cont2monofunE [OF 3]
+ below_trans)
+next
+ fix Y :: "nat \<Rightarrow> 'a"
+ assume "chain Y"
+ then show "f (\<Squnion>i. Y i) (t (\<Squnion>i. Y i)) \<sqsubseteq> (\<Squnion>i. f (Y i) (t (Y i)))"
+ by (simp only: cont2contlubE [OF 1] ch2ch_cont [OF 1]
+ cont2contlubE [OF 2] ch2ch_cont [OF 2]
+ cont2contlubE [OF 3] ch2ch_cont [OF 3]
+ diag_lub below_refl)
+qed
+
+lemma cont_compose: "cont c \<Longrightarrow> cont (\<lambda>x. f x) \<Longrightarrow> cont (\<lambda>x. c (f x))"
+ by (rule cont_apply [OF _ _ cont_const])
+
+text \<open>Least upper bounds preserve continuity\<close>
+
+lemma cont2cont_lub [simp]:
+ assumes chain: "\<And>x. chain (\<lambda>i. F i x)"
+ and cont: "\<And>i. cont (\<lambda>x. F i x)"
+ shows "cont (\<lambda>x. \<Squnion>i. F i x)"
+ apply (rule contI2)
+ apply (simp add: monofunI cont2monofunE [OF cont] lub_mono chain)
+ apply (simp add: cont2contlubE [OF cont])
+ apply (simp add: diag_lub ch2ch_cont [OF cont] chain)
+ done
+
+text \<open>if-then-else is continuous\<close>
+
+lemma cont_if [simp, cont2cont]: "cont f \<Longrightarrow> cont g \<Longrightarrow> cont (\<lambda>x. if b then f x else g x)"
+ by (induct b) simp_all
+
+
+subsection \<open>Finite chains and flat pcpos\<close>
+
+text \<open>Monotone functions map finite chains to finite chains.\<close>
+
+lemma monofun_finch2finch: "monofun f \<Longrightarrow> finite_chain Y \<Longrightarrow> finite_chain (\<lambda>n. f (Y n))"
+ by (force simp add: finite_chain_def ch2ch_monofun max_in_chain_def)
+
+text \<open>The same holds for continuous functions.\<close>
+
+lemma cont_finch2finch: "cont f \<Longrightarrow> finite_chain Y \<Longrightarrow> finite_chain (\<lambda>n. f (Y n))"
+ by (rule cont2mono [THEN monofun_finch2finch])
+
+text \<open>All monotone functions with chain-finite domain are continuous.\<close>
+
+lemma chfindom_monofun2cont: "monofun f \<Longrightarrow> cont f"
+ for f :: "'a::chfin \<Rightarrow> 'b::cpo"
+ apply (erule contI2)
+ apply (frule chfin2finch)
+ apply (clarsimp simp add: finite_chain_def)
+ apply (subgoal_tac "max_in_chain i (\<lambda>i. f (Y i))")
+ apply (simp add: maxinch_is_thelub ch2ch_monofun)
+ apply (force simp add: max_in_chain_def)
+ done
+
+text \<open>All strict functions with flat domain are continuous.\<close>
+
+lemma flatdom_strict2mono: "f \<bottom> = \<bottom> \<Longrightarrow> monofun f"
+ for f :: "'a::flat \<Rightarrow> 'b::pcpo"
+ apply (rule monofunI)
+ apply (drule ax_flat)
+ apply auto
+ done
+
+lemma flatdom_strict2cont: "f \<bottom> = \<bottom> \<Longrightarrow> cont f"
+ for f :: "'a::flat \<Rightarrow> 'b::pcpo"
+ by (rule flatdom_strict2mono [THEN chfindom_monofun2cont])
+
+text \<open>All functions with discrete domain are continuous.\<close>
+
+lemma cont_discrete_cpo [simp, cont2cont]: "cont f"
+ for f :: "'a::discrete_cpo \<Rightarrow> 'b::cpo"
+ apply (rule contI)
+ apply (drule discrete_chain_const, clarify)
+ apply simp
+ done
+
+
+section \<open>Admissibility and compactness\<close>
+
+default_sort cpo
+
+
+subsection \<open>Definitions\<close>
+
+definition adm :: "('a::cpo \<Rightarrow> bool) \<Rightarrow> bool"
+ where "adm P \<longleftrightarrow> (\<forall>Y. chain Y \<longrightarrow> (\<forall>i. P (Y i)) \<longrightarrow> P (\<Squnion>i. Y i))"
+
+lemma admI: "(\<And>Y. \<lbrakk>chain Y; \<forall>i. P (Y i)\<rbrakk> \<Longrightarrow> P (\<Squnion>i. Y i)) \<Longrightarrow> adm P"
+ unfolding adm_def by fast
+
+lemma admD: "adm P \<Longrightarrow> chain Y \<Longrightarrow> (\<And>i. P (Y i)) \<Longrightarrow> P (\<Squnion>i. Y i)"
+ unfolding adm_def by fast
+
+lemma admD2: "adm (\<lambda>x. \<not> P x) \<Longrightarrow> chain Y \<Longrightarrow> P (\<Squnion>i. Y i) \<Longrightarrow> \<exists>i. P (Y i)"
+ unfolding adm_def by fast
+
+lemma triv_admI: "\<forall>x. P x \<Longrightarrow> adm P"
+ by (rule admI) (erule spec)
+
+
+subsection \<open>Admissibility on chain-finite types\<close>
+
+text \<open>For chain-finite (easy) types every formula is admissible.\<close>
+
+lemma adm_chfin [simp]: "adm P"
+ for P :: "'a::chfin \<Rightarrow> bool"
+ by (rule admI, frule chfin, auto simp add: maxinch_is_thelub)
+
+
+subsection \<open>Admissibility of special formulae and propagation\<close>
+
+lemma adm_const [simp]: "adm (\<lambda>x. t)"
+ by (rule admI, simp)
+
+lemma adm_conj [simp]: "adm (\<lambda>x. P x) \<Longrightarrow> adm (\<lambda>x. Q x) \<Longrightarrow> adm (\<lambda>x. P x \<and> Q x)"
+ by (fast intro: admI elim: admD)
+
+lemma adm_all [simp]: "(\<And>y. adm (\<lambda>x. P x y)) \<Longrightarrow> adm (\<lambda>x. \<forall>y. P x y)"
+ by (fast intro: admI elim: admD)
+
+lemma adm_ball [simp]: "(\<And>y. y \<in> A \<Longrightarrow> adm (\<lambda>x. P x y)) \<Longrightarrow> adm (\<lambda>x. \<forall>y\<in>A. P x y)"
+ by (fast intro: admI elim: admD)
+
+text \<open>Admissibility for disjunction is hard to prove. It requires 2 lemmas.\<close>
+
+lemma adm_disj_lemma1:
+ assumes adm: "adm P"
+ assumes chain: "chain Y"
+ assumes P: "\<forall>i. \<exists>j\<ge>i. P (Y j)"
+ shows "P (\<Squnion>i. Y i)"
+proof -
+ define f where "f i = (LEAST j. i \<le> j \<and> P (Y j))" for i
+ have chain': "chain (\<lambda>i. Y (f i))"
+ unfolding f_def
+ apply (rule chainI)
+ apply (rule chain_mono [OF chain])
+ apply (rule Least_le)
+ apply (rule LeastI2_ex)
+ apply (simp_all add: P)
+ done
+ have f1: "\<And>i. i \<le> f i" and f2: "\<And>i. P (Y (f i))"
+ using LeastI_ex [OF P [rule_format]] by (simp_all add: f_def)
+ have lub_eq: "(\<Squnion>i. Y i) = (\<Squnion>i. Y (f i))"
+ apply (rule below_antisym)
+ apply (rule lub_mono [OF chain chain'])
+ apply (rule chain_mono [OF chain f1])
+ apply (rule lub_range_mono [OF _ chain chain'])
+ apply clarsimp
+ done
+ show "P (\<Squnion>i. Y i)"
+ unfolding lub_eq using adm chain' f2 by (rule admD)
+qed
+
+lemma adm_disj_lemma2: "\<forall>n::nat. P n \<or> Q n \<Longrightarrow> (\<forall>i. \<exists>j\<ge>i. P j) \<or> (\<forall>i. \<exists>j\<ge>i. Q j)"
+ apply (erule contrapos_pp)
+ apply (clarsimp, rename_tac a b)
+ apply (rule_tac x="max a b" in exI)
+ apply simp
+ done
+
+lemma adm_disj [simp]: "adm (\<lambda>x. P x) \<Longrightarrow> adm (\<lambda>x. Q x) \<Longrightarrow> adm (\<lambda>x. P x \<or> Q x)"
+ apply (rule admI)
+ apply (erule adm_disj_lemma2 [THEN disjE])
+ apply (erule (2) adm_disj_lemma1 [THEN disjI1])
+ apply (erule (2) adm_disj_lemma1 [THEN disjI2])
+ done
+
+lemma adm_imp [simp]: "adm (\<lambda>x. \<not> P x) \<Longrightarrow> adm (\<lambda>x. Q x) \<Longrightarrow> adm (\<lambda>x. P x \<longrightarrow> Q x)"
+ by (subst imp_conv_disj) (rule adm_disj)
+
+lemma adm_iff [simp]: "adm (\<lambda>x. P x \<longrightarrow> Q x) \<Longrightarrow> adm (\<lambda>x. Q x \<longrightarrow> P x) \<Longrightarrow> adm (\<lambda>x. P x \<longleftrightarrow> Q x)"
+ by (subst iff_conv_conj_imp) (rule adm_conj)
+
+text \<open>admissibility and continuity\<close>
+
+lemma adm_below [simp]: "cont (\<lambda>x. u x) \<Longrightarrow> cont (\<lambda>x. v x) \<Longrightarrow> adm (\<lambda>x. u x \<sqsubseteq> v x)"
+ by (simp add: adm_def cont2contlubE lub_mono ch2ch_cont)
+
+lemma adm_eq [simp]: "cont (\<lambda>x. u x) \<Longrightarrow> cont (\<lambda>x. v x) \<Longrightarrow> adm (\<lambda>x. u x = v x)"
+ by (simp add: po_eq_conv)
+
+lemma adm_subst: "cont (\<lambda>x. t x) \<Longrightarrow> adm P \<Longrightarrow> adm (\<lambda>x. P (t x))"
+ by (simp add: adm_def cont2contlubE ch2ch_cont)
+
+lemma adm_not_below [simp]: "cont (\<lambda>x. t x) \<Longrightarrow> adm (\<lambda>x. t x \<notsqsubseteq> u)"
+ by (rule admI) (simp add: cont2contlubE ch2ch_cont lub_below_iff)
+
+
+subsection \<open>Compactness\<close>
+
+definition compact :: "'a::cpo \<Rightarrow> bool"
+ where "compact k = adm (\<lambda>x. k \<notsqsubseteq> x)"
+
+lemma compactI: "adm (\<lambda>x. k \<notsqsubseteq> x) \<Longrightarrow> compact k"
+ unfolding compact_def .
+
+lemma compactD: "compact k \<Longrightarrow> adm (\<lambda>x. k \<notsqsubseteq> x)"
+ unfolding compact_def .
+
+lemma compactI2: "(\<And>Y. \<lbrakk>chain Y; x \<sqsubseteq> (\<Squnion>i. Y i)\<rbrakk> \<Longrightarrow> \<exists>i. x \<sqsubseteq> Y i) \<Longrightarrow> compact x"
+ unfolding compact_def adm_def by fast
+
+lemma compactD2: "compact x \<Longrightarrow> chain Y \<Longrightarrow> x \<sqsubseteq> (\<Squnion>i. Y i) \<Longrightarrow> \<exists>i. x \<sqsubseteq> Y i"
+ unfolding compact_def adm_def by fast
+
+lemma compact_below_lub_iff: "compact x \<Longrightarrow> chain Y \<Longrightarrow> x \<sqsubseteq> (\<Squnion>i. Y i) \<longleftrightarrow> (\<exists>i. x \<sqsubseteq> Y i)"
+ by (fast intro: compactD2 elim: below_lub)
+
+lemma compact_chfin [simp]: "compact x"
+ for x :: "'a::chfin"
+ by (rule compactI [OF adm_chfin])
+
+lemma compact_imp_max_in_chain: "chain Y \<Longrightarrow> compact (\<Squnion>i. Y i) \<Longrightarrow> \<exists>i. max_in_chain i Y"
+ apply (drule (1) compactD2, simp)
+ apply (erule exE, rule_tac x=i in exI)
+ apply (rule max_in_chainI)
+ apply (rule below_antisym)
+ apply (erule (1) chain_mono)
+ apply (erule (1) below_trans [OF is_ub_thelub])
+ done
+
+text \<open>admissibility and compactness\<close>
+
+lemma adm_compact_not_below [simp]:
+ "compact k \<Longrightarrow> cont (\<lambda>x. t x) \<Longrightarrow> adm (\<lambda>x. k \<notsqsubseteq> t x)"
+ unfolding compact_def by (rule adm_subst)
+
+lemma adm_neq_compact [simp]: "compact k \<Longrightarrow> cont (\<lambda>x. t x) \<Longrightarrow> adm (\<lambda>x. t x \<noteq> k)"
+ by (simp add: po_eq_conv)
+
+lemma adm_compact_neq [simp]: "compact k \<Longrightarrow> cont (\<lambda>x. t x) \<Longrightarrow> adm (\<lambda>x. k \<noteq> t x)"
+ by (simp add: po_eq_conv)
+
+lemma compact_bottom [simp, intro]: "compact \<bottom>"
+ by (rule compactI) simp
+
+text \<open>Any upward-closed predicate is admissible.\<close>
+
+lemma adm_upward:
+ assumes P: "\<And>x y. \<lbrakk>P x; x \<sqsubseteq> y\<rbrakk> \<Longrightarrow> P y"
+ shows "adm P"
+ by (rule admI, drule spec, erule P, erule is_ub_thelub)
+
+lemmas adm_lemmas =
+ adm_const adm_conj adm_all adm_ball adm_disj adm_imp adm_iff
+ adm_below adm_eq adm_not_below
+ adm_compact_not_below adm_compact_neq adm_neq_compact
+
+
+section \<open>Class instances for the full function space\<close>
+
+subsection \<open>Full function space is a partial order\<close>
+
+instantiation "fun" :: (type, below) below
+begin
+
+definition below_fun_def: "(\<sqsubseteq>) \<equiv> (\<lambda>f g. \<forall>x. f x \<sqsubseteq> g x)"
+
+instance ..
+end
+
+instance "fun" :: (type, po) po
+proof
+ fix f :: "'a \<Rightarrow> 'b"
+ show "f \<sqsubseteq> f"
+ by (simp add: below_fun_def)
+next
+ fix f g :: "'a \<Rightarrow> 'b"
+ assume "f \<sqsubseteq> g" and "g \<sqsubseteq> f" then show "f = g"
+ by (simp add: below_fun_def fun_eq_iff below_antisym)
+next
+ fix f g h :: "'a \<Rightarrow> 'b"
+ assume "f \<sqsubseteq> g" and "g \<sqsubseteq> h" then show "f \<sqsubseteq> h"
+ unfolding below_fun_def by (fast elim: below_trans)
+qed
+
+lemma fun_below_iff: "f \<sqsubseteq> g \<longleftrightarrow> (\<forall>x. f x \<sqsubseteq> g x)"
+ by (simp add: below_fun_def)
+
+lemma fun_belowI: "(\<And>x. f x \<sqsubseteq> g x) \<Longrightarrow> f \<sqsubseteq> g"
+ by (simp add: below_fun_def)
+
+lemma fun_belowD: "f \<sqsubseteq> g \<Longrightarrow> f x \<sqsubseteq> g x"
+ by (simp add: below_fun_def)
+
+
+subsection \<open>Full function space is chain complete\<close>
+
+text \<open>Properties of chains of functions.\<close>
+
+lemma fun_chain_iff: "chain S \<longleftrightarrow> (\<forall>x. chain (\<lambda>i. S i x))"
+ by (auto simp: chain_def fun_below_iff)
+
+lemma ch2ch_fun: "chain S \<Longrightarrow> chain (\<lambda>i. S i x)"
+ by (simp add: chain_def below_fun_def)
+
+lemma ch2ch_lambda: "(\<And>x. chain (\<lambda>i. S i x)) \<Longrightarrow> chain S"
+ by (simp add: chain_def below_fun_def)
+
+text \<open>Type \<^typ>\<open>'a::type \<Rightarrow> 'b::cpo\<close> is chain complete\<close>
+
+lemma is_lub_lambda: "(\<And>x. range (\<lambda>i. Y i x) <<| f x) \<Longrightarrow> range Y <<| f"
+ by (simp add: is_lub_def is_ub_def below_fun_def)
+
+lemma is_lub_fun: "chain S \<Longrightarrow> range S <<| (\<lambda>x. \<Squnion>i. S i x)"
+ for S :: "nat \<Rightarrow> 'a::type \<Rightarrow> 'b::cpo"
+ apply (rule is_lub_lambda)
+ apply (rule cpo_lubI)
+ apply (erule ch2ch_fun)
+ done
+
+lemma lub_fun: "chain S \<Longrightarrow> (\<Squnion>i. S i) = (\<lambda>x. \<Squnion>i. S i x)"
+ for S :: "nat \<Rightarrow> 'a::type \<Rightarrow> 'b::cpo"
+ by (rule is_lub_fun [THEN lub_eqI])
+
+instance "fun" :: (type, cpo) cpo
+ by intro_classes (rule exI, erule is_lub_fun)
+
+instance "fun" :: (type, discrete_cpo) discrete_cpo
+proof
+ fix f g :: "'a \<Rightarrow> 'b"
+ show "f \<sqsubseteq> g \<longleftrightarrow> f = g"
+ by (simp add: fun_below_iff fun_eq_iff)
+qed
+
+
+subsection \<open>Full function space is pointed\<close>
+
+lemma minimal_fun: "(\<lambda>x. \<bottom>) \<sqsubseteq> f"
+ by (simp add: below_fun_def)
+
+instance "fun" :: (type, pcpo) pcpo
+ by standard (fast intro: minimal_fun)
+
+lemma inst_fun_pcpo: "\<bottom> = (\<lambda>x. \<bottom>)"
+ by (rule minimal_fun [THEN bottomI, symmetric])
+
+lemma app_strict [simp]: "\<bottom> x = \<bottom>"
+ by (simp add: inst_fun_pcpo)
+
+lemma lambda_strict: "(\<lambda>x. \<bottom>) = \<bottom>"
+ by (rule bottomI, rule minimal_fun)
+
+
+subsection \<open>Propagation of monotonicity and continuity\<close>
+
+text \<open>The lub of a chain of monotone functions is monotone.\<close>
+
+lemma adm_monofun: "adm monofun"
+ by (rule admI) (simp add: lub_fun fun_chain_iff monofun_def lub_mono)
+
+text \<open>The lub of a chain of continuous functions is continuous.\<close>
+
+lemma adm_cont: "adm cont"
+ by (rule admI) (simp add: lub_fun fun_chain_iff)
+
+text \<open>Function application preserves monotonicity and continuity.\<close>
+
+lemma mono2mono_fun: "monofun f \<Longrightarrow> monofun (\<lambda>x. f x y)"
+ by (simp add: monofun_def fun_below_iff)
+
+lemma cont2cont_fun: "cont f \<Longrightarrow> cont (\<lambda>x. f x y)"
+ apply (rule contI2)
+ apply (erule cont2mono [THEN mono2mono_fun])
+ apply (simp add: cont2contlubE lub_fun ch2ch_cont)
+ done
+
+lemma cont_fun: "cont (\<lambda>f. f x)"
+ using cont_id by (rule cont2cont_fun)
+
+text \<open>
+ Lambda abstraction preserves monotonicity and continuity.
+ (Note \<open>(\<lambda>x. \<lambda>y. f x y) = f\<close>.)
+\<close>
+
+lemma mono2mono_lambda: "(\<And>y. monofun (\<lambda>x. f x y)) \<Longrightarrow> monofun f"
+ by (simp add: monofun_def fun_below_iff)
+
+lemma cont2cont_lambda [simp]:
+ assumes f: "\<And>y. cont (\<lambda>x. f x y)"
+ shows "cont f"
+ by (rule contI, rule is_lub_lambda, rule contE [OF f])
+
+text \<open>What D.A.Schmidt calls continuity of abstraction; never used here\<close>
+
+lemma contlub_lambda: "(\<And>x. chain (\<lambda>i. S i x)) \<Longrightarrow> (\<lambda>x. \<Squnion>i. S i x) = (\<Squnion>i. (\<lambda>x. S i x))"
+ for S :: "nat \<Rightarrow> 'a::type \<Rightarrow> 'b::cpo"
+ by (simp add: lub_fun ch2ch_lambda)
+
+
+section \<open>The cpo of cartesian products\<close>
+
+subsection \<open>Unit type is a pcpo\<close>
+
+instantiation unit :: discrete_cpo
+begin
+
+definition below_unit_def [simp]: "x \<sqsubseteq> (y::unit) \<longleftrightarrow> True"
+
+instance
+ by standard simp
+
+end
+
+instance unit :: pcpo
+ by standard simp
+
+
+subsection \<open>Product type is a partial order\<close>
+
+instantiation prod :: (below, below) below
+begin
+
+definition below_prod_def: "(\<sqsubseteq>) \<equiv> \<lambda>p1 p2. (fst p1 \<sqsubseteq> fst p2 \<and> snd p1 \<sqsubseteq> snd p2)"
+
+instance ..
+
+end
+
+instance prod :: (po, po) po
+proof
+ fix x :: "'a \<times> 'b"
+ show "x \<sqsubseteq> x"
+ by (simp add: below_prod_def)
+next
+ fix x y :: "'a \<times> 'b"
+ assume "x \<sqsubseteq> y" "y \<sqsubseteq> x"
+ then show "x = y"
+ unfolding below_prod_def prod_eq_iff
+ by (fast intro: below_antisym)
+next
+ fix x y z :: "'a \<times> 'b"
+ assume "x \<sqsubseteq> y" "y \<sqsubseteq> z"
+ then show "x \<sqsubseteq> z"
+ unfolding below_prod_def
+ by (fast intro: below_trans)
+qed
+
+
+subsection \<open>Monotonicity of \emph{Pair}, \emph{fst}, \emph{snd}\<close>
+
+lemma prod_belowI: "fst p \<sqsubseteq> fst q \<Longrightarrow> snd p \<sqsubseteq> snd q \<Longrightarrow> p \<sqsubseteq> q"
+ by (simp add: below_prod_def)
+
+lemma Pair_below_iff [simp]: "(a, b) \<sqsubseteq> (c, d) \<longleftrightarrow> a \<sqsubseteq> c \<and> b \<sqsubseteq> d"
+ by (simp add: below_prod_def)
+
+text \<open>Pair \<open>(_,_)\<close> is monotone in both arguments\<close>
+
+lemma monofun_pair1: "monofun (\<lambda>x. (x, y))"
+ by (simp add: monofun_def)
+
+lemma monofun_pair2: "monofun (\<lambda>y. (x, y))"
+ by (simp add: monofun_def)
+
+lemma monofun_pair: "x1 \<sqsubseteq> x2 \<Longrightarrow> y1 \<sqsubseteq> y2 \<Longrightarrow> (x1, y1) \<sqsubseteq> (x2, y2)"
+ by simp
+
+lemma ch2ch_Pair [simp]: "chain X \<Longrightarrow> chain Y \<Longrightarrow> chain (\<lambda>i. (X i, Y i))"
+ by (rule chainI, simp add: chainE)
+
+text \<open>\<^term>\<open>fst\<close> and \<^term>\<open>snd\<close> are monotone\<close>
+
+lemma fst_monofun: "x \<sqsubseteq> y \<Longrightarrow> fst x \<sqsubseteq> fst y"
+ by (simp add: below_prod_def)
+
+lemma snd_monofun: "x \<sqsubseteq> y \<Longrightarrow> snd x \<sqsubseteq> snd y"
+ by (simp add: below_prod_def)
+
+lemma monofun_fst: "monofun fst"
+ by (simp add: monofun_def below_prod_def)
+
+lemma monofun_snd: "monofun snd"
+ by (simp add: monofun_def below_prod_def)
+
+lemmas ch2ch_fst [simp] = ch2ch_monofun [OF monofun_fst]
+
+lemmas ch2ch_snd [simp] = ch2ch_monofun [OF monofun_snd]
+
+lemma prod_chain_cases:
+ assumes chain: "chain Y"
+ obtains A B
+ where "chain A" and "chain B" and "Y = (\<lambda>i. (A i, B i))"
+proof
+ from chain show "chain (\<lambda>i. fst (Y i))"
+ by (rule ch2ch_fst)
+ from chain show "chain (\<lambda>i. snd (Y i))"
+ by (rule ch2ch_snd)
+ show "Y = (\<lambda>i. (fst (Y i), snd (Y i)))"
+ by simp
+qed
+
+
+subsection \<open>Product type is a cpo\<close>
+
+lemma is_lub_Pair: "range A <<| x \<Longrightarrow> range B <<| y \<Longrightarrow> range (\<lambda>i. (A i, B i)) <<| (x, y)"
+ by (simp add: is_lub_def is_ub_def below_prod_def)
+
+lemma lub_Pair: "chain A \<Longrightarrow> chain B \<Longrightarrow> (\<Squnion>i. (A i, B i)) = (\<Squnion>i. A i, \<Squnion>i. B i)"
+ for A :: "nat \<Rightarrow> 'a::cpo" and B :: "nat \<Rightarrow> 'b::cpo"
+ by (fast intro: lub_eqI is_lub_Pair elim: thelubE)
+
+lemma is_lub_prod:
+ fixes S :: "nat \<Rightarrow> ('a::cpo \<times> 'b::cpo)"
+ assumes "chain S"
+ shows "range S <<| (\<Squnion>i. fst (S i), \<Squnion>i. snd (S i))"
+ using assms by (auto elim: prod_chain_cases simp: is_lub_Pair cpo_lubI)
+
+lemma lub_prod: "chain S \<Longrightarrow> (\<Squnion>i. S i) = (\<Squnion>i. fst (S i), \<Squnion>i. snd (S i))"
+ for S :: "nat \<Rightarrow> 'a::cpo \<times> 'b::cpo"
+ by (rule is_lub_prod [THEN lub_eqI])
+
+instance prod :: (cpo, cpo) cpo
+proof
+ fix S :: "nat \<Rightarrow> ('a \<times> 'b)"
+ assume "chain S"
+ then have "range S <<| (\<Squnion>i. fst (S i), \<Squnion>i. snd (S i))"
+ by (rule is_lub_prod)
+ then show "\<exists>x. range S <<| x" ..
+qed
+
+instance prod :: (discrete_cpo, discrete_cpo) discrete_cpo
+proof
+ fix x y :: "'a \<times> 'b"
+ show "x \<sqsubseteq> y \<longleftrightarrow> x = y"
+ by (simp add: below_prod_def prod_eq_iff)
+qed
+
+
+subsection \<open>Product type is pointed\<close>
+
+lemma minimal_prod: "(\<bottom>, \<bottom>) \<sqsubseteq> p"
+ by (simp add: below_prod_def)
+
+instance prod :: (pcpo, pcpo) pcpo
+ by intro_classes (fast intro: minimal_prod)
+
+lemma inst_prod_pcpo: "\<bottom> = (\<bottom>, \<bottom>)"
+ by (rule minimal_prod [THEN bottomI, symmetric])
+
+lemma Pair_bottom_iff [simp]: "(x, y) = \<bottom> \<longleftrightarrow> x = \<bottom> \<and> y = \<bottom>"
+ by (simp add: inst_prod_pcpo)
+
+lemma fst_strict [simp]: "fst \<bottom> = \<bottom>"
+ unfolding inst_prod_pcpo by (rule fst_conv)
+
+lemma snd_strict [simp]: "snd \<bottom> = \<bottom>"
+ unfolding inst_prod_pcpo by (rule snd_conv)
+
+lemma Pair_strict [simp]: "(\<bottom>, \<bottom>) = \<bottom>"
+ by simp
+
+lemma split_strict [simp]: "case_prod f \<bottom> = f \<bottom> \<bottom>"
+ by (simp add: split_def)
+
+
+subsection \<open>Continuity of \emph{Pair}, \emph{fst}, \emph{snd}\<close>
+
+lemma cont_pair1: "cont (\<lambda>x. (x, y))"
+ apply (rule contI)
+ apply (rule is_lub_Pair)
+ apply (erule cpo_lubI)
+ apply (rule is_lub_const)
+ done
+
+lemma cont_pair2: "cont (\<lambda>y. (x, y))"
+ apply (rule contI)
+ apply (rule is_lub_Pair)
+ apply (rule is_lub_const)
+ apply (erule cpo_lubI)
+ done
+
+lemma cont_fst: "cont fst"
+ apply (rule contI)
+ apply (simp add: lub_prod)
+ apply (erule cpo_lubI [OF ch2ch_fst])
+ done
+
+lemma cont_snd: "cont snd"
+ apply (rule contI)
+ apply (simp add: lub_prod)
+ apply (erule cpo_lubI [OF ch2ch_snd])
+ done
+
+lemma cont2cont_Pair [simp, cont2cont]:
+ assumes f: "cont (\<lambda>x. f x)"
+ assumes g: "cont (\<lambda>x. g x)"
+ shows "cont (\<lambda>x. (f x, g x))"
+ apply (rule cont_apply [OF f cont_pair1])
+ apply (rule cont_apply [OF g cont_pair2])
+ apply (rule cont_const)
+ done
+
+lemmas cont2cont_fst [simp, cont2cont] = cont_compose [OF cont_fst]
+
+lemmas cont2cont_snd [simp, cont2cont] = cont_compose [OF cont_snd]
+
+lemma cont2cont_case_prod:
+ assumes f1: "\<And>a b. cont (\<lambda>x. f x a b)"
+ assumes f2: "\<And>x b. cont (\<lambda>a. f x a b)"
+ assumes f3: "\<And>x a. cont (\<lambda>b. f x a b)"
+ assumes g: "cont (\<lambda>x. g x)"
+ shows "cont (\<lambda>x. case g x of (a, b) \<Rightarrow> f x a b)"
+ unfolding split_def
+ apply (rule cont_apply [OF g])
+ apply (rule cont_apply [OF cont_fst f2])
+ apply (rule cont_apply [OF cont_snd f3])
+ apply (rule cont_const)
+ apply (rule f1)
+ done
+
+lemma prod_contI:
+ assumes f1: "\<And>y. cont (\<lambda>x. f (x, y))"
+ assumes f2: "\<And>x. cont (\<lambda>y. f (x, y))"
+ shows "cont f"
+proof -
+ have "cont (\<lambda>(x, y). f (x, y))"
+ by (intro cont2cont_case_prod f1 f2 cont2cont)
+ then show "cont f"
+ by (simp only: case_prod_eta)
+qed
+
+lemma prod_cont_iff: "cont f \<longleftrightarrow> (\<forall>y. cont (\<lambda>x. f (x, y))) \<and> (\<forall>x. cont (\<lambda>y. f (x, y)))"
+ apply safe
+ apply (erule cont_compose [OF _ cont_pair1])
+ apply (erule cont_compose [OF _ cont_pair2])
+ apply (simp only: prod_contI)
+ done
+
+lemma cont2cont_case_prod' [simp, cont2cont]:
+ assumes f: "cont (\<lambda>p. f (fst p) (fst (snd p)) (snd (snd p)))"
+ assumes g: "cont (\<lambda>x. g x)"
+ shows "cont (\<lambda>x. case_prod (f x) (g x))"
+ using assms by (simp add: cont2cont_case_prod prod_cont_iff)
+
+text \<open>The simple version (due to Joachim Breitner) is needed if
+ either element type of the pair is not a cpo.\<close>
+
+lemma cont2cont_split_simple [simp, cont2cont]:
+ assumes "\<And>a b. cont (\<lambda>x. f x a b)"
+ shows "cont (\<lambda>x. case p of (a, b) \<Rightarrow> f x a b)"
+ using assms by (cases p) auto
+
+text \<open>Admissibility of predicates on product types.\<close>
+
+lemma adm_case_prod [simp]:
+ assumes "adm (\<lambda>x. P x (fst (f x)) (snd (f x)))"
+ shows "adm (\<lambda>x. case f x of (a, b) \<Rightarrow> P x a b)"
+ unfolding case_prod_beta using assms .
+
+
+subsection \<open>Compactness and chain-finiteness\<close>
+
+lemma fst_below_iff: "fst x \<sqsubseteq> y \<longleftrightarrow> x \<sqsubseteq> (y, snd x)"
+ for x :: "'a \<times> 'b"
+ by (simp add: below_prod_def)
+
+lemma snd_below_iff: "snd x \<sqsubseteq> y \<longleftrightarrow> x \<sqsubseteq> (fst x, y)"
+ for x :: "'a \<times> 'b"
+ by (simp add: below_prod_def)
+
+lemma compact_fst: "compact x \<Longrightarrow> compact (fst x)"
+ by (rule compactI) (simp add: fst_below_iff)
+
+lemma compact_snd: "compact x \<Longrightarrow> compact (snd x)"
+ by (rule compactI) (simp add: snd_below_iff)
+
+lemma compact_Pair: "compact x \<Longrightarrow> compact y \<Longrightarrow> compact (x, y)"
+ by (rule compactI) (simp add: below_prod_def)
+
+lemma compact_Pair_iff [simp]: "compact (x, y) \<longleftrightarrow> compact x \<and> compact y"
+ apply (safe intro!: compact_Pair)
+ apply (drule compact_fst, simp)
+ apply (drule compact_snd, simp)
+ done
+
+instance prod :: (chfin, chfin) chfin
+ apply intro_classes
+ apply (erule compact_imp_max_in_chain)
+ apply (case_tac "\<Squnion>i. Y i", simp)
+ done
+
+
+section \<open>Discrete cpo types\<close>
+
+datatype 'a discr = Discr "'a :: type"
+
+subsection \<open>Discrete cpo class instance\<close>
+
+instantiation discr :: (type) discrete_cpo
+begin
+
+definition "((\<sqsubseteq>) :: 'a discr \<Rightarrow> 'a discr \<Rightarrow> bool) = (=)"
+
+instance
+ by standard (simp add: below_discr_def)
+
+end
+
+
+subsection \<open>\emph{undiscr}\<close>
+
+definition undiscr :: "('a::type)discr \<Rightarrow> 'a"
+ where "undiscr x = (case x of Discr y \<Rightarrow> y)"
+
+lemma undiscr_Discr [simp]: "undiscr (Discr x) = x"
+ by (simp add: undiscr_def)
+
+lemma Discr_undiscr [simp]: "Discr (undiscr y) = y"
+ by (induct y) simp
+
+end
--- a/src/HOL/HOLCF/Cpodef.thy Wed Dec 11 13:44:16 2024 +0100
+++ b/src/HOL/HOLCF/Cpodef.thy Wed Dec 11 13:44:35 2024 +0100
@@ -5,7 +5,7 @@
section \<open>Subtypes of pcpos\<close>
theory Cpodef
- imports Adm
+ imports Cpo
keywords "pcpodef" "cpodef" :: thy_goal_defn
begin
@@ -16,7 +16,7 @@
if the ordering is defined in the standard way.
\<close>
-setup \<open>Sign.add_const_constraint (\<^const_name>\<open>Porder.below\<close>, NONE)\<close>
+setup \<open>Sign.add_const_constraint (\<^const_name>\<open>below\<close>, NONE)\<close>
theorem typedef_po:
fixes Abs :: "'a::po \<Rightarrow> 'b::type"
@@ -30,7 +30,7 @@
apply (erule (1) below_antisym)
done
-setup \<open>Sign.add_const_constraint (\<^const_name>\<open>Porder.below\<close>, SOME \<^typ>\<open>'a::below \<Rightarrow> 'a::below \<Rightarrow> bool\<close>)\<close>
+setup \<open>Sign.add_const_constraint (\<^const_name>\<open>below\<close>, SOME \<^typ>\<open>'a::below \<Rightarrow> 'a::below \<Rightarrow> bool\<close>)\<close>
subsection \<open>Proving a subtype is finite\<close>
--- a/src/HOL/HOLCF/Deflation.thy Wed Dec 11 13:44:16 2024 +0100
+++ b/src/HOL/HOLCF/Deflation.thy Wed Dec 11 13:44:35 2024 +0100
@@ -313,6 +313,7 @@
end
+
subsection \<open>Uniqueness of ep-pairs\<close>
lemma ep_pair_unique_e_lemma:
--- a/src/HOL/HOLCF/Discrete_Cpo.thy Wed Dec 11 13:44:16 2024 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,37 +0,0 @@
-(* Title: HOL/HOLCF/Discrete_Cpo.thy
- Author: Tobias Nipkow
-*)
-
-section \<open>Discrete cpo types\<close>
-
-theory Discrete_Cpo
- imports Cont
-begin
-
-datatype 'a discr = Discr "'a :: type"
-
-subsection \<open>Discrete cpo class instance\<close>
-
-instantiation discr :: (type) discrete_cpo
-begin
-
-definition "((\<sqsubseteq>) :: 'a discr \<Rightarrow> 'a discr \<Rightarrow> bool) = (=)"
-
-instance
- by standard (simp add: below_discr_def)
-
-end
-
-
-subsection \<open>\emph{undiscr}\<close>
-
-definition undiscr :: "('a::type)discr \<Rightarrow> 'a"
- where "undiscr x = (case x of Discr y \<Rightarrow> y)"
-
-lemma undiscr_Discr [simp]: "undiscr (Discr x) = x"
- by (simp add: undiscr_def)
-
-lemma Discr_undiscr [simp]: "Discr (undiscr y) = y"
- by (induct y) simp
-
-end
--- a/src/HOL/HOLCF/Domain.thy Wed Dec 11 13:44:16 2024 +0100
+++ b/src/HOL/HOLCF/Domain.thy Wed Dec 11 13:44:35 2024 +0100
@@ -5,17 +5,377 @@
section \<open>Domain package\<close>
theory Domain
-imports Representable Domain_Aux
+imports Representable Map_Functions Fixrec
keywords
"lazy" "unsafe" and
"domaindef" "domain" :: thy_defn and
"domain_isomorphism" :: thy_decl
begin
-default_sort "domain"
+subsection \<open>Continuous isomorphisms\<close>
+
+text \<open>A locale for continuous isomorphisms\<close>
+
+locale iso =
+ fixes abs :: "'a \<rightarrow> 'b"
+ fixes rep :: "'b \<rightarrow> 'a"
+ assumes abs_iso [simp]: "rep\<cdot>(abs\<cdot>x) = x"
+ assumes rep_iso [simp]: "abs\<cdot>(rep\<cdot>y) = y"
+begin
+
+lemma swap: "iso rep abs"
+ by (rule iso.intro [OF rep_iso abs_iso])
+
+lemma abs_below: "(abs\<cdot>x \<sqsubseteq> abs\<cdot>y) = (x \<sqsubseteq> y)"
+proof
+ assume "abs\<cdot>x \<sqsubseteq> abs\<cdot>y"
+ then have "rep\<cdot>(abs\<cdot>x) \<sqsubseteq> rep\<cdot>(abs\<cdot>y)" by (rule monofun_cfun_arg)
+ then show "x \<sqsubseteq> y" by simp
+next
+ assume "x \<sqsubseteq> y"
+ then show "abs\<cdot>x \<sqsubseteq> abs\<cdot>y" by (rule monofun_cfun_arg)
+qed
+
+lemma rep_below: "(rep\<cdot>x \<sqsubseteq> rep\<cdot>y) = (x \<sqsubseteq> y)"
+ by (rule iso.abs_below [OF swap])
+
+lemma abs_eq: "(abs\<cdot>x = abs\<cdot>y) = (x = y)"
+ by (simp add: po_eq_conv abs_below)
+
+lemma rep_eq: "(rep\<cdot>x = rep\<cdot>y) = (x = y)"
+ by (rule iso.abs_eq [OF swap])
+
+lemma abs_strict: "abs\<cdot>\<bottom> = \<bottom>"
+proof -
+ have "\<bottom> \<sqsubseteq> rep\<cdot>\<bottom>" ..
+ then have "abs\<cdot>\<bottom> \<sqsubseteq> abs\<cdot>(rep\<cdot>\<bottom>)" by (rule monofun_cfun_arg)
+ then have "abs\<cdot>\<bottom> \<sqsubseteq> \<bottom>" by simp
+ then show ?thesis by (rule bottomI)
+qed
+
+lemma rep_strict: "rep\<cdot>\<bottom> = \<bottom>"
+ by (rule iso.abs_strict [OF swap])
+
+lemma abs_defin': "abs\<cdot>x = \<bottom> \<Longrightarrow> x = \<bottom>"
+proof -
+ have "x = rep\<cdot>(abs\<cdot>x)" by simp
+ also assume "abs\<cdot>x = \<bottom>"
+ also note rep_strict
+ finally show "x = \<bottom>" .
+qed
+
+lemma rep_defin': "rep\<cdot>z = \<bottom> \<Longrightarrow> z = \<bottom>"
+ by (rule iso.abs_defin' [OF swap])
+
+lemma abs_defined: "z \<noteq> \<bottom> \<Longrightarrow> abs\<cdot>z \<noteq> \<bottom>"
+ by (erule contrapos_nn, erule abs_defin')
+
+lemma rep_defined: "z \<noteq> \<bottom> \<Longrightarrow> rep\<cdot>z \<noteq> \<bottom>"
+ by (rule iso.abs_defined [OF iso.swap]) (rule iso_axioms)
+
+lemma abs_bottom_iff: "(abs\<cdot>x = \<bottom>) = (x = \<bottom>)"
+ by (auto elim: abs_defin' intro: abs_strict)
+
+lemma rep_bottom_iff: "(rep\<cdot>x = \<bottom>) = (x = \<bottom>)"
+ by (rule iso.abs_bottom_iff [OF iso.swap]) (rule iso_axioms)
+
+lemma casedist_rule: "rep\<cdot>x = \<bottom> \<or> P \<Longrightarrow> x = \<bottom> \<or> P"
+ by (simp add: rep_bottom_iff)
+
+lemma compact_abs_rev: "compact (abs\<cdot>x) \<Longrightarrow> compact x"
+proof (unfold compact_def)
+ assume "adm (\<lambda>y. abs\<cdot>x \<notsqsubseteq> y)"
+ with cont_Rep_cfun2
+ have "adm (\<lambda>y. abs\<cdot>x \<notsqsubseteq> abs\<cdot>y)" by (rule adm_subst)
+ then show "adm (\<lambda>y. x \<notsqsubseteq> y)" using abs_below by simp
+qed
+
+lemma compact_rep_rev: "compact (rep\<cdot>x) \<Longrightarrow> compact x"
+ by (rule iso.compact_abs_rev [OF iso.swap]) (rule iso_axioms)
+
+lemma compact_abs: "compact x \<Longrightarrow> compact (abs\<cdot>x)"
+ by (rule compact_rep_rev) simp
+
+lemma compact_rep: "compact x \<Longrightarrow> compact (rep\<cdot>x)"
+ by (rule iso.compact_abs [OF iso.swap]) (rule iso_axioms)
+
+lemma iso_swap: "(x = abs\<cdot>y) = (rep\<cdot>x = y)"
+proof
+ assume "x = abs\<cdot>y"
+ then have "rep\<cdot>x = rep\<cdot>(abs\<cdot>y)" by simp
+ then show "rep\<cdot>x = y" by simp
+next
+ assume "rep\<cdot>x = y"
+ then have "abs\<cdot>(rep\<cdot>x) = abs\<cdot>y" by simp
+ then show "x = abs\<cdot>y" by simp
+qed
+
+end
+
+
+subsection \<open>Proofs about take functions\<close>
+
+text \<open>
+ This section contains lemmas that are used in a module that supports
+ the domain isomorphism package; the module contains proofs related
+ to take functions and the finiteness predicate.
+\<close>
+
+lemma deflation_abs_rep:
+ fixes abs and rep and d
+ assumes abs_iso: "\<And>x. rep\<cdot>(abs\<cdot>x) = x"
+ assumes rep_iso: "\<And>y. abs\<cdot>(rep\<cdot>y) = y"
+ shows "deflation d \<Longrightarrow> deflation (abs oo d oo rep)"
+by (rule ep_pair.deflation_e_d_p) (simp add: ep_pair.intro assms)
+
+lemma deflation_chain_min:
+ assumes chain: "chain d"
+ assumes defl: "\<And>n. deflation (d n)"
+ shows "d m\<cdot>(d n\<cdot>x) = d (min m n)\<cdot>x"
+proof (rule linorder_le_cases)
+ assume "m \<le> n"
+ with chain have "d m \<sqsubseteq> d n" by (rule chain_mono)
+ then have "d m\<cdot>(d n\<cdot>x) = d m\<cdot>x"
+ by (rule deflation_below_comp1 [OF defl defl])
+ moreover from \<open>m \<le> n\<close> have "min m n = m" by simp
+ ultimately show ?thesis by simp
+next
+ assume "n \<le> m"
+ with chain have "d n \<sqsubseteq> d m" by (rule chain_mono)
+ then have "d m\<cdot>(d n\<cdot>x) = d n\<cdot>x"
+ by (rule deflation_below_comp2 [OF defl defl])
+ moreover from \<open>n \<le> m\<close> have "min m n = n" by simp
+ ultimately show ?thesis by simp
+qed
+
+lemma lub_ID_take_lemma:
+ assumes "chain t" and "(\<Squnion>n. t n) = ID"
+ assumes "\<And>n. t n\<cdot>x = t n\<cdot>y" shows "x = y"
+proof -
+ have "(\<Squnion>n. t n\<cdot>x) = (\<Squnion>n. t n\<cdot>y)"
+ using assms(3) by simp
+ then have "(\<Squnion>n. t n)\<cdot>x = (\<Squnion>n. t n)\<cdot>y"
+ using assms(1) by (simp add: lub_distribs)
+ then show "x = y"
+ using assms(2) by simp
+qed
+
+lemma lub_ID_reach:
+ assumes "chain t" and "(\<Squnion>n. t n) = ID"
+ shows "(\<Squnion>n. t n\<cdot>x) = x"
+using assms by (simp add: lub_distribs)
+
+lemma lub_ID_take_induct:
+ assumes "chain t" and "(\<Squnion>n. t n) = ID"
+ assumes "adm P" and "\<And>n. P (t n\<cdot>x)" shows "P x"
+proof -
+ from \<open>chain t\<close> have "chain (\<lambda>n. t n\<cdot>x)" by simp
+ from \<open>adm P\<close> this \<open>\<And>n. P (t n\<cdot>x)\<close> have "P (\<Squnion>n. t n\<cdot>x)" by (rule admD)
+ with \<open>chain t\<close> \<open>(\<Squnion>n. t n) = ID\<close> show "P x" by (simp add: lub_distribs)
+qed
+
+
+subsection \<open>Finiteness\<close>
+
+text \<open>
+ Let a ``decisive'' function be a deflation that maps every input to
+ either itself or bottom. Then if a domain's take functions are all
+ decisive, then all values in the domain are finite.
+\<close>
+
+definition
+ decisive :: "('a::pcpo \<rightarrow> 'a) \<Rightarrow> bool"
+where
+ "decisive d \<longleftrightarrow> (\<forall>x. d\<cdot>x = x \<or> d\<cdot>x = \<bottom>)"
+
+lemma decisiveI: "(\<And>x. d\<cdot>x = x \<or> d\<cdot>x = \<bottom>) \<Longrightarrow> decisive d"
+ unfolding decisive_def by simp
+
+lemma decisive_cases:
+ assumes "decisive d" obtains "d\<cdot>x = x" | "d\<cdot>x = \<bottom>"
+using assms unfolding decisive_def by auto
+
+lemma decisive_bottom: "decisive \<bottom>"
+ unfolding decisive_def by simp
+
+lemma decisive_ID: "decisive ID"
+ unfolding decisive_def by simp
+
+lemma decisive_ssum_map:
+ assumes f: "decisive f"
+ assumes g: "decisive g"
+ shows "decisive (ssum_map\<cdot>f\<cdot>g)"
+ apply (rule decisiveI)
+ subgoal for s
+ apply (cases s, simp_all)
+ apply (rule_tac x=x in decisive_cases [OF f], simp_all)
+ apply (rule_tac x=y in decisive_cases [OF g], simp_all)
+ done
+ done
+
+lemma decisive_sprod_map:
+ assumes f: "decisive f"
+ assumes g: "decisive g"
+ shows "decisive (sprod_map\<cdot>f\<cdot>g)"
+ apply (rule decisiveI)
+ subgoal for s
+ apply (cases s, simp)
+ subgoal for x y
+ apply (rule decisive_cases [OF f, where x = x], simp_all)
+ apply (rule decisive_cases [OF g, where x = y], simp_all)
+ done
+ done
+ done
+
+lemma decisive_abs_rep:
+ fixes abs rep
+ assumes iso: "iso abs rep"
+ assumes d: "decisive d"
+ shows "decisive (abs oo d oo rep)"
+ apply (rule decisiveI)
+ subgoal for s
+ apply (rule decisive_cases [OF d, where x="rep\<cdot>s"])
+ apply (simp add: iso.rep_iso [OF iso])
+ apply (simp add: iso.abs_strict [OF iso])
+ done
+ done
+
+lemma lub_ID_finite:
+ assumes chain: "chain d"
+ assumes lub: "(\<Squnion>n. d n) = ID"
+ assumes decisive: "\<And>n. decisive (d n)"
+ shows "\<exists>n. d n\<cdot>x = x"
+proof -
+ have 1: "chain (\<lambda>n. d n\<cdot>x)" using chain by simp
+ have 2: "(\<Squnion>n. d n\<cdot>x) = x" using chain lub by (rule lub_ID_reach)
+ have "\<forall>n. d n\<cdot>x = x \<or> d n\<cdot>x = \<bottom>"
+ using decisive unfolding decisive_def by simp
+ hence "range (\<lambda>n. d n\<cdot>x) \<subseteq> {x, \<bottom>}"
+ by auto
+ hence "finite (range (\<lambda>n. d n\<cdot>x))"
+ by (rule finite_subset, simp)
+ with 1 have "finite_chain (\<lambda>n. d n\<cdot>x)"
+ by (rule finite_range_imp_finch)
+ then have "\<exists>n. (\<Squnion>n. d n\<cdot>x) = d n\<cdot>x"
+ unfolding finite_chain_def by (auto simp add: maxinch_is_thelub)
+ with 2 show "\<exists>n. d n\<cdot>x = x" by (auto elim: sym)
+qed
+
+lemma lub_ID_finite_take_induct:
+ assumes "chain d" and "(\<Squnion>n. d n) = ID" and "\<And>n. decisive (d n)"
+ shows "(\<And>n. P (d n\<cdot>x)) \<Longrightarrow> P x"
+using lub_ID_finite [OF assms] by metis
+
+
+subsection \<open>Proofs about constructor functions\<close>
+
+text \<open>Lemmas for proving nchotomy rule:\<close>
+
+lemma ex_one_bottom_iff:
+ "(\<exists>x. P x \<and> x \<noteq> \<bottom>) = P ONE"
+by simp
+
+lemma ex_up_bottom_iff:
+ "(\<exists>x. P x \<and> x \<noteq> \<bottom>) = (\<exists>x. P (up\<cdot>x))"
+by (safe, case_tac x, auto)
+
+lemma ex_sprod_bottom_iff:
+ "(\<exists>y. P y \<and> y \<noteq> \<bottom>) =
+ (\<exists>x y. (P (:x, y:) \<and> x \<noteq> \<bottom>) \<and> y \<noteq> \<bottom>)"
+by (safe, case_tac y, auto)
+
+lemma ex_sprod_up_bottom_iff:
+ "(\<exists>y. P y \<and> y \<noteq> \<bottom>) =
+ (\<exists>x y. P (:up\<cdot>x, y:) \<and> y \<noteq> \<bottom>)"
+by (safe, case_tac y, simp, case_tac x, auto)
+
+lemma ex_ssum_bottom_iff:
+ "(\<exists>x. P x \<and> x \<noteq> \<bottom>) =
+ ((\<exists>x. P (sinl\<cdot>x) \<and> x \<noteq> \<bottom>) \<or>
+ (\<exists>x. P (sinr\<cdot>x) \<and> x \<noteq> \<bottom>))"
+by (safe, case_tac x, auto)
+
+lemma exh_start: "p = \<bottom> \<or> (\<exists>x. p = x \<and> x \<noteq> \<bottom>)"
+ by auto
+
+lemmas ex_bottom_iffs =
+ ex_ssum_bottom_iff
+ ex_sprod_up_bottom_iff
+ ex_sprod_bottom_iff
+ ex_up_bottom_iff
+ ex_one_bottom_iff
+
+text \<open>Rules for turning nchotomy into exhaust:\<close>
+
+lemma exh_casedist0: "\<lbrakk>R; R \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P" (* like make_elim *)
+ by auto
+
+lemma exh_casedist1: "((P \<or> Q \<Longrightarrow> R) \<Longrightarrow> S) \<equiv> (\<lbrakk>P \<Longrightarrow> R; Q \<Longrightarrow> R\<rbrakk> \<Longrightarrow> S)"
+ by rule auto
+
+lemma exh_casedist2: "(\<exists>x. P x \<Longrightarrow> Q) \<equiv> (\<And>x. P x \<Longrightarrow> Q)"
+ by rule auto
+
+lemma exh_casedist3: "(P \<and> Q \<Longrightarrow> R) \<equiv> (P \<Longrightarrow> Q \<Longrightarrow> R)"
+ by rule auto
+
+lemmas exh_casedists = exh_casedist1 exh_casedist2 exh_casedist3
+
+text \<open>Rules for proving constructor properties\<close>
+
+lemmas con_strict_rules =
+ sinl_strict sinr_strict spair_strict1 spair_strict2
+
+lemmas con_bottom_iff_rules =
+ sinl_bottom_iff sinr_bottom_iff spair_bottom_iff up_defined ONE_defined
+
+lemmas con_below_iff_rules =
+ sinl_below sinr_below sinl_below_sinr sinr_below_sinl con_bottom_iff_rules
+
+lemmas con_eq_iff_rules =
+ sinl_eq sinr_eq sinl_eq_sinr sinr_eq_sinl con_bottom_iff_rules
+
+lemmas sel_strict_rules =
+ cfcomp2 sscase1 sfst_strict ssnd_strict fup1
+
+lemma sel_app_extra_rules:
+ "sscase\<cdot>ID\<cdot>\<bottom>\<cdot>(sinr\<cdot>x) = \<bottom>"
+ "sscase\<cdot>ID\<cdot>\<bottom>\<cdot>(sinl\<cdot>x) = x"
+ "sscase\<cdot>\<bottom>\<cdot>ID\<cdot>(sinl\<cdot>x) = \<bottom>"
+ "sscase\<cdot>\<bottom>\<cdot>ID\<cdot>(sinr\<cdot>x) = x"
+ "fup\<cdot>ID\<cdot>(up\<cdot>x) = x"
+by (cases "x = \<bottom>", simp, simp)+
+
+lemmas sel_app_rules =
+ sel_strict_rules sel_app_extra_rules
+ ssnd_spair sfst_spair up_defined spair_defined
+
+lemmas sel_bottom_iff_rules =
+ cfcomp2 sfst_bottom_iff ssnd_bottom_iff
+
+lemmas take_con_rules =
+ ssum_map_sinl' ssum_map_sinr' sprod_map_spair' u_map_up
+ deflation_strict deflation_ID ID1 cfcomp2
+
+
+subsection \<open>ML setup\<close>
+
+named_theorems domain_deflation "theorems like deflation a ==> deflation (foo_map$a)"
+ and domain_map_ID "theorems like foo_map$ID = ID"
+
+ML_file \<open>Tools/Domain/domain_take_proofs.ML\<close>
+ML_file \<open>Tools/cont_consts.ML\<close>
+ML_file \<open>Tools/cont_proc.ML\<close>
+simproc_setup cont ("cont f") = \<open>K ContProc.cont_proc\<close>
+
+ML_file \<open>Tools/Domain/domain_constructors.ML\<close>
+ML_file \<open>Tools/Domain/domain_induction.ML\<close>
+
subsection \<open>Representations of types\<close>
+default_sort "domain"
+
lemma emb_prj: "emb\<cdot>((prj\<cdot>x)::'a) = cast\<cdot>DEFL('a)\<cdot>x"
by (simp add: cast_DEFL)
@@ -60,6 +420,7 @@
unfolding abs_def rep_def
by (simp add: emb_prj_emb DEFL)
+
subsection \<open>Deflations as sets\<close>
definition defl_set :: "'a::bifinite defl \<Rightarrow> 'a set"
@@ -79,6 +440,7 @@
apply (auto simp add: cast.belowI cast.belowD)
done
+
subsection \<open>Proving a subtype is representable\<close>
text \<open>Temporarily relax type constraints.\<close>
@@ -153,6 +515,7 @@
ML_file \<open>Tools/domaindef.ML\<close>
+
subsection \<open>Isomorphic deflations\<close>
definition isodefl :: "('a \<rightarrow> 'a) \<Rightarrow> udom defl \<Rightarrow> bool"
@@ -315,6 +678,7 @@
using isodefl_sfun [OF assms] unfolding isodefl_def
by (simp add: emb_cfun_def prj_cfun_def cfcomp1 encode_cfun_map)
+
subsection \<open>Setting up the domain package\<close>
named_theorems domain_defl_simps "theorems like DEFL('a t) = t_defl$DEFL('a)"
--- a/src/HOL/HOLCF/Domain_Aux.thy Wed Dec 11 13:44:16 2024 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,366 +0,0 @@
-(* Title: HOL/HOLCF/Domain_Aux.thy
- Author: Brian Huffman
-*)
-
-section \<open>Domain package support\<close>
-
-theory Domain_Aux
-imports Map_Functions Fixrec
-begin
-
-subsection \<open>Continuous isomorphisms\<close>
-
-text \<open>A locale for continuous isomorphisms\<close>
-
-locale iso =
- fixes abs :: "'a \<rightarrow> 'b"
- fixes rep :: "'b \<rightarrow> 'a"
- assumes abs_iso [simp]: "rep\<cdot>(abs\<cdot>x) = x"
- assumes rep_iso [simp]: "abs\<cdot>(rep\<cdot>y) = y"
-begin
-
-lemma swap: "iso rep abs"
- by (rule iso.intro [OF rep_iso abs_iso])
-
-lemma abs_below: "(abs\<cdot>x \<sqsubseteq> abs\<cdot>y) = (x \<sqsubseteq> y)"
-proof
- assume "abs\<cdot>x \<sqsubseteq> abs\<cdot>y"
- then have "rep\<cdot>(abs\<cdot>x) \<sqsubseteq> rep\<cdot>(abs\<cdot>y)" by (rule monofun_cfun_arg)
- then show "x \<sqsubseteq> y" by simp
-next
- assume "x \<sqsubseteq> y"
- then show "abs\<cdot>x \<sqsubseteq> abs\<cdot>y" by (rule monofun_cfun_arg)
-qed
-
-lemma rep_below: "(rep\<cdot>x \<sqsubseteq> rep\<cdot>y) = (x \<sqsubseteq> y)"
- by (rule iso.abs_below [OF swap])
-
-lemma abs_eq: "(abs\<cdot>x = abs\<cdot>y) = (x = y)"
- by (simp add: po_eq_conv abs_below)
-
-lemma rep_eq: "(rep\<cdot>x = rep\<cdot>y) = (x = y)"
- by (rule iso.abs_eq [OF swap])
-
-lemma abs_strict: "abs\<cdot>\<bottom> = \<bottom>"
-proof -
- have "\<bottom> \<sqsubseteq> rep\<cdot>\<bottom>" ..
- then have "abs\<cdot>\<bottom> \<sqsubseteq> abs\<cdot>(rep\<cdot>\<bottom>)" by (rule monofun_cfun_arg)
- then have "abs\<cdot>\<bottom> \<sqsubseteq> \<bottom>" by simp
- then show ?thesis by (rule bottomI)
-qed
-
-lemma rep_strict: "rep\<cdot>\<bottom> = \<bottom>"
- by (rule iso.abs_strict [OF swap])
-
-lemma abs_defin': "abs\<cdot>x = \<bottom> \<Longrightarrow> x = \<bottom>"
-proof -
- have "x = rep\<cdot>(abs\<cdot>x)" by simp
- also assume "abs\<cdot>x = \<bottom>"
- also note rep_strict
- finally show "x = \<bottom>" .
-qed
-
-lemma rep_defin': "rep\<cdot>z = \<bottom> \<Longrightarrow> z = \<bottom>"
- by (rule iso.abs_defin' [OF swap])
-
-lemma abs_defined: "z \<noteq> \<bottom> \<Longrightarrow> abs\<cdot>z \<noteq> \<bottom>"
- by (erule contrapos_nn, erule abs_defin')
-
-lemma rep_defined: "z \<noteq> \<bottom> \<Longrightarrow> rep\<cdot>z \<noteq> \<bottom>"
- by (rule iso.abs_defined [OF iso.swap]) (rule iso_axioms)
-
-lemma abs_bottom_iff: "(abs\<cdot>x = \<bottom>) = (x = \<bottom>)"
- by (auto elim: abs_defin' intro: abs_strict)
-
-lemma rep_bottom_iff: "(rep\<cdot>x = \<bottom>) = (x = \<bottom>)"
- by (rule iso.abs_bottom_iff [OF iso.swap]) (rule iso_axioms)
-
-lemma casedist_rule: "rep\<cdot>x = \<bottom> \<or> P \<Longrightarrow> x = \<bottom> \<or> P"
- by (simp add: rep_bottom_iff)
-
-lemma compact_abs_rev: "compact (abs\<cdot>x) \<Longrightarrow> compact x"
-proof (unfold compact_def)
- assume "adm (\<lambda>y. abs\<cdot>x \<notsqsubseteq> y)"
- with cont_Rep_cfun2
- have "adm (\<lambda>y. abs\<cdot>x \<notsqsubseteq> abs\<cdot>y)" by (rule adm_subst)
- then show "adm (\<lambda>y. x \<notsqsubseteq> y)" using abs_below by simp
-qed
-
-lemma compact_rep_rev: "compact (rep\<cdot>x) \<Longrightarrow> compact x"
- by (rule iso.compact_abs_rev [OF iso.swap]) (rule iso_axioms)
-
-lemma compact_abs: "compact x \<Longrightarrow> compact (abs\<cdot>x)"
- by (rule compact_rep_rev) simp
-
-lemma compact_rep: "compact x \<Longrightarrow> compact (rep\<cdot>x)"
- by (rule iso.compact_abs [OF iso.swap]) (rule iso_axioms)
-
-lemma iso_swap: "(x = abs\<cdot>y) = (rep\<cdot>x = y)"
-proof
- assume "x = abs\<cdot>y"
- then have "rep\<cdot>x = rep\<cdot>(abs\<cdot>y)" by simp
- then show "rep\<cdot>x = y" by simp
-next
- assume "rep\<cdot>x = y"
- then have "abs\<cdot>(rep\<cdot>x) = abs\<cdot>y" by simp
- then show "x = abs\<cdot>y" by simp
-qed
-
-end
-
-subsection \<open>Proofs about take functions\<close>
-
-text \<open>
- This section contains lemmas that are used in a module that supports
- the domain isomorphism package; the module contains proofs related
- to take functions and the finiteness predicate.
-\<close>
-
-lemma deflation_abs_rep:
- fixes abs and rep and d
- assumes abs_iso: "\<And>x. rep\<cdot>(abs\<cdot>x) = x"
- assumes rep_iso: "\<And>y. abs\<cdot>(rep\<cdot>y) = y"
- shows "deflation d \<Longrightarrow> deflation (abs oo d oo rep)"
-by (rule ep_pair.deflation_e_d_p) (simp add: ep_pair.intro assms)
-
-lemma deflation_chain_min:
- assumes chain: "chain d"
- assumes defl: "\<And>n. deflation (d n)"
- shows "d m\<cdot>(d n\<cdot>x) = d (min m n)\<cdot>x"
-proof (rule linorder_le_cases)
- assume "m \<le> n"
- with chain have "d m \<sqsubseteq> d n" by (rule chain_mono)
- then have "d m\<cdot>(d n\<cdot>x) = d m\<cdot>x"
- by (rule deflation_below_comp1 [OF defl defl])
- moreover from \<open>m \<le> n\<close> have "min m n = m" by simp
- ultimately show ?thesis by simp
-next
- assume "n \<le> m"
- with chain have "d n \<sqsubseteq> d m" by (rule chain_mono)
- then have "d m\<cdot>(d n\<cdot>x) = d n\<cdot>x"
- by (rule deflation_below_comp2 [OF defl defl])
- moreover from \<open>n \<le> m\<close> have "min m n = n" by simp
- ultimately show ?thesis by simp
-qed
-
-lemma lub_ID_take_lemma:
- assumes "chain t" and "(\<Squnion>n. t n) = ID"
- assumes "\<And>n. t n\<cdot>x = t n\<cdot>y" shows "x = y"
-proof -
- have "(\<Squnion>n. t n\<cdot>x) = (\<Squnion>n. t n\<cdot>y)"
- using assms(3) by simp
- then have "(\<Squnion>n. t n)\<cdot>x = (\<Squnion>n. t n)\<cdot>y"
- using assms(1) by (simp add: lub_distribs)
- then show "x = y"
- using assms(2) by simp
-qed
-
-lemma lub_ID_reach:
- assumes "chain t" and "(\<Squnion>n. t n) = ID"
- shows "(\<Squnion>n. t n\<cdot>x) = x"
-using assms by (simp add: lub_distribs)
-
-lemma lub_ID_take_induct:
- assumes "chain t" and "(\<Squnion>n. t n) = ID"
- assumes "adm P" and "\<And>n. P (t n\<cdot>x)" shows "P x"
-proof -
- from \<open>chain t\<close> have "chain (\<lambda>n. t n\<cdot>x)" by simp
- from \<open>adm P\<close> this \<open>\<And>n. P (t n\<cdot>x)\<close> have "P (\<Squnion>n. t n\<cdot>x)" by (rule admD)
- with \<open>chain t\<close> \<open>(\<Squnion>n. t n) = ID\<close> show "P x" by (simp add: lub_distribs)
-qed
-
-subsection \<open>Finiteness\<close>
-
-text \<open>
- Let a ``decisive'' function be a deflation that maps every input to
- either itself or bottom. Then if a domain's take functions are all
- decisive, then all values in the domain are finite.
-\<close>
-
-definition
- decisive :: "('a::pcpo \<rightarrow> 'a) \<Rightarrow> bool"
-where
- "decisive d \<longleftrightarrow> (\<forall>x. d\<cdot>x = x \<or> d\<cdot>x = \<bottom>)"
-
-lemma decisiveI: "(\<And>x. d\<cdot>x = x \<or> d\<cdot>x = \<bottom>) \<Longrightarrow> decisive d"
- unfolding decisive_def by simp
-
-lemma decisive_cases:
- assumes "decisive d" obtains "d\<cdot>x = x" | "d\<cdot>x = \<bottom>"
-using assms unfolding decisive_def by auto
-
-lemma decisive_bottom: "decisive \<bottom>"
- unfolding decisive_def by simp
-
-lemma decisive_ID: "decisive ID"
- unfolding decisive_def by simp
-
-lemma decisive_ssum_map:
- assumes f: "decisive f"
- assumes g: "decisive g"
- shows "decisive (ssum_map\<cdot>f\<cdot>g)"
- apply (rule decisiveI)
- subgoal for s
- apply (cases s, simp_all)
- apply (rule_tac x=x in decisive_cases [OF f], simp_all)
- apply (rule_tac x=y in decisive_cases [OF g], simp_all)
- done
- done
-
-lemma decisive_sprod_map:
- assumes f: "decisive f"
- assumes g: "decisive g"
- shows "decisive (sprod_map\<cdot>f\<cdot>g)"
- apply (rule decisiveI)
- subgoal for s
- apply (cases s, simp)
- subgoal for x y
- apply (rule decisive_cases [OF f, where x = x], simp_all)
- apply (rule decisive_cases [OF g, where x = y], simp_all)
- done
- done
- done
-
-lemma decisive_abs_rep:
- fixes abs rep
- assumes iso: "iso abs rep"
- assumes d: "decisive d"
- shows "decisive (abs oo d oo rep)"
- apply (rule decisiveI)
- subgoal for s
- apply (rule decisive_cases [OF d, where x="rep\<cdot>s"])
- apply (simp add: iso.rep_iso [OF iso])
- apply (simp add: iso.abs_strict [OF iso])
- done
- done
-
-lemma lub_ID_finite:
- assumes chain: "chain d"
- assumes lub: "(\<Squnion>n. d n) = ID"
- assumes decisive: "\<And>n. decisive (d n)"
- shows "\<exists>n. d n\<cdot>x = x"
-proof -
- have 1: "chain (\<lambda>n. d n\<cdot>x)" using chain by simp
- have 2: "(\<Squnion>n. d n\<cdot>x) = x" using chain lub by (rule lub_ID_reach)
- have "\<forall>n. d n\<cdot>x = x \<or> d n\<cdot>x = \<bottom>"
- using decisive unfolding decisive_def by simp
- hence "range (\<lambda>n. d n\<cdot>x) \<subseteq> {x, \<bottom>}"
- by auto
- hence "finite (range (\<lambda>n. d n\<cdot>x))"
- by (rule finite_subset, simp)
- with 1 have "finite_chain (\<lambda>n. d n\<cdot>x)"
- by (rule finite_range_imp_finch)
- then have "\<exists>n. (\<Squnion>n. d n\<cdot>x) = d n\<cdot>x"
- unfolding finite_chain_def by (auto simp add: maxinch_is_thelub)
- with 2 show "\<exists>n. d n\<cdot>x = x" by (auto elim: sym)
-qed
-
-lemma lub_ID_finite_take_induct:
- assumes "chain d" and "(\<Squnion>n. d n) = ID" and "\<And>n. decisive (d n)"
- shows "(\<And>n. P (d n\<cdot>x)) \<Longrightarrow> P x"
-using lub_ID_finite [OF assms] by metis
-
-subsection \<open>Proofs about constructor functions\<close>
-
-text \<open>Lemmas for proving nchotomy rule:\<close>
-
-lemma ex_one_bottom_iff:
- "(\<exists>x. P x \<and> x \<noteq> \<bottom>) = P ONE"
-by simp
-
-lemma ex_up_bottom_iff:
- "(\<exists>x. P x \<and> x \<noteq> \<bottom>) = (\<exists>x. P (up\<cdot>x))"
-by (safe, case_tac x, auto)
-
-lemma ex_sprod_bottom_iff:
- "(\<exists>y. P y \<and> y \<noteq> \<bottom>) =
- (\<exists>x y. (P (:x, y:) \<and> x \<noteq> \<bottom>) \<and> y \<noteq> \<bottom>)"
-by (safe, case_tac y, auto)
-
-lemma ex_sprod_up_bottom_iff:
- "(\<exists>y. P y \<and> y \<noteq> \<bottom>) =
- (\<exists>x y. P (:up\<cdot>x, y:) \<and> y \<noteq> \<bottom>)"
-by (safe, case_tac y, simp, case_tac x, auto)
-
-lemma ex_ssum_bottom_iff:
- "(\<exists>x. P x \<and> x \<noteq> \<bottom>) =
- ((\<exists>x. P (sinl\<cdot>x) \<and> x \<noteq> \<bottom>) \<or>
- (\<exists>x. P (sinr\<cdot>x) \<and> x \<noteq> \<bottom>))"
-by (safe, case_tac x, auto)
-
-lemma exh_start: "p = \<bottom> \<or> (\<exists>x. p = x \<and> x \<noteq> \<bottom>)"
- by auto
-
-lemmas ex_bottom_iffs =
- ex_ssum_bottom_iff
- ex_sprod_up_bottom_iff
- ex_sprod_bottom_iff
- ex_up_bottom_iff
- ex_one_bottom_iff
-
-text \<open>Rules for turning nchotomy into exhaust:\<close>
-
-lemma exh_casedist0: "\<lbrakk>R; R \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P" (* like make_elim *)
- by auto
-
-lemma exh_casedist1: "((P \<or> Q \<Longrightarrow> R) \<Longrightarrow> S) \<equiv> (\<lbrakk>P \<Longrightarrow> R; Q \<Longrightarrow> R\<rbrakk> \<Longrightarrow> S)"
- by rule auto
-
-lemma exh_casedist2: "(\<exists>x. P x \<Longrightarrow> Q) \<equiv> (\<And>x. P x \<Longrightarrow> Q)"
- by rule auto
-
-lemma exh_casedist3: "(P \<and> Q \<Longrightarrow> R) \<equiv> (P \<Longrightarrow> Q \<Longrightarrow> R)"
- by rule auto
-
-lemmas exh_casedists = exh_casedist1 exh_casedist2 exh_casedist3
-
-text \<open>Rules for proving constructor properties\<close>
-
-lemmas con_strict_rules =
- sinl_strict sinr_strict spair_strict1 spair_strict2
-
-lemmas con_bottom_iff_rules =
- sinl_bottom_iff sinr_bottom_iff spair_bottom_iff up_defined ONE_defined
-
-lemmas con_below_iff_rules =
- sinl_below sinr_below sinl_below_sinr sinr_below_sinl con_bottom_iff_rules
-
-lemmas con_eq_iff_rules =
- sinl_eq sinr_eq sinl_eq_sinr sinr_eq_sinl con_bottom_iff_rules
-
-lemmas sel_strict_rules =
- cfcomp2 sscase1 sfst_strict ssnd_strict fup1
-
-lemma sel_app_extra_rules:
- "sscase\<cdot>ID\<cdot>\<bottom>\<cdot>(sinr\<cdot>x) = \<bottom>"
- "sscase\<cdot>ID\<cdot>\<bottom>\<cdot>(sinl\<cdot>x) = x"
- "sscase\<cdot>\<bottom>\<cdot>ID\<cdot>(sinl\<cdot>x) = \<bottom>"
- "sscase\<cdot>\<bottom>\<cdot>ID\<cdot>(sinr\<cdot>x) = x"
- "fup\<cdot>ID\<cdot>(up\<cdot>x) = x"
-by (cases "x = \<bottom>", simp, simp)+
-
-lemmas sel_app_rules =
- sel_strict_rules sel_app_extra_rules
- ssnd_spair sfst_spair up_defined spair_defined
-
-lemmas sel_bottom_iff_rules =
- cfcomp2 sfst_bottom_iff ssnd_bottom_iff
-
-lemmas take_con_rules =
- ssum_map_sinl' ssum_map_sinr' sprod_map_spair' u_map_up
- deflation_strict deflation_ID ID1 cfcomp2
-
-subsection \<open>ML setup\<close>
-
-named_theorems domain_deflation "theorems like deflation a ==> deflation (foo_map$a)"
- and domain_map_ID "theorems like foo_map$ID = ID"
-
-ML_file \<open>Tools/Domain/domain_take_proofs.ML\<close>
-ML_file \<open>Tools/cont_consts.ML\<close>
-ML_file \<open>Tools/cont_proc.ML\<close>
-simproc_setup cont ("cont f") = \<open>K ContProc.cont_proc\<close>
-
-ML_file \<open>Tools/Domain/domain_constructors.ML\<close>
-ML_file \<open>Tools/Domain/domain_induction.ML\<close>
-
-end
--- a/src/HOL/HOLCF/FOCUS/Stream_adm.thy Wed Dec 11 13:44:16 2024 +0100
+++ b/src/HOL/HOLCF/FOCUS/Stream_adm.thy Wed Dec 11 13:44:35 2024 +0100
@@ -30,8 +30,8 @@
section "admissibility"
lemma infinite_chain_adm_lemma:
- "\<lbrakk>Porder.chain Y; \<forall>i. P (Y i);
- \<And>Y. \<lbrakk>Porder.chain Y; \<forall>i. P (Y i); \<not> finite_chain Y\<rbrakk> \<Longrightarrow> P (\<Squnion>i. Y i)\<rbrakk>
+ "\<lbrakk>chain Y; \<forall>i. P (Y i);
+ \<And>Y. \<lbrakk>chain Y; \<forall>i. P (Y i); \<not> finite_chain Y\<rbrakk> \<Longrightarrow> P (\<Squnion>i. Y i)\<rbrakk>
\<Longrightarrow> P (\<Squnion>i. Y i)"
apply (case_tac "finite_chain Y")
prefer 2 apply fast
@@ -43,7 +43,7 @@
done
lemma increasing_chain_adm_lemma:
- "\<lbrakk>Porder.chain Y; \<forall>i. P (Y i); \<And>Y. \<lbrakk>Porder.chain Y; \<forall>i. P (Y i);
+ "\<lbrakk>chain Y; \<forall>i. P (Y i); \<And>Y. \<lbrakk>chain Y; \<forall>i. P (Y i);
\<forall>i. \<exists>j>i. Y i \<noteq> Y j \<and> Y i \<sqsubseteq> Y j\<rbrakk> \<Longrightarrow> P (\<Squnion>i. Y i)\<rbrakk>
\<Longrightarrow> P (\<Squnion>i. Y i)"
apply (erule infinite_chain_adm_lemma)
@@ -55,9 +55,9 @@
done
lemma flatstream_adm_lemma:
- assumes 1: "Porder.chain Y"
+ assumes 1: "chain Y"
assumes 2: "\<forall>i. P (Y i)"
- assumes 3: "(\<And>Y. [| Porder.chain Y; \<forall>i. P (Y i); \<forall>k. \<exists>j. enat k < #((Y j)::'a::flat stream)|]
+ assumes 3: "(\<And>Y. [| chain Y; \<forall>i. P (Y i); \<forall>k. \<exists>j. enat k < #((Y j)::'a::flat stream)|]
==> P(LUB i. Y i))"
shows "P(LUB i. Y i)"
apply (rule increasing_chain_adm_lemma [OF 1 2])
@@ -78,7 +78,7 @@
done
(* should be without reference to stream length? *)
-lemma flatstream_admI: "[|(\<And>Y. [| Porder.chain Y; \<forall>i. P (Y i);
+lemma flatstream_admI: "[|(\<And>Y. [| chain Y; \<forall>i. P (Y i);
\<forall>k. \<exists>j. enat k < #((Y j)::'a::flat stream)|] ==> P(LUB i. Y i))|]==> adm P"
apply (unfold adm_def)
apply (intro strip)
@@ -210,13 +210,13 @@
done
lemma adm_set:
-"{\<Squnion>i. Y i |Y. Porder.chain Y \<and> (\<forall>i. Y i \<in> P)} \<subseteq> P \<Longrightarrow> adm (\<lambda>x. x\<in>P)"
+"{\<Squnion>i. Y i |Y. chain Y \<and> (\<forall>i. Y i \<in> P)} \<subseteq> P \<Longrightarrow> adm (\<lambda>x. x\<in>P)"
apply (unfold adm_def)
apply (fast)
done
-lemma def_gfp_admI: "P \<equiv> gfp F \<Longrightarrow> {\<Squnion>i. Y i |Y. Porder.chain Y \<and> (\<forall>i. Y i \<in> P)} \<subseteq>
- F {\<Squnion>i. Y i |Y. Porder.chain Y \<and> (\<forall>i. Y i \<in> P)} \<Longrightarrow> adm (\<lambda>x. x\<in>P)"
+lemma def_gfp_admI: "P \<equiv> gfp F \<Longrightarrow> {\<Squnion>i. Y i |Y. chain Y \<and> (\<forall>i. Y i \<in> P)} \<subseteq>
+ F {\<Squnion>i. Y i |Y. chain Y \<and> (\<forall>i. Y i \<in> P)} \<Longrightarrow> adm (\<lambda>x. x\<in>P)"
apply (simp)
apply (rule adm_set)
apply (erule gfp_upperbound)
--- a/src/HOL/HOLCF/Fix.thy Wed Dec 11 13:44:16 2024 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,247 +0,0 @@
-(* Title: HOL/HOLCF/Fix.thy
- Author: Franz Regensburger
- Author: Brian Huffman
-*)
-
-section \<open>Fixed point operator and admissibility\<close>
-
-theory Fix
- imports Cfun
-begin
-
-default_sort pcpo
-
-
-subsection \<open>Iteration\<close>
-
-primrec iterate :: "nat \<Rightarrow> ('a::cpo \<rightarrow> 'a) \<rightarrow> ('a \<rightarrow> 'a)"
- where
- "iterate 0 = (\<Lambda> F x. x)"
- | "iterate (Suc n) = (\<Lambda> F x. F\<cdot>(iterate n\<cdot>F\<cdot>x))"
-
-text \<open>Derive inductive properties of iterate from primitive recursion\<close>
-
-lemma iterate_0 [simp]: "iterate 0\<cdot>F\<cdot>x = x"
- by simp
-
-lemma iterate_Suc [simp]: "iterate (Suc n)\<cdot>F\<cdot>x = F\<cdot>(iterate n\<cdot>F\<cdot>x)"
- by simp
-
-declare iterate.simps [simp del]
-
-lemma iterate_Suc2: "iterate (Suc n)\<cdot>F\<cdot>x = iterate n\<cdot>F\<cdot>(F\<cdot>x)"
- by (induct n) simp_all
-
-lemma iterate_iterate: "iterate m\<cdot>F\<cdot>(iterate n\<cdot>F\<cdot>x) = iterate (m + n)\<cdot>F\<cdot>x"
- by (induct m) simp_all
-
-text \<open>The sequence of function iterations is a chain.\<close>
-
-lemma chain_iterate [simp]: "chain (\<lambda>i. iterate i\<cdot>F\<cdot>\<bottom>)"
- by (rule chainI, unfold iterate_Suc2, rule monofun_cfun_arg, rule minimal)
-
-
-subsection \<open>Least fixed point operator\<close>
-
-definition "fix" :: "('a \<rightarrow> 'a) \<rightarrow> 'a"
- where "fix = (\<Lambda> F. \<Squnion>i. iterate i\<cdot>F\<cdot>\<bottom>)"
-
-text \<open>Binder syntax for \<^term>\<open>fix\<close>\<close>
-
-abbreviation fix_syn :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a" (binder \<open>\<mu> \<close> 10)
- where "fix_syn (\<lambda>x. f x) \<equiv> fix\<cdot>(\<Lambda> x. f x)"
-
-notation (ASCII)
- fix_syn (binder \<open>FIX \<close> 10)
-
-text \<open>Properties of \<^term>\<open>fix\<close>\<close>
-
-text \<open>direct connection between \<^term>\<open>fix\<close> and iteration\<close>
-
-lemma fix_def2: "fix\<cdot>F = (\<Squnion>i. iterate i\<cdot>F\<cdot>\<bottom>)"
- by (simp add: fix_def)
-
-lemma iterate_below_fix: "iterate n\<cdot>f\<cdot>\<bottom> \<sqsubseteq> fix\<cdot>f"
- unfolding fix_def2
- using chain_iterate by (rule is_ub_thelub)
-
-text \<open>
- Kleene's fixed point theorems for continuous functions in pointed
- omega cpo's
-\<close>
-
-lemma fix_eq: "fix\<cdot>F = F\<cdot>(fix\<cdot>F)"
- apply (simp add: fix_def2)
- apply (subst lub_range_shift [of _ 1, symmetric])
- apply (rule chain_iterate)
- apply (subst contlub_cfun_arg)
- apply (rule chain_iterate)
- apply simp
- done
-
-lemma fix_least_below: "F\<cdot>x \<sqsubseteq> x \<Longrightarrow> fix\<cdot>F \<sqsubseteq> x"
- apply (simp add: fix_def2)
- apply (rule lub_below)
- apply (rule chain_iterate)
- apply (induct_tac i)
- apply simp
- apply simp
- apply (erule rev_below_trans)
- apply (erule monofun_cfun_arg)
- done
-
-lemma fix_least: "F\<cdot>x = x \<Longrightarrow> fix\<cdot>F \<sqsubseteq> x"
- by (rule fix_least_below) simp
-
-lemma fix_eqI:
- assumes fixed: "F\<cdot>x = x"
- and least: "\<And>z. F\<cdot>z = z \<Longrightarrow> x \<sqsubseteq> z"
- shows "fix\<cdot>F = x"
- apply (rule below_antisym)
- apply (rule fix_least [OF fixed])
- apply (rule least [OF fix_eq [symmetric]])
- done
-
-lemma fix_eq2: "f \<equiv> fix\<cdot>F \<Longrightarrow> f = F\<cdot>f"
- by (simp add: fix_eq [symmetric])
-
-lemma fix_eq3: "f \<equiv> fix\<cdot>F \<Longrightarrow> f\<cdot>x = F\<cdot>f\<cdot>x"
- by (erule fix_eq2 [THEN cfun_fun_cong])
-
-lemma fix_eq4: "f = fix\<cdot>F \<Longrightarrow> f = F\<cdot>f"
- by (erule ssubst) (rule fix_eq)
-
-lemma fix_eq5: "f = fix\<cdot>F \<Longrightarrow> f\<cdot>x = F\<cdot>f\<cdot>x"
- by (erule fix_eq4 [THEN cfun_fun_cong])
-
-text \<open>strictness of \<^term>\<open>fix\<close>\<close>
-
-lemma fix_bottom_iff: "fix\<cdot>F = \<bottom> \<longleftrightarrow> F\<cdot>\<bottom> = \<bottom>"
- apply (rule iffI)
- apply (erule subst)
- apply (rule fix_eq [symmetric])
- apply (erule fix_least [THEN bottomI])
- done
-
-lemma fix_strict: "F\<cdot>\<bottom> = \<bottom> \<Longrightarrow> fix\<cdot>F = \<bottom>"
- by (simp add: fix_bottom_iff)
-
-lemma fix_defined: "F\<cdot>\<bottom> \<noteq> \<bottom> \<Longrightarrow> fix\<cdot>F \<noteq> \<bottom>"
- by (simp add: fix_bottom_iff)
-
-text \<open>\<^term>\<open>fix\<close> applied to identity and constant functions\<close>
-
-lemma fix_id: "(\<mu> x. x) = \<bottom>"
- by (simp add: fix_strict)
-
-lemma fix_const: "(\<mu> x. c) = c"
- by (subst fix_eq) simp
-
-
-subsection \<open>Fixed point induction\<close>
-
-lemma fix_ind: "adm P \<Longrightarrow> P \<bottom> \<Longrightarrow> (\<And>x. P x \<Longrightarrow> P (F\<cdot>x)) \<Longrightarrow> P (fix\<cdot>F)"
- unfolding fix_def2
- apply (erule admD)
- apply (rule chain_iterate)
- apply (rule nat_induct, simp_all)
- done
-
-lemma cont_fix_ind: "cont F \<Longrightarrow> adm P \<Longrightarrow> P \<bottom> \<Longrightarrow> (\<And>x. P x \<Longrightarrow> P (F x)) \<Longrightarrow> P (fix\<cdot>(Abs_cfun F))"
- by (simp add: fix_ind)
-
-lemma def_fix_ind: "\<lbrakk>f \<equiv> fix\<cdot>F; adm P; P \<bottom>; \<And>x. P x \<Longrightarrow> P (F\<cdot>x)\<rbrakk> \<Longrightarrow> P f"
- by (simp add: fix_ind)
-
-lemma fix_ind2:
- assumes adm: "adm P"
- assumes 0: "P \<bottom>" and 1: "P (F\<cdot>\<bottom>)"
- assumes step: "\<And>x. \<lbrakk>P x; P (F\<cdot>x)\<rbrakk> \<Longrightarrow> P (F\<cdot>(F\<cdot>x))"
- shows "P (fix\<cdot>F)"
- unfolding fix_def2
- apply (rule admD [OF adm chain_iterate])
- apply (rule nat_less_induct)
- apply (case_tac n)
- apply (simp add: 0)
- apply (case_tac nat)
- apply (simp add: 1)
- apply (frule_tac x=nat in spec)
- apply (simp add: step)
- done
-
-lemma parallel_fix_ind:
- assumes adm: "adm (\<lambda>x. P (fst x) (snd x))"
- assumes base: "P \<bottom> \<bottom>"
- assumes step: "\<And>x y. P x y \<Longrightarrow> P (F\<cdot>x) (G\<cdot>y)"
- shows "P (fix\<cdot>F) (fix\<cdot>G)"
-proof -
- from adm have adm': "adm (case_prod P)"
- unfolding split_def .
- have "P (iterate i\<cdot>F\<cdot>\<bottom>) (iterate i\<cdot>G\<cdot>\<bottom>)" for i
- by (induct i) (simp add: base, simp add: step)
- then have "\<And>i. case_prod P (iterate i\<cdot>F\<cdot>\<bottom>, iterate i\<cdot>G\<cdot>\<bottom>)"
- by simp
- then have "case_prod P (\<Squnion>i. (iterate i\<cdot>F\<cdot>\<bottom>, iterate i\<cdot>G\<cdot>\<bottom>))"
- by - (rule admD [OF adm'], simp, assumption)
- then have "case_prod P (\<Squnion>i. iterate i\<cdot>F\<cdot>\<bottom>, \<Squnion>i. iterate i\<cdot>G\<cdot>\<bottom>)"
- by (simp add: lub_Pair)
- then have "P (\<Squnion>i. iterate i\<cdot>F\<cdot>\<bottom>) (\<Squnion>i. iterate i\<cdot>G\<cdot>\<bottom>)"
- by simp
- then show "P (fix\<cdot>F) (fix\<cdot>G)"
- by (simp add: fix_def2)
-qed
-
-lemma cont_parallel_fix_ind:
- assumes "cont F" and "cont G"
- assumes "adm (\<lambda>x. P (fst x) (snd x))"
- assumes "P \<bottom> \<bottom>"
- assumes "\<And>x y. P x y \<Longrightarrow> P (F x) (G y)"
- shows "P (fix\<cdot>(Abs_cfun F)) (fix\<cdot>(Abs_cfun G))"
- by (rule parallel_fix_ind) (simp_all add: assms)
-
-
-subsection \<open>Fixed-points on product types\<close>
-
-text \<open>
- Bekic's Theorem: Simultaneous fixed points over pairs
- can be written in terms of separate fixed points.
-\<close>
-
-lemma fix_cprod:
- "fix\<cdot>(F::'a \<times> 'b \<rightarrow> 'a \<times> 'b) =
- (\<mu> x. fst (F\<cdot>(x, \<mu> y. snd (F\<cdot>(x, y)))),
- \<mu> y. snd (F\<cdot>(\<mu> x. fst (F\<cdot>(x, \<mu> y. snd (F\<cdot>(x, y)))), y)))"
- (is "fix\<cdot>F = (?x, ?y)")
-proof (rule fix_eqI)
- have *: "fst (F\<cdot>(?x, ?y)) = ?x"
- by (rule trans [symmetric, OF fix_eq], simp)
- have "snd (F\<cdot>(?x, ?y)) = ?y"
- by (rule trans [symmetric, OF fix_eq], simp)
- with * show "F\<cdot>(?x, ?y) = (?x, ?y)"
- by (simp add: prod_eq_iff)
-next
- fix z
- assume F_z: "F\<cdot>z = z"
- obtain x y where z: "z = (x, y)" by (rule prod.exhaust)
- from F_z z have F_x: "fst (F\<cdot>(x, y)) = x" by simp
- from F_z z have F_y: "snd (F\<cdot>(x, y)) = y" by simp
- let ?y1 = "\<mu> y. snd (F\<cdot>(x, y))"
- have "?y1 \<sqsubseteq> y"
- by (rule fix_least) (simp add: F_y)
- then have "fst (F\<cdot>(x, ?y1)) \<sqsubseteq> fst (F\<cdot>(x, y))"
- by (simp add: fst_monofun monofun_cfun)
- with F_x have "fst (F\<cdot>(x, ?y1)) \<sqsubseteq> x"
- by simp
- then have *: "?x \<sqsubseteq> x"
- by (simp add: fix_least_below)
- then have "snd (F\<cdot>(?x, y)) \<sqsubseteq> snd (F\<cdot>(x, y))"
- by (simp add: snd_monofun monofun_cfun)
- with F_y have "snd (F\<cdot>(?x, y)) \<sqsubseteq> y"
- by simp
- then have "?y \<sqsubseteq> y"
- by (simp add: fix_least_below)
- with z * show "(?x, ?y) \<sqsubseteq> z"
- by simp
-qed
-
-end
--- a/src/HOL/HOLCF/Fixrec.thy Wed Dec 11 13:44:16 2024 +0100
+++ b/src/HOL/HOLCF/Fixrec.thy Wed Dec 11 13:44:35 2024 +0100
@@ -1,14 +1,253 @@
(* Title: HOL/HOLCF/Fixrec.thy
+ Author: Franz Regensburger
Author: Amber Telfer and Brian Huffman
*)
-section "Package for defining recursive functions in HOLCF"
-
theory Fixrec
-imports Cprod Sprod Ssum Up One Tr Fix
+imports Cprod Sprod Ssum Up One Tr Cfun
keywords "fixrec" :: thy_defn
begin
+section \<open>Fixed point operator and admissibility\<close>
+
+default_sort pcpo
+
+
+subsection \<open>Iteration\<close>
+
+primrec iterate :: "nat \<Rightarrow> ('a::cpo \<rightarrow> 'a) \<rightarrow> ('a \<rightarrow> 'a)"
+ where
+ "iterate 0 = (\<Lambda> F x. x)"
+ | "iterate (Suc n) = (\<Lambda> F x. F\<cdot>(iterate n\<cdot>F\<cdot>x))"
+
+text \<open>Derive inductive properties of iterate from primitive recursion\<close>
+
+lemma iterate_0 [simp]: "iterate 0\<cdot>F\<cdot>x = x"
+ by simp
+
+lemma iterate_Suc [simp]: "iterate (Suc n)\<cdot>F\<cdot>x = F\<cdot>(iterate n\<cdot>F\<cdot>x)"
+ by simp
+
+declare iterate.simps [simp del]
+
+lemma iterate_Suc2: "iterate (Suc n)\<cdot>F\<cdot>x = iterate n\<cdot>F\<cdot>(F\<cdot>x)"
+ by (induct n) simp_all
+
+lemma iterate_iterate: "iterate m\<cdot>F\<cdot>(iterate n\<cdot>F\<cdot>x) = iterate (m + n)\<cdot>F\<cdot>x"
+ by (induct m) simp_all
+
+text \<open>The sequence of function iterations is a chain.\<close>
+
+lemma chain_iterate [simp]: "chain (\<lambda>i. iterate i\<cdot>F\<cdot>\<bottom>)"
+ by (rule chainI, unfold iterate_Suc2, rule monofun_cfun_arg, rule minimal)
+
+
+subsection \<open>Least fixed point operator\<close>
+
+definition "fix" :: "('a \<rightarrow> 'a) \<rightarrow> 'a"
+ where "fix = (\<Lambda> F. \<Squnion>i. iterate i\<cdot>F\<cdot>\<bottom>)"
+
+text \<open>Binder syntax for \<^term>\<open>fix\<close>\<close>
+
+abbreviation fix_syn :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a" (binder \<open>\<mu> \<close> 10)
+ where "fix_syn (\<lambda>x. f x) \<equiv> fix\<cdot>(\<Lambda> x. f x)"
+
+notation (ASCII)
+ fix_syn (binder \<open>FIX \<close> 10)
+
+text \<open>Properties of \<^term>\<open>fix\<close>\<close>
+
+text \<open>direct connection between \<^term>\<open>fix\<close> and iteration\<close>
+
+lemma fix_def2: "fix\<cdot>F = (\<Squnion>i. iterate i\<cdot>F\<cdot>\<bottom>)"
+ by (simp add: fix_def)
+
+lemma iterate_below_fix: "iterate n\<cdot>f\<cdot>\<bottom> \<sqsubseteq> fix\<cdot>f"
+ unfolding fix_def2
+ using chain_iterate by (rule is_ub_thelub)
+
+text \<open>
+ Kleene's fixed point theorems for continuous functions in pointed
+ omega cpo's
+\<close>
+
+lemma fix_eq: "fix\<cdot>F = F\<cdot>(fix\<cdot>F)"
+ apply (simp add: fix_def2)
+ apply (subst lub_range_shift [of _ 1, symmetric])
+ apply (rule chain_iterate)
+ apply (subst contlub_cfun_arg)
+ apply (rule chain_iterate)
+ apply simp
+ done
+
+lemma fix_least_below: "F\<cdot>x \<sqsubseteq> x \<Longrightarrow> fix\<cdot>F \<sqsubseteq> x"
+ apply (simp add: fix_def2)
+ apply (rule lub_below)
+ apply (rule chain_iterate)
+ apply (induct_tac i)
+ apply simp
+ apply simp
+ apply (erule rev_below_trans)
+ apply (erule monofun_cfun_arg)
+ done
+
+lemma fix_least: "F\<cdot>x = x \<Longrightarrow> fix\<cdot>F \<sqsubseteq> x"
+ by (rule fix_least_below) simp
+
+lemma fix_eqI:
+ assumes fixed: "F\<cdot>x = x"
+ and least: "\<And>z. F\<cdot>z = z \<Longrightarrow> x \<sqsubseteq> z"
+ shows "fix\<cdot>F = x"
+ apply (rule below_antisym)
+ apply (rule fix_least [OF fixed])
+ apply (rule least [OF fix_eq [symmetric]])
+ done
+
+lemma fix_eq2: "f \<equiv> fix\<cdot>F \<Longrightarrow> f = F\<cdot>f"
+ by (simp add: fix_eq [symmetric])
+
+lemma fix_eq3: "f \<equiv> fix\<cdot>F \<Longrightarrow> f\<cdot>x = F\<cdot>f\<cdot>x"
+ by (erule fix_eq2 [THEN cfun_fun_cong])
+
+lemma fix_eq4: "f = fix\<cdot>F \<Longrightarrow> f = F\<cdot>f"
+ by (erule ssubst) (rule fix_eq)
+
+lemma fix_eq5: "f = fix\<cdot>F \<Longrightarrow> f\<cdot>x = F\<cdot>f\<cdot>x"
+ by (erule fix_eq4 [THEN cfun_fun_cong])
+
+text \<open>strictness of \<^term>\<open>fix\<close>\<close>
+
+lemma fix_bottom_iff: "fix\<cdot>F = \<bottom> \<longleftrightarrow> F\<cdot>\<bottom> = \<bottom>"
+ apply (rule iffI)
+ apply (erule subst)
+ apply (rule fix_eq [symmetric])
+ apply (erule fix_least [THEN bottomI])
+ done
+
+lemma fix_strict: "F\<cdot>\<bottom> = \<bottom> \<Longrightarrow> fix\<cdot>F = \<bottom>"
+ by (simp add: fix_bottom_iff)
+
+lemma fix_defined: "F\<cdot>\<bottom> \<noteq> \<bottom> \<Longrightarrow> fix\<cdot>F \<noteq> \<bottom>"
+ by (simp add: fix_bottom_iff)
+
+text \<open>\<^term>\<open>fix\<close> applied to identity and constant functions\<close>
+
+lemma fix_id: "(\<mu> x. x) = \<bottom>"
+ by (simp add: fix_strict)
+
+lemma fix_const: "(\<mu> x. c) = c"
+ by (subst fix_eq) simp
+
+
+subsection \<open>Fixed point induction\<close>
+
+lemma fix_ind: "adm P \<Longrightarrow> P \<bottom> \<Longrightarrow> (\<And>x. P x \<Longrightarrow> P (F\<cdot>x)) \<Longrightarrow> P (fix\<cdot>F)"
+ unfolding fix_def2
+ apply (erule admD)
+ apply (rule chain_iterate)
+ apply (rule nat_induct, simp_all)
+ done
+
+lemma cont_fix_ind: "cont F \<Longrightarrow> adm P \<Longrightarrow> P \<bottom> \<Longrightarrow> (\<And>x. P x \<Longrightarrow> P (F x)) \<Longrightarrow> P (fix\<cdot>(Abs_cfun F))"
+ by (simp add: fix_ind)
+
+lemma def_fix_ind: "\<lbrakk>f \<equiv> fix\<cdot>F; adm P; P \<bottom>; \<And>x. P x \<Longrightarrow> P (F\<cdot>x)\<rbrakk> \<Longrightarrow> P f"
+ by (simp add: fix_ind)
+
+lemma fix_ind2:
+ assumes adm: "adm P"
+ assumes 0: "P \<bottom>" and 1: "P (F\<cdot>\<bottom>)"
+ assumes step: "\<And>x. \<lbrakk>P x; P (F\<cdot>x)\<rbrakk> \<Longrightarrow> P (F\<cdot>(F\<cdot>x))"
+ shows "P (fix\<cdot>F)"
+ unfolding fix_def2
+ apply (rule admD [OF adm chain_iterate])
+ apply (rule nat_less_induct)
+ apply (case_tac n)
+ apply (simp add: 0)
+ apply (case_tac nat)
+ apply (simp add: 1)
+ apply (frule_tac x=nat in spec)
+ apply (simp add: step)
+ done
+
+lemma parallel_fix_ind:
+ assumes adm: "adm (\<lambda>x. P (fst x) (snd x))"
+ assumes base: "P \<bottom> \<bottom>"
+ assumes step: "\<And>x y. P x y \<Longrightarrow> P (F\<cdot>x) (G\<cdot>y)"
+ shows "P (fix\<cdot>F) (fix\<cdot>G)"
+proof -
+ from adm have adm': "adm (case_prod P)"
+ unfolding split_def .
+ have "P (iterate i\<cdot>F\<cdot>\<bottom>) (iterate i\<cdot>G\<cdot>\<bottom>)" for i
+ by (induct i) (simp add: base, simp add: step)
+ then have "\<And>i. case_prod P (iterate i\<cdot>F\<cdot>\<bottom>, iterate i\<cdot>G\<cdot>\<bottom>)"
+ by simp
+ then have "case_prod P (\<Squnion>i. (iterate i\<cdot>F\<cdot>\<bottom>, iterate i\<cdot>G\<cdot>\<bottom>))"
+ by - (rule admD [OF adm'], simp, assumption)
+ then have "case_prod P (\<Squnion>i. iterate i\<cdot>F\<cdot>\<bottom>, \<Squnion>i. iterate i\<cdot>G\<cdot>\<bottom>)"
+ by (simp add: lub_Pair)
+ then have "P (\<Squnion>i. iterate i\<cdot>F\<cdot>\<bottom>) (\<Squnion>i. iterate i\<cdot>G\<cdot>\<bottom>)"
+ by simp
+ then show "P (fix\<cdot>F) (fix\<cdot>G)"
+ by (simp add: fix_def2)
+qed
+
+lemma cont_parallel_fix_ind:
+ assumes "cont F" and "cont G"
+ assumes "adm (\<lambda>x. P (fst x) (snd x))"
+ assumes "P \<bottom> \<bottom>"
+ assumes "\<And>x y. P x y \<Longrightarrow> P (F x) (G y)"
+ shows "P (fix\<cdot>(Abs_cfun F)) (fix\<cdot>(Abs_cfun G))"
+ by (rule parallel_fix_ind) (simp_all add: assms)
+
+
+subsection \<open>Fixed-points on product types\<close>
+
+text \<open>
+ Bekic's Theorem: Simultaneous fixed points over pairs
+ can be written in terms of separate fixed points.
+\<close>
+
+lemma fix_cprod:
+ "fix\<cdot>(F::'a \<times> 'b \<rightarrow> 'a \<times> 'b) =
+ (\<mu> x. fst (F\<cdot>(x, \<mu> y. snd (F\<cdot>(x, y)))),
+ \<mu> y. snd (F\<cdot>(\<mu> x. fst (F\<cdot>(x, \<mu> y. snd (F\<cdot>(x, y)))), y)))"
+ (is "fix\<cdot>F = (?x, ?y)")
+proof (rule fix_eqI)
+ have *: "fst (F\<cdot>(?x, ?y)) = ?x"
+ by (rule trans [symmetric, OF fix_eq], simp)
+ have "snd (F\<cdot>(?x, ?y)) = ?y"
+ by (rule trans [symmetric, OF fix_eq], simp)
+ with * show "F\<cdot>(?x, ?y) = (?x, ?y)"
+ by (simp add: prod_eq_iff)
+next
+ fix z
+ assume F_z: "F\<cdot>z = z"
+ obtain x y where z: "z = (x, y)" by (rule prod.exhaust)
+ from F_z z have F_x: "fst (F\<cdot>(x, y)) = x" by simp
+ from F_z z have F_y: "snd (F\<cdot>(x, y)) = y" by simp
+ let ?y1 = "\<mu> y. snd (F\<cdot>(x, y))"
+ have "?y1 \<sqsubseteq> y"
+ by (rule fix_least) (simp add: F_y)
+ then have "fst (F\<cdot>(x, ?y1)) \<sqsubseteq> fst (F\<cdot>(x, y))"
+ by (simp add: fst_monofun monofun_cfun)
+ with F_x have "fst (F\<cdot>(x, ?y1)) \<sqsubseteq> x"
+ by simp
+ then have *: "?x \<sqsubseteq> x"
+ by (simp add: fix_least_below)
+ then have "snd (F\<cdot>(?x, y)) \<sqsubseteq> snd (F\<cdot>(x, y))"
+ by (simp add: snd_monofun monofun_cfun)
+ with F_y have "snd (F\<cdot>(?x, y)) \<sqsubseteq> y"
+ by simp
+ then have "?y \<sqsubseteq> y"
+ by (simp add: fix_least_below)
+ with z * show "(?x, ?y) \<sqsubseteq> z"
+ by simp
+qed
+
+
+section "Package for defining recursive functions in HOLCF"
+
subsection \<open>Pattern-match monad\<close>
default_sort cpo
@@ -46,6 +285,7 @@
"succeed\<cdot>x \<noteq> fail" "fail \<noteq> succeed\<cdot>x"
by (simp_all add: succeed_def fail_def cont_Abs_match Abs_match_inject)
+
subsubsection \<open>Run operator\<close>
definition
@@ -66,6 +306,7 @@
unfolding run_def succeed_def
by (simp add: cont_Rep_match cont_Abs_match Abs_match_inverse)
+
subsubsection \<open>Monad plus operator\<close>
definition
@@ -96,6 +337,7 @@
lemma mplus_assoc: "(x +++ y) +++ z = x +++ (y +++ z)"
by (cases x, simp_all)
+
subsection \<open>Match functions for built-in types\<close>
default_sort pcpo
@@ -192,6 +434,7 @@
"match_FF\<cdot>\<bottom>\<cdot>k = \<bottom>"
by (simp_all add: match_FF_def)
+
subsection \<open>Mutual recursion\<close>
text \<open>
--- a/src/HOL/HOLCF/Fun_Cpo.thy Wed Dec 11 13:44:16 2024 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,150 +0,0 @@
-(* Title: HOL/HOLCF/Fun_Cpo.thy
- Author: Franz Regensburger
- Author: Brian Huffman
-*)
-
-section \<open>Class instances for the full function space\<close>
-
-theory Fun_Cpo
- imports Adm
-begin
-
-subsection \<open>Full function space is a partial order\<close>
-
-instantiation "fun" :: (type, below) below
-begin
-
-definition below_fun_def: "(\<sqsubseteq>) \<equiv> (\<lambda>f g. \<forall>x. f x \<sqsubseteq> g x)"
-
-instance ..
-end
-
-instance "fun" :: (type, po) po
-proof
- fix f :: "'a \<Rightarrow> 'b"
- show "f \<sqsubseteq> f"
- by (simp add: below_fun_def)
-next
- fix f g :: "'a \<Rightarrow> 'b"
- assume "f \<sqsubseteq> g" and "g \<sqsubseteq> f" then show "f = g"
- by (simp add: below_fun_def fun_eq_iff below_antisym)
-next
- fix f g h :: "'a \<Rightarrow> 'b"
- assume "f \<sqsubseteq> g" and "g \<sqsubseteq> h" then show "f \<sqsubseteq> h"
- unfolding below_fun_def by (fast elim: below_trans)
-qed
-
-lemma fun_below_iff: "f \<sqsubseteq> g \<longleftrightarrow> (\<forall>x. f x \<sqsubseteq> g x)"
- by (simp add: below_fun_def)
-
-lemma fun_belowI: "(\<And>x. f x \<sqsubseteq> g x) \<Longrightarrow> f \<sqsubseteq> g"
- by (simp add: below_fun_def)
-
-lemma fun_belowD: "f \<sqsubseteq> g \<Longrightarrow> f x \<sqsubseteq> g x"
- by (simp add: below_fun_def)
-
-
-subsection \<open>Full function space is chain complete\<close>
-
-text \<open>Properties of chains of functions.\<close>
-
-lemma fun_chain_iff: "chain S \<longleftrightarrow> (\<forall>x. chain (\<lambda>i. S i x))"
- by (auto simp: chain_def fun_below_iff)
-
-lemma ch2ch_fun: "chain S \<Longrightarrow> chain (\<lambda>i. S i x)"
- by (simp add: chain_def below_fun_def)
-
-lemma ch2ch_lambda: "(\<And>x. chain (\<lambda>i. S i x)) \<Longrightarrow> chain S"
- by (simp add: chain_def below_fun_def)
-
-text \<open>Type \<^typ>\<open>'a::type \<Rightarrow> 'b::cpo\<close> is chain complete\<close>
-
-lemma is_lub_lambda: "(\<And>x. range (\<lambda>i. Y i x) <<| f x) \<Longrightarrow> range Y <<| f"
- by (simp add: is_lub_def is_ub_def below_fun_def)
-
-lemma is_lub_fun: "chain S \<Longrightarrow> range S <<| (\<lambda>x. \<Squnion>i. S i x)"
- for S :: "nat \<Rightarrow> 'a::type \<Rightarrow> 'b::cpo"
- apply (rule is_lub_lambda)
- apply (rule cpo_lubI)
- apply (erule ch2ch_fun)
- done
-
-lemma lub_fun: "chain S \<Longrightarrow> (\<Squnion>i. S i) = (\<lambda>x. \<Squnion>i. S i x)"
- for S :: "nat \<Rightarrow> 'a::type \<Rightarrow> 'b::cpo"
- by (rule is_lub_fun [THEN lub_eqI])
-
-instance "fun" :: (type, cpo) cpo
- by intro_classes (rule exI, erule is_lub_fun)
-
-instance "fun" :: (type, discrete_cpo) discrete_cpo
-proof
- fix f g :: "'a \<Rightarrow> 'b"
- show "f \<sqsubseteq> g \<longleftrightarrow> f = g"
- by (simp add: fun_below_iff fun_eq_iff)
-qed
-
-
-subsection \<open>Full function space is pointed\<close>
-
-lemma minimal_fun: "(\<lambda>x. \<bottom>) \<sqsubseteq> f"
- by (simp add: below_fun_def)
-
-instance "fun" :: (type, pcpo) pcpo
- by standard (fast intro: minimal_fun)
-
-lemma inst_fun_pcpo: "\<bottom> = (\<lambda>x. \<bottom>)"
- by (rule minimal_fun [THEN bottomI, symmetric])
-
-lemma app_strict [simp]: "\<bottom> x = \<bottom>"
- by (simp add: inst_fun_pcpo)
-
-lemma lambda_strict: "(\<lambda>x. \<bottom>) = \<bottom>"
- by (rule bottomI, rule minimal_fun)
-
-
-subsection \<open>Propagation of monotonicity and continuity\<close>
-
-text \<open>The lub of a chain of monotone functions is monotone.\<close>
-
-lemma adm_monofun: "adm monofun"
- by (rule admI) (simp add: lub_fun fun_chain_iff monofun_def lub_mono)
-
-text \<open>The lub of a chain of continuous functions is continuous.\<close>
-
-lemma adm_cont: "adm cont"
- by (rule admI) (simp add: lub_fun fun_chain_iff)
-
-text \<open>Function application preserves monotonicity and continuity.\<close>
-
-lemma mono2mono_fun: "monofun f \<Longrightarrow> monofun (\<lambda>x. f x y)"
- by (simp add: monofun_def fun_below_iff)
-
-lemma cont2cont_fun: "cont f \<Longrightarrow> cont (\<lambda>x. f x y)"
- apply (rule contI2)
- apply (erule cont2mono [THEN mono2mono_fun])
- apply (simp add: cont2contlubE lub_fun ch2ch_cont)
- done
-
-lemma cont_fun: "cont (\<lambda>f. f x)"
- using cont_id by (rule cont2cont_fun)
-
-text \<open>
- Lambda abstraction preserves monotonicity and continuity.
- (Note \<open>(\<lambda>x. \<lambda>y. f x y) = f\<close>.)
-\<close>
-
-lemma mono2mono_lambda: "(\<And>y. monofun (\<lambda>x. f x y)) \<Longrightarrow> monofun f"
- by (simp add: monofun_def fun_below_iff)
-
-lemma cont2cont_lambda [simp]:
- assumes f: "\<And>y. cont (\<lambda>x. f x y)"
- shows "cont f"
- by (rule contI, rule is_lub_lambda, rule contE [OF f])
-
-text \<open>What D.A.Schmidt calls continuity of abstraction; never used here\<close>
-
-lemma contlub_lambda: "(\<And>x. chain (\<lambda>i. S i x)) \<Longrightarrow> (\<lambda>x. \<Squnion>i. S i x) = (\<Squnion>i. (\<lambda>x. S i x))"
- for S :: "nat \<Rightarrow> 'a::type \<Rightarrow> 'b::cpo"
- by (simp add: lub_fun ch2ch_lambda)
-
-end
--- a/src/HOL/HOLCF/Lift.thy Wed Dec 11 13:44:16 2024 +0100
+++ b/src/HOL/HOLCF/Lift.thy Wed Dec 11 13:44:35 2024 +0100
@@ -5,7 +5,7 @@
section \<open>Lifting types of class type to flat pcpo's\<close>
theory Lift
-imports Discrete_Cpo Up
+imports Up
begin
default_sort type
@@ -19,6 +19,7 @@
Def :: "'a \<Rightarrow> 'a lift" where
"Def x = Abs_lift (up\<cdot>(Discr x))"
+
subsection \<open>Lift as a datatype\<close>
lemma lift_induct: "\<lbrakk>P \<bottom>; \<And>x. P (Def x)\<rbrakk> \<Longrightarrow> P y"
@@ -70,6 +71,7 @@
by (induct x) auto
qed
+
subsection \<open>Continuity of \<^const>\<open>case_lift\<close>\<close>
lemma case_lift_eq: "case_lift \<bottom> f x = fup\<cdot>(\<Lambda> y. f (undiscr y))\<cdot>(Rep_lift x)"
@@ -82,6 +84,7 @@
"\<lbrakk>\<And>y. cont (\<lambda>x. f x y); cont g\<rbrakk> \<Longrightarrow> cont (\<lambda>x. case_lift \<bottom> (f x) (g x))"
unfolding case_lift_eq by (simp add: cont_Rep_lift)
+
subsection \<open>Further operations\<close>
definition
--- a/src/HOL/HOLCF/LowerPD.thy Wed Dec 11 13:44:16 2024 +0100
+++ b/src/HOL/HOLCF/LowerPD.thy Wed Dec 11 13:44:35 2024 +0100
@@ -459,6 +459,7 @@
by (rule finite_range_imp_finite_fixes)
qed
+
subsection \<open>Lower powerdomain is bifinite\<close>
lemma approx_chain_lower_map:
@@ -474,6 +475,7 @@
by (fast intro!: approx_chain_lower_map)
qed
+
subsection \<open>Join\<close>
definition
--- a/src/HOL/HOLCF/Pcpo.thy Wed Dec 11 13:44:16 2024 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,256 +0,0 @@
-(* Title: HOL/HOLCF/Pcpo.thy
- Author: Franz Regensburger
-*)
-
-section \<open>Classes cpo and pcpo\<close>
-
-theory Pcpo
- imports Porder
-begin
-
-subsection \<open>Complete partial orders\<close>
-
-text \<open>The class cpo of chain complete partial orders\<close>
-
-class cpo = po +
- assumes cpo: "chain S \<Longrightarrow> \<exists>x. range S <<| x"
-begin
-
-text \<open>in cpo's everthing equal to THE lub has lub properties for every chain\<close>
-
-lemma cpo_lubI: "chain S \<Longrightarrow> range S <<| (\<Squnion>i. S i)"
- by (fast dest: cpo elim: is_lub_lub)
-
-lemma thelubE: "\<lbrakk>chain S; (\<Squnion>i. S i) = l\<rbrakk> \<Longrightarrow> range S <<| l"
- by (blast dest: cpo intro: is_lub_lub)
-
-text \<open>Properties of the lub\<close>
-
-lemma is_ub_thelub: "chain S \<Longrightarrow> S x \<sqsubseteq> (\<Squnion>i. S i)"
- by (blast dest: cpo intro: is_lub_lub [THEN is_lub_rangeD1])
-
-lemma is_lub_thelub: "\<lbrakk>chain S; range S <| x\<rbrakk> \<Longrightarrow> (\<Squnion>i. S i) \<sqsubseteq> x"
- by (blast dest: cpo intro: is_lub_lub [THEN is_lubD2])
-
-lemma lub_below_iff: "chain S \<Longrightarrow> (\<Squnion>i. S i) \<sqsubseteq> x \<longleftrightarrow> (\<forall>i. S i \<sqsubseteq> x)"
- by (simp add: is_lub_below_iff [OF cpo_lubI] is_ub_def)
-
-lemma lub_below: "\<lbrakk>chain S; \<And>i. S i \<sqsubseteq> x\<rbrakk> \<Longrightarrow> (\<Squnion>i. S i) \<sqsubseteq> x"
- by (simp add: lub_below_iff)
-
-lemma below_lub: "\<lbrakk>chain S; x \<sqsubseteq> S i\<rbrakk> \<Longrightarrow> x \<sqsubseteq> (\<Squnion>i. S i)"
- by (erule below_trans, erule is_ub_thelub)
-
-lemma lub_range_mono: "\<lbrakk>range X \<subseteq> range Y; chain Y; chain X\<rbrakk> \<Longrightarrow> (\<Squnion>i. X i) \<sqsubseteq> (\<Squnion>i. Y i)"
- apply (erule lub_below)
- apply (subgoal_tac "\<exists>j. X i = Y j")
- apply clarsimp
- apply (erule is_ub_thelub)
- apply auto
- done
-
-lemma lub_range_shift: "chain Y \<Longrightarrow> (\<Squnion>i. Y (i + j)) = (\<Squnion>i. Y i)"
- apply (rule below_antisym)
- apply (rule lub_range_mono)
- apply fast
- apply assumption
- apply (erule chain_shift)
- apply (rule lub_below)
- apply assumption
- apply (rule_tac i="i" in below_lub)
- apply (erule chain_shift)
- apply (erule chain_mono)
- apply (rule le_add1)
- done
-
-lemma maxinch_is_thelub: "chain Y \<Longrightarrow> max_in_chain i Y = ((\<Squnion>i. Y i) = Y i)"
- apply (rule iffI)
- apply (fast intro!: lub_eqI lub_finch1)
- apply (unfold max_in_chain_def)
- apply (safe intro!: below_antisym)
- apply (fast elim!: chain_mono)
- apply (drule sym)
- apply (force elim!: is_ub_thelub)
- done
-
-text \<open>the \<open>\<sqsubseteq>\<close> relation between two chains is preserved by their lubs\<close>
-
-lemma lub_mono: "\<lbrakk>chain X; chain Y; \<And>i. X i \<sqsubseteq> Y i\<rbrakk> \<Longrightarrow> (\<Squnion>i. X i) \<sqsubseteq> (\<Squnion>i. Y i)"
- by (fast elim: lub_below below_lub)
-
-text \<open>the = relation between two chains is preserved by their lubs\<close>
-
-lemma lub_eq: "(\<And>i. X i = Y i) \<Longrightarrow> (\<Squnion>i. X i) = (\<Squnion>i. Y i)"
- by simp
-
-lemma ch2ch_lub:
- assumes 1: "\<And>j. chain (\<lambda>i. Y i j)"
- assumes 2: "\<And>i. chain (\<lambda>j. Y i j)"
- shows "chain (\<lambda>i. \<Squnion>j. Y i j)"
- apply (rule chainI)
- apply (rule lub_mono [OF 2 2])
- apply (rule chainE [OF 1])
- done
-
-lemma diag_lub:
- assumes 1: "\<And>j. chain (\<lambda>i. Y i j)"
- assumes 2: "\<And>i. chain (\<lambda>j. Y i j)"
- shows "(\<Squnion>i. \<Squnion>j. Y i j) = (\<Squnion>i. Y i i)"
-proof (rule below_antisym)
- have 3: "chain (\<lambda>i. Y i i)"
- apply (rule chainI)
- apply (rule below_trans)
- apply (rule chainE [OF 1])
- apply (rule chainE [OF 2])
- done
- have 4: "chain (\<lambda>i. \<Squnion>j. Y i j)"
- by (rule ch2ch_lub [OF 1 2])
- show "(\<Squnion>i. \<Squnion>j. Y i j) \<sqsubseteq> (\<Squnion>i. Y i i)"
- apply (rule lub_below [OF 4])
- apply (rule lub_below [OF 2])
- apply (rule below_lub [OF 3])
- apply (rule below_trans)
- apply (rule chain_mono [OF 1 max.cobounded1])
- apply (rule chain_mono [OF 2 max.cobounded2])
- done
- show "(\<Squnion>i. Y i i) \<sqsubseteq> (\<Squnion>i. \<Squnion>j. Y i j)"
- apply (rule lub_mono [OF 3 4])
- apply (rule is_ub_thelub [OF 2])
- done
-qed
-
-lemma ex_lub:
- assumes 1: "\<And>j. chain (\<lambda>i. Y i j)"
- assumes 2: "\<And>i. chain (\<lambda>j. Y i j)"
- shows "(\<Squnion>i. \<Squnion>j. Y i j) = (\<Squnion>j. \<Squnion>i. Y i j)"
- by (simp add: diag_lub 1 2)
-
-end
-
-
-subsection \<open>Pointed cpos\<close>
-
-text \<open>The class pcpo of pointed cpos\<close>
-
-class pcpo = cpo +
- assumes least: "\<exists>x. \<forall>y. x \<sqsubseteq> y"
-begin
-
-definition bottom :: "'a" (\<open>\<bottom>\<close>)
- where "bottom = (THE x. \<forall>y. x \<sqsubseteq> y)"
-
-lemma minimal [iff]: "\<bottom> \<sqsubseteq> x"
- unfolding bottom_def
- apply (rule the1I2)
- apply (rule ex_ex1I)
- apply (rule least)
- apply (blast intro: below_antisym)
- apply simp
- done
-
-end
-
-text \<open>Old "UU" syntax:\<close>
-abbreviation (input) "UU \<equiv> bottom"
-
-text \<open>Simproc to rewrite \<^term>\<open>\<bottom> = x\<close> to \<^term>\<open>x = \<bottom>\<close>.\<close>
-setup \<open>Reorient_Proc.add (fn \<^Const_>\<open>bottom _\<close> => true | _ => false)\<close>
-simproc_setup reorient_bottom ("\<bottom> = x") = \<open>K Reorient_Proc.proc\<close>
-
-text \<open>useful lemmas about \<^term>\<open>\<bottom>\<close>\<close>
-
-lemma below_bottom_iff [simp]: "x \<sqsubseteq> \<bottom> \<longleftrightarrow> x = \<bottom>"
- by (simp add: po_eq_conv)
-
-lemma eq_bottom_iff: "x = \<bottom> \<longleftrightarrow> x \<sqsubseteq> \<bottom>"
- by simp
-
-lemma bottomI: "x \<sqsubseteq> \<bottom> \<Longrightarrow> x = \<bottom>"
- by (subst eq_bottom_iff)
-
-lemma lub_eq_bottom_iff: "chain Y \<Longrightarrow> (\<Squnion>i. Y i) = \<bottom> \<longleftrightarrow> (\<forall>i. Y i = \<bottom>)"
- by (simp only: eq_bottom_iff lub_below_iff)
-
-
-subsection \<open>Chain-finite and flat cpos\<close>
-
-text \<open>further useful classes for HOLCF domains\<close>
-
-class chfin = po +
- assumes chfin: "chain Y \<Longrightarrow> \<exists>n. max_in_chain n Y"
-begin
-
-subclass cpo
- apply standard
- apply (frule chfin)
- apply (blast intro: lub_finch1)
- done
-
-lemma chfin2finch: "chain Y \<Longrightarrow> finite_chain Y"
- by (simp add: chfin finite_chain_def)
-
-end
-
-class flat = pcpo +
- assumes ax_flat: "x \<sqsubseteq> y \<Longrightarrow> x = \<bottom> \<or> x = y"
-begin
-
-subclass chfin
-proof
- fix Y
- assume *: "chain Y"
- show "\<exists>n. max_in_chain n Y"
- apply (unfold max_in_chain_def)
- apply (cases "\<forall>i. Y i = \<bottom>")
- apply simp
- apply simp
- apply (erule exE)
- apply (rule_tac x="i" in exI)
- apply clarify
- using * apply (blast dest: chain_mono ax_flat)
- done
-qed
-
-lemma flat_below_iff: "x \<sqsubseteq> y \<longleftrightarrow> x = \<bottom> \<or> x = y"
- by (safe dest!: ax_flat)
-
-lemma flat_eq: "a \<noteq> \<bottom> \<Longrightarrow> a \<sqsubseteq> b = (a = b)"
- by (safe dest!: ax_flat)
-
-end
-
-subsection \<open>Discrete cpos\<close>
-
-class discrete_cpo = below +
- assumes discrete_cpo [simp]: "x \<sqsubseteq> y \<longleftrightarrow> x = y"
-begin
-
-subclass po
- by standard simp_all
-
-text \<open>In a discrete cpo, every chain is constant\<close>
-
-lemma discrete_chain_const:
- assumes S: "chain S"
- shows "\<exists>x. S = (\<lambda>i. x)"
-proof (intro exI ext)
- fix i :: nat
- from S le0 have "S 0 \<sqsubseteq> S i" by (rule chain_mono)
- then have "S 0 = S i" by simp
- then show "S i = S 0" by (rule sym)
-qed
-
-subclass chfin
-proof
- fix S :: "nat \<Rightarrow> 'a"
- assume S: "chain S"
- then have "\<exists>x. S = (\<lambda>i. x)"
- by (rule discrete_chain_const)
- then have "max_in_chain 0 S"
- by (auto simp: max_in_chain_def)
- then show "\<exists>i. max_in_chain i S" ..
-qed
-
-end
-
-end
--- a/src/HOL/HOLCF/Porder.thy Wed Dec 11 13:44:16 2024 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,343 +0,0 @@
-(* Title: HOL/HOLCF/Porder.thy
- Author: Franz Regensburger and Brian Huffman
-*)
-
-section \<open>Partial orders\<close>
-
-theory Porder
- imports Main
-begin
-
-declare [[typedef_overloaded]]
-
-
-subsection \<open>Type class for partial orders\<close>
-
-class below =
- fixes below :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
-begin
-
-notation (ASCII)
- below (infix \<open><<\<close> 50)
-
-notation
- below (infix \<open>\<sqsubseteq>\<close> 50)
-
-abbreviation not_below :: "'a \<Rightarrow> 'a \<Rightarrow> bool" (infix \<open>\<notsqsubseteq>\<close> 50)
- where "not_below x y \<equiv> \<not> below x y"
-
-notation (ASCII)
- not_below (infix \<open>~<<\<close> 50)
-
-lemma below_eq_trans: "a \<sqsubseteq> b \<Longrightarrow> b = c \<Longrightarrow> a \<sqsubseteq> c"
- by (rule subst)
-
-lemma eq_below_trans: "a = b \<Longrightarrow> b \<sqsubseteq> c \<Longrightarrow> a \<sqsubseteq> c"
- by (rule ssubst)
-
-end
-
-class po = below +
- assumes below_refl [iff]: "x \<sqsubseteq> x"
- assumes below_trans: "x \<sqsubseteq> y \<Longrightarrow> y \<sqsubseteq> z \<Longrightarrow> x \<sqsubseteq> z"
- assumes below_antisym: "x \<sqsubseteq> y \<Longrightarrow> y \<sqsubseteq> x \<Longrightarrow> x = y"
-begin
-
-lemma eq_imp_below: "x = y \<Longrightarrow> x \<sqsubseteq> y"
- by simp
-
-lemma box_below: "a \<sqsubseteq> b \<Longrightarrow> c \<sqsubseteq> a \<Longrightarrow> b \<sqsubseteq> d \<Longrightarrow> c \<sqsubseteq> d"
- by (rule below_trans [OF below_trans])
-
-lemma po_eq_conv: "x = y \<longleftrightarrow> x \<sqsubseteq> y \<and> y \<sqsubseteq> x"
- by (fast intro!: below_antisym)
-
-lemma rev_below_trans: "y \<sqsubseteq> z \<Longrightarrow> x \<sqsubseteq> y \<Longrightarrow> x \<sqsubseteq> z"
- by (rule below_trans)
-
-lemma not_below2not_eq: "x \<notsqsubseteq> y \<Longrightarrow> x \<noteq> y"
- by auto
-
-end
-
-lemmas HOLCF_trans_rules [trans] =
- below_trans
- below_antisym
- below_eq_trans
- eq_below_trans
-
-context po
-begin
-
-subsection \<open>Upper bounds\<close>
-
-definition is_ub :: "'a set \<Rightarrow> 'a \<Rightarrow> bool" (infix \<open><|\<close> 55)
- where "S <| x \<longleftrightarrow> (\<forall>y\<in>S. y \<sqsubseteq> x)"
-
-lemma is_ubI: "(\<And>x. x \<in> S \<Longrightarrow> x \<sqsubseteq> u) \<Longrightarrow> S <| u"
- by (simp add: is_ub_def)
-
-lemma is_ubD: "\<lbrakk>S <| u; x \<in> S\<rbrakk> \<Longrightarrow> x \<sqsubseteq> u"
- by (simp add: is_ub_def)
-
-lemma ub_imageI: "(\<And>x. x \<in> S \<Longrightarrow> f x \<sqsubseteq> u) \<Longrightarrow> (\<lambda>x. f x) ` S <| u"
- unfolding is_ub_def by fast
-
-lemma ub_imageD: "\<lbrakk>f ` S <| u; x \<in> S\<rbrakk> \<Longrightarrow> f x \<sqsubseteq> u"
- unfolding is_ub_def by fast
-
-lemma ub_rangeI: "(\<And>i. S i \<sqsubseteq> x) \<Longrightarrow> range S <| x"
- unfolding is_ub_def by fast
-
-lemma ub_rangeD: "range S <| x \<Longrightarrow> S i \<sqsubseteq> x"
- unfolding is_ub_def by fast
-
-lemma is_ub_empty [simp]: "{} <| u"
- unfolding is_ub_def by fast
-
-lemma is_ub_insert [simp]: "(insert x A) <| y = (x \<sqsubseteq> y \<and> A <| y)"
- unfolding is_ub_def by fast
-
-lemma is_ub_upward: "\<lbrakk>S <| x; x \<sqsubseteq> y\<rbrakk> \<Longrightarrow> S <| y"
- unfolding is_ub_def by (fast intro: below_trans)
-
-
-subsection \<open>Least upper bounds\<close>
-
-definition is_lub :: "'a set \<Rightarrow> 'a \<Rightarrow> bool" (infix \<open><<|\<close> 55)
- where "S <<| x \<longleftrightarrow> S <| x \<and> (\<forall>u. S <| u \<longrightarrow> x \<sqsubseteq> u)"
-
-definition lub :: "'a set \<Rightarrow> 'a"
- where "lub S = (THE x. S <<| x)"
-
-end
-
-syntax (ASCII)
- "_BLub" :: "[pttrn, 'a set, 'b] \<Rightarrow> 'b" (\<open>(\<open>indent=3 notation=\<open>binder LUB\<close>\<close>LUB _:_./ _)\<close> [0,0, 10] 10)
-
-syntax
- "_BLub" :: "[pttrn, 'a set, 'b] \<Rightarrow> 'b" (\<open>(\<open>indent=3 notation=\<open>binder \<Squnion>\<close>\<close>\<Squnion>_\<in>_./ _)\<close> [0,0, 10] 10)
-
-syntax_consts
- "_BLub" \<rightleftharpoons> lub
-
-translations
- "LUB x:A. t" \<rightleftharpoons> "CONST lub ((\<lambda>x. t) ` A)"
-
-context po
-begin
-
-abbreviation Lub (binder \<open>\<Squnion>\<close> 10)
- where "\<Squnion>n. t n \<equiv> lub (range t)"
-
-notation (ASCII)
- Lub (binder \<open>LUB \<close> 10)
-
-text \<open>access to some definition as inference rule\<close>
-
-lemma is_lubD1: "S <<| x \<Longrightarrow> S <| x"
- unfolding is_lub_def by fast
-
-lemma is_lubD2: "\<lbrakk>S <<| x; S <| u\<rbrakk> \<Longrightarrow> x \<sqsubseteq> u"
- unfolding is_lub_def by fast
-
-lemma is_lubI: "\<lbrakk>S <| x; \<And>u. S <| u \<Longrightarrow> x \<sqsubseteq> u\<rbrakk> \<Longrightarrow> S <<| x"
- unfolding is_lub_def by fast
-
-lemma is_lub_below_iff: "S <<| x \<Longrightarrow> x \<sqsubseteq> u \<longleftrightarrow> S <| u"
- unfolding is_lub_def is_ub_def by (metis below_trans)
-
-text \<open>lubs are unique\<close>
-
-lemma is_lub_unique: "S <<| x \<Longrightarrow> S <<| y \<Longrightarrow> x = y"
- unfolding is_lub_def is_ub_def by (blast intro: below_antisym)
-
-text \<open>technical lemmas about \<^term>\<open>lub\<close> and \<^term>\<open>is_lub\<close>\<close>
-
-lemma is_lub_lub: "M <<| x \<Longrightarrow> M <<| lub M"
- unfolding lub_def by (rule theI [OF _ is_lub_unique])
-
-lemma lub_eqI: "M <<| l \<Longrightarrow> lub M = l"
- by (rule is_lub_unique [OF is_lub_lub])
-
-lemma is_lub_singleton [simp]: "{x} <<| x"
- by (simp add: is_lub_def)
-
-lemma lub_singleton [simp]: "lub {x} = x"
- by (rule is_lub_singleton [THEN lub_eqI])
-
-lemma is_lub_bin: "x \<sqsubseteq> y \<Longrightarrow> {x, y} <<| y"
- by (simp add: is_lub_def)
-
-lemma lub_bin: "x \<sqsubseteq> y \<Longrightarrow> lub {x, y} = y"
- by (rule is_lub_bin [THEN lub_eqI])
-
-lemma is_lub_maximal: "S <| x \<Longrightarrow> x \<in> S \<Longrightarrow> S <<| x"
- by (erule is_lubI, erule (1) is_ubD)
-
-lemma lub_maximal: "S <| x \<Longrightarrow> x \<in> S \<Longrightarrow> lub S = x"
- by (rule is_lub_maximal [THEN lub_eqI])
-
-
-subsection \<open>Countable chains\<close>
-
-definition chain :: "(nat \<Rightarrow> 'a) \<Rightarrow> bool"
- where \<comment> \<open>Here we use countable chains and I prefer to code them as functions!\<close>
- "chain Y = (\<forall>i. Y i \<sqsubseteq> Y (Suc i))"
-
-lemma chainI: "(\<And>i. Y i \<sqsubseteq> Y (Suc i)) \<Longrightarrow> chain Y"
- unfolding chain_def by fast
-
-lemma chainE: "chain Y \<Longrightarrow> Y i \<sqsubseteq> Y (Suc i)"
- unfolding chain_def by fast
-
-text \<open>chains are monotone functions\<close>
-
-lemma chain_mono_less: "chain Y \<Longrightarrow> i < j \<Longrightarrow> Y i \<sqsubseteq> Y j"
- by (erule less_Suc_induct, erule chainE, erule below_trans)
-
-lemma chain_mono: "chain Y \<Longrightarrow> i \<le> j \<Longrightarrow> Y i \<sqsubseteq> Y j"
- by (cases "i = j") (simp_all add: chain_mono_less)
-
-lemma chain_shift: "chain Y \<Longrightarrow> chain (\<lambda>i. Y (i + j))"
- by (rule chainI, simp, erule chainE)
-
-text \<open>technical lemmas about (least) upper bounds of chains\<close>
-
-lemma is_lub_rangeD1: "range S <<| x \<Longrightarrow> S i \<sqsubseteq> x"
- by (rule is_lubD1 [THEN ub_rangeD])
-
-lemma is_ub_range_shift: "chain S \<Longrightarrow> range (\<lambda>i. S (i + j)) <| x = range S <| x"
- apply (rule iffI)
- apply (rule ub_rangeI)
- apply (rule_tac y="S (i + j)" in below_trans)
- apply (erule chain_mono)
- apply (rule le_add1)
- apply (erule ub_rangeD)
- apply (rule ub_rangeI)
- apply (erule ub_rangeD)
- done
-
-lemma is_lub_range_shift: "chain S \<Longrightarrow> range (\<lambda>i. S (i + j)) <<| x = range S <<| x"
- by (simp add: is_lub_def is_ub_range_shift)
-
-text \<open>the lub of a constant chain is the constant\<close>
-
-lemma chain_const [simp]: "chain (\<lambda>i. c)"
- by (simp add: chainI)
-
-lemma is_lub_const: "range (\<lambda>x. c) <<| c"
-by (blast dest: ub_rangeD intro: is_lubI ub_rangeI)
-
-lemma lub_const [simp]: "(\<Squnion>i. c) = c"
- by (rule is_lub_const [THEN lub_eqI])
-
-
-subsection \<open>Finite chains\<close>
-
-definition max_in_chain :: "nat \<Rightarrow> (nat \<Rightarrow> 'a) \<Rightarrow> bool"
- where \<comment> \<open>finite chains, needed for monotony of continuous functions\<close>
- "max_in_chain i C \<longleftrightarrow> (\<forall>j. i \<le> j \<longrightarrow> C i = C j)"
-
-definition finite_chain :: "(nat \<Rightarrow> 'a) \<Rightarrow> bool"
- where "finite_chain C = (chain C \<and> (\<exists>i. max_in_chain i C))"
-
-text \<open>results about finite chains\<close>
-
-lemma max_in_chainI: "(\<And>j. i \<le> j \<Longrightarrow> Y i = Y j) \<Longrightarrow> max_in_chain i Y"
- unfolding max_in_chain_def by fast
-
-lemma max_in_chainD: "max_in_chain i Y \<Longrightarrow> i \<le> j \<Longrightarrow> Y i = Y j"
- unfolding max_in_chain_def by fast
-
-lemma finite_chainI: "chain C \<Longrightarrow> max_in_chain i C \<Longrightarrow> finite_chain C"
- unfolding finite_chain_def by fast
-
-lemma finite_chainE: "\<lbrakk>finite_chain C; \<And>i. \<lbrakk>chain C; max_in_chain i C\<rbrakk> \<Longrightarrow> R\<rbrakk> \<Longrightarrow> R"
- unfolding finite_chain_def by fast
-
-lemma lub_finch1: "chain C \<Longrightarrow> max_in_chain i C \<Longrightarrow> range C <<| C i"
- apply (rule is_lubI)
- apply (rule ub_rangeI, rename_tac j)
- apply (rule_tac x=i and y=j in linorder_le_cases)
- apply (drule (1) max_in_chainD, simp)
- apply (erule (1) chain_mono)
- apply (erule ub_rangeD)
- done
-
-lemma lub_finch2: "finite_chain C \<Longrightarrow> range C <<| C (LEAST i. max_in_chain i C)"
- apply (erule finite_chainE)
- apply (erule LeastI2 [where Q="\<lambda>i. range C <<| C i"])
- apply (erule (1) lub_finch1)
- done
-
-lemma finch_imp_finite_range: "finite_chain Y \<Longrightarrow> finite (range Y)"
- apply (erule finite_chainE)
- apply (rule_tac B="Y ` {..i}" in finite_subset)
- apply (rule subsetI)
- apply (erule rangeE, rename_tac j)
- apply (rule_tac x=i and y=j in linorder_le_cases)
- apply (subgoal_tac "Y j = Y i", simp)
- apply (simp add: max_in_chain_def)
- apply simp
- apply simp
- done
-
-lemma finite_range_has_max:
- fixes f :: "nat \<Rightarrow> 'a"
- and r :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
- assumes mono: "\<And>i j. i \<le> j \<Longrightarrow> r (f i) (f j)"
- assumes finite_range: "finite (range f)"
- shows "\<exists>k. \<forall>i. r (f i) (f k)"
-proof (intro exI allI)
- fix i :: nat
- let ?j = "LEAST k. f k = f i"
- let ?k = "Max ((\<lambda>x. LEAST k. f k = x) ` range f)"
- have "?j \<le> ?k"
- proof (rule Max_ge)
- show "finite ((\<lambda>x. LEAST k. f k = x) ` range f)"
- using finite_range by (rule finite_imageI)
- show "?j \<in> (\<lambda>x. LEAST k. f k = x) ` range f"
- by (intro imageI rangeI)
- qed
- hence "r (f ?j) (f ?k)"
- by (rule mono)
- also have "f ?j = f i"
- by (rule LeastI, rule refl)
- finally show "r (f i) (f ?k)" .
-qed
-
-lemma finite_range_imp_finch: "chain Y \<Longrightarrow> finite (range Y) \<Longrightarrow> finite_chain Y"
- apply (subgoal_tac "\<exists>k. \<forall>i. Y i \<sqsubseteq> Y k")
- apply (erule exE)
- apply (rule finite_chainI, assumption)
- apply (rule max_in_chainI)
- apply (rule below_antisym)
- apply (erule (1) chain_mono)
- apply (erule spec)
- apply (rule finite_range_has_max)
- apply (erule (1) chain_mono)
- apply assumption
- done
-
-lemma bin_chain: "x \<sqsubseteq> y \<Longrightarrow> chain (\<lambda>i. if i=0 then x else y)"
- by (rule chainI) simp
-
-lemma bin_chainmax: "x \<sqsubseteq> y \<Longrightarrow> max_in_chain (Suc 0) (\<lambda>i. if i=0 then x else y)"
- by (simp add: max_in_chain_def)
-
-lemma is_lub_bin_chain: "x \<sqsubseteq> y \<Longrightarrow> range (\<lambda>i::nat. if i=0 then x else y) <<| y"
- apply (frule bin_chain)
- apply (drule bin_chainmax)
- apply (drule (1) lub_finch1)
- apply simp
- done
-
-text \<open>the maximal element in a chain is its lub\<close>
-
-lemma lub_chain_maxelem: "Y i = c \<Longrightarrow> \<forall>i. Y i \<sqsubseteq> c \<Longrightarrow> lub (range Y) = c"
- by (blast dest: ub_rangeD intro: lub_eqI is_lubI ub_rangeI)
-
-end
-
-end
--- a/src/HOL/HOLCF/Powerdomains.thy Wed Dec 11 13:44:16 2024 +0100
+++ b/src/HOL/HOLCF/Powerdomains.thy Wed Dec 11 13:44:35 2024 +0100
@@ -31,6 +31,7 @@
unfolding convex_emb_def convex_prj_def
by (simp add: ep_pair_udom approx_chain_convex_map)
+
subsection \<open>Deflation combinators\<close>
definition upper_defl :: "udom defl \<rightarrow> udom defl"
@@ -57,6 +58,7 @@
using ep_pair_convex finite_deflation_convex_map
unfolding convex_defl_def by (rule cast_defl_fun1)
+
subsection \<open>Domain class instances\<close>
instantiation upper_pd :: ("domain") "domain"
@@ -167,6 +169,7 @@
lemma DEFL_convex: "DEFL('a::domain convex_pd) = convex_defl\<cdot>DEFL('a)"
by (rule defl_convex_pd_def)
+
subsection \<open>Isomorphic deflations\<close>
lemma isodefl_upper:
@@ -193,6 +196,7 @@
apply (simp add: convex_map_map)
done
+
subsection \<open>Domain package setup for powerdomains\<close>
lemmas [domain_defl_simps] = DEFL_upper DEFL_lower DEFL_convex
--- a/src/HOL/HOLCF/Product_Cpo.thy Wed Dec 11 13:44:16 2024 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,304 +0,0 @@
-(* Title: HOL/HOLCF/Product_Cpo.thy
- Author: Franz Regensburger
-*)
-
-section \<open>The cpo of cartesian products\<close>
-
-theory Product_Cpo
- imports Adm
-begin
-
-default_sort cpo
-
-
-subsection \<open>Unit type is a pcpo\<close>
-
-instantiation unit :: discrete_cpo
-begin
-
-definition below_unit_def [simp]: "x \<sqsubseteq> (y::unit) \<longleftrightarrow> True"
-
-instance
- by standard simp
-
-end
-
-instance unit :: pcpo
- by standard simp
-
-
-subsection \<open>Product type is a partial order\<close>
-
-instantiation prod :: (below, below) below
-begin
-
-definition below_prod_def: "(\<sqsubseteq>) \<equiv> \<lambda>p1 p2. (fst p1 \<sqsubseteq> fst p2 \<and> snd p1 \<sqsubseteq> snd p2)"
-
-instance ..
-
-end
-
-instance prod :: (po, po) po
-proof
- fix x :: "'a \<times> 'b"
- show "x \<sqsubseteq> x"
- by (simp add: below_prod_def)
-next
- fix x y :: "'a \<times> 'b"
- assume "x \<sqsubseteq> y" "y \<sqsubseteq> x"
- then show "x = y"
- unfolding below_prod_def prod_eq_iff
- by (fast intro: below_antisym)
-next
- fix x y z :: "'a \<times> 'b"
- assume "x \<sqsubseteq> y" "y \<sqsubseteq> z"
- then show "x \<sqsubseteq> z"
- unfolding below_prod_def
- by (fast intro: below_trans)
-qed
-
-
-subsection \<open>Monotonicity of \emph{Pair}, \emph{fst}, \emph{snd}\<close>
-
-lemma prod_belowI: "fst p \<sqsubseteq> fst q \<Longrightarrow> snd p \<sqsubseteq> snd q \<Longrightarrow> p \<sqsubseteq> q"
- by (simp add: below_prod_def)
-
-lemma Pair_below_iff [simp]: "(a, b) \<sqsubseteq> (c, d) \<longleftrightarrow> a \<sqsubseteq> c \<and> b \<sqsubseteq> d"
- by (simp add: below_prod_def)
-
-text \<open>Pair \<open>(_,_)\<close> is monotone in both arguments\<close>
-
-lemma monofun_pair1: "monofun (\<lambda>x. (x, y))"
- by (simp add: monofun_def)
-
-lemma monofun_pair2: "monofun (\<lambda>y. (x, y))"
- by (simp add: monofun_def)
-
-lemma monofun_pair: "x1 \<sqsubseteq> x2 \<Longrightarrow> y1 \<sqsubseteq> y2 \<Longrightarrow> (x1, y1) \<sqsubseteq> (x2, y2)"
- by simp
-
-lemma ch2ch_Pair [simp]: "chain X \<Longrightarrow> chain Y \<Longrightarrow> chain (\<lambda>i. (X i, Y i))"
- by (rule chainI, simp add: chainE)
-
-text \<open>\<^term>\<open>fst\<close> and \<^term>\<open>snd\<close> are monotone\<close>
-
-lemma fst_monofun: "x \<sqsubseteq> y \<Longrightarrow> fst x \<sqsubseteq> fst y"
- by (simp add: below_prod_def)
-
-lemma snd_monofun: "x \<sqsubseteq> y \<Longrightarrow> snd x \<sqsubseteq> snd y"
- by (simp add: below_prod_def)
-
-lemma monofun_fst: "monofun fst"
- by (simp add: monofun_def below_prod_def)
-
-lemma monofun_snd: "monofun snd"
- by (simp add: monofun_def below_prod_def)
-
-lemmas ch2ch_fst [simp] = ch2ch_monofun [OF monofun_fst]
-
-lemmas ch2ch_snd [simp] = ch2ch_monofun [OF monofun_snd]
-
-lemma prod_chain_cases:
- assumes chain: "chain Y"
- obtains A B
- where "chain A" and "chain B" and "Y = (\<lambda>i. (A i, B i))"
-proof
- from chain show "chain (\<lambda>i. fst (Y i))"
- by (rule ch2ch_fst)
- from chain show "chain (\<lambda>i. snd (Y i))"
- by (rule ch2ch_snd)
- show "Y = (\<lambda>i. (fst (Y i), snd (Y i)))"
- by simp
-qed
-
-
-subsection \<open>Product type is a cpo\<close>
-
-lemma is_lub_Pair: "range A <<| x \<Longrightarrow> range B <<| y \<Longrightarrow> range (\<lambda>i. (A i, B i)) <<| (x, y)"
- by (simp add: is_lub_def is_ub_def below_prod_def)
-
-lemma lub_Pair: "chain A \<Longrightarrow> chain B \<Longrightarrow> (\<Squnion>i. (A i, B i)) = (\<Squnion>i. A i, \<Squnion>i. B i)"
- for A :: "nat \<Rightarrow> 'a::cpo" and B :: "nat \<Rightarrow> 'b::cpo"
- by (fast intro: lub_eqI is_lub_Pair elim: thelubE)
-
-lemma is_lub_prod:
- fixes S :: "nat \<Rightarrow> ('a::cpo \<times> 'b::cpo)"
- assumes "chain S"
- shows "range S <<| (\<Squnion>i. fst (S i), \<Squnion>i. snd (S i))"
- using assms by (auto elim: prod_chain_cases simp: is_lub_Pair cpo_lubI)
-
-lemma lub_prod: "chain S \<Longrightarrow> (\<Squnion>i. S i) = (\<Squnion>i. fst (S i), \<Squnion>i. snd (S i))"
- for S :: "nat \<Rightarrow> 'a::cpo \<times> 'b::cpo"
- by (rule is_lub_prod [THEN lub_eqI])
-
-instance prod :: (cpo, cpo) cpo
-proof
- fix S :: "nat \<Rightarrow> ('a \<times> 'b)"
- assume "chain S"
- then have "range S <<| (\<Squnion>i. fst (S i), \<Squnion>i. snd (S i))"
- by (rule is_lub_prod)
- then show "\<exists>x. range S <<| x" ..
-qed
-
-instance prod :: (discrete_cpo, discrete_cpo) discrete_cpo
-proof
- fix x y :: "'a \<times> 'b"
- show "x \<sqsubseteq> y \<longleftrightarrow> x = y"
- by (simp add: below_prod_def prod_eq_iff)
-qed
-
-
-subsection \<open>Product type is pointed\<close>
-
-lemma minimal_prod: "(\<bottom>, \<bottom>) \<sqsubseteq> p"
- by (simp add: below_prod_def)
-
-instance prod :: (pcpo, pcpo) pcpo
- by intro_classes (fast intro: minimal_prod)
-
-lemma inst_prod_pcpo: "\<bottom> = (\<bottom>, \<bottom>)"
- by (rule minimal_prod [THEN bottomI, symmetric])
-
-lemma Pair_bottom_iff [simp]: "(x, y) = \<bottom> \<longleftrightarrow> x = \<bottom> \<and> y = \<bottom>"
- by (simp add: inst_prod_pcpo)
-
-lemma fst_strict [simp]: "fst \<bottom> = \<bottom>"
- unfolding inst_prod_pcpo by (rule fst_conv)
-
-lemma snd_strict [simp]: "snd \<bottom> = \<bottom>"
- unfolding inst_prod_pcpo by (rule snd_conv)
-
-lemma Pair_strict [simp]: "(\<bottom>, \<bottom>) = \<bottom>"
- by simp
-
-lemma split_strict [simp]: "case_prod f \<bottom> = f \<bottom> \<bottom>"
- by (simp add: split_def)
-
-
-subsection \<open>Continuity of \emph{Pair}, \emph{fst}, \emph{snd}\<close>
-
-lemma cont_pair1: "cont (\<lambda>x. (x, y))"
- apply (rule contI)
- apply (rule is_lub_Pair)
- apply (erule cpo_lubI)
- apply (rule is_lub_const)
- done
-
-lemma cont_pair2: "cont (\<lambda>y. (x, y))"
- apply (rule contI)
- apply (rule is_lub_Pair)
- apply (rule is_lub_const)
- apply (erule cpo_lubI)
- done
-
-lemma cont_fst: "cont fst"
- apply (rule contI)
- apply (simp add: lub_prod)
- apply (erule cpo_lubI [OF ch2ch_fst])
- done
-
-lemma cont_snd: "cont snd"
- apply (rule contI)
- apply (simp add: lub_prod)
- apply (erule cpo_lubI [OF ch2ch_snd])
- done
-
-lemma cont2cont_Pair [simp, cont2cont]:
- assumes f: "cont (\<lambda>x. f x)"
- assumes g: "cont (\<lambda>x. g x)"
- shows "cont (\<lambda>x. (f x, g x))"
- apply (rule cont_apply [OF f cont_pair1])
- apply (rule cont_apply [OF g cont_pair2])
- apply (rule cont_const)
- done
-
-lemmas cont2cont_fst [simp, cont2cont] = cont_compose [OF cont_fst]
-
-lemmas cont2cont_snd [simp, cont2cont] = cont_compose [OF cont_snd]
-
-lemma cont2cont_case_prod:
- assumes f1: "\<And>a b. cont (\<lambda>x. f x a b)"
- assumes f2: "\<And>x b. cont (\<lambda>a. f x a b)"
- assumes f3: "\<And>x a. cont (\<lambda>b. f x a b)"
- assumes g: "cont (\<lambda>x. g x)"
- shows "cont (\<lambda>x. case g x of (a, b) \<Rightarrow> f x a b)"
- unfolding split_def
- apply (rule cont_apply [OF g])
- apply (rule cont_apply [OF cont_fst f2])
- apply (rule cont_apply [OF cont_snd f3])
- apply (rule cont_const)
- apply (rule f1)
- done
-
-lemma prod_contI:
- assumes f1: "\<And>y. cont (\<lambda>x. f (x, y))"
- assumes f2: "\<And>x. cont (\<lambda>y. f (x, y))"
- shows "cont f"
-proof -
- have "cont (\<lambda>(x, y). f (x, y))"
- by (intro cont2cont_case_prod f1 f2 cont2cont)
- then show "cont f"
- by (simp only: case_prod_eta)
-qed
-
-lemma prod_cont_iff: "cont f \<longleftrightarrow> (\<forall>y. cont (\<lambda>x. f (x, y))) \<and> (\<forall>x. cont (\<lambda>y. f (x, y)))"
- apply safe
- apply (erule cont_compose [OF _ cont_pair1])
- apply (erule cont_compose [OF _ cont_pair2])
- apply (simp only: prod_contI)
- done
-
-lemma cont2cont_case_prod' [simp, cont2cont]:
- assumes f: "cont (\<lambda>p. f (fst p) (fst (snd p)) (snd (snd p)))"
- assumes g: "cont (\<lambda>x. g x)"
- shows "cont (\<lambda>x. case_prod (f x) (g x))"
- using assms by (simp add: cont2cont_case_prod prod_cont_iff)
-
-text \<open>The simple version (due to Joachim Breitner) is needed if
- either element type of the pair is not a cpo.\<close>
-
-lemma cont2cont_split_simple [simp, cont2cont]:
- assumes "\<And>a b. cont (\<lambda>x. f x a b)"
- shows "cont (\<lambda>x. case p of (a, b) \<Rightarrow> f x a b)"
- using assms by (cases p) auto
-
-text \<open>Admissibility of predicates on product types.\<close>
-
-lemma adm_case_prod [simp]:
- assumes "adm (\<lambda>x. P x (fst (f x)) (snd (f x)))"
- shows "adm (\<lambda>x. case f x of (a, b) \<Rightarrow> P x a b)"
- unfolding case_prod_beta using assms .
-
-
-subsection \<open>Compactness and chain-finiteness\<close>
-
-lemma fst_below_iff: "fst x \<sqsubseteq> y \<longleftrightarrow> x \<sqsubseteq> (y, snd x)"
- for x :: "'a \<times> 'b"
- by (simp add: below_prod_def)
-
-lemma snd_below_iff: "snd x \<sqsubseteq> y \<longleftrightarrow> x \<sqsubseteq> (fst x, y)"
- for x :: "'a \<times> 'b"
- by (simp add: below_prod_def)
-
-lemma compact_fst: "compact x \<Longrightarrow> compact (fst x)"
- by (rule compactI) (simp add: fst_below_iff)
-
-lemma compact_snd: "compact x \<Longrightarrow> compact (snd x)"
- by (rule compactI) (simp add: snd_below_iff)
-
-lemma compact_Pair: "compact x \<Longrightarrow> compact y \<Longrightarrow> compact (x, y)"
- by (rule compactI) (simp add: below_prod_def)
-
-lemma compact_Pair_iff [simp]: "compact (x, y) \<longleftrightarrow> compact x \<and> compact y"
- apply (safe intro!: compact_Pair)
- apply (drule compact_fst, simp)
- apply (drule compact_snd, simp)
- done
-
-instance prod :: (chfin, chfin) chfin
- apply intro_classes
- apply (erule compact_imp_max_in_chain)
- apply (case_tac "\<Squnion>i. Y i", simp)
- done
-
-end
--- a/src/HOL/HOLCF/Representable.thy Wed Dec 11 13:44:16 2024 +0100
+++ b/src/HOL/HOLCF/Representable.thy Wed Dec 11 13:44:35 2024 +0100
@@ -10,6 +10,7 @@
default_sort cpo
+
subsection \<open>Class of representable domains\<close>
text \<open>
@@ -88,6 +89,7 @@
lemmas emb_strict = domain.e_strict
lemmas prj_strict = domain.p_strict
+
subsection \<open>Domains are bifinite\<close>
lemma approx_chain_ep_cast:
@@ -126,6 +128,7 @@
instance predomain \<subseteq> profinite
by standard (rule approx_chain_ep_cast [OF predomain_ep cast_liftdefl])
+
subsection \<open>Universal domain ep-pairs\<close>
definition "u_emb = udom_emb (\<lambda>i. u_map\<cdot>(udom_approx i))"
@@ -163,6 +166,7 @@
unfolding sfun_emb_def sfun_prj_def
by (simp add: ep_pair_udom approx_chain_sfun_map)
+
subsection \<open>Type combinators\<close>
definition u_defl :: "udom defl \<rightarrow> udom defl"
@@ -223,6 +227,7 @@
by (rule cast_eq_imp_eq)
(simp add: cast_u_liftdefl cast_liftdefl_of cast_u_defl)
+
subsection \<open>Class instance proofs\<close>
subsubsection \<open>Universal domain\<close>
@@ -267,6 +272,7 @@
end
+
subsubsection \<open>Lifted cpo\<close>
instantiation u :: (predomain) "domain"
@@ -304,6 +310,7 @@
lemma DEFL_u: "DEFL('a::predomain u) = u_liftdefl\<cdot>LIFTDEFL('a)"
by (rule defl_u_def)
+
subsubsection \<open>Strict function space\<close>
instantiation sfun :: ("domain", "domain") "domain"
@@ -342,6 +349,7 @@
"DEFL('a::domain \<rightarrow>! 'b::domain) = sfun_defl\<cdot>DEFL('a)\<cdot>DEFL('b)"
by (rule defl_sfun_def)
+
subsubsection \<open>Continuous function space\<close>
instantiation cfun :: (predomain, "domain") "domain"
@@ -382,6 +390,7 @@
"DEFL('a::predomain \<rightarrow> 'b::domain) = DEFL('a u \<rightarrow>! 'b)"
by (rule defl_cfun_def)
+
subsubsection \<open>Strict product\<close>
instantiation sprod :: ("domain", "domain") "domain"
@@ -420,6 +429,7 @@
"DEFL('a::domain \<otimes> 'b::domain) = sprod_defl\<cdot>DEFL('a)\<cdot>DEFL('b)"
by (rule defl_sprod_def)
+
subsubsection \<open>Cartesian product\<close>
definition prod_liftdefl :: "udom u defl \<rightarrow> udom u defl \<rightarrow> udom u defl"
@@ -508,6 +518,7 @@
prod_liftdefl\<cdot>LIFTDEFL('a)\<cdot>LIFTDEFL('b)"
by (rule liftdefl_prod_def)
+
subsubsection \<open>Unit type\<close>
instantiation unit :: "domain"
@@ -541,6 +552,7 @@
end
+
subsubsection \<open>Discrete cpo\<close>
instantiation discr :: (countable) predomain
@@ -586,6 +598,7 @@
end
+
subsubsection \<open>Strict sum\<close>
instantiation ssum :: ("domain", "domain") "domain"
@@ -624,6 +637,7 @@
"DEFL('a::domain \<oplus> 'b::domain) = ssum_defl\<cdot>DEFL('a)\<cdot>DEFL('b)"
by (rule defl_ssum_def)
+
subsubsection \<open>Lifted HOL type\<close>
instantiation lift :: (countable) "domain"
--- a/src/HOL/HOLCF/Universal.thy Wed Dec 11 13:44:16 2024 +0100
+++ b/src/HOL/HOLCF/Universal.thy Wed Dec 11 13:44:35 2024 +0100
@@ -8,7 +8,8 @@
imports Bifinite Completion "HOL-Library.Nat_Bijection"
begin
-no_notation binomial (infix \<open>choose\<close> 64)
+unbundle no binomial_syntax
+
subsection \<open>Basis for universal domain\<close>
@@ -79,6 +80,7 @@
apply (simp add: 2 node_gt1 node_gt2)
done
+
subsubsection \<open>Basis ordering\<close>
inductive
@@ -105,6 +107,7 @@
apply (erule (1) ubasis_le_trans)
done
+
subsubsection \<open>Generic take function\<close>
function
@@ -275,6 +278,7 @@
approx_chain approx for approx :: "nat \<Rightarrow> 'a::bifinite \<rightarrow> 'a"
begin
+
subsubsection \<open>Choosing a maximal element from a finite set\<close>
lemma finite_has_maximal:
@@ -389,6 +393,7 @@
apply (simp add: choose_pos.simps)
done
+
subsubsection \<open>Compact basis take function\<close>
primrec
@@ -443,6 +448,7 @@
apply (rule inj_onI, simp add: Rep_compact_basis_inject)
done
+
subsubsection \<open>Rank of basis elements\<close>
definition
@@ -522,6 +528,7 @@
lemma rank_lt_Un_rank_eq: "rank_lt x \<union> rank_eq x = rank_le x"
unfolding rank_lt_def rank_eq_def rank_le_def by auto
+
subsubsection \<open>Sequencing basis elements\<close>
definition
@@ -571,6 +578,7 @@
lemma inj_place: "inj place"
by (rule inj_onI, erule place_eqD)
+
subsubsection \<open>Embedding and projection on basis elements\<close>
definition
@@ -831,6 +839,7 @@
by (rule bifinite_approx_chain.ideal_completion)
qed
+
subsubsection \<open>EP-pair from any bifinite domain into \emph{udom}\<close>
context bifinite_approx_chain begin
@@ -879,6 +888,7 @@
lemmas ep_pair_udom =
bifinite_approx_chain.ep_pair_udom [unfolded bifinite_approx_chain_def]
+
subsection \<open>Chain of approx functions for type \emph{udom}\<close>
definition
@@ -973,6 +983,6 @@
hide_const (open) node
-notation binomial (infixl \<open>choose\<close> 65)
+unbundle binomial_syntax
end
--- a/src/HOL/HOLCF/UpperPD.thy Wed Dec 11 13:44:16 2024 +0100
+++ b/src/HOL/HOLCF/UpperPD.thy Wed Dec 11 13:44:35 2024 +0100
@@ -452,6 +452,7 @@
by (rule finite_range_imp_finite_fixes)
qed
+
subsection \<open>Upper powerdomain is bifinite\<close>
lemma approx_chain_upper_map:
@@ -467,6 +468,7 @@
by (fast intro!: approx_chain_upper_map)
qed
+
subsection \<open>Join\<close>
definition
--- a/src/Pure/Admin/component_cvc5.scala Wed Dec 11 13:44:16 2024 +0100
+++ b/src/Pure/Admin/component_cvc5.scala Wed Dec 11 13:44:35 2024 +0100
@@ -19,17 +19,17 @@
val platforms: List[Download_Platform] =
List(
- Download_Platform("arm64-darwin", "cvc5-macOS-arm64-static-2024-03-20-ef2bc3f.zip"),
- Download_Platform("arm64-linux", "cvc5-Linux-arm64-static-2024-03-20-ef2bc3f.zip"),
- Download_Platform("x86_64-darwin", "cvc5-macOS-static-2024-03-20-ef2bc3f.zip"),
- Download_Platform("x86_64-linux", "cvc5-Linux-static-2024-03-20-ef2bc3f.zip"),
- Download_Platform("x86_64-windows", "cvc5-Win64-static-2024-03-20-ef2bc3f.zip"))
+ Download_Platform("arm64-darwin", "cvc5-macOS-arm64-static.zip"),
+ Download_Platform("arm64-linux", "cvc5-Linux-arm64-static.zip"),
+ Download_Platform("x86_64-darwin", "cvc5-macOS-x86_64-static.zip"),
+ Download_Platform("x86_64-linux", "cvc5-Linux-x86_64-static.zip"),
+ Download_Platform("x86_64-windows", "cvc5-Win64-x86_64-static.zip"))
/* build cvc5 */
val default_url = "https://github.com/cvc5/cvc5/releases/download"
- val default_version = "latest"
+ val default_version = "1.2.0"
def build_cvc5(
base_url: String = default_url,
@@ -48,7 +48,7 @@
for (platform <- platforms) {
Isabelle_System.with_tmp_dir("download") { download_dir =>
- val download = base_url + "/" + version + "/" + platform.download_name
+ val download = base_url + "/cvc5-" + version + "/" + platform.download_name
val archive_name =
Url.get_base_name(platform.download_name) getOrElse
@@ -86,11 +86,9 @@
/* README */
File.write(component_dir.README,
- """This distribution of cvc5 was assembled from official downloads
-from """ + base_url + """ for macOS, Linux,
-and Windows, with ARM64 support on macOS and Linux.
-
-The change id is ef2bc3f735df (3 weeks after cvc5-1.1.2).
+ """This distribution of cvc5 was assembled from official downloads from
+""" + base_url + """ --- the static.zip variants
+for macOS, Linux, and Windows, with ARM64 support on macOS and Linux.
The downloaded files were renamed and made executable.
--- a/src/Pure/ROOT.ML Wed Dec 11 13:44:16 2024 +0100
+++ b/src/Pure/ROOT.ML Wed Dec 11 13:44:35 2024 +0100
@@ -373,4 +373,3 @@
ML_file "Tools/jedit.ML";
ML_file "Tools/ghc.ML";
ML_file "Tools/generated_files.ML";
-
--- a/src/Pure/Syntax/syntax_phases.ML Wed Dec 11 13:44:16 2024 +0100
+++ b/src/Pure/Syntax/syntax_phases.ML Wed Dec 11 13:44:35 2024 +0100
@@ -877,8 +877,8 @@
(case asts of
[Ast.Appl [Ast.Constant "_constrain", Ast.Variable c, T as Ast.Variable p]] =>
let
- val (c', _) = decode_const ctxt (c, map #pos (Term_Position.decode p));
- val d = if intern then Lexicon.mark_const c' else c;
+ val (c', reports) = decode_const ctxt (c, map #pos (Term_Position.decode p));
+ val d = if intern then (Context_Position.reports ctxt reports; Lexicon.mark_const c') else c;
in Ast.constrain (Ast.Constant d) T end
| _ => raise Ast.AST ("const_ast_tr", asts));
--- a/src/Tools/jEdit/src/jedit_lib.scala Wed Dec 11 13:44:16 2024 +0100
+++ b/src/Tools/jEdit/src/jedit_lib.scala Wed Dec 11 13:44:35 2024 +0100
@@ -365,12 +365,14 @@
def pixel_range(text_area: TextArea, x: Int, y: Int): Option[Text.Range] = {
// coordinates wrt. inner painter component
val painter = text_area.getPainter
+ val buffer = text_area.getBuffer
if (0 <= x && x < painter.getWidth && 0 <= y && y < painter.getHeight) {
val offset = text_area.xyToOffset(x, y, false)
if (offset >= 0) {
- val range = point_range(text_area.getBuffer, offset)
+ val range = point_range(buffer, offset)
gfx_range(text_area)(range) match {
- case Some(g) if g.x <= x && x < g.x + g.length => Some(range)
+ case Some(g) if g.x <= x && x < g.x + g.length =>
+ range.try_restrict(buffer_range(buffer))
case _ => None
}
}