section \<open>Invariants for SCCs\<close>
theory DFS_Invars_SCC
imports
  DFS_Invars_Basic
begin

definition scc_root' :: "('v \<times> 'v) set \<Rightarrow> ('v,'es) state_scheme  \<Rightarrow> 'v \<Rightarrow> 'v set \<Rightarrow> bool"
    \<comment> \<open>@{term v} is a root of its scc
        iff all the discovered parts of the scc can be reached by tree edges from @{term v}\<close>
  where
  "scc_root' E s v scc \<longleftrightarrow> is_scc E scc
                       \<and> v \<in> scc
                       \<and> v \<in> dom (discovered s)
                       \<and> scc \<inter> dom (discovered s) \<subseteq> (tree_edges s)\<^sup>* `` {v}"

context param_DFS_defs begin
  abbreviation "scc_root \<equiv> scc_root' E"
  lemmas scc_root_def = scc_root'_def

  lemma scc_rootI:
    assumes "is_scc E scc"
    and "v \<in> dom (discovered s)"
    and "v \<in> scc"
    and "scc \<inter> dom (discovered s) \<subseteq> (tree_edges s)\<^sup>* `` {v}"
    shows "scc_root s v scc"
    using assms by (simp add: scc_root_def)

  definition "scc_roots s = {v. \<exists>scc. scc_root s v scc}"
end

context DFS_invar begin
  lemma scc_root_is_discovered:
    "scc_root s v scc \<Longrightarrow> v \<in> dom (discovered s)"
    by (simp add: scc_root_def)

  lemma scc_root_scc_tree_rtrancl:
    assumes "scc_root s v scc"
    and "x \<in> scc" "x \<in> dom (discovered s)"
    shows "(v,x) \<in> (tree_edges s)\<^sup>*"
    using assms
    by (auto simp add: scc_root_def)

  lemma scc_root_scc_reach:
    assumes "scc_root s r scc"
    and "v \<in> scc"
    shows "(r,v) \<in> E\<^sup>*"
  proof -
    from assms have "is_scc E scc" "r \<in> scc" by (simp_all add: scc_root_def)
    with is_scc_connected assms show ?thesis by metis
  qed

  lemma scc_reach_scc_root:
    assumes "scc_root s r scc"
    and "v \<in> scc"
    shows "(v,r) \<in> E\<^sup>*"
  proof -
    from assms have "is_scc E scc" "r \<in> scc" by (simp_all add: scc_root_def)
    with is_scc_connected assms show ?thesis by metis
  qed

  lemma scc_root_scc_tree_trancl:
    assumes "scc_root s v scc"
    and "x \<in> scc" "x \<in> dom (discovered s)" "x \<noteq> v"
    shows "(v,x) \<in> (tree_edges s)\<^sup>+"
    using assms scc_root_scc_tree_rtrancl
    by (auto simp add: rtrancl_eq_or_trancl)

  lemma scc_root_unique_scc:
    "scc_root s v scc \<Longrightarrow> scc_root s v scc' \<Longrightarrow> scc = scc'"
    unfolding scc_root_def
    by (metis is_scc_unique)

  lemma scc_root_unique_root:
    assumes scc1: "scc_root s v scc"
    and scc2: "scc_root s v' scc"
    shows "v = v'"
  proof (rule ccontr)
    assume "v \<noteq> v'"
    from scc1 have "v \<in> scc" "v \<in> dom (discovered s)"
      by (simp_all add: scc_root_def)
    with scc_root_scc_tree_trancl[OF scc2] \<open>v \<noteq> v'\<close> have "(v',v) \<in> (tree_edges s)\<^sup>+"
      by simp
    also from scc2 have "v' \<in> scc" "v' \<in> dom (discovered s)"
      by (simp_all add: scc_root_def)
    with scc_root_scc_tree_trancl[OF scc1] \<open>v\<noteq>v'\<close> have "(v,v') \<in> (tree_edges s)\<^sup>+"
      by simp
    finally show False using no_loop_in_tree by contradiction
  qed

  lemma scc_root_unique_is_scc:
    assumes "scc_root s v scc"
    shows "scc_root s v (scc_of E v)"
  proof -
    from assms have "v \<in> scc" "is_scc E scc" by (simp_all add: scc_root_def)
    moreover have "v \<in> scc_of E v" "is_scc E (scc_of E v)" by simp_all
    ultimately have "scc = scc_of E v" using is_scc_unique by metis
    thus ?thesis using assms by simp
  qed

  lemma scc_root_finished_impl_scc_finished:
    assumes "v \<in> dom (finished s)"
    and "scc_root s v scc"
    shows "scc \<subseteq> dom (finished s)"
  proof
    fix x
    assume "x \<in> scc"

    let ?E = "Restr E scc"

    from assms have "is_scc E scc" "v \<in> scc" by (simp_all add: scc_root_def)
    hence "(v,x) \<in> (Restr E scc)\<^sup>*" using \<open>x \<in> scc\<close>
      by (simp add: is_scc_connected')
    with rtrancl_is_path obtain p where "path ?E v p x" by metis
    thus "x \<in> dom (finished s)"
    proof (induction p arbitrary: x rule: rev_induct)
      case Nil hence "v = x" by simp
      with assms show ?case by simp
    next
      case (snoc y ys) hence "path ?E v ys y" "(y,x) \<in> ?E"
        by (simp_all add: path_append_conv)
      with snoc.IH have "y \<in> dom (finished s)" by simp
      moreover from \<open>(y,x) \<in> ?E\<close> have "(y,x) \<in> E" "x \<in> scc" by auto
      ultimately have "x \<in> dom (discovered s)"
        using finished_imp_succ_discovered
        by blast
      with \<open>x \<in> scc\<close> show ?case
        using assms scc_root_scc_tree_trancl tree_path_impl_parenthesis
        by blast
    qed
  qed

context begin interpretation timing_syntax .
  lemma scc_root_disc_le:
    assumes "scc_root s v scc"
    and "x \<in> scc" "x \<in> dom (discovered s)"
    shows "\<delta> s v \<le> \<delta> s x"
  proof (cases "x = v")
    case False with assms scc_root_scc_tree_trancl tree_path_disc have
      "\<delta> s v < \<delta> s x"
      by blast
    thus ?thesis by simp
  qed simp

  lemma scc_root_fin_ge:
    assumes "scc_root s v scc"
    and "v \<in> dom (finished s)"
    and "x \<in> scc"
    shows "\<phi> s v \<ge> \<phi> s x"
  proof (cases "x = v")
    case False
    from assms scc_root_finished_impl_scc_finished have
      "x \<in> dom (finished s)" by auto
    hence "x \<in> dom (discovered s)" using finished_discovered by auto
    with assms False have "(v,x) \<in> (tree_edges s)\<^sup>+"
      using scc_root_scc_tree_trancl by simp
    with tree_path_impl_parenthesis assms False show ?thesis by force
  qed simp

  lemma scc_root_is_Min_disc:
    assumes "scc_root s v scc"
    shows "Min (\<delta> s ` (scc \<inter> dom (discovered s))) = \<delta> s v" (is "Min ?S = _")
  proof (rule Min_eqI)
    from discovered_finite show "finite ?S" by auto
    from scc_root_disc_le[OF assms] show "\<And>y. y \<in> ?S \<Longrightarrow> \<delta> s v \<le> y" by force

    from assms have "v \<in> scc" "v \<in> dom (discovered s)"
      by (simp_all add: scc_root_def)
    thus "\<delta> s v \<in> ?S" by auto
  qed

  lemma Min_disc_is_scc_root:
    assumes "v \<in> scc" "v \<in> dom (discovered s)"
    and "is_scc E scc"
    and min: "\<delta> s v = Min (\<delta> s ` (scc \<inter> dom (discovered s)))"
    shows "scc_root s v scc"
  proof -
    {
      fix y
      assume A: "y \<in> scc" "y \<in> dom (discovered s)" "y \<noteq> v"
      with min have "\<delta> s v \<le> \<delta> s y" by auto
      with assms disc_unequal A have "\<delta> s v < \<delta> s y" by fastforce
    } note scc_disc = this

    {
      fix x
      assume A: "x \<in> scc \<inter> dom (discovered s)"

      have "x \<in> (tree_edges s)\<^sup>* `` {v}"
      proof (cases "v = x")
        case False with A scc_disc have \<delta>: "\<delta> s v < \<delta> s x" by simp

        have "(v,x) \<in> (tree_edges s)\<^sup>+"
        proof (cases "v \<in> dom (finished s)")
          case False with stack_set_def assms have
            v_stack: "v \<in> set (stack s)" by auto
          show ?thesis
          proof (cases "x \<in> dom (finished s)")
            case True
            with parenthesis_impl_tree_path_not_finished[of v x] assms \<delta> False
            show ?thesis by auto
          next
            case False with A stack_set_def have "x \<in> set (stack s)" by auto
            with v_stack \<delta> show ?thesis
              using on_stack_is_tree_path
              by simp
          qed
        next
          case True note v_fin = this

          let ?E = "Restr E scc"

          {
            fix y
            assume "(v, y) \<in> ?E" and "v \<noteq> y"
            hence *: "y \<in> succ v" "y \<in> scc" by auto
            with finished_imp_succ_discovered v_fin have
              "y \<in> dom (discovered s)" by simp
            with scc_disc \<open>v \<noteq> y\<close> * have "\<delta> s v < \<delta> s y" by simp
            with * finished_succ_impl_path_in_tree v_fin have "(v,y) \<in> (tree_edges s)\<^sup>+" by simp
          } note trancl_base = this

          from A have "x \<in> scc" by simp
          with assms have "(v,x) \<in> ?E\<^sup>*"
            by (simp add: is_scc_connected')
          with \<open>v\<noteq>x\<close> have "(v,x) \<in> ?E\<^sup>+" by (metis rtrancl_eq_or_trancl)
          thus ?thesis using \<open>v\<noteq>x\<close>
          proof (induction)
            case (base y) with trancl_base show ?case .
          next
            case (step y z)
            show ?case
            proof (cases "v = y")
              case True with step trancl_base show ?thesis by simp
            next
              case False with step have "(v,y) \<in> (tree_edges s)\<^sup>+" by simp
              with tree_path_impl_parenthesis[OF _ v_fin] have
                y_fin: "y \<in> dom (finished s)"
                and y_t: "\<delta> s v < \<delta> s y" "\<phi> s y < \<phi> s v"
                by auto
              with finished_discovered have y_disc: "y \<in> dom (discovered s)"
                by auto

              from step have *: "z \<in> succ y" "z \<in> scc" by auto
              with finished_imp_succ_discovered y_fin have
                z_disc: "z \<in> dom (discovered s)" by simp
              with * \<open>v\<noteq>z\<close> have \<delta>z: "\<delta> s v < \<delta> s z" by (simp add: scc_disc)

              from * edges_covered finished_no_pending[OF \<open>y \<in> dom (finished s)\<close>]
                   y_disc have "(y,z) \<in> edges s" by auto
              thus ?thesis
              proof safe
                assume "(y,z) \<in> tree_edges s" with \<open>(v,y) \<in> (tree_edges s)\<^sup>+\<close> show ?thesis ..
              next
                assume CE: "(y,z) \<in> cross_edges s"
                with cross_edges_finished_decr y_fin y_t have "\<phi> s z < \<phi> s v"
                  by force
                moreover note \<delta>z
                moreover from CE cross_edges_target_finished have
                  "z \<in> dom (finished s)" by simp
                ultimately show ?thesis
                  using parenthesis_impl_tree_path[OF v_fin] by metis
              next
                assume BE: "(y,z) \<in> back_edges s"
                with back_edge_disc_lt_fin y_fin y_t have
                  "\<delta> s z < \<phi> s v" by force
                moreover note \<delta>z
                moreover note z_disc
                ultimately have "z \<in> dom (finished s)" "\<phi> s z < \<phi> s v"
                  using parenthesis_contained[OF v_fin] by simp_all
                with \<delta>z show ?thesis
                  using parenthesis_impl_tree_path[OF v_fin] by metis
              qed
            qed
          qed
        qed
        thus ?thesis by auto
      qed simp
    }
    hence "scc \<inter> dom (discovered s) \<subseteq> (tree_edges s)\<^sup>* `` {v}" by blast

    with assms show ?thesis by (auto intro: scc_rootI)
  qed

  lemma scc_root_iff_Min_disc:
    assumes "is_scc E scc" "r \<in> scc" "r \<in> dom (discovered s)"
    shows "scc_root s r scc \<longleftrightarrow> Min (\<delta> s ` (scc \<inter> dom (discovered s))) = \<delta> s r" (is "?L \<longleftrightarrow> ?R")
  proof
    assume "?L" with scc_root_is_Min_disc show "?R" .
  next
    assume "?R" with Min_disc_is_scc_root assms show "?L" by simp
  qed

  lemma scc_root_exists:
    assumes "is_scc E scc"
    and scc: "scc \<inter> dom (discovered s) \<noteq> {}"
    shows "\<exists>r. scc_root s r scc"
  proof -
    let ?S = "scc \<inter> dom (discovered s)"

    from discovered_finite have "finite (\<delta> s`?S)" by auto
    moreover from scc have "\<delta> s ` ?S \<noteq> {}" by auto
    moreover have "\<And>(x::nat) f A. x \<notin> f ` A \<or> (\<exists>y. x = f y \<and> y \<in> A)" by blast
      \<comment> \<open>autogenerated by sledgehammer\<close>
    ultimately have "\<exists>x \<in> ?S. \<delta> s x = Min (\<delta> s ` ?S)" by (metis Min_in)
    with Min_disc_is_scc_root \<open>is_scc E scc\<close> show ?thesis by auto
  qed

  lemma scc_root_of_node_exists:
    assumes "v \<in> dom (discovered s)"
    shows "\<exists>r. scc_root s r (scc_of E v)"
  proof -
    have "is_scc E (scc_of E v)" by simp
    moreover have "v \<in> scc_of E v" by simp
    with assms have "scc_of E v \<inter> dom (discovered s) \<noteq> {}" by blast
    ultimately show ?thesis using scc_root_exists by metis
  qed

  lemma scc_root_transfer':
    assumes "discovered s = discovered s'" "tree_edges s = tree_edges s'"
    shows "scc_root s r scc \<longleftrightarrow> scc_root s' r scc"
    unfolding scc_root_def
    by (simp add: assms)

  lemma scc_root_transfer:
    assumes inv: "DFS_invar G param s'"
    assumes r_d: "r \<in> dom (discovered s)"
    assumes d: "dom (discovered s) \<subseteq> dom (discovered s')"
               "\<forall>x\<in>dom (discovered s). \<delta> s x = \<delta> s' x"
               "\<forall>x\<in>dom (discovered s') - dom (discovered s). \<delta> s' x \<ge> counter s"
    and t: "tree_edges s \<subseteq> tree_edges s'"
    shows "scc_root s r scc \<longleftrightarrow> scc_root s' r scc"
  proof -
    interpret s': DFS_invar where s=s' by fact

    let ?sd = "scc \<inter> dom (discovered s)"
    let ?sd' = "scc \<inter> dom (discovered s')"
    let ?sdd = "scc \<inter> (dom (discovered s') - dom (discovered s))"

    {
      assume r_s: "r \<in> scc" "is_scc E scc"
      with r_d have ne: "\<delta> s'`?sd \<noteq> {}" by blast
      from discovered_finite have fin: "finite (\<delta> s' ` ?sd)" by simp

      from timing_less_counter d have "\<And>x. x\<in>\<delta> s' ` ?sd \<Longrightarrow> x < counter s" by auto
      hence Min: "Min (\<delta> s' ` ?sd) < counter s"
        using Min_less_iff[OF fin] ne by blast

      from d have "Min (\<delta> s ` ?sd) = Min (\<delta> s' ` ?sd)" by (auto simp: image_def)
      also from d have "?sd' = ?sd \<union> ?sdd" by auto
      hence *: "\<delta> s' ` ?sd' = \<delta> s' ` ?sd \<union> \<delta> s' ` ?sdd" by auto
      hence "Min (\<delta> s' ` ?sd) = Min (\<delta> s' ` ?sd')"
      proof (cases "?sdd = {}")
        case False
        from d have "\<And>x. x \<in> \<delta> s' ` ?sdd \<Longrightarrow> x \<ge> counter s" by auto
        moreover from False have ne': "\<delta> s' ` ?sdd \<noteq> {}" by blast
        moreover from s'.discovered_finite have fin': "finite (\<delta> s' ` ?sdd)" by blast
        ultimately have "Min (\<delta> s' ` ?sdd) \<ge> counter s"
          using Min_ge_iff by metis
        with Min Min_Un[OF fin ne fin' ne'] * show ?thesis by simp
      qed simp
      finally have "Min (\<delta> s ` ?sd) = Min (\<delta> s' ` ?sd')" .
    } note aux = this

    show ?thesis
    proof
      assume r: "scc_root s r scc"
      from r_d d have "\<delta> s' r = \<delta> s r" by simp
      also from r scc_root_is_Min_disc have "\<delta> s r = Min (\<delta> s ` ?sd)" by simp
      also from r aux have "Min (\<delta> s ` ?sd) = Min (\<delta> s' ` ?sd')" by (simp add: scc_root_def)
      finally show "scc_root s' r scc"
        using r_d d r[unfolded scc_root_def]
        by (blast intro!: s'.Min_disc_is_scc_root)
    next
      assume r': "scc_root s' r scc"
      from r_d d have "\<delta> s r = \<delta> s' r" by simp
      also from r' s'.scc_root_is_Min_disc have "\<delta> s' r = Min (\<delta> s' ` ?sd')" by simp
      also from r' aux have "Min (\<delta> s' ` ?sd') = Min (\<delta> s ` ?sd)" by (simp add: scc_root_def)
      finally show "scc_root s r scc"
        using r_d d r'[unfolded scc_root_def]
        by (blast intro!: Min_disc_is_scc_root)
    qed
  qed

