Theory Lift

Up to index of Isabelle/HOLCF

theory Lift
imports Discrete Up Countable

(*  Title:      HOLCF/Lift.thy
Author: Olaf Mueller
*)


header {* Lifting types of class type to flat pcpo's *}

theory Lift
imports Discrete Up Countable
begin


default_sort type

pcpodef 'a lift = "UNIV :: 'a discr u set"
by simp_all

instance lift :: (finite) finite_po
by (rule typedef_finite_po [OF type_definition_lift])

lemmas inst_lift_pcpo = Abs_lift_strict [symmetric]

definition
Def :: "'a => 'a lift" where
"Def x = Abs_lift (up·(Discr x))"


subsection {* Lift as a datatype *}

lemma lift_induct: "[|P ⊥; !!x. P (Def x)|] ==> P y"
apply (induct y)
apply (rule_tac p=y in upE)
apply (simp add: Abs_lift_strict)
apply (case_tac x)
apply (simp add: Def_def)
done

rep_datatype "⊥::'a lift" Def
by (erule lift_induct) (simp_all add: Def_def Abs_lift_inject lift_def inst_lift_pcpo)

lemmas lift_distinct1 = lift.distinct(1)
lemmas lift_distinct2 = lift.distinct(2)
lemmas Def_not_UU = lift.distinct(2)
lemmas Def_inject = lift.inject


text {* @{term UU} and @{term Def} *}

lemma Lift_exhaust: "x = ⊥ ∨ (∃y. x = Def y)"
by (induct x) simp_all

lemma Lift_cases: "[|x = ⊥ ==> P; ∃a. x = Def a ==> P|] ==> P"
by (insert Lift_exhaust) blast

lemma not_Undef_is_Def: "(x ≠ ⊥) = (∃y. x = Def y)"
by (cases x) simp_all

lemma lift_definedE: "[|x ≠ ⊥; !!a. x = Def a ==> R|] ==> R"
by (cases x) simp_all

text {*
For @{term "x ~= UU"} in assumptions @{text defined} replaces @{text
x} by @{text "Def a"} in conclusion. *}


method_setup defined = {*
Scan.succeed (fn ctxt => SIMPLE_METHOD'
(etac @{thm lift_definedE} THEN' asm_simp_tac (simpset_of ctxt)))
*}
""


lemma DefE: "Def x = ⊥ ==> R"
by simp

lemma DefE2: "[|x = Def s; x = ⊥|] ==> R"
by simp

lemma Def_below_Def: "Def x \<sqsubseteq> Def y <-> x = y"
by (simp add: below_lift_def Def_def Abs_lift_inverse lift_def)

lemma Def_below_iff [simp]: "Def x \<sqsubseteq> y <-> Def x = y"
by (induct y, simp, simp add: Def_below_Def)


subsection {* Lift is flat *}

instance lift :: (type) flat
proof
fix x y :: "'a lift"
assume "x \<sqsubseteq> y" thus "x = ⊥ ∨ x = y"
by (induct x) auto
qed

text {*
\medskip Two specific lemmas for the combination of LCF and HOL
terms.
*}


lemma cont_Rep_CFun_app [simp]: "[|cont g; cont f|] ==> cont(λx. ((f x)·(g x)) s)"
by (rule cont2cont_Rep_CFun [THEN cont2cont_fun])

lemma cont_Rep_CFun_app_app [simp]: "[|cont g; cont f|] ==> cont(λx. ((f x)·(g x)) s t)"
by (rule cont_Rep_CFun_app [THEN cont2cont_fun])

subsection {* Further operations *}

definition
flift1 :: "('a => 'b::pcpo) => ('a lift -> 'b)" (binder "FLIFT " 10) where
"flift1 = (λf. (Λ x. lift_case ⊥ f x))"


definition
flift2 :: "('a => 'b) => ('a lift -> 'b lift)" where
"flift2 f = (FLIFT x. Def (f x))"


subsection {* Continuity Proofs for flift1, flift2 *}

text {* Need the instance of @{text flat}. *}

lemma cont_lift_case1: "cont (λf. lift_case a f x)"
apply (induct x)
apply simp
apply simp
apply (rule cont_id [THEN cont2cont_fun])
done

lemma cont_lift_case2: "cont (λx. lift_case ⊥ f x)"
apply (rule flatdom_strict2cont)
apply simp
done

lemma cont_flift1: "cont flift1"
unfolding flift1_def
apply (rule cont2cont_LAM)
apply (rule cont_lift_case2)
apply (rule cont_lift_case1)
done

lemma FLIFT_mono:
"(!!x. f x \<sqsubseteq> g x) ==> (FLIFT x. f x) \<sqsubseteq> (FLIFT x. g x)"

apply (rule monofunE [where f=flift1])
apply (rule cont2mono [OF cont_flift1])
apply (simp add: below_fun_ext)
done

lemma cont2cont_flift1 [simp, cont2cont]:
"[|!!y. cont (λx. f x y)|] ==> cont (λx. FLIFT y. f x y)"

apply (rule cont_flift1 [THEN cont2cont_app3])
apply simp
done

lemma cont2cont_lift_case [simp]:
"[|!!y. cont (λx. f x y); cont g|] ==> cont (λx. lift_case UU (f x) (g x))"

apply (subgoal_tac "cont (λx. (FLIFT y. f x y)·(g x))")
apply (simp add: flift1_def cont_lift_case2)
apply simp
done

text {* rewrites for @{term flift1}, @{term flift2} *}

lemma flift1_Def [simp]: "flift1 f·(Def x) = (f x)"
by (simp add: flift1_def cont_lift_case2)

lemma flift2_Def [simp]: "flift2 f·(Def x) = Def (f x)"
by (simp add: flift2_def)

lemma flift1_strict [simp]: "flift1 f·⊥ = ⊥"
by (simp add: flift1_def cont_lift_case2)

lemma flift2_strict [simp]: "flift2 f·⊥ = ⊥"
by (simp add: flift2_def)

lemma flift2_defined [simp]: "x ≠ ⊥ ==> (flift2 f)·x ≠ ⊥"
by (erule lift_definedE, simp)

lemma flift2_defined_iff [simp]: "(flift2 f·x = ⊥) = (x = ⊥)"
by (cases x, simp_all)


subsection {* Lifted countable types are bifinite *}

instantiation lift :: (countable) bifinite
begin


definition
approx_lift_def:
"approx = (λn. FLIFT x. if to_nat x < n then Def x else ⊥)"


instance proof
fix x :: "'a lift"
show "chain (approx :: nat => 'a lift -> 'a lift)"
unfolding approx_lift_def
by (rule chainI, simp add: FLIFT_mono)
next
fix x :: "'a lift"
show "(\<Squnion>i. approx i·x) = x"
unfolding approx_lift_def
apply (cases x, simp)
apply (rule thelubI)
apply (rule is_lubI)
apply (rule ub_rangeI, simp)
apply (drule ub_rangeD)
apply (erule rev_below_trans)
apply simp
apply (rule lessI)
done
next
fix i :: nat and x :: "'a lift"
show "approx i·(approx i·x) = approx i·x"
unfolding approx_lift_def
by (cases x, simp, simp)
next
fix i :: nat
show "finite {x::'a lift. approx i·x = x}"
proof (rule finite_subset)
let ?S = "insert (⊥::'a lift) (Def ` to_nat -` {..<i})"
show "{x::'a lift. approx i·x = x} ⊆ ?S"
unfolding approx_lift_def
by (rule subsetI, case_tac x, simp, simp split: split_if_asm)
show "finite ?S"
by (simp add: finite_vimageI)
qed
qed

end

end