Theory Lift

Up to index of Isabelle/HOLCF

theory Lift
imports Discrete Up Cprod Countable
begin

(*  Title:      HOLCF/Lift.thy
    ID:         $Id: Lift.thy,v 1.33 2008/05/19 21:50:06 huffman Exp $
    Author:     Olaf Mueller
*)

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

theory Lift
imports Discrete Up Cprod Countable
begin

defaultsort type

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

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_distinct1: "⊥ ≠ Def x"
by (simp add: Def_def Abs_lift_inject lift_def inst_lift_pcpo)

lemma lift_distinct2: "Def x ≠ ⊥"
by (simp add: Def_def Abs_lift_inject lift_def inst_lift_pcpo)

lemma Def_inject: "(Def x = Def y) = (x = y)"
by (simp add: Def_def Abs_lift_inject lift_def)

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 lift
  distinct lift_distinct1 lift_distinct2
  inject Def_inject
  induction lift_induct

lemma Def_not_UU: "Def a ≠ UU"
  by simp


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 def_tac} replaces @{text
  x} by @{text "Def a"} in conclusion. *}

ML {*
  local val lift_definedE = thm "lift_definedE"
  in val def_tac = SIMPSET' (fn ss =>
    etac lift_definedE THEN' asm_simp_tac ss)
  end;
*}

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

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

lemma Def_inject_less_eq: "Def x \<sqsubseteq> Def y = (x = y)"
by (simp add: less_lift_def Def_def Abs_lift_inverse lift_def)

lemma Def_less_is_eq [simp]: "Def x \<sqsubseteq> y = (Def x = y)"
apply (induct y)
apply simp
apply (simp add: Def_inject_less_eq)
done


subsection {* Lift is flat *}

lemma less_lift: "(x::'a lift) \<sqsubseteq> y = (x = y ∨ x = ⊥)"
by (induct x, simp_all)

instance lift :: (type) flat
by (intro_classes, auto simp add: less_lift)

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))"

definition
  liftpair :: "'a lift × 'b lift => ('a × 'b) lift" where
  "liftpair x = csplit·(FLIFT x y. Def (x, y))·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"
apply (unfold flift1_def)
apply (rule cont2cont_LAM)
apply (rule cont_lift_case2)
apply (rule cont_lift_case1)
done

lemma cont2cont_flift1 [simp]:
  "[|!!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)

text {*
  \medskip Extension of @{text cont_tac} and installation of simplifier.
*}

lemmas cont_lemmas_ext =
  cont2cont_flift1 cont2cont_lift_case cont2cont_lambda
  cont_Rep_CFun_app cont_Rep_CFun_app_app cont_if

ML {*
local
  val cont_lemmas2 = thms "cont_lemmas1" @ thms "cont_lemmas_ext";
  val flift1_def = thm "flift1_def";
in

fun cont_tac  i = resolve_tac cont_lemmas2 i;
fun cont_tacR i = REPEAT (cont_tac i);

fun cont_tacRs ss i =
  simp_tac ss i THEN
  REPEAT (cont_tac i)
end;
*}

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 (λi. approx i·x)"
    unfolding approx_lift_def
    by (rule chainI, cases x, simp_all)
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_trans_less)
    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

lemma inst_lift_pcpo:

  UU = Abs_lift UU

Lift as a datatype

lemma lift_distinct1:

  UU  Def x

lemma lift_distinct2:

  Def x  UU

lemma Def_inject:

  (Def x = Def y) = (x = y)

lemma lift_induct:

  [| P UU; !!x. P (Def x) |] ==> P y

lemma Def_not_UU:

  Def a  UU

lemma Lift_exhaust:

  x = UU ∨ (∃y. x = Def y)

lemma Lift_cases:

  [| x = UU ==> P; ∃a. x = Def a ==> P |] ==> P

lemma not_Undef_is_Def:

  (x  UU) = (∃y. x = Def y)

lemma lift_definedE:

  [| x  UU; !!a. x = Def a ==> R |] ==> R

lemma DefE:

  Def x = UU ==> R

lemma DefE2:

  [| x = Def s; x = UU |] ==> R

lemma Def_inject_less_eq:

  Def x << Def y = (x = y)

lemma Def_less_is_eq:

  Def x << y = (Def x = y)

Lift is flat

lemma less_lift:

  x << y = (x = yx = UU)

lemma cont_Rep_CFun_app:

  [| cont g; cont f |] ==> contx. (f x·(g x)) s)

lemma cont_Rep_CFun_app_app:

  [| cont g; cont f |] ==> contx. (f x·(g x)) s t)

Further operations

Continuity Proofs for flift1, flift2

lemma cont_lift_case1:

  contf. lift_case a f x)

lemma cont_lift_case2:

  cont (lift_case UU f)

lemma cont_flift1:

  cont flift1

lemma cont2cont_flift1:

  (!!y. contx. f x y)) ==> contx. FLIFT y. f x y)

lemma cont2cont_lift_case:

  [| !!y. contx. f x y); cont g |] ==> contx. lift_case UU (f x) (g x))

lemma flift1_Def:

  flift1 f·(Def x) = f x

lemma flift2_Def:

  flift2 f·(Def x) = Def (f x)

lemma flift1_strict:

  flift1 f·UU = UU

lemma flift2_strict:

  flift2 f·UU = UU

lemma flift2_defined:

  x  UU ==> flift2 f·x  UU

lemma flift2_defined_iff:

  (flift2 f·x = UU) = (x = UU)

lemma cont_lemmas_ext:

  (!!y. contx. f x y)) ==> contx. FLIFT y. f x y)
  [| !!y. contx. f x y); cont g |] ==> contx. lift_case UU (f x) (g x))
  (!!y. contx. f x y)) ==> cont f
  [| cont g; cont f |] ==> contx. (f x·(g x)) s)
  [| cont g; cont f |] ==> contx. (f x·(g x)) s t)
  [| cont f; cont g |] ==> contx. if b then f x else g x)

Lifted countable types are bifinite