# Theory Porder

```(*  Title:      HOL/HOLCF/Porder.thy
Author:     Franz Regensburger and Brian Huffman
*)

section ‹Partial orders›

theory Porder
imports Main
begin

subsection ‹Type class for partial orders›

class below =
fixes below :: "'a ⇒ 'a ⇒ bool"
begin

notation (ASCII)
below (infix "<<" 50)

notation
below (infix "⊑" 50)

abbreviation not_below :: "'a ⇒ 'a ⇒ bool"  (infix "\<notsqsubseteq>" 50)
where "not_below x y ≡ ¬ below x y"

notation (ASCII)
not_below  (infix "~<<" 50)

lemma below_eq_trans: "a ⊑ b ⟹ b = c ⟹ a ⊑ c"
by (rule subst)

lemma eq_below_trans: "a = b ⟹ b ⊑ c ⟹ a ⊑ c"
by (rule ssubst)

end

class po = below +
assumes below_refl [iff]: "x ⊑ x"
assumes below_trans: "x ⊑ y ⟹ y ⊑ z ⟹ x ⊑ z"
assumes below_antisym: "x ⊑ y ⟹ y ⊑ x ⟹ x = y"
begin

lemma eq_imp_below: "x = y ⟹ x ⊑ y"
by simp

lemma box_below: "a ⊑ b ⟹ c ⊑ a ⟹ b ⊑ d ⟹ c ⊑ d"
by (rule below_trans [OF below_trans])

lemma po_eq_conv: "x = y ⟷ x ⊑ y ∧ y ⊑ x"
by (fast intro!: below_antisym)

lemma rev_below_trans: "y ⊑ z ⟹ x ⊑ y ⟹ x ⊑ z"
by (rule below_trans)

lemma not_below2not_eq: "x \<notsqsubseteq> y ⟹ x ≠ y"
by auto

end

lemmas HOLCF_trans_rules [trans] =
below_trans
below_antisym
below_eq_trans
eq_below_trans

context po
begin

subsection ‹Upper bounds›

definition is_ub :: "'a set ⇒ 'a ⇒ bool" (infix "<|" 55)
where "S <| x ⟷ (∀y∈S. y ⊑ x)"

lemma is_ubI: "(⋀x. x ∈ S ⟹ x ⊑ u) ⟹ S <| u"
by (simp add: is_ub_def)

lemma is_ubD: "⟦S <| u; x ∈ S⟧ ⟹ x ⊑ u"
by (simp add: is_ub_def)

lemma ub_imageI: "(⋀x. x ∈ S ⟹ f x ⊑ u) ⟹ (λx. f x) ` S <| u"
unfolding is_ub_def by fast

lemma ub_imageD: "⟦f ` S <| u; x ∈ S⟧ ⟹ f x ⊑ u"
unfolding is_ub_def by fast

lemma ub_rangeI: "(⋀i. S i ⊑ x) ⟹ range S <| x"
unfolding is_ub_def by fast

lemma ub_rangeD: "range S <| x ⟹ S i ⊑ 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 ⊑ y ∧ A <| y)"
unfolding is_ub_def by fast

lemma is_ub_upward: "⟦S <| x; x ⊑ y⟧ ⟹ S <| y"
unfolding is_ub_def by (fast intro: below_trans)

subsection ‹Least upper bounds›

definition is_lub :: "'a set ⇒ 'a ⇒ bool" (infix "<<|" 55)
where "S <<| x ⟷ S <| x ∧ (∀u. S <| u ⟶ x ⊑ u)"

definition lub :: "'a set ⇒ 'a"
where "lub S = (THE x. S <<| x)"

end

syntax (ASCII)
"_BLub" :: "[pttrn, 'a set, 'b] ⇒ 'b" ("(3LUB _:_./ _)" [0,0, 10] 10)

syntax
"_BLub" :: "[pttrn, 'a set, 'b] ⇒ 'b" ("(3⨆_∈_./ _)" [0,0, 10] 10)

translations
"LUB x:A. t" ⇌ "CONST lub ((λx. t) ` A)"

context po
begin

abbreviation Lub  (binder "⨆" 10)
where "⨆n. t n ≡ lub (range t)"

notation (ASCII)
Lub  (binder "LUB " 10)

text ‹access to some definition as inference rule›

lemma is_lubD1: "S <<| x ⟹ S <| x"
unfolding is_lub_def by fast

lemma is_lubD2: "⟦S <<| x; S <| u⟧ ⟹ x ⊑ u"
unfolding is_lub_def by fast

lemma is_lubI: "⟦S <| x; ⋀u. S <| u ⟹ x ⊑ u⟧ ⟹ S <<| x"
unfolding is_lub_def by fast

lemma is_lub_below_iff: "S <<| x ⟹ x ⊑ u ⟷ S <| u"
unfolding is_lub_def is_ub_def by (metis below_trans)

text ‹lubs are unique›

lemma is_lub_unique: "S <<| x ⟹ S <<| y ⟹ x = y"
unfolding is_lub_def is_ub_def by (blast intro: below_antisym)

text ‹technical lemmas about \<^term>‹lub› and \<^term>‹is_lub››

lemma is_lub_lub: "M <<| x ⟹ M <<| lub M"
unfolding lub_def by (rule theI [OF _ is_lub_unique])

lemma lub_eqI: "M <<| l ⟹ 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 ⊑ y ⟹ {x, y} <<| y"
by (simp add: is_lub_def)

