theory Perm
imports Main Rat VHelper Lang
begin

text {* This file contains a soundness proof for CSL with multiple resources
  and permissions. *}

text {* (Adapted to Isabelle 2016-1 by Qin Yu and James Brotherston) *}

subsection {* Permission model *}

text {* Fractional permissions are rational numbers in the range (0,1]. *}

typedef myfrac = "{x::rat. 0 < x \<and> x \<le> 1}"
by (rule_tac x="0.5" in exI, simp)

definition "pfull \<equiv> Abs_myfrac 1"        (*r Full permission *)

type_synonym pheap  = "(nat \<rightharpoonup> nat * myfrac)"       (*r Permission heaps *)
type_synonym pstate = "stack \<times> pheap"               (*r Permission states *)

text {* Definition when two permission heaps are composable. *}

definition
  pdisj :: "pheap \<Rightarrow> pheap \<Rightarrow> bool"
where
  "pdisj h1 h2 \<equiv> (\<forall>x. case h1 x of None \<Rightarrow> True | Some y1 \<Rightarrow>
                      (case h2 x of None \<Rightarrow> True | Some y2 \<Rightarrow>
                       fst y1 = fst y2 \<and>
                       Rep_myfrac (snd y1) + Rep_myfrac (snd y2) \<le> 1))"

text {* Composition of two permission heaps. *}

definition
  padd :: "pheap \<Rightarrow> pheap \<Rightarrow> pheap"
where
  "padd h1 h2 \<equiv>
     (\<lambda>x. case h1 x of None \<Rightarrow> h2 x | Some y1 \<Rightarrow>
          (case h2 x of None \<Rightarrow> h1 x | Some y2 \<Rightarrow>
           Some (fst y1, Abs_myfrac (Rep_myfrac (snd y1) + Rep_myfrac (snd y2)))))"

text {* Composition of two permission heaps, better for automation. *}

definition
  mypadd :: "pheap option \<Rightarrow> pheap option \<Rightarrow> pheap option"
  (infixr "\<oplus>" 100)
where
  "xo \<oplus> yo \<equiv> case xo of None \<Rightarrow> None | Some x \<Rightarrow>
             (case yo of None \<Rightarrow> None | Some y \<Rightarrow>
              if pdisj x y then Some (padd x y) else None)"

text {* Full-permission domain of a permission heap *}

definition "fpdom h \<equiv> {x. \<exists>v. h x = Some (v, pfull)}"

text {* Mapping from permission heaps to normal heaps *}

definition
  ptoheap :: "pheap option \<Rightarrow> heap \<Rightarrow> bool"
where
  "ptoheap ho h \<equiv> case ho of None \<Rightarrow> False | Some ha \<Rightarrow>
                  (\<forall>x. case ha x of None \<Rightarrow> h x = None | Some y \<Rightarrow>
                   snd y = pfull \<and> h x = Some (fst y))"

text {* Basic properties of fractions in the range (0,1] *}

lemmas rat_simps =
  add_rat eq_rat one_rat zero_rat mult_rat le_rat minus_rat diff_rat

lemmas frac_simps =
  Rep_myfrac_inverse Rep_myfrac Abs_myfrac_inverse Abs_myfrac_inject

lemma frac_contra[simp]:
  "\<not> (Rep_myfrac pfull + Rep_myfrac b \<le> 1)"
  "\<not> (Rep_myfrac b + Rep_myfrac pfull \<le> 1)"
by (case_tac b, auto simp add: pfull_def frac_simps)+

lemma frac_pos: "0 < Rep_myfrac x"
by (case_tac x, simp add: frac_simps)

lemma frac_pos2[simp]:
  "0 < Rep_myfrac x + Rep_myfrac y"
  "0 < Rep_myfrac x + (Rep_myfrac y + Rep_myfrac z)"
by (case_tac x, (case_tac y)?, (case_tac z)?, simp add: frac_simps)+

text {* Properties of permission-heaps *}

lemma pdisj_empty[simp]:
  "pdisj x Map.empty"
  "pdisj Map.empty x"
by (clarsimp simp add: pdisj_def split: option.splits)+

lemma pdisj_upd: "h x = Some (w, pfull) \<Longrightarrow> pdisj (h(x \<mapsto> (v, pfull))) h' = pdisj h h'"
by (simp add: pdisj_def, rule iff_allI, auto split: option.splits)

lemma pdisj_comm: "pdisj h1 h2 = pdisj h2 h1"
by (fastforce split: option.splits simp add: pdisj_def)

lemma padd_empty[simp]:
  "padd x Map.empty = x"
  "padd Map.empty x = x"
by (rule ext, clarsimp simp add: padd_def split: option.splits)+

lemma padd_comm[simp]: "pdisj x y \<Longrightarrow> padd y x = padd x y"
by (fastforce split: option.splits simp add: padd_def pdisj_def algebra_simps)

lemma pdisj_padd: "\<lbrakk> pdisj y z ; pdisj x (padd y z) \<rbrakk> \<Longrightarrow> (pdisj x y \<and> pdisj x z)"
apply (clarsimp simp add: pdisj_def padd_def all_conj_distrib [symmetric])
apply (drule_tac a=xa in allD)+
apply (auto split: option.splits simp add: algebra_simps frac_simps)
apply (cut_tac x=be in frac_pos, simp)
apply (cut_tac x=bd in frac_pos, simp)
done

lemma pdisjE[elim]:
  "\<lbrakk> pdisj x (padd y z) ; pdisj y z \<rbrakk> \<Longrightarrow> pdisj x y"
  "\<lbrakk> pdisj x (padd y z) ; pdisj y z \<rbrakk> \<Longrightarrow> pdisj x z"
by (drule (1) pdisj_padd, simp)+

lemma pdisj_padd_comm: "\<lbrakk> pdisj y (padd x z); pdisj x z \<rbrakk> \<Longrightarrow> pdisj x (padd y z)"
apply (clarsimp simp add: pdisj_def padd_def all_conj_distrib [symmetric])
apply (drule_tac a=xa in allD)+
apply (auto split: option.splits simp add: algebra_simps frac_simps)
apply (subst Abs_myfrac_inverse, simp add: frac_simps)
apply (cut_tac x=bf in frac_pos, simp)
apply (cut_tac x=bd in frac_pos, simp)
done

lemma pdisj_padd_expand:
  "pdisj x y \<Longrightarrow> pdisj (padd x y) z = (pdisj x (padd y z) \<and> pdisj y z)"
apply (simp add: pdisj_comm, rule iffI)
 apply (frule (1) pdisj_padd_comm)
 apply (drule (1) pdisj_padd, subst padd_comm, simp_all add: pdisj_comm)
apply (clarify, rule pdisj_padd_comm, simp_all add: pdisj_comm)
done

lemma padd_assoc: "\<lbrakk> pdisj x (padd y z) ; pdisj y z \<rbrakk> \<Longrightarrow> padd (padd x y) z = padd x (padd y z)"
apply (clarsimp simp add: pdisj_def padd_def all_conj_distrib [symmetric], rule ext)
apply (drule_tac a=xa in allD)+
apply (auto split: option.splits simp add: algebra_simps frac_simps)
apply (subst Abs_myfrac_inverse, simp_all add: frac_simps)
apply (cut_tac x=be in frac_pos, simp)
done

lemma padd_left_comm: "\<lbrakk> pdisj x (padd y z) ; pdisj y z \<rbrakk> \<Longrightarrow> padd x (padd y z) = padd y (padd x z)"
apply (clarsimp simp add: pdisj_def padd_def all_conj_distrib [symmetric], rule ext)
apply (drule_tac a=xa in allD)+
apply (auto split: option.splits simp add: algebra_simps frac_simps)
apply (subst Abs_myfrac_inverse, simp_all add: frac_simps)
apply (cut_tac x=bf in frac_pos, simp)
done

lemma padd_cancel: "\<lbrakk> padd x y = padd x z ; pdisj x y; pdisj x z \<rbrakk> \<Longrightarrow> y = z"
apply (clarsimp simp add: pdisj_def padd_def all_conj_distrib [symmetric], rule ext)
apply (drule_tac a=xa in allD |drule_tac x=xa in fun_cong)+
apply (auto split: option.splits simp add: algebra_simps frac_simps)
apply (case_tac b, case_tac ba, clarsimp simp add: frac_simps)
apply (case_tac b, case_tac ba, clarsimp simp add: frac_simps)
apply (case_tac b, case_tac ba, clarsimp simp add: frac_simps)
done

lemma dom_padd[simp]: "dom (padd x y) = dom x \<union> dom y"
by (rule set_eqI, simp add: padd_def dom_def split: option.splits)

lemma fpdom_padd[elim]:
  "pdisj h1 h2 \<Longrightarrow> fpdom h1 \<subseteq> fpdom (padd h1 h2)"
  "pdisj h1 h2 \<Longrightarrow> fpdom h2 \<subseteq> fpdom (padd h1 h2)"
apply (auto simp add: fpdom_def pdisj_def padd_def disjoint_def split: option.splits)
apply (drule_tac a=x in allD, fastforce)+
done

lemma pa_empty[simp]:
  "x \<oplus> Some Map.empty = x"
  "Some Map.empty \<oplus> x = x"
by (auto simp add: mypadd_def split: option.splits)

lemma pa_none[simp]:
  "x \<oplus> None = None"
  "None \<oplus> x = None"
by (auto simp add: mypadd_def split: option.splits)

lemma pa_comm: "y \<oplus> x = x \<oplus> y"
by (auto simp add: mypadd_def pdisj_comm split: option.splits)

lemma pa_assoc: "(x \<oplus> y) \<oplus> z = x \<oplus> y \<oplus> z"
apply (auto simp add: mypadd_def padd_assoc pdisj_padd_expand split: option.splits)
apply (erule notE, fast)
done

lemma pa_left_comm: "y \<oplus> x \<oplus> z = x \<oplus> y \<oplus> z"
apply (auto simp add: mypadd_def padd_left_comm split: option.splits)
apply (erule_tac[!] notE, (erule (1) pdisj_padd_comm |erule (1) pdisjE)+)
done

lemma some_padd: "pdisj h1 h2 \<Longrightarrow> Some (padd h1 h2) = Some h1 \<oplus> Some h2"
by (simp add: mypadd_def)

lemmas pa_ac = pa_comm pa_assoc pa_left_comm some_padd

lemma pa_cancel:
  "\<lbrakk> x \<oplus> y = x \<oplus> z;  x \<oplus> y \<noteq> None \<rbrakk> \<Longrightarrow> y = z"
apply (simp add: mypadd_def split: option.splits if_splits)
apply (clarify, erule (2) padd_cancel)
done

lemma ptoD: "\<lbrakk> ptoheap x z; ptoheap y z \<rbrakk> \<Longrightarrow> x = y"
apply (clarsimp simp add: ptoheap_def split: option.splits)
apply (rule ext)
apply ((drule_tac a=xa in allD)+, auto)
apply (case_tac "x2a xa", case_tac "x2 xa", simp_all, fast+)
done

lemma pdisj_search1:
  "ptoheap (Some x \<oplus> Some y) hh             \<Longrightarrow> pdisj x y"
  "ptoheap (Some x \<oplus> Some y \<oplus> z) hh         \<Longrightarrow> pdisj x y"
  "ptoheap (Some x \<oplus> z \<oplus> Some y) hh         \<Longrightarrow> pdisj x y"
  "ptoheap (Some x \<oplus> z \<oplus> Some y \<oplus> w) hh     \<Longrightarrow> pdisj x y"
  "ptoheap (Some x \<oplus> z \<oplus> w \<oplus> Some y) hh     \<Longrightarrow> pdisj x y"
  "ptoheap (Some x \<oplus> z \<oplus> w \<oplus> Some y \<oplus> v) hh \<Longrightarrow> pdisj x y"
  "ptoheap (z \<oplus> Some x \<oplus> Some y) hh         \<Longrightarrow> pdisj x y"
  "ptoheap (z \<oplus> Some x \<oplus> Some y \<oplus> w) hh     \<Longrightarrow> pdisj x y"
  "ptoheap (z \<oplus> Some x \<oplus> w \<oplus> Some y) hh     \<Longrightarrow> pdisj x y"
  "ptoheap (z \<oplus> Some x \<oplus> w \<oplus> Some y \<oplus> v) hh \<Longrightarrow> pdisj x y"
  "ptoheap (z \<oplus> Some x \<oplus> w \<oplus> v \<oplus> Some y) hh \<Longrightarrow> pdisj x y"
  "ptoheap (z \<oplus> w \<oplus> Some x \<oplus> Some y) hh     \<Longrightarrow> pdisj x y"
  "ptoheap (z \<oplus> w \<oplus> Some x \<oplus> Some y \<oplus> v) hh \<Longrightarrow> pdisj x y"
  "ptoheap (z \<oplus> w \<oplus> Some x \<oplus> v \<oplus> Some y) hh \<Longrightarrow> pdisj x y"
apply (simp_all add: ptoheap_def mypadd_def, case_tac[!] "pdisj x y", simp_all)
apply (auto split: option.splits if_split_asm)
apply (erule notE | fast | erule pdisjE [rotated])+
done

lemma pdisj_comm_implies: "pdisj h1 h2 \<Longrightarrow> pdisj h2 h1"
by (fastforce split: option.splits simp add: pdisj_def)

lemmas pdisj_search[elim] =
  pdisj_search1 pdisj_search1[THEN pdisj_comm_implies]

subsection {* Assertions with permissions *}

