(*  Title:      HOL/Lifting_Set.thy
    Author:     Brian Huffman and Ondrej Kuncar
*)

section \<open>Setup for Lifting/Transfer for the set type\<close>

theory Lifting_Set
imports Lifting
begin

subsection \<open>Relator and predicator properties\<close>

lemma rel_setD1: "\<lbrakk> rel_set R A B; x \<in> A \<rbrakk> \<Longrightarrow> \<exists>y \<in> B. R x y"
  and rel_setD2: "\<lbrakk> rel_set R A B; y \<in> B \<rbrakk> \<Longrightarrow> \<exists>x \<in> A. R x y"
  by (simp_all add: rel_set_def)

lemma rel_set_conversep [simp]: "rel_set A\<inverse>\<inverse> = (rel_set A)\<inverse>\<inverse>"
  unfolding rel_set_def by auto

lemma rel_set_eq [relator_eq]: "rel_set (op =) = (op =)"
  unfolding rel_set_def fun_eq_iff by auto

lemma rel_set_mono[relator_mono]:
  assumes "A \<le> B"
  shows "rel_set A \<le> rel_set B"
  using assms unfolding rel_set_def by blast

lemma rel_set_OO[relator_distr]: "rel_set R OO rel_set S = rel_set (R OO S)"
  apply (rule sym)
  apply (intro ext)
  subgoal for X Z
    apply (rule iffI)
    apply (rule relcomppI [where b="{y. (\<exists>x\<in>X. R x y) \<and> (\<exists>z\<in>Z. S y z)}"])
    apply (simp add: rel_set_def, fast)+
    done
  done

lemma Domainp_set[relator_domain]:
  "Domainp (rel_set T) = (\<lambda>A. Ball A (Domainp T))"
  unfolding rel_set_def Domainp_iff[abs_def]
  apply (intro ext)
  apply (rule iffI)
  apply blast
  subgoal for A by (rule exI [where x="{y. \<exists>x\<in>A. T x y}"]) fast
  done

lemma left_total_rel_set[transfer_rule]:
  "left_total A \<Longrightarrow> left_total (rel_set A)"
  unfolding left_total_def rel_set_def
  apply safe
  subgoal for X by (rule exI [where x="{y. \<exists>x\<in>X. A x y}"]) fast
  done

lemma left_unique_rel_set[transfer_rule]:
  "left_unique A \<Longrightarrow> left_unique (rel_set A)"
  unfolding left_unique_def rel_set_def
  by fast

lemma right_total_rel_set [transfer_rule]:
  "right_total A \<Longrightarrow> right_total (rel_set A)"
  using left_total_rel_set[of "A\<inverse>\<inverse>"] by simp

lemma right_unique_rel_set [transfer_rule]:
  "right_unique A \<Longrightarrow> right_unique (rel_set A)"
  unfolding right_unique_def rel_set_def by fast

lemma bi_total_rel_set [transfer_rule]:
  "bi_total A \<Longrightarrow> bi_total (rel_set A)"
  by(simp add: bi_total_alt_def left_total_rel_set right_total_rel_set)

lemma bi_unique_rel_set [transfer_rule]:
  "bi_unique A \<Longrightarrow> bi_unique (rel_set A)"
  unfolding bi_unique_def rel_set_def by fast

lemma set_relator_eq_onp [relator_eq_onp]:
  "rel_set (eq_onp P) = eq_onp (\<lambda>A. Ball A P)"
  unfolding fun_eq_iff rel_set_def eq_onp_def Ball_def by fast

lemma bi_unique_rel_set_lemma:
  assumes "bi_unique R" and "rel_set R X Y"
  obtains f where "Y = image f X" and "inj_on f X" and "\<forall>x\<in>X. R x (f x)"
proof
  define f where "f x = (THE y. R x y)" for x
  { fix x assume "x \<in> X"
    with \<open>rel_set R X Y\<close> \<open>bi_unique R\<close> have "R x (f x)"
      by (simp add: bi_unique_def rel_set_def f_def) (metis theI)
    with assms \<open>x \<in> X\<close>
    have  "R x (f x)" "\<forall>x'\<in>X. R x' (f x) \<longrightarrow> x = x'" "\<forall>y\<in>Y. R x y \<longrightarrow> y = f x" "f x \<in> Y"
      by (fastforce simp add: bi_unique_def rel_set_def)+ }
  note * = this
  moreover
  { fix y assume "y \<in> Y"
    with \<open>rel_set R X Y\<close> *(3) \<open>y \<in> Y\<close> have "\<exists>x\<in>X. y = f x"
      by (fastforce simp: rel_set_def) }
  ultimately show "\<forall>x\<in>X. R x (f x)" "Y = image f X" "inj_on f X"
    by (auto simp: inj_on_def image_iff)
qed

subsection \<open>Quotient theorem for the Lifting package\<close>

lemma Quotient_set[quot_map]:
  assumes "Quotient R Abs Rep T"
  shows "Quotient (rel_set R) (image Abs) (image Rep) (rel_set T)"
  using assms unfolding Quotient_alt_def4
  apply (simp add: rel_set_OO[symmetric])
  apply (simp add: rel_set_def)
  apply fast
  done

subsection \<open>Transfer rules for the Transfer package\<close>

subsubsection \<open>Unconditional transfer rules\<close>

context includes lifting_syntax
begin

lemma empty_transfer [transfer_rule]: "(rel_set A) {} {}"
  unfolding rel_set_def by simp

lemma insert_transfer [transfer_rule]:
  "(A ===> rel_set A ===> rel_set A) insert insert"
  unfolding rel_fun_def rel_set_def by auto

lemma union_transfer [transfer_rule]:
  "(rel_set A ===> rel_set A ===> rel_set A) union union"
  unfolding rel_fun_def rel_set_def by auto

lemma Union_transfer [transfer_rule]:
  "(rel_set (rel_set A) ===> rel_set A) Union Union"
  unfolding rel_fun_def rel_set_def by simp fast

lemma image_transfer [transfer_rule]:
  "((A ===> B) ===> rel_set A ===> rel_set B) image image"
  unfolding rel_fun_def rel_set_def by simp fast

lemma UNION_transfer [transfer_rule]:
  "(rel_set A ===> (A ===> rel_set B) ===> rel_set B) UNION UNION"
  by transfer_prover

lemma Ball_transfer [transfer_rule]:
  "(rel_set A ===> (A ===> op =) ===> op =) Ball Ball"
  unfolding rel_set_def rel_fun_def by fast

lemma Bex_transfer [transfer_rule]:
  "(rel_set A ===> (A ===> op =) ===> op =) Bex Bex"
  unfolding rel_set_def rel_fun_def by fast

lemma Pow_transfer [transfer_rule]:
  "(rel_set A ===> rel_set (rel_set A)) Pow Pow"
  apply (rule rel_funI)
  apply (rule rel_setI)
  subgoal for X Y X'
    apply (rule rev_bexI [where x="{y\<in>Y. \<exists>x\<in>X'. A x y}"])
    apply clarsimp
    apply (simp add: rel_set_def)
    apply fast
    done
  subgoal for X Y Y'
    apply (rule rev_bexI [where x="{x\<in>X. \<exists>y\<in>Y'. A x y}"])
    apply clarsimp
    apply (simp add: rel_set_def)
    apply fast
    done
  done

lemma rel_set_transfer [transfer_rule]:
  "((A ===> B ===> op =) ===> rel_set A ===> rel_set B ===> op =) rel_set rel_set"
  unfolding rel_fun_def rel_set_def by fast

lemma bind_transfer [transfer_rule]:
  "(rel_set A ===> (A ===> rel_set B) ===> rel_set B) Set.bind Set.bind"
  unfolding bind_UNION [abs_def] by transfer_prover

lemma INF_parametric [transfer_rule]:
  "(rel_set A ===> (A ===> HOL.eq) ===> HOL.eq) INFIMUM INFIMUM"
  by transfer_prover

lemma SUP_parametric [transfer_rule]:
  "(rel_set R ===> (R ===> HOL.eq) ===> HOL.eq) SUPREMUM SUPREMUM"
  by transfer_prover

subsubsection \<open>Rules requiring bi-unique, bi-total or right-total relations\<close>

lemma member_transfer [transfer_rule]:
  assumes "bi_unique A"
  shows "(A ===> rel_set A ===> op =) (op \<in>) (op \<in>)"
  using assms unfolding rel_fun_def rel_set_def bi_unique_def by fast

lemma right_total_Collect_transfer[transfer_rule]:
  assumes "right_total A"
  shows "((A ===> op =) ===> rel_set A) (\<lambda>P. Collect (\<lambda>x. P x \<and> Domainp A x)) Collect"
  using assms unfolding right_total_def rel_set_def rel_fun_def Domainp_iff by fast

lemma Collect_transfer [transfer_rule]:
  assumes "bi_total A"
  shows "((A ===> op =) ===> rel_set A) Collect Collect"
  using assms unfolding rel_fun_def rel_set_def bi_total_def by fast

lemma inter_transfer [transfer_rule]:
  assumes "bi_unique A"
  shows "(rel_set A ===> rel_set A ===> rel_set A) inter inter"
  using assms unfolding rel_fun_def rel_set_def bi_unique_def by fast

lemma Diff_transfer [transfer_rule]:
  assumes "bi_unique A"
  shows "(rel_set A ===> rel_set A ===> rel_set A) (op -) (op -)"
  using assms unfolding rel_fun_def rel_set_def bi_unique_def
  unfolding Ball_def Bex_def Diff_eq
  by (safe, simp, metis, simp, metis)

lemma subset_transfer [transfer_rule]:
  assumes [transfer_rule]: "bi_unique A"
  shows "(rel_set A ===> rel_set A ===> op =) (op \<subseteq>) (op \<subseteq>)"
  unfolding subset_eq [abs_def] by transfer_prover

declare right_total_UNIV_transfer[transfer_rule]

lemma UNIV_transfer [transfer_rule]:
  assumes "bi_total A"
  shows "(rel_set A) UNIV UNIV"
  using assms unfolding rel_set_def bi_total_def by simp

lemma right_total_Compl_transfer [transfer_rule]:
  assumes [transfer_rule]: "bi_unique A" and [transfer_rule]: "right_total A"
  shows "(rel_set A ===> rel_set A) (\<lambda>S. uminus S \<inter> Collect (Domainp A)) uminus"
  unfolding Compl_eq [abs_def]
  by (subst Collect_conj_eq[symmetric]) transfer_prover

lemma Compl_transfer [transfer_rule]:
  assumes [transfer_rule]: "bi_unique A" and [transfer_rule]: "bi_total A"
  shows "(rel_set A ===> rel_set A) uminus uminus"
  unfolding Compl_eq [abs_def] by transfer_prover

lemma right_total_Inter_transfer [transfer_rule]:
  assumes [transfer_rule]: "bi_unique A" and [transfer_rule]: "right_total A"
  shows "(rel_set (rel_set A) ===> rel_set A) (\<lambda>S. \<Inter>S \<inter> Collect (Domainp A)) Inter"
  unfolding Inter_eq[abs_def]
  by (subst Collect_conj_eq[symmetric]) transfer_prover

lemma Inter_transfer [transfer_rule]:
  assumes [transfer_rule]: "bi_unique A" and [transfer_rule]: "bi_total A"
  shows "(rel_set (rel_set A) ===> rel_set A) Inter Inter"
  unfolding Inter_eq [abs_def] by transfer_prover

lemma filter_transfer [transfer_rule]:
  assumes [transfer_rule]: "bi_unique A"
  shows "((A ===> op=) ===> rel_set A ===> rel_set A) Set.filter Set.filter"
  unfolding Set.filter_def[abs_def] rel_fun_def rel_set_def by blast

lemma finite_transfer [transfer_rule]:
  "bi_unique A \<Longrightarrow> (rel_set A ===> op =) finite finite"
  by (rule rel_funI, erule (1) bi_unique_rel_set_lemma)
     (auto dest: finite_imageD)

lemma card_transfer [transfer_rule]:
  "bi_unique A \<Longrightarrow> (rel_set A ===> op =) card card"
  by (rule rel_funI, erule (1) bi_unique_rel_set_lemma)
     (simp add: card_image)

lemma vimage_parametric [transfer_rule]:
  assumes [transfer_rule]: "bi_total A" "bi_unique B"
  shows "((A ===> B) ===> rel_set B ===> rel_set A) vimage vimage"
  unfolding vimage_def[abs_def] by transfer_prover

lemma Image_parametric [transfer_rule]:
  assumes "bi_unique A"
  shows "(rel_set (rel_prod A B) ===> rel_set A ===> rel_set B) op `` op ``"
  by (intro rel_funI rel_setI)
    (force dest: rel_setD1 bi_uniqueDr[OF assms], force dest: rel_setD2 bi_uniqueDl[OF assms])

end

lemma (in comm_monoid_set) F_parametric [transfer_rule]:
  fixes A :: "'b \<Rightarrow> 'c \<Rightarrow> bool"
  assumes "bi_unique A"
  shows "rel_fun (rel_fun A (op =)) (rel_fun (rel_set A) (op =)) F F"
proof (rule rel_funI)+
  fix f :: "'b \<Rightarrow> 'a" and g S T
  assume "rel_fun A (op =) f g" "rel_set A S T"
  with \<open>bi_unique A\<close> obtain i where "bij_betw i S T" "\<And>x. x \<in> S \<Longrightarrow> f x = g (i x)"
    by (auto elim: bi_unique_rel_set_lemma simp: rel_fun_def bij_betw_def)
  then show "F f S = F g T"
    by (simp add: reindex_bij_betw)
qed

lemmas sum_parametric = sum.F_parametric
lemmas prod_parametric = prod.F_parametric

lemma rel_set_UNION:
  assumes [transfer_rule]: "rel_set Q A B" "rel_fun Q (rel_set R) f g"
  shows "rel_set R (UNION A f) (UNION B g)"
  by transfer_prover

end


section \<open>Infinitely Transitive Closure\<close>

theory Inf
  imports Well_founded
begin

coinductive inf :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> bool" for r where
  inf_step: "r x y \<Longrightarrow> inf r y \<Longrightarrow> inf r x"

