theory wp1_incorrectness imports pl1 regular_interpretation fixed_points HOL.Complete_Partial_Order
begin

section \<open>instantiate fixed point theory\<close>

interpretation power_set_Fix_Lim_Ord \<open>{} :: (string \<Rightarrow> int) set\<close>
proof
  have \<open>infinite (UNIV :: (string \<Rightarrow> int) set)\<close>
    using finite_fun_UNIVD2 infinite_UNIV_char_0 by auto
  then show \<open>infinite (UNIV :: (string \<Rightarrow> int) set set)\<close>
    by (simp add: Finite_Set.finite_set)
qed

lemma xfmax:
  \<open>x \<in> under ( |UNIV| ) (max2 ( |UNIV| ) x y)\<close>
  using Field_card_of UNIV_I wo_rel.max2_def Refl_under_in card_of_well_order_on in_mono under_incr wo_rel.REFL wo_rel.TRANS wo_rel_def
  by metis
lemma yfmax:
  \<open>y \<in> under ( |UNIV| ) (max2 ( |UNIV| ) x y)\<close>
  using Field_card_of UNIV_I wo_rel.max2_def Refl_under_in card_of_well_order_on in_mono under_incr wo_rel.REFL wo_rel.TRANS wo_rel_def wo_rel.max2_equals1
  by metis

lemma fsucc: \<open>mono f \<Longrightarrow> iter f ({} :: (string \<Rightarrow> int) set) (Fix\<delta> f {}) = iter f {} (succ ( |UNIV| ) (Fix\<delta> f {}))\<close>
  using Fix_in_Field_and_fixed by simp

lemma fmax: \<open>mono f \<Longrightarrow> iter f {} (Fix\<delta> f {}) =
    iter f {} (max2 ( |UNIV| ) (Fix\<delta> f ({} :: (string \<Rightarrow> int) set)) n)\<close>
  using fsucc xfmax reach_fixpoint_above by (metis empty_subsetI)
lemma gmax: \<open>mono g \<Longrightarrow> iter g {} (Fix\<delta> g {}) =
    iter g {} (max2 ( |UNIV| ) n (Fix\<delta> g ({} :: (string \<Rightarrow> int) set)))\<close>
  using fsucc yfmax reach_fixpoint_above by (metis empty_subsetI)

section \<open>weakest precondition\<close>