datatype assn =
    Aemp                                           (*r Empty heap *)
  | Apsto myfrac exp exp                           (*r Singleton heap *)
  | Astar assn assn      (infixl "**" 100)         (*r Separating conjunction *)
  | Awand assn assn                                (*r Separating implication *)
  | Apure bexp                                     (*r Pure assertion *)
  | Aconj assn assn                                (*r Conjunction *)
  | Adisj assn assn                                (*r Disjunction *)
  | Aex "(nat \<Rightarrow> assn)"                            (*r Existential quantification *)

text {* Separating conjunction of a finite list of assertions is
  just a derived assertion. *}

primrec
  Aistar :: "assn list \<Rightarrow> assn"
where
  "Aistar [] = Aemp"
| "Aistar (P # Ps) = Astar P (Aistar Ps)"

primrec
  sat :: "pstate \<Rightarrow> assn \<Rightarrow> bool" (infixl "\<Turnstile>" 60)
where
  "(\<sigma> \<Turnstile> Aemp)      = (snd \<sigma> = empty)"
| "(\<sigma> \<Turnstile> Apsto k E E') = (dom (snd \<sigma>) = { edenot E (fst \<sigma>) } \<and> (snd \<sigma>) (edenot E (fst \<sigma>)) = Some (edenot E' (fst \<sigma>), k))"
| "(\<sigma> \<Turnstile> P ** Q)    = (\<exists>h1 h2. (fst \<sigma>, h1) \<Turnstile> P \<and> (fst \<sigma>, h2) \<Turnstile> Q \<and> snd \<sigma> = padd h1 h2 \<and> pdisj h1 h2)"
| "(\<sigma> \<Turnstile> Awand P Q) = (\<forall>h. disjoint (dom (snd \<sigma>)) (dom h) \<and> (fst \<sigma>, h) \<Turnstile> P \<longrightarrow> (fst \<sigma>, snd \<sigma> ++ h) \<Turnstile> Q)"
| "(\<sigma> \<Turnstile> Apure B)   = bdenot B (fst \<sigma>)"
| "(\<sigma> \<Turnstile> Aconj P Q) = (\<sigma> \<Turnstile> P \<and> \<sigma> \<Turnstile> Q)"
| "(\<sigma> \<Turnstile> Adisj P Q) = (\<sigma> \<Turnstile> P \<or> \<sigma> \<Turnstile> Q)"
| "(\<sigma> \<Turnstile> Aex PP)    = (\<exists>v. \<sigma> \<Turnstile> PP v)"

text {* Shorthand for full permission *}

definition
  Aptsto :: "exp \<Rightarrow> exp \<Rightarrow> assn"  (infixl "\<longmapsto>" 200)
where
  "E \<longmapsto> E' \<equiv> Apsto pfull E E'"

