# Theory Porder

Up to index of Isabelle/HOL/HOLCF

theory Porder
imports Main
`(*  Title:      HOL/HOLCF/Porder.thy    Author:     Franz Regensburger and Brian Huffman*)header {* Partial orders *}theory Porderimports Mainbeginsubsection {* Type class for partial orders *}class below =  fixes below :: "'a => 'a => bool"beginnotation  below (infix "<<" 50)notation (xsymbols)  below (infix "\<sqsubseteq>" 50)abbreviation  not_below :: "'a => 'a => bool" (infix "~<<" 50)  where "not_below x y ≡ ¬ below x y"notation (xsymbols)  not_below (infix "\<notsqsubseteq>" 50)lemma below_eq_trans: "[|a \<sqsubseteq> b; b = c|] ==> a \<sqsubseteq> c"  by (rule subst)lemma eq_below_trans: "[|a = b; b \<sqsubseteq> c|] ==> a \<sqsubseteq> c"  by (rule ssubst)endclass po = below +  assumes below_refl [iff]: "x \<sqsubseteq> x"  assumes below_trans: "x \<sqsubseteq> y ==> y \<sqsubseteq> z ==> x \<sqsubseteq> z"  assumes below_antisym: "x \<sqsubseteq> y ==> y \<sqsubseteq> x ==> x = y"beginlemma eq_imp_below: "x = y ==> x \<sqsubseteq> y"  by simplemma box_below: "a \<sqsubseteq> b ==> c \<sqsubseteq> a ==> b \<sqsubseteq> d ==> c \<sqsubseteq> d"  by (rule below_trans [OF below_trans])lemma po_eq_conv: "x = y <-> x \<sqsubseteq> y ∧ y \<sqsubseteq> x"  by (fast intro!: below_antisym)lemma rev_below_trans: "y \<sqsubseteq> z ==> x \<sqsubseteq> y ==> x \<sqsubseteq> z"  by (rule below_trans)lemma not_below2not_eq: "x \<notsqsubseteq> y ==> x ≠ y"  by autoendlemmas HOLCF_trans_rules [trans] =  below_trans  below_antisym  below_eq_trans  eq_below_transcontext pobeginsubsection {* Upper bounds *}definition is_ub :: "'a set => 'a => bool" (infix "<|" 55) where  "S <| x <-> (∀y∈S. y \<sqsubseteq> x)"lemma is_ubI: "(!!x. x ∈ S ==> x \<sqsubseteq> u) ==> S <| u"  by (simp add: is_ub_def)lemma is_ubD: "[|S <| u; x ∈ S|] ==> x \<sqsubseteq> u"  by (simp add: is_ub_def)lemma ub_imageI: "(!!x. x ∈ S ==> f x \<sqsubseteq> u) ==> (λx. f x) ` S <| u"  unfolding is_ub_def by fastlemma ub_imageD: "[|f ` S <| u; x ∈ S|] ==> f x \<sqsubseteq> u"  unfolding is_ub_def by fastlemma ub_rangeI: "(!!i. S i \<sqsubseteq> x) ==> range S <| x"  unfolding is_ub_def by fastlemma ub_rangeD: "range S <| x ==> S i \<sqsubseteq> x"  unfolding is_ub_def by fastlemma is_ub_empty [simp]: "{} <| u"  unfolding is_ub_def by fastlemma is_ub_insert [simp]: "(insert x A) <| y = (x \<sqsubseteq> y ∧ A <| y)"  unfolding is_ub_def by fastlemma is_ub_upward: "[|S <| x; x \<sqsubseteq> 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 \<sqsubseteq> u)"definition lub :: "'a set => 'a" where  "lub S = (THE x. S <<| x)"endsyntax  "_BLub" :: "[pttrn, 'a set, 'b] => 'b" ("(3LUB _:_./ _)" [0,0, 10] 10)syntax (xsymbols)  "_BLub" :: "[pttrn, 'a set, 'b] => 'b" ("(3\<Squnion>_∈_./ _)" [0,0, 10] 10)translations  "LUB x:A. t" == "CONST lub ((%x. t) ` A)"context pobeginabbreviation  Lub  (binder "LUB " 10) where  "LUB n. t n == lub (range t)"notation (xsymbols)  Lub  (binder "\<Squnion> " 10)text {* access to some definition as inference rule *}lemma is_lubD1: "S <<| x ==> S <| x"  unfolding is_lub_def by fastlemma is_lubD2: "[|S <<| x; S <| u|] ==> x \<sqsubseteq> u"  unfolding is_lub_def by fastlemma is_lubI: "[|S <| x; !!u. S <| u ==> x \<sqsubseteq> u|] ==> S <<| x"  unfolding is_lub_def by fastlemma is_lub_below_iff: "S <<| x ==> x \<sqsubseteq> 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: "{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 ==> {x, y} <<| y"  by (simp add: is_lub_def)lemma lub_bin: "x \<sqsubseteq> 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 \<sqsubseteq> Y (Suc i))"lemma chainI: "(!!i. Y i \<sqsubseteq> Y (Suc i)) ==> chain Y"  unfolding chain_def by fastlemma chainE: "chain Y ==> Y i \<sqsubseteq> Y (Suc i)"  unfolding chain_def by fasttext {* chains are monotone functions *}lemma chain_mono_less: "[|chain Y; i < j|] ==> Y i \<sqsubseteq> Y j"  by (erule less_Suc_induct, erule chainE, erule below_trans)lemma chain_mono: "[|chain Y; i ≤ j|] ==> Y i \<sqsubseteq> Y j"  by (cases "i = j", simp, simp 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 \<sqsubseteq> 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 (rule le_add1)apply (erule ub_rangeD)apply (rule ub_rangeI)apply (erule ub_rangeD)donelemma 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]: "(\<Squnion>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 fastlemma max_in_chainD: "[|max_in_chain i Y; i ≤ j|] ==> Y i = Y j"  unfolding max_in_chain_def by fastlemma finite_chainI:  "[|chain C; max_in_chain i C|] ==> finite_chain C"  unfolding finite_chain_def by fastlemma finite_chainE:  "[|finite_chain C; !!i. [|chain C; max_in_chain i C|] ==> R|] ==> R"  unfolding finite_chain_def by fastlemma 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)donelemma 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)donelemma 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 simpdonelemma 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)" .qedlemma finite_range_imp_finch:  "[|chain Y; finite (range Y)|] ==> finite_chain Y" apply (subgoal_tac "∃k. ∀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 assumptiondonelemma bin_chain: "x \<sqsubseteq> y ==> chain (λi. if i=0 then x else y)"  by (rule chainI, simp)lemma bin_chainmax:  "x \<sqsubseteq> y ==> max_in_chain (Suc 0) (λi. if i=0 then x else y)"  unfolding max_in_chain_def by simplemma is_lub_bin_chain:  "x \<sqsubseteq> 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 simpdonetext {* the maximal element in a chain is its lub *}lemma lub_chain_maxelem: "[|Y i = c; ∀i. Y i \<sqsubseteq> c|] ==> lub (range Y) = c"  by (blast dest: ub_rangeD intro: lub_eqI is_lubI ub_rangeI)endend`