coinductive inf_wf :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> ('b \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> 'b \<Rightarrow> 'a \<Rightarrow> bool" for r order where
  inf_wf: "order n m \<Longrightarrow> inf_wf r order n x \<Longrightarrow> inf_wf r order m x" |
  inf_wf_step: "r\<^sup>+\<^sup>+ x y \<Longrightarrow> inf_wf r order n y \<Longrightarrow> inf_wf r order m x"

lemma inf_wf_to_step_inf_wf:
  assumes "well_founded order"
  shows "inf_wf r order n x \<Longrightarrow> \<exists>y m. r x y \<and> inf_wf r order m y"
proof (induction n arbitrary: x rule: well_founded.induct[OF assms(1)])
  case (1 n)
  from "1.prems"(1) show ?case
  proof (induction rule: inf_wf.cases)
    case (inf_wf m n' x')
    then show ?case using "1.IH" by simp
  next
    case (inf_wf_step x' y m n')
    then show ?case
      by (metis converse_tranclpE inf_wf.inf_wf_step)
  qed
qed

lemma inf_wf_to_inf:
  assumes "well_founded order"
  shows "inf_wf r order n x \<Longrightarrow> inf r x"
proof (coinduction arbitrary: x n rule: inf.coinduct)
  case (inf x n)
  then obtain y m where "r x y" and "inf_wf r order m y"
    using inf_wf_to_step_inf_wf[OF assms(1) inf(1)] by metis
  thus ?case by auto
qed

lemma step_inf:
  assumes "right_unique r"
  shows "r x y \<Longrightarrow> inf r x \<Longrightarrow> inf r y"
  using right_uniqueD[OF \<open>right_unique r\<close>]
  by (metis inf.cases)

lemma star_inf:
  assumes "right_unique r"
  shows "r\<^sup>*\<^sup>* x y \<Longrightarrow> inf r x \<Longrightarrow> inf r y"
proof (induction y rule: rtranclp_induct)
  case base
  then show ?case by assumption
next
  case (step y z)
  then show ?case
    using step_inf[OF \<open>right_unique r\<close>] by metis
qed

end


section \<open>@{term "\<R>"} is not in BC\label{s:r1_bc}\<close>

theory R1_BC
  imports Lemma_R
    CP_FIN_NUM  (* for V0 *)
begin

text \<open>We show that @{term "U\<^sub>0 \<union> V\<^sub>0"} is not in BC,
which implies @{term "\<R> \<notin> BC"}.

The proof is by contradiction. Assume there is a strategy $S$ learning @{term
"U\<^sub>0 \<union> V\<^sub>0"} behaviorally correct in the limit with respect to our
standard Gödel numbering $\varphi$. Thanks to Lemma~R for BC we can assume
$S$ to be total. Then we construct a function in @{term "U\<^sub>0 \<union> V\<^sub>0"} for
which $S$ fails.

As usual, there is a computable process building prefixes of functions
$\psi_j$. For every $j$ it starts with the singleton prefix $b = [j]$ and
computes the next prefix from a given prefix $b$ as follows:

\begin{enumerate}
\item Simulate $\varphi_{S(b0^k)}(|b| + k)$ for increasing $k$ for an
  increasing number of steps.
\item Once a $k$ with $\varphi_{S(b0^k)}(|b| + k) = 0$ is found, extend the
  prefix by $0^k1$.
\end{enumerate}

There is always such a $k$ because by assumption $S$ learns $b0^\infty \in
U_0$ and thus outputs a hypothesis for $b0^\infty$ on almost all of its
prefixes. Therefore for almost all prefixes of the form $b0^k$, we have
$\varphi_{S(b0^k)} = b0^\infty$ and hence $\varphi_{S(b0^k)}(|b| + k) = 0$.
But Step~2 constructs $\psi_j$ such that $\psi_j(|b| + k) = 1$. Therefore $S$
does not hypothesize $\psi_j$ on the prefix $b0^k$ of $\psi_j$. And since the
process runs forever, $S$ outputs infinitely many incorrect hypotheses for
$\psi_j$ and thus does not learn $\psi_j$.

Applying Kleene's fixed-point theorem to @{term "\<psi> \<in> \<R>\<^sup>2"}
yields a $j$ with $\varphi_j = \psi_j$ and thus $\psi_j \in V_0$. But $S$
does not learn any $\psi_j$, contradicting our assumption.

The result @{prop "\<R> \<notin> BC"} can be obtained more directly by
running the process with the empty prefix, thereby constructing only one
function instead of a numbering. This function is in @{term R1}, and $S$
fails to learn it by the same reasoning as above. The stronger statement
about @{term "U\<^sub>0 \<union> V\<^sub>0"} will be exploited in
Section~\ref{s:union}.

In the following locale the assumption that $S$ learns @{term "U\<^sub>0"}
suffices for analyzing the process. However, in order to arrive at the
desired contradiction this assumption is too weak because the functions built
by the process are not in @{term "U\<^sub>0"}.\<close>

locale r1_bc =
  fixes s :: partial1
  assumes s_in_R1: "s \<in> \<R>" and s_learn_U0: "learn_bc \<phi> U\<^sub>0 s"
begin

lemma s_learn_prenum: "\<And>b. learn_bc \<phi> {prenum b} s"
  using s_learn_U0 U0_altdef learn_bc_closed_subseteq by blast

text \<open>A @{typ recf} for the strategy:\<close>

definition r_s :: recf where
  "r_s \<equiv> SOME rs. recfn 1 rs \<and>  total rs \<and> s = (\<lambda>x. eval rs [x])"

lemma r_s_recfn [simp]: "recfn 1 r_s"
  and r_s_total: "\<And>x. eval r_s [x] \<down>"
  and eval_r_s: "\<And>x. s x = eval r_s [x]"
  using r_s_def R1_SOME[OF s_in_R1, of r_s] by simp_all

text \<open>We begin with the function that finds the $k$ from Step~1 of the
construction of $\psi$.\<close>

definition "r_find_k \<equiv>
  let k = Cn 2 r_pdec1 [Id 2 0];
      r = Cn 2 r_result1
        [Cn 2 r_pdec2 [Id 2 0],
        Cn 2 r_s [Cn 2 r_append_zeros [Id 2 1, k]],
        Cn 2 r_add [Cn 2 r_length [Id 2 1], k]]
  in Cn 1 r_pdec1 [Mn 1 (Cn 2 r_eq [r, r_constn 1 1])]"

lemma r_find_k_recfn [simp]: "recfn 1 r_find_k"
  unfolding r_find_k_def by (simp add: Let_def)

text \<open>There is always a suitable $k$, since the strategy learns
$b0^\infty$ for all $b$.\<close>

lemma learn_bc_prenum_eventually_zero:
  "\<exists>k. \<phi> (the (s (e_append_zeros b k))) (e_length b + k) \<down>= 0"
proof -
  let ?f = "prenum b"
  have "\<exists>n\<ge>e_length b. \<phi> (the (s (?f \<triangleright> n))) = ?f"
    using learn_bcE s_learn_prenum by (meson le_cases singletonI)
  then obtain n where n: "n \<ge> e_length b" "\<phi> (the (s (?f \<triangleright> n))) = ?f"
    by auto
  define k where "k = Suc n - e_length b"
  let ?e = "e_append_zeros b k"
  have len: "e_length ?e = Suc n"
    using k_def n e_append_zeros_length by simp
  have "?f \<triangleright> n = ?e"
  proof -
    have "e_length ?e > 0"
      using len n(1) by simp
    moreover have "?f x \<down>= e_nth ?e x" for x
    proof (cases "x < e_length b")
      case True
      then show ?thesis using e_nth_append_zeros by simp
    next
      case False
      then have "?f x \<down>= 0" by simp
      moreover from False have "e_nth ?e x = 0"
        using e_nth_append_zeros_big by simp
      ultimately show ?thesis by simp
    qed
    ultimately show ?thesis using initI[of "?e"] len by simp
  qed
  with n(2) have "\<phi> (the (s ?e)) = ?f" by simp
  then have "\<phi> (the (s ?e)) (e_length ?e) \<down>= 0"
    using len n(1) by auto
  then show ?thesis using e_append_zeros_length by auto
qed

lemma if_eq_eq: "(if v = 1 then (0 :: nat) else 1) = 0 \<Longrightarrow> v = 1"
  by presburger

lemma r_find_k:
  shows "eval r_find_k [b] \<down>"
    and "let k = the (eval r_find_k [b])
           in \<phi> (the (s (e_append_zeros b k))) (e_length b + k) \<down>= 0"
proof -
  let ?k = "Cn 2 r_pdec1 [Id 2 0]"
  let ?argt = "Cn 2 r_pdec2 [Id 2 0]"
  let ?argi = "Cn 2 r_s [Cn 2 r_append_zeros [Id 2 1, ?k]]"
  let ?argx = "Cn 2 r_add [Cn 2 r_length [Id 2 1], ?k]"
  let ?r = "Cn 2 r_result1 [?argt, ?argi, ?argx]"
  define f where "f \<equiv>
    let k = Cn 2 r_pdec1 [Id 2 0];
        r = Cn 2 r_result1
             [Cn 2 r_pdec2 [Id 2 0],
              Cn 2 r_s [Cn 2 r_append_zeros [Id 2 1, k]],
              Cn 2 r_add [Cn 2 r_length [Id 2 1], k]]
    in Cn 2 r_eq [r, r_constn 1 1]"
  then have "recfn 2 f" by (simp add: Let_def)
  have "total r_s"
    by (simp add: r_s_total totalI1)
  then have "total f"
    unfolding f_def using Cn_total Mn_free_imp_total by (simp add: Let_def)

  have "eval ?argi [z, b] = s (e_append_zeros b (pdec1 z))" for z
    using r_append_zeros \<open>recfn 2 f\<close> eval_r_s by auto
  then have "eval ?argi [z, b] \<down>= the (s (e_append_zeros b (pdec1 z)))" for z
    using eval_r_s r_s_total by simp
  moreover have "recfn 2 ?r" using \<open>recfn 2 f\<close> by auto
  ultimately have r: "eval ?r [z, b] =
      eval r_result1 [pdec2 z, the (s (e_append_zeros b (pdec1 z))), e_length b + pdec1 z]"
      for z
    by simp
  then have f: "eval f [z, b] \<down>= (if the (eval ?r [z, b]) = 1 then 0 else 1)" for z
    using f_def \<open>recfn 2 f\<close> prim_recfn_total by (auto simp add: Let_def)

  have "\<exists>k. \<phi> (the (s (e_append_zeros b k))) (e_length b + k) \<down>= 0"
    using s_learn_prenum learn_bc_prenum_eventually_zero by auto
  then obtain k where "\<phi> (the (s (e_append_zeros b k))) (e_length b + k) \<down>= 0"
    by auto
  then obtain t where "eval r_result1 [t, the (s (e_append_zeros b k)), e_length b + k] \<down>= Suc 0"
    using r_result1_converg_phi(1) by blast
  then have t: "eval r_result1 [t, the (s (e_append_zeros b k)), e_length b + k] \<down>= Suc 0"
    by simp

  let ?z = "prod_encode (k, t)"
  have "eval ?r [?z, b] \<down>= Suc 0"
    using t r by (metis fst_conv prod_encode_inverse snd_conv)
  with f have fzb: "eval f [?z, b] \<down>= 0" by simp
  moreover have "eval (Mn 1 f) [b] =
    (if (\<exists>z. eval f ([z, b]) \<down>= 0)
     then Some (LEAST z. eval f [z, b] \<down>= 0)
     else None)"
    using eval_Mn_total[of 1 f "[b]"] \<open>total f\<close> \<open>recfn 2 f\<close> by simp
  ultimately have mn1f: "eval (Mn 1 f) [b] \<down>= (LEAST z. eval f [z, b] \<down>= 0)"
    by auto
  with fzb have "eval f [the (eval (Mn 1 f) [b]), b] \<down>= 0" (is "eval f [?zz, b] \<down>= 0")
    using \<open>total f\<close> \<open>recfn 2 f\<close> LeastI_ex[of "%z. eval f [z, b] \<down>= 0"] by auto
  moreover have "eval f [?zz, b] \<down>= (if the (eval ?r [?zz, b]) = 1 then 0 else 1)"
    using f by simp
  ultimately have "(if the (eval ?r [?zz, b]) = 1 then (0 :: nat) else 1) = 0" by auto
  then have "the (eval ?r [?zz, b]) = 1"
    using if_eq_eq[of "the (eval ?r [?zz, b])"] by simp
  then have
     "eval r_result1
        [pdec2 ?zz, the (s (e_append_zeros b (pdec1 ?zz))), e_length b + pdec1 ?zz] \<down>=
      1"
    using r r_result1_total r_result1_prim totalE
    by (metis length_Cons list.size(3) numeral_3_eq_3 option.collapse)
  then have *: "\<phi> (the (s (e_append_zeros b (pdec1 ?zz)))) (e_length b + pdec1 ?zz) \<down>= 0"
    by (simp add: r_result1_some_phi)

  define Mn1f where "Mn1f = Mn 1 f"
  then have "eval Mn1f [b] \<down>= ?zz"
    using mn1f by auto
  moreover have "recfn 1 (Cn 1 r_pdec1 [Mn1f])"
    using \<open>recfn 2 f\<close> Mn1f_def by simp
  ultimately have "eval (Cn 1 r_pdec1 [Mn1f]) [b] = eval r_pdec1 [the (eval (Mn1f) [b])]"
    by auto
  then have "eval (Cn 1 r_pdec1 [Mn1f]) [b] = eval r_pdec1 [?zz]"
    using Mn1f_def by blast
  then have 1: "eval (Cn 1 r_pdec1 [Mn1f]) [b] \<down>= pdec1 ?zz"
    by simp
  moreover have "recfn 1 (Cn 1 S [Cn 1 r_pdec1 [Mn1f]])"
    using \<open>recfn 2 f\<close> Mn1f_def by simp
  ultimately have "eval (Cn 1 S [Cn 1 r_pdec1 [Mn1f]]) [b] =
      eval S [the (eval (Cn 1 r_pdec1 [Mn1f]) [b])]"
    by simp
  then have "eval (Cn 1 S [Cn 1 r_pdec1 [Mn1f]]) [b] = eval S [pdec1 ?zz]"
    using 1 by simp
  then have "eval (Cn 1 S [Cn 1 r_pdec1 [Mn1f]]) [b] \<down>= Suc (pdec1 ?zz)"
    by simp
  moreover have "eval r_find_k [b] = eval (Cn 1 r_pdec1 [Mn1f]) [b]"
    unfolding r_find_k_def Mn1f_def f_def by metis
  ultimately have r_find_ksb: "eval r_find_k [b] \<down>= pdec1 ?zz"
    using 1 by simp
  then show "eval r_find_k [b] \<down>" by simp_all

  from r_find_ksb have "the (eval r_find_k [b]) = pdec1 ?zz"
    by simp
  moreover have "\<phi> (the (s (e_append_zeros b (pdec1 ?zz)))) (e_length b + pdec1 ?zz) \<down>= 0"
    using * by simp
  ultimately show "let k = the (eval r_find_k [b])
      in \<phi> (the (s (e_append_zeros b k))) (e_length b + k) \<down>= 0"
    by simp
qed

lemma r_find_k_total: "total r_find_k"
  by (simp add: s_learn_prenum r_find_k(1) totalI1)

text \<open>The following function represents one iteration of the
process.\<close>

abbreviation "r_next \<equiv>
  Cn 3 r_snoc [Cn 3 r_append_zeros [Id 3 1, Cn 3 r_find_k [Id 3 1]], r_constn 2 1]"

text \<open>Using @{term r_next} we define the function @{term r_prefixes}
that computes the prefix after every iteration of the process.\<close>

definition r_prefixes :: recf where
  "r_prefixes \<equiv> Pr 1 r_singleton_encode r_next"

lemma r_prefixes_total: "total r_prefixes"
proof -
  have "recfn 3 r_next" by simp
  then have "total r_next"
    using \<open>recfn 3 r_next\<close> r_find_k_total Cn_total Mn_free_imp_total by auto
  then show ?thesis
    by (simp add: Mn_free_imp_total Pr_total r_prefixes_def)
qed

lemma r_prefixes_0: "eval r_prefixes [0, j] \<down>= list_encode [j]"
  unfolding r_prefixes_def by simp

lemma r_prefixes_Suc:
  "eval r_prefixes [Suc n, j] \<down>=
    (let b = the (eval r_prefixes [n, j])
     in e_snoc (e_append_zeros b (the (eval r_find_k [b]))) 1)"
proof -
  have "recfn 3 r_next" by simp
  then have "total r_next"
    using \<open>recfn 3 r_next\<close> r_find_k_total Cn_total Mn_free_imp_total by auto
  have eval_next: "eval r_next [t, v, j] \<down>=
      e_snoc (e_append_zeros v (the (eval r_find_k [v]))) 1"
      for t v j
    using r_find_k_total \<open>recfn 3 r_next\<close> r_append_zeros by simp
  then have "eval r_prefixes [Suc n, j] = eval r_next [n, the (eval r_prefixes [n, j]), j]"
    using r_prefixes_total by (simp add: r_prefixes_def)
  then show "eval r_prefixes [Suc n, j] \<down>=
    (let b = the (eval r_prefixes [n, j])
     in e_snoc (e_append_zeros b (the (eval r_find_k [b]))) 1)"
    using eval_next by metis
qed

text \<open>Since @{term r_prefixes} is total, we can get away with
introducing a total function.\<close>

definition prefixes :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
  "prefixes j t \<equiv> the (eval r_prefixes [t, j])"

lemma prefixes_Suc:
  "prefixes j (Suc t) =
    e_snoc (e_append_zeros (prefixes j t) (the (eval r_find_k [prefixes j t]))) 1"
  unfolding prefixes_def using r_prefixes_Suc by (simp_all add: Let_def)

lemma prefixes_Suc_length:
  "e_length (prefixes j (Suc t)) =
    Suc (e_length (prefixes j t) + the (eval r_find_k [prefixes j t]))"
  using e_append_zeros_length prefixes_Suc by simp

lemma prefixes_length_mono: "e_length (prefixes j t) < e_length (prefixes j (Suc t))"
  using prefixes_Suc_length by simp

lemma prefixes_length_mono': "e_length (prefixes j t) \<le> e_length (prefixes j (t + d))"
proof (induction d)
  case 0
  then show ?case by simp
next
  case (Suc d)
  then show ?case using prefixes_length_mono le_less_trans by fastforce
qed

lemma prefixes_length_lower_bound: "e_length (prefixes j t) \<ge> Suc t"
proof (induction t)
  case 0
  then show ?case by (simp add: prefixes_def r_prefixes_0)
next
  case (Suc t)
  moreover have "Suc (e_length (prefixes j t)) \<le> e_length (prefixes j (Suc t))"
    using prefixes_length_mono by (simp add: Suc_leI)
  ultimately show ?case by simp
qed

lemma prefixes_Suc_nth:
  assumes "x < e_length (prefixes j t)"
  shows "e_nth (prefixes j t) x = e_nth (prefixes j (Suc t)) x"
proof -
  define k where "k = the (eval r_find_k [prefixes j t])"
  let ?u = "e_append_zeros (prefixes j t) k"
  have "prefixes j (Suc t) =
      e_snoc (e_append_zeros (prefixes j t) (the (eval r_find_k [prefixes j t]))) 1"
    using prefixes_Suc by simp
  with k_def have "prefixes j (Suc t) = e_snoc ?u 1"
    by simp
  then have "e_nth (prefixes j (Suc t)) x = e_nth (e_snoc ?u 1) x"
    by simp
  moreover have "x < e_length ?u"
    using assms e_append_zeros_length by auto
  ultimately have "e_nth (prefixes j (Suc t)) x = e_nth ?u x"
    using e_nth_snoc_small by simp
  moreover have "e_nth ?u x = e_nth (prefixes j t) x"
    using assms e_nth_append_zeros by simp
  ultimately show "e_nth (prefixes j t) x = e_nth (prefixes j (Suc t)) x"
    by simp
qed

lemma prefixes_Suc_last: "e_nth (prefixes j (Suc t)) (e_length (prefixes j (Suc t)) - 1) = 1"
  using prefixes_Suc by simp

lemma prefixes_le_nth:
  assumes "x < e_length (prefixes j t)"
  shows "e_nth (prefixes j t) x = e_nth (prefixes j (t + d)) x"
proof (induction d)
  case 0
  then show ?case by simp
next
  case (Suc d)
  have "x < e_length (prefixes j (t + d))"
    using s_learn_prenum assms prefixes_length_mono'
    by (simp add: less_eq_Suc_le order_trans_rules(23))
  then have "e_nth (prefixes j (t + d)) x = e_nth (prefixes j (t + Suc d)) x"
    using prefixes_Suc_nth by simp
  with Suc show ?case by simp
qed

text \<open>The numbering $\psi$ is defined via @{term[names_short] prefixes}.\<close>

definition psi :: partial2 ("\<psi>") where
  "\<psi> j x \<equiv> Some (e_nth (prefixes j (Suc x)) x)"

lemma psi_in_R2: "\<psi> \<in> \<R>\<^sup>2"
proof
  define r where "r \<equiv>  Cn 2 r_nth [Cn 2 r_prefixes [Cn 2 S [Id 2 1], Id 2 0], Id 2 1]"
  then have "recfn 2 r"
    using r_prefixes_recfn by simp
  then have "eval r [j, x] \<down>= e_nth (prefixes j (Suc x)) x" for j x
    unfolding r_def prefixes_def using r_prefixes_total r_prefixes_recfn e_nth by simp
  then have "eval r [j, x] = \<psi> j x" for j x
    unfolding psi_def by simp
  then show "\<psi> \<in> \<P>\<^sup>2"
    using \<open>recfn 2 r\<close> by auto
  show "total2 \<psi>"
    unfolding psi_def by auto
qed

lemma psi_eq_nth_prefixes:
  assumes "x < e_length (prefixes j t)"
  shows "\<psi> j x \<down>= e_nth (prefixes j t) x"
proof (cases "Suc x < t")
  case True
  have "x \<le> e_length (prefixes j x)"
    using prefixes_length_lower_bound by (simp add: Suc_leD)
  also have "... < e_length (prefixes j (Suc x))"
    using prefixes_length_mono s_learn_prenum by simp
  finally have "x < e_length (prefixes j (Suc x))" .
  with True have "e_nth (prefixes j (Suc x)) x = e_nth (prefixes j t) x"
    using prefixes_le_nth[of x j "Suc x" "t - Suc x"] by simp
  then show ?thesis using psi_def by simp
next
  case False
  then have "e_nth (prefixes j (Suc x)) x = e_nth (prefixes j t) x"
    using prefixes_le_nth[of x j t "Suc x - t"] assms by simp
  then show ?thesis using psi_def by simp
qed

lemma psi_at_0: "\<psi> j 0 \<down>= j"
  using psi_eq_nth_prefixes[of 0 j 0] prefixes_length_lower_bound[of 0 j]
  by (simp add: prefixes_def r_prefixes_0)

text \<open>The prefixes output by the process @{term[names_short] "prefixes j"} are
indeed prefixes of $\psi_j$.\<close>

lemma prefixes_init_psi: "\<psi> j \<triangleright> (e_length (prefixes j (Suc t)) - 1) = prefixes j (Suc t)"
proof (rule initI[of "prefixes j (Suc t)"])
  let ?e = "prefixes j (Suc t)"
  show "e_length ?e > 0"
    using prefixes_length_lower_bound[of "Suc t" j] by auto
  show "\<And>x. x < e_length ?e \<Longrightarrow> \<psi> j x \<down>= e_nth ?e x"
    using prefixes_Suc_nth psi_eq_nth_prefixes by simp
qed

text \<open>Every prefix of $\psi_j$ generated by the process
@{term[names_short] "prefixes j"} (except for the initial one) is of the form
$b0^k1$. But $k$ is chosen such that $\varphi_{S(b0^k)}(|b|+k) = 0 \neq 1 =
b0^k1_{|b|+k}$. Therefore the hypothesis $S(b0^k)$ is incorrect for
$\psi_j$.\<close>

lemma hyp_wrong_at_last:
  "\<phi> (the (s (e_butlast (prefixes j (Suc t))))) (e_length (prefixes j (Suc t)) - 1) \<noteq>
   \<psi> j (e_length (prefixes j (Suc t)) - 1)"
  (is "?lhs \<noteq> ?rhs")
proof -
  let ?b = "prefixes j t"
  let ?k = "the (eval r_find_k [?b])"
  let ?x = "e_length (prefixes j (Suc t)) - 1"
  have "e_butlast (prefixes j (Suc t)) = e_append_zeros ?b ?k"
    using s_learn_prenum prefixes_Suc by simp
  then have "?lhs = \<phi> (the (s (e_append_zeros ?b ?k))) ?x"
    by simp
  moreover have "?x = e_length ?b + ?k"
    using prefixes_Suc_length by simp
  ultimately have "?lhs = \<phi> (the (s (e_append_zeros ?b ?k))) (e_length ?b + ?k)"
    by simp
  then have "?lhs \<down>= 0"
    using r_find_k(2) r_s_total s_learn_prenum by metis
  moreover have "?x < e_length (prefixes j (Suc t))"
    using prefixes_length_lower_bound le_less_trans linorder_not_le s_learn_prenum
    by fastforce
  ultimately have "?rhs \<down>= e_nth (prefixes j (Suc t)) ?x"
    using psi_eq_nth_prefixes[of ?x j "Suc t"] by simp
  moreover have "e_nth (prefixes j (Suc t)) ?x = 1"
    using prefixes_Suc prefixes_Suc_last by simp
  ultimately have "?rhs \<down>= 1" by simp
  with \<open>?lhs \<down>= 0\<close> show ?thesis by simp
qed

corollary hyp_wrong: "\<phi> (the (s (e_butlast (prefixes j (Suc t))))) \<noteq> \<psi> j"
  using hyp_wrong_at_last[of j t] by auto

text \<open>For all $j$, the strategy $S$ outputs infinitely many wrong hypotheses for
$\psi_j$\<close>

lemma infinite_hyp_wrong: "\<exists>m>n. \<phi> (the (s (\<psi> j \<triangleright> m))) \<noteq> \<psi> j"
proof -
  let ?b = "prefixes j (Suc (Suc n))"
  let ?bb = "e_butlast ?b"
  have len_b: "e_length ?b > Suc (Suc n)"
    using prefixes_length_lower_bound by (simp add: Suc_le_lessD)
  then have len_bb: "e_length ?bb > Suc n" by simp
  define m where "m = e_length ?bb - 1"
  with len_bb have "m > n" by simp
  have "\<psi> j \<triangleright> m = ?bb"
  proof -
    have "\<psi> j \<triangleright> (e_length ?b - 1) = ?b"
      using prefixes_init_psi by simp
    then have "\<psi> j \<triangleright> (e_length ?b - 2) = ?bb"
      using init_butlast_init psi_in_R2 R2_proj_R1 R1_imp_total1 len_bb length_init
      by (metis Suc_1 diff_diff_left length_butlast length_greater_0_conv
        list.size(3) list_decode_encode not_less0 plus_1_eq_Suc)
    then show ?thesis by (metis diff_Suc_1 length_init m_def)
  qed
  moreover have "\<phi> (the (s ?bb)) \<noteq> \<psi> j"
    using hyp_wrong by simp
  ultimately have "\<phi> (the (s (\<psi> j \<triangleright> m))) \<noteq> \<psi> j"
    by simp
  with \<open>m > n\<close> show ?thesis by auto
qed

lemma U0_V0_not_learn_bc: "\<not> learn_bc \<phi> (U\<^sub>0 \<union> V\<^sub>0) s"
proof -
  obtain j where j: "\<phi> j = \<psi> j"
    using R2_imp_P2 kleene_fixed_point psi_in_R2 by blast
  moreover have "\<exists>m>n. \<phi> (the (s ((\<psi> j) \<triangleright> m))) \<noteq> \<psi> j" for n
    using infinite_hyp_wrong[of _ j] by simp
  ultimately have "\<not> learn_bc \<phi> {\<psi> j} s"
    using infinite_hyp_wrong_not_BC by simp
  moreover have "\<psi> j \<in> V\<^sub>0"
  proof -
    have "\<psi> j \<in> \<R>" (is "?f \<in> \<R>")
      using psi_in_R2 by simp
    moreover have "\<phi> (the (?f 0)) = ?f"
      using j psi_at_0[of j] by simp
    ultimately show ?thesis by (simp add: V0_def)
  qed
  ultimately show "\<not> learn_bc \<phi> (U\<^sub>0 \<union> V\<^sub>0) s"
    using learn_bc_closed_subseteq by auto
qed

end

lemma U0_V0_not_in_BC: "U\<^sub>0 \<union> V\<^sub>0 \<notin> BC"
proof
  assume in_BC: "U\<^sub>0 \<union> V\<^sub>0 \<in> BC"
  then have "U\<^sub>0 \<union> V\<^sub>0 \<in> BC_wrt \<phi>"
    using BC_wrt_phi_eq_BC by simp
  then obtain s where "learn_bc \<phi> (U\<^sub>0 \<union> V\<^sub>0) s"
    using BC_wrt_def by auto
  then obtain s' where s': "s' \<in> \<R>" "learn_bc \<phi> (U\<^sub>0 \<union> V\<^sub>0) s'"
    using lemma_R_for_BC_simple by blast
  then have learn_U0: "learn_bc \<phi> U\<^sub>0 s'"
    using learn_bc_closed_subseteq[of \<phi> "U\<^sub>0 \<union> V\<^sub>0" "s'"] by simp
  then interpret r1_bc s'
    by (simp add: r1_bc_def s'(1))
  have "\<not> learn_bc \<phi> (U\<^sub>0 \<union> V\<^sub>0) s'"
    using learn_bc_closed_subseteq U0_V0_not_learn_bc by simp
  with s'(2) show False by simp
qed

theorem R1_not_in_BC: "\<R> \<notin> BC"
proof -
  have "U\<^sub>0 \<union> V\<^sub>0 \<subseteq> \<R>"
    using V0_def U0_in_NUM by auto
  then show ?thesis
    using U0_V0_not_in_BC BC_closed_subseteq by auto
qed

end


(* Victor B. F. Gomes, University of Cambridge
   Martin Kleppmann, University of Cambridge
   Dominic P. Mulligan, University of Cambridge
   Alastair R. Beresford, University of Cambridge
*)

section\<open>Axiomatic network models\<close>

text\<open>In this section we develop a formal definition of an \emph{asynchronous unreliable causal broadcast network}.
     We choose this model because it satisfies the causal delivery requirements of many operation-based
     CRDTs~\cite{Almeida:2015fc,Baquero:2014ed}. Moreover, it is suitable for use in decentralised settings,
     as motivated in the introduction, since it does not require waiting for communication with
     a central server or a quorum of nodes.\<close>

theory
  Network
imports
  Convergence
begin

subsection\<open>Node histories\<close>

text\<open>We model a distributed system as an unbounded number of communicating nodes.
     We assume nothing about the communication pattern of nodes---we assume only that each node is
     uniquely identified by a natural number, and that the flow of execution at each node consists
     of a finite, totally ordered sequence of execution steps (events).
     We call that sequence of events at node $i$ the \emph{history} of that node.
     For convenience, we assume that every event or execution step is unique within a node's history.\<close>

locale node_histories =
  fixes history :: "nat \<Rightarrow> 'evt list"
  assumes histories_distinct [intro!, simp]: "distinct (history i)"

lemma (in node_histories) history_finite:
  shows "finite (set (history i))"
by auto

definition (in node_histories) history_order :: "'evt \<Rightarrow> nat \<Rightarrow> 'evt \<Rightarrow> bool" ("_/ \<sqsubset>\<^sup>_/ _" [50,1000,50]50) where
  "x \<sqsubset>\<^sup>i z \<equiv> \<exists>xs ys zs. xs@x#ys@z#zs = history i"

lemma (in node_histories) node_total_order_trans:
  assumes "e1 \<sqsubset>\<^sup>i e2"
      and "e2 \<sqsubset>\<^sup>i e3"
    shows "e1 \<sqsubset>\<^sup>i e3"
proof -
  obtain xs1 xs2 ys1 ys2 zs1 zs2 where *: "xs1 @ e1 # ys1 @ e2 # zs1 = history i"
      "xs2 @ e2 # ys2 @ e3 # zs2 = history i"
    using history_order_def assms by auto
  hence "xs1 @ e1 # ys1 = xs2 \<and> zs1 = ys2 @ e3 # zs2"
    by(rule_tac xs="history i" and ys="[e2]" in pre_suf_eq_distinct_list) auto
  thus ?thesis
    by(clarsimp simp: history_order_def) (metis "*"(2) append.assoc append_Cons)
qed

lemma (in node_histories) local_order_carrier_closed:
  assumes "e1 \<sqsubset>\<^sup>i e2"
    shows "{e1,e2} \<subseteq> set (history i)"
  using assms by (clarsimp simp add: history_order_def)
    (metis in_set_conv_decomp Un_iff Un_subset_iff insert_subset list.simps(15)
        set_append set_subset_Cons)+

lemma (in node_histories) node_total_order_irrefl:
  shows "\<not> (e \<sqsubset>\<^sup>i e)"
  by(clarsimp simp add: history_order_def)
    (metis Un_iff histories_distinct distinct_append distinct_set_notin
        list.set_intros(1) set_append)

lemma (in node_histories) node_total_order_antisym:
  assumes "e1 \<sqsubset>\<^sup>i e2"
      and "e2 \<sqsubset>\<^sup>i e1"
    shows "False"
  using assms node_total_order_irrefl node_total_order_trans by blast

lemma (in node_histories) node_order_is_total:
  assumes "e1 \<in> set (history i)"
      and "e2 \<in> set (history i)"
      and "e1 \<noteq> e2"
    shows "e1 \<sqsubset>\<^sup>i e2 \<or> e2 \<sqsubset>\<^sup>i e1"
  using assms unfolding history_order_def by(metis list_split_two_elems histories_distinct)

definition (in node_histories) prefix_of_node_history :: "'evt list \<Rightarrow> nat \<Rightarrow> bool" (infix "prefix of" 50) where
  "xs prefix of i \<equiv> \<exists>ys. xs@ys = history i"

lemma (in node_histories) carriers_head_lt:
  assumes "y#ys = history i"
  shows   "\<not>(x \<sqsubset>\<^sup>i y)"
using assms
  apply(clarsimp simp add: history_order_def)
  apply(rename_tac xs1 ys1 zs1)
   apply (subgoal_tac "xs1 @ x # ys1 = [] \<and> zs1 = ys")
  apply clarsimp
  apply (rule_tac xs="history i" and ys="[y]" in pre_suf_eq_distinct_list)
   apply auto
  done

lemma (in node_histories) prefix_of_ConsD [dest]:
  assumes "x # xs prefix of i"
    shows "[x] prefix of i"
  using assms by(auto simp: prefix_of_node_history_def)

lemma (in node_histories) prefix_of_appendD [dest]:
  assumes "xs @ ys prefix of i"
    shows "xs prefix of i"
  using assms by(auto simp: prefix_of_node_history_def)

lemma (in node_histories) prefix_distinct:
  assumes "xs prefix of i"
    shows "distinct xs"
  using assms by(clarsimp simp: prefix_of_node_history_def) (metis histories_distinct distinct_append)

lemma (in node_histories) prefix_to_carriers [intro]:
  assumes "xs prefix of i"
    shows "set xs \<subseteq> set (history i)"
  using assms by(clarsimp simp: prefix_of_node_history_def) (metis Un_iff set_append)

lemma (in node_histories) prefix_elem_to_carriers:
  assumes "xs prefix of i"
      and "x \<in> set xs"
    shows "x \<in> set (history i)"
  using assms by(clarsimp simp: prefix_of_node_history_def) (metis Un_iff set_append)

lemma (in node_histories) local_order_prefix_closed:
  assumes "x \<sqsubset>\<^sup>i y"
      and "xs prefix of i"
      and "y \<in> set xs"
    shows "x \<in> set xs"
proof -
  obtain ys where "xs @ ys = history i"
    using assms prefix_of_node_history_def by blast
  moreover obtain as bs cs where "as @ x # bs @ y # cs = history i"
    using assms history_order_def by blast
  moreover obtain pre suf where *: "xs = pre @ y # suf"
    using assms split_list by fastforce
  ultimately have "pre = as @ x # bs \<and> suf @ ys = cs"
    by (rule_tac xs="history i" and ys="[y]" in pre_suf_eq_distinct_list) auto
  thus ?thesis
    using assms * by clarsimp
qed

lemma (in node_histories) local_order_prefix_closed_last:
  assumes "x \<sqsubset>\<^sup>i y"
      and "xs@[y] prefix of i"
    shows "x \<in> set xs"
proof -
  have "x \<in> set (xs @ [y])"
    using assms by (force dest: local_order_prefix_closed)
  thus ?thesis
    using assms by(force simp add: node_total_order_irrefl prefix_to_carriers)
qed

lemma (in node_histories) events_before_exist:
  assumes "x \<in> set (history i)"
  shows "\<exists>pre. pre @ [x] prefix of i"
proof -
  have "\<exists>idx. idx < length (history i) \<and> (history i) ! idx = x"
    using assms by(simp add: set_elem_nth)
  thus ?thesis
    by(metis append_take_drop_id take_Suc_conv_app_nth prefix_of_node_history_def)
qed

lemma (in node_histories) events_in_local_order:
  assumes "pre @ [e2] prefix of i"
  and "e1 \<in> set pre"
  shows "e1 \<sqsubset>\<^sup>i e2"
  using assms split_list unfolding history_order_def prefix_of_node_history_def by fastforce

subsection\<open>Asynchronous broadcast networks\<close>

text\<open>We define a new locale $\isa{network}$ containing three axioms that define how broadcast
     and deliver events may interact, with these axioms defining the properties of our network model.\<close>

datatype 'msg event
  = Broadcast 'msg
  | Deliver 'msg

locale network = node_histories history for history :: "nat \<Rightarrow> 'msg event list" +
  fixes msg_id :: "'msg \<Rightarrow> 'msgid"
  (* Broadcast/Deliver interaction *)
  assumes delivery_has_a_cause: "\<lbrakk> Deliver m \<in> set (history i) \<rbrakk> \<Longrightarrow>
                                    \<exists>j. Broadcast m \<in> set (history j)"
      and deliver_locally: "\<lbrakk> Broadcast m \<in> set (history i) \<rbrakk> \<Longrightarrow>
                                    Broadcast m \<sqsubset>\<^sup>i Deliver m"
      and msg_id_unique: "\<lbrakk> Broadcast m1 \<in> set (history i);
                            Broadcast m2 \<in> set (history j);
                            msg_id m1 = msg_id m2 \<rbrakk> \<Longrightarrow> i = j \<and> m1 = m2"

text\<open>
The axioms can be understood as follows:
\begin{description}
    \item[delivery-has-a-cause:] If some message $\isa{m}$ was delivered at some node, then there exists some node on which $\isa{m}$ was broadcast.
        With this axiom, we assert that messages are not created ``out of thin air'' by the network itself, and that the only source of messages are the nodes.
    \item[deliver-locally:] If a node broadcasts some message $\isa{m}$, then the same node must subsequently also deliver $\isa{m}$ to itself.
        Since $\isa{m}$ does not actually travel over the network, this local delivery is always possible, even if the network is interrupted.
        Local delivery may seem redundant, since the effect of the delivery could also be implemented by the broadcast event itself; however, it is standard practice in the description of broadcast protocols that the sender of a message also sends it to itself, since this property simplifies the definition of algorithms built on top of the broadcast abstraction \cite{Cachin:2011wt}.
    \item[msg-id-unique:] We do not assume that the message type $\isacharprime\isa{msg}$ has any particular structure; we only assume the existence of a function $\isa{msg-id} \mathbin{\isacharcolon\isacharcolon} \isacharprime\isa{msg} \mathbin{\isasymRightarrow} \isacharprime\isa{msgid}$ that maps every message to some globally unique identifier of type $\isacharprime\isa{msgid}$.
        We assert this uniqueness by stating that if $\isa{m1}$ and $\isa{m2}$ are any two messages broadcast by any two nodes, and their $\isa{msg-id}$s are the same, then they were in fact broadcast by the same node and the two messages are identical.
        In practice, these globally unique IDs can by implemented using unique node identifiers, sequence numbers or timestamps.
\end{description}
\<close>

lemma (in network) broadcast_before_delivery:
  assumes "Deliver m \<in> set (history i)"
  shows "\<exists>j. Broadcast m \<sqsubset>\<^sup>j Deliver m"
  using assms deliver_locally delivery_has_a_cause by blast

lemma (in network) broadcasts_unique:
  assumes "i \<noteq> j"
    and "Broadcast m \<in> set (history i)"
  shows "Broadcast m \<notin> set (history j)"
  using assms msg_id_unique by blast

text\<open>Based on the well-known definition by \cite{Lamport:1978jq}, we say that
    $\isa{m1}\prec\isa{m2}$ if any of the following is true:
    \begin{enumerate}
      \item $\isa{m1}$ and $\isa{m2}$ were broadcast by the same node, and $\isa{m1}$ was broadcast before $\isa{m2}$.
      \item The node that broadcast $\isa{m2}$ had delivered $\isa{m1}$ before it broadcast $\isa{m2}$.
      \item There exists some operation $\isa{m3}$ such that $\isa{m1} \prec \isa{m3}$ and $\isa{m3} \prec \isa{m2}$.
    \end{enumerate}\<close>

inductive (in network) hb :: "'msg \<Rightarrow> 'msg \<Rightarrow> bool" where
  hb_broadcast: "\<lbrakk> Broadcast m1 \<sqsubset>\<^sup>i Broadcast m2 \<rbrakk> \<Longrightarrow> hb m1 m2" |
  hb_deliver:   "\<lbrakk> Deliver m1 \<sqsubset>\<^sup>i Broadcast m2 \<rbrakk> \<Longrightarrow> hb m1 m2" |
  hb_trans:     "\<lbrakk> hb m1 m2; hb m2 m3 \<rbrakk> \<Longrightarrow> hb m1 m3"

inductive_cases (in network) hb_elim: "hb x y"

definition (in network) weak_hb :: "'msg \<Rightarrow> 'msg \<Rightarrow> bool" where
  "weak_hb m1 m2 \<equiv> hb m1 m2 \<or> m1 = m2"

locale causal_network = network +
  assumes causal_delivery: "Deliver m2 \<in> set (history j) \<Longrightarrow> hb m1 m2 \<Longrightarrow> Deliver m1 \<sqsubset>\<^sup>j Deliver m2"

lemma (in causal_network) causal_broadcast:
  assumes "Deliver m2 \<in> set (history j)"
      and "Deliver m1 \<sqsubset>\<^sup>i Broadcast m2"
    shows "Deliver m1 \<sqsubset>\<^sup>j Deliver m2"
  using assms causal_delivery hb.intros(2) by blast

lemma (in network) hb_broadcast_exists1:
  assumes "hb m1 m2"
  shows "\<exists>i. Broadcast m1 \<in> set (history i)"
  using assms
  apply(induction rule: hb.induct)
    apply(meson insert_subset node_histories.local_order_carrier_closed node_histories_axioms)
   apply(meson delivery_has_a_cause insert_subset local_order_carrier_closed)
  apply simp
  done

lemma (in network) hb_broadcast_exists2:
  assumes "hb m1 m2"
  shows "\<exists>i. Broadcast m2 \<in> set (history i)"
  using assms
  apply(induction rule: hb.induct)
    apply(meson insert_subset node_histories.local_order_carrier_closed node_histories_axioms)
   apply(meson delivery_has_a_cause insert_subset local_order_carrier_closed)
  apply simp
  done

subsection\<open>Causal networks\<close>

lemma (in causal_network) hb_has_a_reason:
  assumes "hb m1 m2"
    and "Broadcast m2 \<in> set (history i)"
  shows "Deliver m1 \<in> set (history i) \<or> Broadcast m1 \<in> set (history i)"
  using assms apply (induction rule: hb.induct)
    apply(metis insert_subset local_order_carrier_closed network.broadcasts_unique network_axioms)
   apply(metis insert_subset local_order_carrier_closed network.broadcasts_unique network_axioms)
  using hb_trans causal_delivery local_order_carrier_closed apply blast
  done

lemma (in causal_network) hb_cross_node_delivery:
  assumes "hb m1 m2"
    and "Broadcast m1 \<in> set (history i)"
    and "Broadcast m2 \<in> set (history j)"
    and "i \<noteq> j"
  shows "Deliver m1 \<in> set (history j)"
  using assms
  apply(induction rule: hb.induct)
    apply(metis broadcasts_unique insert_subset local_order_carrier_closed)
   apply(metis insert_subset local_order_carrier_closed network.broadcasts_unique network_axioms)
  using broadcasts_unique hb.intros(3) hb_has_a_reason apply blast
  done

lemma (in causal_network) hb_irrefl:
  assumes "hb m1 m2"
  shows "m1 \<noteq> m2"
using assms proof(induction rule: hb.induct)
  case (hb_broadcast m1 i m2) thus ?case
    using node_total_order_antisym by blast
next
  case (hb_deliver m1 i m2) thus ?case
    by(meson causal_broadcast insert_subset local_order_carrier_closed node_total_order_irrefl)
next
  case (hb_trans m1 m2 m3)
  then obtain i j where "Broadcast m3 \<in> set (history i)" "Broadcast m2 \<in> set (history j)"
    using hb_broadcast_exists2 by blast
  then show ?case
    using assms hb_trans by (meson causal_network.causal_delivery causal_network_axioms
        deliver_locally insert_subset network.hb.intros(3) network_axioms
        node_histories.local_order_carrier_closed assms hb_trans
        node_histories_axioms node_total_order_irrefl)
qed

lemma (in causal_network) hb_broadcast_broadcast_order:
  assumes "hb m1 m2"
    and "Broadcast m1 \<in> set (history i)"
    and "Broadcast m2 \<in> set (history i)"
  shows "Broadcast m1 \<sqsubset>\<^sup>i Broadcast m2"
using assms proof(induction rule: hb.induct)
  case (hb_broadcast m1 i m2) thus ?case
    by(metis insertI1 local_order_carrier_closed network.broadcasts_unique network_axioms subsetCE)
next
  case (hb_deliver m1 i m2) thus ?case
    by(metis broadcasts_unique insert_subset local_order_carrier_closed
          network.broadcast_before_delivery network_axioms node_total_order_trans)
next
  case (hb_trans m1 m2 m3)
  then show ?case
  proof (cases "Broadcast m2 \<in> set (history i)")
    case True thus ?thesis
      using hb_trans node_total_order_trans by blast
  next
    case False hence "Deliver m2 \<in> set (history i)" "m1 \<noteq> m2" "m2 \<noteq> m3"
      using hb_has_a_reason hb_trans by auto
    thus ?thesis
      by(metis hb_trans event.inject(1) hb.intros(1) hb_irrefl network.hb.intros(3) network_axioms node_order_is_total hb_irrefl)
  qed
qed

lemma (in causal_network) hb_antisym:
  assumes "hb x y"
      and "hb y x"
  shows   "False"
using assms proof(induction rule: hb.induct)
  fix m1 i m2
  assume "hb m2 m1" and "Broadcast m1 \<sqsubset>\<^sup>i Broadcast m2"
  thus False
    apply - proof(erule hb_elim)
    show "\<And>ia. Broadcast m1 \<sqsubset>\<^sup>i Broadcast m2 \<Longrightarrow> Broadcast m2 \<sqsubset>\<^sup>ia Broadcast m1 \<Longrightarrow> False"
      by(metis broadcasts_unique insert_subset local_order_carrier_closed node_total_order_irrefl node_total_order_trans)
  next
    show "\<And>ia. Broadcast m1 \<sqsubset>\<^sup>i Broadcast m2 \<Longrightarrow> Deliver m2 \<sqsubset>\<^sup>ia Broadcast m1 \<Longrightarrow> False"
      by(metis broadcast_before_delivery broadcasts_unique insert_subset local_order_carrier_closed node_total_order_irrefl node_total_order_trans)
  next
    show "\<And>m2a. Broadcast m1 \<sqsubset>\<^sup>i Broadcast m2 \<Longrightarrow> hb m2 m2a \<Longrightarrow> hb m2a m1 \<Longrightarrow> False"
      using assms(1) assms(2) hb.intros(3) hb_irrefl by blast
  qed
next
  fix m1 i m2
  assume "hb m2 m1"
     and "Deliver m1 \<sqsubset>\<^sup>i Broadcast m2"
  thus "False"
    apply - proof(erule hb_elim)
    show "\<And>ia. Deliver m1 \<sqsubset>\<^sup>i Broadcast m2 \<Longrightarrow> Broadcast m2 \<sqsubset>\<^sup>ia Broadcast m1 \<Longrightarrow> False"
      by (metis broadcast_before_delivery broadcasts_unique insert_subset local_order_carrier_closed node_total_order_irrefl node_total_order_trans)
  next
    show "\<And>ia. Deliver m1 \<sqsubset>\<^sup>i Broadcast m2 \<Longrightarrow> Deliver m2 \<sqsubset>\<^sup>ia Broadcast m1 \<Longrightarrow> False"
      by (meson causal_network.causal_delivery causal_network_axioms hb.intros(2) hb.intros(3) insert_subset local_order_carrier_closed node_total_order_irrefl)
  next
    show "\<And>m2a. Deliver m1 \<sqsubset>\<^sup>i Broadcast m2 \<Longrightarrow> hb m2 m2a \<Longrightarrow> hb m2a m1 \<Longrightarrow> False"
      by (meson causal_delivery hb.intros(2) insert_subset local_order_carrier_closed network.hb.intros(3) network_axioms node_total_order_irrefl)
  qed
next
  fix m1 m2 m3
  assume "hb m1 m2" "hb m2 m3" "hb m3 m1"
     and "(hb m2 m1 \<Longrightarrow> False)" "(hb m3 m2 \<Longrightarrow> False)"
  thus "False"
    using hb.intros(3) by blast
qed

definition (in network) node_deliver_messages :: "'msg event list \<Rightarrow> 'msg list" where
  "node_deliver_messages cs \<equiv> List.map_filter (\<lambda>e. case e of Deliver m \<Rightarrow> Some m | _ \<Rightarrow> None) cs"

lemma (in network) node_deliver_messages_empty [simp]:
  shows "node_deliver_messages [] = []"
  by(auto simp add: node_deliver_messages_def List.map_filter_simps)

lemma (in network) node_deliver_messages_Cons:
  shows "node_deliver_messages (x#xs) = (node_deliver_messages [x])@(node_deliver_messages xs)"
  by(auto simp add: node_deliver_messages_def map_filter_def)

lemma (in network) node_deliver_messages_append:
  shows "node_deliver_messages (xs@ys) = (node_deliver_messages xs)@(node_deliver_messages ys)"
  by(auto simp add: node_deliver_messages_def map_filter_def)

lemma (in network) node_deliver_messages_Broadcast [simp]:
  shows "node_deliver_messages [Broadcast m] = []"
  by(clarsimp simp: node_deliver_messages_def map_filter_def)

lemma (in network) node_deliver_messages_Deliver [simp]:
  shows "node_deliver_messages [Deliver m] = [m]"
  by(clarsimp simp: node_deliver_messages_def map_filter_def)

lemma (in network) prefix_msg_in_history:
  assumes "es prefix of i"
      and "m \<in> set (node_deliver_messages es)"
    shows "Deliver m \<in> set (history i)"
using assms prefix_to_carriers by(fastforce simp: node_deliver_messages_def map_filter_def split: event.split_asm)

lemma (in network) prefix_contains_msg:
  assumes "es prefix of i"
      and "m \<in> set (node_deliver_messages es)"
    shows "Deliver m \<in> set es"
  using assms by(auto simp: node_deliver_messages_def map_filter_def split: event.split_asm)

lemma (in network) node_deliver_messages_distinct:
  assumes "xs prefix of i"
  shows "distinct (node_deliver_messages xs)"
using assms proof(induction xs rule: rev_induct)
  case Nil thus ?case by simp
next
  case (snoc x xs)
  { fix y assume *: "y \<in> set (node_deliver_messages xs)" "y \<in> set (node_deliver_messages [x])"
    moreover have "distinct (xs @ [x])"
      using assms snoc prefix_distinct by blast
    ultimately have "False"
      using assms apply(case_tac x; clarsimp simp add: map_filter_def node_deliver_messages_def)
      using * prefix_contains_msg snoc.prems by blast
  } thus ?case
    using snoc by(fastforce simp add: node_deliver_messages_append node_deliver_messages_def map_filter_def)
qed

lemma (in network) drop_last_message:
  assumes "evts prefix of i"
  and "node_deliver_messages evts = msgs @ [last_msg]"
  shows "\<exists>pre. pre prefix of i \<and> node_deliver_messages pre = msgs"
proof -
  have "Deliver last_msg \<in> set evts"
    using assms network.prefix_contains_msg network_axioms by force
  then obtain idx where *: "idx < length evts" "evts ! idx = Deliver last_msg"
    by (meson set_elem_nth)
  then obtain pre suf where "evts = pre @ (evts ! idx) # suf"
    using id_take_nth_drop by blast
  hence **: "evts = pre @ (Deliver last_msg) # suf"
    using assms * by auto
  moreover hence "distinct (node_deliver_messages ([Deliver last_msg] @ suf))"
    by (metis assms(1) assms(2) distinct_singleton node_deliver_messages_Cons node_deliver_messages_Deliver
        node_deliver_messages_append node_deliver_messages_distinct not_Cons_self2 pre_suf_eq_distinct_list)
  ultimately have "node_deliver_messages ([Deliver last_msg] @ suf) = [last_msg] @ []"
    by (metis append_self_conv assms(1) assms(2) node_deliver_messages_Cons node_deliver_messages_Deliver
        node_deliver_messages_append node_deliver_messages_distinct not_Cons_self2 pre_suf_eq_distinct_list)
  thus ?thesis
    using assms * ** by (metis append1_eq_conv append_Cons append_Nil node_deliver_messages_append prefix_of_appendD)
qed

locale network_with_ops = causal_network history fst
  for history :: "nat \<Rightarrow> ('msgid \<times> 'op) event list" +
  fixes interp :: "'op \<Rightarrow> 'state \<rightharpoonup> 'state"
  and initial_state :: "'state"

context network_with_ops begin

definition interp_msg :: "'msgid \<times> 'op \<Rightarrow> 'state \<rightharpoonup> 'state" where
  "interp_msg msg state \<equiv> interp (snd msg) state"

sublocale hb: happens_before weak_hb hb interp_msg
proof
  fix x y :: "'msgid \<times> 'op"
  show "hb x y = (weak_hb x y \<and> \<not> weak_hb y x)"
    unfolding weak_hb_def using hb_antisym by blast
next
  fix x
  show "weak_hb x x"
    using weak_hb_def by blast
next
  fix x y z
  assume "weak_hb x y" "weak_hb y z"
  thus "weak_hb x z"
    using weak_hb_def by (metis network.hb.intros(3) network_axioms)
qed

end

definition (in network_with_ops) apply_operations :: "('msgid \<times> 'op) event list \<rightharpoonup> 'state" where
  "apply_operations es \<equiv> hb.apply_operations (node_deliver_messages es) initial_state"

definition (in network_with_ops) node_deliver_ops :: "('msgid \<times> 'op) event list \<Rightarrow> 'op list" where
  "node_deliver_ops cs \<equiv> map snd (node_deliver_messages cs)"

lemma (in network_with_ops) apply_operations_empty [simp]:
  shows "apply_operations [] = Some initial_state"
  by(auto simp add: apply_operations_def)

lemma (in network_with_ops) apply_operations_Broadcast [simp]:
  shows "apply_operations (xs @ [Broadcast m]) = apply_operations xs"
  by(auto simp add: apply_operations_def node_deliver_messages_def map_filter_def)

lemma (in network_with_ops) apply_operations_Deliver [simp]:
  shows "apply_operations (xs @ [Deliver m]) = (apply_operations xs \<bind> interp_msg m)"
  by(auto simp add: apply_operations_def node_deliver_messages_def map_filter_def kleisli_def)

lemma (in network_with_ops) hb_consistent_technical:
  assumes "\<And>m n. m < length cs \<Longrightarrow> n < m \<Longrightarrow> cs ! n \<sqsubset>\<^sup>i cs ! m"
  shows   "hb.hb_consistent (node_deliver_messages cs)"
using assms proof (induction cs rule: rev_induct)
  case Nil thus ?case
   by(simp add: node_deliver_messages_def hb.hb_consistent.intros(1) map_filter_simps(2))
next
  case (snoc x xs)
  hence *: "(\<And>m n. m < length xs \<Longrightarrow> n < m \<Longrightarrow> xs ! n \<sqsubset>\<^sup>i xs ! m)"
    by(-, erule_tac x=m in meta_allE, erule_tac x=n in meta_allE, clarsimp simp add: nth_append)
  then show ?case
  proof (cases x)
    case (Broadcast x1) thus ?thesis
      using snoc * by (simp add: node_deliver_messages_append)
  next
    case (Deliver x2) thus ?thesis
      using snoc * apply(clarsimp simp add: node_deliver_messages_def map_filter_def map_filter_append)
      apply (rename_tac m m1 m2)
      apply (case_tac m; clarsimp)
      apply(drule set_elem_nth, erule exE, erule conjE)
      apply(erule_tac x="length xs" in meta_allE)
      apply(clarsimp simp add: nth_append)
      by (metis causal_delivery insert_subset node_histories.local_order_carrier_closed
          node_histories_axioms node_total_order_antisym)
  qed
qed

corollary (in network_with_ops)
  shows "hb.hb_consistent (node_deliver_messages (history i))"
  by (metis hb_consistent_technical history_order_def less_one linorder_neqE_nat list_nth_split zero_order(3))

lemma (in network_with_ops) hb_consistent_prefix:
  assumes "xs prefix of i"
  shows "hb.hb_consistent (node_deliver_messages xs)"
using assms proof (clarsimp simp: prefix_of_node_history_def, rule_tac i=i in hb_consistent_technical)
  fix m n ys assume *: "xs @ ys = history i" "m < length xs" "n < m"
  consider (a) "xs = []" | (b) "\<exists>c. xs = [c]" | (c) "Suc 0 < length (xs)"
    by (metis Suc_pred length_Suc_conv length_greater_0_conv zero_less_diff)
  thus "xs ! n \<sqsubset>\<^sup>i xs ! m"
  proof (cases)
    case a thus ?thesis
      using * by clarsimp
  next
    case b thus ?thesis
      using assms * by clarsimp
  next
    case c thus ?thesis
      using assms * apply clarsimp
      apply(drule list_nth_split, assumption, clarsimp simp: c)
      apply (metis append.assoc append.simps(2) history_order_def)
      done
  qed
qed

locale network_with_constrained_ops = network_with_ops +
  fixes valid_msg :: "'c \<Rightarrow> ('a \<times> 'b) \<Rightarrow> bool"
  assumes broadcast_only_valid_msgs: "pre @ [Broadcast m] prefix of i \<Longrightarrow>
             \<exists>state. apply_operations pre = Some state \<and> valid_msg state m"

lemma (in network_with_constrained_ops) broadcast_is_valid:
  assumes "Broadcast m \<in> set (history i)"
  shows "\<exists>state. valid_msg state m"
  using assms broadcast_only_valid_msgs events_before_exist by blast

lemma (in network_with_constrained_ops) deliver_is_valid:
  assumes "Deliver m \<in> set (history i)"
  shows "\<exists>j pre state. pre @ [Broadcast m] prefix of j \<and> apply_operations pre = Some state \<and> valid_msg state m"
  using assms apply (clarsimp dest!: delivery_has_a_cause)
  using broadcast_only_valid_msgs events_before_exist apply blast
  done

lemma (in network_with_constrained_ops) deliver_in_prefix_is_valid:
  assumes "xs prefix of i"
      and "Deliver m \<in> set xs"
    shows "\<exists>state. valid_msg state m"
  by (meson assms network_with_constrained_ops.deliver_is_valid network_with_constrained_ops_axioms prefix_elem_to_carriers)

subsection\<open>Dummy network models\<close>

interpretation trivial_node_histories: node_histories "\<lambda>m. []"
  by standard auto

interpretation trivial_network: network "\<lambda>m. []" id
  by standard auto

interpretation trivial_causal_network: causal_network "\<lambda>m. []" id
  by standard auto

interpretation trivial_network_with_ops: network_with_ops "\<lambda>m. []" "(\<lambda>x y. Some y)" 0
  by standard auto

interpretation trivial_network_with_constrained_ops: network_with_constrained_ops "\<lambda>m. []" "(\<lambda>x y. Some y)" 0 "\<lambda>x y. True"
  by standard (simp add: trivial_node_histories.prefix_of_node_history_def)

end


section \<open>Locals Up Block\<close>

theory Locals_Up_Block
  imports Helping_Lemmas
begin

lemma locals_up_block:
  fixes Vup and Vstar and Vdown and V
    and c :: "nat \<Rightarrow> context" and n :: nat
  assumes [simp]: "finite Vup"
  defines "call \<equiv> block (map (\<lambda>i. locals (V i) (c i)) [0..<n])"
  defines "d \<equiv> (\<lambda>i. inits (Vstar i); locals (Vdown i) (c i))"
  defines "W \<equiv> rec_nat Vup (\<lambda>i W. W \<union> Vstar i - (fv (c i) - Vdown i))"
  assumes "\<And>i. i<n \<Longrightarrow> program (c i)"
  assumes "\<And>i. i<n \<Longrightarrow> finite (V i)"
  assumes "\<And>i. i<n \<Longrightarrow> Vstar i \<subseteq> Vup"
  assumes "\<And>i. i<n \<Longrightarrow> Vstar i \<supseteq> V i - Vdown i - W i"
  assumes "\<And>i. i<n \<Longrightarrow> Vdown i \<subseteq> V i"
  assumes "\<And>i. i<n \<Longrightarrow> V i \<subseteq> Vdown i \<union> Vup"
  assumes "fv call \<inter> Vup = {}"
  shows "call =d= locals Vup (block (map d [0..<n]))"
  using assms(2-) apply atomize
proof (induction n arbitrary: V Vdown c d Vstar W call)
  case 0
  then show ?case
    using locals_unused[of Vup Skip] locals.R_sym by auto
next
  case (Suc n)

  have [simp]: "i < Suc n \<longleftrightarrow> i \<le> n" for i
    by auto

  from Suc.prems
  have d_def: "d i = inits (Vstar i) ; locals (Vdown i) (c i)"
    and W0: "W 0 = Vup"
    and W_Suc: "W (Suc i) = W i \<union> Vstar i - (fv (c i) - Vdown i)"
    and finite_V[simp]: "i\<le>n \<Longrightarrow> finite (V i)"
    and finite_c[simp]: "i\<le>n \<Longrightarrow> program (c i)"
    and fv_call: "fv call \<inter> Vup = {}"
    and VVW: "i<Suc n \<Longrightarrow> V i - Vdown i - W i \<subseteq> Vstar i"
    for i
    by auto

  have finite_Vstar[simp]: "i\<le>n \<Longrightarrow> finite (Vstar i)"
    and finite_Vdown[simp]: "i\<le>n \<Longrightarrow> finite (Vdown i)" for i
     apply (meson Suc.prems(6) assms(1) infinite_super le_trans lessI not_less)
    by (meson Suc.prems(8) finite_V finite_subset le_imp_less_Suc)

  define V' Vdown' Vstar' W' and c' d' c'all d'all
    where "V' i = V (Suc i)"
      and "Vdown' i = Vdown (Suc i)"
      and "Vstar' i = Vstar (Suc i)"
      and "W' = rec_nat Vup (\<lambda>i W. W \<union> Vstar' i - (fv (c' i) - Vdown' i))"
      and "c' i = c (Suc i)"
      and "d' i = d (Suc i)"
      and "c'all = block (map (\<lambda>i. locals (V' i) (c' i)) [0..<n])"
      and "d'all = block (map d' [0..<n])"
    for i

  have [simp]: "i \<le> n \<Longrightarrow> program (d i)" for i
    unfolding d_def
    by (simp add: program.intros(10) program_initsI program_localsI)
  have [simp]: "i < n \<Longrightarrow> program (d' i)" for i
    unfolding d'_def by auto

  have [simp]: "program d'all"
    unfolding d'all_def apply (rule program_blockI)
    by auto
  have [simp]: "i\<le>Suc n \<Longrightarrow> finite (W i)" for i
    unfolding Suc apply (induction i) by auto

  have W'W: "W' i \<supseteq> W (Suc i)" for i
    apply (induction i)
    apply (simp add: Suc.prems W'_def W0 W_Suc sup.absorb1)
    using Vdown'_def Vstar'_def W'_def W_Suc c'_def by auto

  have VVdown': "V' i \<subseteq> Vdown' i \<union> Vup" if "i<n" for i
    by (simp add: Suc.prems Suc_leI V'_def Vdown'_def that)

  have VVW': "V' i - Vdown' i - W' i \<subseteq> Vstar' i" if "i<n" for i
    using that W'W VVW unfolding Vstar'_def V'_def Vdown'_def
    by (metis Diff_mono Suc_mono dual_order.trans subset_refl)

  have "call = locals (V 0) (c 0); c'all"
    unfolding Suc c'all_def
    apply (subst asm_rl[of "[0..<Suc n] = 0 # map Suc [0..<n]"])
     apply (simp add: map_Suc_upt upt_conv_Cons)
    by (simp add: o_def V'_def c'_def)
  with fv_call have fv_c'all: "fv c'all \<inter> Vup = {}"
    by auto

  note IH = Suc.IH[where V=V' and Vdown=Vdown' and Vstar=Vstar' and c=c' and d=d' and W=W' and call=c'all]

  have IH: "c'all =d=
   locals Vup (block (map d' [0..<n]))"
    apply (rule IH)
             apply (simp add: c'all_def)
            apply (simp add: Suc.prems Vstar'_def Vdown'_def d'_def c'_def)
           apply (simp add: W'_def)
          apply (simp add: Suc.prems c'_def)
         apply (simp add: Suc.prems V'_def)
        apply (simp add: Suc.prems Vstar'_def)
       apply (simp add: VVW')
      apply (simp add: Suc.prems V'_def Vdown'_def)
     apply (simp add: VVdown')
    by (simp add: fv_c'all)

  have "1 \<le> Suc n" by simp

  have "i \<le> n \<Longrightarrow> x \<notin> V i \<Longrightarrow> x \<in> fv (c i)
    \<Longrightarrow> x \<in> fv (c i) \<Longrightarrow> x \<in> fv call" for x i
    unfolding Suc apply auto by auto
  then have 1: "i \<le> n \<Longrightarrow> x \<notin> V i \<Longrightarrow> x \<in> fv (c i)
    \<Longrightarrow> x \<in> fv (c i) \<Longrightarrow> x \<notin> Vup" for x i
    using Suc by blast

  have *: "W i \<union>
    overwr (block (map d [i..<Suc n])) \<supseteq> Vup \<inter> fv (block (map d [i..<Suc n]))"
    if "i \<le> Suc n" for i
    using that
  proof (induction i rule:inc_induct)
    case base
    show ?case by simp
  next
    case (step i)
    define dSuc where "dSuc = block (map d [Suc i..<Suc n])"
    with step have [simp]: "i \<le> n" and
      IH: "Vup \<inter> fv dSuc \<subseteq> (W i \<union> Vstar i - (fv (c i) - Vdown i))
            \<union> overwr dSuc"
      by (auto simp: W_Suc)
    have "Vup \<inter> fv (d i; dSuc) \<subseteq> W i \<union> overwr (d i; dSuc)"
      apply (auto simp: d_def)
            apply (metis "1" Diff_iff VVW \<open>i \<le> n\<close> step.hyps(2) subsetD)
            apply (metis "1" Diff_iff VVW \<open>i \<le> n\<close> step.hyps(2) subsetD)
          apply (simp add: Suc.prems(4) program_covered step.hyps(2))
      using IH apply auto[1]
        apply (metis "1" Diff_iff VVW \<open>i \<le> n\<close> step.hyps(2) subsetD)
       apply (simp add: Suc.prems(4) program_covered step.hyps(2))
      using IH by auto
    then show ?case
      unfolding dSuc_def
      by (metis block.simps(2) list.simps(9) step.hyps(2) upt_conv_Cons)
  qed
  have all_inits_removed: "((Vup-W 1)\<inter>fv d'all)-overwr d'all = {}"
    unfolding d'all_def d'_def
    apply (insert *[OF \<open>1\<le>Suc n\<close>])
    apply (subst (asm) asm_rl[of "[1..<Suc n] = map Suc [0..<n]"],
           simp add: map_Suc_upt)
    apply (subst (asm) asm_rl[of "[1..<Suc n] = map Suc [0..<n]"],
           simp add: map_Suc_upt)
    by (auto simp add: o_def)
  have W1_fv_c0: "W 1 \<inter> fv (locals (Vdown 0) (c 0)) = {}"
    by (auto simp add: Suc)

  have "call
        =d=
        Seq (locals (V 0) (c 0)) (block (map (\<lambda>i. locals (V' i) (c' i)) [0..<n]))"
    unfolding Suc
    apply (subst asm_rl[of "[0..<Suc n] = 0 # (map Suc [0..<n])"])
     apply (simp add: map_Suc_upt upt_conv_Cons)
    by (simp add: o_def V'_def[symmetric] c'_def[symmetric])
  also have "\<dots> =d= locals (V 0) (c 0);
                    locals Vup d'all"
    unfolding d'all_def
    apply (rule denot_eq_seq_cong2)
    by (rule IH[unfolded c'all_def])
  also have "\<dots> =d= locals Vup (locals (V 0) (c 0));
                    locals Vup d'all"
    apply (rule denot_eq_seq_cong1)
    apply (rule locals_unused[THEN denot_eq'_sym])
    using 1 by auto
  also have "\<dots> =d= locals Vup (locals (Vdown 0) (c 0));
                    locals Vup d'all"
    apply (subgoal_tac "Vup \<union> Vdown 0 = Vup \<union> V 0")
    apply (smt \<open>program d'all\<close> assms(1) denot_eq_seq_cong1 finite_V finite_Vdown finite_c le0 locals.F_join locals.R_sym locals.R_trans program_localsI)
    using Suc by (smt Diff_partition Un_Diff_cancel W0 boolean_algebra_cancel.sup2 sup_commute zero_less_Suc)
  also have "\<dots> =d= locals Vup (locals (Vdown 0) (c 0);
                      inits Vup; d'all)"
    by (rule locals_seq_merge, auto)
  also have "\<dots> =d= locals Vup (locals (Vdown 0) (c 0);
                      (inits (W 1); inits (Vup-W 1)); d'all)"
    apply (intro denot_eq_cong_locals denot_eq_seq_cong2 denot_eq_seq_cong1)
    using inits_inits
    by (metis (no_types, lifting) Diff_Diff_Int Diff_cancel Diff_eq_empty_iff One_nat_def Suc.prems(6) Un_Diff_Int Un_Diff_cancel W0 W_Suc assms(1) finite_Un locals.R_sym zero_less_Suc)
  also have "\<dots> =d= locals Vup ((locals (Vdown 0) (c 0);
                      inits (W 1)); inits (Vup-W 1); d'all)"
    (* Associativity *)
    apply (intro denot_eq_cong_locals denot_eq_seq_cong2 denot_eq_seq_cong1)
    using denot_eq_seq_assoc locals.R_sym by blast
  also have "\<dots> =d= locals Vup (inits (W 1); locals (Vdown 0) (c 0);
                      inits (Vup-W 1); d'all)"
    apply (intro denot_eq_cong_locals denot_eq_seq_cong2 denot_eq_seq_cong1)
    apply (rule swap)
    using W1_fv_c0 by auto
  also have "\<dots> =d= locals Vup (inits (W 1); locals (Vdown 0) (c 0);
                      (inits ((Vup-W 1)\<inter>fv d'all); inits ((Vup-W 1)-fv d'all)); d'all)"
    apply (intro denot_eq_cong_locals denot_eq_seq_cong2 denot_eq_seq_cong1)
    by (metis Un_Diff_Int Un_commute assms(1) equivp_symp finite_Diff finite_Int inits_inits locals.equiv_R)
  also have "\<dots> =d= locals Vup (inits (W 1); locals (Vdown 0) (c 0);
                      inits ((Vup-W 1)\<inter>fv d'all); (inits ((Vup-W 1)-fv d'all); d'all))"
    (* Associativity *)
    by (meson denot_eq'_trans denot_eq_cong_locals denot_eq_seq_assoc denot_eq_seq_cong1 locals.R_sym)
  also have "\<dots> =d= locals Vup (inits (W 1); locals (Vdown 0) (c 0);
                      inits ((Vup-W 1)\<inter>fv d'all); d'all;
                      inits ((Vup-W 1)-fv d'all))"
    (* Swapping inits ((Vup-W 1)-fv d'all); d'all *)
    apply (intro denot_eq_cong_locals denot_eq_seq_cong2 denot_eq_seq_cong1
        denot_eq'_trans[OF denot_eq_seq_assoc]
        denot_eq'_trans[OF _ denot_eq_seq_assoc[THEN denot_eq'_sym]])
    apply (rule swap)
    by auto
  also have "\<dots> =d= locals Vup (inits (W 1); locals (Vdown 0) (c 0);
                      inits ((Vup-W 1)\<inter>fv d'all); d'all)"
    (* Removing "inits ((Vup-W 1)-fv d'all" at the end which only initializes
       local variables *)
    apply (rule locals_inits_end)
    by auto
  also have "\<dots> =d= locals Vup (inits (W 1); locals (Vdown 0) (c 0);
          (inits (((Vup-W 1)\<inter>fv d'all)-overwr d'all); inits (((Vup-W 1)\<inter>fv d'all)\<inter>overwr d'all)); d'all)"
    (* Splitting inits ((Vup-W 1)\<inter>fv d'all) *)
    by (smt Diff_Diff_Int Diff_empty all_inits_removed denot_eq_cong_locals denot_eq_seq_cong1 denot_eq_seq_cong2 finite.emptyI locals.F_empty locals_inits_beginning)
  also have "\<dots> =d= locals Vup (inits (W 1); locals (Vdown 0) (c 0);
          inits (((Vup-W 1)\<inter>fv d'all)-overwr d'all); (inits (((Vup-W 1)\<inter>fv d'all)\<inter>overwr d'all); d'all))"
    (* Associativity *)
    using denot_eq'_sym denot_eq_cong_locals denot_eq_seq_assoc denot_eq_seq_cong1 locals.R_trans by blast
  also have "\<dots> =d= locals Vup (inits (W 1); locals (Vdown 0) (c 0);
                      inits (((Vup-W 1)\<inter>fv d'all)-overwr d'all); d'all)"
    apply (intro denot_eq_cong_locals denot_eq_seq_cong2 denot_eq_seq_cong1)
    apply (rule inits_overwr)
    by simp
  also have "\<dots> =d= locals Vup (inits (W 1); (locals (Vdown 0) (c 0);
                      d'all))"
    unfolding all_inits_removed
    apply simp
    by (metis denot_eq_cong_locals denot_eq_seq_assoc denot_eq_seq_cong1 equivp_def locals.equiv_R seq_c_skip)
  also have "\<dots> =d= locals Vup (inits (Vstar 0); (locals (Vdown 0) (c 0);
                      d'all))"
    (* Replacing inits (W 0) by inits (Vstar 0),
       possible because the difference is in Vup *)
    apply (rule locals_inits_change)
    apply auto[2]
    using Suc.prems W0 W_Suc by auto
  also have "\<dots> =d= locals Vup (d 0; d'all)"
    by (simp add: d_def denot_eq_cong_locals denot_eq_seq_assoc locals.R_sym)
  also have "\<dots> =d= locals Vup (block (map d [0..<Suc n]))"
    apply (subst asm_rl[of "[0..<Suc n] = 0 # (map Suc [0..<n])"])
     apply (simp add: map_Suc_upt upt_conv_Cons)
    unfolding d'all_def d'_def
    by (metis block.simps(2) locals.R_refl map_Suc_upt map_upt_Suc upt_conv_Cons zero_less_Suc)
  finally show ?case
    by -
qed

end


section \<open> Variables as Lenses \<close>

theory Variables
  imports "Optics.Optics" "HOL-Library.Adhoc_Overloading"
begin

subsection \<open> Constructors \<close>

bundle Expression_Syntax
begin

no_notation
  Set.member ("op :") and
  Set.member ("(_/ : _)" [51, 51] 50)

end

unbundle Expression_Syntax

declare fst_vwb_lens [simp] and snd_vwb_lens [simp]

text \<open> Variables can also be used to effectively define sets of variables. Here we define the
  the universal alphabet ($\Sigma$) to be the bijective lens @{term "1\<^sub>L"}. This characterises
  the whole of the source type, and thus is effectively the set of all alphabet variables. \<close>

definition univ_var :: "('\<alpha> \<Longrightarrow> '\<alpha>)" ("\<^bold>v") where
[lens_defs]: "univ_var = 1\<^sub>L"

lemma univ_var_vwb [simp]: "vwb_lens univ_var"
  by (simp add: univ_var_def)

definition univ_alpha :: "'s scene" where
[lens_defs]: "univ_alpha = \<top>\<^sub>S"

definition emp_alpha :: "'s scene" where
[lens_defs]: "emp_alpha = \<bottom>\<^sub>S"

definition var_alpha :: "('a \<Longrightarrow> 's) \<Rightarrow> 's scene" where
[lens_defs]: "var_alpha x = lens_scene x"

definition ns_alpha :: "('b \<Longrightarrow> 'c) \<Rightarrow> ('a \<Longrightarrow> 'b) \<Rightarrow> 'a \<Longrightarrow> 'c" where
[lens_defs]: "ns_alpha a x = x ;\<^sub>L a"

definition var_fst :: "('a \<times> 'b \<Longrightarrow> 's) \<Rightarrow> ('a \<Longrightarrow> 's)" where
[lens_defs]: "var_fst x = fst\<^sub>L ;\<^sub>L x"

definition var_snd :: "('a \<times> 'b \<Longrightarrow> 's) \<Rightarrow> ('b \<Longrightarrow> 's)" where
[lens_defs]: "var_snd x = snd\<^sub>L ;\<^sub>L x"

abbreviation var_member :: "('a \<Longrightarrow> 's) \<Rightarrow> 's scene \<Rightarrow> bool" (infix "\<in>\<^sub>v" 50) where
"x \<in>\<^sub>v A \<equiv> var_alpha x \<le> A"

lemma ns_alpha_weak [simp]: "\<lbrakk> weak_lens a; weak_lens x \<rbrakk> \<Longrightarrow> weak_lens (ns_alpha a x)"
  by (simp add: ns_alpha_def comp_weak_lens)

lemma ns_alpha_mwb [simp]: "\<lbrakk> mwb_lens a; mwb_lens x \<rbrakk> \<Longrightarrow> mwb_lens (ns_alpha a x)"
  by (simp add: ns_alpha_def comp_mwb_lens)

lemma ns_alpha_vwb [simp]: "\<lbrakk> vwb_lens a; vwb_lens x \<rbrakk> \<Longrightarrow> vwb_lens (ns_alpha a x)"
  by (simp add: ns_alpha_def comp_vwb_lens)

lemma ns_alpha_indep_1 [simp]: "a \<bowtie> b \<Longrightarrow> ns_alpha a x \<bowtie> ns_alpha b y"
  by (simp add: lens_indep_left_ext lens_indep_right_ext ns_alpha_def)

lemma ns_alpha_indep_2 [simp]: "a \<bowtie> y \<Longrightarrow> ns_alpha a x \<bowtie> y"
  by (simp add: lens_indep_left_ext ns_alpha_def)

lemma ns_alpha_indep_3 [simp]: "x \<bowtie> b \<Longrightarrow> x \<bowtie> ns_alpha b y"
  by (simp add: lens_indep_sym)

lemma ns_alpha_indep_4 [simp]: "\<lbrakk> mwb_lens a; x \<bowtie> y \<rbrakk> \<Longrightarrow> ns_alpha a x \<bowtie> ns_alpha a y"
  by (simp add: ns_alpha_def)

lemma var_fst_mwb [simp]: "mwb_lens x \<Longrightarrow> mwb_lens (var_fst x)"
  by (simp add: var_fst_def comp_mwb_lens)

lemma var_snd_mwb [simp]: "mwb_lens x \<Longrightarrow> mwb_lens (var_snd x)"
  by (simp add: var_snd_def comp_mwb_lens)

lemma var_fst_vwb [simp]: "vwb_lens x \<Longrightarrow> vwb_lens (var_fst x)"
  by (simp add: var_fst_def comp_vwb_lens)

lemma var_snd_vwb [simp]: "vwb_lens x \<Longrightarrow> vwb_lens (var_snd x)"
  by (simp add: var_snd_def comp_vwb_lens)

lemma var_fst_indep_1 [simp]: "x \<bowtie> y \<Longrightarrow> var_fst x \<bowtie> y"
  by (simp add: var_fst_def lens_indep_left_ext)

lemma var_fst_indep_2 [simp]: "x \<bowtie> y \<Longrightarrow> x \<bowtie> var_fst y"
  by (simp add: var_fst_def lens_indep_right_ext)

lemma var_snd_indep_1 [simp]: "x \<bowtie> y \<Longrightarrow> var_snd x \<bowtie> y"
  by (simp add: var_snd_def lens_indep_left_ext)

lemma var_snd_indep_2 [simp]: "x \<bowtie> y \<Longrightarrow> x \<bowtie> var_snd y"
  by (simp add: var_snd_def lens_indep_right_ext)

definition res_alpha :: "('a \<Longrightarrow> 'b) \<Rightarrow> ('c \<Longrightarrow> 'b) \<Rightarrow> 'a \<Longrightarrow> 'c" where
[lens_defs]: "res_alpha x a = x /\<^sub>L a"

lemma idem_scene_var [simp]:
  "vwb_lens x \<Longrightarrow> idem_scene (var_alpha x)"
  by (simp add: lens_defs)

lemma var_alpha_combine: "\<lbrakk> vwb_lens x; vwb_lens y; x \<bowtie> y \<rbrakk> \<Longrightarrow> var_alpha x \<squnion>\<^sub>S var_alpha y = var_alpha (x +\<^sub>L y)"
  by (simp add: lens_plus_scene var_alpha_def)

lemma var_alpha_indep [simp]:
  assumes "vwb_lens x" "vwb_lens y"
  shows "var_alpha x \<bowtie>\<^sub>S var_alpha y \<longleftrightarrow> x \<bowtie> y"
  by (simp add: assms(1) assms(2) lens_indep_scene var_alpha_def)

lemma pre_var_indep_prod [simp]: "x \<bowtie> a \<Longrightarrow> ns_alpha fst\<^sub>L x \<bowtie> a \<times>\<^sub>L b"
  using lens_indep.lens_put_irr2
  by (unfold_locales, force simp add: lens_defs prod.case_eq_if lens_indep_comm)+

lemma post_var_indep_prod [simp]: "x \<bowtie> b \<Longrightarrow> ns_alpha snd\<^sub>L x \<bowtie> a \<times>\<^sub>L b"
  using lens_indep.lens_put_irr2
  by (unfold_locales, force simp add: lens_defs prod.case_eq_if lens_indep_comm)+

lemma lens_indep_impl_scene_indep_var [simp]:
  "(X \<bowtie> Y) \<Longrightarrow> var_alpha X \<bowtie>\<^sub>S var_alpha Y"
  by (simp add: var_alpha_def)

declare lens_scene_override [simp]
declare uminus_scene_twice [simp]

lemma var_alpha_override [simp]:
  "mwb_lens X \<Longrightarrow> s\<^sub>1 \<oplus>\<^sub>S s\<^sub>2 on var_alpha X = s\<^sub>1 \<oplus>\<^sub>L s\<^sub>2 on X"
  by (simp add: var_alpha_def)

(* Some extra Scene laws; should be moved to Optics at some point *)

lemma var_alpha_indep_compl [simp]:
  assumes "vwb_lens x" "vwb_lens y"
  shows "var_alpha x \<bowtie>\<^sub>S - var_alpha y \<longleftrightarrow> x \<subseteq>\<^sub>L y"
  by (simp add: assms scene_le_iff_indep_inv sublens_iff_subscene var_alpha_def)

lemma var_alpha_subset [simp]:
  assumes "vwb_lens x" "vwb_lens y"
  shows "var_alpha x \<le> var_alpha y \<longleftrightarrow> x \<subseteq>\<^sub>L y"
  by (simp add: assms(1) assms(2) sublens_iff_subscene var_alpha_def)

subsection \<open> Converting scenes to frames \<close>

lemma var_alpha_empty [frame]: "\<bottom>\<^sub>S = \<lbrakk>\<lbrace>\<rbrace>\<^sub>F\<rbrakk>\<^sub>F"
  by (simp add: bot_frame.rep_eq)

lemma var_alpha_top [frame]: "\<top>\<^sub>S = \<lbrakk>\<top>\<^sub>F\<rbrakk>\<^sub>F"
  by (simp add: top_frame.rep_eq)

lemma var_alpha_insert_frame [simp]:
  "var_lens x \<Longrightarrow> var_alpha x \<squnion>\<^sub>S \<lbrakk>A\<rbrakk>\<^sub>F = \<lbrakk>lens_insert x A\<rbrakk>\<^sub>F"
  by (simp add: lens_scene_insert_frame var_alpha_def)

lemma var_alpha_uminus [simp]: "- \<lbrakk>A\<rbrakk>\<^sub>F = \<lbrakk>- A\<rbrakk>\<^sub>F"
  by (simp add: uminus_frame.rep_eq)

lemma var_alpha_minus [simp]: "\<lbrakk>A\<rbrakk>\<^sub>F - \<lbrakk>B\<rbrakk>\<^sub>F = \<lbrakk>A - B\<rbrakk>\<^sub>F"
  by (simp add: minus_frame.rep_eq minus_scene_def)

lemma var_alpha_union [simp]: "\<lbrakk>A\<rbrakk>\<^sub>F \<squnion>\<^sub>S \<lbrakk>B\<rbrakk>\<^sub>F = \<lbrakk>A \<union>\<^sub>F B\<rbrakk>\<^sub>F"
  by (simp add: sup_frame.rep_eq)

lemma var_alpha_inter [simp]: "\<lbrakk>A\<rbrakk>\<^sub>F \<sqinter>\<^sub>S \<lbrakk>B\<rbrakk>\<^sub>F = \<lbrakk>A \<inter>\<^sub>F B\<rbrakk>\<^sub>F"
  by (simp add: inf_frame.rep_eq)

lemma var_member_iff [simp]: "var_lens x \<Longrightarrow> x \<in>\<^sub>v \<lbrakk>A\<rbrakk>\<^sub>F \<longleftrightarrow> x \<in>\<^sub>F A"
  by (simp add: lens_frame.rep_eq lens_member_def less_eq_frame.rep_eq var_alpha_def)

lemma var_indep_iff [simp]: "ebasis_lens x \<Longrightarrow> var_alpha x \<bowtie>\<^sub>S \<lbrakk>A\<rbrakk>\<^sub>F \<longleftrightarrow> x \<notin>\<^sub>F A"
  by (simp add: basis_lens_not_member_indep var_alpha_def)

text \<open> We can transparently move from frames to scenes using the following coercion\<close>

declare [[coercion of_frame]]

subsection \<open> Syntax Translations \<close>

text \<open> In order to support nice syntax for variables, we here set up some translations. The first
  step is to introduce a collection of non-terminals. \<close>

nonterminal svid and svids and salpha and sframe_enum and sframe

text \<open> These non-terminals correspond to the following syntactic entities. Non-terminal
  @{typ "svid"} is an atomic variable identifier, and @{typ "svids"} is a list of identifier.
  @{typ "salpha"} is an alphabet or set of variables. @{typ "sframe"} is a frame. Such sets can
  be constructed only through lens composition due to typing restrictions. Next we introduce some
  syntax constructors. \<close>

syntax \<comment> \<open> Identifiers \<close>
  "_svid"         :: "id_position \<Rightarrow> svid" ("_" [999] 999)
  "_svlongid"     :: "longid_position \<Rightarrow> svid" ("_" [999] 999)
  ""              :: "svid \<Rightarrow> svids" ("_")
  "_svid_list"    :: "svid \<Rightarrow> svids \<Rightarrow> svids" ("_,/ _")
  "_svid_alpha"   :: "svid" ("\<^bold>v")
  "_svid_index"   :: "id_position \<Rightarrow> logic \<Rightarrow> svid" ("_'(_')" [999] 999)
  "_svid_tuple"   :: "svids \<Rightarrow> svid" ("'(_')")
  "_svid_dot"     :: "svid \<Rightarrow> svid \<Rightarrow> svid" ("_:_" [999,998] 998)
  "_svid_res"     :: "svid \<Rightarrow> svid \<Rightarrow> svid" ("_\<restriction>_" [999,998] 998)
  "_svid_pre"     :: "svid \<Rightarrow> svid" ("_\<^sup><" [997] 997)
  "_svid_post"    :: "svid \<Rightarrow> svid" ("_\<^sup>>" [997] 997)
  "_svid_fst"     :: "svid \<Rightarrow> svid" ("_.1" [997] 997)
  "_svid_snd"     :: "svid \<Rightarrow> svid" ("_.2" [997] 997)
  "_mk_svid_list" :: "svids \<Rightarrow> logic" \<comment> \<open> Helper function for summing a list of identifiers \<close>
  "_of_svid_list"   :: "logic \<Rightarrow> svids" \<comment> \<open> Reverse of the above \<close>
  "_svid_view"    :: "logic \<Rightarrow> svid" ("\<V>[_]") \<comment> \<open> View of a symmetric lens \<close>
  "_svid_coview"  :: "logic \<Rightarrow> svid" ("\<C>[_]") \<comment> \<open> Coview of a symmetric lens \<close>
  "_svid_prod"    :: "svid \<Rightarrow> svid \<Rightarrow> svid" (infixr "\<times>" 85)
  "_svid_pow2"    :: "svid \<Rightarrow> svid" ("_\<^sup>2" [999] 999)

text \<open> A variable can be decorated with an ampersand, to indicate it is a predicate variable, with
  a dollar to indicate its an unprimed relational variable, or a dollar and ``acute'' symbol to
  indicate its a primed relational variable. Isabelle's parser is extensible so additional
  decorations can be and are added later. \<close>

term "(-)"

syntax \<comment> \<open> Variable sets \<close>
  "_salphaid"    :: "id_position \<Rightarrow> salpha" ("_" [990] 990)
  "_salphavar"   :: "svid \<Rightarrow> salpha" ("$_" [990] 990)
  "_salphaparen" :: "salpha \<Rightarrow> salpha" ("'(_')")
  "_salphaunion" :: "salpha \<Rightarrow> salpha \<Rightarrow> salpha" (infixr "\<union>" 75)
  "_salphainter" :: "salpha \<Rightarrow> salpha \<Rightarrow> salpha" (infixr "\<inter>" 75)
  "_salphaminus" :: "salpha \<Rightarrow> salpha \<Rightarrow> salpha" (infixl "-" 65)
  "_salphacompl" :: "salpha \<Rightarrow> salpha" ("- _" [81] 80)
  "_salpha_all"  :: "salpha" ("\<Sigma>")
  "_salpha_none" :: "salpha" ("\<emptyset>")
(*  "_salpha_pre"  :: "salpha \<Rightarrow> salpha" ("_\<^sup><" [989] 989)
  "_salpha_post" :: "salpha \<Rightarrow> salpha" ("_\<^sup>>" [989] 989) *)
  "_salphaset"   :: "svids \<Rightarrow> salpha" ("{_}")
  "_sframeid"    :: "id \<Rightarrow> sframe" ("_")
  "_sframeset"   :: "svids \<Rightarrow> sframe_enum" ("\<lbrace>_\<rbrace>")
  "_sframeunion" :: "sframe \<Rightarrow> sframe \<Rightarrow> sframe" (infixr "\<union>" 75)
  "_sframeinter" :: "sframe \<Rightarrow> sframe \<Rightarrow> sframe" (infixr "\<inter>" 75)
  "_sframeminus" :: "sframe \<Rightarrow> sframe \<Rightarrow> sframe" (infixl "-" 65)
  "_sframecompl" :: "sframe \<Rightarrow> sframe" ("- _" [81] 80)
  "_sframe_all"  :: "sframe" ("\<Sigma>")
  "_sframe_none" :: "sframe" ("\<emptyset>")
  "_sframe_pre"  :: "sframe \<Rightarrow> sframe" ("_\<^sup><" [989] 989)
  "_sframe_post" :: "sframe \<Rightarrow> sframe" ("_\<^sup>>" [989] 989)
  "_sframe_enum" :: "sframe_enum \<Rightarrow> sframe" ("_")
  "_sframe_alpha" :: "sframe_enum \<Rightarrow> salpha" ("_")
  "_salphamk"    :: "logic \<Rightarrow> salpha"
  "_mk_alpha_list" :: "svids \<Rightarrow> logic"
  "_mk_frame_list" :: "svids \<Rightarrow> logic"

text \<open> The terminals of an alphabet are either HOL identifiers or UTP variable identifiers.
  We support two ways of constructing alphabets; by composition of smaller alphabets using
  a semi-colon or by a set-style construction $\{a,b,c\}$ with a list of UTP variables. \<close>

syntax \<comment> \<open> Quotations \<close>
  "_svid_set"    :: "svids \<Rightarrow> logic" ("{_}\<^sub>v")
  "_svid_empty"  :: "logic" ("{}\<^sub>v")
  "_svar"        :: "svid \<Rightarrow> logic" ("'(_')\<^sub>v")

text \<open> For various reasons, the syntax constructors above all yield specific grammar categories and
  will not parser at the HOL top level (basically this is to do with us wanting to reuse the syntax
  for expressions). As a result we provide some quotation constructors above.

  Next we need to construct the syntax translations rules. Finally, we set up the translations rules. \<close>

translations
  \<comment> \<open> Identifiers \<close>
  "_svid x" \<rightharpoonup> "x"
  "_svlongid x" \<rightharpoonup> "x"
  "_svid_alpha" \<rightleftharpoons> "CONST univ_var"
  "_svid_tuple xs" \<rightharpoonup> "_mk_svid_list xs"
  "_svid_dot x y" \<rightleftharpoons> "CONST ns_alpha x y"
  "_svid_index x i" \<rightharpoonup> "x i"
  "_svid_res x y" \<rightleftharpoons> "x /\<^sub>L y"
  "_svid_pre x" \<rightleftharpoons> "_svid_dot fst\<^sub>L x"
  "_svid_post x" \<rightleftharpoons> "_svid_dot snd\<^sub>L x"
  "_svid_fst x" \<rightleftharpoons> "CONST var_fst x"
  "_svid_snd x" \<rightleftharpoons> "CONST var_snd x"
  "_svid_prod x y" \<rightleftharpoons> "x \<times>\<^sub>L y"
  "_svid_pow2 x" \<rightharpoonup> "x \<times>\<^sub>L x"
  "_mk_svid_list (_svid_list x xs)" \<rightharpoonup> "x +\<^sub>L _mk_svid_list xs"
  "_mk_svid_list x" \<rightharpoonup> "x"
  "_mk_alpha_list (_svid_list x xs)" \<rightharpoonup> "CONST var_alpha x \<squnion>\<^sub>S _mk_alpha_list xs"
  "_mk_alpha_list x" \<rightharpoonup> "CONST var_alpha x"

  "_mk_frame_list (_svid_list x xs)" \<rightharpoonup> "CONST lens_insert x (_mk_frame_list xs)"
  "_mk_frame_list x" \<rightharpoonup> "CONST lens_insert x \<lbrace>\<rbrace>\<^sub>F"

  "_svid_view a" => "\<V>\<^bsub>a\<^esub>"
  "_svid_coview a" => "\<C>\<^bsub>a\<^esub>"

  "_svid_list (_svid_tuple (_of_svid_list (x +\<^sub>L y))) (_of_svid_list z)" \<leftharpoondown> "_of_svid_list ((x +\<^sub>L y) +\<^sub>L z)"
  "_svid_list x (_of_svid_list y)"    \<leftharpoondown> "_of_svid_list (x +\<^sub>L y)"
  "x"                                 \<leftharpoondown> "_of_svid_list x"

  \<comment> \<open> Alphabets \<close>
  "_salphaparen a" \<rightharpoonup> "a"
  "_salphaid x" \<rightharpoonup> "x"
  "_salphaunion x y" \<rightharpoonup> "x \<squnion>\<^sub>S y"
  "_salphainter x y" \<rightharpoonup> "x \<sqinter>\<^sub>S y"
  "_salphaminus x y" \<rightharpoonup> "x - y"
  "_salphacompl x"  \<rightharpoonup> "- x"
(*  "_salpha_pre A" \<rightharpoonup> "A ;\<^sub>S fst\<^sub>L"
  "_salpha_post A" \<rightharpoonup> "A ;\<^sub>S snd\<^sub>L" *)
(*  "_salphaprod a b" \<rightleftharpoons> "a \<times>\<^sub>L b" *)
  "_salphavar x" \<rightleftharpoons> "CONST var_alpha x"
  "_salphaset A" \<rightharpoonup> "_mk_alpha_list A"
  "_sframeid A" \<rightharpoonup> "A"
  "_sframeunion x y" \<rightharpoonup> "x \<union>\<^sub>F y"
  "_sframeinter x y" \<rightharpoonup> "x \<inter>\<^sub>F y"
  "_sframeminus x y" \<rightharpoonup> "x - y"
  "_sframecompl x"  \<rightharpoonup> "- x"
  "_sframe_all" \<rightharpoonup> "\<top>\<^sub>F"
  "_sframe_none" \<rightharpoonup> "\<lbrace>\<rbrace>\<^sub>F"
  "_sframe_pre A" \<rightharpoonup> "A ;\<^sub>F fst\<^sub>L"
  "_sframe_post A" \<rightharpoonup> "A ;\<^sub>F snd\<^sub>L"
  "_sframe_enum A" \<rightharpoonup> "A"
  "_sframe_alpha A" \<rightharpoonup> "CONST of_frame A"
  "_sframeset A" \<rightharpoonup> "_mk_frame_list A"
  "(_svid_list x (_salphamk y))" \<leftharpoondown> "_salphamk (x +\<^sub>L y)"
  "x" \<leftharpoondown> "_salphamk x"
  "_salpha_all" \<rightleftharpoons> "CONST univ_alpha"
  "_salpha_none" \<rightleftharpoons> "CONST emp_alpha"

  \<comment> \<open> Quotations \<close>
  "_svid_set A" \<rightharpoonup> "_mk_alpha_list A"
  "_svid_empty" \<rightharpoonup> "0\<^sub>L"
  "_svar x" \<rightharpoonup> "x"

text \<open> The translation rules mainly convert syntax into lens constructions, using a mixture
  of lens operators and the bespoke variable definitions. Notably, a colon variable identifier
  qualification becomes a lens composition, and variable sets are constructed using len sum.
  The translation rules are carefully crafted to ensure both parsing and pretty printing.

  Finally we create the following useful utility translation function that allows us to construct a
  UTP variable (lens) type given a return and alphabet type. \<close>

syntax
  "_uvar_ty"      :: "type \<Rightarrow> type \<Rightarrow> type"

parse_translation \<open>
let
  fun uvar_ty_tr [ty] = Syntax.const @{type_syntax lens} $ ty $ Syntax.const @{type_syntax dummy}
    | uvar_ty_tr ts = raise TERM ("uvar_ty_tr", ts);
in [(@{syntax_const "_uvar_ty"}, K uvar_ty_tr)] end
\<close>

subsection \<open> Simplifications \<close>

lemma get_pre [simp]: "get\<^bsub>(x\<^sup><)\<^sub>v\<^esub> (s\<^sub>1, s\<^sub>2) = get\<^bsub>x\<^esub> s\<^sub>1"
  by (simp add: lens_defs)

lemma get_post [simp]: "get\<^bsub>(x\<^sup>>)\<^sub>v\<^esub> (s\<^sub>1, s\<^sub>2) = get\<^bsub>x\<^esub> s\<^sub>2"
  by (simp add: lens_defs)

lemma get_prod_decomp: "get\<^bsub>x\<^esub> s = (get\<^bsub>var_fst x\<^esub> s, get\<^bsub>var_snd x\<^esub> s)"
  by (simp add: lens_defs)

end


(*
 * Copyright 2014, NICTA
 *
 * 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_BSD2.txt" for details.
 *
 * @TAG(NICTA_BSD)
 *)

chapter "List Manipulation Functions"

theory List_Lib
imports Main
begin

definition list_replace :: "'a list \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a list" where
  "list_replace list a b \<equiv> map (\<lambda>x. if x = a then b else x) list"

primrec list_replace_list :: "'a list \<Rightarrow> 'a \<Rightarrow> 'a list \<Rightarrow> 'a list" where
  "list_replace_list [] a list' = []" |
  "list_replace_list (x # xs) a list' = (if x = a then list' @ xs
                           else x # list_replace_list xs a list')"

definition list_swap :: "'a list \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a list" where
  "list_swap list a b \<equiv> map (\<lambda>x. if x = a then b else if x = b then a else x) list"

primrec list_insert_after :: "'a list \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a list" where
  "list_insert_after [] a b = []" |
  "list_insert_after (x # xs) a b = (if x = a then x # b # xs
                                     else x # list_insert_after xs a b)"

primrec list_remove :: "'a list \<Rightarrow> 'a \<Rightarrow> 'a list" where
  "list_remove [] a = []" |
  "list_remove (x # xs) a = (if x = a then (list_remove xs a)
                             else x # (list_remove xs a))"

fun after_in_list :: "'a list \<Rightarrow> 'a \<Rightarrow> 'a option" where
  "after_in_list [] a = None" |
  "after_in_list [x] a = None" |
  "after_in_list (x # y # xs) a = (if a = x then Some y else after_in_list (y # xs) a)"

lemma zip_take1:
  "zip (take n xs) ys = take n (zip xs ys)"
  apply (induct xs arbitrary: n ys)
  apply simp_all
  apply (case_tac n, simp_all)
  apply (case_tac ys, simp_all)
  done

lemma zip_take2:
  "zip xs (take n ys) = take n (zip xs ys)"
  apply (induct xs arbitrary: n ys)
  apply simp_all
  apply (case_tac n, simp_all)
  apply (case_tac ys, simp_all)
  done

lemmas zip_take = zip_take1 zip_take2

lemma replicate_append: "replicate n x @ (x # xs) = replicate (n + 1) x @ xs"
  by (induct n, simp+)

end