lemma lub_bin: "x ⊑ y ⟹ lub {x, y} = y"
by (rule is_lub_bin [THEN lub_eqI])

lemma is_lub_maximal: "S <| x ⟹ x ∈ S ⟹ S <<| x"
by (erule is_lubI, erule (1) is_ubD)

lemma lub_maximal: "S <| x ⟹ x ∈ S ⟹ lub S = x"
by (rule is_lub_maximal [THEN lub_eqI])

subsection ‹Countable chains›

definition chain :: "(nat ⇒ 'a) ⇒ bool"
where ― ‹Here we use countable chains and I prefer to code them as functions!›
"chain Y = (∀i. Y i ⊑ Y (Suc i))"

lemma chainI: "(⋀i. Y i ⊑ Y (Suc i)) ⟹ chain Y"
unfolding chain_def by fast

lemma chainE: "chain Y ⟹ Y i ⊑ Y (Suc i)"
unfolding chain_def by fast

text ‹chains are monotone functions›

lemma chain_mono_less: "chain Y ⟹ i < j ⟹ Y i ⊑ Y j"
by (erule less_Suc_induct, erule chainE, erule below_trans)

lemma chain_mono: "chain Y ⟹ i ≤ j ⟹ Y i ⊑ Y j"
by (cases "i = j") (simp_all add: chain_mono_less)

lemma chain_shift: "chain Y ⟹ chain (λi. Y (i + j))"
by (rule chainI, simp, erule chainE)

text ‹technical lemmas about (least) upper bounds of chains›

lemma is_lub_rangeD1: "range S <<| x ⟹ S i ⊑ x"
by (rule is_lubD1 [THEN ub_rangeD])

lemma is_ub_range_shift: "chain S ⟹ range (λ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 (erule ub_rangeD)
apply (rule ub_rangeI)
apply (erule ub_rangeD)
done

lemma is_lub_range_shift: "chain S ⟹ range (λi. S (i + j)) <<| x = range S <<| x"
by (simp add: is_lub_def is_ub_range_shift)

text ‹the lub of a constant chain is the constant›

lemma chain_const [simp]: "chain (λi. c)"
by (simp add: chainI)

lemma is_lub_const: "range (λx. c) <<| c"
by (blast dest: ub_rangeD intro: is_lubI ub_rangeI)

lemma lub_const [simp]: "(⨆i. c) = c"
by (rule is_lub_const [THEN lub_eqI])

subsection ‹Finite chains›

definition max_in_chain :: "nat ⇒ (nat ⇒ 'a) ⇒ bool"
where ― ‹finite chains, needed for monotony of continuous functions›
"max_in_chain i C ⟷ (∀j. i ≤ j ⟶ C i = C j)"

definition finite_chain :: "(nat ⇒ 'a) ⇒ bool"
where "finite_chain C = (chain C ∧ (∃i. max_in_chain i C))"

text ‹results about finite chains›

lemma max_in_chainI: "(⋀j. i ≤ j ⟹ Y i = Y j) ⟹ max_in_chain i Y"
unfolding max_in_chain_def by fast

lemma max_in_chainD: "max_in_chain i Y ⟹ i ≤ j ⟹ Y i = Y j"
unfolding max_in_chain_def by fast

lemma finite_chainI: "chain C ⟹ max_in_chain i C ⟹ finite_chain C"
unfolding finite_chain_def by fast

lemma finite_chainE: "⟦finite_chain C; ⋀i. ⟦chain C; max_in_chain i C⟧ ⟹ R⟧ ⟹ R"
unfolding finite_chain_def by fast

lemma lub_finch1: "chain C ⟹ max_in_chain i C ⟹ 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 ⟹ range C <<| C (LEAST i. max_in_chain i C)"
apply (erule finite_chainE)
apply (erule LeastI2 [where Q="λi. range C <<| C i"])
apply (erule (1) lub_finch1)
done

lemma finch_imp_finite_range: "finite_chain Y ⟹ 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 ⇒ 'a"
and r :: "'a ⇒ 'a ⇒ bool"
assumes mono: "⋀i j. i ≤ j ⟹ r (f i) (f j)"
assumes finite_range: "finite (range f)"
shows "∃k. ∀i. r (f i) (f k)"
proof (intro exI allI)
fix i :: nat
let ?j = "LEAST k. f k = f i"
let ?k = "Max ((λx. LEAST k. f k = x) ` range f)"
have "?j ≤ ?k"
proof (rule Max_ge)
show "finite ((λx. LEAST k. f k = x) ` range f)"
using finite_range by (rule finite_imageI)
show "?j ∈ (λ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 ⟹ finite (range Y) ⟹ finite_chain Y"
apply (subgoal_tac "∃k. ∀i. Y i ⊑ 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 ⊑ y ⟹ chain (λi. if i=0 then x else y)"
by (rule chainI) simp

lemma bin_chainmax: "x ⊑ y ⟹ max_in_chain (Suc 0) (λi. if i=0 then x else y)"
by (simp add: max_in_chain_def)

lemma is_lub_bin_chain: "x ⊑ y ⟹ range (λi::nat. if i=0 then x else y) <<| y"
apply (frule bin_chain)
apply (drule bin_chainmax)
apply (drule (1) lub_finch1)
apply simp
done

text ‹the maximal element in a chain is its lub›

lemma lub_chain_maxelem: "Y i = c ⟹ ∀i. Y i ⊑ c ⟹ lub (range Y) = c"
by (blast dest: ub_rangeD intro: lub_eqI is_lubI ub_rangeI)

end

end
```