end end

end


section {* Small-step semantics of CBV lambda calculus *}

theory SmallStepLam
  imports Lambda
begin

text{*
  The following substitution function is not capture avoiding, so it has a precondition
  that $v$ is closed. With hindsight, we should have used DeBruijn indices instead
  because we also use substitution in the optimizing compiler.
*}
fun subst :: "name \<Rightarrow> exp \<Rightarrow> exp \<Rightarrow> exp" where
  "subst x v (EVar y) = (if x = y then v else EVar y)" |
  "subst x v (ENat n) = ENat n" |
  "subst x v (ELam y e) = (if x = y then ELam y e else ELam y (subst x v e))" |
  "subst x v (EApp e1 e2) = EApp (subst x v e1) (subst x v e2)" |
  "subst x v (EPrim f e1 e2) = EPrim f (subst x v e1) (subst x v e2)" |
  "subst x v (EIf e1 e2 e3) = EIf (subst x v e1) (subst x v e2) (subst x v e3)"

inductive isval :: "exp \<Rightarrow> bool" where
  valnat[intro!]: "isval (ENat n)" |
  vallam[intro!]: "isval (ELam x e)"

inductive_cases
  isval_var_inv[elim!]: "isval (EVar x)" and
  isval_app_inv[elim!]: "isval (EApp e1 e2)" and
  isval_prim_inv[elim!]: "isval (EPrim f e1 e2)" and
  isval_if_inv[elim!]: "isval (EIf e1 e2 e3)"

definition is_val :: "exp \<Rightarrow> bool" where
  "is_val v \<equiv> isval v \<and> FV v = {}"
declare is_val_def[simp]

inductive reduce :: "exp \<Rightarrow> exp \<Rightarrow> bool" (infix "\<longrightarrow>" 55) where
  beta[intro!]: "\<lbrakk> is_val v \<rbrakk> \<Longrightarrow> EApp (ELam x e) v \<longrightarrow> (subst x v e)" |
  app_left[intro!]: "\<lbrakk> e1 \<longrightarrow> e1' \<rbrakk> \<Longrightarrow> EApp e1 e2 \<longrightarrow> EApp e1' e2" |
  app_right[intro!]: "\<lbrakk> e2 \<longrightarrow> e2' \<rbrakk> \<Longrightarrow> EApp e1 e2 \<longrightarrow> EApp e1 e2'" |
  delta[intro!]: "EPrim f (ENat n1) (ENat n2) \<longrightarrow> ENat (f n1 n2)" |
  prim_left[intro!]: "\<lbrakk> e1 \<longrightarrow> e1' \<rbrakk> \<Longrightarrow> EPrim f e1 e2 \<longrightarrow> EPrim f e1' e2" |
  prim_right[intro!]: "\<lbrakk> e2 \<longrightarrow> e2' \<rbrakk> \<Longrightarrow> EPrim f e1 e2 \<longrightarrow> EPrim f e1 e2'" |
  if_zero[intro!]: "EIf (ENat 0) thn els \<longrightarrow> els" |
  if_nz[intro!]: "n \<noteq> 0 \<Longrightarrow> EIf (ENat n) thn els \<longrightarrow> thn" |
  if_cond[intro!]: "\<lbrakk> cond \<longrightarrow> cond' \<rbrakk> \<Longrightarrow>
    EIf cond thn els \<longrightarrow> EIf cond' thn els"

inductive_cases
  red_var_inv[elim!]: "EVar x \<longrightarrow> e" and
  red_int_inv[elim!]: "ENat n \<longrightarrow> e" and
  red_lam_inv[elim!]: "ELam x e \<longrightarrow> e'" and
  red_app_inv[elim!]: "EApp e1 e2 \<longrightarrow> e'"

inductive multi_step :: "exp \<Rightarrow> exp \<Rightarrow> bool" (infix "\<longrightarrow>*" 55) where
  ms_nil[intro!]: "e \<longrightarrow>* e" |
  ms_cons[intro!]: "\<lbrakk> e1 \<longrightarrow> e2; e2 \<longrightarrow>* e3 \<rbrakk> \<Longrightarrow> e1 \<longrightarrow>* e3"

definition diverge :: "exp \<Rightarrow> bool" where
  "diverge e \<equiv> (\<forall> e'. e \<longrightarrow>* e' \<longrightarrow> (\<exists> e''. e' \<longrightarrow> e''))"

definition stuck :: "exp \<Rightarrow> bool" where
  "stuck e \<equiv> \<not> (\<exists> e'. e \<longrightarrow> e')"
declare stuck_def[simp]

definition goes_wrong :: "exp \<Rightarrow> bool" where
  "goes_wrong e \<equiv> \<exists> e'. e \<longrightarrow>* e' \<and> stuck e' \<and> \<not> isval e'"
declare goes_wrong_def[simp]

datatype obs = ONat nat | OFun | OBad

fun observe :: "exp \<Rightarrow> obs \<Rightarrow> bool" where
  "observe (ENat n) (ONat n') = (n = n')" |
  "observe (ELam x e) OFun = True" |
  "observe e ob = False"

definition run :: "exp \<Rightarrow> obs \<Rightarrow> bool" (infix "\<Down>" 52) where
  "run e ob \<equiv> ((\<exists> v. e \<longrightarrow>* v \<and> observe v ob)
              \<or> ((diverge e \<or> goes_wrong e) \<and> ob = OBad))"

lemma val_stuck: fixes e::exp assumes val_e: "isval e" shows "stuck e"
proof (rule classical)
  assume "\<not> stuck e"
  from this obtain e' where red: "e \<longrightarrow> e'" by auto
  from val_e red have "False" by (case_tac e) auto
  from this show ?thesis ..
qed

lemma subst_fv_aux: assumes fvv: "FV v = {}" shows "FV (subst x v e) \<subseteq> FV e - {x}"
  using fvv
proof (induction e arbitrary: x v rule: exp.induct)
  case (EVar x)
  then show ?case by auto
next
  case (ENat x)
  then show ?case by auto
next
  case (ELam y e)
  then show ?case by (cases "x = y") auto
qed (simp,blast)+

lemma subst_fv:  assumes fv_e: "FV e \<subseteq> {x}" and fv_v: "FV v = {}"
  shows "FV (subst x v e) = {}"
  using fv_e fv_v subst_fv_aux by blast

lemma red_pres_fv:  fixes e::exp assumes red: "e \<longrightarrow> e'" and fv: "FV e = {}" shows "FV e' = {}"
  using red fv
proof (induction rule: reduce.induct)
  case (beta v x e)
  then show ?case using subst_fv by auto
qed fastforce+

lemma reduction_pres_fv: fixes e::exp assumes r: "e \<longrightarrow>* e'" and fv: "FV e = {}" shows "FV e' = {}"
  using r fv
proof (induction)
  case (ms_nil e)
  then show ?case by blast
next
  case (ms_cons e1 e2 e3)
  then show ?case using red_pres_fv by auto
qed

end


theory "HOLCF-Utils"
  imports HOLCF Pointwise
begin

default_sort type

lemmas cont_fun[simp]
lemmas cont2cont_fun[simp]

lemma cont_compose2:
  assumes "cont c"
  assumes "\<And> x. cont (c x)"
  assumes "cont f"
  assumes "cont g"
  shows "cont (\<lambda>x. c (f x) (g x))"
  by (rule cont_apply[OF assms(4) assms(2) cont2cont_fun[OF cont_compose[OF assms(1) assms(3)]]])

lemma pointwise_adm:
  fixes P :: "'a::pcpo \<Rightarrow> 'b::pcpo \<Rightarrow> bool"
  assumes "adm (\<lambda> x. P (fst x) (snd x))"
  shows "adm (\<lambda> m. pointwise P (fst m) (snd m))"
proof (rule admI)
  case (goal1 Y)
    show ?case
    apply (rule pointwiseI)
    apply (rule admD[OF adm_subst[where t = "\<lambda>p . (fst p x, snd p x)" for x, OF _ assms, simplified] `chain Y`])
    using goal1(2) unfolding pointwise_def by auto
qed

lemma fun_upd_mono:
  "\<rho>1 \<sqsubseteq> \<rho>2 \<Longrightarrow> v1 \<sqsubseteq> v2 \<Longrightarrow> \<rho>1(x := v1) \<sqsubseteq> \<rho>2(x := v2)"
  apply (rule fun_belowI)
  apply (case_tac "xa = x")
  apply simp
  apply (auto elim:fun_belowD)
  done

lemma fun_upd_cont[simp,cont2cont]:
  assumes "cont f" and "cont h"
  shows "cont (\<lambda> x. (f x)(v := h x) :: 'a \<Rightarrow> 'b::pcpo)"
  by (rule cont2cont_lambda)(auto simp add: assms)

subsubsection {* Composition of fun and cfun *}

lemma cont2cont_comp [simp, cont2cont]:
  assumes "cont f"
  assumes "\<And> x. cont (f x)"
  assumes "cont g"
  shows "cont (\<lambda> x. (f x) \<circ> (g x))"
  unfolding comp_def
  by (rule cont2cont_lambda)
     (intro cont2cont  `cont g` `cont f` cont_compose2[OF assms(1,2)] cont2cont_fun)

definition cfun_comp :: "('a::pcpo \<rightarrow> 'b::pcpo) \<rightarrow> ('c::type \<Rightarrow> 'a) \<rightarrow> ('c::type \<Rightarrow> 'b)"
  where  "cfun_comp = (\<Lambda> f \<rho>. (\<lambda> x. f\<cdot>x) \<circ> \<rho>)"

lemma cfun_comp_app[simp]: "(cfun_comp\<cdot>f\<cdot>\<rho>) x = f\<cdot>(\<rho> x)"
  unfolding cfun_comp_def by auto

lemma fix_eq_fix:
  "f\<cdot>(fix\<cdot>g) \<sqsubseteq> fix\<cdot>g \<Longrightarrow> g\<cdot>(fix\<cdot>f) \<sqsubseteq> fix\<cdot>f \<Longrightarrow> fix\<cdot>f = fix\<cdot>g"
  by (metis fix_least_below below_antisym)

subsection {* Additional transitivity rules *}

text {*
These collect side-conditions of the form @{term "cont f"}, so the usual way to discharge them
is to write @{text[source] "by this (intro cont2cont)+"} at the end.
*}

lemma below_trans_cong[trans]:
  "a \<sqsubseteq> f x \<Longrightarrow> x \<sqsubseteq> y \<Longrightarrow> cont f \<Longrightarrow> a \<sqsubseteq> f y "
by (metis below_trans cont2monofunE)

lemma not_bot_below_trans[trans]:
  "a \<noteq> \<bottom> \<Longrightarrow> a \<sqsubseteq> b \<Longrightarrow> b \<noteq> \<bottom>"
  by (metis below_bottom_iff)

lemma not_bot_below_trans_cong[trans]:
  "f a \<noteq> \<bottom> \<Longrightarrow> a \<sqsubseteq> b \<Longrightarrow> cont f \<Longrightarrow> f b \<noteq> \<bottom>"
  by (metis below_bottom_iff cont2monofunE)

end


section \<open> Circus Trace Merge \<close>

theory utp_circus_traces
  imports utp_circus_core
begin

subsection \<open> Function Definition \<close>

fun tr_par ::
  "'\<theta> set \<Rightarrow> '\<theta> list \<Rightarrow> '\<theta> list \<Rightarrow> '\<theta> list set" where
