(* Title: HOLCF/Porder.thy ID: $Id: Porder.thy,v 1.38 2007/10/21 12:21:49 wenzelm Exp $ Author: Franz Regensburger *) header {* Partial orders *} theory Porder imports Datatype Finite_Set begin subsection {* Type class for partial orders *} class sq_ord = type + fixes sq_le :: "'a => 'a => bool" notation sq_le (infixl "<<" 55) notation (xsymbols) sq_le (infixl "\<sqsubseteq>" 55) axclass po < sq_ord refl_less [iff]: "x \<sqsubseteq> x" antisym_less: "[|x \<sqsubseteq> y; y \<sqsubseteq> x|] ==> x = y" trans_less: "[|x \<sqsubseteq> y; y \<sqsubseteq> z|] ==> x \<sqsubseteq> z" text {* minimal fixes least element *} lemma minimal2UU[OF allI] : "∀x::'a::po. uu \<sqsubseteq> x ==> uu = (THE u. ∀y. u \<sqsubseteq> y)" by (blast intro: theI2 antisym_less) text {* the reverse law of anti-symmetry of @{term "op <<"} *} lemma antisym_less_inverse: "(x::'a::po) = y ==> x \<sqsubseteq> y ∧ y \<sqsubseteq> x" by simp lemma box_less: "[|(a::'a::po) \<sqsubseteq> b; c \<sqsubseteq> a; b \<sqsubseteq> d|] ==> c \<sqsubseteq> d" by (rule trans_less [OF trans_less]) lemma po_eq_conv: "((x::'a::po) = y) = (x \<sqsubseteq> y ∧ y \<sqsubseteq> x)" by (fast elim!: antisym_less_inverse intro!: antisym_less) lemma rev_trans_less: "[|(y::'a::po) \<sqsubseteq> z; x \<sqsubseteq> y|] ==> x \<sqsubseteq> z" by (rule trans_less) lemma sq_ord_less_eq_trans: "[|a \<sqsubseteq> b; b = c|] ==> a \<sqsubseteq> c" by (rule subst) lemma sq_ord_eq_less_trans: "[|a = b; b \<sqsubseteq> c|] ==> a \<sqsubseteq> c" by (rule ssubst) lemmas HOLCF_trans_rules [trans] = trans_less antisym_less sq_ord_less_eq_trans sq_ord_eq_less_trans subsection {* Chains and least upper bounds *} text {* class definitions *} definition is_ub :: "['a set, 'a::po] => bool" (infixl "<|" 55) where "(S <| x) = (∀y. y ∈ S --> y \<sqsubseteq> x)" definition is_lub :: "['a set, 'a::po] => bool" (infixl "<<|" 55) where "(S <<| x) = (S <| x ∧ (∀u. S <| u --> x \<sqsubseteq> u))" definition -- {* Arbitrary chains are total orders *} tord :: "'a::po set => bool" where "tord S = (∀x y. x ∈ S ∧ y ∈ S --> (x \<sqsubseteq> y ∨ y \<sqsubseteq> x))" definition -- {* Here we use countable chains and I prefer to code them as functions! *} chain :: "(nat => 'a::po) => bool" where "chain F = (∀i. F i \<sqsubseteq> F (Suc i))" definition -- {* finite chains, needed for monotony of continuous functions *} max_in_chain :: "[nat, nat => 'a::po] => bool" where "max_in_chain i C = (∀j. i ≤ j --> C i = C j)" definition finite_chain :: "(nat => 'a::po) => bool" where "finite_chain C = (chain C ∧ (∃i. max_in_chain i C))" definition lub :: "'a set => 'a::po" where "lub S = (THE x. S <<| x)" abbreviation Lub (binder "LUB " 10) where "LUB n. t n == lub (range t)" notation (xsymbols) Lub (binder "\<Squnion> " 10) text {* lubs are unique *} lemma unique_lub: "[|S <<| x; S <<| y|] ==> x = y" apply (unfold is_lub_def is_ub_def) apply (blast intro: antisym_less) done text {* chains are monotone functions *} lemma chain_mono [rule_format]: "chain F ==> x < y --> F x \<sqsubseteq> F y" apply (unfold chain_def) apply (induct_tac y) apply simp apply (blast elim: less_SucE intro: trans_less) done lemma chain_mono3: "[|chain F; x ≤ y|] ==> F x \<sqsubseteq> F y" apply (drule le_imp_less_or_eq) apply (blast intro: chain_mono) done text {* The range of a chain is a totally ordered *} lemma chain_tord: "chain F ==> tord (range F)" apply (unfold tord_def, clarify) apply (rule nat_less_cases) apply (fast intro: chain_mono)+ done text {* technical lemmas about @{term lub} and @{term is_lub} *} lemma lubI: "M <<| x ==> M <<| lub M" apply (unfold lub_def) apply (rule theI) apply assumption apply (erule (1) unique_lub) done lemma thelubI: "M <<| l ==> lub M = l" by (rule unique_lub [OF lubI]) lemma lub_singleton [simp]: "lub {x} = x" by (simp add: thelubI is_lub_def is_ub_def) text {* access to some definition as inference rule *} lemma is_lubD1: "S <<| x ==> S <| x" by (unfold is_lub_def, simp) lemma is_lub_lub: "[|S <<| x; S <| u|] ==> x \<sqsubseteq> u" by (unfold is_lub_def, simp) lemma is_lubI: "[|S <| x; !!u. S <| u ==> x \<sqsubseteq> u|] ==> S <<| x" by (unfold is_lub_def, fast) lemma chainE: "chain F ==> F i \<sqsubseteq> F (Suc i)" by (unfold chain_def, simp) lemma chainI: "(!!i. F i \<sqsubseteq> F (Suc i)) ==> chain F" by (unfold chain_def, simp) lemma chain_shift: "chain Y ==> chain (λi. Y (i + j))" apply (rule chainI) apply simp apply (erule chainE) done text {* technical lemmas about (least) upper bounds of chains *} lemma ub_rangeD: "range S <| x ==> S i \<sqsubseteq> x" by (unfold is_ub_def, simp) lemma ub_rangeI: "(!!i. S i \<sqsubseteq> x) ==> range S <| x" by (unfold is_ub_def, fast) lemma is_ub_lub: "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 trans_less) apply (erule chain_mono3) apply (rule le_add1) 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 {* results about finite chains *} lemma lub_finch1: "[|chain C; max_in_chain i C|] ==> range C <<| C i" apply (unfold max_in_chain_def) apply (rule is_lubI) apply (rule ub_rangeI, rename_tac j) apply (rule_tac x=i and y=j in linorder_le_cases) apply simp apply (erule (1) chain_mono3) apply (erule ub_rangeD) done lemma lub_finch2: "finite_chain C ==> range C <<| C (LEAST i. max_in_chain i C)" apply (unfold finite_chain_def) apply (erule conjE) apply (erule LeastI2_ex) apply (erule (1) lub_finch1) done lemma finch_imp_finite_range: "finite_chain Y ==> finite (range Y)" apply (unfold finite_chain_def, clarify) apply (rule_tac f="Y" and n="Suc i" in nat_seg_image_imp_finite) apply (rule equalityI) 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 fast done lemma finite_tord_has_max [rule_format]: "finite S ==> S ≠ {} --> tord S --> (∃y∈S. ∀x∈S. x \<sqsubseteq> y)" apply (erule finite_induct, simp) apply (rename_tac a S, clarify) apply (case_tac "S = {}", simp) apply (drule (1) mp) apply (drule mp, simp add: tord_def) apply (erule bexE, rename_tac z) apply (subgoal_tac "a \<sqsubseteq> z ∨ z \<sqsubseteq> a") apply (erule disjE) apply (rule_tac x="z" in bexI, simp, simp) apply (rule_tac x="a" in bexI) apply (clarsimp elim!: rev_trans_less) apply simp apply (simp add: tord_def) done lemma finite_range_imp_finch: "[|chain Y; finite (range Y)|] ==> finite_chain Y" apply (subgoal_tac "∃y∈range Y. ∀x∈range Y. x \<sqsubseteq> y") apply (clarsimp, rename_tac i) apply (subgoal_tac "max_in_chain i Y") apply (simp add: finite_chain_def exI) apply (simp add: max_in_chain_def po_eq_conv chain_mono3) apply (erule finite_tord_has_max, simp) apply (erule chain_tord) done lemma 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)" by (unfold max_in_chain_def, simp) lemma 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 simp done text {* 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: thelubI is_lubI ub_rangeI) text {* the lub of a constant chain is the constant *} lemma chain_const [simp]: "chain (λi. c)" by (simp add: chainI) lemma lub_const: "range (λx. c) <<| c" by (blast dest: ub_rangeD intro: is_lubI ub_rangeI) lemma thelub_const [simp]: "(\<Squnion>i. c) = c" by (rule lub_const [THEN thelubI]) end
lemma minimal2UU:
(!!x. uu << x) ==> uu = (THE u. ∀y. u << y)
lemma antisym_less_inverse:
x = y ==> x << y ∧ y << x
lemma box_less:
[| a << b; c << a; b << d |] ==> c << d
lemma po_eq_conv:
(x = y) = (x << y ∧ y << x)
lemma rev_trans_less:
[| y << z; x << y |] ==> x << z
lemma sq_ord_less_eq_trans:
[| a << b; b = c |] ==> a << c
lemma sq_ord_eq_less_trans:
[| a = b; b << c |] ==> a << c
lemma HOLCF_trans_rules:
[| x << y; y << z |] ==> x << z
[| x << y; y << x |] ==> x = y
[| a << b; b = c |] ==> a << c
[| a = b; b << c |] ==> a << c
lemma unique_lub:
[| S <<| x; S <<| y |] ==> x = y
lemma chain_mono:
[| chain F; x < y |] ==> F x << F y
lemma chain_mono3:
[| chain F; x ≤ y |] ==> F x << F y
lemma chain_tord:
chain F ==> tord (range F)
lemma lubI:
M <<| x ==> M <<| lub M
lemma thelubI:
M <<| l ==> lub M = l
lemma lub_singleton:
lub {x} = x
lemma is_lubD1:
S <<| x ==> S <| x
lemma is_lub_lub:
[| S <<| x; S <| u |] ==> x << u
lemma is_lubI:
[| S <| x; !!u. S <| u ==> x << u |] ==> S <<| x
lemma chainE:
chain F ==> F i << F (Suc i)
lemma chainI:
(!!i. F i << F (Suc i)) ==> chain F
lemma chain_shift:
chain Y ==> chain (λi. Y (i + j))
lemma ub_rangeD:
range S <| x ==> S i << x
lemma ub_rangeI:
(!!i. S i << x) ==> range S <| x
lemma is_ub_lub:
range S <<| x ==> S i << x
lemma is_ub_range_shift:
chain S ==> range (λi. S (i + j)) <| x = range S <| x
lemma is_lub_range_shift:
chain S ==> range (λi. S (i + j)) <<| x = range S <<| x
lemma lub_finch1:
[| chain C; max_in_chain i C |] ==> range C <<| C i
lemma lub_finch2:
finite_chain C ==> range C <<| C (LEAST i. max_in_chain i C)
lemma finch_imp_finite_range:
finite_chain Y ==> finite (range Y)
lemma finite_tord_has_max:
[| finite S; S ≠ {}; tord S |] ==> ∃y∈S. ∀x∈S. x << y
lemma finite_range_imp_finch:
[| chain Y; finite (range Y) |] ==> finite_chain Y
lemma bin_chain:
x << y ==> chain (λi. if i = 0 then x else y)
lemma bin_chainmax:
x << y ==> max_in_chain (Suc 0) (λi. if i = 0 then x else y)
lemma lub_bin_chain:
x << y ==> range (λi. if i = 0 then x else y) <<| y
lemma lub_chain_maxelem:
[| Y i = c; ∀i. Y i << c |] ==> Lub Y = c
lemma chain_const:
chain (λi. c)
lemma lub_const:
range (λx. c) <<| c
lemma thelub_const:
(LUB i. c) = c