(* Title: HOLCF/Up.thy ID: $Id: Up.thy,v 1.32 2008/05/19 21:49:22 huffman Exp $ Author: Franz Regensburger and Brian Huffman Lifting. *) header {* The type of lifted values *} theory Up imports Bifinite begin defaultsort cpo subsection {* Definition of new type for lifting *} datatype 'a u = Ibottom | Iup 'a syntax (xsymbols) "u" :: "type => type" ("(_⊥)" [1000] 999) consts Ifup :: "('a -> 'b::pcpo) => 'a u => 'b" primrec "Ifup f Ibottom = ⊥" "Ifup f (Iup x) = f·x" subsection {* Ordering on lifted cpo *} instantiation u :: (cpo) sq_ord begin definition less_up_def: "(op \<sqsubseteq>) ≡ (λx y. case x of Ibottom => True | Iup a => (case y of Ibottom => False | Iup b => a \<sqsubseteq> b))" instance .. end lemma minimal_up [iff]: "Ibottom \<sqsubseteq> z" by (simp add: less_up_def) lemma not_Iup_less [iff]: "¬ Iup x \<sqsubseteq> Ibottom" by (simp add: less_up_def) lemma Iup_less [iff]: "(Iup x \<sqsubseteq> Iup y) = (x \<sqsubseteq> y)" by (simp add: less_up_def) subsection {* Lifted cpo is a partial order *} instance u :: (cpo) po proof fix x :: "'a u" show "x \<sqsubseteq> x" unfolding less_up_def by (simp split: u.split) next fix x y :: "'a u" assume "x \<sqsubseteq> y" "y \<sqsubseteq> x" thus "x = y" unfolding less_up_def by (auto split: u.split_asm intro: antisym_less) next fix x y z :: "'a u" assume "x \<sqsubseteq> y" "y \<sqsubseteq> z" thus "x \<sqsubseteq> z" unfolding less_up_def by (auto split: u.split_asm intro: trans_less) qed lemma u_UNIV: "UNIV = insert Ibottom (range Iup)" by (auto, case_tac x, auto) instance u :: (finite_po) finite_po by (intro_classes, simp add: u_UNIV) subsection {* Lifted cpo is a cpo *} lemma is_lub_Iup: "range S <<| x ==> range (λi. Iup (S i)) <<| Iup x" apply (rule is_lubI) apply (rule ub_rangeI) apply (subst Iup_less) apply (erule is_ub_lub) apply (case_tac u) apply (drule ub_rangeD) apply simp apply simp apply (erule is_lub_lub) apply (rule ub_rangeI) apply (drule_tac i=i in ub_rangeD) apply simp done lemma is_lub_Iup': "[|directed S; S <<| x|] ==> (Iup ` S) <<| Iup x" apply (rule is_lubI) apply (rule ub_imageI) apply (subst Iup_less) apply (erule (1) is_ubD [OF is_lubD1]) apply (case_tac u) apply (drule directedD1, erule exE) apply (drule (1) ub_imageD) apply simp apply simp apply (erule is_lub_lub) apply (rule is_ubI) apply (drule (1) ub_imageD) apply simp done text {* Now some lemmas about chains of @{typ "'a u"} elements *} lemma up_lemma1: "z ≠ Ibottom ==> Iup (THE a. Iup a = z) = z" by (case_tac z, simp_all) lemma up_lemma2: "[|chain Y; Y j ≠ Ibottom|] ==> Y (i + j) ≠ Ibottom" apply (erule contrapos_nn) apply (drule_tac i="j" and j="i + j" in chain_mono) apply (rule le_add2) apply (case_tac "Y j") apply assumption apply simp done lemma up_lemma3: "[|chain Y; Y j ≠ Ibottom|] ==> Iup (THE a. Iup a = Y (i + j)) = Y (i + j)" by (rule up_lemma1 [OF up_lemma2]) lemma up_lemma4: "[|chain Y; Y j ≠ Ibottom|] ==> chain (λi. THE a. Iup a = Y (i + j))" apply (rule chainI) apply (rule Iup_less [THEN iffD1]) apply (subst up_lemma3, assumption+)+ apply (simp add: chainE) done lemma up_lemma5: "[|chain Y; Y j ≠ Ibottom|] ==> (λi. Y (i + j)) = (λi. Iup (THE a. Iup a = Y (i + j)))" by (rule ext, rule up_lemma3 [symmetric]) lemma up_lemma6: "[|chain Y; Y j ≠ Ibottom|] ==> range Y <<| Iup (\<Squnion>i. THE a. Iup a = Y(i + j))" apply (rule_tac j1 = j in is_lub_range_shift [THEN iffD1]) apply assumption apply (subst up_lemma5, assumption+) apply (rule is_lub_Iup) apply (rule cpo_lubI) apply (erule (1) up_lemma4) done lemma up_chain_lemma: "chain Y ==> (∃A. chain A ∧ lub (range Y) = Iup (lub (range A)) ∧ (∃j. ∀i. Y (i + j) = Iup (A i))) ∨ (Y = (λi. Ibottom))" apply (rule disjCI) apply (simp add: expand_fun_eq) apply (erule exE, rename_tac j) apply (rule_tac x="λi. THE a. Iup a = Y (i + j)" in exI) apply (simp add: up_lemma4) apply (simp add: up_lemma6 [THEN thelubI]) apply (rule_tac x=j in exI) apply (simp add: up_lemma3) done lemma cpo_up: "chain (Y::nat => 'a u) ==> ∃x. range Y <<| x" apply (frule up_chain_lemma, safe) apply (rule_tac x="Iup (lub (range A))" in exI) apply (erule_tac j="j" in is_lub_range_shift [THEN iffD1, standard]) apply (simp add: is_lub_Iup cpo_lubI) apply (rule exI, rule lub_const) done instance u :: (cpo) cpo by intro_classes (rule cpo_up) subsection {* Lifted cpo is pointed *} lemma least_up: "∃x::'a u. ∀y. x \<sqsubseteq> y" apply (rule_tac x = "Ibottom" in exI) apply (rule minimal_up [THEN allI]) done instance u :: (cpo) pcpo by intro_classes (rule least_up) text {* for compatibility with old HOLCF-Version *} lemma inst_up_pcpo: "⊥ = Ibottom" by (rule minimal_up [THEN UU_I, symmetric]) subsection {* Continuity of @{term Iup} and @{term Ifup} *} text {* continuity for @{term Iup} *} lemma cont_Iup: "cont Iup" apply (rule contI) apply (rule is_lub_Iup) apply (erule cpo_lubI) done text {* continuity for @{term Ifup} *} lemma cont_Ifup1: "cont (λf. Ifup f x)" by (induct x, simp_all) lemma monofun_Ifup2: "monofun (λx. Ifup f x)" apply (rule monofunI) apply (case_tac x, simp) apply (case_tac y, simp) apply (simp add: monofun_cfun_arg) done lemma cont_Ifup2: "cont (λx. Ifup f x)" apply (rule contI) apply (frule up_chain_lemma, safe) apply (rule_tac j="j" in is_lub_range_shift [THEN iffD1, standard]) apply (erule monofun_Ifup2 [THEN ch2ch_monofun]) apply (simp add: cont_cfun_arg) apply (simp add: lub_const) done subsection {* Continuous versions of constants *} definition up :: "'a -> 'a u" where "up = (Λ x. Iup x)" definition fup :: "('a -> 'b::pcpo) -> 'a u -> 'b" where "fup = (Λ f p. Ifup f p)" translations "case l of XCONST up·x => t" == "CONST fup·(Λ x. t)·l" "Λ(XCONST up·x). t" == "CONST fup·(Λ x. t)" text {* continuous versions of lemmas for @{typ "('a)u"} *} lemma Exh_Up: "z = ⊥ ∨ (∃x. z = up·x)" apply (induct z) apply (simp add: inst_up_pcpo) apply (simp add: up_def cont_Iup) done lemma up_eq [simp]: "(up·x = up·y) = (x = y)" by (simp add: up_def cont_Iup) lemma up_inject: "up·x = up·y ==> x = y" by simp lemma up_defined [simp]: "up·x ≠ ⊥" by (simp add: up_def cont_Iup inst_up_pcpo) lemma not_up_less_UU: "¬ up·x \<sqsubseteq> ⊥" by simp lemma up_less [simp]: "(up·x \<sqsubseteq> up·y) = (x \<sqsubseteq> y)" by (simp add: up_def cont_Iup) lemma upE [cases type: u]: "[|p = ⊥ ==> Q; !!x. p = up·x ==> Q|] ==> Q" apply (cases p) apply (simp add: inst_up_pcpo) apply (simp add: up_def cont_Iup) done lemma up_induct [induct type: u]: "[|P ⊥; !!x. P (up·x)|] ==> P x" by (cases x, simp_all) text {* lifting preserves chain-finiteness *} lemma up_chain_cases: "chain Y ==> (∃A. chain A ∧ (\<Squnion>i. Y i) = up·(\<Squnion>i. A i) ∧ (∃j. ∀i. Y (i + j) = up·(A i))) ∨ Y = (λi. ⊥)" by (simp add: inst_up_pcpo up_def cont_Iup up_chain_lemma) lemma compact_up: "compact x ==> compact (up·x)" apply (rule compactI2) apply (drule up_chain_cases, safe) apply (drule (1) compactD2, simp) apply (erule exE, rule_tac x="i + j" in exI) apply simp apply simp done lemma compact_upD: "compact (up·x) ==> compact x" unfolding compact_def by (drule adm_subst [OF cont_Rep_CFun2 [where f=up]], simp) lemma compact_up_iff [simp]: "compact (up·x) = compact x" by (safe elim!: compact_up compact_upD) instance u :: (chfin) chfin apply intro_classes apply (erule compact_imp_max_in_chain) apply (rule_tac p="\<Squnion>i. Y i" in upE, simp_all) done text {* properties of fup *} lemma fup1 [simp]: "fup·f·⊥ = ⊥" by (simp add: fup_def cont_Ifup1 cont_Ifup2 inst_up_pcpo) lemma fup2 [simp]: "fup·f·(up·x) = f·x" by (simp add: up_def fup_def cont_Iup cont_Ifup1 cont_Ifup2) lemma fup3 [simp]: "fup·up·x = x" by (cases x, simp_all) subsection {* Lifted cpo is a bifinite domain *} instantiation u :: (profinite) bifinite begin definition approx_up_def: "approx = (λn. fup·(Λ x. up·(approx n·x)))" instance proof fix i :: nat and x :: "'a u" show "chain (λi. approx i·x)" unfolding approx_up_def by simp show "(\<Squnion>i. approx i·x) = x" unfolding approx_up_def by (simp add: lub_distribs eta_cfun) show "approx i·(approx i·x) = approx i·x" unfolding approx_up_def by (induct x, simp, simp) have "{x::'a u. approx i·x = x} ⊆ insert ⊥ ((λx. up·x) ` {x::'a. approx i·x = x})" unfolding approx_up_def by (rule subsetI, rule_tac p=x in upE, simp_all) thus "finite {x::'a u. approx i·x = x}" by (rule finite_subset, simp add: finite_fixes_approx) qed end lemma approx_up [simp]: "approx i·(up·x) = up·(approx i·x)" unfolding approx_up_def by simp end
lemma minimal_up:
Ibottom << z
lemma not_Iup_less:
¬ Iup x << Ibottom
lemma Iup_less:
Iup x << Iup y = x << y
lemma u_UNIV:
UNIV = insert Ibottom (range Iup)
lemma is_lub_Iup:
range S <<| x ==> range (λi. Iup (S i)) <<| Iup x
lemma is_lub_Iup':
[| directed S; S <<| x |] ==> Iup ` S <<| Iup x
lemma up_lemma1:
z ≠ Ibottom ==> Iup (THE a. Iup a = z) = z
lemma up_lemma2:
[| chain Y; Y j ≠ Ibottom |] ==> Y (i + j) ≠ Ibottom
lemma up_lemma3:
[| chain Y; Y j ≠ Ibottom |] ==> Iup (THE a. Iup a = Y (i + j)) = Y (i + j)
lemma up_lemma4:
[| chain Y; Y j ≠ Ibottom |] ==> chain (λi. THE a. Iup a = Y (i + j))
lemma up_lemma5:
[| chain Y; Y j ≠ Ibottom |]
==> (λi. Y (i + j)) = (λi. Iup (THE a. Iup a = Y (i + j)))
lemma up_lemma6:
[| chain Y; Y j ≠ Ibottom |]
==> range Y <<| Iup (LUB i. THE a. Iup a = Y (i + j))
lemma up_chain_lemma:
chain Y
==> (∃A. chain A ∧ Lub Y = Iup (Lub A) ∧ (∃j. ∀i. Y (i + j) = Iup (A i))) ∨
Y = (λi. Ibottom)
lemma cpo_up:
chain Y ==> ∃x. range Y <<| x
lemma least_up:
∃x. ∀y. x << y
lemma inst_up_pcpo:
UU = Ibottom
lemma cont_Iup:
cont Iup
lemma cont_Ifup1:
cont (λf. Ifup f x)
lemma monofun_Ifup2:
monofun (Ifup f)
lemma cont_Ifup2:
cont (Ifup f)
lemma Exh_Up:
z = UU ∨ (∃x. z = up·x)
lemma up_eq:
(up·x = up·y) = (x = y)
lemma up_inject:
up·x = up·y ==> x = y
lemma up_defined:
up·x ≠ UU
lemma not_up_less_UU:
¬ up·x << UU
lemma up_less:
up·x << up·y = x << y
lemma upE:
[| p = UU ==> Q; !!x. p = up·x ==> Q |] ==> Q
lemma up_induct:
[| P UU; !!x. P (up·x) |] ==> P x
lemma up_chain_cases:
chain Y
==> (∃A. chain A ∧
(LUB i. Y i) = up·(LUB i. A i) ∧ (∃j. ∀i. Y (i + j) = up·(A i))) ∨
Y = (λi. UU)
lemma compact_up:
compact x ==> compact (up·x)
lemma compact_upD:
compact (up·x) ==> compact x
lemma compact_up_iff:
compact (up·x) = compact x
lemma fup1:
fup·f·UU = UU
lemma fup2:
fup·f·(up·x) = f·x
lemma fup3:
fup·up·x = x
lemma approx_up:
approx i·(up·x) = up·(approx i·x)