"tr_par cs [] [] = {[]}" |
"tr_par cs (e # t) [] = (if e \<in> cs then {[]} else {[e]} \<^sup>\<frown> (tr_par cs t []))" |
"tr_par cs [] (e # t) = (if e \<in> cs then {[]} else {[e]} \<^sup>\<frown> (tr_par cs [] t))" |
"tr_par cs (e\<^sub>1 # t\<^sub>1) (e\<^sub>2 # t\<^sub>2) =
  (if e\<^sub>1 = e\<^sub>2
    then
      if e\<^sub>1 \<in> cs (* \<and> e\<^sub>2 \<in> cs *)
        then {[e\<^sub>1]} \<^sup>\<frown> (tr_par cs t\<^sub>1 t\<^sub>2)
        else
          ({[e\<^sub>1]} \<^sup>\<frown> (tr_par cs t\<^sub>1 (e\<^sub>2 # t\<^sub>2))) \<union>
          ({[e\<^sub>2]} \<^sup>\<frown> (tr_par cs (e\<^sub>1 # t\<^sub>1) t\<^sub>2))
    else
      if e\<^sub>1 \<in> cs then
        if e\<^sub>2 \<in> cs then {[]}
        else
          {[e\<^sub>2]} \<^sup>\<frown> (tr_par cs (e\<^sub>1 # t\<^sub>1) t\<^sub>2)
      else
        if e\<^sub>2 \<in> cs then
          {[e\<^sub>1]} \<^sup>\<frown> (tr_par cs t\<^sub>1 (e\<^sub>2 # t\<^sub>2))
        else
          {[e\<^sub>1]} \<^sup>\<frown> (tr_par cs t\<^sub>1 (e\<^sub>2 # t\<^sub>2)) \<union>
          {[e\<^sub>2]} \<^sup>\<frown> (tr_par cs (e\<^sub>1 # t\<^sub>1) t\<^sub>2))"

abbreviation tr_inter :: "'\<theta> list \<Rightarrow> '\<theta> list \<Rightarrow> '\<theta> list set" (infixr "|||\<^sub>t" 100) where
"x |||\<^sub>t y \<equiv> tr_par {} x y"

subsection \<open> Lifted Trace Merge \<close>

syntax "_utr_par" ::
  "logic \<Rightarrow> logic \<Rightarrow> logic \<Rightarrow> logic" ("(_ \<star>\<^bsub>_\<^esub>/ _)" [100, 0, 101] 100)

text \<open> The function @{const trop} is used to lift ternary operators. \<close>

translations
  "t1 \<star>\<^bsub>cs\<^esub> t2" == "(CONST trop) (CONST tr_par) cs t1 t2"

subsection \<open> Trace Merge Lemmas \<close>

lemma tr_par_empty:
"tr_par cs t1 [] = {takeWhile (\<lambda>x. x \<notin> cs) t1}"
"tr_par cs [] t2 = {takeWhile (\<lambda>x. x \<notin> cs) t2}"
-- \<open> Subgoal 1 \<close>
apply (induct t1; simp)
-- \<open> Subgoal 2 \<close>
apply (induct t2; simp)
done

lemma tr_par_sym:
"tr_par cs t1 t2 = tr_par cs t2 t1"
apply (induct t1 arbitrary: t2)
-- \<open> Subgoal 1 \<close>
apply (simp add: tr_par_empty)
-- \<open> Subgoal 2 \<close>
apply (induct_tac t2)
-- \<open> Subgoal 2.1 \<close>
apply (clarsimp)
-- \<open> Subgoal 2.2 \<close>
apply (clarsimp)
apply (blast)
done

lemma tr_inter_sym: "x |||\<^sub>t y = y |||\<^sub>t x"
  by (simp add: tr_par_sym)

lemma trace_merge_nil [simp]: "x \<star>\<^bsub>{}\<^sub>u\<^esub> \<langle>\<rangle> = {x}\<^sub>u"
  by (pred_auto, simp_all add: tr_par_empty, metis takeWhile_eq_all_conv)

lemma trace_merge_empty [simp]:
  "(\<langle>\<rangle> \<star>\<^bsub>cs\<^esub> \<langle>\<rangle>) = {\<langle>\<rangle>}\<^sub>u"
  by (rel_auto)

lemma trace_merge_single_empty [simp]:
  "a \<in> cs \<Longrightarrow> \<langle>\<guillemotleft>a\<guillemotright>\<rangle> \<star>\<^bsub>\<guillemotleft>cs\<guillemotright>\<^esub> \<langle>\<rangle> = {\<langle>\<rangle>}\<^sub>u"
  by (rel_auto)

lemma trace_merge_empty_single [simp]:
  "a \<in> cs \<Longrightarrow> \<langle>\<rangle> \<star>\<^bsub>\<guillemotleft>cs\<guillemotright>\<^esub> \<langle>\<guillemotleft>a\<guillemotright>\<rangle> = {\<langle>\<rangle>}\<^sub>u"
  by (rel_auto)

lemma trace_merge_commute: "t\<^sub>1 \<star>\<^bsub>cs\<^esub> t\<^sub>2 = t\<^sub>2 \<star>\<^bsub>cs\<^esub> t\<^sub>1"
  by (rel_simp, simp add: tr_par_sym)

lemma csp_trace_simps [simp]:
  "v ^\<^sub>u \<langle>\<rangle> = v" "\<langle>\<rangle> ^\<^sub>u v = v"
  "v + \<langle>\<rangle> = v" "\<langle>\<rangle> + v = v"
  "bop (op #) x xs ^\<^sub>u ys = bop (op #) x (xs ^\<^sub>u ys)"
  by (rel_auto)+

end


subsection\<open>Ultrafilter Analysis of Scott's Variant (Fig.~3 in \<^cite>\<open>"C85"\<close>))\<close>

theory ScottVariant imports
  HOML
  MFilter
  BaseDefs
begin
text\<open>Axioms of Scott's variant.\<close>
axiomatization where
  A1: "\<lfloor>\<^bold>\<forall>X.((\<^bold>\<not>(\<P> X)) \<^bold>\<leftrightarrow> (\<P>(\<^bold>\<rightharpoondown>X)))\<rfloor>" and
  A2: "\<lfloor>\<^bold>\<forall>X Y.(((\<P> X) \<^bold>\<and> (X\<Rrightarrow>Y)) \<^bold>\<rightarrow> (\<P> Y))\<rfloor>" and
  A3: "\<lfloor>\<^bold>\<forall>\<Z>.((\<P>\<o>\<s> \<Z>) \<^bold>\<rightarrow> (\<^bold>\<forall>X.((X\<Sqinter>\<Z>) \<^bold>\<rightarrow> (\<P> X))))\<rfloor>" and
  A4: "\<lfloor>\<^bold>\<forall>X.((\<P> X) \<^bold>\<rightarrow> \<^bold>\<box>(\<P> X))\<rfloor>" and
  A5: "\<lfloor>\<P> \<N>\<E>\<rfloor>" and
  B:  "\<lfloor>\<^bold>\<forall>\<phi>.(\<phi> \<^bold>\<rightarrow> \<^bold>\<box>\<^bold>\<diamond>\<phi>)\<rfloor>" \<comment>\<open>Logic KB\<close>

lemma B': "\<forall>x y. \<not>(x\<^bold>ry) \<or> (y\<^bold>rx)" using B by fastforce

text\<open>Necessary existence of a Godlike entity.\<close>
theorem T6: "\<lfloor>\<^bold>\<box>(\<^bold>\<exists>\<^sup>E \<G>)\<rfloor>"
proof -
  have T1: "\<lfloor>\<^bold>\<forall>X.((\<P> X) \<^bold>\<rightarrow> \<^bold>\<diamond>(\<^bold>\<exists>\<^sup>E X))\<rfloor>" using A1 A2 by blast
  have T2: "\<lfloor>\<P> \<G>\<rfloor>" by (metis A3 G_def)
  have T3: "\<lfloor>\<^bold>\<diamond>(\<^bold>\<exists>\<^sup>E \<G>)\<rfloor>" using T1 T2 by simp
  have T4: "\<lfloor>\<^bold>\<forall>\<^sup>Ex.((\<G> x)\<^bold>\<rightarrow>(\<E> \<G> x))\<rfloor>" unfolding G_def E_def using A1 A4 by metis
  have T5: "\<lfloor>(\<^bold>\<diamond>(\<^bold>\<exists>\<^sup>E\<G>))\<^bold>\<rightarrow> \<^bold>\<box>(\<^bold>\<exists>\<^sup>E\<G>)\<rfloor>" by (smt A5 G_def B' NE_def T4)
  thus ?thesis using T3 by blast qed

text\<open>Existence of a Godlike entity.\<close>
lemma "\<lfloor>\<^bold>\<exists>\<^sup>E \<G>\<rfloor>" using A1 A2 B' T6 by blast

text\<open>Consistency\<close>
lemma True nitpick[satisfy] oops \<comment>\<open>Model found.\<close>

text\<open>Modal collapse: holds.\<close>
lemma MC: "\<lfloor>\<^bold>\<forall>\<Phi>.(\<Phi> \<^bold>\<rightarrow> \<^bold>\<box>\<Phi>)\<rfloor>"
proof - {
    fix w fix Q
    have 1: "\<forall>x.((\<G> x w) \<longrightarrow> (\<^bold>\<forall>Z.((Z x) \<^bold>\<rightarrow> \<^bold>\<box>(\<^bold>\<forall>\<^sup>Ez.((\<G> z) \<^bold>\<rightarrow> (Z z))))) w)"
      by (metis A1 A4 G_def)
    have 2: "(\<exists>x. \<G> x w)\<longrightarrow>((Q \<^bold>\<rightarrow> \<^bold>\<box>(\<^bold>\<forall>\<^sup>Ez.((\<G> z) \<^bold>\<rightarrow> Q))) w)"
      using 1 by force
    have 3: "(Q \<^bold>\<rightarrow> \<^bold>\<box>Q) w" using B' T6 2 by blast}
  thus ?thesis by auto qed

text\<open>Analysis of positive properties using ultrafilters.\<close>
theorem U1: "\<lfloor>UFilter \<P>\<rfloor>"  \<comment>\<open>Proof found by sledgehammer\<close>
proof -
  have 1: "\<lfloor>(\<^bold>U\<^bold>\<in>\<P>) \<^bold>\<and> \<^bold>\<not>(\<^bold>\<emptyset>\<^bold>\<in>\<P>)\<rfloor>"  using A1 A2 by blast
  have 2: "\<lfloor>\<^bold>\<forall>\<phi> \<psi>.(((\<phi>\<^bold>\<in>\<P>)\<^bold>\<and>(\<phi>\<^bold>\<subseteq>\<psi>))\<^bold>\<rightarrow>(\<psi>\<^bold>\<in>\<P>))\<rfloor>"  by (smt A2 B' MC)
  have 3: "\<lfloor>\<^bold>\<forall>\<phi> \<psi>.(((\<phi>\<^bold>\<in>\<P>)\<^bold>\<and>(\<psi>\<^bold>\<in>\<P>))\<^bold>\<rightarrow>((\<phi>\<^bold>\<sqinter>\<psi>)\<^bold>\<in>\<P>))\<rfloor>" by (metis A1 A2 G_def B' T6)
  have 4: "\<lfloor>\<^bold>\<forall>\<phi>.((\<phi>\<^bold>\<in>\<P>) \<^bold>\<or> ((\<inverse>\<phi>)\<^bold>\<in>\<P>))\<rfloor>"  using A1 by blast
  thus ?thesis using 1 2 3 4 by simp qed

lemma L1: "\<lfloor>\<^bold>\<forall>X Y.((X\<Rrightarrow>Y) \<^bold>\<rightarrow> (X\<^bold>\<sqsubseteq>Y))\<rfloor>" by (metis A1 A2 MC)
lemma L2: "\<lfloor>\<^bold>\<forall>X Y.(((\<P> X) \<^bold>\<and> (X\<^bold>\<sqsubseteq>Y)) \<^bold>\<rightarrow> (\<P> Y))\<rfloor>" by (smt A2 B' MC)

text\<open>Set of supersets of X, we call this HF X.\<close>
abbreviation HF where "HF X \<equiv> \<lambda>Y.(X\<^bold>\<sqsubseteq>Y)"

text\<open>\<open>HF \<G>\<close> is a filter; hence, \<open>HF \<G>\<close> is Hauptfilter of \<open>\<G>\<close>.\<close>
lemma F1: "\<lfloor>Filter (HF \<G>)\<rfloor>" by (metis A2 B' T6 U1)
lemma F2: "\<lfloor>UFilter (HF \<G>)\<rfloor>" by (smt A1 F1 G_def)

text\<open>T6 follows directly from F1.\<close>
theorem T6again: "\<lfloor>\<^bold>\<box>(\<^bold>\<exists>\<^sup>E \<G>)\<rfloor>" using F1 by simp
end


theory PHL
  imports MonoPredicateTransformers
begin

definition ht :: "'a :: bbi \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> bool"  where
  "ht p F q \<equiv> p \<le> F q"

lemma ht_skip: "p \<le> q \<Longrightarrow> ht p id q"
  by (simp add: ht_def)

lemma ht_skip': "ht p id p"
  by (simp add: ht_def)

lemma ht_strengthen: "p' \<le> p \<Longrightarrow> ht p F q \<Longrightarrow> ht p' F q"
  by (simp add: ht_def)

lemma ht_choice: "ht p F q \<Longrightarrow> ht p G q \<Longrightarrow> ht p (F + G) q"
  apply (simp add: ht_def)
  by (metis le_supI2)

notation Sup.qstar ("_\<^sup>\<star>" [1000] 1000)
lemma ht_iteration: "ht p F q \<Longrightarrow> ht p F\<^sup>\<star> q"
  apply (simp add: ht_def)
  by (metis (erased, hide_lams) Sup.order_trans Sup.qisol Sup.qstar_unfoldl_var le_fun_def quantale_unital_class.Sup.qstar_ref qunitr_fun)

lift_definition ht_mono :: "'a :: bbi \<Rightarrow> 'a mtran \<Rightarrow> 'a \<Rightarrow> bool" is "\<lambda>p F q. ht p F q" .

lemma ht_weaken': "q \<le> q' \<Longrightarrow> ht p F q \<Longrightarrow> ht p F q'"
  (* nitpick *) oops

lemma ht_weaken: "q \<le> q' \<Longrightarrow> ht_mono p F q \<Longrightarrow> ht_mono p F q'"
  apply transfer
  apply (simp add: ht_def)
  by (metis mono_def order_trans)

lemma ht_seq: "ht p F r \<Longrightarrow> ht r G q \<Longrightarrow> ht p (F \<cdot> G) q"
  (* nitpick *) oops

lemma ht_seq: "ht_mono p F r \<Longrightarrow> ht_mono r G q \<Longrightarrow> ht_mono p (F \<cdot> G) q"
  apply transfer
  apply (simp add: ht_def)
  by (metis Sup.order_trans monoE)

end


theory sas
imports "../../CSP-Prover/CSP_F/CSP_F"
begin

typedef ActuatorId = "{1..4}::nat set" morphisms to_nat to_ActuatorId
by (auto)

setup_lifting type_definition_ActuatorId

declare [[coercion to_ActuatorId]]

code_thms to_ActuatorId

type_synonym displacement = real
type_synonym angularVelocity = real
type_synonym voltage = real

definition dMAX :: "displacement"
where "dMAX = 40"

definition dMIN :: "displacement"
where "dMIN = -40"

fun gain :: "real \<times> real \<Rightarrow> real"
where "gain(x,k) = x * k"

fun saturate :: "real \<Rightarrow> real"
where "saturate(x) = max dMIN (min x dMAX)"

fun dOmega :: "displacement \<Rightarrow> angularVelocity"
where "dOmega(e) = saturate(gain(e,20))"

fun disp :: "angularVelocity \<Rightarrow> displacement"
where "disp(v) = v / 20"

fun modulate :: "voltage \<Rightarrow> displacement"
where "modulate(v) = v / 10"

fun senseVoltage :: "displacement \<Rightarrow> voltage"
where "senseVoltage(p) = gain(p,10)"

lemma modulate_senseVoltage [simp]: "(modulate (senseVoltage a)) = a"
by (auto)

lemma senseVoltage_modulate [simp]: "(senseVoltage (modulate a)) = a"
by (auto)

declare gain.simps [simp del]
declare saturate.simps [simp del]
declare dOmega.simps [simp del]
declare disp.simps [simp del]
declare modulate.simps [simp del]
declare senseVoltage.simps [simp del]

datatype Events = rawPosition ActuatorId displacement
                | adjust ActuatorId displacement
                | coreMoved ActuatorId displacement
                | lvdtOutput ActuatorId voltage
                | ehsvOutput ActuatorId displacement
                | servoCmd ActuatorId displacement
                | controlCmd ActuatorId displacement
                | feedbackPos ActuatorId voltage

datatype PN = ACE ActuatorId
            | EHSV ActuatorId
            | Raw ActuatorId displacement
            | LVDT ActuatorId

primrec PNfun :: "PN \<Rightarrow> (PN,Events) proc"
where
    "PNfun(ACE i) =
           controlCmd(i) ? p \<rightarrow> feedbackPos(i) ? feedback \<rightarrow> servoCmd(i) ! (saturate(p - feedback)) \<rightarrow> $ACE i"
  | "PNfun(EHSV i) =
           rawPosition(i) ? p \<rightarrow> servoCmd(i) ? e \<rightarrow> ehsvOutput(i) ! (p - disp (dOmega e)) \<rightarrow> $EHSV i"
  | "PNfun(Raw i p) =
           rawPosition(i) ! p \<rightarrow> $Raw i p
           [+] adjust(i) ? adj \<rightarrow> $Raw i (saturate (p + adj))"
  | "PNfun(LVDT i) =
           coreMoved(i) ? p \<rightarrow> lvdtOutput(i) ! (modulate (senseVoltage p)) \<rightarrow> $LVDT i"

overloading Set_PNfun ==
  "CSP_syntax.PNfun :: (PN,Events)pnfun"
begin
  definition "CSP_syntax.PNfun == PNfun::((PN,Events) pnfun)"
end
declare Set_PNfun_def [simp add]

lemma guardedfun_PNfun [simp]: "guardedfun PNfun"
  apply (simp add: guardedfun_def)
  by (rule allI, induct_tac p, simp_all add: Let_def)

definition PCU
where "PCU i p0 ==
            (
              $EHSV i [[ ehsvOutput i <== adjust i ]]
              |[ {| rawPosition i, adjust i |}\<^sub>c ]|
              ( $Raw i p0 )
            )
            |[ {| rawPosition i |}\<^sub>c ]|
            ( $LVDT i [[ coreMoved i <== rawPosition i ]] [[ lvdtOutput i <== feedbackPos i ]] )"

definition ACE_PCU
where "ACE_PCU i p0 ==
           $ACE i
           |[ {| servoCmd i, feedbackPos i |}\<^sub>c ]|
           PCU i p0"

definition SimpleActuator
where "SimpleActuator i == ACE_PCU i 0"

end


(*
 * Copyright (c) 2020, CleanQ Project - Systems Group, ETH Zurich
 * All rights reserved.
 *
 * This software may be distributed and modified according to the terms of
 * the BSD 2-Clause license. Note that NO WARRANTY is provided.
 *
 * See "LICENSE" for details.
 *
 * SPDX-License-Identifier: BSD-2-Clause
 *)

section "CleanQ Abstract List Model"

text \<open>
  We define a first refinement of the abstract model based on sets. We redefine the
  transfer sets as lists in order to get the FIFO for the transfer from X to Y and
  vice versa. We define the model of this first refinement in the the following
  Isabelle theory:
\<close>

theory CleanQ_ListModel
(*<*)
  imports Main CleanQ_SetModel CleanQ_Utils
(*>*)
begin

(* ==================================================================================== *)
subsection \<open>State Definition\<close>
(* ==================================================================================== *)

text \<open>
  Similar to the abstract set model, We express a system with a single point-to-point
  queue between two agents $X$ and $Y$. However, in contrast we now use lists instead
  of sets for the transfer between the two agents.  The state of the abstract CleanQ List
  model is captured in the Isabelle record \verb+CleanQ_List_State+. Like the previous
  model, we express the buffers owned by $X$ or $Y$ as sets.

  \<^item> lSX: this is the set of buffers owned by X.
  \<^item> lSY: this is the set of buffers owned by Y.
  \<^item> lTXY: this is a list of buffers in transfer from X to Y.
  \<^item> lTYX: this is a list of buffers in transfer from Y to X.
\<close>

record 'a CleanQ_List_State =
  lSX  :: "'a set"
  lSY  :: "'a set"
  lTXY :: "'a list"
  lTYX :: "'a list"

text \<open>
  Like the abstract set model,  we do not specify the representation of the buffer
  elements. This can be a single, fixed-sized page frame, a variable-sized base-limit
  segment, or a set of memory locations.
\<close>

(*<*)
(* Define some global variables to make Simpl/Complex proofs work *)
record 'g CleanQ_List_State_vars =
  ListRB_'  :: "nat CleanQ_List_State"
  ListB_'   ::  nat
(*>*)

(* ==================================================================================== *)
subsection \<open>State Lifting Function\<close>
(* ==================================================================================== *)

text \<open>
  The CleanQ List model is a data refinement of the CleanQ Set Model. We can define an
  interpretation function. That lifts the CleanQ list model state into the CleanQ
  set model state by taking the \verb+set+ of the transfer lists.
\<close>

definition CleanQ_List2Set :: "'a CleanQ_List_State  \<Rightarrow> 'a CleanQ_Set_State"
  where "CleanQ_List2Set l = \<lparr> SX = lSX l, SY = lSY l,
                               TXY = set (lTXY l), TYX = set (lTYX l) \<rparr>"

(* ==================================================================================== *)
subsection \<open>CleanQ List Model Invariants\<close>
(* ==================================================================================== *)

text \<open>
  We now formulate the invariants I1 and I2 under the the CleanQ list model, and add
  an additional invariant I3.
\<close>

(* ------------------------------------------------------------------------------------ *)
subsubsection \<open>I1: Constant Union (Image)\<close>
(* ------------------------------------------------------------------------------------ *)

text \<open>
  The union of all sets is constant. We formulate this as an image for
  \verb+CleanQ_List+ where we take the set of the transfer lists and apply the
  union.
\<close>

definition I1_list_img :: "'a CleanQ_List_State \<Rightarrow> 'a set \<Rightarrow> bool"
  where "I1_list_img rb K \<longleftrightarrow> ((lSX rb) \<union> (lSY rb) \<union> set (lTXY rb) \<union> set (lTYX rb)) = K"

text \<open>
  We can show that the image of the invariant satisfies the original invariant I1 when
  we apply the lifting function \verb+CleanQ_List2Set+ to the model state. We prove
  this in the following lemma.
\<close>

lemma I1_list_img_lift:
  "I1_list_img L K = I1 (CleanQ_List2Set L) K"
  unfolding CleanQ_List2Set_def I1_def I1_list_img_def by(simp)

(* ------------------------------------------------------------------------------------ *)
subsubsection \<open>I2: Pairwise Empty (Image)\<close>
(* ------------------------------------------------------------------------------------ *)

text \<open>
 All pairwise intersections are empty. Again, we formulate this as an image for
 \verb+CleanQ_List+ by taking the set of the transfer lists.
\<close>

definition I2_list_img :: "'a CleanQ_List_State \<Rightarrow> bool"
  where "I2_list_img rb \<longleftrightarrow> lSX rb \<inter> lSY rb = {} \<and> lSX rb \<inter> set (lTXY rb) = {} \<and>
                       lSX rb \<inter> set (lTYX rb) = {} \<and> lSY rb \<inter> set (lTXY rb) = {} \<and>
                       lSY rb \<inter> set (lTYX rb) = {} \<and> set (lTXY rb) \<inter> set (lTYX rb) = {}"

text \<open>
  Finally, we can show that the image of the Invariant I2 is equivalent to the original
  invariant, when we lift the CleanQ List State to the CleanQ Set State. We prove this
  in the following lemma:
\<close>

lemma I2_list_img_lift:
  "I2_list_img L = I2 (CleanQ_List2Set L)"
  unfolding CleanQ_List2Set_def I2_def I2_list_img_def  by(simp)

(* ------------------------------------------------------------------------------------ *)
subsubsection \<open>I3: Distinct Transfer Lists\<close>
(* ------------------------------------------------------------------------------------ *)

text \<open>
  In contrast to sets, an element can be in a list twice. Thus we need to rule out,
  that a buffer can be present in a list twice. This invariant is required for the
  move from sets to lists. In sets an element occurs only once while in lists it can
  occur multiple times. If we map the list which contains twice the same element,
  it would be mapped to only a single set element. In order to avoid this the elements
  of the lists need to be distinct
\<close>

definition  I3 :: "'a CleanQ_List_State \<Rightarrow> bool"
  where "I3 st_list \<longleftrightarrow> distinct (lTXY st_list) \<and> distinct (lTYX st_list)"

text \<open>
  Form the invariant I3, we obtain that the cardinality of the sets in the lifted
  CleanQ set state is the same as the length of the lists.
\<close>

lemma I3_cardinality :
  assumes I3_holds : "I3 L"  and  lift: "LS = CleanQ_List2Set L"
    shows "length (lTXY L) = card (TXY LS) \<and> length (lTYX L) = card (TYX LS)"
  using I3_holds lift unfolding CleanQ_List2Set_def
  by (metis CleanQ_List2Set_def CleanQ_Set_State.ext_inject CleanQ_Set_State.surjective
            I3_def assms(2) distinct_card)

(* ------------------------------------------------------------------------------------ *)
subsubsection \<open>All CleanQ List Invariants\<close>
(* ------------------------------------------------------------------------------------ *)

text \<open>
  We combine all invariants for the abstract CleanQ list model and define the unified
  predicate \verb+CleanQ_List_Invariants+.
\<close>

definition CleanQ_List_Invariants :: "'a set \<Rightarrow> 'a CleanQ_List_State \<Rightarrow> bool"
  where "CleanQ_List_Invariants K rb \<longleftrightarrow> I1_list_img rb K \<and> I2_list_img rb \<and> I3 rb"

lemmas CleanQ_List_Invariants_simp = CleanQ_List_Invariants_def I1_list_img_def
                                     I2_list_img_def I3_def

text \<open>
  Finally, we can show that when the CleanQ List invariants are satisfied, this also
  satisfies the set invariants.
\<close>

lemma CleanQ_List_Invariants_Set_Invariants:
  "CleanQ_List_Invariants K L \<Longrightarrow> CleanQ_Set_Invariants K (CleanQ_List2Set L)"
  by (simp add: CleanQ_List_Invariants_def CleanQ_Set_Invariants_def
                I1_list_img_lift I2_list_img_lift)

(* ==================================================================================== *)
subsection \<open>State Transition Operations\<close>
(* ==================================================================================== *)

text \<open>
  We now formulate the state transition operations in terms of the CleanQ List model
  state. Again,  the two agents can, independently from each other, perform one of
  two operations, \verb+enqueue+ and \verb+dequeue+,  which trigger an ownership
  transfer of buffer elements.
\<close>

(* ------------------------------------------------------------------------------------ *)
subsubsection \<open>Enqueue Operation\<close>
(* ------------------------------------------------------------------------------------ *)

text \<open>
  The \verb+enqueue+ operation is analogous to the Set operations except that the elements
  are added to the list instead of inserted to the set. Note, we always insert the
  element at the end of the list.
\<close>

definition CleanQ_List_enq_x :: "'a \<Rightarrow> 'a CleanQ_List_State  \<Rightarrow> 'a CleanQ_List_State"
  where "CleanQ_List_enq_x b rb = rb \<lparr> lSX := (lSX rb) - {b}, lTXY := lTXY rb @ [b] \<rparr>"

definition CleanQ_List_enq_y :: "'a \<Rightarrow> 'a CleanQ_List_State  \<Rightarrow> 'a CleanQ_List_State"
  where "CleanQ_List_enq_y b rb = rb \<lparr> lSY := (lSY rb) - {b}, lTYX := lTYX rb @ [b] \<rparr>"

text \<open>
  These definitions are the same as producing a new record:
\<close>
lemma CleanQ_List_enq_x_upd :
  "CleanQ_List_enq_x b rb = \<lparr> lSX = (lSX rb) - {b},  lSY = (lSY rb),
                              lTXY = (lTXY rb) @ [b],  lTYX = (lTYX rb) \<rparr>"
  by(simp add:CleanQ_List_enq_x_def)

lemma CleanQ_List_enq_y_upd :
  "CleanQ_List_enq_y b rb = \<lparr> lSX = (lSX rb), lSY = (lSY rb) - {b},
                              lTXY = (lTXY rb), lTYX = (lTYX rb) @ [b] \<rparr>"
  by(simp add:CleanQ_List_enq_y_def)

text \<open>
  We can now show that the result of the \verb+enqueue+ operation is the same as the
  \verb+enqueue+ operation on the set model. This is the refinement proof for the
  \verb+enqueue+ operation, showing commutative equivalence.
\<close>

lemma CleanQ_List_enq_x_equal :
  "CleanQ_List2Set (CleanQ_List_enq_x b rb) = CleanQ_Set_enq_x b (CleanQ_List2Set rb)"
  unfolding CleanQ_List2Set_def CleanQ_Set_enq_x_def CleanQ_List_enq_x_def
  by(auto)

lemma CleanQ_List_enq_y_equal :
  "CleanQ_List2Set (CleanQ_List_enq_y b rb) = CleanQ_Set_enq_y b (CleanQ_List2Set rb)"
  unfolding CleanQ_List2Set_def CleanQ_Set_enq_y_def CleanQ_List_enq_y_def
  by(auto)

text \<open>
  The enqueue operations move buffers around different sets and lists. We define a
  few helper lemmas, which allow us to talk about where the buffer ends up.
\<close>

lemma CleanQ_List_enq_x_result :
assumes X_owned: "b \<in> lSX rb"  and  X_enq: "rb' = CleanQ_List_enq_x b rb"
    and I2_holds : "I2_list_img rb"
  shows  "b \<in> set (lTXY rb') \<and> b \<notin> lSX rb' \<and> b \<notin> lSY rb' \<and> b \<notin> set (lTYX rb')"
  using X_owned X_enq I2_holds unfolding CleanQ_List_enq_x_def by(auto simp:I2_list_img_def)

lemma CleanQ_List_enq_y_result :
assumes Y_owned: "b \<in> lSY rb"  and  X_enq: "rb' = CleanQ_List_enq_y b rb"
    and I2_holds : "I2_list_img rb"
  shows  "b \<in> set (lTYX rb') \<and> b \<notin> lSY rb' \<and> b \<notin> lSX rb' \<and> b \<notin> set (lTXY rb')"
  using Y_owned X_enq I2_holds unfolding CleanQ_List_enq_y_def by(auto simp:I2_list_img_def)

text \<open>
  Not only we can say that it is in the set of the list, we can even say that
  the buffer is precisely at the end of it.
\<close>

lemma CleanQ_List_enq_x_result_p :
assumes X_owned: "b \<in> lSX rb"  and  X_enq: "rb' = CleanQ_List_enq_x b rb"
    and I2_holds : "I2_list_img rb"
  shows  "b = last (lTXY rb') \<and> b \<notin> lSX rb' \<and> b \<notin> lSY rb' \<and> b \<notin> set (lTYX rb')"
  using X_owned X_enq I2_holds unfolding CleanQ_List_enq_x_def by(auto simp:I2_list_img_def)

lemma CleanQ_List_enq_y_result_p :
assumes Y_owned: "b \<in> lSY rb"  and  X_enq: "rb' = CleanQ_List_enq_y b rb"
    and I2_holds : "I2_list_img rb"
  shows  "b = last (lTYX rb') \<and> b \<notin> lSY rb' \<and> b \<notin> lSX rb' \<and> b \<notin> set (lTXY rb')"
  using Y_owned X_enq I2_holds unfolding CleanQ_List_enq_y_def by(auto simp:I2_list_img_def)

text \<open>
  The two operations \verb+CleanQ_Set_enq_x+ and \verb+CleanQ_Set_enq_y+ transition
  the model state. Thus we need to prove that all invariants are preserved. We do this
  Individually first, then do the union. Note, the proofs are symmetric.
\<close>

lemma CleanQ_List_enq_x_I1 :
assumes I1_holds: "I1_list_img rb K"  and  X_owned: "b \<in> lSX rb"
  shows "I1_list_img (CleanQ_List_enq_x b rb) K"
  using I1_holds X_owned unfolding CleanQ_List_enq_x_def I1_list_img_def  by auto

lemma CleanQ_List_enq_y_I1 :
assumes I1_holds: "I1_list_img rb K"  and  X_owned: "b \<in> lSY rb"
  shows "I1_list_img (CleanQ_List_enq_y b rb) K"
  using I1_holds X_owned unfolding CleanQ_List_enq_y_def I1_list_img_def  by auto

lemma CleanQ_List_enq_x_I2 :
assumes  I2_holds: "I2_list_img rb"   and  X_owned: "b \<in> lSX rb"
  shows "I2_list_img (CleanQ_List_enq_x b rb)"
  using I2_holds X_owned unfolding CleanQ_List_enq_x_def I2_list_img_def  by auto

lemma CleanQ_List_enq_y_I2 :
assumes I2_holds: "I2_list_img rb"    and  X_owned: "b \<in> lSY rb"
  shows "I2_list_img (CleanQ_List_enq_y b rb)"
  using I2_holds X_owned unfolding CleanQ_List_enq_y_def I2_list_img_def  by auto

lemma CleanQ_List_enq_x_I3 :
assumes I2_holds: "I2_list_img rb" and I3_holds: "I3 rb"  and  X_owned: "b \<in> lSX rb"
  shows "I3 (CleanQ_List_enq_x b rb)"
  using I2_holds I3_holds X_owned  unfolding CleanQ_List_enq_x_def I3_def I2_list_img_def
  by auto

lemma CleanQ_List_enq_y_I3 :
assumes  I2_holds: "I2_list_img rb" and I3_holds: "I3 rb"  and  X_owned: "b \<in> lSY rb"
  shows "I3 (CleanQ_List_enq_y b rb)"
  using I2_holds I3_holds X_owned  unfolding CleanQ_List_enq_y_def I3_def I2_list_img_def
  by auto

text \<open>
  Invariants I1, I2, and I3 are preserved by \verb+enqueue+ operations, thus we can
  combine them to obtain show that the combined predicate \verb+CleanQ_List_Invariants+
  always holds.
\<close>

lemma CleanQ_List_enq_x_Invariants :
assumes I_holds : "CleanQ_List_Invariants K rb"  and  X_owned: "b \<in> lSX rb"
  shows "CleanQ_List_Invariants K (CleanQ_List_enq_x b rb)"
  using assms unfolding CleanQ_List_Invariants_def
  by(simp add:CleanQ_List_enq_x_I1 CleanQ_List_enq_x_I2 CleanQ_List_enq_x_I3)

lemma CleanQ_List_enq_y_Invariants :
assumes I_holds : "CleanQ_List_Invariants K rb"  and  Y_owned: "b \<in> lSY rb"
  shows "CleanQ_List_Invariants K (CleanQ_List_enq_y b rb)"
  using assms unfolding CleanQ_List_Invariants_def
  by(simp add:CleanQ_List_enq_y_I1 CleanQ_List_enq_y_I2 CleanQ_List_enq_y_I3)

text \<open>
  Finally, we can show that the invariants of the set model are preserved.
\<close>

lemma CleanQ_List_enq_x_Set_Invariants :
  assumes I_holds : "CleanQ_List_Invariants K rb"  and  X_owned: "b \<in> lSX rb"
      and RB_upd: "rb' = CleanQ_List_enq_x b rb"
  shows "CleanQ_Set_Invariants K (CleanQ_List2Set rb')"
  by (metis CleanQ_List_Invariants_Set_Invariants CleanQ_List_enq_x_Invariants assms)

lemma CleanQ_List_enq_y_Set_Invariants :
  assumes I_holds : "CleanQ_List_Invariants K rb"  and  Y_owned: "b \<in> lSY rb"
      and RB_upd: "rb' = CleanQ_List_enq_y b rb"
  shows "CleanQ_Set_Invariants K (CleanQ_List2Set rb')"
  by (metis CleanQ_List_Invariants_Set_Invariants CleanQ_List_enq_y_Invariants assms)

(* ------------------------------------------------------------------------------------ *)
subsubsection \<open>Dequeue Operation\<close>
(* ------------------------------------------------------------------------------------ *)

text \<open>
  The \verb+dequeue+ operation is analogous to the Set operations except that the elements
  are removed from the list instead of inserted to the set. Note, we always remove the
  element at the front of the list.
\<close>

definition CleanQ_List_deq_x :: "'a CleanQ_List_State  \<Rightarrow> 'a CleanQ_List_State"
  where "CleanQ_List_deq_x rb = rb \<lparr> lSX := (lSX rb) \<union> {hd (lTYX rb)},
                                     lTYX := tl (lTYX rb) \<rparr>"

definition CleanQ_List_deq_y :: "'a CleanQ_List_State  \<Rightarrow> 'a CleanQ_List_State"
  where "CleanQ_List_deq_y rb = rb \<lparr> lSY := (lSY rb) \<union> {hd (lTXY rb)},
                                     lTXY := tl (lTXY rb) \<rparr>"

text \<open>
  These definitions are the same as producing a new record, instead of updating the old one
\<close>

lemma CleanQ_List_deq_x_upd :
  "CleanQ_List_deq_x rb = \<lparr> lSX = (lSX rb) \<union> {hd (lTYX rb)}, lSY = lSY rb,
                            lTXY = lTXY rb, lTYX = tl (lTYX rb) \<rparr>"
  by (simp add: CleanQ_List_deq_x_def)

lemma CleanQ_List_deq_y_upd :
  "CleanQ_List_deq_y rb = \<lparr> lSX = lSX rb, lSY = (lSY rb) \<union> {hd (lTXY rb)},
                            lTXY = tl (lTXY rb), lTYX = lTYX rb \<rparr>"
  by(simp add:CleanQ_List_deq_y_def)

text \<open>
  We can express the dequeue operation using \verb+drop 1+ and \verb+take 1+ instead of
  using head and tail.
\<close>

lemma CleanQ_List_deq_x_drop_take :
  "lTYX rb \<noteq> [] \<Longrightarrow> CleanQ_List_deq_x rb = rb \<lparr> lSX := (lSX rb) \<union> set (take 1 (lTYX rb)),
                                     lTYX := drop 1 (lTYX rb) \<rparr>"
  unfolding CleanQ_List_deq_x_def
  by(auto simp add:list_tail_drop_one list_head_take_one_set2)

lemma CleanQ_List_deq_y_drop_take :
  "lTXY rb \<noteq> [] \<Longrightarrow> CleanQ_List_deq_y rb = rb \<lparr> lSY := (lSY rb) \<union> set (take 1 (lTXY rb)),
                                     lTXY := drop 1 (lTXY rb) \<rparr>"
  unfolding CleanQ_List_deq_y_def
  by(auto simp add:list_tail_drop_one list_head_take_one_set2)

text \<open>
  The dequeue operations move buffers around different sets and lists. We define a
  few helper lemmas, which allow us to talk about where the buffer ends up.
\<close>

lemma CleanQ_List_deq_x_result :
assumes ne: "lTYX rb \<noteq> []"  and  X_deq: "rb' = CleanQ_List_deq_x rb"
    and I: "CleanQ_List_Invariants K rb"  and buf: "b = hd (lTYX rb)"
  shows  "b \<in> (lSX rb') \<and> b \<notin> lSY rb' \<and> b \<notin> set(lTXY rb') \<and> b \<notin> set (lTYX rb')"
  using assms unfolding CleanQ_List_deq_x_def
  by(auto simp:CleanQ_List_Invariants_simp list_set_hd_tl_subtract)

lemma CleanQ_List_deq_y_result :
assumes ne: "lTXY rb \<noteq> []"  and  Y_deq: "rb' = CleanQ_List_deq_y rb"
    and I: "CleanQ_List_Invariants K rb" and buf: "b = hd (lTXY rb)"
  shows "b \<in> (lSY rb') \<and> b \<notin> lSX rb' \<and> b \<notin> set(lTXY rb') \<and> b \<notin> set (lTYX rb')"
  using assms unfolding CleanQ_List_deq_y_def
  apply(simp add:CleanQ_List_Invariants_simp list_set_hd_tl_subtract )
  by (meson disjoint_iff_not_equal hd_in_set)

text \<open>
  We can now show that the operations have the same outcome of when lifted to the
  set model.
\<close>

lemma CleanQ_List_deq_x_equal :
  assumes ne: "lTYX rb \<noteq> []" and  TYX_owned : "b = hd (lTYX rb)" and  I3_holds : "I3 rb"
  shows "CleanQ_List2Set (CleanQ_List_deq_x rb) = CleanQ_Set_deq_x b (CleanQ_List2Set rb)"
  unfolding CleanQ_List2Set_def CleanQ_Set_deq_x_def CleanQ_List_deq_x_def
  using assms by(simp add: list_set_hd_tl_subtract I3_def)

lemma CleanQ_List_deq_y_equal :
  assumes ne: "lTXY rb \<noteq> []" and  TXY_owned : "b = hd (lTXY rb)" and  I3_holds : "I3 rb"
  shows "CleanQ_List2Set (CleanQ_List_deq_y rb) = CleanQ_Set_deq_y b (CleanQ_List2Set rb)"
  unfolding CleanQ_List2Set_def CleanQ_Set_deq_y_def CleanQ_List_deq_y_def
  using assms by(simp add: list_set_hd_tl_subtract I3_def)

text \<open>
  The two operations \verb+CleanQ_List_deq_x+ and \verb+CleanQ_List_deq_y+ transition
  the model state. Thus we need to prove that invariants \verb+I1_list_img+,
  \verb+I2_list_img+, and \verb+I3+ are preserved for both of them.
\<close>

lemma CleanQ_List_deq_x_I1 :
  assumes I1_holds : "I1_list_img rb K"  and   TYX_ne: "(lTYX rb) \<noteq> []"
  shows "I1_list_img (CleanQ_List_deq_x rb) K"
  using TYX_ne I1_holds list_set_hd_tl_union
  unfolding CleanQ_List_deq_x_def by(auto simp:I1_list_img_def)

lemma CleanQ_List_deq_y_I1 :
  assumes I1_holds : "I1_list_img rb K"  and   TXY_ne: "(lTXY rb) \<noteq> []"
  shows "I1_list_img (CleanQ_List_deq_y rb) K"
  using TXY_ne I1_holds list_set_hd_tl_union
  unfolding CleanQ_List_deq_y_def by(auto simp:I1_list_img_def)

lemma CleanQ_List_deq_x_I2 :
  assumes I2_holds : "I2_list_img rb"  and  ne: "(lTYX rb) \<noteq> []" and I3_holds: "I3 rb"
  shows "I2_list_img (CleanQ_List_deq_x rb)"
  using assms unfolding CleanQ_List_deq_x_def  I2_list_img_def I3_def
  by (auto simp add:  list_set_hd_tl_subtract)

lemma CleanQ_List_deq_y_I2 :
  assumes I2_holds : "I2_list_img rb"  and   ne: "(lTXY rb) \<noteq> []" and I3_holds: "I3 rb"
  shows "I2_list_img (CleanQ_List_deq_y rb)"
  using assms unfolding CleanQ_List_deq_y_def  I2_list_img_def I3_def
  apply (auto simp:  list_set_hd_tl_subtract)
  by (metis IntI empty_iff hd_in_set)

lemma CleanQ_List_deq_x_I3 :
  assumes I3_holds : "I3 rb"
  shows "I3 (CleanQ_List_deq_x rb)"
  using assms distinct_tl unfolding CleanQ_List_deq_x_def  I3_def by auto

lemma CleanQ_List_deq_y_I3 :
  assumes I3_holds : "I3 rb"
  shows "I3 (CleanQ_List_deq_y rb)"
  using assms distinct_tl unfolding CleanQ_List_deq_y_def  I3_def by auto

text \<open>
  Both invariants I1, I2, and I3 are preserved by dequeue operations, thus we can combine
  them to obtain show that the predicate \verb+CleanQ_List_Invariants+ holds
\<close>

lemma CleanQ_List_deq_x_Invariants :
  assumes I_holds : "CleanQ_List_Invariants K rb"  and  TYX_ne: "[] \<noteq> (lTYX rb)"
    shows "CleanQ_List_Invariants K (CleanQ_List_deq_x rb)"
  using assms CleanQ_List_deq_x_I1 CleanQ_List_deq_x_I2 CleanQ_List_deq_x_I3
  using CleanQ_List_Invariants_def by fastforce

lemma CleanQ_List_deq_y_Invariants :
  assumes I_holds : "CleanQ_List_Invariants K rb"  and  TYX_ne: "[] \<noteq> (lTXY rb)"
    shows "CleanQ_List_Invariants K (CleanQ_List_deq_y rb)"
   using assms CleanQ_List_deq_y_I1 CleanQ_List_deq_y_I2 CleanQ_List_deq_y_I3
   using CleanQ_List_Invariants_def by fastforce

(* ==================================================================================== *)
subsection \<open>Multi-Step State Transition Operations\<close>
(* ==================================================================================== *)

text \<open>
  We now define the \verb+enqueue+ and \verb+dequeue+ operations for multipl step
  state advancements in one instance.
\<close>

(* ------------------------------------------------------------------------------------ *)
subsubsection \<open>Enqueue Operation\<close>
(* ------------------------------------------------------------------------------------ *)

text \<open>
  We first define the \verb+enqueue_n+ operation, for both sides. This will remove a list
  of buffers from the owning set, and add it to the transfer set
\<close>

definition CleanQ_List_enq_n_x :: "'a list \<Rightarrow> 'a CleanQ_List_State \<Rightarrow> 'a CleanQ_List_State"
  where "CleanQ_List_enq_n_x B rb = rb \<lparr> lSX := (lSX rb) - set B, lTXY := lTXY rb @ B \<rparr>"

definition CleanQ_List_enq_n_y :: "'a list \<Rightarrow> 'a CleanQ_List_State \<Rightarrow> 'a CleanQ_List_State"
  where "CleanQ_List_enq_n_y B rb = rb \<lparr> lSY := (lSY rb) - set B, lTYX := lTYX rb @ B \<rparr>"

text \<open>
 This can be defined inductively as:
\<close>

lemma CleanQ_List_enq_n_x_ind:
  "CleanQ_List_enq_n_x (b # B) rb = CleanQ_List_enq_n_x B (CleanQ_List_enq_x b rb)"
  unfolding CleanQ_List_enq_n_x_def CleanQ_List_enq_x_def
  by (simp, meson Diff_insert2)

lemma CleanQ_List_enq_n_y_ind:
  "CleanQ_List_enq_n_y (b # B) rb = CleanQ_List_enq_n_y B (CleanQ_List_enq_y b rb)"
  unfolding CleanQ_List_enq_n_y_def CleanQ_List_enq_y_def
  by (simp, meson Diff_insert2)

text \<open>
  We can now show that with an empty list, there is no change in the state and if the
  list is just containing one element, then this is just the same as the single element
  enqueues.
\<close>

lemma CleanQ_List_enq_n_x_0[simp]:
  "CleanQ_List_enq_n_x [] rb = rb"
  unfolding CleanQ_List_enq_n_x_def by(auto)

lemma CleanQ_List_enq_n_y_0[simp]:
  "CleanQ_List_enq_n_y [] rb = rb"
  unfolding CleanQ_List_enq_n_y_def by(auto)

lemma CleanQ_List_enq_n_x_1[simp]:
  "CleanQ_List_enq_n_x [b] rb = CleanQ_List_enq_x b rb"
  unfolding CleanQ_List_enq_n_x_def CleanQ_List_enq_x_def by(auto)

lemma CleanQ_List_enq_n_y_1[simp]:
  "CleanQ_List_enq_n_y [b] rb = CleanQ_List_enq_y b rb"
  unfolding CleanQ_List_enq_n_y_def CleanQ_List_enq_y_def by(auto)

text \<open>
  The multi-step  enqueue operations move buffers around different sets and lists.
   We define a few helper lemmas, which allow us to talk about where the buffer ends up.
\<close>

lemma CleanQ_List_enq_n_x_result :
  assumes X_owned: "\<forall>b \<in> set B. b \<in> lSX rb"  and  X_enq: "rb' = CleanQ_List_enq_n_x B rb"
    and I2_holds : "I2_list_img rb"
  shows  "\<forall>b \<in> set B. b \<in> set (lTXY rb') \<and> b \<notin> lSX rb' \<and> b \<notin> lSY rb' \<and> b \<notin> set (lTYX rb')"
  using X_owned X_enq I2_holds unfolding CleanQ_List_enq_n_x_def
  by(auto simp:CleanQ_List_Invariants_simp)

lemma CleanQ_List_enq_n_y_result :
  assumes X_owned: "\<forall>b \<in> set B. b \<in> lSY rb"  and  X_enq: "rb' = CleanQ_List_enq_n_y B rb"
    and I2_holds : "I2_list_img rb"
  shows  "\<forall>b \<in> set B. b \<in> set (lTYX rb') \<and> b \<notin> lSX rb' \<and> b \<notin> lSY rb' \<and> b \<notin> set (lTXY rb')"
  using X_owned X_enq I2_holds unfolding CleanQ_List_enq_n_y_def
  by(auto simp:CleanQ_List_Invariants_simp)

text \<open>
  We can now show that the outcome of the list \verb+enqeue_n+ operation is the same
  as the corresponding set operation.
\<close>

lemma CleanQ_List_enq_n_x_equal :
  "CleanQ_List2Set (CleanQ_List_enq_n_x B rb) = CleanQ_Set_enq_n_x (set B) (CleanQ_List2Set rb)"
  unfolding CleanQ_List2Set_def CleanQ_Set_enq_n_x_def CleanQ_List_enq_n_x_def
  by(auto)

lemma CleanQ_List_enq_n_yx_equal :
  "CleanQ_List2Set (CleanQ_List_enq_n_y B rb) = CleanQ_Set_enq_n_y (set B) (CleanQ_List2Set rb)"
  unfolding CleanQ_List2Set_def CleanQ_Set_enq_n_y_def CleanQ_List_enq_n_y_def
  by(auto)

text \<open>
  We now show that the \verb+enqueue_n+ operation satisfy the list invariant, we show each
  invariant I1-I3 individually.
\<close>

lemma CleanQ_List_enq_n_x_I1 :
  assumes I1_holds: "I1_list_img rb K"  and  X_owned: "\<forall> b \<in> set B. b \<in> lSX rb"
    shows "I1_list_img (CleanQ_List_enq_n_x B rb) K"
  unfolding CleanQ_List_enq_n_x_def using I1_holds X_owned by(auto simp:I1_list_img_def)

lemma CleanQ_List_enq_n_y_I1 :
  assumes I1_holds: "I1_list_img rb K"  and  Y_owned: "\<forall> b \<in> set B. b \<in> lSY rb"
    shows "I1_list_img (CleanQ_List_enq_n_y B rb) K"
  unfolding CleanQ_List_enq_n_y_def using I1_holds Y_owned  by(auto simp:I1_list_img_def)

lemma CleanQ_List_enq_n_x_I2 :
  assumes  I2_holds: "I2_list_img rb"   and  X_owned: "\<forall>b \<in> set B. b \<in> lSX rb"
      and  dist: "distinct B"
    shows "I2_list_img (CleanQ_List_enq_n_x B rb)"
  unfolding CleanQ_List_enq_n_x_def using assms by(auto simp:I2_list_img_def)

lemma CleanQ_List_enq_n_y_I2 :
  assumes  I2_holds: "I2_list_img rb"   and  X_owned: "\<forall>b \<in> set B. b \<in> lSY rb"
      and  dist: "distinct B"
    shows "I2_list_img (CleanQ_List_enq_n_y B rb)"
  unfolding CleanQ_List_enq_n_y_def using assms  by(auto simp:I2_list_img_def)

lemma CleanQ_List_enq_n_x_I3 :
  assumes  I2_holds: "I2_list_img rb" and I3_holds: "I3 rb"
      and  X_owned: "\<forall> b \<in> set B. b \<in> lSX rb" and  dist: "distinct B"
    shows "I3 (CleanQ_List_enq_n_x B rb)"
  unfolding CleanQ_List_enq_n_x_def using assms  by(auto simp:CleanQ_List_Invariants_simp)

lemma CleanQ_List_enq_n_y_I3 :
  assumes  I2_holds: "I2_list_img rb" and I3_holds: "I3 rb"
      and  Y_owned: "\<forall> b \<in> set B. b \<in> lSY rb" and  dist: "distinct B"
    shows "I3 (CleanQ_List_enq_n_y B rb)"
  unfolding CleanQ_List_enq_n_y_def  using assms  by(auto simp:CleanQ_List_Invariants_simp)

text \<open>
  We can now combine the proofs for invariants I1-I3 and show the complete list invariant.
\<close>

lemma CleanQ_List_enq_n_x_Invariants :
  assumes I_holds : "CleanQ_List_Invariants K rb"
      and  X_owned: "\<forall> b \<in> set B. b \<in> lSX rb" and  dist: "distinct B"
  shows "CleanQ_List_Invariants K (CleanQ_List_enq_n_x B rb)"
  unfolding CleanQ_List_enq_n_x_def
  using assms CleanQ_List_enq_n_x_I3 CleanQ_List_enq_n_x_I2 CleanQ_List_enq_n_x_I1
  by(auto simp:CleanQ_List_Invariants_simp)

lemma CleanQ_List_enq_n_y_Invariants :
  assumes I_holds : "CleanQ_List_Invariants K rb"
      and  Y_owned: "\<forall> b \<in> set B. b \<in> lSY rb" and  dist: "distinct B"
  shows "CleanQ_List_Invariants K (CleanQ_List_enq_n_y B rb)"
  unfolding CleanQ_List_enq_n_y_def
  using assms CleanQ_List_enq_n_y_I3 CleanQ_List_enq_n_y_I2 CleanQ_List_enq_n_y_I1
  by(auto simp:CleanQ_List_Invariants_simp)

text \<open>
  Finally, we can also show that the set invariants are preserved.
\<close>

lemma CleanQ_List_enq_n_x_Set_Invariants :
  assumes I_holds : "CleanQ_List_Invariants K rb"
      and  X_owned: "\<forall> b \<in> set B. b \<in> lSX rb" and  dist: "distinct B"
      and RB_upd: "rb' = CleanQ_List_enq_n_x B rb"
    shows "CleanQ_Set_Invariants K (CleanQ_List2Set rb')"
  using assms CleanQ_List_Invariants_Set_Invariants CleanQ_List_enq_n_x_Invariants
  by(metis)

lemma CleanQ_List_enq_n_y_Set_Invariants :
  assumes I_holds : "CleanQ_List_Invariants K rb"
      and  X_owned: "\<forall> b \<in> set B. b \<in> lSY rb" and  dist: "distinct B"
      and RB_upd: "rb' = CleanQ_List_enq_n_y B rb"
    shows "CleanQ_Set_Invariants K (CleanQ_List2Set rb')"
  using assms CleanQ_List_Invariants_Set_Invariants CleanQ_List_enq_n_y_Invariants
  by(metis)

(* ------------------------------------------------------------------------------------ *)
subsubsection \<open>Dequeue Operation\<close>
(* ------------------------------------------------------------------------------------ *)

text \<open>
  The multi-step \verb+dequeue_n+ operation is similar to the single step operation,
  with the exception that it takes the first $n$ elements from the transfer list, instead
  of just the head.
\<close>

definition CleanQ_List_deq_n_x :: "nat \<Rightarrow> 'a CleanQ_List_State  \<Rightarrow> 'a CleanQ_List_State"
  where "CleanQ_List_deq_n_x n rb = rb \<lparr> lSX := (lSX rb) \<union> set (take n (lTYX rb)),
                                     lTYX := drop n (lTYX rb) \<rparr>"

definition CleanQ_List_deq_n_y :: "nat \<Rightarrow> 'a CleanQ_List_State  \<Rightarrow> 'a CleanQ_List_State"
  where "CleanQ_List_deq_n_y n rb = rb \<lparr> lSY := (lSY rb) \<union> set (take n (lTXY rb)),
                                     lTXY := drop n (lTXY rb) \<rparr>"

text \<open>
 This can be defined inductively as:

 Note: this equivalence only holds if there are elements in the list. Technically,
       it doesn't matter the order, but needs to make sure there are enough elements
       in the list.
\<close>

lemma CleanQ_List_deq_n_x_ind:
  "lTYX rb \<noteq> [] \<Longrightarrow> CleanQ_List_deq_n_x (Suc n) rb
                             = CleanQ_List_deq_n_x n (CleanQ_List_deq_x rb)"
  unfolding CleanQ_List_deq_n_x_def CleanQ_List_deq_x_def
  by(auto simp add: drop_Suc take_Suc)

lemma CleanQ_List_deq_n_y_ind:
  "lTXY rb \<noteq> [] \<Longrightarrow> CleanQ_List_deq_n_y (Suc n) rb
                            = CleanQ_List_deq_n_y n (CleanQ_List_deq_y rb)"
  unfolding CleanQ_List_deq_n_y_def CleanQ_List_deq_y_def
  by(auto simp add: drop_Suc take_Suc)

text \<open>
  We can now show that with an empty list, there is no change in the state and if the
  list is just containing one element, then this is just the same as the single element
  dequeue.
\<close>

lemma CleanQ_List_deq_n_x_0[simp]:
  "CleanQ_List_deq_n_x 0 rb = rb"
  unfolding CleanQ_List_deq_n_x_def by(auto)

lemma CleanQ_List_deq_n_y_0[simp]:
  "CleanQ_List_deq_n_y 0 rb = rb"
  unfolding CleanQ_List_deq_n_y_def by(auto)

lemma CleanQ_List_deq_n_x_1[simp]:
  "(lTYX rb \<noteq> []) \<Longrightarrow> CleanQ_List_deq_n_x 1 rb = CleanQ_List_deq_x rb"
  by (simp add: CleanQ_List_deq_n_x_ind)

lemma CleanQ_List_deq_n_y_1[simp]:
  "(lTXY rb \<noteq> []) \<Longrightarrow> CleanQ_List_deq_n_y 1 rb = CleanQ_List_deq_y rb"
  by (simp add: CleanQ_List_deq_n_y_ind)

text \<open>
  We can now talk about the effects of the \verb+dequeue_n+ operation with respect to
  the ownership sets.
\<close>

lemma CleanQ_List_deq_n_x_equal :
assumes TYX_owned : "B = take n (lTYX rb)" and I3_holds : "I3 rb"
  shows "CleanQ_List2Set (CleanQ_List_deq_n_x n rb)
                            = CleanQ_Set_deq_n_x (set B) (CleanQ_List2Set rb)"
  unfolding CleanQ_List2Set_def CleanQ_Set_deq_n_x_def CleanQ_List_deq_n_x_def
  by (simp, metis Diff_cancel I3_def I3_holds TYX_owned Un_Diff Un_Diff_Int
                  list_distinct_drop_take_inter list_take_drop_union sup.commute)

lemma CleanQ_List_deq_n_y_equal :
assumes  TYX_owned : "B = take n (lTXY rb)"  and  I3_holds : "I3 rb"
  shows "CleanQ_List2Set (CleanQ_List_deq_n_y n rb)
                            = CleanQ_Set_deq_n_y (set B) (CleanQ_List2Set rb)"
  unfolding CleanQ_List2Set_def CleanQ_Set_deq_n_y_def CleanQ_List_deq_n_y_def
  by (simp, metis Diff_cancel I3_def I3_holds TYX_owned Un_Diff Un_Diff_Int
                  list_distinct_drop_take_inter list_take_drop_union sup.commute)

text \<open>
  The \verb+dequeue_n+ operation preserves the invariant I1-I3
\<close>

lemma CleanQ_List_deq_n_x_I1 :
assumes I1_holds : "I1_list_img rb K"
  shows "I1_list_img (CleanQ_List_deq_n_x n rb) K"
  using assms unfolding I1_list_img_def  CleanQ_List_deq_n_x_def
  by (simp, metis list_take_drop_union sup_assoc sup_left_commute)

lemma CleanQ_List_deq_n_y_I1 :
assumes I1_holds : "I1_list_img rb K"
  shows "I1_list_img (CleanQ_List_deq_n_y n rb) K"
  using assms unfolding I1_list_img_def  CleanQ_List_deq_n_y_def
  by (simp, metis list_take_drop_union sup_assoc sup_left_commute)

lemma CleanQ_List_deq_n_x_I2 :
assumes I2_holds : "I2_list_img rb"  and  I3_holds: "I3 rb"
  shows "I2_list_img (CleanQ_List_deq_n_x n rb)"
  using assms unfolding CleanQ_List_deq_n_x_def I2_list_img_def I3_def
  by(simp add:list_drop_set_inter2 list_take_drop_union_inters list_distinct_drop_take_inter
              Int_Un_distrib inf.commute list_take_set_inter2)

lemma CleanQ_List_deq_n_y_I2 :
assumes I2_holds : "I2_list_img rb"  and  I3_holds: "I3 rb"
  shows "I2_list_img (CleanQ_List_deq_n_y n rb)"
  using assms unfolding CleanQ_List_deq_n_y_def I2_list_img_def I3_def
  by(simp add:list_drop_set_inter2 list_take_drop_union_inters list_distinct_drop_take_inter
              Int_Un_distrib inf.commute list_take_set_inter2)

lemma CleanQ_List_deq_n_x_I3 :
assumes I3_holds : "I3 rb"
  shows "I3 (CleanQ_List_deq_n_x n rb)"
    unfolding CleanQ_List_deq_n_x_def using I3_holds distinct_tl by (auto simp:I3_def)

lemma CleanQ_List_deq_n_y_I3 :
assumes I3_holds : "I3 rb"
  shows "I3 (CleanQ_List_deq_n_y n rb)"
    unfolding CleanQ_List_deq_n_y_def using I3_holds distinct_tl by (auto simp:I3_def)

lemma CleanQ_List_deq_n_x_Invariants :
assumes I_holds : "CleanQ_List_Invariants K rb"
  shows "CleanQ_List_Invariants K (CleanQ_List_deq_n_x n rb)"
  using assms CleanQ_List_deq_n_x_I1 CleanQ_List_deq_n_x_I2 CleanQ_List_deq_n_x_I3
  using CleanQ_List_Invariants_simp by blast

lemma CleanQ_List_deq_n_y_Invariants :
assumes I_holds : "CleanQ_List_Invariants K rb"
  shows "CleanQ_List_Invariants K (CleanQ_List_deq_n_y n rb)"
  using assms CleanQ_List_deq_n_y_I1 CleanQ_List_deq_n_y_I2 CleanQ_List_deq_n_y_I3
  using CleanQ_List_Invariants_simp by blast

(* ==================================================================================== *)
subsection \<open>Strong and Weak Frame Conditions\<close>
(* ==================================================================================== *)

text \<open>
  We now define the strong and weak frame conditions for the CleanQ List model. Those are
  used in the concurrency proofs. They define the set of operations the other side can
  do to the state of the queue system.
\<close>
(* ------------------------------------------------------------------------------------ *)
subsubsection \<open>Strong Frame Condition\<close>
(* ------------------------------------------------------------------------------------ *)

fun CleanQ_List_Frame_Strong :: "'a tuple \<Rightarrow>'a tuple \<Rightarrow> bool"
  where "CleanQ_List_Frame_Strong (sx',txy',sy',tyx') (sx,txy,sy,tyx) \<longleftrightarrow>
                                          sx' = sx \<and> txy' = txy \<and> sy' = sy \<and> tyx' = tyx"

lemma CleanQ_Set_Strong_Frame_Implies:
  "CleanQ_List_Frame_Strong A B \<Longrightarrow> CleanQ_Set_Frame_Strong A B"
  by (smt CleanQ_List_Frame_Strong.elims(2) CleanQ_Set_Frame_Strong.simps)

(* ------------------------------------------------------------------------------------ *)
subsubsection \<open>Weak Frame Condition\<close>
(* ------------------------------------------------------------------------------------ *)

text \<open>
  For the concurrent case, we can not assume that the sets we do not explicitly modify by
  an operation do not change and for this we have to weaken the frame condition that
  e.g. when enqueueing from X the sets TXY, SY and TYX might change through actions of Y.
\<close>

(*
 Note: Those definitions contain two additional clauses
  set dtxy \<inter> set (lTXY st) = {} \<and>  set dsy \<inter> set (lTXY st) = {}
  set dtyx \<inter> set (lTYX st) = {} \<and>  set dsx \<inter> set (lTYX st) = {}
 which can be obtained by combining the frame conditions with the Invariant

definition  CleanQ_List_Frame_Weak_x ::
  "'a CleanQ_List_State \<Rightarrow> 'a CleanQ_List_State \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> bool"
  where "CleanQ_List_Frame_Weak_x st' st dtxy dsy  \<longleftrightarrow>
          lSX st = lSX st' \<and> lSY st \<union> set dsy = lSY st'\<union> set dtxy \<and>
          dtxy @ lTXY st  = lTXY st' \<and> lTYX st = lTYX st' @ dsy \<and>
          set dsy \<inter> (lSY st) = {} \<and> set dtxy \<inter> set (lTXY st) = {} \<and>
          set dsy \<inter> set (lTXY st) = {} \<and> distinct dsy"

definition  CleanQ_List_Frame_Weak_y ::
  "'a CleanQ_List_State \<Rightarrow> 'a CleanQ_List_State \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> bool"
  where "CleanQ_List_Frame_Weak_y st' st dtyx dsx  \<longleftrightarrow>
          lSY st = lSY st' \<and> lSX st \<union> set dsx = lSX st'\<union> set dtyx \<and>
          dtyx @ lTYX st  = lTYX st' \<and> lTXY st = lTXY st' @  dsx \<and>
          set dsx \<inter> (lSX st) = {} \<and> set dtyx \<inter> set (lTYX st) = {} \<and>
          set dsx \<inter> set  (lTYX st) = {} \<and> distinct dsx "
*)

definition  CleanQ_List_Frame_Weak_x ::
  "'a CleanQ_List_State \<Rightarrow> 'a CleanQ_List_State \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> bool"
  where "CleanQ_List_Frame_Weak_x st' st dtxy dsy  \<longleftrightarrow>
          lSX st = lSX st' \<and> lSY st \<union> set dsy = lSY st'\<union> set dtxy \<and>
          dtxy @ lTXY st  = lTXY st' \<and> lTYX st = lTYX st' @ dsy \<and>
          set dsy \<inter> (lSY st) = {}  \<and> distinct dsy"

definition  CleanQ_List_Frame_Weak_y ::
  "'a CleanQ_List_State \<Rightarrow> 'a CleanQ_List_State \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> bool"
  where "CleanQ_List_Frame_Weak_y st' st dtyx dsx  \<longleftrightarrow>
          lSY st = lSY st' \<and> lSX st \<union> set dsx = lSX st'\<union> set dtyx \<and>
          dtyx @ lTYX st  = lTYX st' \<and> lTXY st = lTXY st' @  dsx \<and>
          set dsx \<inter> (lSX st) = {} \<and> distinct dsx "

text \<open>
  From the weak frame conditions and the Invariant we can obtain two additional set
  intersections
\<close>

lemma CleanQ_List_Frame_Weak_x_emptyset_A:
assumes I: "CleanQ_List_Invariants K st'" and F: "CleanQ_List_Frame_Weak_x st' st A B"
  shows "set A \<inter> set (lTXY st) = {}"
  using assms unfolding  CleanQ_List_Frame_Weak_x_def CleanQ_List_Invariants_def
  by (metis I3_def distinct_append)

lemma CleanQ_List_Frame_Weak_x_emptyset_B:
assumes I: "CleanQ_List_Invariants K st'" and F: "CleanQ_List_Frame_Weak_x st' st A B"
  shows "set B \<inter> set (lTXY st) = {}"
  using assms unfolding  CleanQ_List_Frame_Weak_x_def CleanQ_List_Invariants_def
  by (metis (no_types, hide_lams) I2_list_img_def I3_def Un_iff disjoint_iff_not_equal
                                  distinct_append set_append)

lemma CleanQ_List_Frame_Weak_y_emptyset_A:
assumes I: "CleanQ_List_Invariants K st'" and F: "CleanQ_List_Frame_Weak_y st' st A B"
  shows "set A \<inter> set (lTYX st) = {}"
  using assms unfolding  CleanQ_List_Frame_Weak_y_def CleanQ_List_Invariants_def
  by (metis I3_def distinct_append)

lemma CleanQ_List_Frame_Weak_y_emptyset_B:
assumes I: "CleanQ_List_Invariants K st'" and F: "CleanQ_List_Frame_Weak_y st' st A B"
  shows "set B \<inter> set (lTYX st) = {}"
  using assms unfolding  CleanQ_List_Frame_Weak_y_def CleanQ_List_Invariants_def
  by (metis (no_types, hide_lams) I2_list_img_def I3_def Un_iff disjoint_iff_not_equal
                                  distinct_append set_append)

text \<open>
  The weak frame condition of the List model implies the weak frame condition of the
  set model.
\<close>

lemma CleanQ_List_Frame_Weak_x_implies:
assumes I: "CleanQ_List_Invariants K st'" and F: "CleanQ_List_Frame_Weak_x st' st A B"
shows "CleanQ_Set_Frame_Weak_x (CleanQ_List2Set st') (CleanQ_List2Set st) (set A) (set B)"
  using F unfolding CleanQ_Set_Frame_Weak_x_def CleanQ_List2Set_def CleanQ_List_Frame_Weak_x_def
  using I F by (simp, metis CleanQ_List_Frame_Weak_x_emptyset_A
                            CleanQ_List_Frame_Weak_x_emptyset_B Un_commute set_append)

lemma CleanQ_List_Frame_Weak_y_implies:
assumes I: "CleanQ_List_Invariants K st'" and F: "CleanQ_List_Frame_Weak_y st' st A B"
shows "CleanQ_Set_Frame_Weak_y (CleanQ_List2Set st') (CleanQ_List2Set st) (set A) (set B)"
  using F unfolding CleanQ_Set_Frame_Weak_y_def CleanQ_List2Set_def CleanQ_List_Frame_Weak_y_def
  using I F by (simp, metis CleanQ_List_Frame_Weak_y_emptyset_A
                            CleanQ_List_Frame_Weak_y_emptyset_B Un_commute set_append)

text \<open>
  We can now show, that enqueue  and dequeue operations fulfil the weak frame condition.
\<close>

lemma CleanQ_List_Frame_Weak_x_enq:
  assumes I: "CleanQ_List_Invariants K st'"  and  owns: "b \<in> lSX st'"
    shows "CleanQ_List_Frame_Weak_y st' (CleanQ_List_enq_x b st') [] [b]"
  using assms unfolding CleanQ_List_Frame_Weak_y_def CleanQ_List_enq_x_def
  by(auto simp:CleanQ_List_Invariants_simp)

lemma CleanQ_List_Frame_Weak_y_enq:
  assumes I: "CleanQ_List_Invariants K st'"  and  owns: "b \<in> lSY st'"
    shows "CleanQ_List_Frame_Weak_x st' (CleanQ_List_enq_y b st') [] [b]"
  using assms unfolding CleanQ_List_Frame_Weak_x_def CleanQ_List_enq_y_def
  by(auto simp:CleanQ_List_Invariants_simp)

lemma CleanQ_List_Frame_Weak_x_deq:
  assumes I: "CleanQ_List_Invariants K st'"  and  owns: "b = hd (lTYX st') \<and> lTYX st' \<noteq> []"
    shows "CleanQ_List_Frame_Weak_y st' (CleanQ_List_deq_x st') [b] []"
  using assms unfolding CleanQ_List_Frame_Weak_y_def CleanQ_List_deq_x_def by(auto)

lemma CleanQ_List_Frame_Weak_y_deq:
  assumes I: "CleanQ_List_Invariants K st'"  and  owns: "b = hd (lTXY st') \<and> lTXY st' \<noteq> []"
    shows "CleanQ_List_Frame_Weak_x st' (CleanQ_List_deq_y st') [b] []"
  using assms unfolding CleanQ_List_Frame_Weak_x_def CleanQ_List_deq_y_def by(auto)

text \<open>
  The weak frame condition for an \verb+enqueue+ or \verb+dequeue+ preserves I1.
\<close>

lemma CleanQ_List_enq_x_I1_weak:
assumes I: "CleanQ_List_Invariants K st'"
   and frame: "CleanQ_List_Frame_Weak_y st' st [] [b]"
 shows "I1_list_img st K"
  using assms unfolding I1_def CleanQ_List_Frame_Weak_y_def CleanQ_List_Invariants_def
  by(auto simp:CleanQ_List_Invariants_simp)

lemma CleanQ_List_enq_y_I1_weak:
assumes I: "CleanQ_List_Invariants K st'"
   and frame: "CleanQ_List_Frame_Weak_x st' st [] [b]"
 shows "I1_list_img st K"
  using assms unfolding I1_def CleanQ_List_Frame_Weak_x_def CleanQ_List_Invariants_def
  by(auto simp:CleanQ_List_Invariants_simp)

lemma CleanQ_List_deq_x_I1_weak:
assumes I: "CleanQ_List_Invariants K st'"  and  owns:  "b = hd (lTYX st')"
   and frame: "CleanQ_List_Frame_Weak_y st' st [b] []"
 shows "I1_list_img st K"
  using assms unfolding I1_def CleanQ_List_Frame_Weak_y_def CleanQ_List_Invariants_def
  by (smt I1_list_img_def Un_assoc Un_commute set_append)

lemma CleanQ_List_deq_y_I1_weak:
assumes I: "CleanQ_List_Invariants K st'"  and  owns:  "b = hd (lTXY st')"
   and frame: "CleanQ_List_Frame_Weak_x st' st [b] []"
 shows "I1_list_img st K"
  using assms unfolding I1_def CleanQ_List_Frame_Weak_x_def CleanQ_List_Invariants_def
  by (smt I1_list_img_def Un_assoc Un_commute set_append)

text \<open>
  The weak frame condition for an \verb+enqueue+ or \verb+dequeue+ preserves I2.
\<close>

lemma CleanQ_List_enq_x_I2_weak:
assumes I: "CleanQ_List_Invariants K st'"
   and frame: "CleanQ_List_Frame_Weak_y st' st [] [b]"
 shows "I2_list_img st"
  using assms unfolding CleanQ_List_Frame_Weak_y_def I2_list_img_def
  by(auto simp:CleanQ_List_Invariants_simp)

lemma CleanQ_List_enq_y_I2_weak:
assumes I: "CleanQ_List_Invariants K st'"
   and frame: "CleanQ_List_Frame_Weak_x st' st [] [b]"
 shows "I2_list_img st"
  using assms unfolding CleanQ_List_Frame_Weak_x_def I2_list_img_def
  by(auto simp:CleanQ_List_Invariants_simp)

lemma CleanQ_List_deq_x_I2_weak:
assumes I: "CleanQ_List_Invariants K st'" and  owns:  "b = hd (lTYX st')"
   and frame: "CleanQ_List_Frame_Weak_y st' st [b] []"
 shows "I2_list_img st"
  using assms unfolding CleanQ_List_Frame_Weak_y_def I2_list_img_def
  apply(simp add:CleanQ_List_Invariants_simp)
  by (metis disjoint_insert(2) distinct.simps(2) list.simps(15))

lemma CleanQ_List_deq_y_I2_weak:
assumes I: "CleanQ_List_Invariants K st'" and  owns:  "b = hd (lTXY st')"
   and frame: "CleanQ_List_Frame_Weak_x st' st [b] []"
 shows "I2_list_img st"
  using assms unfolding CleanQ_List_Frame_Weak_x_def I2_list_img_def
  apply(simp add:CleanQ_List_Invariants_simp)
  by (metis disjoint_insert(2) distinct.simps(2) inf_commute list.simps(15))

text \<open>
  The weak frame condition for an \verb+enqueue+ or \verb+dequeue+ preserves I3.
\<close>

lemma CleanQ_List_enq_x_I3_weak:
assumes I: "CleanQ_List_Invariants K st'"
   and frame: "CleanQ_List_Frame_Weak_y st' st [] [b]"
 shows "I3 st"
  using assms unfolding CleanQ_List_Frame_Weak_y_def I3_def
  by(auto simp add:CleanQ_List_Invariants_simp)

lemma CleanQ_List_enq_y_I3_weak:
assumes I: "CleanQ_List_Invariants K st'"
   and frame: "CleanQ_List_Frame_Weak_x st' st [] [b]"
 shows "I3 st"
  using assms unfolding CleanQ_List_Frame_Weak_x_def I3_def
  by(auto simp add:CleanQ_List_Invariants_simp)

lemma CleanQ_List_deq_y_I3_weak:
assumes I: "CleanQ_List_Invariants K st'"
   and frame: "CleanQ_List_Frame_Weak_x st' st [b] []"
 shows "I3 st"
  using assms unfolding CleanQ_List_Frame_Weak_x_def I3_def
  apply(simp add:CleanQ_List_Invariants_simp)
  by (metis distinct.simps(2))

lemma CleanQ_List_deq_x_I3_weak:
assumes I: "CleanQ_List_Invariants K st'"
   and frame: "CleanQ_List_Frame_Weak_y st' st [b] []"
 shows "I3 st"
  using assms unfolding CleanQ_List_Frame_Weak_y_def I3_def
  apply(simp add:CleanQ_List_Invariants_simp)
  by (metis distinct.simps(2))

text \<open>
  Additionally we have to define the weak frame condition for the concurrency case
  again similar to the set model.
\<close>

fun frame_list_weak ::
  "'a list \<times> 'a set \<times> 'a list \<times> 'a set \<Rightarrow> 'a list \<times> 'a set \<times> 'a list \<times> 'a set \<Rightarrow> bool"
  where "frame_list_weak (a',B',c',D') (a,B,c,D) \<longleftrightarrow> (\<exists>\<delta>aB \<delta>Bc.
    a' = \<delta>aB @ a \<and>
    B' \<union> set \<delta>aB = set \<delta>Bc \<union> B \<and>
    c' @ \<delta>Bc = c \<and>
    B \<inter> set \<delta>Bc = {} \<and>
    distinct \<delta>Bc)
  \<and> D' = D"

lemma frame2_s_w:
  "frame_strong (a',B',c',D') (a,B,c,D) \<Longrightarrow> frame_list_weak (a',B',c',D') (a,B,c,D)"
  by(auto)

lemma CleanQ_List_frame_weak_equiv_x:
  "frame_list_weak (lTXY st', lSY st', lTYX st', lSX st' ) (lTXY st, lSY st, lTYX st, lSX st)
                              \<longleftrightarrow> (\<exists>\<Delta>AB \<Delta>BC. CleanQ_List_Frame_Weak_x st' st \<Delta>AB \<Delta>BC)"
  unfolding frame_list_weak.simps CleanQ_List_Frame_Weak_x_def
  by (smt inf_commute sup.commute)

lemma CleanQ_List_frame_weak_equiv_y:
  "frame_weak (TYX st', SX st', TXY st', SY st' ) (TYX st, SX st, TXY st, SY st)
                             \<longleftrightarrow> (\<exists>\<Delta>AB \<Delta>BC. CleanQ_Set_Frame_Weak_y st' st \<Delta>AB \<Delta>BC)"
  unfolding frame_weak.simps CleanQ_Set_Frame_Weak_y_def
  by (metis Int_commute)

text \<open>The second weak frame condition refines the first.\<close>

lemma frame2_w_1_w:
  fixes st st' K
  assumes I1: "I1 (CleanQ_List2Set st') K"
      and I2: "I2 (CleanQ_List2Set st')"
      and I3: "I3 st'"
      and frame: "frame_list_weak (lTXY st', lSY st', lTYX st', lSX st') (lTXY st, lSY st, lTYX st, lSX st)"
    shows "frame_weak (TXY (CleanQ_List2Set st'), SY (CleanQ_List2Set st'), TYX (CleanQ_List2Set st'), SX (CleanQ_List2Set st'))
                      (TXY (CleanQ_List2Set st), SY (CleanQ_List2Set st), TYX (CleanQ_List2Set st), SX (CleanQ_List2Set st))"
proof -
  from frame obtain \<delta>aB \<delta>Bc where
    fA: "lTXY st' = \<delta>aB @ lTXY st" and
    fB: "lSY st' \<union> set \<delta>aB = set \<delta>Bc \<union> lSY st" and
    fC: "lTYX st' @ \<delta>Bc = lTYX st" and
    dBC: "lSY st \<inter> set \<delta>Bc = {}" and
    fD: "lSX st' = lSX st"
    by(auto)

  define \<Delta>AB where "\<Delta>AB = set \<delta>aB"
  define \<Delta>BC where "\<Delta>BC = set \<delta>Bc"

  from fA \<Delta>AB_def have fA': "set (lTXY st') = \<Delta>AB \<union> set (lTXY st)"
    by(simp)
  from fB \<Delta>AB_def \<Delta>BC_def have fB': "lSY st' \<union> \<Delta>AB = \<Delta>BC \<union> lSY st"
    by(simp)
  from fC \<Delta>BC_def have fC': "set (lTYX st') \<union> \<Delta>BC = set (lTYX st)"
    by (metis set_append)

  from fA I3 \<Delta>AB_def have dAB: "set (lTXY st) \<inter> \<Delta>AB = {}"
    by(auto simp: I3_def)

  from fB have dAC: "set (lTXY st) \<inter> \<Delta>BC = {}"
  proof(rule contrapos_pp)
    assume "set (lTXY st) \<inter> \<Delta>BC \<noteq> {}"
    then obtain x where xa: "x \<in> set (lTXY st)" and xBC: "x \<in> set \<delta>Bc"
      unfolding \<Delta>BC_def by(blast)

    from xa fA have "x \<in> set (lTXY st')" by(auto)
    with I2 have "x \<notin> (lSY st')"
      by (meson I2_list_img_def I2_list_img_lift disjoint_iff_not_equal)
    moreover from xa fA I3 have "x \<notin> set \<delta>aB" by(auto simp: I3_def)
    ultimately show "(lSY st') \<union> set \<delta>aB \<noteq> set \<delta>Bc \<union> (lSY st)"
      using xBC by(auto)
  qed

  from dBC \<Delta>BC_def fB have dBC': "lSY st \<inter> \<Delta>BC = {}"
    by(auto)

  from fA' fB' fC' dAB dAC dBC' fD show ?thesis
    unfolding frame_weak.simps CleanQ_List2Set_def
    apply(simp)
    by (metis sup.commute)
qed

lemma  CleanQ_List_enq_x_weak_I3 :
  fixes st st' K x
  assumes I: "CleanQ_List_Invariants K st'"
      and frame: "frame_list_weak (lTXY st' @ [x], lSY st', lTYX st', lSX st' - {x}) (lTXY st, lSY st, lTYX st, lSX st)"
      and owns: "x \<in> lSX st'"
    shows "I3 st"
proof(unfold I3_def, intro conjI)
  from frame obtain \<delta>aB \<delta>Bc where
    fA: "(lTXY st') @ [x] = \<delta>aB @ (lTXY st)" and
    fB: "(lSY st') \<union> set \<delta>aB = set \<delta>Bc \<union> (lSY st)" and
    fC: "(lTYX st') @ \<delta>Bc = lTYX st" and
    dBC: "(lSY st) \<inter> set \<delta>Bc = {}" and
    dsBC: "distinct \<delta>Bc" and
    fD: "(lSX st') - {x} = lSX st"
    by auto

  from I owns have "x \<notin> set (lTXY st')" by(auto simp:CleanQ_List_Invariants_simp)
  with I have "distinct ((lTXY st') @ [x])" by(auto simp:CleanQ_List_Invariants_simp)
  hence "distinct (\<delta>aB @ (lTXY st))" by(simp add:fA)
  thus "distinct (lTXY st)" by(auto)

  from fA have "set (\<delta>aB @ (lTXY st)) = set ((lTXY st') @ [x])" by(simp)
  hence "set \<delta>aB \<subseteq> set (lTXY st') \<union> {x}" by(auto)
  with fB have "set \<delta>Bc \<subseteq> set (lTXY st') \<union> (lSY st') \<union> {x}" by(auto)
  with I owns have "set (lTYX st') \<inter> set \<delta>Bc = {}"by(auto simp:CleanQ_List_Invariants_simp)
  moreover from I have "distinct (lTYX st')" by(auto simp:CleanQ_List_Invariants_simp)
  ultimately show "distinct (lTYX st)"
    using dsBC fC[symmetric] by(simp)
qed

lemma  CleanQ_List_enq_y_weak_I3 :
  fixes st st' K x
  assumes I: "CleanQ_List_Invariants K st'"
      and frame: "frame_list_weak (lTYX st' @ [x], lSX st', lTXY st', lSY st' - {x}) (lTYX st, lSX st, lTXY st, lSY st)"
      and owns: "x \<in> lSY st'"
    shows "I3 st"
proof(unfold I3_def, intro conjI)
  from frame obtain \<delta>aB \<delta>Bc where
    fA: "lTYX st' @ [x] = \<delta>aB @ lTYX st" and
    fB: "lSX st' \<union> set \<delta>aB = set \<delta>Bc \<union> lSX st" and
    fC: "lTXY st' @ \<delta>Bc = lTXY st" and
    dBC: "lSX st \<inter> set \<delta>Bc = {}" and
    dsBC: "distinct \<delta>Bc" and
    fD: "lSY st' - {x} = lSY st"
    by(auto)

  from I owns have "x \<notin> set (lTYX st')" by(auto simp:CleanQ_List_Invariants_simp)
  with I have "distinct ((lTYX st') @ [x])" by(auto simp:CleanQ_List_Invariants_simp)
  hence "distinct (\<delta>aB @ (lTYX st))" by(simp add:fA)
  thus "distinct (lTYX st)" by(auto)

  from fA have "set (\<delta>aB @ (lTYX st)) = set ((lTYX st') @ [x])" by(simp)
  hence "set \<delta>aB \<subseteq> set (lTYX st') \<union> {x}" by(auto)
  with fB have "set \<delta>Bc \<subseteq> set (lTYX st') \<union> (lSX st') \<union> {x}" by(auto)
  with I owns have "set (lTXY st') \<inter> set \<delta>Bc = {}" by(auto simp:CleanQ_List_Invariants_simp)
  moreover from I have "distinct (lTXY st')" by(auto simp:CleanQ_List_Invariants_simp)
  ultimately show "distinct (lTXY st)"
    using dsBC fC[symmetric]
    by(simp)
qed

text \<open>The weak frame condition for an dequeue  preserves invariant 3.\<close>

lemma CleanQ_List_deq_x_weak_I3:
  fixes st st' K x
  assumes I: "CleanQ_List_Invariants K st'"
      and frame: "frame_list_weak (lTXY st', lSY st', lTYX st', lSX st' \<union> {x}) (lTXY st, lSY st, lTYX st, lSX st)"
      and hd: "lTYX st \<noteq> [] \<and> x = hd (lTYX st)"
    shows "I3 st"
  using I frame hd unfolding CleanQ_List_Invariants_def apply auto
proof -
  fix \<delta>aB :: "'a list" and \<delta>Bc :: "'a list"
  assume a1: "I2_list_img st'"
  assume a2: "I3 st'"
  assume a3: "distinct \<delta>Bc"
  assume a4: "lTXY st' = \<delta>aB @ lTXY st"
  assume a5: "lTYX st' @ \<delta>Bc = lTYX st"
  assume "lSY st \<inter> set \<delta>Bc = {}"
  assume a6: "lSY st' \<union> set \<delta>aB = set \<delta>Bc \<union> lSY st"
  have f7: "\<And>A. (lSY st' \<union> A) \<inter> set (lTYX st') = A \<inter> set (lTYX st')"
    using a1 by (simp add: I2_list_img_def Int_Un_distrib2)
  have "\<And>A. set \<delta>aB \<inter> (set (lTYX st') \<inter> (set \<delta>aB \<union> A)) = set \<delta>aB \<inter> set (lTYX st')"
    by blast
  then have "set \<delta>aB \<inter> set (lTYX st') = {}"
    using a4 a1 by (metis (no_types) I2_list_img_def inf_commute inf_sup_absorb set_append sup_bot.left_neutral)
  then have "set \<delta>Bc \<inter> set (lTYX st') = {}"
    using f7 a6 by blast
  then show ?thesis
    using a5 a4 a3 a2 by (metis (no_types) I3_def distinct_append inf_commute)
qed

text \<open>The weak frame condition for an dequeue  preserves invariant 3.\<close>

lemma CleanQ_List_deq_y_weak_I3:
  fixes st st' K x
  assumes I: "CleanQ_List_Invariants K st'"
      and frame: "frame_list_weak (lTYX st', lSX st', lTXY st', lSY st' \<union> {x}) (lTYX st, lSX st, lTXY st, lSY st)"
      and hd: "lTXY st \<noteq> [] \<and> x = hd (lTXY st)"
    shows "I3 st"
 using I frame hd unfolding CleanQ_List_Invariants_def apply auto
proof -
  fix \<delta>aB :: "'a list" and \<delta>Bc :: "'a list"
  assume a1: "I2_list_img st'"
  assume a2: "I3 st'"
  assume a3: "distinct \<delta>Bc"
  assume a4: "lTYX st' = \<delta>aB @ lTYX st"
  assume a5: "lTXY st' @ \<delta>Bc = lTXY st"
  assume a6: "lSX st' \<union> set \<delta>aB = set \<delta>Bc \<union> lSX st"
  have f7: "lSX st' \<inter> set (lTXY st') = {}"
    using a1 by (metis I2_list_img_def)
  have "set (lTXY st') \<inter> set \<delta>aB = {}"
    using a4 a1 by (metis (no_types) I2_list_img_def inf_bot_right inf_left_commute inf_sup_absorb set_append)
  then have "set \<delta>Bc \<inter> set (lTXY st') = {}"
    using f7 a6 by blast
  then show ?thesis
    using a5 a4 a3 a2 by (metis I3_def distinct_append inf_commute)
qed

end