fun wpst where (*weakest postcondition for total incorrectness*)
  \<open>wpst p (Assert r) = p \<inter> {i. i \<^bold>\<Turnstile> r}\<close> |
  \<open>wpst p (Var x) = {i. \<exists> v. i(x := v) \<in> p}\<close> |
  \<open>wpst p (Assign x a) = (\<lambda> i. i(x := i\<lparr>a\<rparr>)) ` p\<close> |
  \<open>wpst p (Choice s1 s2) = wpst p s1 \<union> wpst p s2\<close> |
  \<open>wpst p (Seq s1 s2) = wpst (wpst p s1) s2\<close> |
  \<open>wpst p (If b s1 s2) = wpst (p \<inter> {i. i \<^bold>\<Turnstile> b}) s1 \<union> wpst (p \<inter> {i. \<not>i \<^bold>\<Turnstile> b}) s2\<close> |
  \<open>wpst p (While b I s) = (\<Union> n. ((\<lambda> x. x \<union> wpst (x \<inter> {i. i \<^bold>\<Turnstile> b}) s) ^^ n) p) \<inter> {i. \<not>i \<^bold>\<Turnstile> b}\<close> |
  \<open>wpst p (Ghost s) = wpst p s\<close>

lemma wpst_mono: \<open>mono (\<lambda> q. wpst q s)\<close>
proof (rule monoI, induct rule: wpst.induct)
  case (4 p s1 s2)
  then show ?case
    by (simp add: le_supI1 le_supI2)
next
  case (6 p b s1 s2)
  then have \<open>(x \<inter> {i. i \<^bold>\<Turnstile> b}) \<subseteq> (y \<inter> {i. i \<^bold>\<Turnstile> b})\<close> \<open>(x \<inter> {i. \<not>i \<^bold>\<Turnstile> b}) \<subseteq> (y \<inter> {i. \<not>i \<^bold>\<Turnstile> b})\<close>
    by auto
  then have \<open>wpst (x \<inter> {i. i \<^bold>\<Turnstile> b}) s1 \<subseteq> wpst (y \<inter> {i. i \<^bold>\<Turnstile> b}) s1\<close> \<open>wpst (x \<inter> {i. \<not>i \<^bold>\<Turnstile> b}) s2 \<subseteq> wpst (y \<inter> {i. \<not>i \<^bold>\<Turnstile> b}) s2\<close>
    using 6 by auto
  then show ?case
    by auto
next
  case (7 p b I s)
  have \<open>((\<lambda> x. x \<union> wpst (x \<inter> {i. i \<^bold>\<Turnstile> b}) s) ^^ n) x \<subseteq> ((\<lambda> x. x \<union> wpst (x \<inter> {i. i \<^bold>\<Turnstile> b}) s) ^^ n) y\<close> for n
  proof (induct n)
    case 0
    then show ?case
      using 7 by simp
  next
    case (Suc n)
    let ?x = \<open>((\<lambda>x. x \<union> wpst (x \<inter> {i. i \<^bold>\<Turnstile> b}) s) ^^ n) x\<close>
    let ?y = \<open>((\<lambda>x. x \<union> wpst (x \<inter> {i. i \<^bold>\<Turnstile> b}) s) ^^ n) y\<close>
    from Suc have \<open>?x \<inter> {i. i \<^bold>\<Turnstile> b} \<subseteq> ?y \<inter> {i. i \<^bold>\<Turnstile> b}\<close>
      by auto
    then have \<open>wpst (?x \<inter> {i. i \<^bold>\<Turnstile> b}) s \<subseteq> wpst (?y \<inter> {i. i \<^bold>\<Turnstile> b}) s\<close>
      using 7 by auto
    then have \<open>?x \<union> wpst (?x \<inter> {i. i \<^bold>\<Turnstile> b}) s \<subseteq> ?y \<union> wpst (?y \<inter> {i. i \<^bold>\<Turnstile> b}) s\<close>
      using Suc by auto
    then show ?case
      by auto
  qed
  then show ?case
    by auto
qed auto

primrec erase_ghost where
  \<open>erase_ghost (Assert b) = Assert b\<close> |
  \<open>erase_ghost (Var x) = Var x\<close> |
  \<open>erase_ghost (Assign x a) = Assign x a\<close> |
  \<open>erase_ghost (Choice s1 s2) = Choice (erase_ghost s1) (erase_ghost s2)\<close> |
  \<open>erase_ghost (Seq s1 s2) = Seq (erase_ghost s1) (erase_ghost s2)\<close> |
  \<open>erase_ghost (If b s1 s2) = If b (erase_ghost s1) (erase_ghost s2)\<close> |
  \<open>erase_ghost (While b I s) = While b I (erase_ghost s)\<close> |
  \<open>erase_ghost (Ghost s) = Assign (''x'') (V ''x'')\<close> (*needed to change definition of skip because of assert_check*)

primrec gc_check where
  \<open>gc_check g (Assert b) = True\<close> |
  \<open>gc_check g (Var x) = g x\<close> |
  \<open>gc_check g (Assign x a) = g x\<close> |
  \<open>gc_check g (Choice s1 s2) = (gc_check g s1 \<and> gc_check g s2)\<close> |
  \<open>gc_check g (Seq s1 s2) = (gc_check g s1 \<and> gc_check g s2)\<close> |
  \<open>gc_check g (If b s1 s2) = (gc_check g s1 \<and> gc_check g s2)\<close> |
  \<open>gc_check g (While b I s) = (gc_check g s)\<close> |
  \<open>gc_check g (Ghost s) = gc_check g s\<close>

lemma gc_check_lemma: \<open>gc_check g s \<Longrightarrow> regular_s g q \<Longrightarrow> p \<subseteq> q \<Longrightarrow> wpst p s \<subseteq> q\<close>
proof (induct s arbitrary: p q)
  case (Var x)
  {
    fix i v
    assume \<open>i(x := v) \<in> p\<close>
    then have \<open>i (x := v) \<in> q\<close>
      using Var by auto
    then have \<open>i \<in> q\<close>
      using Var(1,2) by (simp add: regular_alt)
  }
  then show ?case
    by auto
next
  case (Assign x a)
  {
    fix i
    assume \<open>i \<in> p\<close>
    then have \<open>i \<in> q\<close>
      using Assign by auto
    then have \<open>i(x := i\<lparr>a\<rparr>) \<in> q\<close>
      using Assign(1,2) by (simp add: regular_alt)
  }
  then show ?case
    by auto
next
  case (Seq s1 s2)
  then have \<open>wpst p s1 \<subseteq> q\<close>
    by simp
  then have \<open>wpst (wpst p s1) s2 \<subseteq> wpst q s2\<close>
    using wpst_mono monoD by blast
  moreover have \<open>... \<subseteq> q\<close>
    using Seq by simp
  ultimately show ?case
    by simp
next
  case (If b s1 s2)
  then have \<open>wpst p s1 \<subseteq> q\<close> \<open>wpst p s2 \<subseteq> q\<close>
    by simp_all
  moreover have \<open>wpst (p \<inter> {i. i \<^bold>\<Turnstile> b}) s1 \<subseteq> wpst p s1\<close> \<open>wpst (p \<inter> {i. \<not>i \<^bold>\<Turnstile> b}) s2 \<subseteq> wpst p s2\<close>
    using wpst_mono monoD by blast+
  ultimately show ?case
    by auto
next
  case (While b I s)
  have \<open>((\<lambda> x. x \<union> wpst (x \<inter> {i. i \<^bold>\<Turnstile> b}) s) ^^ n) p \<subseteq> q\<close> for n
  proof (induct n)
    case 0
    then show ?case
      using While by simp
  next
    case (Suc n)
    let ?pn = \<open>((\<lambda> x. x \<union> wpst (x \<inter> {i. i \<^bold>\<Turnstile> b}) s) ^^ n) p\<close>
    from Suc have \<open>?pn \<inter> {i. i \<^bold>\<Turnstile> b} \<subseteq> q\<close>
      by auto
    then have \<open>wpst (?pn \<inter> {i. i \<^bold>\<Turnstile> b}) s \<subseteq> q\<close>
      using While by simp
    then show ?case
      using Suc by simp
  qed
  then show ?case
    by auto
qed auto

primrec rc_check where
  \<open>rc_check g (Assert b) = regular_p g b\<close> |
  \<open>rc_check g (Var x) = True\<close> |
  \<open>rc_check g (Assign x a) = (\<not>g x \<and> regular_a g a)\<close> |
  \<open>rc_check g (Choice s1 s2) = (rc_check g s1 \<and> rc_check g s2)\<close> |
  \<open>rc_check g (Seq s1 s2) = (rc_check g s1 \<and> rc_check g s2)\<close> |
  \<open>rc_check g (If b s1 s2) = (regular_p g b \<and> rc_check g s1 \<and> rc_check g s2)\<close> |
  \<open>rc_check g (While b I s) = (regular_p g b \<and> rc_check g s)\<close> |
  \<open>rc_check g (Ghost s) = gc_check g s\<close>

lemma rc_regular: \<open>rc_check g s \<Longrightarrow> regular_s g p \<Longrightarrow> regular_s g (wpst p (erase_ghost s))\<close>
proof (induct s arbitrary: p)
  case (Assert q)
  then show ?case
    by (metis Int_iff rc_check.simps(1) regular_p_then_regular_s wpst.simps(1) erase_ghost.simps(1))
next
  case (Var x)
  {
    fix i j :: \<open>char list \<Rightarrow> int\<close>
    assume \<open>i \<^bold>\<down> g = j \<^bold>\<down> g\<close>
    assume \<open>\<exists> v. i(x := v) \<in> p\<close>
    then obtain v where \<open>i(x := v) \<in> p\<close>
      by auto
    moreover have \<open>i(x := v) \<^bold>\<down> g = j(x := v) \<^bold>\<down> g\<close>
      using \<open>i \<^bold>\<down> g = j \<^bold>\<down> g\<close> by (simp add: regular_alt)
    ultimately have \<open>j(x := v) \<in> p\<close>
      using Var.prems(2) by blast
    then have \<open>\<exists> v. j(x := v) \<in> p\<close>
      by auto
  }
  then show ?case
    by auto
next
  case (Assign x a)
  {
    fix i j :: \<open>char list \<Rightarrow> int\<close>
    assume \<open>i \<in> (\<lambda> i. i(x := i\<lparr>a\<rparr>)) ` p\<close>
    then obtain i' where \<open>i' \<in> p\<close> \<open>i'(x := i'\<lparr>a\<rparr>) = i\<close>
      by auto
    moreover assume \<open>i \<^bold>\<down> g = j \<^bold>\<down> g\<close>
    ultimately have *: \<open>i' \<^bold>\<down> g = j(x := i' x) \<^bold>\<down> g\<close>
      by (smt (verit) fun_upd_apply regular_alt)
    then have \<open>j(x := i' x) \<in> p\<close>
      using \<open>i' \<in> p\<close> Assign by auto
    with * have \<open>j(x := (j(x := i' x)) \<lparr>a\<rparr>) \<in> (\<lambda> i. i(x := i\<lparr>a\<rparr>)) ` p\<close>
      using Assign by (metis (mono_tags, lifting) fun_upd_upd image_iff)
    moreover have \<open>j(x := (j(x := i' x)) \<lparr>a\<rparr>) = j\<close>
      using \<open>i'(x := i'\<lparr>a\<rparr>) = i\<close> \<open>i \<^bold>\<down> g = j \<^bold>\<down> g\<close> Assign
      by (metis (mono_tags, lifting) "*" fun_upd_idem fun_upd_same rc_check.simps(3) regular_agree_aexp regular_alt)
    ultimately have \<open>j \<in> (\<lambda> i. i(x := i\<lparr>a\<rparr>)) ` p\<close>
      by simp
  }
  then show ?case
    by auto
next
  case (Seq s1 s2)
  then have \<open>regular_s g (wpst p (erase_ghost s1))\<close>
    by simp
  then have \<open>regular_s g (wpst (wpst p (erase_ghost s1)) (erase_ghost s2))\<close>
    using Seq by (meson rc_check.simps(5))
  then show ?case
    by simp
next
  case (Choice s1 s2)
  then have \<open>regular_s g (wpst p (erase_ghost s1))\<close> \<open>regular_s g (wpst p (erase_ghost s2))\<close>
    by auto
  then show ?case
    by (metis Un_iff erase_ghost.simps(4) wpst.simps(4))
next
  case (If b s1 s2)
  then have \<open>regular_s g (p \<inter> {i. i \<^bold>\<Turnstile> b})\<close> \<open>regular_s g (p \<inter> {i. \<not>i \<^bold>\<Turnstile> b})\<close>
    by (metis Int_Collect rc_check.simps(6) regular_agree_pexp)+
  with If have \<open>regular_s g (wpst (p \<inter> {i. i \<^bold>\<Turnstile> b}) (erase_ghost s1))\<close> \<open>regular_s g (wpst (p \<inter> {i. \<not>i \<^bold>\<Turnstile> b}) (erase_ghost s2))\<close>
    by (smt (verit, best) rc_check.simps(6))+
  moreover have \<open>regular_s g x \<Longrightarrow> regular_s g y \<Longrightarrow> regular_s g (x \<union> y)\<close> for x y :: \<open>(string \<Rightarrow> int) set\<close>
    by blast
  ultimately show ?case
    using erase_ghost.simps(6) wpst.simps(6) by presburger
next
  case (While b I s)
  define \<Phi> where \<open>\<Phi> \<equiv> \<lambda> n. ((\<lambda> x. x \<union> wpst (x \<inter> {i. i \<^bold>\<Turnstile> b}) (erase_ghost s)) ^^ n) p\<close>
  have *: \<open>regular_s g (\<Phi> n)\<close> for n
  proof (induct n)
    case 0
    then show ?case
      unfolding \<Phi>_def using While by simp
  next
    case (Suc n)
    then have \<open>regular_s g (\<Phi> n \<inter> {i. i \<^bold>\<Turnstile> b})\<close>
      using While by (metis Int_Collect rc_check.simps(7) regular_agree_pexp)
    then have \<open>regular_s g (wpst (\<Phi> n \<inter> {i. i \<^bold>\<Turnstile> b}) (erase_ghost s))\<close>
      using While rc_check.simps(7) by blast
    then have \<open>regular_s g (\<Phi> n \<union> wpst (\<Phi> n \<inter> {i. i \<^bold>\<Turnstile> b}) (erase_ghost s))\<close>
      using Suc by auto
    then show ?case
      unfolding \<Phi>_def by simp
  qed
  {
    fix i j :: \<open>char list \<Rightarrow> int\<close>
    assume \<open>i \<^bold>\<down> g = j \<^bold>\<down> g\<close>
    assume \<open>i \<in> (\<Union> n. \<Phi> n) \<inter> {i. \<not>i \<^bold>\<Turnstile> b}\<close>
    then obtain n where \<open>i \<in> \<Phi> n\<close>
      by auto
    then have \<open>j \<in> \<Phi> n\<close>
      using * \<open>i \<^bold>\<down> g = j \<^bold>\<down> g\<close> by simp
    from \<open>i \<in> (\<Union> n. \<Phi> n) \<inter> {i. \<not>i \<^bold>\<Turnstile> b}\<close> have \<open>\<not>i \<^bold>\<Turnstile> b\<close>
      by simp
    then have \<open>\<not>j \<^bold>\<Turnstile> b\<close>
      using \<open>i \<^bold>\<down> g = j \<^bold>\<down> g\<close> While(2) by (simp add: regular_agree_pexp)
    with \<open>j \<in> \<Phi> n\<close> have \<open>j \<in> (\<Union> n. \<Phi> n) \<inter> {i. \<not>i \<^bold>\<Turnstile> b}\<close>
      by auto
  }
  then have \<open>regular_s g ((\<Union> n. ((\<lambda> x. x \<union> wpst (x \<inter> {i. i \<^bold>\<Turnstile> b}) (erase_ghost s)) ^^ n) p) \<inter> {i. \<not>i \<^bold>\<Turnstile> b})\<close>
    unfolding \<Phi>_def by blast
  then show ?case
    using erase_ghost.simps(7) wpst.simps(7) by presburger
next
  case (Ghost s)
  moreover have \<open>(wpst p (erase_ghost (\<^bold>g s))) = p\<close>
    by simp
  ultimately show ?case
    by simp
qed

lemma rc_check_lemma: \<open>rc_check g s \<Longrightarrow> regular_s g q \<Longrightarrow> p \<subseteq> q \<Longrightarrow> wpst p s \<subseteq> wpst q (erase_ghost s)\<close>
proof (induct s arbitrary: p q)
  case (Seq s1 s2)
  then have \<open>wpst p s1 \<subseteq> wpst q (erase_ghost s1)\<close>
    by simp
  moreover have \<open>regular_s g (wpst q (erase_ghost s1))\<close>
    by (meson Seq.prems(1) Seq.prems(2) rc_check.simps(5) rc_regular)
  ultimately show ?case
    using Seq by simp
next
  case (Choice s1 s2)
  then have \<open>wpst p s1 \<subseteq> wpst q (erase_ghost s1)\<close> \<open>wpst p s2 \<subseteq> wpst q (erase_ghost s2)\<close>
    by simp_all
  then show ?case
    by auto
next
  case (If b s1 s2)
  then have \<open>regular_s g (q \<inter> {i. i \<^bold>\<Turnstile> b})\<close> \<open>regular_s g (q \<inter> {i. \<not>i \<^bold>\<Turnstile> b})\<close>
    by (metis Int_Collect rc_check.simps(6) regular_agree_pexp)+
  moreover have \<open>p \<inter> {i. i \<^bold>\<Turnstile> b} \<subseteq> q \<inter> {i. i \<^bold>\<Turnstile> b}\<close> \<open>p \<inter> {i. \<not>i \<^bold>\<Turnstile> b} \<subseteq> q \<inter> {i. \<not>i \<^bold>\<Turnstile> b}\<close>
    using If by auto
  moreover have \<open>rc_check g s1\<close> \<open>rc_check g s2\<close>
    using If by simp_all
  ultimately have \<open>wpst (p \<inter> {i. i \<^bold>\<Turnstile> b}) s1 \<subseteq> wpst (q \<inter> {i. i \<^bold>\<Turnstile> b}) (erase_ghost s1)\<close> \<open>wpst (p \<inter> {i. \<not>i \<^bold>\<Turnstile> b}) s2 \<subseteq> wpst (q \<inter> {i. \<not>i \<^bold>\<Turnstile> b}) (erase_ghost s2)\<close>
    using If(1,2) by meson+
  then show ?case
    by auto
next
  case (While b I s)
  let ?\<Phi>p = \<open>\<lambda> n. ((\<lambda> x. x \<union> wpst (x \<inter> {i. i \<^bold>\<Turnstile> b}) s) ^^ n) p\<close>
  let ?\<Phi>q = \<open>\<lambda> n. ((\<lambda> x. x \<union> wpst (x \<inter> {i. i \<^bold>\<Turnstile> b}) (erase_ghost s)) ^^ n) q\<close>
  have \<open>?\<Phi>p n \<subseteq> ?\<Phi>q n\<close> \<open>regular_s g (?\<Phi>q n)\<close> for n
  proof (induct n)
    case (Suc n)
    from Suc(2) have *: \<open>regular_s g (?\<Phi>q n \<inter> {i. i \<^bold>\<Turnstile> b})\<close>
      using While(2) regular_agree_pexp by fastforce
    then have \<open>regular_s g (wpst (?\<Phi>q n \<inter> {i. i \<^bold>\<Turnstile> b}) (erase_ghost s))\<close>
      using While(2) rc_check.simps(7) rc_regular by (smt (verit, best))
    then have \<open>regular_s g (?\<Phi>q n \<union> wpst (?\<Phi>q n \<inter> {i. i \<^bold>\<Turnstile> b}) (erase_ghost s))\<close>
      using Suc by auto
    then have reg: \<open>regular_s g ((\<lambda> x. x \<union> wpst (x \<inter> {i. i \<^bold>\<Turnstile> b}) (erase_ghost s)) (?\<Phi>q  n))\<close>
      by simp
    {
      case 1
      from Suc have **: \<open>?\<Phi>p n \<inter> {i. i \<^bold>\<Turnstile> b} \<subseteq> ?\<Phi>q n \<inter> {i. i \<^bold>\<Turnstile> b}\<close>
        by auto
      have ***: \<open>rc_check g s\<close>
        using While(2) by simp
      have \<open>wpst (?\<Phi>p n \<inter> {i. i \<^bold>\<Turnstile> b}) s \<subseteq> wpst (?\<Phi>q n \<inter> {i. i \<^bold>\<Turnstile> b}) (erase_ghost s)\<close>
        using While(1)[OF *** * **] by simp
      then have \<open>?\<Phi>p n \<union> wpst (?\<Phi>p n \<inter> {i. i \<^bold>\<Turnstile> b}) s \<subseteq> ?\<Phi>q n \<union> wpst (?\<Phi>q n \<inter> {i. i \<^bold>\<Turnstile> b}) (erase_ghost s)\<close>
        using Suc by auto
      then show ?case
        by simp
    next
      case 2
      then show ?case
        using reg by simp
    }
  qed (simp_all add: While)
  then show ?case
    by auto
next
  case (Ghost s)
  then show ?case
    using gc_check_lemma by simp
qed auto

corollary
  assumes \<open>rc_check g s\<close> \<open>regular_s g p\<close> \<open>regular_s g q\<close>
    and \<open>q \<subseteq> wpst p s\<close>
  shows \<open>q \<subseteq> wpst p (erase_ghost s)\<close>
  using assms rc_check_lemma by fastforce

fun assert_check where
  \<open>assert_check p (Assert r) = (p \<supseteq> {i. i \<^bold>\<Turnstile> r})\<close> |
  \<open>assert_check p (Var x) = True\<close> |
  \<open>assert_check p (Assign x a) = True\<close> |
  \<open>assert_check p (Choice s1 s2) = (assert_check p s1 \<and> assert_check p s2)\<close> |
  \<open>assert_check p (Seq s1 s2) = (assert_check p s1 \<and> assert_check (wpst p s1) s2)\<close> |
  \<open>assert_check p (If b s1 s2) = (assert_check (p \<inter> {i. i \<^bold>\<Turnstile> b}) s1 \<and> assert_check (p \<inter> {i. \<not>i \<^bold>\<Turnstile> b}) s2)\<close> |
  \<open>assert_check p (While b I s) = assert_check ((\<Union> n. ((\<lambda> x. x \<union> wpst (x \<inter> {i. i \<^bold>\<Turnstile> b}) s) ^^ n) p) \<inter> {i. i \<^bold>\<Turnstile> b}) s\<close> |
  \<open>assert_check p (Ghost s) = assert_check p s\<close>

lemma assert_check_lemma: \<open>rc_check g s \<Longrightarrow> regular_s g q \<Longrightarrow> p \<subseteq> q \<Longrightarrow> assert_check p s \<longrightarrow> assert_check q (erase_ghost s)\<close>
proof (induct s arbitrary: p q)
  case (Seq s1 s2)
  then have \<open>wpst p s1 \<subseteq> wpst q (erase_ghost s1)\<close>
    by (metis rc_check.simps(5) rc_check_lemma)
  moreover have \<open>regular_s g (wpst q (erase_ghost s1))\<close>
    using Seq by (meson rc_check.simps(5) rc_regular)
  ultimately have \<open>assert_check (wpst p s1) s2 \<longrightarrow> assert_check (wpst q (erase_ghost s1)) (erase_ghost s2)\<close>
    using Seq by simp
  then show ?case
    using Seq by auto
next
  case (If b s1 s2)
  then have \<open>rc_check g s1\<close>
    by simp
  moreover have \<open>regular_s g (q \<inter> {i. i \<^bold>\<Turnstile> b})\<close>
    using If regular_agree_pexp by fastforce
  moreover have \<open>p \<inter> {i. i \<^bold>\<Turnstile> b} \<subseteq> q \<inter> {i. i \<^bold>\<Turnstile> b}\<close>
    using If by auto
  ultimately have *: \<open>assert_check (p \<inter> {i. i \<^bold>\<Turnstile> b}) s1 \<longrightarrow> assert_check (q \<inter> {i. i \<^bold>\<Turnstile> b}) (erase_ghost s1)\<close>
    using If(1) by blast
  from If have \<open>rc_check g s2\<close>
    by simp
  moreover have \<open>regular_s g (q \<inter> {i. \<not>i \<^bold>\<Turnstile> b})\<close>
    using If regular_agree_pexp by fastforce
  moreover have \<open>p \<inter> {i. \<not>i \<^bold>\<Turnstile> b} \<subseteq> q \<inter> {i. \<not>i \<^bold>\<Turnstile> b}\<close>
    using If by auto
  ultimately have \<open>assert_check (p \<inter> {i. \<not>i \<^bold>\<Turnstile> b}) s2 \<longrightarrow> assert_check (q \<inter> {i. \<not>i \<^bold>\<Turnstile> b}) (erase_ghost s2)\<close>
    using If(2) by blast
  with * show ?case
    by simp
next
  case (While b I s)
  define \<Phi>r where \<open>\<Phi>r \<equiv> \<lambda> n. ((\<lambda> x. x \<union> wpst (x \<inter> {i. i \<^bold>\<Turnstile> b}) s) ^^ n) p\<close>
  define \<Phi>g where \<open>\<Phi>g \<equiv> \<lambda> n. ((\<lambda> x. x \<union> wpst (x \<inter> {i. i \<^bold>\<Turnstile> b}) (erase_ghost s)) ^^ n) q\<close>
  have \<open>\<Phi>r n \<subseteq> \<Phi>g n\<close> \<open>regular_s g (\<Phi>g n)\<close> for n
  proof (induct n)
    case (Suc n)
    from Suc(2) have *: \<open>regular_s g (\<Phi>g n \<inter> {i. i \<^bold>\<Turnstile> b})\<close>
      using While(2) regular_agree_pexp by fastforce
    then have \<open>regular_s g (wpst (\<Phi>g n \<inter> {i. i \<^bold>\<Turnstile> b}) (erase_ghost s))\<close>
      using While(2) rc_check.simps(7) rc_regular by (smt (verit, best))
    then have \<open>regular_s g (\<Phi>g n \<union> wpst (\<Phi>g n \<inter> {i. i \<^bold>\<Turnstile> b}) (erase_ghost s))\<close>
      using Suc by auto
    then have reg: \<open>regular_s g ((\<lambda> x. x \<union> wpst (x \<inter> {i. i \<^bold>\<Turnstile> b}) (erase_ghost s)) (\<Phi>g  n))\<close>
      by simp
    {
      case 1
      from Suc have \<open>\<Phi>r n \<inter> {i. i \<^bold>\<Turnstile> b} \<subseteq> \<Phi>g n \<inter> {i. i \<^bold>\<Turnstile> b}\<close>
        by auto
      with * have \<open>wpst (\<Phi>r n \<inter> {i. i \<^bold>\<Turnstile> b}) s \<subseteq> wpst (\<Phi>g n \<inter> {i. i \<^bold>\<Turnstile> b}) (erase_ghost s)\<close>
        using While(2) rc_check_lemma rc_check.simps(7) by metis
      then have \<open>\<Phi>r n \<union> wpst (\<Phi>r n \<inter> {i. i \<^bold>\<Turnstile> b}) s \<subseteq> \<Phi>g n \<union> wpst (\<Phi>g n \<inter> {i. i \<^bold>\<Turnstile> b}) (erase_ghost s)\<close>
        using Suc(1) by auto
      then show ?case
        unfolding \<Phi>r_def \<Phi>g_def by simp
    next
      case 2
      then show ?case
        using reg unfolding \<Phi>g_def by simp
    }
  qed (auto simp add: While \<Phi>r_def \<Phi>g_def)
  then have *:\<open>(\<Union> n. \<Phi>r n) \<inter> {i. i \<^bold>\<Turnstile> b} \<subseteq> (\<Union> n. \<Phi>g n) \<inter> {i. i \<^bold>\<Turnstile> b}\<close>
    by auto

  have \<open>rc_check g s\<close>
    using While by simp
  {
    fix i j :: \<open>char list \<Rightarrow> int\<close>
    assume \<open>i \<^bold>\<down> g = j \<^bold>\<down> g\<close>
    assume \<open>i \<in> (\<Union> n. \<Phi>g n) \<inter> {i. i \<^bold>\<Turnstile> b}\<close>
    then obtain n where \<open>i \<in> \<Phi>g n\<close>
      by auto
    then have \<open>j \<in> \<Phi>g n\<close>
      using \<open>regular_s g (\<Phi>g n)\<close> \<open>i \<^bold>\<down> g = j \<^bold>\<down> g\<close> by simp
    from \<open>i \<in> (\<Union> n. \<Phi>g n) \<inter> {i. i \<^bold>\<Turnstile> b}\<close> have \<open>i \<^bold>\<Turnstile> b\<close>
      by simp
    then have \<open>j \<^bold>\<Turnstile> b\<close>
      using \<open>i \<^bold>\<down> g = j \<^bold>\<down> g\<close> While(2) by (simp add: regular_agree_pexp)
    with \<open>j \<in> \<Phi>g n\<close> have \<open>j \<in> (\<Union> n. \<Phi>g n) \<inter> {i. i \<^bold>\<Turnstile> b}\<close>
      by auto
  }
  then have **: \<open>regular_s g ((\<Union> n. \<Phi>g n) \<inter> {i. i \<^bold>\<Turnstile> b})\<close>
    by blast
  have \<open>assert_check ((\<Union> n. \<Phi>r n) \<inter> {i. i \<^bold>\<Turnstile> b}) s \<longrightarrow> assert_check ((\<Union> n. \<Phi>g n) \<inter> {i. i \<^bold>\<Turnstile> b}) (erase_ghost s)\<close>
    using While(1)[OF \<open>rc_check g s\<close> ** *] .
  then show ?case
    unfolding \<Phi>r_def \<Phi>g_def by simp
qed auto

section \<open>Correspondence to "Incorrectness Logic" by PETER W. O’HEARN\<close>
(*definition of incorrectness triple using my predicate transformer*)
definition \<open>psq p s q \<equiv> wpst p s \<supseteq> q\<close>

lemma empty_under_approximates: \<open>psq p s {}\<close>
  unfolding psq_def by simp

lemma consequence: \<open>p' \<supseteq> p \<Longrightarrow> psq p s q \<Longrightarrow> q \<supseteq> q' \<Longrightarrow> psq p' s q'\<close>
  using wpst_mono monoD unfolding psq_def by blast

lemma disjunction: \<open>psq p1 s q1 \<Longrightarrow> psq p2 s q2 \<Longrightarrow> psq (p1 \<union> p2) s (q1 \<union> q2)\<close>
  using wpst_mono monoD unfolding psq_def by blast

lemma unit: \<open>psq p (Assert \<^bold>\<top>) p\<close>
  unfolding psq_def by simp

lemma sequencing: \<open>psq p s1 q \<Longrightarrow> psq q s2 r \<Longrightarrow> psq p (s1\<^bold>;s2) r\<close>
proof (unfold psq_def wpst.simps)
  assume \<open>q \<subseteq> wpst p s1\<close>
  then have \<open>wpst q s2 \<subseteq> wpst (wpst p s1) s2\<close>
    using wpst_mono monoD by blast
  moreover assume \<open>r \<subseteq> wpst q s2\<close>
  ultimately show \<open>r \<subseteq> wpst (wpst p s1) s2\<close>
    by simp
qed

lemma choice: \<open>psq p s1 q \<or> psq p s2 q \<Longrightarrow> psq p (s1 \<^bold>[\<^bold>] s2) q\<close>
  unfolding psq_def by auto

lemma assignment: \<open>psq p (x \<^bold>\<leftarrow> a) {i(x := i\<lparr>a\<rparr>) | i. i \<in> p}\<close>
  unfolding psq_def by auto

lemma nondet_assignment: \<open>psq p (Var x) {i. \<exists> v. i(x := v) \<in> p}\<close>
  unfolding psq_def by simp

lemma assert: \<open>psq p (\<^bold>\<turnstile> r) (p \<inter> {i. i \<^bold>\<Turnstile> r})\<close>
  unfolding psq_def by simp

(*O\<acute>Hearn gives rules for kleene iteration, but not while. The following are my analogous rules*)

lemma while_zero: \<open>psq p (While b I s) (p \<inter> {i. \<not> i \<^bold>\<Turnstile> b})\<close>
proof-
  have \<open>p \<subseteq> ((\<lambda> x. x \<union> wpst (x \<inter> {i. i \<^bold>\<Turnstile> b}) s) ^^ 0) p\<close>
    by simp
  then have \<open>p \<subseteq> (\<Union> n. ((\<lambda> x. x \<union> wpst (x \<inter> {i. i \<^bold>\<Turnstile> b}) s) ^^ n) p)\<close>
    by fast
  then show ?thesis
    unfolding psq_def by auto
qed

lemma while_non_zero: \<open>psq p (If b s (\<^bold>\<turnstile> \<^bold>\<top>)\<^bold>; While b I s) q \<Longrightarrow> psq p (While b I s) q\<close>
proof (unfold psq_def)
  let ?p = \<open>wpst (p \<inter> {i. i \<^bold>\<Turnstile> b}) s \<union> (p \<inter> {i. \<not>i \<^bold>\<Turnstile> b})\<close>
  have \<open>wpst p (If b s (\<^bold>\<turnstile> \<^bold>\<top>)) = ?p\<close>
    by auto
  have \<open>((\<lambda> x. x \<union> wpst (x \<inter> {i. i \<^bold>\<Turnstile> b}) s) ^^ n) ?p \<subseteq> ((\<lambda> x. x \<union> wpst (x \<inter> {i. i \<^bold>\<Turnstile> b}) s) ^^ (n + 1)) p\<close> for n
  proof (induct n)
    case (Suc n)
    let ?r = \<open>((\<lambda> x. x \<union> wpst (x \<inter> {i. i \<^bold>\<Turnstile> b}) s) ^^ n) ?p\<close>
    let ?q = \<open>((\<lambda> x. x \<union> wpst (x \<inter> {i. i \<^bold>\<Turnstile> b}) s) ^^ (n + 1)) p\<close>
    from Suc have \<open>?r \<inter> {i. i \<^bold>\<Turnstile> b} \<subseteq> ?q \<inter> {i. i \<^bold>\<Turnstile> b}\<close>
      by auto
    then have \<open>wpst (?r \<inter> {i. i \<^bold>\<Turnstile> b}) s \<subseteq> wpst (?q \<inter> {i. i \<^bold>\<Turnstile> b}) s\<close>
      using wpst_mono monoD by blast
    then show ?case
      using Suc by auto
  qed auto
  then have \<open>(\<Union> n. ((\<lambda> x. x \<union> wpst (x \<inter> {i. i \<^bold>\<Turnstile> b}) s) ^^ n) ?p) \<subseteq> (\<Union> n. ((\<lambda> x. x \<union> wpst (x \<inter> {i. i \<^bold>\<Turnstile> b}) s) ^^ n) p)\<close>
    by blast
  moreover assume \<open>q \<subseteq> wpst p (If b s (\<^bold>\<turnstile> \<^bold>\<top>)\<^bold>; While b I s)\<close>
  ultimately show \<open>q \<subseteq> wpst p (While b I s)\<close>
    by auto
qed

lemma backwards_variant: \<open>(\<forall> n :: nat. psq (p n \<inter> {i. i \<^bold>\<Turnstile> b}) s (p (n + 1))) \<Longrightarrow> psq (p 0) (While b I s) ((\<Union> n. p n) \<inter> {i. \<not> i \<^bold>\<Turnstile> b})\<close>
proof (unfold psq_def)
  assume a: \<open>\<forall>n. p (n + 1) \<subseteq> wpst (p n \<inter> {i. i \<^bold>\<Turnstile> b}) s\<close>
  have \<open>p n \<subseteq> ((\<lambda> x. x \<union> wpst (x \<inter> {i. i \<^bold>\<Turnstile> b}) s) ^^ n) (p 0)\<close> for n
  proof (induct n)
    case (Suc n)
    let ?\<Phi> = \<open>((\<lambda>x. x \<union> wpst (x \<inter> {i. i \<^bold>\<Turnstile> b}) s) ^^ n) (p 0)\<close>
    have *: \<open>p n \<inter> {i. i \<^bold>\<Turnstile> b} \<subseteq> ?\<Phi> \<inter> {i. i \<^bold>\<Turnstile> b}\<close>
      using Suc by auto
    have \<open>p (n + 1) \<subseteq> wpst (p n \<inter> {i. i \<^bold>\<Turnstile> b}) s\<close>
      using a by simp
    moreover have \<open>... \<subseteq> wpst (?\<Phi> \<inter> {i. i \<^bold>\<Turnstile> b}) s\<close>
      using * wpst_mono monoD by blast
    ultimately show ?case
      by auto
  qed auto
  then show \<open>(\<Union> n. p n) \<inter> {i. \<not> i \<^bold>\<Turnstile> b} \<subseteq> wpst (p 0) (While b I s)\<close>
    by auto
qed

(*O\<acute>Hearn doesn't give a rule for if, but the following can be derived from his encoding*)

lemma \<open>psq (p \<inter> {i. i \<^bold>\<Turnstile> b}) s1 q \<Longrightarrow> psq (p \<inter> {i. i \<^bold>\<Turnstile> b}) (If b s1 s2) q\<close>
  unfolding psq_def by auto

lemma \<open>psq (p \<inter> {i. \<not>i \<^bold>\<Turnstile> b}) s2 q \<Longrightarrow> psq (p \<inter> {i. \<not>i \<^bold>\<Turnstile> b}) (If b s1 s2) q\<close>
  unfolding psq_def by auto

end


section \<open>Priority Search Trees on top of RBTs\<close>

theory PST_RBT
imports
  "HOL-Data_Structures.Cmp"
  "HOL-Data_Structures.Isin2"
  "HOL-Data_Structures.Lookup2"
  PST_General "Eval_Base.Eval_Base"
begin

text \<open>
We obtain a priority search map based on red-black trees via the
general priority search tree augmentation.

This theory has been derived from the standard Isabelle implementation of red
black trees in @{session "HOL-Data_Structures"}.
\<close>

subsection \<open>Definitions\<close>

subsubsection \<open>The Code\<close>

datatype tcolor = Red | Black

type_synonym ('k,'p) rbth = "(('k\<times>'p) \<times> (tcolor \<times> ('k \<times> 'p))) tree"

abbreviation R where "R mkp l a r \<equiv> Node l (a, Red,mkp) r"
abbreviation B where "B mkp l a r \<equiv> Node l (a, Black,mkp) r"

abbreviation "mkR \<equiv> mkNode Red"
abbreviation "mkB \<equiv> mkNode Black"

fun baliL :: "('k,'p::linorder) rbth \<Rightarrow> 'k\<times>'p \<Rightarrow> ('k,'p) rbth \<Rightarrow> ('k,'p) rbth"
  where
  "baliL (R _ (R _ t1 a1 t2) a2 t3) a3 t4 = mkR (mkB t1 a1 t2) a2 (mkB t3 a3 t4)"
| "baliL (R _ t1 a1 (R _ t2 a2 t3)) a3 t4 = mkR (mkB t1 a1 t2) a2 (mkB t3 a3 t4)"
| "baliL t1 a t2 = mkB t1 a t2"

fun baliR :: "('k,'p::linorder) rbth \<Rightarrow> 'k\<times>'p \<Rightarrow> ('k,'p) rbth \<Rightarrow> ('k,'p) rbth"
  where
"baliR t1 a1 (R _ (R _ t2 a2 t3) a3 t4) = mkR (mkB t1 a1 t2) a2 (mkB t3 a3 t4)" |
"baliR t1 a1 (R _ t2 a2 (R _ t3 a3 t4)) = mkR (mkB t1 a1 t2) a2 (mkB t3 a3 t4)" |
"baliR t1 a t2 = mkB t1 a t2"

fun paint :: "tcolor \<Rightarrow> ('k,'p::linorder) rbth \<Rightarrow> ('k,'p::linorder) rbth" where
"paint c Leaf = Leaf" |
"paint c (Node l (a, (_,mkp)) r) = Node l (a, (c,mkp)) r"

fun baldL :: "('k,'p::linorder) rbth \<Rightarrow> 'k \<times> 'p \<Rightarrow> ('k,'p::linorder) rbth
    \<Rightarrow> ('k,'p::linorder) rbth"
where
"baldL (R _ t1 x t2) y t3 = mkR (mkB t1 x t2) y t3" |
"baldL bl x (B _ t1 y t2) = baliR bl x (mkR t1 y t2)" |
"baldL bl x (R _ (B _ t1 y t2) z t3)
  = mkR (mkB bl x t1) y (baliR t2 z (paint Red t3))" |
"baldL t1 x t2 = mkR t1 x t2"

fun baldR :: "('k,'p::linorder) rbth \<Rightarrow> 'k \<times> 'p \<Rightarrow> ('k,'p::linorder) rbth
    \<Rightarrow> ('k,'p::linorder) rbth"
where
"baldR t1 x (R _ t2 y t3) = mkR t1 x (mkB t2 y t3)" |
"baldR (B _ t1 x t2) y t3 = baliL (mkR t1 x t2) y t3" |
"baldR (R _ t1 x (B _ t2 y t3)) z t4
  = mkR (baliL (paint Red t1) x t2) y (mkB t3 z t4)" |
"baldR t1 x t2 = mkR t1 x t2"

fun combine :: "('k,'p::linorder) rbth \<Rightarrow> ('k,'p::linorder) rbth
    \<Rightarrow> ('k,'p::linorder) rbth"
where
"combine Leaf t = t" |
"combine t Leaf = t" |
"combine (R _ t1 a t2) (R _ t3 c t4) =
  (case combine t2 t3 of
     R _ u2 b u3 \<Rightarrow> (mkR (mkR t1 a u2) b (mkR u3 c t4)) |
     t23 \<Rightarrow> mkR t1 a (mkR t23 c t4))" |
"combine (B _ t1 a t2) (B _ t3 c t4) =
  (case combine t2 t3 of
     R _ t2' b t3' \<Rightarrow> mkR (mkB t1 a t2') b (mkB t3' c t4) |
     t23 \<Rightarrow> baldL t1 a (mkB t23 c t4))" |
"combine t1 (R _ t2 a t3) = mkR (combine t1 t2) a t3" |
"combine (R _ t1 a t2) t3 = mkR t1 a (combine t2 t3)"

fun color :: "('k,'p) rbth \<Rightarrow> tcolor" where
"color Leaf = Black" |
"color (Node _ (_, (c,_)) _) = c"

fun upd :: "'a::linorder \<Rightarrow> 'b::linorder \<Rightarrow> ('a,'b) rbth \<Rightarrow> ('a,'b) rbth" where
"upd x y Leaf = mkR Leaf (x,y) Leaf" |
"upd x y (B _ l (a,b) r) = (case cmp x a of
  LT \<Rightarrow> baliL (upd x y l) (a,b) r |
  GT \<Rightarrow> baliR l (a,b) (upd x y r) |
  EQ \<Rightarrow> mkB l (x,y) r)" |
"upd x y (R _ l (a,b) r) = (case cmp x a of
  LT \<Rightarrow> mkR (upd x y l) (a,b) r |
  GT \<Rightarrow> mkR l (a,b) (upd x y r) |
  EQ \<Rightarrow> mkR l (x,y) r)"

definition update :: "'a::linorder \<Rightarrow> 'b::linorder \<Rightarrow> ('a,'b) rbth \<Rightarrow> ('a,'b) rbth"
where
"update x y t = paint Black (upd x y t)"

fun del :: "'a::linorder \<Rightarrow> ('a,'b::linorder)rbth \<Rightarrow> ('a,'b)rbth" where
"del x Leaf = Leaf" |
"del x (Node l ((a,b), (c,_)) r) = (case cmp x a of
     LT \<Rightarrow> if l \<noteq> Leaf \<and> color l = Black
           then baldL (del x l) (a,b) r else mkR (del x l) (a,b) r |
     GT \<Rightarrow> if r \<noteq> Leaf\<and> color r = Black
           then baldR l (a,b) (del x r) else mkR l (a,b) (del x r) |
  EQ \<Rightarrow> combine l r)"

definition delete :: "'a::linorder \<Rightarrow> ('a,'b::linorder) rbth \<Rightarrow> ('a,'b) rbth" where
"delete x t = paint Black (del x t)"

subsubsection \<open>Invariants\<close>

fun bheight :: "('k,'p) rbth \<Rightarrow> nat" where
"bheight Leaf = 0" |
"bheight (Node l (x, (c,_)) r) = (if c = Black then bheight l + 1 else bheight l)"

fun invc :: "('k,'p) rbth \<Rightarrow> bool" where
"invc Leaf = True" |
"invc (Node l (a, (c,_)) r) =
  (invc l \<and> invc r \<and> (c = Red \<longrightarrow> color l = Black \<and> color r = Black))"

fun invc2 :: "('k,'p) rbth \<Rightarrow> bool" \<comment> \<open>Weaker version\<close> where
"invc2 Leaf = True" |
"invc2 (Node l (a, _) r) = (invc l \<and> invc r)"

fun invh :: "('k,'p) rbth \<Rightarrow> bool" where
"invh Leaf = True" |
"invh (Node l (x, _) r) = (invh l \<and> invh r \<and> bheight l = bheight r)"

definition rbt :: "('k,'p::linorder) rbth \<Rightarrow> bool" where
"rbt t = (invc t \<and> invh t \<and> invpst t \<and> color t = Black)"

subsection \<open>Functional Correctness\<close>

lemma inorder_paint[simp]: "inorder(paint c t) = inorder t"
by(cases t) (auto)

lemma inorder_mkNode[simp]:
  "inorder (mkNode c l a r) = inorder l @ a # inorder r"
by (auto simp: mkNode_def)

lemma inorder_baliL[simp]:
  "inorder(baliL l a r) = inorder l @ a # inorder r"
by(cases "(l,a,r)" rule: baliL.cases) (auto)

lemma inorder_baliR[simp]:
  "inorder(baliR l a r) = inorder l @ a # inorder r"
by(cases "(l,a,r)" rule: baliR.cases) (auto)

lemma inorder_baldL[simp]:
  "inorder(baldL l a r) = inorder l @ a # inorder r"
by (cases "(l,a,r)" rule: baldL.cases) auto

lemma inorder_baldR[simp]:
  "inorder(baldR l a r) = inorder l @ a # inorder r"
by(cases "(l,a,r)" rule: baldR.cases) auto

lemma inorder_combine[simp]:
  "inorder(combine l r) = inorder l @ inorder r"
  apply2 (induction l r rule: combine.induct) by(auto split: tree.split tcolor.split)

lemma inorder_upd:
  "sorted1(inorder t) \<Longrightarrow> inorder(upd x y t) = upd_list x y (inorder t)"
apply2(induction x y t rule: upd.induct)
  by(auto simp: upd_list_simps)

lemma inorder_update:
  "sorted1(inorder t) \<Longrightarrow> inorder(update x y t) = upd_list x y (inorder t)"
by(simp add: update_def inorder_upd)

lemma inorder_del:
 "sorted1(inorder t) \<Longrightarrow>  inorder(del x t) = del_list x (inorder t)"
apply2(induction x t rule: del.induct)
  by(auto simp: del_list_simps)

lemma inorder_delete:
  "sorted1(inorder t) \<Longrightarrow> inorder(delete x t) = del_list x (inorder t)"
by(simp add: delete_def inorder_del)

subsection \<open>Invariant Preservation\<close>

lemma color_paint_Black: "color (paint Black t) = Black"
by (cases t) auto

theorem rbt_Leaf: "rbt Leaf"
by (simp add: rbt_def)

lemma invc2I: "invc t \<Longrightarrow> invc2 t"
by (cases t rule: invc.cases) simp+

lemma paint_invc2: "invc2 t \<Longrightarrow> invc2 (paint c t)"
by (cases t) auto

lemma invc_paint_Black: "invc2 t \<Longrightarrow> invc (paint Black t)"
by (cases t) auto

lemma invh_paint: "invh t \<Longrightarrow> invh (paint c t)"
by (cases t) auto

lemma invc_mkRB[simp]:
  "invc (mkR l a r) \<longleftrightarrow> invc l \<and> invc r \<and> color l = Black \<and> color r = Black"
  "invc (mkB l a r) \<longleftrightarrow> invc l \<and> invc r"
by (simp_all add: mkNode_def)

lemma color_mkNode[simp]: "color (mkNode c l a r) = c"
by (simp_all add: mkNode_def)

subsubsection \<open>Update\<close>

lemma invc_baliL:
  "\<lbrakk>invc2 l; invc r\<rbrakk> \<Longrightarrow> invc (baliL l a r)"
apply2 (induct l a r rule: baliL.induct) by auto

lemma invc_baliR:
  "\<lbrakk>invc l; invc2 r\<rbrakk> \<Longrightarrow> invc (baliR l a r)"
apply2 (induct l a r rule: baliR.induct) by auto

lemma bheight_mkRB[simp]:
  "bheight (mkR l a r) = bheight l"
  "bheight (mkB l a r) = Suc (bheight l)"
  by (simp_all add: mkNode_def)

lemma bheight_baliL:
  "bheight l = bheight r \<Longrightarrow> bheight (baliL l a r) = Suc (bheight l)"
apply2 (induct l a r rule: baliL.induct) by auto

lemma bheight_baliR:
  "bheight l = bheight r \<Longrightarrow> bheight (baliR l a r) = Suc (bheight l)"
apply2 (induct l a r rule: baliR.induct) by auto

lemma invh_mkNode[simp]:
  "invh (mkNode c l a r) \<longleftrightarrow> invh l \<and> invh r \<and> bheight l = bheight r"
by (simp add: mkNode_def)

lemma invh_baliL:
  "\<lbrakk> invh l; invh r; bheight l = bheight r \<rbrakk> \<Longrightarrow> invh (baliL l a r)"
apply2 (induct l a r rule: baliL.induct) by auto

lemma invh_baliR:
  "\<lbrakk> invh l; invh r; bheight l = bheight r \<rbrakk> \<Longrightarrow> invh (baliR l a r)"
apply2 (induct l a r rule: baliR.induct) by auto

lemma invc_upd: assumes "invc t"
  shows "color t = Black \<Longrightarrow> invc (upd x y t)" "invc2 (upd x y t)"
using assms
apply2 (induct x y t rule: upd.induct)
  by(auto simp: invc_baliL invc_baliR invc2I mkNode_def)

lemma invh_upd: assumes "invh t"
  shows "invh (upd x y t)" "bheight (upd x y t) = bheight t"
using assms
apply2(induct x y t rule: upd.induct)
  by(auto simp: invh_baliL invh_baliR bheight_baliL bheight_baliR)

lemma invpst_paint[simp]: "invpst (paint c t) = invpst t"
by (cases "(c,t)" rule: paint.cases) auto

lemma invpst_baliR: "invpst l \<Longrightarrow> invpst r \<Longrightarrow> invpst (baliR l a r)"
by (cases "(l,a,r)" rule: baliR.cases) auto

lemma invpst_baliL: "invpst l \<Longrightarrow> invpst r \<Longrightarrow> invpst (baliL l a r)"
by (cases "(l,a,r)" rule: baliL.cases) auto

lemma invpst_upd: "invpst t \<Longrightarrow> invpst (upd x y t)"
apply2 (induct x y t rule: upd.induct) by(auto simp: invpst_baliR invpst_baliL)

theorem rbt_update: "rbt t \<Longrightarrow> rbt (update x y t)"
by (simp add: invc_upd(2) invh_upd(1) color_paint_Black invc_paint_Black
  invh_paint rbt_def update_def invpst_upd)

subsubsection \<open>Delete\<close>

lemma bheight_paint_Red:
  "color t = Black \<Longrightarrow> bheight (paint Red t) = bheight t - 1"
by (cases t) auto

lemma invh_baldL_invc:
  "\<lbrakk> invh l;  invh r;  bheight l + 1 = bheight r;  invc r \<rbrakk>
   \<Longrightarrow> invh (baldL l a r) \<and> bheight (baldL l a r) = bheight l + 1"
apply2 (induct l a r rule: baldL.induct)
   by(auto simp: invh_baliR invh_paint bheight_baliR bheight_paint_Red)

lemma invh_baldL_Black:
  "\<lbrakk> invh l;  invh r;  bheight l + 1 = bheight r;  color r = Black \<rbrakk>
   \<Longrightarrow> invh (baldL l a r) \<and> bheight (baldL l a r) = bheight r"
apply2 (induct l a r rule: baldL.induct) by(auto simp add: invh_baliR bheight_baliR)

lemma invc_baldL: "\<lbrakk>invc2 l; invc r; color r = Black\<rbrakk> \<Longrightarrow> invc (baldL l a r)"
apply2 (induct l a r rule: baldL.induct) by(auto simp: invc_baliR invc2I mkNode_def)

lemma invc2_baldL: "\<lbrakk> invc2 l; invc r \<rbrakk> \<Longrightarrow> invc2 (baldL l a r)"
apply2 (induct l a r rule: baldL.induct)
  by(auto simp: invc_baliR paint_invc2 invc2I mkNode_def)

lemma invh_baldR_invc:
  "\<lbrakk> invh l;  invh r;  bheight l = bheight r + 1;  invc l \<rbrakk>
  \<Longrightarrow> invh (baldR l a r) \<and> bheight (baldR l a r) = bheight l"
apply2(induct l a r rule: baldR.induct)
  by(auto simp: invh_baliL bheight_baliL invh_paint bheight_paint_Red)

lemma invc_baldR: "\<lbrakk>invc a; invc2 b; color a = Black\<rbrakk> \<Longrightarrow> invc (baldR a x b)"
apply2 (induct a x b rule: baldR.induct) by(simp_all add: invc_baliL mkNode_def)

lemma invc2_baldR: "\<lbrakk> invc l; invc2 r \<rbrakk> \<Longrightarrow>invc2 (baldR l x r)"
apply2 (induct l x r rule: baldR.induct)
  by(auto simp: invc_baliL paint_invc2 invc2I mkNode_def)

lemma invh_combine:
  "\<lbrakk> invh l; invh r; bheight l = bheight r \<rbrakk>
  \<Longrightarrow> invh (combine l r) \<and> bheight (combine l r) = bheight l"
apply2 (induct l r rule: combine.induct)
  by(auto simp: invh_baldL_Black split: tree.splits tcolor.splits)

lemma invc_combine:
  assumes "invc l" "invc r"
  shows "color l = Black \<Longrightarrow> color r = Black \<Longrightarrow> invc (combine l r)"
         "invc2 (combine l r)"
using assms
apply2 (induct l r rule: combine.induct)
  by(auto simp: invc_baldL invc2I mkNode_def split: tree.splits tcolor.splits)

lemma neq_LeafD: "t \<noteq> Leaf \<Longrightarrow> \<exists>l x c r. t = Node l (x,c) r"
by(cases t) auto

lemma del_invc_invh: "invh t \<Longrightarrow> invc t \<Longrightarrow> invh (del x t) \<and>
   (color t = Red \<and> bheight (del x t) = bheight t \<and> invc (del x t) \<or>
    color t = Black \<and> bheight (del x t) = bheight t - 1 \<and> invc2 (del x t))"
proof2 (induct x t rule: del.induct)
case (2 x _ y _ c)
  have "x = y \<or> x < y \<or> x > y" by auto
  thus ?case proof (elim disjE)
    assume "x = y"
    with 2 show ?thesis
    by (cases c) (simp_all add: invh_combine invc_combine)
  next
    assume "x < y"
    with 2 show ?thesis
      by(cases c)
        (auto
          simp: invh_baldL_invc invc_baldL invc2_baldL mkNode_def
          dest: neq_LeafD)
  next
    assume "y < x"
    with 2 show ?thesis
      by(cases c)
        (auto
          simp: invh_baldR_invc invc_baldR invc2_baldR mkNode_def
          dest: neq_LeafD)
  qed
qed auto

lemma invpst_baldR: "invpst l \<Longrightarrow> invpst r \<Longrightarrow> invpst (baldR l a r)"
by (cases "(l,a,r)" rule: baldR.cases) (auto simp: invpst_baliL)

lemma invpst_baldL: "invpst l \<Longrightarrow> invpst r \<Longrightarrow> invpst (baldL l a r)"
by (cases "(l,a,r)" rule: baldL.cases) (auto simp: invpst_baliR)

lemma invpst_combine: "invpst l \<Longrightarrow> invpst r \<Longrightarrow> invpst (combine l r)"
apply2(induction l r rule: combine.induct)
  by(auto split: tree.splits tcolor.splits simp: invpst_baldR invpst_baldL)

lemma invpst_del: "invpst t \<Longrightarrow> invpst (del x t)"
apply2(induct x t rule: del.induct)
  by(auto simp: invpst_baldR invpst_baldL invpst_combine)

theorem rbt_delete: "rbt t \<Longrightarrow> rbt (delete k t)"
apply (clarsimp simp: delete_def rbt_def)
apply (frule (1) del_invc_invh[where x=k])
apply (auto simp: invc_paint_Black invh_paint color_paint_Black invpst_del)
done

lemma rbt_getmin_ismin:
  "rbt t \<Longrightarrow> t\<noteq>Leaf \<Longrightarrow> is_min2 (pst_getmin t) (set_tree t)"
unfolding rbt_def by (simp add: pst_getmin_ismin)

definition "rbt_is_empty t \<equiv> t = Leaf"

lemma rbt_is_empty: "rbt_is_empty t \<longleftrightarrow> inorder t = []"
by (cases t) (auto simp: rbt_is_empty_def)

definition empty where "empty = Leaf"

subsection \<open>Overall Correctness\<close>

interpretation PM: PrioMap_by_Ordered
where empty = empty and lookup = lookup and update = update and delete = delete
and inorder = inorder and inv = "rbt" and is_empty = rbt_is_empty
and getmin = pst_getmin
apply standard
apply (auto simp: lookup_map_of inorder_update inorder_delete rbt_update
                  rbt_delete rbt_Leaf rbt_is_empty empty_def
            dest: rbt_getmin_ismin)
done

end


theory F_Spark_User
imports F_Spark_Specification F_Spark_Declaration

begin

lemma goal2'1:
  shows "0 <= bit__or' (bit__and' x'' y'') (bit__and' (4294967295 - x'') z'')"
  by (rule Word.uint_0)

lemma goal2'2:
  shows "bit__or' (bit__and' x'' y'') (bit__and' (4294967295 - x'') z'') <= 4294967295"
  by (simp add: bwsimps int_word_uint)

lemma goal3'1:
  shows "0 <= bit__xor' (bit__or' x'' (4294967295 - y'')) z''"
  by (rule Word.uint_0)

lemma goal3'2:
  shows "bit__xor' (bit__or' x'' (4294967295 - y'')) z'' <= 4294967295"
  by (simp add: bwsimps int_word_uint)

lemma goal4'1:
  shows "0 <= bit__or' (bit__and' x'' z'' ) (bit__and' y'' (4294967295 - z''))"
  by simp

lemma goal4'2:
  shows "bit__or' (bit__and' x'' z'' ) (bit__and' y'' (4294967295 - z'')) <= 4294967295"
  by (simp add: bwsimps int_word_uint)

lemma goal5'1:
  shows "0 <= bit__xor' x'' (bit__or' y'' (4294967295 - z''))"
  by simp

lemma goal5'2:
  shows "bit__xor' x'' (bit__or' y'' (4294967295 - z'')) <= 4294967295"
  by (simp add: bwsimps int_word_uint)

lemma goal6'1:
  assumes H8: "j'' <= (15 :: int) "
  shows " bit__xor' x'' (bit__xor' y'' z'') = f' j'' x'' y'' z''"
proof -
  from H8 have "nat j'' <= 15" by simp
  thus ?thesis
    by (simp add: f_def)
qed

lemma goal7'1:
  assumes H7: "(16 :: int) <= j''"
  assumes H8: "j'' <= (31 :: int)"
  shows "bit__or' (bit__and' x'' y'') (bit__and' (4294967295 - x'') z'') = f' j'' x'' y'' z''"
proof -
  from H7 have "16 <= nat j''" by simp
  moreover from H8 have "nat j'' <= 31" by simp
  ultimately show ?thesis
    by (simp add: f_def)
qed

lemma goal8'1:
  assumes H7: "32 <= j''"
  assumes H8: "j'' <= 47"
  shows "bit__xor' (bit__or' x'' (4294967295 - y'')) z'' = f' j'' x'' y'' z''"
proof -
  from H7 have "32 <= nat j''" by simp
  moreover from H8 have "nat j'' <= 47" by simp
  ultimately show ?thesis by (simp add: f_def)
qed

lemma goal9'1:
  assumes H7: "48 <= j''"
  assumes H8: "j'' <= 63"
  shows "bit__or' (bit__and' x'' z'') (bit__and' y'' (4294967295 - z'')) = f' j'' x'' y'' z''"
proof -
  from H7 have "48 <= nat j''" by simp
  moreover from H8 have   "nat j'' <= 63" by simp
  ultimately show ?thesis by (simp add: f_def)
qed

lemma goal10'1:
  assumes H2: "j'' <= 79"
  assumes H12: "63 < j''"
  shows "bit__xor' x'' (bit__or' y'' (4294967295 - z'')) = f' j'' x'' y'' z''"
proof -
  from H2 have "nat j'' <= 79" by simp
  moreover from H12 have "64 <= nat j''" by simp
  ultimately show ?thesis by (simp add: f_def)
qed

lemmas userlemmas =
  goal2'1
  goal2'2
  goal3'1
  goal3'2
  goal4'1
  goal4'2
  goal5'1
  goal5'2
  goal6'1
  goal7'1
  goal8'1
  goal9'1
  goal10'1

end


(* *********************************************************************

    Theory Computations.thy is part of a framework for modelling,
    verification and transformation of concurrent imperative
    programs. Copyright (c) 2021  M. Bortin

    The framework is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
    For more details see the license agreement (LICENSE) you should have
    received along with the framework.

   ******************************************************************* *)

theory Computations
imports SmallSteps
begin

text "A Boolean value amends configurations to indicate what kind of transition
      (i.e. env. or program) leads to it.
      For instance, if (cf2, b2) follows (cf1, b1) then cf1 -p-> cf2
      when b2 is True and cf1 -e-> cf2 otherwise. "
definition stepR :: "(nat \<Rightarrow> 's LA) \<Rightarrow> (('s config \<times> bool) \<times> ('s config \<times> bool)) set"
where "stepR \<rho> = {(((p, s), tk), ((p', t), tk')) | p s tk p' t tk'.
                   if tk' then \<rho> \<turnstile> (p, s) -p\<rightarrow> (p', t) else \<turnstile> (p, s) -e\<rightarrow> (p', t)}"

lemma stepR_D1 :
"(((p, s), tk), ((p', t), True)) \<in> stepR \<rho> \<Longrightarrow>
 \<rho> \<turnstile> (p, s) -p\<rightarrow> (p', t)"
  by(simp add: stepR_def, fastforce)

lemma stepR_D2 :
"(((p, s), tk), ((p', t), False)) \<in> stepR \<rho> \<Longrightarrow>
 p = p'"
  by(simp add: stepR_def, fastforce)

lemma stepR_exch :
"(cf, cf') \<in> stepR \<rho> \<Longrightarrow> fst cf = fst cf'' \<Longrightarrow>
 (cf'', cf') \<in> stepR \<rho>"
  by(case_tac cf, case_tac cf', case_tac cf'', clarsimp simp: stepR_def)

section "Infinite computations"

text \<open>An infinite computation is an infinite sequence of tuples (config, bool) successively
        related by @{term "stepR"}.\<close>

definition iCOMP :: "(nat \<Rightarrow> 's LA) \<Rightarrow> (nat \<Rightarrow> 's config \<times> bool) set"
where "iCOMP \<rho> = {sq. \<forall>i. (sq i, sq(i+1)) \<in> stepR \<rho>}"

lemma iCOMP_D :
"sq \<in> iCOMP \<rho> \<Longrightarrow>
 (sq i, sq(i+1)) \<in> stepR \<rho>"
  by(simp add: iCOMP_def)

lemma iCOMP_jumpfree :
"sq \<in> iCOMP \<rho> \<Longrightarrow> jumpfree(progOf(sq j)) \<Longrightarrow>
 \<forall>i>j. jumpfree(progOf(sq i))"
  apply(rule allI)
  apply(induct_tac i, simp)
  apply clarify
  apply(subgoal_tac "jumpfree (progOf(sq n))")
   apply(clarsimp simp: iCOMP_def)
   apply(drule_tac x=n in spec)
   apply(case_tac "sq n")
   apply(case_tac "sq(n+1)", clarsimp)
   apply(rename_tac tk)
   apply(case_tac tk, simp)
    apply(drule stepR_D1)
    apply(erule jumpfree_pstep, assumption)
   apply simp
   apply(drule stepR_D2, simp)
  apply(case_tac "j=n", simp_all)
  done

lemma iCOMP_Skip :
"sq \<in> iCOMP \<rho> \<Longrightarrow> progOf(sq j) = Skip \<Longrightarrow>
 \<forall>i>j. progOf(sq i) = Skip \<and> \<not> snd(sq i)"
  apply(rule allI)
  apply(induct_tac i, simp)
  apply clarify
  apply(subgoal_tac "progOf(sq n) = Skip")
   apply(clarsimp simp: iCOMP_def)
   apply(drule_tac x=n in spec)
   apply(case_tac "sq n")
   apply(case_tac "sq(n+1)", clarsimp)
   apply(rename_tac tk)
   apply(case_tac tk, simp)
    apply(drule stepR_D1)
    apply(erule Skip_pstep)
   apply simp
   apply(drule stepR_D2, simp)
  apply(case_tac "j=n", simp_all)
  done

lemma iCOMP_Skip' :
"sq \<in> iCOMP \<rho> \<Longrightarrow> progOf(sq j) = Skip \<Longrightarrow>
 \<forall>i\<ge>j. progOf(sq i) = Skip"
  apply(drule iCOMP_Skip, assumption)
  apply clarsimp
  apply(case_tac "i=j", simp)
  by fastforce

lemma iCOMP_estepsG :
"sq \<in> iCOMP \<rho> \<Longrightarrow> \<forall>k<j. i < k \<longrightarrow> progOf(sq(k-1)) = progOf(sq i) \<longrightarrow> \<not>tkOf(sq k) \<Longrightarrow>
 \<forall>k<j. i \<le> k \<longrightarrow> progOf(sq k) = progOf(sq i)"
  apply(rule allI)
  apply(induct_tac k, simp)
  apply clarsimp
  apply(case_tac "i=n+1", clarsimp)
  apply(drule mp, simp)
  apply(drule spec, drule mp, assumption)
  apply(drule mp, simp)
  apply(drule mp, simp)
  apply(erule subst)
  apply(case_tac "sq n")
  apply(case_tac "sq(n+1)", clarsimp simp: iCOMP_def)
  apply(drule_tac x=n in spec, simp)
  apply(drule stepR_D2)
  by(erule sym)

lemma iCOMP_esteps :
"sq \<in> iCOMP \<rho> \<Longrightarrow> \<forall>k<j. i < k \<longrightarrow> \<not>tkOf(sq k) \<Longrightarrow>
 \<forall>k<j. i \<le> k \<longrightarrow> progOf(sq k) = progOf(sq i)"
  by(drule_tac i=i and j=j in iCOMP_estepsG, simp, assumption)

fun fprefix :: "(nat \<Rightarrow> 'a) \<Rightarrow> nat \<Rightarrow> 'a list"
where "fprefix sq 0 = [sq 0]" |
      "fprefix sq (Suc n) = fprefix sq n @ [sq (Suc n)]"

lemma fprefix_length :
"length(fprefix sq n) = n + 1"
  by(induct n, simp_all)

lemma fprefix_nth :
"i \<le> n \<Longrightarrow> (fprefix sq n)!i = sq i"
  apply(induct n, simp_all)
  apply(case_tac "i = Suc n", simp)
   apply(subst nth_append, simp add: fprefix_length)
  apply simp
  apply(subst nth_append, simp add: fprefix_length)
 done

definition
"isuffix sq d = (\<lambda>(i::nat). sq (i + d))"

lemma isuffix_add :
"isuffix(isuffix sq d) d' = isuffix sq (d' + d)"
  apply(simp add: isuffix_def, rule ext)
  apply(subst add.assoc, rule refl)
  done

lemma iCOMP_isuffix :
"sq \<in> iCOMP \<rho> \<Longrightarrow> isuffix sq d \<in> iCOMP \<rho>"
  by(simp add: iCOMP_def isuffix_def)

text "Relating consecutive computation steps."
definition cstep_cond :: "bool \<Rightarrow> 's staterel \<Rightarrow>
                          's config \<times> bool \<Rightarrow> 's config \<times> bool \<Rightarrow> bool"
where "cstep_cond K R = (\<lambda>((p, s), tk) ((p', t), tk'). tk' = K \<longrightarrow> (s, t) \<in> R)"

lemma cstep_cond_D :
"cstep_cond K R cf cf' \<Longrightarrow> cf = ((p, s), tk) \<Longrightarrow> cf' = ((p', t), K) \<Longrightarrow>
 (s, t) \<in> R"
  by(simp add: cstep_cond_def)

lemma not_cstep_cond_D :
"\<not> cstep_cond K R cf cf' \<Longrightarrow>
 \<exists>p s tk p' t. cf = ((p, s), tk) \<and> cf' = ((p', t), K) \<and> (s, t) \<notin> R"
  by(clarsimp simp add: cstep_cond_def)

lemma cstep_cond_mono :
"cstep_cond K R cf cf' \<Longrightarrow> R \<subseteq> R' \<Longrightarrow>
 cstep_cond K R' cf cf'"
  by(clarsimp simp add: cstep_cond_def, force)

definition EnvCond_i :: "(nat \<Rightarrow> 's LA)  \<Rightarrow> 's staterel \<Rightarrow> (nat \<Rightarrow> 's config \<times> bool) set"
where "EnvCond_i \<rho> R = {sq |sq. sq \<in> iCOMP \<rho> \<and> (\<forall>i. 0 < i \<longrightarrow> cstep_cond False R (sq (i-1)) (sq i))}"

definition ProgCond_i :: "(nat \<Rightarrow> 's LA)  \<Rightarrow> 's staterel \<Rightarrow> (nat \<Rightarrow> 's config \<times> bool) set"
where "ProgCond_i \<rho> R = {sq |sq. sq \<in> iCOMP \<rho> \<and> (\<forall>i. 0 < i \<longrightarrow> cstep_cond True R (sq (i-1)) (sq i))}"

definition "InitCond_i \<rho> P = {sq |sq c s tk. sq \<in> iCOMP \<rho> \<and> sq 0 = ((c, s), tk) \<and> s \<in> P}"

definition "TermCond_i \<rho> Q = {sq |sq. sq \<in> iCOMP \<rho> \<and>
                                  (\<forall>j. progOf(sq j) = Skip \<longrightarrow>
                                        (\<exists>i s tk. i \<le> j \<and> sq i = ((Skip, s), tk) \<and> s \<in> Q))}"

lemma EnvCond_i_suffix :
"sq \<in> EnvCond_i \<rho> R \<Longrightarrow> isuffix sq d \<in> EnvCond_i \<rho> R"
  apply(clarsimp simp: EnvCond_i_def)
  apply(rule conjI)
  apply(erule iCOMP_isuffix)
  apply(clarsimp simp: isuffix_def)
  done

lemma ProgCond_i_suffix :
"sq \<in> ProgCond_i \<rho> R \<Longrightarrow> isuffix sq d \<in> ProgCond_i \<rho> R"
  apply(clarsimp simp: ProgCond_i_def)
  apply(rule conjI)
  apply(erule iCOMP_isuffix)
  apply(clarsimp simp: isuffix_def)
  done

section "Finite computations"

definition COMP :: "(nat \<Rightarrow> 's LA) \<Rightarrow> ('s config \<times> bool) list set"
  where "COMP \<rho> = {sq. sq \<noteq> [] \<and> (\<forall>i<length sq - 1. (sq!i, sq!(i+1)) \<in> stepR \<rho>)}"

lemma COMP_eq :
"(sq \<in> COMP \<rho>) = (sq \<noteq> [] \<and> (\<forall>i<length sq - 1. (sq!i, sq!(i+1)) \<in> stepR \<rho>))"
  by(simp add: COMP_def)

lemma COMP_fprefix :
"COMP \<rho> = {fprefix sq n |sq n. sq \<in> iCOMP \<rho>}"
  apply(rule set_eqI)
  apply(rename_tac sq)
  apply(subst COMP_eq)
  apply(rule iffI, clarsimp)
   apply(rule_tac x="\<lambda>i. if i<length sq then sq!i
                        else (fst(sq!(length sq - 1)), False)" in exI)
   apply(rule conjI)
    apply(rule_tac x="length sq - 1" in exI)
    apply(rule nth_equalityI, simp add: fprefix_length, simp add: fprefix_nth)
   apply(clarsimp simp: iCOMP_def)
   apply(case_tac "sq!(length sq - 1)")
   apply(rule conjI, clarsimp)
    apply(drule leI)
    apply(subgoal_tac "i = length sq - 1")
     apply(subst stepR_def, clarsimp, rule_tac x=False in exI, simp)
    apply fastforce
   apply(subst stepR_def, clarsimp, rule_tac x=False in exI, clarsimp+)
  apply(rule conjI, clarsimp, drule_tac f=length in arg_cong,
        (clarsimp simp: fprefix_length fprefix_nth iCOMP_def)+)
  done

corollary fprefix_COMP :
"sq \<in> iCOMP \<rho> \<Longrightarrow> fprefix sq n \<in> COMP \<rho>"
  by(subst COMP_fprefix, fast)

text "Finite potential computations of a program"
definition pcs :: "'s LA \<Rightarrow> (nat \<Rightarrow> 's LA) \<Rightarrow> ('s config \<times> bool) list set"
("\<lbrakk>_\<rbrakk>\<^sub>_" [100,101] 100)
where "\<lbrakk>p\<rbrakk>\<^sub>\<rho> = {sq |sq s tk. sq \<in> COMP \<rho> \<and> hd sq = ((p, s), tk)}"

text "Picking actual computations, i.e. those where no env. transitions occur"
definition acs :: "'s LA \<Rightarrow> (nat \<Rightarrow> 's LA) \<Rightarrow> ('s config \<times> bool) list set"
("\<^sup>A\<lbrakk>_\<rbrakk>\<^sub>_" [100,101] 100)
where "\<^sup>A\<lbrakk>p\<rbrakk>\<^sub>\<rho> = {sq. sq \<in> \<lbrakk>p\<rbrakk>\<^sub>\<rho> \<and> (\<forall>i < length sq. 0 < i \<longrightarrow> snd(sq!i))}"

section "Properties"

corollary COMP_noNil :
"sq \<in> COMP \<rho> \<Longrightarrow> sq \<noteq> []"
  by(subst (asm) COMP_eq, simp)

corollary COMP_nth :
"sq \<in> COMP \<rho> \<Longrightarrow> i < length sq \<Longrightarrow> 0 < i \<Longrightarrow>
 (sq!(i-1), sq!i) \<in> stepR \<rho>"
  by(subst (asm) COMP_eq, clarsimp, drule_tac x="i-1" in spec, simp)

corollary nth_COMP[rule_format] :
"\<forall>i<length sq. 0 < i \<longrightarrow> (sq!(i-1), sq!i) \<in> stepR \<rho> \<Longrightarrow> sq \<noteq> [] \<Longrightarrow>
 sq \<in> COMP \<rho>"
  by(subst COMP_eq, clarsimp, drule_tac x="i+1" in spec, simp)

lemma COMP_compose' :
"sq \<in> COMP \<rho> \<Longrightarrow> sq' \<in> COMP \<rho> \<Longrightarrow>
 fst(last sq) = fst(hd sq') \<Longrightarrow> (sq @ tl sq') \<in> COMP \<rho>"
  apply(case_tac "tl sq' = []", simp)
  apply(clarsimp simp: COMP_eq)
  apply(case_tac "i<length sq - 1", clarsimp simp: nth_append, fastforce)
  apply(drule leI)
  apply(case_tac "i=length sq - 1", clarsimp simp: nth_append)
   apply(subst (asm) last_conv_nth, assumption)
   apply(subst (asm) hd_conv_nth, assumption)
   apply(subst nth_tl, simp)
   apply(case_tac "sq!(length sq - 1)", clarsimp)
   apply(drule_tac x=0 in spec)+
   apply(drule mp, fastforce)
   apply(clarsimp simp: stepR_def, fastforce)
  apply(clarsimp simp: nth_append)
  apply(rule conjI, fastforce)
  apply(subst nth_tl, simp)+
  apply(drule_tac x="i - length sq + 1" in spec)+
  apply(drule mp, fastforce)
  apply clarsimp
  apply(subgoal_tac "i - length sq + 1 = i + 1 - length sq", simp)
  by simp

lemma COMP_compose2' :
"sq \<in> COMP \<rho> \<Longrightarrow> (fst(last sq), tk) # sq' \<in> COMP \<rho> \<Longrightarrow>
 (sq @ sq') \<in> COMP \<rho>"
  by(drule COMP_compose', assumption, simp+)

lemma COMP_compose :
"sq \<in> COMP \<rho> \<Longrightarrow> sq' \<in> COMP \<rho> \<Longrightarrow>
 last sq = hd sq' \<Longrightarrow> (sq @ tl sq') \<in> COMP \<rho>"
by(erule COMP_compose', simp_all)

lemma COMP_compose2 :
"sq \<in> COMP \<rho> \<Longrightarrow> last sq # sq' \<in> COMP \<rho> \<Longrightarrow>
 (sq @ sq') \<in> COMP \<rho>"
  by(drule COMP_compose, assumption, simp+)

lemma iCOMP_pow :
"sq \<in> iCOMP \<rho> \<Longrightarrow> (sq 0, sq i) \<in> stepR \<rho> ^^ i"
  apply(induct_tac i, simp_all)
  apply(erule relcompI)
  by(simp add: iCOMP_def)

lemma COMP_pow :
"sq \<in> COMP \<rho> \<Longrightarrow>
 \<forall>i<length sq. (sq!0, sq!i) \<in> (stepR \<rho>)^^i"
  apply(subst (asm) COMP_fprefix, clarsimp simp: fprefix_length fprefix_nth)
  by(erule iCOMP_pow)

lemma pow_COMP[rule_format] :
"\<forall>cf cf'. (cf, cf') \<in> (stepR \<rho>)^^i \<longrightarrow>
 (\<exists>sq. length sq = Suc i \<and> sq \<in> COMP \<rho> \<and> sq!0 = cf \<and> sq!i = cf')"
  apply(induct_tac i)
   apply clarsimp
   apply(rename_tac p s tk)
   apply(rule_tac x="[((p, s), tk)]" in exI, simp add: COMP_eq)
  apply clarsimp
  apply((drule spec)+, drule mp, assumption)
  apply clarify
  apply(rename_tac p s tk sq)
  apply(rule_tac x="sq@[((p, s), tk)]" in exI, simp)
  apply(frule COMP_noNil)
  apply(subst nth_append, simp)
  apply(subst nth_append, simp)
  apply(erule COMP_compose2)
  apply(subst last_conv_nth, assumption)
  by(clarsimp simp: COMP_eq)

lemma pstep_pow_COMP[rule_format] :
"\<forall>cf cf'. ((pstep \<rho>)^^i) cf cf' \<longrightarrow>
 (\<exists>sq. length sq = Suc i \<and> sq \<in> COMP \<rho> \<and> fst(sq!0) = cf \<and> fst(sq!i) = cf' \<and>
    (\<forall>j<length sq. snd(sq!j)))"
  apply(induct_tac i)
   apply clarsimp
   apply(rename_tac p s)
   apply(rule_tac x="[((p, s), True)]" in exI, simp add: COMP_eq)
  apply clarsimp
  apply((drule spec)+, drule mp, assumption)
  apply clarify
  apply(rename_tac p' t p s sq)
  apply(rule_tac x="sq@[((p', t), True)]" in exI, simp)
  apply(frule COMP_noNil)
  apply(subst nth_append, simp)
  apply(subst nth_append, simp)
  apply(rule conjI)
   apply(erule COMP_compose2)
   apply(subst last_conv_nth, assumption)
   apply(case_tac "sq!n", clarsimp simp: COMP_eq)
   apply(simp add: stepR_def, rule_tac x=True in exI, simp (no_asm))
  apply clarsimp
  apply(case_tac "j = Suc n", clarsimp)
  apply(subst nth_append, simp)
  apply(subst nth_append, simp)
 done

lemma COMP_pstep_pow[rule_format] :
"sq \<in> COMP \<rho> \<Longrightarrow> \<forall>j<length sq. 0 < j \<longrightarrow> snd(sq!j) \<Longrightarrow>
 \<forall>i<length sq. ((pstep \<rho>)^^i) (fst(sq!0)) (fst(sq!i))"
  apply(rule allI)
  apply(induct_tac i, clarsimp+)
  apply(erule relcomppI)
  apply(drule spec, drule mp, assumption)
  apply(case_tac "sq!n", case_tac "sq!(n+1)", clarsimp)
  apply(drule_tac i="n+1" in COMP_nth, clarsimp+)
  by(erule stepR_D1)

lemma esteps_COMP[rule_format] :
"sq \<in> COMP \<rho> \<Longrightarrow>
 \<forall>i < length sq. 0 < i \<longrightarrow> \<not>tkOf(sq!i) \<and> (stateOf(sq!(i - 1)) \<in> S \<longrightarrow> stateOf(sq!i) \<in> S) \<Longrightarrow>
  stateOf(sq!0) \<in> S \<Longrightarrow> i < length sq \<Longrightarrow>
 progOf(sq!i) = progOf(sq!0) \<and> stateOf(sq!i) \<in> S"
  apply(induct i, simp_all)
  apply(drule spec, drule mp, assumption)
  apply clarsimp
  apply(drule_tac i="i+1" in COMP_nth, simp, simp)
  apply(clarsimp simp: stepR_def)
  done

lemma Skip_COMP[rule_format] :
"sq \<in> COMP \<rho> \<Longrightarrow> \<forall>i < length sq. \<forall>s t p tk. 0 < i \<longrightarrow> sq!(i - 1) = ((Skip, s), tk) \<longrightarrow>
               sq!i = ((p, t), False) \<longrightarrow> s \<in> Q \<longrightarrow> t \<in> Q \<Longrightarrow>
 progOf(sq!0) = Skip \<Longrightarrow> stateOf(sq!0) \<in> Q \<Longrightarrow>
 i < length sq \<Longrightarrow> progOf(sq!i) = Skip \<and> stateOf(sq!i) \<in> Q"
  apply(induct i, simp_all)
  apply(drule_tac x="i+1" in spec, simp)
  apply(case_tac "sq!i")
  apply(case_tac "sq!(i+1)", clarsimp)
  apply(drule_tac i="i+1" in COMP_nth, simp, simp)
  apply(rename_tac tk)
  apply(case_tac tk)
   apply clarsimp
   apply(drule stepR_D1)
   apply(erule Skip_pstep)
  apply clarsimp
  apply(drule stepR_D2, simp)
  done

lemma Skip_COMP_pstep :
"sq \<in> COMP \<rho> \<Longrightarrow>
 progOf(sq!0) = Skip \<Longrightarrow> i < length sq \<Longrightarrow> 0 < i \<Longrightarrow> tkOf(sq!i) \<Longrightarrow> P"
  apply(frule_tac i="i-1" and Q=UNIV in Skip_COMP, clarsimp, assumption, simp, simp)
  apply(case_tac "sq!(i-1)", clarsimp)
  apply(case_tac "sq!i", clarsimp)
  apply(drule_tac i=i in COMP_nth, assumption+)
  apply clarsimp
  apply(drule stepR_D1)
  by(erule Skip_pstep)

section "Prefixes and suffixes of finite computations"

definition "prefix pr sq = (\<exists>s. sq = pr@s)"

lemma prefix_length :
"prefix pr sq \<Longrightarrow> length pr \<le> length sq"
  by(clarsimp simp add: prefix_def)

lemma prefix_take :
"prefix (take i sq) sq"
  apply(simp add: prefix_def)
  apply(rule_tac x="drop i sq" in exI)
  by(rule sym, rule append_take_drop_id)

lemma prefix_nth :
"prefix pr sq \<Longrightarrow> i < length pr \<Longrightarrow>
 pr!i = sq!i"
  apply(clarsimp simp add: prefix_def)
  apply(subst nth_append, simp)
  done

lemma prefix_appendI :
"prefix pr xs \<Longrightarrow> prefix pr (xs @ zs)"
  apply(simp add: prefix_def, fastforce)
  done

lemma prefix_appendD :
"prefix pr (xs @ zs) \<Longrightarrow> prefix pr xs \<or> (\<exists>pr1. pr1 \<noteq> [] \<and> pr = xs @ pr1 \<and> prefix pr1 zs)"
  apply(simp add: prefix_def)
  apply(erule exE)
  apply(subst (asm) append_eq_append_conv2)
  apply(erule exE)
  apply(erule disjE, fastforce)
  apply fastforce
  done

corollary prefix_snoc :
"prefix pr (xs @ [a]) \<Longrightarrow> pr = (xs @ [a]) \<or> prefix pr xs"
  by(drule prefix_appendD, erule disjE, clarsimp+, case_tac pr1, (clarsimp simp: prefix_def)+)

lemma prefix_length_eqD :
"prefix pr xs \<Longrightarrow> length pr = length xs \<Longrightarrow> pr = xs"
  by(clarsimp simp: prefix_def)

lemma COMP_prefix_cls :
"sq \<in> COMP \<rho> \<Longrightarrow> prefix pr sq \<Longrightarrow> pr \<noteq> [] \<Longrightarrow> pr \<in> COMP \<rho>"
  apply(clarsimp simp: COMP_eq)
  apply(subst prefix_nth, assumption, simp)+
  apply(drule_tac x=i in spec)
  apply(drule mp, erule less_le_trans, drule prefix_length)
  by fastforce

definition "suffix su sq = (\<exists>x. sq = x@su)"

lemma suffix_length :
"suffix su sq \<Longrightarrow> length su \<le> length sq"
  by(clarsimp simp add: suffix_def)

lemma suffix_drop :
"suffix (drop i sq) sq"
  apply(simp add: suffix_def)
  apply(rule_tac x="take i sq" in exI)
  by(rule sym, rule append_take_drop_id)

lemma suffix_nth :
"suffix su sq \<Longrightarrow> i < length su \<Longrightarrow>
 su!i = sq!(i + (length sq - length su))"
  apply(clarsimp simp add: suffix_def)
  apply(subst nth_append, simp)
  done

lemma COMP_suffix_cls :
"sq \<in> COMP \<rho> \<Longrightarrow> suffix su sq \<Longrightarrow> su \<noteq> [] \<Longrightarrow> su \<in> COMP \<rho>"
  apply(clarsimp simp: COMP_eq)
  apply(subst suffix_nth, assumption, simp)+
  apply(drule_tac x="i + (length sq - length su)" in spec, simp)
  apply(drule mp, drule suffix_length)
  by fastforce

lemma COMP_decomp :
"(sq @ sq') \<in> COMP \<rho> \<Longrightarrow> sq \<noteq> [] \<Longrightarrow>
 sq \<in> COMP \<rho> \<and> (last sq # sq') \<in> COMP \<rho>"
  apply(rule conjI)
   apply(erule COMP_prefix_cls)
    apply(simp add: prefix_def)
   apply assumption
  apply(erule COMP_suffix_cls)
   apply(simp add: suffix_def)
   apply(rule_tac x="butlast sq" in exI)
  by simp+

lemma Skip_COMP'[rule_format] :
"sq \<in> COMP \<rho> \<Longrightarrow> (\<forall>i < length sq. \<forall>s t p tk. 0 < i \<longrightarrow> sq!(i - 1) = ((Skip, s), tk) \<longrightarrow>
               sq!i = ((p, t), False) \<longrightarrow> s \<in> Q \<longrightarrow> t \<in> Q) \<Longrightarrow>
 progOf(sq!i) = Skip \<Longrightarrow> stateOf(sq!i) \<in> Q \<Longrightarrow> i < length sq \<Longrightarrow>
 \<forall>j<length sq. i\<le>j \<longrightarrow> progOf(sq!j) = Skip \<and> stateOf(sq!j) \<in> Q"
  apply(drule_tac su="drop i sq" in COMP_suffix_cls)
    apply(rule suffix_drop, simp)
  apply clarsimp
  apply(drule_tac Q=Q and i="j-i" in Skip_COMP)
      apply clarsimp
      apply(rename_tac k s t p tk)
      apply(drule_tac x="i+k" in spec, simp)
     apply clarsimp+
   apply fastforce
  apply clarsimp
  done

subsection "Properties of finite potential computations of a program"

lemma pcs_noNil :
"sq \<in> \<lbrakk>p\<rbrakk>\<^sub>\<rho> \<Longrightarrow> sq \<noteq> []"
  apply(clarsimp simp add: pcs_def)
  by(drule COMP_noNil, clarify)

lemma pcsD :
"sq \<in> \<lbrakk>p\<rbrakk>\<^sub>\<rho> \<Longrightarrow> sq \<in> COMP \<rho>"
  by(simp add: pcs_def)

lemma pcs_nth :
"sq \<in> \<lbrakk>p\<rbrakk>\<^sub>\<rho> \<Longrightarrow> i < length sq \<Longrightarrow> 0 < i \<Longrightarrow> (sq!(i-1), sq!i) \<in> stepR \<rho>"
  apply(clarsimp simp: pcs_def)
  by(erule COMP_nth[simplified], assumption+)

lemma pcs0 :
"sq \<in> \<lbrakk>p\<rbrakk>\<^sub>\<rho> \<Longrightarrow> \<exists>s tk. sq!0 = ((p, s), tk)"
  apply(clarsimp simp add: pcs_def)
  apply(drule COMP_noNil)
  apply(subst (asm) hd_conv_nth, simp)
  by fastforce

lemma esteps_pcs :
"sq \<in> \<lbrakk>p\<rbrakk>\<^sub>\<rho> \<Longrightarrow>
 \<forall>i<length sq. 0 < i \<longrightarrow> \<not>tkOf(sq!i) \<and> (stateOf(sq!(i - 1)) \<in> P \<longrightarrow> stateOf(sq!i) \<in> P) \<Longrightarrow>
 stateOf(sq!0) \<in> P \<Longrightarrow>
 \<forall>i < length sq. progOf(sq!i) = p \<and> stateOf(sq!i) \<in> P"
  apply(clarsimp simp add: pcs_def)
  apply(frule COMP_noNil)
  apply(subst (asm) hd_conv_nth, assumption)
  apply(drule_tac i=i and S=P in esteps_COMP, simp, assumption+)
  by simp

lemma Skip_pcs :
"sq \<in> \<lbrakk>Skip\<rbrakk>\<^sub>\<rho> \<Longrightarrow> \<forall>i < length sq. \<forall>s t p' tk. 0 < i \<longrightarrow> sq!(i - 1) = ((Skip, s), tk) \<longrightarrow>
                  sq!i = ((p', t), False) \<longrightarrow> s \<in> Q \<longrightarrow> t \<in> Q \<Longrightarrow>
 stateOf(sq!0) \<in> Q \<Longrightarrow>
 \<forall>i < length sq. progOf(sq!i) = Skip \<and> stateOf(sq!i) \<in> Q"
  apply(clarsimp simp add: pcs_def)
  apply(frule COMP_noNil)
  apply(subst (asm) hd_conv_nth, assumption)
  apply(drule_tac i=i and Q=Q in Skip_COMP)
      apply force
     apply simp_all
  done

lemma Skip_pcs_pstep[rule_format] :
"sq \<in> \<lbrakk>Skip\<rbrakk>\<^sub>\<rho> \<Longrightarrow> i < length sq \<Longrightarrow> 0 < i \<Longrightarrow> snd(sq!i) \<Longrightarrow> P"
  apply(clarsimp simp: pcs_def)
  apply(subst (asm) hd_conv_nth, erule COMP_noNil)
  apply(drule Skip_COMP_pstep, simp, assumption+)
done

lemma pcs_prefix_cls :
"sq \<in> \<lbrakk>p\<rbrakk>\<^sub>\<rho> \<Longrightarrow> prefix pr sq \<Longrightarrow> pr \<noteq> [] \<Longrightarrow>
 pr \<in> \<lbrakk>p\<rbrakk>\<^sub>\<rho>"
  apply(clarsimp simp add: pcs_def)
  apply(drule COMP_prefix_cls, assumption+)
  apply(simp add: prefix_def)
  apply clarify
  apply(rule_tac x=s in exI)
  apply(rule_tac x=tk in exI)
  apply(case_tac pr, simp_all)
  done

lemma pcs_suffix_cls :
"sq \<in> \<lbrakk>p\<rbrakk>\<^sub>\<rho> \<Longrightarrow> suffix su sq \<Longrightarrow> su \<noteq> [] \<Longrightarrow>
 su \<in> \<lbrakk>progOf(sq!(length sq - length su))\<rbrakk>\<^sub>\<rho>"
  apply(clarsimp simp add: pcs_def)
  apply(drule COMP_suffix_cls, assumption+)
   apply(drule_tac i=0 in suffix_nth)
   apply simp
  apply clarsimp
  apply(erule_tac s="su!0" in subst)
  apply(case_tac su, clarify)
  apply clarsimp
  done

lemma acs_noNil :
"[] \<in> \<^sup>A\<lbrakk>p\<rbrakk>\<^sub>\<rho> \<Longrightarrow> P"
  by(simp add: acs_def, drule pcs_noNil, clarify)

lemma acs_prefix_cls :
"sq \<in> \<^sup>A\<lbrakk>p\<rbrakk>\<^sub>\<rho> \<Longrightarrow> prefix pr sq \<Longrightarrow> pr \<noteq> [] \<Longrightarrow>
 pr \<in> \<^sup>A\<lbrakk>p\<rbrakk>\<^sub>\<rho>"
  apply(clarsimp simp add: acs_def)
  apply(rule conjI)
   apply(erule pcs_prefix_cls, assumption+)
  apply(clarsimp simp: prefix_def)
  apply(drule_tac x=i in spec, simp)
  apply(subst (asm) nth_append, simp)
  done

section "Pcs, constrained by conditions"

text "Computations where all environment transitions satisfy a state relation"
definition EnvCond :: "(nat \<Rightarrow> 's LA) \<Rightarrow> 's staterel \<Rightarrow>
                      ('s config \<times> bool) list set"
where "EnvCond \<rho> R = {sq |sq p. sq \<in> \<lbrakk>p\<rbrakk>\<^sub>\<rho> \<and> (\<forall>i. i < length sq \<longrightarrow> 0 < i \<longrightarrow>
                                             cstep_cond False R (sq!(i-1)) (sq!i))}"

definition EnvCond_br :: "(nat \<Rightarrow> 's LA)\<Rightarrow> 's staterel \<Rightarrow> ('s config \<times> bool) list \<Rightarrow>
                           nat \<Rightarrow> bool"
  where "EnvCond_br \<rho> R sq i =
  (\<exists>c s c' t tk. sq!(i - 1) = ((c, s), tk) \<and> sq!i = ((c', t), False) \<and> (s, t) \<notin> R)"

lemma EnvCond_D :
"sq \<in> EnvCond \<rho> R \<Longrightarrow>
 i < length sq \<Longrightarrow> 0 < i \<Longrightarrow>
 sq!(i - Suc 0) = ((c, s), tk) \<Longrightarrow> sq!i = ((c', t), False) \<Longrightarrow> (s, t) \<in> R"
  apply(clarsimp simp add: EnvCond_def)
  apply(drule_tac x=i in spec, simp)
  by(erule cstep_cond_D, rule refl, rule refl)

lemma not_EnvCond_D :
"sq \<notin> EnvCond \<rho> R \<Longrightarrow> sq \<in> \<lbrakk>p\<rbrakk>\<^sub>\<rho> \<Longrightarrow>
 \<exists>i. i < length sq \<and> 0 < i \<and> \<not> cstep_cond False R (sq!(i-1)) (sq!i)"
  by(clarsimp simp add: EnvCond_def)

lemma not_EnvCond_D' :
"sq \<notin> EnvCond \<rho> R \<Longrightarrow> sq \<in> \<lbrakk>p\<rbrakk>\<^sub>\<rho> \<Longrightarrow>
 \<exists>i c s c' t tk. i < length sq \<and> 0 < i \<and>
 sq!(i - 1) = ((c, s), tk) \<and> sq!i = ((c', t), False) \<and> (s, t) \<notin> R"
  apply(clarsimp simp add: EnvCond_def)
  apply(erule disjE, simp)
  apply clarsimp
  apply(rule_tac x=i in exI, simp)
  apply(case_tac "sq!i", case_tac "sq!(i-1)")
  apply(clarsimp simp add: cstep_cond_def)
  done

lemma EnvCond_prefix_cls :
"sq \<in> EnvCond \<rho> R' \<Longrightarrow> prefix pr sq \<Longrightarrow> pr \<noteq> [] \<Longrightarrow> R' \<subseteq> R \<Longrightarrow>
 pr \<in> EnvCond \<rho> R"
  apply(clarsimp simp add: EnvCond_def)
  apply(rule conjI)
   apply(rule exI, erule pcs_prefix_cls, assumption+)
  apply clarsimp
  apply(subst prefix_nth, assumption, simp)+
  apply(drule prefix_length)
  apply(drule_tac x=i in spec, simp)
  by(erule cstep_cond_mono)

lemma EnvCond_suffix_cls :
"sq \<in> EnvCond \<rho> R' \<Longrightarrow> suffix sf sq \<Longrightarrow> sf \<noteq> [] \<Longrightarrow> R' \<subseteq> R \<Longrightarrow>
 sf \<in> EnvCond \<rho> R"
  apply(clarsimp simp add: EnvCond_def)
  apply(rule conjI)
   apply(rule exI, erule pcs_suffix_cls, assumption+)
  apply clarsimp
  apply(subst suffix_nth, assumption, simp)+
  apply(drule suffix_length)
  apply(drule_tac x="i + (length sq - length sf)" in spec, simp)
  apply(drule mp, force)
  by(erule cstep_cond_mono, assumption)

lemma EnvCond_compose :
"sq \<in> EnvCond \<rho> R \<Longrightarrow> sq' \<in> EnvCond \<rho> R \<Longrightarrow>
 fst(last sq) = fst(hd sq') \<Longrightarrow>
 (sq @ tl sq') \<in> EnvCond \<rho> R"
  apply(case_tac "length sq' = 1")
   apply(case_tac sq', clarsimp, clarsimp)
  apply(subgoal_tac "0 < length sq \<and> 1 < length sq'")
   prefer 2
   apply(rule ccontr, simp)
   apply(clarsimp simp: EnvCond_def)
   apply(drule pcs_noNil)+
   apply(case_tac sq', clarsimp, clarsimp)
  apply(subst EnvCond_def, simp)
  apply(rule conjI)
   apply(clarsimp simp: EnvCond_def pcs_def)
   apply(frule COMP_noNil)
   apply(drule COMP_compose', assumption, simp)
   apply simp
  apply(clarsimp simp: cstep_cond_def)
  apply(drule_tac t="(sq @ tl sq') ! (i - Suc 0)" in sym)
  apply(subst (asm) nth_append)+
  apply(simp split: if_splits)
    apply(erule_tac i=i in EnvCond_D, assumption+)
   apply(subgoal_tac "i = length sq", clarsimp)
    apply(subst (asm) last_conv_nth, simp)
    apply(subst (asm) hd_conv_nth, fastforce)
    apply(subst (asm) nth_tl, simp)
    apply(case_tac "sq'!0", clarsimp)
    apply(erule_tac i=1 and sq=sq' in EnvCond_D, simp, simp (no_asm), simp, simp)
   apply fastforce
  apply(drule leI)+
  apply(subst (asm) nth_tl, simp)+
  apply(subgoal_tac " Suc (i - Suc (length sq)) = i - length sq", simp)
   apply(erule_tac sq=sq' and i="i - length sq + 1" in EnvCond_D, simp+)
  done

text "Computations where all program transitions satisfy a state relation"
definition ProgCond :: "(nat \<Rightarrow> 's LA) \<Rightarrow> 's staterel \<Rightarrow> ('s config \<times> bool) list set"
where "ProgCond \<rho> R = {sq |sq p. sq \<in> \<lbrakk>p\<rbrakk>\<^sub>\<rho> \<and> (\<forall>i. i < length sq \<longrightarrow> 0 < i \<longrightarrow>
                                                 cstep_cond True R (sq!(i-1)) (sq!i))}"

lemma ProgCond_D :
"sq \<in> ProgCond \<rho> R \<Longrightarrow>
 i < length sq \<Longrightarrow> 0 < i \<Longrightarrow>
 sq!(i - Suc 0) = ((c, s), tk) \<Longrightarrow> sq!i = ((c', t), True) \<Longrightarrow> (s, t) \<in> R"
  apply(clarsimp simp add: ProgCond_def)
  apply(drule_tac x=i in spec, simp)
  by(erule cstep_cond_D, rule refl, rule refl)

lemma not_ProgCond_D :
"sq \<notin> ProgCond \<rho> R \<Longrightarrow> sq \<in> \<lbrakk>p\<rbrakk>\<^sub>\<rho> \<Longrightarrow>
 \<exists>i c s c' t tk. i < length sq \<and> 0 < i \<and> \<not> cstep_cond True R (sq!(i-1)) (sq!i)"
  by(clarsimp simp add: ProgCond_def)

lemma not_ProgCond_D' :
"sq \<notin> ProgCond \<rho> R \<Longrightarrow> sq \<in> \<lbrakk>p\<rbrakk>\<^sub>\<rho> \<Longrightarrow>
 \<exists>i c s c' t tk. i < length sq \<and> 0 < i \<and>
 sq!(i - 1) = ((c, s), tk) \<and> sq!i = ((c', t), True) \<and> (s, t) \<notin> R"
  apply(simp add: ProgCond_def)
  apply(erule disjE, simp)
  apply clarsimp
  apply(rule_tac x=i in exI, simp)
  apply(case_tac "sq!i", case_tac "sq!(i-1)")
  apply(clarsimp simp add: cstep_cond_def)
  done

lemma ProgCond_prefix_cls :
"sq \<in> ProgCond \<rho> R' \<Longrightarrow> prefix pr sq \<Longrightarrow> pr \<noteq> [] \<Longrightarrow> R' \<subseteq> R \<Longrightarrow>
 pr \<in> ProgCond \<rho> R"
  apply(clarsimp simp add: ProgCond_def)
  apply(rule conjI)
   apply(rule exI, erule pcs_prefix_cls, assumption+)
  apply clarsimp
  apply(subst prefix_nth, assumption, simp)+
  apply(drule prefix_length)
  apply(drule_tac x=i in spec, simp)
  by(erule cstep_cond_mono)

lemma ProgCond_suffix_cls :
"sq \<in> ProgCond \<rho> R' \<Longrightarrow> suffix su sq \<Longrightarrow> su \<noteq> [] \<Longrightarrow> R' \<subseteq> R \<Longrightarrow>
 su \<in> ProgCond \<rho> R"
  apply(clarsimp simp add: ProgCond_def)
  apply(rule conjI)
   apply(rule exI, erule pcs_suffix_cls, assumption+)
  apply clarsimp
  apply(subst suffix_nth, assumption, simp)+
  apply(drule suffix_length)
  apply(drule_tac x="i + (length sq - length su)" in spec, simp)
  apply(drule mp, fastforce)
  by(erule cstep_cond_mono)

lemma ProgCond_compose :
"sq \<in> ProgCond \<rho> R \<Longrightarrow> sq' \<in> ProgCond \<rho> R \<Longrightarrow>
 fst(last sq) = fst(hd sq') \<Longrightarrow>
 (sq @ tl sq') \<in> ProgCond \<rho> R"
  apply(case_tac "length sq' = 1")
   apply(case_tac sq', clarsimp, clarsimp)
  apply(subgoal_tac "0 < length sq \<and> 1 < length sq'")
   prefer 2
   apply(rule ccontr, simp)
   apply(clarsimp simp: ProgCond_def)
   apply(drule pcs_noNil)+
   apply(case_tac sq', clarsimp, clarsimp)
  apply(subst ProgCond_def, simp)
  apply(rule conjI)
   apply(clarsimp simp: ProgCond_def pcs_def)
   apply(frule COMP_noNil)
   apply(drule COMP_compose', assumption, simp)
   apply simp
  apply(clarsimp simp: cstep_cond_def)
  apply(drule_tac t="(sq @ tl sq') ! (i - Suc 0)" in sym)
  apply(subst (asm) nth_append)+
  apply(simp split: if_splits)
    apply(erule_tac i=i in ProgCond_D, assumption+)
   apply(subgoal_tac "i = length sq", clarsimp)
    apply(subst (asm) last_conv_nth, simp)
    apply(subst (asm) hd_conv_nth, fastforce)
    apply(subst (asm) nth_tl, simp)
    apply(case_tac "sq'!0", clarsimp)
    apply(erule_tac i=1 and sq=sq' in ProgCond_D, simp, simp (no_asm), simp, simp)
   apply fastforce
  apply(drule leI)+
  apply(subst (asm) nth_tl, simp)+
  apply(subgoal_tac " Suc (i - Suc (length sq)) = i - length sq", simp)
   apply(erule_tac sq=sq' and i="i - length sq + 1" in ProgCond_D, simp+)
  done

lemma ProgCond_decompose :
"(sq @ tl sq') \<in> ProgCond \<rho> R \<Longrightarrow>
 0 < length sq \<Longrightarrow>
 0 < length sq' \<Longrightarrow>
 fst(last sq) = fst(hd sq') \<Longrightarrow>
 sq \<in> ProgCond \<rho> R \<and> sq' \<in> ProgCond \<rho> R"
  apply(rule conjI)
   apply(erule ProgCond_prefix_cls, simp add: prefix_def, fast, rule subset_refl)
  apply(subst ProgCond_def, simp)
  apply(rule conjI)
   apply(rule_tac x="progOf(sq'!0)" in exI)
   apply(clarsimp simp: ProgCond_def pcs_def)
   apply(rule conjI)
    apply(drule COMP_decomp, assumption)
    apply(subst (asm) hd_conv_nth, assumption)+
    apply(subst (asm) last_conv_nth, assumption)+
    apply(clarsimp simp: COMP_eq)
    apply(case_tac i, clarsimp)
     apply(drule_tac x=0 in spec)+
     apply clarsimp
     apply(subst (asm) nth_tl, simp)
     apply(erule stepR_exch, assumption)
    apply(drule_tac x=i in spec, drule mp, assumption)
    apply clarsimp
    apply(subst (asm) nth_tl, simp)+
    apply assumption
   apply(subst hd_conv_nth, assumption)
   apply(case_tac "sq'!0", clarsimp)
  apply(clarsimp simp: cstep_cond_def)
  apply(drule_tac t="sq' ! (i - Suc 0)" in sym)
  apply(case_tac "i = 1", clarsimp)
   apply(subst (asm) last_conv_nth, assumption)
   apply(subst (asm) hd_conv_nth, assumption)
   apply(case_tac "sq!(length sq - 1)", clarsimp)
   apply(drule_tac i="length sq" in ProgCond_D, simp, simp)
     apply(subst nth_append, simp)
    apply(subst nth_append, simp)
    apply(subst nth_tl, simp, assumption+)
   apply(drule_tac i="length sq + i - 1" in ProgCond_D, simp, simp)
    apply(subst nth_append, simp)
    apply(rule conjI, fastforce)
    apply clarsimp
    apply(subst nth_tl, simp)
    apply(case_tac i, simp, simp)
   apply(subst nth_append, simp)
   apply(rule conjI, fastforce)
   apply clarsimp
   apply(subst nth_tl, simp)
   apply(case_tac i, simp, simp)
  by assumption

text "Computations where the initial state satisfies a state predicate"
definition "InitCond \<rho> A = {sq |sq p c s tk. sq \<in> \<lbrakk>p\<rbrakk>\<^sub>\<rho> \<and> hd sq = ((c, s), tk) \<and> s \<in> A}"

lemma InitCond_mono :
"sq \<in> InitCond \<rho> A' \<Longrightarrow> A' \<subseteq> A \<Longrightarrow> sq \<in> InitCond \<rho> A"
  by(clarsimp simp add: InitCond_def, fastforce)

lemma InitCond_prefix_cls :
"sq \<in> InitCond \<rho> A' \<Longrightarrow> prefix pr sq \<Longrightarrow> pr \<noteq> [] \<Longrightarrow> A' \<subseteq> A \<Longrightarrow>
 pr \<in> InitCond \<rho> A"
  apply(clarsimp simp add: InitCond_def)
  apply(rule conjI)
   apply(rule exI, erule pcs_prefix_cls, assumption+)
  apply(subst hd_conv_nth, assumption)
  apply(subst prefix_nth, assumption, simp)
  apply(subst hd_conv_nth[THEN sym])
  apply(drule prefix_length, force)
  apply force
  done

text "condition upon termination"
definition "TermCond \<rho> Q = {sq |sq p. sq \<in> \<lbrakk>p\<rbrakk>\<^sub>\<rho> \<and>
                                  (\<forall>j<length sq. progOf(sq!j) = Skip \<longrightarrow>
                                        (\<exists>i t tk. i \<le> j \<and> sq!i = ((Skip, t), tk) \<and> t \<in> Q))}"

lemma TermCond_D :
"sq \<in> TermCond \<rho> Q \<Longrightarrow>
 (\<forall>j < length sq. progOf(sq!j) = Skip \<longrightarrow>
 (\<exists>i t tk. i \<le> j \<and> sq!i = ((Skip, t), tk) \<and> t \<in> Q))"
  by(simp add: TermCond_def)

end