lemma sat_Aptsto[simp]:
  "(\<sigma> \<Turnstile> E \<longmapsto> E') = (dom (snd \<sigma>) = { edenot E (fst \<sigma>) }
                      \<and> (snd \<sigma>) (edenot E (fst \<sigma>)) = Some (edenot E' (fst \<sigma>), pfull))"
by (simp add: Aptsto_def)

definition
  implies :: "assn \<Rightarrow> assn \<Rightarrow> bool" (infixl "\<sqsubseteq>" 60)
where
  "P \<sqsubseteq> Q \<equiv> (\<forall>\<sigma>. \<sigma> \<Turnstile> P \<longrightarrow> \<sigma> \<Turnstile> Q)"

lemma sat_istar_map_expand:
  "\<lbrakk> r \<in> set l \<rbrakk> \<Longrightarrow>
     \<sigma> \<Turnstile> Aistar (map f l)
     \<longleftrightarrow> (\<exists>h1 h2. (fst \<sigma>, h1) \<Turnstile> f r
              \<and> (fst \<sigma>, h2) \<Turnstile> Aistar (map f (remove1 r l))
              \<and> snd \<sigma> = padd h1 h2 \<and> pdisj h1 h2)"
apply (case_tac \<sigma>, rename_tac s h, clarify)
apply (induct l arbitrary: \<sigma>, simp_all, clarsimp, safe)
apply (intro exI conjI, simp+)
 apply (drule pdisj_padd, simp, clarsimp)
apply (rule padd_left_comm, simp_all)
apply (rule pdisj_padd_comm, simp_all)

apply (intro exI conjI, simp+)
apply (drule pdisj_padd, simp, clarsimp)
apply (rule padd_left_comm, simp_all)
apply (rule pdisj_padd_comm, simp_all)
done

subsubsection {* Precision *}

text {* We say that an assertion is precise if for any given heap, there is at
most one subheap that satisfies the formula. (The formal definition below says
that if there are two such subheaps, they must be equal.) *}

definition
  precise :: "assn \<Rightarrow> bool"
where
  "precise P \<equiv> \<forall>h1 h2 h1' h2' s. pdisj h1 h2 \<and> pdisj h1' h2'
                   \<and> padd h1 h2 = padd h1' h2' \<and> (s, h1) \<Turnstile> P \<and> (s, h1') \<Turnstile> P
               \<longrightarrow> h1 = h1'"

text {* A direct consequence of the definition that is more useful in
Isabelle, because unfolding the definition slows down Isabelle's simplifier
dramatically. *}

lemma preciseD:
  "\<lbrakk> precise P; (s, x) \<Turnstile> P; (s, x') \<Turnstile> P; padd x y = padd x' y';
     pdisj x y; pdisj x' y' \<rbrakk> \<Longrightarrow>
    x = x' \<and> y = y'"
unfolding precise_def
by (drule all5_impD, (erule conjI)+, simp_all, drule padd_cancel)

text {* The separating conjunction of precise assertions is precise: *}

lemma precise_istar:
  "\<forall>x \<in> set l. precise x \<Longrightarrow> precise (Aistar l)"
apply (induct l, simp_all (no_asm) add: precise_def)
apply (clarsimp simp add: padd_assoc pdisj_padd_expand)
apply (drule (3) preciseD, simp_all, clarsimp)
apply (drule (3) preciseD, simp_all)
done

subsubsection {* Auxiliary definition for resource environments *}

definition
  envs :: "('a \<Rightarrow> assn) \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> assn"
where
  "envs \<Gamma> l l' \<equiv> Aistar (map \<Gamma> (list_minus l l'))"

lemma sat_envs_expand:
  "\<lbrakk> r \<in> set l; r \<notin> set l'; distinct l \<rbrakk> \<Longrightarrow>
     \<sigma> \<Turnstile> envs \<Gamma> l l'
     \<longleftrightarrow> (\<exists>h1 h2. (fst \<sigma>, h1) \<Turnstile> \<Gamma> r
              \<and> (fst \<sigma>, h2) \<Turnstile> envs \<Gamma> (removeAll r l) l'
              \<and> snd \<sigma> = padd h1 h2 \<and> pdisj h1 h2)"
apply (simp add: envs_def distinct_remove1_removeAll [THEN sym] add: list_minus_remove1)
apply (subst sat_istar_map_expand [where f=\<Gamma> and r=r], simp_all)
done

lemma envs_upd:
  "r \<notin> set l \<Longrightarrow> envs (\<Gamma>(r := R)) l l' = envs \<Gamma> l l'"
  "r \<in> set l' \<Longrightarrow> envs (\<Gamma>(r := R)) l l' = envs \<Gamma> l l'"
by (simp_all add: envs_def)

lemma envs_removeAll_irr:
  "r \<notin> set l \<Longrightarrow> envs \<Gamma> l (removeAll r l') = envs \<Gamma> l l'"
by (simp add: envs_def list_minus_removeAll_irr)

lemma envs_removeAll2:
  "r \<in> set l' \<Longrightarrow> envs \<Gamma> (removeAll r l) (removeAll r l') = envs \<Gamma> l l'"
by (simp add: envs_def list_minus_removeAll2)

lemma envs_app:
  "disjoint (set x) (set z) \<Longrightarrow> envs \<Gamma> (x @ z) (y @ z) = envs \<Gamma> x y"
  "disjoint (set z) (set x) \<Longrightarrow> envs \<Gamma> (z @ x) (z @ y) = envs \<Gamma> x y"
by (simp_all add: envs_def list_minus_appl list_minus_appr)

subsubsection {* Free variables and substitutions *}

primrec
  fvA :: "assn \<Rightarrow> var set"
where
  "fvA (Aemp)      = {}"
| "fvA (Apure B)   = fvB B"
| "fvA (Apsto k e1 e2) = (fvE e1 \<union> fvE e2)"
| "fvA (P ** Q)    = (fvA P \<union> fvA Q)"
| "fvA (Awand P Q) = (fvA P \<union> fvA Q)"
| "fvA (Aconj P Q) = (fvA P \<union> fvA Q)"
| "fvA (Adisj P Q) = (fvA P \<union> fvA Q)"
| "fvA (Aex P)     = (\<Union>x. fvA (P x))"

definition
  fvAs :: "('a \<Rightarrow> assn) \<Rightarrow> var set"
where
  "fvAs \<Gamma> = (\<Union>x. fvA (\<Gamma> x))"

primrec
  subA :: "var \<Rightarrow> exp \<Rightarrow> assn \<Rightarrow> assn"
where
  "subA x E (Aemp)      = Aemp"
| "subA x E (Apure B)   = Apure (subB x E B)"
| "subA x E (Apsto k e1 e2) = (Apsto k (subE x E e1) (subE x E e2))"
| "subA x E (P ** Q)    = (subA x E P ** subA x E Q)"
| "subA x E (Awand P Q) = Awand (subA x E P) (subA x E Q)"
| "subA x E (Aconj P Q) = Aconj (subA x E P) (subA x E Q)"
| "subA x E (Adisj P Q) = Adisj (subA x E P) (subA x E Q)"
| "subA x E (Aex PP)    = Aex (\<lambda>n. subA x E (PP n))"

lemma subAptsto[simp]:
  "subA x E (e1 \<longmapsto> e2) = (subE x E e1 \<longmapsto> subE x E e2)"
by (simp add: Aptsto_def)

lemma subA_assign:
 "(s,h) \<Turnstile> subA x E P \<longleftrightarrow> (s(x := edenot E s), h) \<Turnstile> P"
by (induct P arbitrary: h, simp_all add: subE_assign subB_assign fun_upd_def)

lemma fvA_istar[simp]: "fvA (Aistar Ps) = (\<Union>P \<in> set Ps. fvA P)"
by (induct Ps, simp_all)

text {* Proposition 4.2 for assertions *}

lemma assn_agrees: "agrees (fvA P) s s' \<Longrightarrow> (s, h) \<Turnstile> P \<longleftrightarrow> (s', h) \<Turnstile> P"
apply (induct P arbitrary: h, simp_all add: bexp_agrees)
apply (clarsimp, (subst exp_agrees, simp_all)+ )
apply (rule iff_exI, simp add: agrees_def)
done

text {* Corollaries of Proposition 4.2, useful for automation. *}

lemma assns_agrees:
  "agrees (fvAs J) s s' \<Longrightarrow> (s, h) \<Turnstile> envs J l1 l2 \<longleftrightarrow> (s', h) \<Turnstile> envs J l1 l2"
apply (clarsimp simp add: envs_def, subst assn_agrees, simp_all)
apply (erule agrees_search, auto simp add: fvAs_def)
done

corollary assns_agreesE[elim]:
  "\<lbrakk> (s, h) \<Turnstile> envs J l1 l2 ; agrees (fvAs J) s s' \<rbrakk> \<Longrightarrow> (s',h) \<Turnstile> envs J l1 l2"
by (simp add: assns_agrees)

corollary assn_agrees2[simp]:
  "x \<notin> fvA P \<Longrightarrow> (s(x := v), h) \<Turnstile> P \<longleftrightarrow> (s, h) \<Turnstile> P"
by (rule assn_agrees, simp add: agrees_def)

corollary assns_agrees2[simp]:
  "x \<notin> fvAs J \<Longrightarrow> (s(x := v), h) \<Turnstile> envs J l l' \<longleftrightarrow> (s, h) \<Turnstile> envs J l l'"
by (rule assns_agrees, simp add: agrees_def)

subsection {* Meaning of CSL judgments *}

text {* Definition 5.1: Configuration safety. *}

primrec
  safe :: "nat \<Rightarrow> cmd \<Rightarrow> stack \<Rightarrow> pheap \<Rightarrow> (rname \<Rightarrow> assn) \<Rightarrow> assn \<Rightarrow> bool"
where
  "safe 0       C s h \<Gamma> Q = True"
| "safe (Suc n) C s h \<Gamma> Q = (
(* Condition (i) *)
            (C = Cskip \<longrightarrow> (s, h) \<Turnstile> Q)
(* Condition (ii) *)
          \<and> (\<forall>hF hh. ptoheap (Some h \<oplus> hF) hh \<longrightarrow> \<not> aborts C (s, hh))
(* Condition (iii) *)
          \<and> accesses C s \<subseteq> dom h
          \<and> writes C s \<subseteq> fpdom h
(* Condition (iv) *)
          \<and> (\<forall>hJ hF hh C' \<sigma>'.
                  red C (s, hh) C' \<sigma>'
                 \<longrightarrow> ptoheap (Some h \<oplus> Some hJ \<oplus> hF) hh
                 \<longrightarrow> (s, hJ) \<Turnstile> envs \<Gamma> (llocked C') (llocked C)
                 \<longrightarrow> (\<exists>h' hJ'.
                         ptoheap (Some h' \<oplus> Some hJ' \<oplus> hF) (snd \<sigma>')
                       \<and> (fst \<sigma>', hJ') \<Turnstile> envs \<Gamma> (llocked C) (llocked C')
                       \<and> safe n C' (fst \<sigma>') h' \<Gamma> Q)))"

text {* The predicate @{text "safe n C s h \<Gamma> Q"} says that the command @{text C} and the logical state
  @{text "(s, h)"} are safe with respect to the resource environment @{text \<Gamma>} and the
  postcondition @{text Q} for @{text n} execution steps.
  Intuitively, any configuration is safe for zero steps.
  For @{text "n + 1"} steps, it must
  (i) satisfy the postcondition if it is a terminal configuration,
  (ii) not abort,
  (iii) access memory only inside its footprint, and
  (iv) after any step it does, re-establish the resource invariant and be safe for
  another @{text n} steps. *}

text {* Definition 5.2: The meaning of CSL judgements. *}

definition
  CSL :: "(rname \<Rightarrow> assn) \<Rightarrow> assn \<Rightarrow> cmd \<Rightarrow> assn \<Rightarrow> bool"
  ("_ \<turnstile> { _ } _ { _ }")
where
  "\<Gamma> \<turnstile> {P} C {Q} \<equiv> (user_cmd C \<and> (\<forall>n s h. (s, h) \<Turnstile> P \<longrightarrow> safe n C s h \<Gamma> Q))"

subsubsection {* Basic properties of Definition 5.1 *}

text {* Proposition 4.3: Monotonicity with respect to the step number. *}

lemma safe_mon:
  "\<lbrakk> safe n C s h J Q; m \<le> n \<rbrakk> \<Longrightarrow> safe m C s h J Q"
apply (induct m arbitrary: C s n h l, simp)
apply (case_tac n, clarify)
apply (simp only: safe.simps, clarsimp)
apply (drule all5D, drule (2) all_imp2D, clarsimp)
apply (rule_tac x="h'" in exI, rule_tac x="hJ'" in exI, simp)
done

text {* Proposition 4.4: Safety depends only the free variables
        of @{term "C"}, @{term "Q"}, and @{term "\<Gamma>"}. *}

lemma safe_agrees:
  "\<lbrakk> safe n C s h \<Gamma> Q ;
     agrees (fvC C \<union> fvA Q \<union> fvAs \<Gamma>) s s' \<rbrakk>
   \<Longrightarrow> safe n C s' h \<Gamma> Q"
apply (induct n arbitrary: C s s' h bl, simp, simp only: safe.simps, clarify)
apply (rule conjI, clarsimp, subst assn_agrees, subst agreesC, assumption+)
apply (rule conjI, clarsimp)
 apply (drule_tac aborts_agrees, simp, fast, simp, simp)
apply (rule conjI, subst (asm) accesses_agrees, simp_all)
apply (rule conjI, subst (asm) writes_agrees, simp_all)
apply (clarify, drule_tac X="fvC C \<union> fvAs \<Gamma> \<union> fvA Q" in red_agrees,
       simp (no_asm), fast, simp (no_asm), fast, clarify)
apply (drule allD, drule (1) all5_impD, clarsimp)
apply (drule imp2D, erule_tac[2] assns_agreesE, simp_all add: agreesC, clarify)
apply (rule_tac x="h'a" and y="hJ'" in ex2I, simp add: pa_ac)
apply (rule conjI, erule assns_agreesE, subst agreesC, assumption)
apply (erule (1) mall4_imp2D, simp add: agreesC)
apply (drule red_properties, auto)
done

subsection {* Soundness of the proof rules *}

subsubsection {* Skip *}

lemma safe_skip[intro!]:
  "(s,h) \<Turnstile> Q \<Longrightarrow> safe n Cskip s h J Q"
by (induct n, simp_all)

theorem rule_skip:
  "\<Gamma> \<turnstile> {P} Cskip {P}"
by (auto simp add: CSL_def)

subsubsection {* Parallel composition *}

lemma disj_conv:
  "pdisj h1 h2 \<Longrightarrow> disjoint (fpdom h1) (dom h2)"
  "pdisj h1 h2 \<Longrightarrow> disjoint (dom h1) (fpdom h2)"
by (simp add: fpdom_def pdisj_def disjoint_def, rule set_eqI, drule_tac a=x in allD, clarsimp)+

lemma safe_par:
 "\<lbrakk> safe n C1 s h1 J Q1; safe n C2 s h2 J Q2;
    wf_cmd (Cpar C1 C2);
    pdisj h1 h2;
    disjoint (fvC C1 \<union> fvA Q1 \<union> fvAs J) (wrC C2);
    disjoint (fvC C2 \<union> fvA Q2 \<union> fvAs J) (wrC C1)\<rbrakk>
  \<Longrightarrow> safe n (Cpar C1 C2) s (padd h1 h2) J (Q1 ** Q2)"
apply (induct n arbitrary: C1 C2 s h1 h2 bl1 bl2, simp, clarsimp)
apply (rule conjI, clarify)
 -- {* no aborts *}
 apply (erule aborts.cases, simp_all add: pa_ac)
   apply (clarify, drule_tac a="Some h2 \<oplus> hF" in all2_impD, simp add: pa_ac, clarsimp)
   apply (clarify, drule_tac a="Some h1 \<oplus> hF" in all2_impD, simp add: pa_ac, clarsimp)
 -- {* no races *}
 apply (clarsimp, erule notE, (erule disjoint_search [rotated])+, erule disj_conv)+
-- {* accesses *}
apply (rule conjI, erule order_trans, simp)+
apply (rule conjI, erule order_trans, erule fpdom_padd)+
-- {* step *}
 apply (clarsimp, erule red_par_cases, simp_all)
 -- {* C1 does a step *}
  apply (clarify, drule_tac a="hJ" and b="Some h2 \<oplus> hF" in all2D, drule all4_impD,
         simp_all add: envs_app locked_eq, clarsimp simp add: pa_ac)
  apply (subgoal_tac "pdisj h' h2", erule_tac[2] pdisj_search)
  apply (rule_tac x="padd h' h2" and y="hJ'" in ex2I, simp add: pa_ac)
  apply (frule (1) red_wf_cmd, drule red_properties, clarsimp)
  apply (drule_tac a=C1' and b=C2 in mall2D, simp add: hsimps)
  apply (drule mall3_imp2D, erule_tac[3] mimp3D, simp_all add: hsimps)
  apply (rule_tac s="s" in safe_agrees)
  apply (rule_tac n="Suc n" in safe_mon, simp add: pa_ac, simp)
  apply (fastforce simp add: agreesC disjoint_commute)
  apply (intro conjI | erule (1) disjoint_search)+
 -- {* C2 does a step *}
  apply (clarify, drule_tac a="hJ" and b="Some h1 \<oplus> hF" in all2D, drule all4_imp2D,
         simp_all add: hsimps envs_app pa_ac, clarsimp)
  apply (subgoal_tac "pdisj h1 h'", erule_tac[2] pdisj_search)
  apply (rule_tac x="padd h1 h'" and y="hJ'" in ex2I, simp add: pa_ac)
  apply (frule (1) red_wf_cmd, drule red_properties, clarsimp)
  apply (drule_tac a=C1 and b=C2' in mall2D, simp add: hsimps)
  apply (drule mall3_imp2D, erule_tac[3] mimp3D, simp_all add: hsimps)
  apply (rule_tac s="s" in safe_agrees)
   apply (rule_tac n="Suc n" in safe_mon, simp add: pa_ac, simp)
  apply (subst agreesC, bestsimp, bestsimp, bestsimp)
-- {* Par skip skip *}
apply (clarify)
apply (rule_tac x="padd h1 h2" and y="hJ" in ex2I, simp add: pa_ac)
apply (rule_tac safe_skip, simp, (rule exI, erule conjI)+, simp)
done

theorem rule_par:
 "\<lbrakk> \<Gamma> \<turnstile> {P1} C1 {Q1} ; \<Gamma> \<turnstile> {P2} C2 {Q2};
    disjoint (fvC C1 \<union> fvA Q1 \<union> fvAs \<Gamma>) (wrC C2);
    disjoint (fvC C2 \<union> fvA Q2 \<union> fvAs \<Gamma>) (wrC C1) \<rbrakk>
  \<Longrightarrow> \<Gamma> \<turnstile> {P1 ** P2} (Cpar C1 C2) {Q1 ** Q2}"
by (auto simp add: CSL_def intro!: safe_par)

subsubsection {* Resource declaration *}

lemma safe_resource:
 "\<lbrakk> safe n C s h (\<Gamma>(r := R)) Q; wf_cmd C; disjoint (fvA R) (wrC C) \<rbrakk> \<Longrightarrow>
     (\<forall>hR. r \<notin> locked C \<longrightarrow> pdisj h hR \<longrightarrow> (s,hR) \<Turnstile> R \<longrightarrow> safe n (Cresource r C) s (padd h hR) \<Gamma> (Q ** R))
   \<and> (r \<in> locked C \<longrightarrow> safe n (Cresource r C) s h \<Gamma> (Q ** R))"
apply (induct n arbitrary: C s h, simp, clarsimp simp add: pa_ac)
apply (rule conjI, clarify)
 apply (rule conjI, clarify)
  -- {* no aborts *}
  apply (erule aborts.cases, simp_all, clarsimp)
  apply (drule_tac a="Some hR \<oplus> hF" in all2_impD, simp add: pa_ac, simp)
 -- {* accesses *}
 apply (rule conjI, erule order_trans, simp)
 apply (rule conjI, erule order_trans, erule fpdom_padd)
 -- {* step *}
 apply (clarify, frule red_properties, clarsimp)
 apply (erule red.cases, simp_all, clarsimp, rename_tac C s hh C' s' hh')
 -- {* normal step *}
apply (subgoal_tac "pdisj hR hJ", erule_tac[2] pdisj_search)
  apply (case_tac "r \<in> set (llocked C')", simp_all add: locked_eq)
   apply (drule_tac a="padd hJ hR" and b="hF" and c="hh" in all3D,
          drule_tac a=C' and b=s' and c=hh' in all3D, simp_all add: pa_ac)
   apply (drule impD, subst sat_envs_expand [where r=r], simp_all)
     apply (rule wf_cmd_distinct_locked, erule (1) red_wf_cmd)
    apply (intro exI conjI, simp, simp_all add: envs_upd)
   apply (clarsimp simp add: envs_removeAll_irr)
   apply (drule (1) mall3_imp2D, erule (1) red_wf_cmd)
   apply (drule mimpD, fast, clarsimp)
   apply (intro exI conjI, simp+)
  -- {* @{term "r \<notin> locked C'"} *}
  apply (drule_tac a="hJ" and b="Some hR \<oplus> hF" and c=hh in all3D, drule_tac a=C' and b=s' and c=hh' in all3D,
         simp add: pa_ac)
  apply (clarsimp simp add: envs_upd)
  apply (drule (1) mall3_imp2D, erule (1) red_wf_cmd)
  apply (drule mimpD, fast, clarsimp)
  apply (subgoal_tac "pdisj h' hR", erule_tac[2] pdisj_search)
  apply (rule_tac x="padd h' hR" and y="hJ'" in ex2I, simp add: pa_ac)
  apply (drule_tac a=hR in all_imp2D, simp_all add: hsimps)
  apply (subst assn_agrees, simp_all, fastforce)
 -- {* skip *}
 apply (clarsimp simp add: envs_def)
 apply (rule_tac x="padd h hR" in exI, simp add: pa_ac, rule safe_skip, simp, fast)
-- {* not user cmd *}
apply (clarsimp)
apply (rule conjI, clarsimp, erule aborts.cases, simp_all, clarsimp, clarsimp)
apply (frule red_properties, clarsimp)
apply (erule red.cases, simp_all, clarsimp, rename_tac C s hh C' s' hh')
apply (drule_tac a="hJ" and b="hF" and c=hh in all3D, drule_tac a=C' and b=s' and c=hh' in all3D,
       simp add: pa_ac)
apply (clarsimp simp add: envs_upd envs_removeAll2)
apply (drule (1) mall3_imp2D, erule (1) red_wf_cmd)
apply (drule mimpD, fast, clarsimp)
apply (case_tac "r \<in> set (llocked C')", simp_all add: locked_eq envs_removeAll2 envs_upd)
 apply (intro exI conjI, simp+)
apply (subst (asm) sat_envs_expand [where r=r], simp_all add: wf_cmd_distinct_locked,
       clarsimp simp add: pa_ac, rename_tac hR' hJ')
apply (subgoal_tac "pdisj h' hR'", erule_tac[2] pdisj_search)
apply (drule (2) all_imp2D, rule_tac x="padd h' hR'" and y=hJ' in ex2I, simp add: pa_ac envs_upd)
done

theorem rule_resource:
 "\<lbrakk> \<Gamma>(r := R) \<turnstile> {P} C {Q} ; disjoint (fvA R) (wrC C) \<rbrakk> \<Longrightarrow>
    \<Gamma> \<turnstile> {P ** R} (Cresource r C) {Q ** R}"
by (clarsimp simp add: CSL_def, drule (1) all3_impD)
   (auto simp add: locked_eq dest!: safe_resource)

subsubsection {* Frame rule *}

text {* The safety of the frame rule can be seen as a special case of the parallel composition
  rule taking one thread to be the empty command. *}

lemma safe_frame:
 "\<lbrakk> safe n C s h J Q;
    pdisj h hR;
    disjoint (fvA R) (wrC C);
    (s,hR) \<Turnstile> R\<rbrakk>
  \<Longrightarrow> safe n C s (padd h hR) J (Q ** R)"
apply (induct n arbitrary: C s h hR, simp, clarsimp simp add: pa_ac)
apply (rule conjI, clarify, fast)
apply (rule conjI, clarify)
 -- {* no aborts *}
 apply (drule_tac a="Some hR \<oplus> hF" in all2_impD, simp add: pa_ac, simp)
-- {* accesses *}
apply (rule conjI, erule order_trans, simp)
apply (rule conjI, erule order_trans, erule fpdom_padd)
-- {* step *}
apply (clarify, frule red_properties, clarsimp)
apply (drule_tac a="hJ" and b="Some hR \<oplus> hF" in all3D, simp add: pa_ac, drule (1) all3_impD, clarsimp)
apply (subgoal_tac "pdisj h' hR", erule_tac[2] pdisj_search)
apply (rule_tac y="hJ'" and x="padd h' hR" in ex2I, clarsimp simp add: pa_ac)
apply (drule mall4D, erule mimp4D, simp_all add: hsimps)
 apply (erule (1) disjoint_search)
apply (subst assn_agrees, simp_all, fastforce)
done

theorem rule_frame:
 "\<lbrakk> \<Gamma> \<turnstile> {P} C {Q} ; disjoint (fvA R) (wrC C) \<rbrakk>
  \<Longrightarrow> \<Gamma> \<turnstile> {P ** R} C {Q ** R}"
by (auto simp add: CSL_def intro: safe_frame)

subsubsection {* Conditional critical regions *}

lemma safe_inwith:
  "\<lbrakk>safe n C s h \<Gamma> (Q ** \<Gamma> r); wf_cmd (Cinwith r C) \<rbrakk>
  \<Longrightarrow> safe n (Cinwith r C) s h \<Gamma> Q"
apply (induct n arbitrary: C s h, simp_all, clarify)
apply (rule conjI)
 apply (clarify, erule aborts.cases, simp_all, clarsimp)
apply (clarify, erule_tac red.cases, simp_all, clarify)
 apply (frule (1) red_wf_cmd)
 apply (drule allD, drule (1) all5_imp2D, simp_all)
 apply (simp add: envs_def list_minus_removeAll [THEN sym] locked_eq)+
 apply fast
apply (clarsimp simp add: envs_def, rename_tac hQ hJ)
apply (rule_tac x="hQ" and y="hJ" in ex2I, simp add: pa_ac, fast)
done

theorem rule_with:
  "\<lbrakk> \<Gamma> \<turnstile> {Aconj (P ** \<Gamma> r) (Apure B)} C {Q ** \<Gamma> r} \<rbrakk>
   \<Longrightarrow> \<Gamma> \<turnstile> {P} Cwith r B C {Q}"
apply (clarsimp simp add: CSL_def)
apply (case_tac n, simp, clarsimp)
apply (rule conjI, clarify, erule aborts.cases, simp_all)
apply (clarify, erule red.cases, simp_all, clarsimp)
apply (subgoal_tac "pdisj h hJ", erule_tac[2] pdisj_search)
apply (simp add: envs_def, rule_tac x="padd h hJ" in exI, simp add: pa_ac)
apply (rule safe_inwith, erule all3_impD, auto dest: user_cmdD)
done

subsubsection {* Sequential composition *}

lemma safe_seq:
 "\<lbrakk> safe n C s h J Q; user_cmd C2;
    \<forall>m s' h'. m \<le> n \<and> (s', h') \<Turnstile> Q \<longrightarrow> safe m C2 s' h' J R \<rbrakk>
  \<Longrightarrow> safe n (Cseq C C2) s h J R"
apply (induct n arbitrary: C s h l, simp, clarsimp)
apply (rule conjI, clarsimp)
 apply (erule aborts.cases, simp_all, clarsimp)
apply (clarsimp, erule red.cases, simp_all)
 -- {* Seq1 *}
 apply (clarify, rule_tac x="h" and y="hJ" in ex2I, simp)
-- {* Seq2 *}
apply (clarify, drule all3D, drule (2) all3_imp2D, clarsimp)
apply (drule (1) mall3_impD, rule_tac x="h'" and y="hJ'" in ex2I, simp)
done

theorem rule_seq:
  "\<lbrakk> \<Gamma> \<turnstile> {P} C1 {Q} ; \<Gamma> \<turnstile> {Q} C2 {R} \<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> {P} Cseq C1 C2 {R}"
by (auto simp add: CSL_def intro!: safe_seq)

subsubsection {* Conditionals (if-then-else) *}

theorem rule_if:
  "\<lbrakk> \<Gamma> \<turnstile> {Aconj P (Apure B)} C1 {Q} ;
     \<Gamma> \<turnstile> {Aconj P (Apure (Bnot B))} C2 {Q} \<rbrakk>
  \<Longrightarrow> \<Gamma> \<turnstile> {P} Cif B C1 C2 {Q}"
apply (clarsimp simp add: CSL_def)
apply (case_tac n, simp, clarsimp)
apply (intro conjI allI impI notI, erule aborts.cases, simp_all)
apply (erule red.cases, simp_all)
apply (clarsimp, intro exI, (rule conjI, simp)+, simp)+
done

subsubsection {* While *}

lemma safe_while:
  "\<lbrakk> \<Gamma> \<turnstile> {Aconj P (Apure B)} C {P} ; (s, h) \<Turnstile> P \<rbrakk>
  \<Longrightarrow> safe n (Cwhile B C) s h \<Gamma> (Aconj P (Apure (Bnot B)))"
apply (induct n arbitrary: s h, simp, clarsimp)
apply (intro conjI allI impI notI, erule aborts.cases, simp_all)
apply (erule red.cases, simp_all)
apply (clarsimp, intro exI, (rule conjI, simp)+)
apply (subgoal_tac "\<forall>m s h. m \<le> n \<and> (s, h) \<Turnstile> P \<longrightarrow> safe m (Cwhile B C) s h \<Gamma> (Aconj P (Apure (Bnot B)))")
 apply (case_tac n, simp, clarsimp)
 apply (intro conjI allI impI notI, erule aborts.cases, simp_all)
 apply (erule red.cases, simp_all)
  apply (clarsimp, intro exI, (rule conjI, simp)+)
  apply (clarsimp simp add: CSL_def, rule safe_seq, blast, simp, clarsimp)
 apply (clarsimp, intro exI, (rule conjI, simp)+, rule safe_skip, simp)
apply (clarsimp, drule (1) mall2_impD, erule (1) safe_mon)
done

theorem rule_while:
  "\<Gamma> \<turnstile> {Aconj P (Apure B)} C {P}
  \<Longrightarrow> \<Gamma> \<turnstile> {P} Cwhile B C {Aconj P (Apure (Bnot B))}"
by (auto simp add: CSL_def intro: safe_while)

subsubsection {* Local variable declaration *}

lemma safe_inlocal:
  "\<lbrakk> safe n C (s(x:=v)) h \<Gamma> Q ; x \<notin> fvA Q \<union> fvAs \<Gamma> \<rbrakk>
  \<Longrightarrow> safe n (Cinlocal x v C) s h \<Gamma> Q"
apply (induct n arbitrary: s h v C, simp, clarsimp)
apply (intro conjI allI impI notI, erule aborts.cases, simp_all, clarsimp)
apply (erule red.cases, simp_all)
 apply (clarsimp, drule allD, drule (1) all5_imp2D, simp)
 apply (clarsimp, intro exI, (rule conjI, simp)+, simp)
apply (fastforce simp add: safe_skip)
done

theorem rule_local:
  "\<lbrakk> \<Gamma> \<turnstile> {Aconj P (Apure (Beq (Evar x) E))} C {Q} ;
     x \<notin> fvA P \<union> fvA Q \<union> fvAs \<Gamma> \<union> fvE E \<rbrakk>
  \<Longrightarrow> \<Gamma> \<turnstile> {P} Clocal x E C {Q}"
apply (auto simp add: CSL_def intro: safe_inlocal)
apply (case_tac n, simp_all)
apply (intro conjI allI impI notI, erule aborts.cases, simp_all)
apply (erule red.cases, simp_all, clarsimp)
apply (intro exI conjI, simp_all, rule safe_inlocal, simp_all)
done

subsubsection {* Basic commands (Assign, Read, Write, Alloc, Free) *}

theorem rule_assign:
  "x \<notin> fvAs \<Gamma> \<Longrightarrow> \<Gamma> \<turnstile> {subA x E Q} Cassign x E {Q}"
apply (clarsimp simp add: CSL_def)
apply (case_tac n, simp, clarsimp)
apply (rule conjI, clarsimp, erule aborts.cases, simp_all)
apply (clarsimp, erule red.cases, simp_all)
apply (rule_tac x="h" in exI, rule_tac x="hJ" in exI,
       clarsimp simp add: subA_assign)
done

lemma ptoheap_read:
 "\<lbrakk> ptoheap (Some h \<oplus> hF) hh; h x = Some (v, k) \<rbrakk> \<Longrightarrow> hh x = Some v"
apply (case_tac hF, (simp add: ptoheap_def mypadd_def split: if_split_asm)+)
apply (drule_tac a="x" in allD, fastforce simp add: padd_def split: option.splits)
done

theorem rule_read:
  "\<lbrakk> x \<notin> fvE E \<union> fvE E' \<union> fvAs \<Gamma> \<rbrakk> \<Longrightarrow>
    \<Gamma> \<turnstile> {Apsto k E E'} Cread x E {Aconj (Apsto k E E') (Apure (Beq (Evar x) E'))}"
apply (clarsimp simp add: CSL_def)
apply (case_tac n, simp, clarsimp, intro conjI allI impI notI)
 apply (erule aborts.cases, simp_all, fastforce dest: ptoheap_read)
apply (erule red.cases, simp_all, fastforce dest: ptoheap_read)
done

lemma pdisj_upd2: "h x = Some (w, pfull) \<Longrightarrow> pdisj (h(x \<mapsto> (v, pfull))) h' = pdisj h h'"
by (simp add: pdisj_def, rule iff_allI, auto split: option.splits)

lemma write_helper:
 "\<lbrakk> ptoheap (Some h \<oplus> hF) hh; h x = Some (v, pfull) \<rbrakk> \<Longrightarrow>
  ptoheap (Some (h(x\<mapsto> (w, pfull))) \<oplus> hF) (hh(x\<mapsto>w))"
apply (case_tac hF, simp_all add: ptoheap_def mypadd_def split: if_split_asm)
apply (clarsimp simp add: pdisj_upd2, simp add: pdisj_def, (drule_tac a=xa in allD)+)
apply (clarsimp simp add: pdisj_def padd_def split: option.splits)
done

theorem rule_write:
  "\<Gamma> \<turnstile> {E \<longmapsto> E0} Cwrite E E' {E \<longmapsto> E'}"
apply (clarsimp simp add: CSL_def)
apply (case_tac n, simp, clarsimp simp add: fpdom_def, intro conjI allI impI notI)
apply (erule aborts.cases, simp_all, fastforce dest: ptoheap_read)
apply (erule red.cases, simp_all, fastforce elim: write_helper)
done

lemma alloc_helper:
 "\<lbrakk>ptoheap h hh; x \<notin> dom hh\<rbrakk> \<Longrightarrow>
  ptoheap (Some [x \<mapsto> (v, pfull)] \<oplus> h) (hh(x \<mapsto> v))"
apply (auto simp add: ptoheap_def mypadd_def pdisj_def padd_def split: option.splits)
apply (drule_tac a=xa in allD, simp)
done

theorem rule_alloc:
  "\<lbrakk> x \<notin> fvE E \<union> fvAs \<Gamma> \<rbrakk>
  \<Longrightarrow> \<Gamma> \<turnstile> {Aemp} Calloc x E {Evar x \<longmapsto> E}"
apply (clarsimp simp add: CSL_def)
apply (case_tac n, simp, clarsimp, intro conjI allI impI notI)
apply (erule aborts.cases, simp_all)
apply (erule red.cases, simp_all, fastforce elim: alloc_helper)
done

lemma free_helper:
 "\<lbrakk> ptoheap (Some h \<oplus> hF) hh; h x = Some (v, pfull) \<rbrakk> \<Longrightarrow>
  ptoheap (Some (h(x:=None)) \<oplus> hF) (hh(x:=None))"
apply (case_tac hF, simp_all add: ptoheap_def mypadd_def split: if_split_asm)
apply (clarsimp simp add: pdisj_def, (drule_tac a=xa in allD)+)
apply (clarsimp simp add: padd_def split: option.splits)
done

theorem rule_free:
  "\<Gamma> \<turnstile> {E \<longmapsto> E0} Cdispose E {Aemp}"
apply (clarsimp simp add: CSL_def)
apply (case_tac n, simp, clarsimp simp add: fpdom_def, intro conjI allI impI notI)
 apply (erule aborts.cases, simp_all, fastforce dest: ptoheap_read)
apply (erule red.cases, simp_all, fastforce elim: free_helper dom_eqD)
done

subsubsection {* Simple structural rules (Conseq, Disj, Ex) *}

lemma safe_conseq:
 "\<lbrakk> safe n C s h \<Gamma> Q ; Q \<sqsubseteq> Q' \<rbrakk> \<Longrightarrow> safe n C s h \<Gamma> Q'"
apply (induct n arbitrary: C s h, simp, clarsimp simp add: implies_def)
apply (drule allD, drule (2) all5_imp2D, simp_all, clarsimp)
apply (drule (1) mall3_impD, rule_tac x="h'" and y="hJ'" in ex2I, simp)
done

theorem rule_conseq:
 "\<lbrakk> \<Gamma> \<turnstile> {P} C {Q} ; P' \<sqsubseteq> P ; Q \<sqsubseteq> Q' \<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> {P'} C {Q'}"
by (fastforce simp add: CSL_def implies_def elim!: safe_conseq)

theorem rule_disj:
 "\<lbrakk> \<Gamma> \<turnstile> {P1} C {Q1}; \<Gamma> \<turnstile> {P2} C {Q2} \<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> {Adisj P1 P2} C {Adisj Q1 Q2}"
by (clarsimp simp add: CSL_def, safe)
   (rule safe_conseq, simp_all add: implies_def, drule (2) all3_impD, force)+

theorem rule_ex:
 "\<lbrakk> \<forall>n. (\<Gamma> \<turnstile> {P n} C {Q n}) \<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> {Aex P} C {Aex Q}"
by (clarsimp simp add: CSL_def, rule_tac Q = "Q v" in safe_conseq,
    auto simp add: implies_def)

subsubsection {* Conjunction rule *}

lemma safe_conj:
  "\<lbrakk> safe n C s h \<Gamma> Q1;
     safe n C s h \<Gamma> Q2;
     \<forall>r. precise (\<Gamma> r) \<rbrakk>
  \<Longrightarrow> safe n C s h \<Gamma> (Aconj Q1 Q2)"
apply (induct n arbitrary: C s h, simp, clarsimp)
apply (drule allD, drule (2) all5_imp2D, clarsimp)+
apply (rule_tac x=h' and y=hJ' in ex2I, simp)
apply (erule mall3_imp2D, simp_all)
apply (subgoal_tac "Some hJ' \<oplus> Some h' = Some hJ'a \<oplus> Some h'a")
 apply (subst (asm) (8 9) mypadd_def, simp split: if_split_asm)
  apply (erule_tac[2] notE, erule_tac[2] pdisj_search)
 apply (drule_tac s="a" and y="h'" and y'="h'a" in preciseD [rotated], simp_all
        add: envs_def precise_istar, fast)
apply (case_tac hF, simp add: ptoheap_def, clarsimp, rename_tac hR)
apply (drule (1) ptoD, rule_tac x="Some hR" in pa_cancel, simp add: pa_ac)
apply (rule notI, simp add: pa_ac ptoheap_def)
done

theorem rule_conj:
 "\<lbrakk> \<Gamma> \<turnstile> {P1} C {Q1};
    \<Gamma> \<turnstile> {P2} C {Q2};
    \<forall>r. precise (\<Gamma> r) \<rbrakk>
  \<Longrightarrow> \<Gamma> \<turnstile> {Aconj P1 P2} C {Aconj Q1 Q2}"
by (auto simp add: CSL_def intro: safe_conj)

subsubsection {* Auxiliary variables *}

lemma safe_aux:
  "\<lbrakk> safe n C s h \<Gamma> Q; disjoint X (fvC (rem_vars X C) \<union> fvA Q \<union> fvAs \<Gamma>) \<rbrakk>
  \<Longrightarrow> safe n (rem_vars X C) s h \<Gamma> Q"
apply (induct n arbitrary: C s h, simp_all)
apply (intro conjI impI allI, clarsimp)
apply (fastforce intro: aborts_remvars)
apply (elim conjE, erule order_trans [OF accesses_remvars])
apply (clarsimp, frule red_properties, drule aux_red, simp_all)
apply (drule_tac a="Some hJ \<oplus> hF" in allD, simp add: pa_ac)
apply (clarsimp, drule allD, drule (2) all5_imp2D, clarsimp)
apply (intro exI conjI, simp+)
apply (fastforce simp add: disjoint_commute agreesC)
apply (drule (1) mall3_imp2D, fast)
apply (erule safe_agrees, fastforce simp add: disjoint_commute agreesC)
done

text {* The proof rule for eliminating auxiliary variables. Note that a
  set of variables, @{term X}, is auxiliary for a command @{term C}
  iff it disjoint from @{term "fvC (rem_vars X C)"}. *}

theorem rule_aux:
  "\<lbrakk> \<Gamma> \<turnstile> {P} C {Q} ;
     disjoint X (fvA P \<union> fvA Q \<union> fvAs \<Gamma> \<union> fvC (rem_vars X C)) \<rbrakk>
  \<Longrightarrow> \<Gamma> \<turnstile> {P} rem_vars X C {Q}"
by (auto simp add: CSL_def safe_aux disjoint_commute)

end


(* This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.*)
  theory TIP_sort_HSort2Sorts
  imports "../../Test_Base"
begin

datatype 'a list = nil2 | cons2 "'a" "'a list"

datatype Heap = Node "Heap" "int" "Heap" | Nil

fun ordered :: "int list => bool" where
  "ordered (nil2) = True"
| "ordered (cons2 y (nil2)) = True"
| "ordered (cons2 y (cons2 y2 xs)) =
     ((y <= y2) & (ordered (cons2 y2 xs)))"

fun hmerge :: "Heap => Heap => Heap" where
  "hmerge (Node z x2 x3) (Node x4 x5 x6) =
   (if x2 <= x5 then Node (hmerge x3 (Node x4 x5 x6)) x2 z else
      Node (hmerge (Node z x2 x3) x6) x5 x4)"
| "hmerge (Node z x2 x3) (Nil) = Node z x2 x3"
| "hmerge (Nil) y = y"

(*fun did not finish the proof*)
function toList :: "Heap => int list" where
  "toList (Node p y q) = cons2 y (toList (hmerge p q))"
| "toList (Nil) = nil2"
  by pat_completeness auto

fun hinsert :: "int => Heap => Heap" where
  "hinsert x y = hmerge (Node Nil x Nil) y"

fun toHeap2 :: "int list => Heap" where
  "toHeap2 (nil2) = Nil"
| "toHeap2 (cons2 y xs) = hinsert y (toHeap2 xs)"

fun hsort2 :: "int list => int list" where
  "hsort2 x = toList (toHeap2 x)"

theorem property0 :
  "ordered (hsort2 xs)"
  oops

end


(*  Title:      HOL/Conditionally_Complete_Lattices.thy
    Author:     Amine Chaieb and L C Paulson, University of Cambridge
    Author:     Johannes Hölzl, TU München
    Author:     Luke S. Serafin, Carnegie Mellon University
*)

section \<open>Conditionally-complete Lattices\<close>

theory Conditionally_Complete_Lattices
imports Finite_Set Lattices_Big Set_Interval
begin

context preorder
begin

definition "bdd_above A \<longleftrightarrow> (\<exists>M. \<forall>x \<in> A. x \<le> M)"
definition "bdd_below A \<longleftrightarrow> (\<exists>m. \<forall>x \<in> A. m \<le> x)"

lemma bdd_aboveI[intro]: "(\<And>x. x \<in> A \<Longrightarrow> x \<le> M) \<Longrightarrow> bdd_above A"
  by (auto simp: bdd_above_def)

lemma bdd_belowI[intro]: "(\<And>x. x \<in> A \<Longrightarrow> m \<le> x) \<Longrightarrow> bdd_below A"
  by (auto simp: bdd_below_def)

lemma bdd_aboveI2: "(\<And>x. x \<in> A \<Longrightarrow> f x \<le> M) \<Longrightarrow> bdd_above (f`A)"
  by force

lemma bdd_belowI2: "(\<And>x. x \<in> A \<Longrightarrow> m \<le> f x) \<Longrightarrow> bdd_below (f`A)"
  by force

lemma bdd_above_empty [simp, intro]: "bdd_above {}"
  unfolding bdd_above_def by auto

lemma bdd_below_empty [simp, intro]: "bdd_below {}"
  unfolding bdd_below_def by auto

lemma bdd_above_mono: "bdd_above B \<Longrightarrow> A \<subseteq> B \<Longrightarrow> bdd_above A"
  by (metis (full_types) bdd_above_def order_class.le_neq_trans psubsetD)

lemma bdd_below_mono: "bdd_below B \<Longrightarrow> A \<subseteq> B \<Longrightarrow> bdd_below A"
  by (metis bdd_below_def order_class.le_neq_trans psubsetD)

lemma bdd_above_Int1 [simp]: "bdd_above A \<Longrightarrow> bdd_above (A \<inter> B)"
  using bdd_above_mono by auto

lemma bdd_above_Int2 [simp]: "bdd_above B \<Longrightarrow> bdd_above (A \<inter> B)"
  using bdd_above_mono by auto

lemma bdd_below_Int1 [simp]: "bdd_below A \<Longrightarrow> bdd_below (A \<inter> B)"
  using bdd_below_mono by auto

lemma bdd_below_Int2 [simp]: "bdd_below B \<Longrightarrow> bdd_below (A \<inter> B)"
  using bdd_below_mono by auto

lemma bdd_above_Ioo [simp, intro]: "bdd_above {a <..< b}"
  by (auto simp add: bdd_above_def intro!: exI[of _ b] less_imp_le)

lemma bdd_above_Ico [simp, intro]: "bdd_above {a ..< b}"
  by (auto simp add: bdd_above_def intro!: exI[of _ b] less_imp_le)

lemma bdd_above_Iio [simp, intro]: "bdd_above {..< b}"
  by (auto simp add: bdd_above_def intro: exI[of _ b] less_imp_le)

lemma bdd_above_Ioc [simp, intro]: "bdd_above {a <.. b}"
  by (auto simp add: bdd_above_def intro: exI[of _ b] less_imp_le)

lemma bdd_above_Icc [simp, intro]: "bdd_above {a .. b}"
  by (auto simp add: bdd_above_def intro: exI[of _ b] less_imp_le)

lemma bdd_above_Iic [simp, intro]: "bdd_above {.. b}"
  by (auto simp add: bdd_above_def intro: exI[of _ b] less_imp_le)

lemma bdd_below_Ioo [simp, intro]: "bdd_below {a <..< b}"
  by (auto simp add: bdd_below_def intro!: exI[of _ a] less_imp_le)

lemma bdd_below_Ioc [simp, intro]: "bdd_below {a <.. b}"
  by (auto simp add: bdd_below_def intro!: exI[of _ a] less_imp_le)

lemma bdd_below_Ioi [simp, intro]: "bdd_below {a <..}"
  by (auto simp add: bdd_below_def intro: exI[of _ a] less_imp_le)

lemma bdd_below_Ico [simp, intro]: "bdd_below {a ..< b}"
  by (auto simp add: bdd_below_def intro: exI[of _ a] less_imp_le)

lemma bdd_below_Icc [simp, intro]: "bdd_below {a .. b}"
  by (auto simp add: bdd_below_def intro: exI[of _ a] less_imp_le)

lemma bdd_below_Ici [simp, intro]: "bdd_below {a ..}"
  by (auto simp add: bdd_below_def intro: exI[of _ a] less_imp_le)

end

lemma (in order_top) bdd_above_top[simp, intro!]: "bdd_above A"
  by (rule bdd_aboveI[of _ top]) simp

lemma (in order_bot) bdd_above_bot[simp, intro!]: "bdd_below A"
  by (rule bdd_belowI[of _ bot]) simp

lemma bdd_above_image_mono: "mono f \<Longrightarrow> bdd_above A \<Longrightarrow> bdd_above (f`A)"
  by (auto simp: bdd_above_def mono_def)

lemma bdd_below_image_mono: "mono f \<Longrightarrow> bdd_below A \<Longrightarrow> bdd_below (f`A)"
  by (auto simp: bdd_below_def mono_def)

lemma bdd_above_image_antimono: "antimono f \<Longrightarrow> bdd_below A \<Longrightarrow> bdd_above (f`A)"
  by (auto simp: bdd_above_def bdd_below_def antimono_def)

lemma bdd_below_image_antimono: "antimono f \<Longrightarrow> bdd_above A \<Longrightarrow> bdd_below (f`A)"
  by (auto simp: bdd_above_def bdd_below_def antimono_def)

lemma
  fixes X :: "'a::ordered_ab_group_add set"
  shows bdd_above_uminus[simp]: "bdd_above (uminus ` X) \<longleftrightarrow> bdd_below X"
    and bdd_below_uminus[simp]: "bdd_below (uminus ` X) \<longleftrightarrow> bdd_above X"
  using bdd_above_image_antimono[of uminus X] bdd_below_image_antimono[of uminus "uminus`X"]
  using bdd_below_image_antimono[of uminus X] bdd_above_image_antimono[of uminus "uminus`X"]
  by (auto simp: antimono_def image_image)

context lattice
begin

lemma bdd_above_insert [simp]: "bdd_above (insert a A) = bdd_above A"
  by (auto simp: bdd_above_def intro: le_supI2 sup_ge1)

lemma bdd_below_insert [simp]: "bdd_below (insert a A) = bdd_below A"
  by (auto simp: bdd_below_def intro: le_infI2 inf_le1)

lemma bdd_finite [simp]:
  assumes "finite A" shows bdd_above_finite: "bdd_above A" and bdd_below_finite: "bdd_below A"
  using assms by (induct rule: finite_induct, auto)

lemma bdd_above_Un [simp]: "bdd_above (A \<union> B) = (bdd_above A \<and> bdd_above B)"
proof
  assume "bdd_above (A \<union> B)"
  thus "bdd_above A \<and> bdd_above B" unfolding bdd_above_def by auto
next
  assume "bdd_above A \<and> bdd_above B"
  then obtain a b where "\<forall>x\<in>A. x \<le> a" "\<forall>x\<in>B. x \<le> b" unfolding bdd_above_def by auto
  hence "\<forall>x \<in> A \<union> B. x \<le> sup a b" by (auto intro: Un_iff le_supI1 le_supI2)
  thus "bdd_above (A \<union> B)" unfolding bdd_above_def ..
qed

lemma bdd_below_Un [simp]: "bdd_below (A \<union> B) = (bdd_below A \<and> bdd_below B)"
proof
  assume "bdd_below (A \<union> B)"
  thus "bdd_below A \<and> bdd_below B" unfolding bdd_below_def by auto
next
  assume "bdd_below A \<and> bdd_below B"
  then obtain a b where "\<forall>x\<in>A. a \<le> x" "\<forall>x\<in>B. b \<le> x" unfolding bdd_below_def by auto
  hence "\<forall>x \<in> A \<union> B. inf a b \<le> x" by (auto intro: Un_iff le_infI1 le_infI2)
  thus "bdd_below (A \<union> B)" unfolding bdd_below_def ..
qed

lemma bdd_above_image_sup[simp]:
  "bdd_above ((\<lambda>x. sup (f x) (g x)) ` A) \<longleftrightarrow> bdd_above (f`A) \<and> bdd_above (g`A)"
by (auto simp: bdd_above_def intro: le_supI1 le_supI2)

lemma bdd_below_image_inf[simp]:
  "bdd_below ((\<lambda>x. inf (f x) (g x)) ` A) \<longleftrightarrow> bdd_below (f`A) \<and> bdd_below (g`A)"
by (auto simp: bdd_below_def intro: le_infI1 le_infI2)

lemma bdd_below_UN[simp]: "finite I \<Longrightarrow> bdd_below (\<Union>i\<in>I. A i) = (\<forall>i \<in> I. bdd_below (A i))"
by (induction I rule: finite.induct) auto

lemma bdd_above_UN[simp]: "finite I \<Longrightarrow> bdd_above (\<Union>i\<in>I. A i) = (\<forall>i \<in> I. bdd_above (A i))"
by (induction I rule: finite.induct) auto

end

text \<open>

To avoid name classes with the \<^class>\<open>complete_lattice\<close>-class we prefix \<^const>\<open>Sup\<close> and
\<^const>\<open>Inf\<close> in theorem names with c.

\<close>

class conditionally_complete_lattice = lattice + Sup + Inf +
  assumes cInf_lower: "x \<in> X \<Longrightarrow> bdd_below X \<Longrightarrow> Inf X \<le> x"
    and cInf_greatest: "X \<noteq> {} \<Longrightarrow> (\<And>x. x \<in> X \<Longrightarrow> z \<le> x) \<Longrightarrow> z \<le> Inf X"
  assumes cSup_upper: "x \<in> X \<Longrightarrow> bdd_above X \<Longrightarrow> x \<le> Sup X"
    and cSup_least: "X \<noteq> {} \<Longrightarrow> (\<And>x. x \<in> X \<Longrightarrow> x \<le> z) \<Longrightarrow> Sup X \<le> z"
begin

lemma cSup_upper2: "x \<in> X \<Longrightarrow> y \<le> x \<Longrightarrow> bdd_above X \<Longrightarrow> y \<le> Sup X"
  by (metis cSup_upper order_trans)

lemma cInf_lower2: "x \<in> X \<Longrightarrow> x \<le> y \<Longrightarrow> bdd_below X \<Longrightarrow> Inf X \<le> y"
  by (metis cInf_lower order_trans)

lemma cSup_mono: "B \<noteq> {} \<Longrightarrow> bdd_above A \<Longrightarrow> (\<And>b. b \<in> B \<Longrightarrow> \<exists>a\<in>A. b \<le> a) \<Longrightarrow> Sup B \<le> Sup A"
  by (metis cSup_least cSup_upper2)

lemma cInf_mono: "B \<noteq> {} \<Longrightarrow> bdd_below A \<Longrightarrow> (\<And>b. b \<in> B \<Longrightarrow> \<exists>a\<in>A. a \<le> b) \<Longrightarrow> Inf A \<le> Inf B"
  by (metis cInf_greatest cInf_lower2)

lemma cSup_subset_mono: "A \<noteq> {} \<Longrightarrow> bdd_above B \<Longrightarrow> A \<subseteq> B \<Longrightarrow> Sup A \<le> Sup B"
  by (metis cSup_least cSup_upper subsetD)

lemma cInf_superset_mono: "A \<noteq> {} \<Longrightarrow> bdd_below B \<Longrightarrow> A \<subseteq> B \<Longrightarrow> Inf B \<le> Inf A"
  by (metis cInf_greatest cInf_lower subsetD)

lemma cSup_eq_maximum: "z \<in> X \<Longrightarrow> (\<And>x. x \<in> X \<Longrightarrow> x \<le> z) \<Longrightarrow> Sup X = z"
  by (intro antisym cSup_upper[of z X] cSup_least[of X z]) auto

lemma cInf_eq_minimum: "z \<in> X \<Longrightarrow> (\<And>x. x \<in> X \<Longrightarrow> z \<le> x) \<Longrightarrow> Inf X = z"
  by (intro antisym cInf_lower[of z X] cInf_greatest[of X z]) auto

lemma cSup_le_iff: "S \<noteq> {} \<Longrightarrow> bdd_above S \<Longrightarrow> Sup S \<le> a \<longleftrightarrow> (\<forall>x\<in>S. x \<le> a)"
  by (metis order_trans cSup_upper cSup_least)

lemma le_cInf_iff: "S \<noteq> {} \<Longrightarrow> bdd_below S \<Longrightarrow> a \<le> Inf S \<longleftrightarrow> (\<forall>x\<in>S. a \<le> x)"
  by (metis order_trans cInf_lower cInf_greatest)

lemma cSup_eq_non_empty:
  assumes 1: "X \<noteq> {}"
  assumes 2: "\<And>x. x \<in> X \<Longrightarrow> x \<le> a"
  assumes 3: "\<And>y. (\<And>x. x \<in> X \<Longrightarrow> x \<le> y) \<Longrightarrow> a \<le> y"
  shows "Sup X = a"
  by (intro 3 1 antisym cSup_least) (auto intro: 2 1 cSup_upper)

lemma cInf_eq_non_empty:
  assumes 1: "X \<noteq> {}"
  assumes 2: "\<And>x. x \<in> X \<Longrightarrow> a \<le> x"
  assumes 3: "\<And>y. (\<And>x. x \<in> X \<Longrightarrow> y \<le> x) \<Longrightarrow> y \<le> a"
  shows "Inf X = a"
  by (intro 3 1 antisym cInf_greatest) (auto intro: 2 1 cInf_lower)

lemma cInf_cSup: "S \<noteq> {} \<Longrightarrow> bdd_below S \<Longrightarrow> Inf S = Sup {x. \<forall>s\<in>S. x \<le> s}"
  by (rule cInf_eq_non_empty) (auto intro!: cSup_upper cSup_least simp: bdd_below_def)

lemma cSup_cInf: "S \<noteq> {} \<Longrightarrow> bdd_above S \<Longrightarrow> Sup S = Inf {x. \<forall>s\<in>S. s \<le> x}"
  by (rule cSup_eq_non_empty) (auto intro!: cInf_lower cInf_greatest simp: bdd_above_def)

lemma cSup_insert: "X \<noteq> {} \<Longrightarrow> bdd_above X \<Longrightarrow> Sup (insert a X) = sup a (Sup X)"
  by (intro cSup_eq_non_empty) (auto intro: le_supI2 cSup_upper cSup_least)

lemma cInf_insert: "X \<noteq> {} \<Longrightarrow> bdd_below X \<Longrightarrow> Inf (insert a X) = inf a (Inf X)"
  by (intro cInf_eq_non_empty) (auto intro: le_infI2 cInf_lower cInf_greatest)

lemma cSup_singleton [simp]: "Sup {x} = x"
  by (intro cSup_eq_maximum) auto

lemma cInf_singleton [simp]: "Inf {x} = x"
  by (intro cInf_eq_minimum) auto

lemma cSup_insert_If:  "bdd_above X \<Longrightarrow> Sup (insert a X) = (if X = {} then a else sup a (Sup X))"
  using cSup_insert[of X] by simp

lemma cInf_insert_If: "bdd_below X \<Longrightarrow> Inf (insert a X) = (if X = {} then a else inf a (Inf X))"
  using cInf_insert[of X] by simp

lemma le_cSup_finite: "finite X \<Longrightarrow> x \<in> X \<Longrightarrow> x \<le> Sup X"
proof (induct X arbitrary: x rule: finite_induct)
  case (insert x X y) then show ?case
    by (cases "X = {}") (auto simp: cSup_insert intro: le_supI2)
qed simp

lemma cInf_le_finite: "finite X \<Longrightarrow> x \<in> X \<Longrightarrow> Inf X \<le> x"
proof (induct X arbitrary: x rule: finite_induct)
  case (insert x X y) then show ?case
    by (cases "X = {}") (auto simp: cInf_insert intro: le_infI2)
qed simp

lemma cSup_eq_Sup_fin: "finite X \<Longrightarrow> X \<noteq> {} \<Longrightarrow> Sup X = Sup_fin X"
  by (induct X rule: finite_ne_induct) (simp_all add: cSup_insert)

lemma cInf_eq_Inf_fin: "finite X \<Longrightarrow> X \<noteq> {} \<Longrightarrow> Inf X = Inf_fin X"
  by (induct X rule: finite_ne_induct) (simp_all add: cInf_insert)

lemma cSup_atMost[simp]: "Sup {..x} = x"
  by (auto intro!: cSup_eq_maximum)

lemma cSup_greaterThanAtMost[simp]: "y < x \<Longrightarrow> Sup {y<..x} = x"
  by (auto intro!: cSup_eq_maximum)

lemma cSup_atLeastAtMost[simp]: "y \<le> x \<Longrightarrow> Sup {y..x} = x"
  by (auto intro!: cSup_eq_maximum)

lemma cInf_atLeast[simp]: "Inf {x..} = x"
  by (auto intro!: cInf_eq_minimum)

lemma cInf_atLeastLessThan[simp]: "y < x \<Longrightarrow> Inf {y..<x} = y"
  by (auto intro!: cInf_eq_minimum)

lemma cInf_atLeastAtMost[simp]: "y \<le> x \<Longrightarrow> Inf {y..x} = y"
  by (auto intro!: cInf_eq_minimum)

lemma cINF_lower: "bdd_below (f ` A) \<Longrightarrow> x \<in> A \<Longrightarrow> \<Sqinter>(f ` A) \<le> f x"
  using cInf_lower [of _ "f ` A"] by simp

lemma cINF_greatest: "A \<noteq> {} \<Longrightarrow> (\<And>x. x \<in> A \<Longrightarrow> m \<le> f x) \<Longrightarrow> m \<le> \<Sqinter>(f ` A)"
  using cInf_greatest [of "f ` A"] by auto

lemma cSUP_upper: "x \<in> A \<Longrightarrow> bdd_above (f ` A) \<Longrightarrow> f x \<le> \<Squnion>(f ` A)"
  using cSup_upper [of _ "f ` A"] by simp

lemma cSUP_least: "A \<noteq> {} \<Longrightarrow> (\<And>x. x \<in> A \<Longrightarrow> f x \<le> M) \<Longrightarrow> \<Squnion>(f ` A) \<le> M"
  using cSup_least [of "f ` A"] by auto

lemma cINF_lower2: "bdd_below (f ` A) \<Longrightarrow> x \<in> A \<Longrightarrow> f x \<le> u \<Longrightarrow> \<Sqinter>(f ` A) \<le> u"
  by (auto intro: cINF_lower order_trans)

lemma cSUP_upper2: "bdd_above (f ` A) \<Longrightarrow> x \<in> A \<Longrightarrow> u \<le> f x \<Longrightarrow> u \<le> \<Squnion>(f ` A)"
  by (auto intro: cSUP_upper order_trans)

lemma cSUP_const [simp]: "A \<noteq> {} \<Longrightarrow> (\<Squnion>x\<in>A. c) = c"
  by (intro antisym cSUP_least) (auto intro: cSUP_upper)

lemma cINF_const [simp]: "A \<noteq> {} \<Longrightarrow> (\<Sqinter>x\<in>A. c) = c"
  by (intro antisym cINF_greatest) (auto intro: cINF_lower)

lemma le_cINF_iff: "A \<noteq> {} \<Longrightarrow> bdd_below (f ` A) \<Longrightarrow> u \<le> \<Sqinter>(f ` A) \<longleftrightarrow> (\<forall>x\<in>A. u \<le> f x)"
  by (metis cINF_greatest cINF_lower order_trans)

lemma cSUP_le_iff: "A \<noteq> {} \<Longrightarrow> bdd_above (f ` A) \<Longrightarrow> \<Squnion>(f ` A) \<le> u \<longleftrightarrow> (\<forall>x\<in>A. f x \<le> u)"
  by (metis cSUP_least cSUP_upper order_trans)

lemma less_cINF_D: "bdd_below (f`A) \<Longrightarrow> y < (\<Sqinter>i\<in>A. f i) \<Longrightarrow> i \<in> A \<Longrightarrow> y < f i"
  by (metis cINF_lower less_le_trans)

lemma cSUP_lessD: "bdd_above (f`A) \<Longrightarrow> (\<Squnion>i\<in>A. f i) < y \<Longrightarrow> i \<in> A \<Longrightarrow> f i < y"
  by (metis cSUP_upper le_less_trans)

lemma cINF_insert: "A \<noteq> {} \<Longrightarrow> bdd_below (f ` A) \<Longrightarrow> \<Sqinter>(f ` insert a A) = inf (f a) (\<Sqinter>(f ` A))"
  by (simp add: cInf_insert)

lemma cSUP_insert: "A \<noteq> {} \<Longrightarrow> bdd_above (f ` A) \<Longrightarrow> \<Squnion>(f ` insert a A) = sup (f a) (\<Squnion>(f ` A))"
  by (simp add: cSup_insert)

lemma cINF_mono: "B \<noteq> {} \<Longrightarrow> bdd_below (f ` A) \<Longrightarrow> (\<And>m. m \<in> B \<Longrightarrow> \<exists>n\<in>A. f n \<le> g m) \<Longrightarrow> \<Sqinter>(f ` A) \<le> \<Sqinter>(g ` B)"
  using cInf_mono [of "g ` B" "f ` A"] by auto

lemma cSUP_mono: "A \<noteq> {} \<Longrightarrow> bdd_above (g ` B) \<Longrightarrow> (\<And>n. n \<in> A \<Longrightarrow> \<exists>m\<in>B. f n \<le> g m) \<Longrightarrow> \<Squnion>(f ` A) \<le> \<Squnion>(g ` B)"
  using cSup_mono [of "f ` A" "g ` B"] by auto

lemma cINF_superset_mono: "A \<noteq> {} \<Longrightarrow> bdd_below (g ` B) \<Longrightarrow> A \<subseteq> B \<Longrightarrow> (\<And>x. x \<in> B \<Longrightarrow> g x \<le> f x) \<Longrightarrow> \<Sqinter>(g ` B) \<le> \<Sqinter>(f ` A)"
  by (rule cINF_mono) auto

lemma cSUP_subset_mono:
  "\<lbrakk>A \<noteq> {}; bdd_above (g ` B); A \<subseteq> B; \<And>x. x \<in> A \<Longrightarrow> f x \<le> g x\<rbrakk> \<Longrightarrow> \<Squnion> (f ` A) \<le> \<Squnion> (g ` B)"
  by (rule cSUP_mono) auto

lemma less_eq_cInf_inter: "bdd_below A \<Longrightarrow> bdd_below B \<Longrightarrow> A \<inter> B \<noteq> {} \<Longrightarrow> inf (Inf A) (Inf B) \<le> Inf (A \<inter> B)"
  by (metis cInf_superset_mono lattice_class.inf_sup_ord(1) le_infI1)

lemma cSup_inter_less_eq: "bdd_above A \<Longrightarrow> bdd_above B \<Longrightarrow> A \<inter> B \<noteq> {} \<Longrightarrow> Sup (A \<inter> B) \<le> sup (Sup A) (Sup B) "
  by (metis cSup_subset_mono lattice_class.inf_sup_ord(1) le_supI1)

lemma cInf_union_distrib: "A \<noteq> {} \<Longrightarrow> bdd_below A \<Longrightarrow> B \<noteq> {} \<Longrightarrow> bdd_below B \<Longrightarrow> Inf (A \<union> B) = inf (Inf A) (Inf B)"
  by (intro antisym le_infI cInf_greatest cInf_lower) (auto intro: le_infI1 le_infI2 cInf_lower)

lemma cINF_union: "A \<noteq> {} \<Longrightarrow> bdd_below (f ` A) \<Longrightarrow> B \<noteq> {} \<Longrightarrow> bdd_below (f ` B) \<Longrightarrow> \<Sqinter> (f ` (A \<union> B)) = \<Sqinter> (f ` A) \<sqinter> \<Sqinter> (f ` B)"
  using cInf_union_distrib [of "f ` A" "f ` B"] by (simp add: image_Un)

lemma cSup_union_distrib: "A \<noteq> {} \<Longrightarrow> bdd_above A \<Longrightarrow> B \<noteq> {} \<Longrightarrow> bdd_above B \<Longrightarrow> Sup (A \<union> B) = sup (Sup A) (Sup B)"
  by (intro antisym le_supI cSup_least cSup_upper) (auto intro: le_supI1 le_supI2 cSup_upper)

lemma cSUP_union: "A \<noteq> {} \<Longrightarrow> bdd_above (f ` A) \<Longrightarrow> B \<noteq> {} \<Longrightarrow> bdd_above (f ` B) \<Longrightarrow> \<Squnion> (f ` (A \<union> B)) = \<Squnion> (f ` A) \<squnion> \<Squnion> (f ` B)"
  using cSup_union_distrib [of "f ` A" "f ` B"] by (simp add: image_Un)

lemma cINF_inf_distrib: "A \<noteq> {} \<Longrightarrow> bdd_below (f`A) \<Longrightarrow> bdd_below (g`A) \<Longrightarrow> \<Sqinter> (f ` A) \<sqinter> \<Sqinter> (g ` A) = (\<Sqinter>a\<in>A. inf (f a) (g a))"
  by (intro antisym le_infI cINF_greatest cINF_lower2)
     (auto intro: le_infI1 le_infI2 cINF_greatest cINF_lower le_infI)

lemma SUP_sup_distrib: "A \<noteq> {} \<Longrightarrow> bdd_above (f`A) \<Longrightarrow> bdd_above (g`A) \<Longrightarrow> \<Squnion> (f ` A) \<squnion> \<Squnion> (g ` A) = (\<Squnion>a\<in>A. sup (f a) (g a))"
  by (intro antisym le_supI cSUP_least cSUP_upper2)
     (auto intro: le_supI1 le_supI2 cSUP_least cSUP_upper le_supI)

lemma cInf_le_cSup:
  "A \<noteq> {} \<Longrightarrow> bdd_above A \<Longrightarrow> bdd_below A \<Longrightarrow> Inf A \<le> Sup A"
  by (auto intro!: cSup_upper2[of "SOME a. a \<in> A"] intro: someI cInf_lower)

end

instance complete_lattice \<subseteq> conditionally_complete_lattice
  by standard (auto intro: Sup_upper Sup_least Inf_lower Inf_greatest)

lemma cSup_eq:
  fixes a :: "'a :: {conditionally_complete_lattice, no_bot}"
  assumes upper: "\<And>x. x \<in> X \<Longrightarrow> x \<le> a"
  assumes least: "\<And>y. (\<And>x. x \<in> X \<Longrightarrow> x \<le> y) \<Longrightarrow> a \<le> y"
  shows "Sup X = a"
proof cases
  assume "X = {}" with lt_ex[of a] least show ?thesis by (auto simp: less_le_not_le)
qed (intro cSup_eq_non_empty assms)

lemma cInf_eq:
  fixes a :: "'a :: {conditionally_complete_lattice, no_top}"
  assumes upper: "\<And>x. x \<in> X \<Longrightarrow> a \<le> x"
  assumes least: "\<And>y. (\<And>x. x \<in> X \<Longrightarrow> y \<le> x) \<Longrightarrow> y \<le> a"
  shows "Inf X = a"
proof cases
  assume "X = {}" with gt_ex[of a] least show ?thesis by (auto simp: less_le_not_le)
qed (intro cInf_eq_non_empty assms)

class conditionally_complete_linorder = conditionally_complete_lattice + linorder
begin

lemma less_cSup_iff:
  "X \<noteq> {} \<Longrightarrow> bdd_above X \<Longrightarrow> y < Sup X \<longleftrightarrow> (\<exists>x\<in>X. y < x)"
  by (rule iffI) (metis cSup_least not_less, metis cSup_upper less_le_trans)

lemma cInf_less_iff: "X \<noteq> {} \<Longrightarrow> bdd_below X \<Longrightarrow> Inf X < y \<longleftrightarrow> (\<exists>x\<in>X. x < y)"
  by (rule iffI) (metis cInf_greatest not_less, metis cInf_lower le_less_trans)

lemma cINF_less_iff: "A \<noteq> {} \<Longrightarrow> bdd_below (f`A) \<Longrightarrow> (\<Sqinter>i\<in>A. f i) < a \<longleftrightarrow> (\<exists>x\<in>A. f x < a)"
  using cInf_less_iff[of "f`A"] by auto

lemma less_cSUP_iff: "A \<noteq> {} \<Longrightarrow> bdd_above (f`A) \<Longrightarrow> a < (\<Squnion>i\<in>A. f i) \<longleftrightarrow> (\<exists>x\<in>A. a < f x)"
  using less_cSup_iff[of "f`A"] by auto

lemma less_cSupE:
  assumes "y < Sup X" "X \<noteq> {}" obtains x where "x \<in> X" "y < x"
  by (metis cSup_least assms not_le that)

lemma less_cSupD:
  "X \<noteq> {} \<Longrightarrow> z < Sup X \<Longrightarrow> \<exists>x\<in>X. z < x"
  by (metis less_cSup_iff not_le_imp_less bdd_above_def)

lemma cInf_lessD:
  "X \<noteq> {} \<Longrightarrow> Inf X < z \<Longrightarrow> \<exists>x\<in>X. x < z"
  by (metis cInf_less_iff not_le_imp_less bdd_below_def)

lemma complete_interval:
  assumes "a < b" and "P a" and "\<not> P b"
  shows "\<exists>c. a \<le> c \<and> c \<le> b \<and> (\<forall>x. a \<le> x \<and> x < c \<longrightarrow> P x) \<and>
             (\<forall>d. (\<forall>x. a \<le> x \<and> x < d \<longrightarrow> P x) \<longrightarrow> d \<le> c)"
proof (rule exI [where x = "Sup {d. \<forall>x. a \<le> x \<and> x < d \<longrightarrow> P x}"], auto)
  show "a \<le> Sup {d. \<forall>c. a \<le> c \<and> c < d \<longrightarrow> P c}"
    by (rule cSup_upper, auto simp: bdd_above_def)
       (metis \<open>a < b\<close> \<open>\<not> P b\<close> linear less_le)
next
  show "Sup {d. \<forall>c. a \<le> c \<and> c < d \<longrightarrow> P c} \<le> b"
    apply (rule cSup_least)
    apply auto
    apply (metis less_le_not_le)
    apply (metis \<open>a<b\<close> \<open>\<not> P b\<close> linear less_le)
    done
next
  fix x
  assume x: "a \<le> x" and lt: "x < Sup {d. \<forall>c. a \<le> c \<and> c < d \<longrightarrow> P c}"
  show "P x"
    apply (rule less_cSupE [OF lt], auto)
    apply (metis less_le_not_le)
    apply (metis x)
    done
next
  fix d
    assume 0: "\<forall>x. a \<le> x \<and> x < d \<longrightarrow> P x"
    thus "d \<le> Sup {d. \<forall>c. a \<le> c \<and> c < d \<longrightarrow> P c}"
      by (rule_tac cSup_upper, auto simp: bdd_above_def)
         (metis \<open>a<b\<close> \<open>\<not> P b\<close> linear less_le)
qed

end

instance complete_linorder < conditionally_complete_linorder
  ..

lemma cSup_eq_Max: "finite (X::'a::conditionally_complete_linorder set) \<Longrightarrow> X \<noteq> {} \<Longrightarrow> Sup X = Max X"
  using cSup_eq_Sup_fin[of X] by (simp add: Sup_fin_Max)

lemma cInf_eq_Min: "finite (X::'a::conditionally_complete_linorder set) \<Longrightarrow> X \<noteq> {} \<Longrightarrow> Inf X = Min X"
  using cInf_eq_Inf_fin[of X] by (simp add: Inf_fin_Min)

lemma cSup_lessThan[simp]: "Sup {..<x::'a::{conditionally_complete_linorder, no_bot, dense_linorder}} = x"
  by (auto intro!: cSup_eq_non_empty intro: dense_le)

lemma cSup_greaterThanLessThan[simp]: "y < x \<Longrightarrow> Sup {y<..<x::'a::{conditionally_complete_linorder, dense_linorder}} = x"
  by (auto intro!: cSup_eq_non_empty intro: dense_le_bounded)

lemma cSup_atLeastLessThan[simp]: "y < x \<Longrightarrow> Sup {y..<x::'a::{conditionally_complete_linorder, dense_linorder}} = x"
  by (auto intro!: cSup_eq_non_empty intro: dense_le_bounded)

lemma cInf_greaterThan[simp]: "Inf {x::'a::{conditionally_complete_linorder, no_top, dense_linorder} <..} = x"
  by (auto intro!: cInf_eq_non_empty intro: dense_ge)

lemma cInf_greaterThanAtMost[simp]: "y < x \<Longrightarrow> Inf {y<..x::'a::{conditionally_complete_linorder, dense_linorder}} = y"
  by (auto intro!: cInf_eq_non_empty intro: dense_ge_bounded)

lemma cInf_greaterThanLessThan[simp]: "y < x \<Longrightarrow> Inf {y<..<x::'a::{conditionally_complete_linorder, dense_linorder}} = y"
  by (auto intro!: cInf_eq_non_empty intro: dense_ge_bounded)

lemma Inf_insert_finite:
  fixes S :: "'a::conditionally_complete_linorder set"
  shows "finite S \<Longrightarrow> Inf (insert x S) = (if S = {} then x else min x (Inf S))"
  by (simp add: cInf_eq_Min)

lemma Sup_insert_finite:
  fixes S :: "'a::conditionally_complete_linorder set"
  shows "finite S \<Longrightarrow> Sup (insert x S) = (if S = {} then x else max x (Sup S))"
  by (simp add: cSup_insert sup_max)

lemma finite_imp_less_Inf:
  fixes a :: "'a::conditionally_complete_linorder"
  shows "\<lbrakk>finite X; x \<in> X; \<And>x. x\<in>X \<Longrightarrow> a < x\<rbrakk> \<Longrightarrow> a < Inf X"
  by (induction X rule: finite_induct) (simp_all add: cInf_eq_Min Inf_insert_finite)

lemma finite_less_Inf_iff:
  fixes a :: "'a :: conditionally_complete_linorder"
  shows "\<lbrakk>finite X; X \<noteq> {}\<rbrakk> \<Longrightarrow> a < Inf X \<longleftrightarrow> (\<forall>x \<in> X. a < x)"
  by (auto simp: cInf_eq_Min)

lemma finite_imp_Sup_less:
  fixes a :: "'a::conditionally_complete_linorder"
  shows "\<lbrakk>finite X; x \<in> X; \<And>x. x\<in>X \<Longrightarrow> a > x\<rbrakk> \<Longrightarrow> a > Sup X"
  by (induction X rule: finite_induct) (simp_all add: cSup_eq_Max Sup_insert_finite)

lemma finite_Sup_less_iff:
  fixes a :: "'a :: conditionally_complete_linorder"
  shows "\<lbrakk>finite X; X \<noteq> {}\<rbrakk> \<Longrightarrow> a > Sup X \<longleftrightarrow> (\<forall>x \<in> X. a > x)"
  by (auto simp: cSup_eq_Max)

class linear_continuum = conditionally_complete_linorder + dense_linorder +
  assumes UNIV_not_singleton: "\<exists>a b::'a. a \<noteq> b"
begin

lemma ex_gt_or_lt: "\<exists>b. a < b \<or> b < a"
  by (metis UNIV_not_singleton neq_iff)

end

instantiation nat :: conditionally_complete_linorder
begin

definition "Sup (X::nat set) = (if X={} then 0 else Max X)"
definition "Inf (X::nat set) = (LEAST n. n \<in> X)"

lemma bdd_above_nat: "bdd_above X \<longleftrightarrow> finite (X::nat set)"
proof
  assume "bdd_above X"
  then obtain z where "X \<subseteq> {.. z}"
    by (auto simp: bdd_above_def)
  then show "finite X"
    by (rule finite_subset) simp
qed simp

instance
proof
  fix x :: nat
  fix X :: "nat set"
  show "Inf X \<le> x" if "x \<in> X" "bdd_below X"
    using that by (simp add: Inf_nat_def Least_le)
  show "x \<le> Inf X" if "X \<noteq> {}" "\<And>y. y \<in> X \<Longrightarrow> x \<le> y"
    using that unfolding Inf_nat_def ex_in_conv[symmetric] by (rule LeastI2_ex)
  show "x \<le> Sup X" if "x \<in> X" "bdd_above X"
    using that by (auto simp add: Sup_nat_def bdd_above_nat)
  show "Sup X \<le> x" if "X \<noteq> {}" "\<And>y. y \<in> X \<Longrightarrow> y \<le> x"
  proof -
    from that have "bdd_above X"
      by (auto simp: bdd_above_def)
    with that show ?thesis
      by (simp add: Sup_nat_def bdd_above_nat)
  qed
qed

end

lemma Inf_nat_def1:
  fixes K::"nat set"
  assumes "K \<noteq> {}"
  shows "Inf K \<in> K"
by (auto simp add: Min_def Inf_nat_def) (meson LeastI assms bot.extremum_unique subsetI)

lemma Sup_nat_empty [simp]: "Sup {} = (0::nat)"
  by (auto simp add: Sup_nat_def)

instantiation int :: conditionally_complete_linorder
begin

definition "Sup (X::int set) = (THE x. x \<in> X \<and> (\<forall>y\<in>X. y \<le> x))"
definition "Inf (X::int set) = - (Sup (uminus ` X))"

instance
proof
  { fix x :: int and X :: "int set" assume "X \<noteq> {}" "bdd_above X"
    then obtain x y where "X \<subseteq> {..y}" "x \<in> X"
      by (auto simp: bdd_above_def)
    then have *: "finite (X \<inter> {x..y})" "X \<inter> {x..y} \<noteq> {}" and "x \<le> y"
      by (auto simp: subset_eq)
    have "\<exists>!x\<in>X. (\<forall>y\<in>X. y \<le> x)"
    proof
      { fix z assume "z \<in> X"
        have "z \<le> Max (X \<inter> {x..y})"
        proof cases
          assume "x \<le> z" with \<open>z \<in> X\<close> \<open>X \<subseteq> {..y}\<close> *(1) show ?thesis
            by (auto intro!: Max_ge)
        next
          assume "\<not> x \<le> z"
          then have "z < x" by simp
          also have "x \<le> Max (X \<inter> {x..y})"
            using \<open>x \<in> X\<close> *(1) \<open>x \<le> y\<close> by (intro Max_ge) auto
          finally show ?thesis by simp
        qed }
      note le = this
      with Max_in[OF *] show ex: "Max (X \<inter> {x..y}) \<in> X \<and> (\<forall>z\<in>X. z \<le> Max (X \<inter> {x..y}))" by auto

      fix z assume *: "z \<in> X \<and> (\<forall>y\<in>X. y \<le> z)"
      with le have "z \<le> Max (X \<inter> {x..y})"
        by auto
      moreover have "Max (X \<inter> {x..y}) \<le> z"
        using * ex by auto
      ultimately show "z = Max (X \<inter> {x..y})"
        by auto
    qed
    then have "Sup X \<in> X \<and> (\<forall>y\<in>X. y \<le> Sup X)"
      unfolding Sup_int_def by (rule theI') }
  note Sup_int = this

  { fix x :: int and X :: "int set" assume "x \<in> X" "bdd_above X" then show "x \<le> Sup X"
      using Sup_int[of X] by auto }
  note le_Sup = this
  { fix x :: int and X :: "int set" assume "X \<noteq> {}" "\<And>y. y \<in> X \<Longrightarrow> y \<le> x" then show "Sup X \<le> x"
      using Sup_int[of X] by (auto simp: bdd_above_def) }
  note Sup_le = this

  { fix x :: int and X :: "int set" assume "x \<in> X" "bdd_below X" then show "Inf X \<le> x"
      using le_Sup[of "-x" "uminus ` X"] by (auto simp: Inf_int_def) }
  { fix x :: int and X :: "int set" assume "X \<noteq> {}" "\<And>y. y \<in> X \<Longrightarrow> x \<le> y" then show "x \<le> Inf X"
      using Sup_le[of "uminus ` X" "-x"] by (force simp: Inf_int_def) }
qed
end

lemma interval_cases:
  fixes S :: "'a :: conditionally_complete_linorder set"
  assumes ivl: "\<And>a b x. a \<in> S \<Longrightarrow> b \<in> S \<Longrightarrow> a \<le> x \<Longrightarrow> x \<le> b \<Longrightarrow> x \<in> S"
  shows "\<exists>a b. S = {} \<or>
    S = UNIV \<or>
    S = {..<b} \<or>
    S = {..b} \<or>
    S = {a<..} \<or>
    S = {a..} \<or>
    S = {a<..<b} \<or>
    S = {a<..b} \<or>
    S = {a..<b} \<or>
    S = {a..b}"
proof -
  define lower upper where "lower = {x. \<exists>s\<in>S. s \<le> x}" and "upper = {x. \<exists>s\<in>S. x \<le> s}"
  with ivl have "S = lower \<inter> upper"
    by auto
  moreover
  have "\<exists>a. upper = UNIV \<or> upper = {} \<or> upper = {.. a} \<or> upper = {..< a}"
  proof cases
    assume *: "bdd_above S \<and> S \<noteq> {}"
    from * have "upper \<subseteq> {.. Sup S}"
      by (auto simp: upper_def intro: cSup_upper2)
    moreover from * have "{..< Sup S} \<subseteq> upper"
      by (force simp add: less_cSup_iff upper_def subset_eq Ball_def)
    ultimately have "upper = {.. Sup S} \<or> upper = {..< Sup S}"
      unfolding ivl_disj_un(2)[symmetric] by auto
    then show ?thesis by auto
  next
    assume "\<not> (bdd_above S \<and> S \<noteq> {})"
    then have "upper = UNIV \<or> upper = {}"
      by (auto simp: upper_def bdd_above_def not_le dest: less_imp_le)
    then show ?thesis
      by auto
  qed
  moreover
  have "\<exists>b. lower = UNIV \<or> lower = {} \<or> lower = {b ..} \<or> lower = {b <..}"
  proof cases
    assume *: "bdd_below S \<and> S \<noteq> {}"
    from * have "lower \<subseteq> {Inf S ..}"
      by (auto simp: lower_def intro: cInf_lower2)
    moreover from * have "{Inf S <..} \<subseteq> lower"
      by (force simp add: cInf_less_iff lower_def subset_eq Ball_def)
    ultimately have "lower = {Inf S ..} \<or> lower = {Inf S <..}"
      unfolding ivl_disj_un(1)[symmetric] by auto
    then show ?thesis by auto
  next
    assume "\<not> (bdd_below S \<and> S \<noteq> {})"
    then have "lower = UNIV \<or> lower = {}"
      by (auto simp: lower_def bdd_below_def not_le dest: less_imp_le)
    then show ?thesis
      by auto
  qed
  ultimately show ?thesis
    unfolding greaterThanAtMost_def greaterThanLessThan_def atLeastAtMost_def atLeastLessThan_def
    by (metis inf_bot_left inf_bot_right inf_top.left_neutral inf_top.right_neutral)
qed

lemma cSUP_eq_cINF_D:
  fixes f :: "_ \<Rightarrow> 'b::conditionally_complete_lattice"
  assumes eq: "(\<Squnion>x\<in>A. f x) = (\<Sqinter>x\<in>A. f x)"
     and bdd: "bdd_above (f ` A)" "bdd_below (f ` A)"
     and a: "a \<in> A"
  shows "f a = (\<Sqinter>x\<in>A. f x)"
apply (rule antisym)
using a bdd
apply (auto simp: cINF_lower)
apply (metis eq cSUP_upper)
done

lemma cSUP_UNION:
  fixes f :: "_ \<Rightarrow> 'b::conditionally_complete_lattice"
  assumes ne: "A \<noteq> {}" "\<And>x. x \<in> A \<Longrightarrow> B(x) \<noteq> {}"
      and bdd_UN: "bdd_above (\<Union>x\<in>A. f ` B x)"
  shows "(\<Squnion>z \<in> \<Union>x\<in>A. B x. f z) = (\<Squnion>x\<in>A. \<Squnion>z\<in>B x. f z)"
proof -
  have bdd: "\<And>x. x \<in> A \<Longrightarrow> bdd_above (f ` B x)"
    using bdd_UN by (meson UN_upper bdd_above_mono)
  obtain M where "\<And>x y. x \<in> A \<Longrightarrow> y \<in> B(x) \<Longrightarrow> f y \<le> M"
    using bdd_UN by (auto simp: bdd_above_def)
  then have bdd2: "bdd_above ((\<lambda>x. \<Squnion>z\<in>B x. f z) ` A)"
    unfolding bdd_above_def by (force simp: bdd cSUP_le_iff ne(2))
  have "(\<Squnion>z \<in> \<Union>x\<in>A. B x. f z) \<le> (\<Squnion>x\<in>A. \<Squnion>z\<in>B x. f z)"
    using assms by (fastforce simp add: intro!: cSUP_least intro: cSUP_upper2 simp: bdd2 bdd)
  moreover have "(\<Squnion>x\<in>A. \<Squnion>z\<in>B x. f z) \<le> (\<Squnion> z \<in> \<Union>x\<in>A. B x. f z)"
    using assms by (fastforce simp add: intro!: cSUP_least intro: cSUP_upper simp: image_UN bdd_UN)
  ultimately show ?thesis
    by (rule order_antisym)
qed

lemma cINF_UNION:
  fixes f :: "_ \<Rightarrow> 'b::conditionally_complete_lattice"
  assumes ne: "A \<noteq> {}" "\<And>x. x \<in> A \<Longrightarrow> B(x) \<noteq> {}"
      and bdd_UN: "bdd_below (\<Union>x\<in>A. f ` B x)"
  shows "(\<Sqinter>z \<in> \<Union>x\<in>A. B x. f z) = (\<Sqinter>x\<in>A. \<Sqinter>z\<in>B x. f z)"
proof -
  have bdd: "\<And>x. x \<in> A \<Longrightarrow> bdd_below (f ` B x)"
    using bdd_UN by (meson UN_upper bdd_below_mono)
  obtain M where "\<And>x y. x \<in> A \<Longrightarrow> y \<in> B(x) \<Longrightarrow> f y \<ge> M"
    using bdd_UN by (auto simp: bdd_below_def)
  then have bdd2: "bdd_below ((\<lambda>x. \<Sqinter>z\<in>B x. f z) ` A)"
    unfolding bdd_below_def by (force simp: bdd le_cINF_iff ne(2))
  have "(\<Sqinter>z \<in> \<Union>x\<in>A. B x. f z) \<le> (\<Sqinter>x\<in>A. \<Sqinter>z\<in>B x. f z)"
    using assms by (fastforce simp add: intro!: cINF_greatest intro: cINF_lower simp: bdd2 bdd)
  moreover have "(\<Sqinter>x\<in>A. \<Sqinter>z\<in>B x. f z) \<le> (\<Sqinter>z \<in> \<Union>x\<in>A. B x. f z)"
    using assms  by (fastforce simp add: intro!: cINF_greatest intro: cINF_lower2  simp: bdd bdd_UN bdd2)
  ultimately show ?thesis
    by (rule order_antisym)
qed

lemma cSup_abs_le:
  fixes S :: "('a::{linordered_idom,conditionally_complete_linorder}) set"
  shows "S \<noteq> {} \<Longrightarrow> (\<And>x. x\<in>S \<Longrightarrow> \<bar>x\<bar> \<le> a) \<Longrightarrow> \<bar>Sup S\<bar> \<le> a"
  apply (auto simp add: abs_le_iff intro: cSup_least)
  by (metis bdd_aboveI cSup_upper neg_le_iff_le order_trans)

end