theory Inductive_Predicate
imports Setup
begin

(*<*)
hide_const %invisible append

inductive %invisible append where
  "append [] ys ys"
| "append xs ys zs \<Longrightarrow> append (x # xs) ys (x # zs)"

lemma %invisible append: "append xs ys zs = (xs @ ys = zs)"
  by (induct xs arbitrary: ys zs) (auto elim: append.cases intro: append.intros)

lemmas lexordp_def =
  lexordp_def [unfolded lexord_def mem_Collect_eq split]
(*>*)

section \<open>Inductive Predicates \label{sec:inductive}\<close>

text \<open>
  The \<open>predicate compiler\<close> is an extension of the code generator
  which turns inductive specifications into equational ones, from
  which in turn executable code can be generated.  The mechanisms of
  this compiler are described in detail in
  \<^cite>\<open>"Berghofer-Bulwahn-Haftmann:2009:TPHOL"\<close>.

  Consider the simple predicate \<^const>\<open>append\<close> given by these two
  introduction rules:
\<close>

text %quote \<open>
  @{thm append.intros(1)[of ys]} \\
  @{thm append.intros(2)[of xs ys zs x]}
\<close>

text \<open>
  \noindent To invoke the compiler, simply use @{command_def "code_pred"}:
\<close>

code_pred %quote append .

text \<open>
  \noindent The @{command "code_pred"} command takes the name of the
  inductive predicate and then you put a period to discharge a trivial
  correctness proof.  The compiler infers possible modes for the
  predicate and produces the derived code equations.  Modes annotate
  which (parts of the) arguments are to be taken as input, and which
  output. Modes are similar to types, but use the notation \<open>i\<close>
  for input and \<open>o\<close> for output.

  For \<^term>\<open>append\<close>, the compiler can infer the following modes:
  \begin{itemize}
    \item \<open>i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> bool\<close>
    \item \<open>i \<Rightarrow> i \<Rightarrow> o \<Rightarrow> bool\<close>
    \item \<open>o \<Rightarrow> o \<Rightarrow> i \<Rightarrow> bool\<close>
  \end{itemize}
  You can compute sets of predicates using @{command_def "values"}:
\<close>

values %quote "{zs. append [(1::nat),2,3] [4,5] zs}"

text \<open>\noindent outputs \<open>{[1, 2, 3, 4, 5]}\<close>, and\<close>

values %quote "{(xs, ys). append xs ys [(2::nat),3]}"

text \<open>\noindent outputs \<open>{([], [2, 3]), ([2], [3]), ([2, 3], [])}\<close>.\<close>

text \<open>
  \noindent If you are only interested in the first elements of the
  set comprehension (with respect to a depth-first search on the
  introduction rules), you can pass an argument to @{command "values"}
  to specify the number of elements you want:
\<close>

values %quote 1 "{(xs, ys). append xs ys [(1::nat), 2, 3, 4]}"
values %quote 3 "{(xs, ys). append xs ys [(1::nat), 2, 3, 4]}"

text \<open>
  \noindent The @{command "values"} command can only compute set
  comprehensions for which a mode has been inferred.

  The code equations for a predicate are made available as theorems with
  the suffix \<open>equation\<close>, and can be inspected with:
\<close>

thm %quote append.equation

text \<open>
  \noindent More advanced options are described in the following subsections.
\<close>

subsection \<open>Alternative names for functions\<close>

text \<open>
  By default, the functions generated from a predicate are named after
  the predicate with the mode mangled into the name (e.g., \<open>append_i_i_o\<close>).  You can specify your own names as follows:
\<close>

code_pred %quote (modes: i \<Rightarrow> i \<Rightarrow> o \<Rightarrow> bool as concat,
  o \<Rightarrow> o \<Rightarrow> i \<Rightarrow> bool as split,
  i \<Rightarrow> o \<Rightarrow> i \<Rightarrow> bool as suffix) append .

subsection \<open>Alternative introduction rules\<close>

text \<open>
  Sometimes the introduction rules of an predicate are not executable
  because they contain non-executable constants or specific modes
  could not be inferred.  It is also possible that the introduction
  rules yield a function that loops forever due to the execution in a
  depth-first search manner.  Therefore, you can declare alternative
  introduction rules for predicates with the attribute @{attribute
  "code_pred_intro"}.  For example, the transitive closure is defined
  by:
\<close>

text %quote \<open>
  @{lemma [source] "r a b \<Longrightarrow> tranclp r a b" by (fact tranclp.intros(1))}\\
  @{lemma [source] "tranclp r a b \<Longrightarrow> r b c \<Longrightarrow> tranclp r a c" by (fact tranclp.intros(2))}
\<close>

text \<open>
  \noindent These rules do not suit well for executing the transitive
  closure with the mode \<open>(i \<Rightarrow> o \<Rightarrow> bool) \<Rightarrow> i \<Rightarrow> o \<Rightarrow> bool\<close>, as
  the second rule will cause an infinite loop in the recursive call.
  This can be avoided using the following alternative rules which are
  declared to the predicate compiler by the attribute @{attribute
  "code_pred_intro"}:
\<close>

lemma %quote [code_pred_intro]:
  "r a b \<Longrightarrow> tranclp r a b"
  "r a b \<Longrightarrow> tranclp r b c \<Longrightarrow> tranclp r a c"
by auto

text \<open>
  \noindent After declaring all alternative rules for the transitive
  closure, you invoke @{command "code_pred"} as usual.  As you have
  declared alternative rules for the predicate, you are urged to prove
  that these introduction rules are complete, i.e., that you can
  derive an elimination rule for the alternative rules:
\<close>

code_pred %quote tranclp
proof -
  case tranclp
  from this converse_tranclpE [OF tranclp.prems] show thesis by metis
qed

text \<open>
  \noindent Alternative rules can also be used for constants that have
  not been defined inductively. For example, the lexicographic order
  which is defined as:
\<close>

text %quote \<open>
  @{thm [display] lexordp_def [of r]}
\<close>

text \<open>
  \noindent To make it executable, you can derive the following two
  rules and prove the elimination rule:
\<close>

lemma %quote [code_pred_intro]:
  "append xs (a # v) ys \<Longrightarrow> lexordp r xs ys"
(*<*)unfolding lexordp_def by (auto simp add: append)(*>*)

lemma %quote [code_pred_intro]:
  "append u (a # v) xs \<Longrightarrow> append u (b # w) ys \<Longrightarrow> r a b
  \<Longrightarrow> lexordp r xs ys"
(*<*)unfolding lexordp_def append apply simp
apply (rule disjI2) by auto(*>*)

code_pred %quote lexordp
(*<*)proof -
  fix r xs ys
  assume lexord: "lexordp r xs ys"
  assume 1: "\<And>r' xs' ys' a v. r = r' \<Longrightarrow> xs = xs' \<Longrightarrow> ys = ys'
    \<Longrightarrow> append xs' (a # v) ys' \<Longrightarrow> thesis"
  assume 2: "\<And>r' xs' ys' u a v b w. r = r' \<Longrightarrow> xs = xs' \<Longrightarrow> ys = ys'
    \<Longrightarrow> append u (a # v) xs' \<Longrightarrow> append u (b # w) ys' \<Longrightarrow> r' a b \<Longrightarrow> thesis"
  {
    assume "\<exists>a v. ys = xs @ a # v"
    from this 1 have thesis
        by (fastforce simp add: append)
  } moreover
  {
    assume "\<exists>u a b v w. r a b \<and> xs = u @ a # v \<and> ys = u @ b # w"
    from this 2 have thesis by (fastforce simp add: append)
  } moreover
  note lexord
  ultimately show thesis
    unfolding lexordp_def
    by fastforce
qed(*>*)

subsection \<open>Options for values\<close>

text \<open>
  In the presence of higher-order predicates, multiple modes for some
  predicate could be inferred that are not disambiguated by the
  pattern of the set comprehension.  To disambiguate the modes for the
  arguments of a predicate, you can state the modes explicitly in the
  @{command "values"} command.  Consider the simple predicate \<^term>\<open>succ\<close>:
\<close>

inductive %quote succ :: "nat \<Rightarrow> nat \<Rightarrow> bool" where
  "succ 0 (Suc 0)"
| "succ x y \<Longrightarrow> succ (Suc x) (Suc y)"

code_pred %quote succ .

text \<open>
  \noindent For this, the predicate compiler can infer modes \<open>o
  \<Rightarrow> o \<Rightarrow> bool\<close>, \<open>i \<Rightarrow> o \<Rightarrow> bool\<close>, \<open>o \<Rightarrow> i \<Rightarrow> bool\<close> and
  \<open>i \<Rightarrow> i \<Rightarrow> bool\<close>.  The invocation of @{command "values"}
  \<open>{n. tranclp succ 10 n}\<close> loops, as multiple modes for the
  predicate \<open>succ\<close> are possible and here the first mode \<open>o \<Rightarrow> o \<Rightarrow> bool\<close> is chosen. To choose another mode for the argument,
  you can declare the mode for the argument between the @{command
  "values"} and the number of elements.
\<close>

values %quote [mode: i \<Rightarrow> o \<Rightarrow> bool] 1 "{n. tranclp succ 10 n}" (*FIXME does not terminate for n\<ge>1*)
values %quote [mode: o \<Rightarrow> i \<Rightarrow> bool] 1 "{n. tranclp succ n 10}"

subsection \<open>Embedding into functional code within Isabelle/HOL\<close>

text \<open>
  To embed the computation of an inductive predicate into functions
  that are defined in Isabelle/HOL, you have a number of options:

  \begin{itemize}

  \item You want to use the first-order predicate with the mode
    where all arguments are input. Then you can use the predicate directly, e.g.

    @{text [display]
\<open>valid_suffix ys zs =
  (if append [Suc 0, 2] ys zs then Some ys else None)\<close>}

  \item If you know that the execution returns only one value (it is
    deterministic), then you can use the combinator \<^term>\<open>Predicate.the\<close>, e.g., a functional concatenation of lists is
    defined with

    @{term [display] "functional_concat xs ys = Predicate.the (append_i_i_o xs ys)"}

    Note that if the evaluation does not return a unique value, it
    raises a run-time error \<^term>\<open>not_unique\<close>.

  \end{itemize}
\<close>

subsection \<open>Further Examples\<close>

text \<open>
  Further examples for compiling inductive predicates can be found in
  \<^file>\<open>~~/src/HOL/Predicate_Compile_Examples/Examples.thy\<close>.  There are
  also some examples in the Archive of Formal Proofs, notably in the
  \<open>POPLmark-deBruijn\<close> and the \<open>FeatherweightJava\<close>
  sessions.
\<close>

end


(*
   Title: The pi-calculus
   Author/Maintainer: Jesper Bengtson (jebe.dk), 2012
*)
theory Late_Hennessy
  imports Weak_Late_Bisim Weak_Late_Cong
begin

lemma sim1:
  fixes P   :: pi
  and   Q   :: pi
  and   Rel :: "(pi \<times> pi) set"

  assumes PSimQ: "P \<leadsto>\<^sup>^<Rel> Q"

  shows "\<tau>.(P) \<leadsto><Rel> Q"
proof(induct rule: simCases)
  case(Bound Q' a x)
  have "Q \<longmapsto>a<\<nu>x> \<prec> Q'" by fact
  moreover have xFreshP: "x \<sharp> P"
  proof -
    have "x \<sharp> \<tau>.(P)" by fact
    thus ?thesis by simp
  qed
  ultimately obtain P' where PTrans: "P \<Longrightarrow>\<^sub>l\<^sup>^a<\<nu>x> \<prec> P'" and P'RelQ': "(P', Q') \<in> Rel" using PSimQ
    by(blast dest: Weak_Late_Sim.simE)
  from PTrans have "\<tau>.(P) \<Longrightarrow>\<^sub>la<\<nu>x> \<prec> P'"
  proof(induct rule: transitionCases)
    case Step
    have "P \<Longrightarrow>\<^sub>la<\<nu>x> \<prec> P'" by fact
    with xFreshP obtain P''' P'' where PChain: "P \<Longrightarrow>\<^sub>\<tau> P'''"
                                   and P'''Trans:  "P''' \<longmapsto>a<\<nu>x> \<prec> P''"
                                   and P''Chain: "P'' \<Longrightarrow>\<^sub>\<tau> P'"
      by(blast dest: transitionE)
    have "\<tau>.(P) \<Longrightarrow>\<^sub>\<tau> P'''"
    proof -
      have "\<tau>.(P) \<longmapsto>\<tau> \<prec> P" by(rule Late_Semantics.Tau)
      thus ?thesis using PChain by auto
    qed
    thus ?case using P'''Trans P''Chain by(blast intro: Weak_Late_Step_Semantics.transitionI)
  next
    case Stay
    have "a<\<nu>x> \<prec> P' = \<tau> \<prec> P" by fact
    hence False by(simp add: residual.inject)
    thus ?case by simp
  qed
  with P'RelQ' show ?case by blast
next
  case(Input Q' a x)
  have "Q \<longmapsto>a<x> \<prec> Q'" by fact
  moreover have xFreshP: "x \<sharp> P"
  proof -
    have "x \<sharp> \<tau>.(P)" by fact
    thus ?thesis by simp
  qed
  ultimately obtain P'' where L1: "\<forall>u. \<exists>P'. P \<Longrightarrow>\<^sub>lu in P''\<rightarrow>a<x> \<prec> P' \<and> (P', Q'[x::=u]) \<in> Rel" using PSimQ
    by(blast dest: Weak_Late_Sim.simE)
  have "\<And>u. \<exists>P'. \<tau>.(P) \<Longrightarrow>\<^sub>lu in P''\<rightarrow>a<x> \<prec> P' \<and> (P', Q'[x::=u]) \<in> Rel"
  proof -
    fix u
    from L1 obtain P' where PTrans: "P \<Longrightarrow>\<^sub>lu in P''\<rightarrow>a<x> \<prec> P'" and P'RelQ': "(P', Q'[x::=u]) \<in> Rel" by blast
    from PTrans xFreshP obtain P''' where PChain: "P \<Longrightarrow>\<^sub>\<tau> P'''"
                                     and P'''Trans:  "P''' \<longmapsto>a<x> \<prec> P''"
                                     and P''Chain: "P''[x::=u] \<Longrightarrow>\<^sub>\<tau> P'"
      by(blast dest: transitionE)
    have "\<tau>.(P) \<Longrightarrow>\<^sub>\<tau> P'''"
    proof -
      have "\<tau>.(P) \<longmapsto>\<tau> \<prec> P" by(rule Late_Semantics.Tau)
      thus ?thesis using PChain by auto
    qed
    hence "\<tau>.(P) \<Longrightarrow>\<^sub>lu in P''\<rightarrow>a<x> \<prec> P'" using P'''Trans P''Chain by(blast intro: Weak_Late_Step_Semantics.transitionI)
    with P'RelQ' show "\<exists>P'. \<tau>.(P) \<Longrightarrow>\<^sub>lu in P''\<rightarrow>a<x> \<prec> P' \<and> (P', Q'[x::=u]) \<in> Rel" by blast
  qed
  thus ?case by blast
next
  case(Free Q' \<alpha>)
  have Trans: "Q \<longmapsto>\<alpha> \<prec> Q'" by fact
  then obtain P' where PTrans: "P \<Longrightarrow>\<^sub>l\<^sup>^\<alpha> \<prec> P'" and P'RelQ': "(P', Q') \<in> Rel" using PSimQ
    by(blast dest: Weak_Late_Sim.simE)
  from PTrans have "\<tau>.(P) \<Longrightarrow>\<^sub>l\<alpha> \<prec> P'"
  proof(induct rule: transitionCases)
    case Step
    have "P \<Longrightarrow>\<^sub>l\<alpha> \<prec> P'" by fact
    then obtain P''' P'' where PChain: "P \<Longrightarrow>\<^sub>\<tau> P'''"
                           and P'''Trans:  "P''' \<longmapsto>\<alpha> \<prec> P''"
                           and P''Chain: "P'' \<Longrightarrow>\<^sub>\<tau> P'"
      by(blast dest: transitionE)
    have "\<tau>.(P) \<Longrightarrow>\<^sub>\<tau> P'''"
    proof -
      have "\<tau>.(P) \<longmapsto>\<tau> \<prec> P" by(rule Late_Semantics.Tau)
      thus ?thesis using PChain by auto
    qed
    thus ?case using P'''Trans P''Chain by(blast intro: Weak_Late_Step_Semantics.transitionI)
  next
    case Stay
    have "\<alpha> \<prec> P' = \<tau> \<prec> P" by fact
    hence "\<alpha> = \<tau>" and "P = P'" by(simp add: residual.inject)+
    moreover have "\<tau>.(P) \<Longrightarrow>\<^sub>l\<tau> \<prec> P"
    proof -
      have "\<tau>.(P) \<Longrightarrow>\<^sub>\<tau>\<tau>.(P)" by simp
      moreover have "\<tau>.(P) \<longmapsto>\<tau> \<prec> P" by(rule Late_Semantics.Tau)
      moreover have "P \<Longrightarrow>\<^sub>\<tau> P" by simp
      ultimately show ?thesis by(blast intro: Weak_Late_Step_Semantics.transitionI)
    qed
    ultimately show ?case by force
  qed
  with P'RelQ' show ?case by blast
qed

lemma sim2:
  fixes P  :: pi
  and   Q  :: pi
  and   P' :: pi

  assumes PSimQ: "P \<leadsto>\<^sup>^<Rel> Q"
  and     PTrans: "P \<longmapsto>\<tau> \<prec> P'"
  and     P'RelQ: "(P', Q) \<in> Rel"

  shows "P \<leadsto><Rel> \<tau>.(Q)"
proof(induct rule: simCases)
  case(Bound Q' a x)
  have "\<tau>.(Q) \<longmapsto>a<\<nu>x> \<prec> Q'" by fact
  hence False by(force intro: tauCases)
  thus ?case by simp
next
  case(Input Q' a x)
  have "\<tau>.(Q) \<longmapsto> a<x> \<prec> Q'" by fact
  hence False by(force intro: tauCases)
  thus ?case by simp
next
  case(Free Q' \<alpha>)

  have "\<tau>.(Q) \<longmapsto>\<alpha> \<prec> Q'" by fact
  hence "\<alpha> = \<tau>" and "Q = Q'" by(drule_tac tauCases, auto simp add: pi.inject residual.inject)+
  moreover from PTrans have "P \<Longrightarrow>\<^sub>l\<tau> \<prec> P'" by(rule Weak_Late_Step_Semantics.singleActionChain)
  ultimately show ?case using P'RelQ by blast
qed

lemma sim3:
  fixes P   :: pi
  and   Q   :: pi
  and   Rel :: "(pi \<times> pi) set"

  assumes PSimQ: "P \<leadsto>\<^sup>^<Rel> Q"
  and     L1: "\<And>Q'. Q \<longmapsto>\<tau> \<prec> Q' \<Longrightarrow> (P, Q') \<notin> Rel"

  shows "P \<leadsto><Rel> Q"
proof(induct rule: simCases)
  case(Bound Q' a x)
  have "Q \<longmapsto>a<\<nu>x> \<prec> Q'" and "x \<sharp> P" by fact+
  with PSimQ obtain P' where "P \<Longrightarrow>\<^sub>l\<^sup>^a<\<nu>x> \<prec> P'" and "(P', Q') \<in> Rel" by(blast dest: Weak_Late_Sim.simE)
  thus ?case by(auto simp add: weakTransition_def)
next
  case(Input Q' a x)
  have "Q \<longmapsto>a<x> \<prec> Q'" and "x \<sharp> P" by fact+
  with PSimQ show ?case by(auto dest: Weak_Late_Sim.simE)
next
  case(Free Q' \<alpha>)
  have QTrans: "Q \<longmapsto>\<alpha> \<prec> Q'" by fact
  with PSimQ obtain P' where PTrans: "P \<Longrightarrow>\<^sub>l\<^sup>^\<alpha> \<prec> P'" and P'RelQ': "(P', Q') \<in> Rel"
    by(blast dest: Weak_Late_Sim.simE)
  from PTrans show ?case
  proof(induct rule: transitionCases)
    case Step
    have "P \<Longrightarrow>\<^sub>l\<alpha> \<prec> P'" by fact
    with P'RelQ' show ?case by blast
  next
    case Stay
    have "\<alpha> \<prec> P' = \<tau> \<prec> P" by fact
    hence \<alpha>eq\<tau>: "\<alpha> = \<tau>" and PeqP': "P = P'" by(simp add: residual.inject)+
    from P'RelQ' PeqP' have "(P, Q') \<in> Rel" by blast
    moreover from QTrans \<alpha>eq\<tau> have "(P, Q') \<notin> Rel" by(blast dest: L1)
    ultimately have False by  simp
    thus ?case by simp
  qed
qed

lemma hennessyLeft:
  fixes P :: pi
  and   Q :: pi

  assumes PBisimQ: "P \<approx> Q"

  shows "\<tau>.(P) \<simeq> Q \<or> P \<simeq> Q \<or> P \<simeq> \<tau>.(Q)"
proof(case_tac "\<exists>P'. P \<longmapsto>\<tau> \<prec> P' \<and> P' \<approx> Q")
  assume "\<exists>P'. P \<longmapsto> \<tau> \<prec> P' \<and> P' \<approx> Q"
  then obtain P' where PTrans: "P \<longmapsto>\<tau> \<prec> P'" and P'BisimP: "P' \<approx> Q" by blast

  have "P \<leadsto><weakBisim> \<tau>.(Q)"
  proof -
    from PBisimQ have "P \<leadsto>\<^sup>^<weakBisim> Q" by(blast dest: Weak_Late_Bisim.unfoldE)
    thus ?thesis using PTrans P'BisimP by(rule sim2)
  qed
  moreover have "\<tau>.(Q) \<leadsto><weakBisim> P"
  proof -
    from PBisimQ have "Q \<leadsto>\<^sup>^<weakBisim> P" by(blast dest: Weak_Late_Bisim.unfoldE)
    thus ?thesis by(rule sim1)
  qed
  ultimately have "P \<simeq> \<tau>.(Q)" by(simp add: congruence_def)
  thus ?thesis by simp
next
  assume "\<not>(\<exists>P'. P \<longmapsto>\<tau> \<prec> P' \<and> P' \<approx> Q)"
  hence L1: "\<And>P'. P\<longmapsto>\<tau> \<prec> P' \<Longrightarrow> \<not>(Q \<approx> P')" by(auto intro: Weak_Late_Bisim.symmetric)
  show ?thesis
  proof(case_tac "\<exists>Q'. Q \<longmapsto>\<tau> \<prec> Q' \<and> Q' \<approx> P")
    assume "\<exists>Q'. Q \<longmapsto>\<tau> \<prec> Q' \<and> Q' \<approx> P"
    then obtain Q' where QTrans: "Q \<longmapsto>\<tau> \<prec> Q'" and Q'BisimP: "Q' \<approx> P" by blast
    have "\<tau>.(P) \<leadsto><weakBisim> Q"
    proof -
      from PBisimQ have "P \<leadsto>\<^sup>^<weakBisim> Q" by(blast dest: Weak_Late_Bisim.unfoldE)
      thus ?thesis by(rule sim1)
    qed
    moreover have "Q \<leadsto><weakBisim> \<tau>.(P)"
    proof -
      from PBisimQ have "Q \<leadsto>\<^sup>^<weakBisim> P" by(blast dest: Weak_Late_Bisim.unfoldE)
      thus ?thesis using QTrans Q'BisimP by(rule sim2)
    qed
    ultimately have "\<tau>.(P) \<simeq> Q" by(simp add: congruence_def)
    thus ?thesis by simp
  next
    assume "\<not>(\<exists>Q'. Q \<longmapsto>\<tau> \<prec> Q' \<and> Q' \<approx> P)"
    hence L2: "\<And>Q'. Q\<longmapsto>\<tau> \<prec> Q' \<Longrightarrow> \<not>(P \<approx> Q')" by(auto intro: Weak_Late_Bisim.symmetric)

    have "P \<leadsto><weakBisim> Q"
    proof -
      from PBisimQ have "P \<leadsto>\<^sup>^<weakBisim> Q" by(blast dest: Weak_Late_Bisim.unfoldE)
      thus ?thesis using L2 by(rule sim3)
    qed
    moreover have "Q \<leadsto><weakBisim> P"
    proof -
      from PBisimQ have "Q \<leadsto>\<^sup>^<weakBisim> P" by(blast dest: Weak_Late_Bisim.unfoldE)
      thus ?thesis using L1 by(rule sim3)
    qed
    ultimately have "P \<simeq> Q" by(simp add: congruence_def)
    thus ?thesis by simp
  qed
qed

lemma boundOutputRemoveTau:
  fixes P  :: pi
  and   a  :: name
  and   x  :: name
  and   P' :: pi

  assumes "\<tau>.(P) \<Longrightarrow>\<^sub>la<\<nu>x> \<prec> P'"
  and     "x \<sharp> P"

  shows "P \<Longrightarrow>\<^sub>la<\<nu>x> \<prec> P'"
proof -
  from assms obtain P''' P'''' where PChain:"\<tau>.(P) \<Longrightarrow>\<^sub>\<tau> P'''"
                                 and P'''Trans: "P''' \<longmapsto>a<\<nu>x> \<prec> P''''"
                                 and P''''Chain: "P'''' \<Longrightarrow>\<^sub>\<tau> P'"
    by(force dest: Weak_Late_Step_Semantics.transitionE)
  show ?thesis
  proof(case_tac "P''' = \<tau>.(P)")
    assume "P''' = \<tau>.(P)"
    with P'''Trans have False by auto
    thus ?thesis by simp
  next
    assume "P''' \<noteq> \<tau>.(P)"
    with PChain obtain P'' where PTrans: "\<tau>.(P) \<longmapsto>\<tau> \<prec> P''" and P''Chain: "P'' \<Longrightarrow>\<^sub>\<tau> P'''"
      by (auto elim: converse_rtranclE)
    from PTrans have "P = P''"
      by(force elim: tauCases simp add: pi.inject residual.inject)
    with P''Chain P'''Trans P''''Chain show ?thesis
      by(blast intro: Weak_Late_Step_Semantics.transitionI)
  qed
qed

lemma inputRemoveTau:
  fixes P     :: pi
  and   u     :: name
  and   P'''' :: pi
  and   a     :: name
  and   x     :: name
  and   P'    :: pi

  assumes "\<tau>.(P) \<Longrightarrow>\<^sub>lu in P'''' \<rightarrow> a<x> \<prec> P'"

  shows "P \<Longrightarrow>\<^sub>lu in P'''' \<rightarrow> a<x> \<prec> P'"
proof -
  from assms obtain P''' where PChain:"\<tau>.(P) \<Longrightarrow>\<^sub>\<tau> P'''"
                            and P'''Trans: "P''' \<longmapsto>a<x> \<prec> P''''"
                            and P''''Chain: "P''''[x::=u] \<Longrightarrow>\<^sub>\<tau> P'"
    by(force dest: Weak_Late_Step_Semantics.transitionE)
  show ?thesis
  proof(case_tac "P''' = \<tau>.(P)")
    assume "P''' = \<tau>.(P)"
    with P'''Trans have False by auto
    thus ?thesis by simp
  next
    assume "P''' \<noteq> \<tau>.(P)"
    with PChain obtain P'' where PTrans: "\<tau>.(P) \<longmapsto>\<tau> \<prec> P''" and P''Chain: "P'' \<Longrightarrow>\<^sub>\<tau> P'''"
      by (auto elim: converse_rtranclE)
    from PTrans have "P = P''"
      by(force elim: tauCases simp add: pi.inject residual.inject)
    with P''Chain P'''Trans P''''Chain show ?thesis
      by(blast intro: Weak_Late_Step_Semantics.transitionI)
  qed
qed

lemma outputRemoveTau:
  fixes P  :: pi
  and   a  :: name
  and   b  :: name
  and   P' :: pi

  assumes "\<tau>.(P) \<Longrightarrow>\<^sub>la[b] \<prec> P'"

  shows "P \<Longrightarrow>\<^sub>la[b] \<prec> P'"
proof -
  from assms obtain P''' P'''' where PChain:"\<tau>.(P) \<Longrightarrow>\<^sub>\<tau> P'''"
                                 and P'''Trans: "P''' \<longmapsto>a[b] \<prec> P''''"
                                 and P''''Chain: "P'''' \<Longrightarrow>\<^sub>\<tau> P'"
    by(force dest: Weak_Late_Step_Semantics.transitionE)
  show ?thesis
  proof(case_tac "P''' = \<tau>.(P)")
    assume "P''' = \<tau>.(P)"
    with P'''Trans have False by auto
    thus ?thesis by simp
  next
    assume "P''' \<noteq> \<tau>.(P)"
    with PChain obtain P'' where PTrans: "\<tau>.(P) \<longmapsto>\<tau> \<prec> P''" and P''Chain: "P'' \<Longrightarrow>\<^sub>\<tau> P'''"
      by (auto elim: converse_rtranclE)
    from PTrans have "P = P''"
      by(force elim: tauCases simp add: pi.inject residual.inject)
    with P''Chain P'''Trans P''''Chain show ?thesis
      by(blast intro: Weak_Late_Step_Semantics.transitionI)
  qed
qed

lemma tauRemoveTau:
  fixes P  :: pi
  and   P' :: pi

  assumes PTrans: "\<tau>.(P) \<Longrightarrow>\<^sub>l\<tau> \<prec> P'"
  and     PineqP': "P \<noteq> P'"

  shows "P \<Longrightarrow>\<^sub>l\<tau> \<prec> P'"
proof -
  from PTrans obtain P''' P'''' where PChain:"\<tau>.(P) \<Longrightarrow>\<^sub>\<tau> P'''"
                                  and P'''Trans: "P''' \<longmapsto>\<tau> \<prec> P''''"
                                  and P''''Chain: "P'''' \<Longrightarrow>\<^sub>\<tau> P'"
    by(force dest: Weak_Late_Step_Semantics.transitionE)
  show ?thesis
  proof(case_tac "P''' = \<tau>.(P)")
    assume "P''' = \<tau>.(P)"
    with P'''Trans have "P = P''''"
      by(force elim: tauCases simp add: pi.inject residual.inject)
    with P''''Chain PineqP' obtain P'' where PTrans: "P \<longmapsto>\<tau> \<prec> P''" and P''Chain: "P'' \<Longrightarrow>\<^sub>\<tau> P'"
      by (auto elim: converse_rtranclE)
    moreover have "P \<Longrightarrow>\<^sub>\<tau> P" by simp
    ultimately show ?thesis by(rule_tac Weak_Late_Step_Semantics.transitionI)
  next
    assume "P''' \<noteq> \<tau>.(P)"
    with PChain obtain P'' where PTrans: "\<tau>.(P) \<longmapsto>\<tau> \<prec> P''" and P''Chain: "P'' \<Longrightarrow>\<^sub>\<tau> P'''"
      by (auto elim: converse_rtranclE)
    from PTrans have "P = P''"
      by(force elim: tauCases simp add: pi.inject residual.inject)
    with P''Chain P'''Trans P''''Chain show ?thesis
      by(blast intro: Weak_Late_Step_Semantics.transitionI)
  qed
qed

lemma sim4:
  fixes P :: pi
  and   Q :: pi
  and   Rel :: "(pi \<times> pi) set"

  assumes PSimQ: "\<tau>.(P) \<leadsto><Rel> Q"

  shows "P \<leadsto>\<^sup>^<Rel> Q"
proof(induct rule: Weak_Late_Sim.simCases)
  case(Bound Q' a x)
  have QTrans: "Q \<longmapsto>a<\<nu>x> \<prec> Q'" and xFreshP: "x \<sharp> P" by fact+

  with PSimQ obtain P' where PTrans: "\<tau>.(P) \<Longrightarrow>\<^sub>la<\<nu>x> \<prec> P'"
                         and P'RelQ': "(P', Q') \<in> Rel" by(auto dest: simE)
  from PTrans xFreshP have "P \<Longrightarrow>\<^sub>la<\<nu>x> \<prec> P'"
    by(blast intro: boundOutputRemoveTau)
  hence "P \<Longrightarrow>\<^sub>l\<^sup>^a<\<nu>x> \<prec> P'" by(simp add: weakTransition_def)
  with P'RelQ' show ?case by blast
next
  case(Input Q' a x)
  have QTrans: "Q \<longmapsto>a<x> \<prec> Q'" and xFreshP: "x \<sharp> P" by fact+
  with PSimQ obtain P'' where PSim: "\<forall>u. \<exists>P'. \<tau>.(P) \<Longrightarrow>\<^sub>lu in P'' \<rightarrow> a<x> \<prec> P' \<and> (P', Q'[x::=u]) \<in> Rel"
    by(auto dest: simE)
  have "\<forall>u. \<exists>P'. P \<Longrightarrow>\<^sub>lu in P''\<rightarrow>a<x> \<prec> P' \<and> (P', Q'[x::=u]) \<in> Rel"
  proof(rule allI)
    fix u
    from PSim obtain P' where PTrans: "\<tau>.(P) \<Longrightarrow>\<^sub>lu in P'' \<rightarrow> a<x> \<prec> P'" and P'RelQ': "(P', Q'[x::=u]) \<in> Rel"
      by blast
    with PTrans have "P \<Longrightarrow>\<^sub>lu in P'' \<rightarrow> a<x> \<prec> P'" by(blast intro: inputRemoveTau)
    with P'RelQ' show "\<exists>P'. P \<Longrightarrow>\<^sub>lu in P'' \<rightarrow> a<x> \<prec> P' \<and> (P', Q'[x::=u]) \<in> Rel"  by blast
  qed
  thus ?case by blast
next
  case(Free Q' \<alpha>)
  with PSimQ obtain P' where PTrans: "\<tau>.(P) \<Longrightarrow>\<^sub>l\<alpha> \<prec> P'"
                         and P'RelQ': "(P', Q') \<in> Rel" by(auto dest: simE)
  from PTrans show ?case
  proof(cases \<alpha>, auto)
    fix a b
    assume "\<tau>.(P) \<Longrightarrow>\<^sub>l(a::name)[b] \<prec> P'"
    hence "P \<Longrightarrow>\<^sub>la[b] \<prec> P'" by(rule outputRemoveTau)
    hence "P \<Longrightarrow>\<^sub>l\<^sup>^a[b] \<prec> P'" by(simp add: weakTransition_def)
    with P'RelQ' show "\<exists>P'. P \<Longrightarrow>\<^sub>l\<^sup>^a[b] \<prec> P' \<and> (P', Q') \<in> Rel" by blast
  next
    assume PTrans: "\<tau>.(P) \<Longrightarrow>\<^sub>l\<tau> \<prec> P'"
    thus "\<exists>P'. P \<Longrightarrow>\<^sub>l\<^sup>^\<tau> \<prec> P' \<and> (P', Q') \<in> Rel"
    proof(case_tac "P = P'")
      assume "P = P'"
      hence "P \<Longrightarrow>\<^sub>l\<^sup>^\<tau> \<prec> P'" by(simp add: weakTransition_def)
      with P'RelQ' show ?thesis by blast
    next
      assume "P \<noteq> P'"
      hence "P \<Longrightarrow>\<^sub>l\<tau> \<prec> P'" using PTrans by(rule_tac tauRemoveTau)
      hence "P \<Longrightarrow>\<^sub>l\<^sup>^\<tau> \<prec> P'" by(simp add: weakTransition_def)
      with P'RelQ' show ?thesis by blast
    qed
  qed
qed

lemma sim5:
  fixes P :: pi
  and   Q :: pi
  and   Rel :: "(pi \<times> pi) set"

  assumes PSimQ: "P \<leadsto><Rel> \<tau>.(Q)"
  and     L1: "\<And>P Q. (P, Q) \<in> Rel \<Longrightarrow> P \<leadsto>\<^sup>^<Rel> Q"

  shows "P \<leadsto>\<^sup>^<Rel> Q"
proof -
  have "\<tau>.(Q) \<longmapsto>\<tau> \<prec> Q" by(rule Late_Semantics.Tau)
  with PSimQ obtain P' where PTrans: "P \<Longrightarrow>\<^sub>l\<tau> \<prec> P'" and P'RelQ: "(P', Q) \<in> Rel"
    by(auto dest: simE)
  from PTrans have PChain:"P \<Longrightarrow>\<^sub>\<tau> P'" by(rule Weak_Late_Step_Semantics.tauTransitionChain)
  from P'RelQ have P'SimQ: "P' \<leadsto>\<^sup>^<Rel> Q" by(rule L1)
  show ?thesis
  proof(induct rule: Weak_Late_Sim.simCases)
    case(Bound Q' a x)
    have QTrans: "Q \<longmapsto>a<\<nu>x> \<prec> Q'" and xFreshP: "x \<sharp> P" by fact+
    from PChain xFreshP have xFreshP': "x \<sharp> P'" by(rule freshChain)

    with P'SimQ QTrans obtain P'' where P''Trans: "P' \<Longrightarrow>\<^sub>l\<^sup>^a<\<nu>x> \<prec> P''"
                                    and P''RelQ': "(P'', Q') \<in> Rel" by(auto dest: Weak_Late_Sim.simE)
    from PChain P''Trans have "P \<Longrightarrow>\<^sub>l\<^sup>^a<\<nu>x> \<prec> P''"
      by(rule chainTransitionAppend)
    with P''RelQ' show ?case by blast
  next
    case(Input Q' a x)
    have QTrans: "Q \<longmapsto>a<x> \<prec> Q'" and xFreshP: "x \<sharp> P" by fact+
    from PChain xFreshP have xFreshP': "x \<sharp> P'" by(rule freshChain)
    with P'SimQ QTrans obtain P''' where PSim: "\<forall>u. \<exists>P''. P' \<Longrightarrow>\<^sub>lu in P''' \<rightarrow> a<x> \<prec> P'' \<and> (P'', Q'[x::=u]) \<in> Rel"
      by(auto dest: Weak_Late_Sim.simE)
    have "\<forall>u. \<exists>P''. P \<Longrightarrow>\<^sub>lu in P'''\<rightarrow>a<x> \<prec> P'' \<and> (P'', Q'[x::=u]) \<in> Rel"
    proof(rule allI)
      fix u
      from PSim obtain P'' where P'Trans: "P' \<Longrightarrow>\<^sub>lu in P''' \<rightarrow> a<x> \<prec> P''" and P''RelQ': "(P'', Q'[x::=u]) \<in> Rel"
        by blast
      from PChain P'Trans have "P \<Longrightarrow>\<^sub>lu in P''' \<rightarrow>a<x> \<prec> P''" by(rule Weak_Late_Step_Semantics.chainTransitionAppend)
      with P''RelQ' show "\<exists>P''. P \<Longrightarrow>\<^sub>lu in P''' \<rightarrow> a<x> \<prec> P'' \<and> (P'', Q'[x::=u]) \<in> Rel"  by blast
    qed
    thus ?case by blast
  next
    case(Free Q' \<alpha>)
    with P'SimQ obtain P'' where P'Trans: "P' \<Longrightarrow>\<^sub>l\<^sup>^\<alpha> \<prec> P''"
                             and P''RelQ': "(P'', Q') \<in> Rel" by(auto dest: Weak_Late_Sim.simE)
    from PChain P'Trans have "P \<Longrightarrow>\<^sub>l\<^sup>^\<alpha> \<prec> P''" by(rule chainTransitionAppend)
    with P''RelQ' show ?case by blast
  qed
qed

lemma hennessyRight:
  fixes P :: pi
  and   Q :: pi

  assumes "\<tau>.(P) \<simeq> Q \<or> P \<simeq> Q \<or> P \<simeq> \<tau>.(Q)"

  shows "P \<approx> Q"
using assms
proof(rule disjE)
  assume PeqQ: "\<tau>.(P) \<simeq> Q"
  have "P \<leadsto>\<^sup>^<weakBisim> Q"
  proof -
    from PeqQ have "\<tau>.(P) \<leadsto><weakBisim> Q" by(simp add: congruence_def)
    thus ?thesis by(rule sim4)
  qed
  moreover have "Q \<leadsto>\<^sup>^<weakBisim> P"
  proof -
    from PeqQ have "Q \<leadsto><weakBisim> \<tau>.(P)" by(simp add: congruence_def)
    thus ?thesis using Weak_Late_Bisim.unfoldE(1) by(rule sim5)
  qed
  ultimately show ?thesis by(blast intro: Weak_Late_Bisim.unfoldI)
next
  assume "P \<simeq> Q \<or> P \<simeq> \<tau>.(Q)"
  thus ?thesis
  proof(rule disjE)
    assume "P \<simeq> Q"
    thus ?thesis by(rule congruenceWeakBisim)
  next
    assume PeqQ: "P \<simeq> \<tau>.(Q)"
    have "P \<leadsto>\<^sup>^<weakBisim> Q"
    proof -
      from PeqQ have "P \<leadsto><weakBisim> \<tau>.(Q)" by(simp add: congruence_def)
      thus ?thesis using Weak_Late_Bisim.unfoldE(1) by(rule sim5)
    qed
    moreover have "Q \<leadsto>\<^sup>^<weakBisim> P"
    proof -
      from PeqQ have "\<tau>.(Q) \<leadsto><weakBisim> P" by(simp add: congruence_def)
      thus ?thesis by(rule sim4)
    qed
    ultimately show ?thesis by(blast intro: Weak_Late_Bisim.unfoldI)
  qed
qed

lemma hennessy:
  fixes P :: pi
  and   Q :: pi
  and   R :: pi

  shows "P \<approx> Q = (\<tau>.(P) \<simeq> Q \<or> P \<simeq> Q \<or> P \<simeq> \<tau>.(Q))"
proof(rule iffI)
  assume "P \<approx> Q"
  then show "\<tau>.(P) \<simeq> Q \<or> P \<simeq> Q \<or> P \<simeq> \<tau>.(Q)" by(rule hennessyLeft)
next
  assume "\<tau>.(P) \<simeq> Q \<or> P \<simeq> Q \<or> P \<simeq> \<tau>.(Q)"
  then show "P \<approx> Q" by(rule hennessyRight)
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>Observed-Remove Set\<close>

text\<open>The ORSet is a well-known CRDT for implementing replicated sets, supporting two operations:
     the \emph{insertion} and \emph{deletion} of an arbitrary element in the shared set.\<close>

theory
  ORSet
imports
  Network
begin

datatype ('id, 'a) operation = Add "'id" "'a" | Rem "'id set" "'a"

type_synonym ('id, 'a) state = "'a \<Rightarrow> 'id set"

definition op_elem :: "('id, 'a) operation \<Rightarrow> 'a" where
  "op_elem oper \<equiv> case oper of Add i e \<Rightarrow> e | Rem is e \<Rightarrow> e"

definition interpret_op :: "('id, 'a) operation \<Rightarrow> ('id, 'a) state \<rightharpoonup> ('id, 'a) state" ("\<langle>_\<rangle>" [0] 1000) where
  "interpret_op oper state \<equiv>
     let before = state (op_elem oper);
         after  = case oper of Add i e \<Rightarrow> before \<union> {i} | Rem is e \<Rightarrow> before - is
     in  Some (state ((op_elem oper) := after))"

definition valid_behaviours :: "('id, 'a) state \<Rightarrow> 'id \<times> ('id, 'a) operation \<Rightarrow> bool" where
  "valid_behaviours state msg \<equiv>
     case msg of
       (i, Add j  e) \<Rightarrow> i = j |
       (i, Rem is e) \<Rightarrow> is = state e"

locale orset = network_with_constrained_ops _ interpret_op "\<lambda>x. {}" valid_behaviours

lemma (in orset) add_add_commute:
  shows "\<langle>Add i1 e1\<rangle> \<rhd> \<langle>Add i2 e2\<rangle> = \<langle>Add i2 e2\<rangle> \<rhd> \<langle>Add i1 e1\<rangle>"
  by(auto simp add: interpret_op_def op_elem_def kleisli_def, fastforce)

lemma (in orset) add_rem_commute:
  assumes "i \<notin> is"
  shows "\<langle>Add i e1\<rangle> \<rhd> \<langle>Rem is e2\<rangle> = \<langle>Rem is e2\<rangle> \<rhd> \<langle>Add i e1\<rangle>"
  using assms by(auto simp add: interpret_op_def kleisli_def op_elem_def, fastforce)

lemma (in orset) apply_operations_never_fails:
  assumes "xs prefix of i"
  shows "apply_operations xs \<noteq> None"
using assms proof(induction xs rule: rev_induct, clarsimp)
  case (snoc x xs) thus ?case
  proof (cases x)
    case (Broadcast e) thus ?thesis
      using snoc by force
  next
    case (Deliver e) thus ?thesis
      using snoc by (clarsimp, metis interpret_op_def interp_msg_def bind.bind_lunit prefix_of_appendD)
  qed
qed

lemma (in orset) add_id_valid:
  assumes "xs prefix of j"
    and "Deliver (i1, Add i2 e) \<in> set xs"
  shows "i1 = i2"
proof -
  have "\<exists>s. valid_behaviours s (i1, Add i2 e)"
    using assms deliver_in_prefix_is_valid by blast
  thus ?thesis
    by(simp add: valid_behaviours_def)
qed

definition (in orset) added_ids :: "('id \<times> ('id, 'b) operation) event list \<Rightarrow> 'b \<Rightarrow> 'id list" where
  "added_ids es p \<equiv> List.map_filter (\<lambda>x. case x of Deliver (i, Add j e) \<Rightarrow> if e = p then Some j else None | _ \<Rightarrow> None) es"

lemma (in orset) added_ids_Broadcast_collapse [simp]:
  shows "added_ids ([Broadcast e]) e' = []"
  by (auto simp: added_ids_def map_filter_append map_filter_def)

lemma (in orset) added_ids_Deliver_Rem_collapse [simp]:
  shows "added_ids ([Deliver (i, Rem is e)]) e' = []"
  by (auto simp: added_ids_def map_filter_append map_filter_def)

lemma (in orset) added_ids_Deliver_Add_diff_collapse [simp]:
  shows "e \<noteq> e' \<Longrightarrow> added_ids ([Deliver (i, Add j e)]) e' = []"
  by (auto simp: added_ids_def map_filter_append map_filter_def)

lemma (in orset) added_ids_Deliver_Add_same_collapse [simp]:
  shows "added_ids ([Deliver (i, Add j e)]) e = [j]"
  by (auto simp: added_ids_def map_filter_append map_filter_def)

lemma (in orset) added_id_not_in_set:
  assumes "i1 \<notin> set (added_ids [Deliver (i, Add i2 e)] e)"
  shows "i1 \<noteq> i2"
  using assms by simp

lemma (in orset) apply_operations_added_ids:
  assumes "es prefix of j"
    and "apply_operations es = Some f"
  shows "f x \<subseteq> set (added_ids es x)"
using assms proof (induct es arbitrary: f rule: rev_induct, force)
  case (snoc x xs) thus ?case
  proof (cases x, force)
    case (Deliver e)
    moreover obtain a b where "e = (a, b)" by force
    ultimately show ?thesis
      using snoc by(case_tac b; clarsimp simp: interp_msg_def split: bind_splits,
                    force split: if_split_asm simp add: op_elem_def interpret_op_def)
  qed
qed

lemma (in orset) Deliver_added_ids:
  assumes "xs prefix of j"
    and "i \<in> set (added_ids xs e)"
  shows "Deliver (i, Add i e) \<in> set xs"
using assms proof (induct xs rule: rev_induct, clarsimp)
  case (snoc x xs) thus ?case
  proof (cases x, force)
    case (Deliver e')
    moreover obtain a b where "e' = (a, b)" by force
    ultimately show ?thesis
      using snoc apply (case_tac b; clarsimp)
       apply (metis added_ids_Deliver_Add_diff_collapse added_ids_Deliver_Add_same_collapse
              empty_iff list.set(1) set_ConsD add_id_valid in_set_conv_decomp prefix_of_appendD)
      apply force
      done
  qed
qed

lemma (in orset) Broadcast_Deliver_prefix_closed:
  assumes "xs @ [Broadcast (r, Rem ix e)] prefix of j"
    and "i \<in> ix"
  shows "Deliver (i, Add i e) \<in> set xs"
proof -
  obtain y where "apply_operations xs = Some y"
    using assms broadcast_only_valid_msgs by blast
  moreover hence "ix = y e"
    by (metis (mono_tags, lifting) assms(1) broadcast_only_valid_msgs operation.case(2) option.simps(1)
     valid_behaviours_def case_prodD)
  ultimately show ?thesis
    using assms Deliver_added_ids apply_operations_added_ids by blast
qed

lemma (in orset) Broadcast_Deliver_prefix_closed2:
  assumes "xs prefix of j"
    and "Broadcast (r, Rem ix e) \<in> set xs"
    and "i \<in> ix"
  shows "Deliver (i, Add i e) \<in> set xs"
using assms Broadcast_Deliver_prefix_closed by (induction xs rule: rev_induct; force)

lemma (in orset) concurrent_add_remove_independent_technical:
  assumes "i \<in> is"
    and "xs prefix of j"
    and "(i, Add i e) \<in> set (node_deliver_messages xs)" and "(ir, Rem is e) \<in> set (node_deliver_messages xs)"
  shows "hb (i, Add i e) (ir, Rem is e)"
proof -
  obtain pre k where "pre@[Broadcast (ir, Rem is e)] prefix of k"
    using assms delivery_has_a_cause events_before_exist prefix_msg_in_history by blast
  moreover hence "Deliver (i, Add i e) \<in> set pre"
    using Broadcast_Deliver_prefix_closed assms(1) by auto
  ultimately show ?thesis
    using hb.intros(2) events_in_local_order by blast
qed

lemma (in orset) Deliver_Add_same_id_same_message:
  assumes "Deliver (i, Add i e1) \<in> set (history j)" and "Deliver (i, Add i e2) \<in> set (history j)"
  shows "e1 = e2"
proof -
  obtain pre1 pre2 k1 k2 where *: "pre1@[Broadcast (i, Add i e1)] prefix of k1" "pre2@[Broadcast (i, Add i e2)] prefix of k2"
    using assms delivery_has_a_cause events_before_exist by meson
  moreover hence "Broadcast (i, Add i e1) \<in> set (history k1)" "Broadcast (i, Add i e2) \<in> set (history k2)"
    using node_histories.prefix_to_carriers node_histories_axioms by force+
  ultimately show ?thesis
    using msg_id_unique by fastforce
qed

lemma (in orset) ids_imply_messages_same:
  assumes "i \<in> is"
    and "xs prefix of j"
    and "(i, Add i e1) \<in> set (node_deliver_messages xs)" and "(ir, Rem is e2) \<in> set (node_deliver_messages xs)"
  shows "e1 = e2"
proof -
  obtain pre k where "pre@[Broadcast (ir, Rem is e2)] prefix of k"
    using assms delivery_has_a_cause events_before_exist prefix_msg_in_history by blast
  moreover hence "Deliver (i, Add i e2) \<in> set pre"
    using Broadcast_Deliver_prefix_closed assms(1) by blast
  moreover have "Deliver (i, Add i e1) \<in> set (history j)"
    using assms(2) assms(3) prefix_msg_in_history by blast
  ultimately show ?thesis
    by (metis fst_conv msg_id_unique network.delivery_has_a_cause network_axioms operation.inject(1)
        prefix_elem_to_carriers prefix_of_appendD prod.inject)
qed

corollary (in orset) concurrent_add_remove_independent:
  assumes "\<not> hb (i, Add i e1) (ir, Rem is e2)" and "\<not> hb (ir, Rem is e2) (i, Add i e1)"
    and "xs prefix of j"
    and "(i, Add i e1) \<in> set (node_deliver_messages xs)" and "(ir, Rem is e2) \<in> set (node_deliver_messages xs)"
  shows "i \<notin> is"
  using assms ids_imply_messages_same concurrent_add_remove_independent_technical by fastforce

lemma (in orset) rem_rem_commute:
  shows "\<langle>Rem i1 e1\<rangle> \<rhd> \<langle>Rem i2 e2\<rangle> = \<langle>Rem i2 e2\<rangle> \<rhd> \<langle>Rem i1 e1\<rangle>"
  by(unfold interpret_op_def op_elem_def kleisli_def, fastforce)

lemma (in orset) concurrent_operations_commute:
  assumes "xs prefix of i"
  shows "hb.concurrent_ops_commute (node_deliver_messages xs)"
proof -
  { fix a b x y
    assume "(a, b) \<in> set (node_deliver_messages xs)"
           "(x, y) \<in> set (node_deliver_messages xs)"
           "hb.concurrent (a, b) (x, y)"
    hence "interp_msg (a, b) \<rhd> interp_msg (x, y) = interp_msg (x, y) \<rhd> interp_msg (a, b)"
      apply(unfold interp_msg_def, case_tac "b"; case_tac "y"; simp add: add_add_commute rem_rem_commute hb.concurrent_def)
       apply (metis add_id_valid add_rem_commute assms concurrent_add_remove_independent hb.concurrentD1 hb.concurrentD2 prefix_contains_msg)+
      done
  } thus ?thesis
    by(fastforce simp: hb.concurrent_ops_commute_def)
qed

sublocale sec: strong_eventual_consistency weak_hb hb interp_msg
  "\<lambda>ops.\<exists>xs i. xs prefix of i \<and> node_deliver_messages xs = ops" "\<lambda>x.{}"
  apply(standard; clarsimp simp add: hb_consistent_prefix node_deliver_messages_distinct
        concurrent_operations_commute)
   apply(metis (no_types, lifting) apply_operations_def bind.bind_lunit not_None_eq
     hb.apply_operations_Snoc kleisli_def apply_operations_never_fails interp_msg_def)
  using drop_last_message apply blast
done

end
end


theory nat_acc_plus_assoc
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin

datatype Nat = Z | S "Nat"

fun accplus :: "Nat => Nat => Nat" where
"accplus (Z) y = y"
| "accplus (S z) y = accplus z (S y)"

(*hipster accplus *)

theorem x0 :
  "!! (x :: Nat) (y :: Nat) (z :: Nat) .
     (accplus x (accplus y z)) = (accplus (accplus x y) z)"
  by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)

end


theory Small_Step_sseefried
imports
Star
BigStep_sseefried

begin

subsection "The transition relation"

inductive
  small_step :: "com * state \<Rightarrow> com * state \<Rightarrow> bool" (infix "\<rightarrow>" 55)
where
Assign:  "(x ::= a, s) \<rightarrow> (SKIP, s(x := aval a s))" |

Seq1:    "(SKIP;;c\<^sub>2,s) \<rightarrow> (c\<^sub>2,s)" |
Seq2:    "(c\<^sub>1,s) \<rightarrow> (c\<^sub>1',s') \<Longrightarrow> (c\<^sub>1;;c\<^sub>2,s) \<rightarrow> (c\<^sub>1';;c\<^sub>2,s')" |

IfTrue:  "bval b s \<Longrightarrow> (IF b THEN c\<^sub>1 ELSE c\<^sub>2,s) \<rightarrow> (c\<^sub>1,s)" |
IfFalse: "\<not>bval b s \<Longrightarrow> (IF b THEN c\<^sub>1 ELSE c\<^sub>2,s) \<rightarrow> (c\<^sub>2,s)" |

While:   "(WHILE b DO c,s) \<rightarrow>
            (IF b THEN c;; WHILE b DO c ELSE SKIP,s)"

abbreviation
  small_steps :: "com * state \<Rightarrow> com * state \<Rightarrow> bool" (infix "\<rightarrow>*" 55)
where "x \<rightarrow>* y == star small_step x y"

code_pred small_step .

lemmas small_step_induct = small_step.induct[split_format(complete)]

declare small_step.intros[simp,intro]

text{* Rule inversion: *}

inductive_cases SkipE[elim!]: "(SKIP,s) \<rightarrow> ct"
thm SkipE
inductive_cases AssignE[elim!]: "(x::=a,s) \<rightarrow> ct"
thm AssignE
inductive_cases SeqE[elim]: "(c1;;c2,s) \<rightarrow> ct"
thm SeqE
inductive_cases IfE[elim!]: "(IF b THEN c1 ELSE c2,s) \<rightarrow> ct"
thm IfE
inductive_cases WhileE[elim]: "(WHILE b DO c, s) \<rightarrow> ct"

(* Lemma 7.11 *)
lemma "cs \<rightarrow> cs' \<Longrightarrow> cs \<rightarrow> cs'' \<Longrightarrow> cs'' = cs'"
  apply (induction cs' arbitrary: cs'' rule: small_step.induct)
  apply blast+
  done

(* Lemma 7.13 *)
lemma star_seq2: "(c1, s1) \<rightarrow>* (c, s2) \<Longrightarrow> (c1;;c2, s1) \<rightarrow>* (c;; c2, s2)"
proof (induction "(c1,s1)" "(c,s2)" arbitrary: c1 s1 c s2  rule: star.induct)
  case (refl)
  then show ?case by simp
next
  case (step y)
  obtain c1' s1' where a: "y = (c1', s1')" by fastforce
  have star: "(c1';;c2, s1') \<rightarrow>* (c;;c2, s2)" using step.hyps(3) a by blast
  have first: "(c1;; c2, s1) \<rightarrow> (c1';;c2, s1')" using step.hyps(1) a  by blast
  thus ?case using first star step.hyps by (simp add: star.step)
qed

(* I was having trouble with proving
     obtain c1' s1' where a: "y = (c1', s1')"
  It is equivalent to the following. If you can prove that
  you can prove the "obtain" *)

lemma "\<And>thesis. (\<And>c1' s1'. y = (c1', s1') \<Longrightarrow> thesis) \<Longrightarrow> thesis"
proof -
  fix thesis
  assume [intro]: "\<And>c1' s1'. y = (c1', s1') \<Longrightarrow> thesis"
  then show thesis by fastforce
qed

thm big_step.WhileTrue

(* Lemma 7.12 *)
lemma big_step_imp_small_step: "cs \<Rightarrow> t \<Longrightarrow> cs \<rightarrow>* (SKIP, t)"
proof (induction rule: big_step.induct)
  case (Skip s)
  then show ?case by blast
next
  case (Assign x a s)
  then show ?case by blast
next
  case (Seq c\<^sub>1 s\<^sub>1 s\<^sub>2 c\<^sub>2 s\<^sub>3)
  then show ?case by (blast intro: star.step star_seq2 star_trans)
next
  case (IfTrue b s c\<^sub>1 t c\<^sub>2)
  then have "(IF b THEN c\<^sub>1 ELSE c\<^sub>2, s) \<rightarrow> (c\<^sub>1, s)" by blast
  then show ?case using IfTrue.IH by (blast intro: star.step)
next
  case (IfFalse b s c\<^sub>2 t c\<^sub>1)
  then have "(IF b THEN c\<^sub>1 ELSE c\<^sub>2, s) \<rightarrow> (c\<^sub>2, s)" by blast
  then show ?case using IfFalse.IH by (blast intro: star.step)
next
  case (WhileFalse b s c)
  then have a: "(WHILE b DO c,s) \<rightarrow>
            (IF b THEN (c;; WHILE b DO c) ELSE SKIP,s)" by blast
  then have "(IF b THEN (c;; WHILE b DO c) ELSE SKIP,s) \<rightarrow>* (SKIP,s)" using WhileFalse.hyps by blast
  then show "(WHILE b DO c, s) \<rightarrow>* (SKIP, s)" using a by (blast intro: star.step)
next
  case (WhileTrue b s\<^sub>1 c s\<^sub>2 s\<^sub>3)
  let ?w = "WHILE b DO c"
  let ?if = "IF b THEN c;; ?w ELSE SKIP"
  have 1: "(?w, s\<^sub>1) \<rightarrow>* (?if, s\<^sub>1)" by blast
  have 2: "(?if, s\<^sub>1) \<rightarrow>* (c;;?w, s\<^sub>1)" using WhileTrue(1) by blast
  have 3: "(c;;?w, s\<^sub>1) \<rightarrow>* (SKIP;;?w, s\<^sub>2)" using WhileTrue.IH(1) by (simp add: star_seq2)
  have 4: "(SKIP;;?w, s\<^sub>2) \<rightarrow>* (?w, s\<^sub>2)" by simp
  then have "(?w, s\<^sub>1) \<rightarrow>* (?w, s\<^sub>2)" using 1 2 3 4 by (blast intro: star_trans)
  then show ?case using WhileTrue.IH by (blast intro: star_trans)
qed

(* I could have got an even smaller proof for the WhileTrue cases above if I'd have proved this
   I could then have got
     assume w: "(?w,s') \<rightarrow>* (SKIP,t)"
     assume c: "(c,s) \<rightarrow>* (SKIP,s')"
     have new_3: "(c;; ?w,s) \<rightarrow>* (SKIP,t)" by(rule seq_comp[OF c w])

     Then I could have used 1 2 and new_3

*)
lemma seq_comp: "\<lbrakk> (c\<^sub>1, s\<^sub>1) \<rightarrow>* (SKIP, s\<^sub>2); (c\<^sub>2, s\<^sub>2) \<rightarrow>* (SKIP, s\<^sub>3) \<rbrakk> \<Longrightarrow> (c\<^sub>1;;c\<^sub>2, s\<^sub>1) \<rightarrow>* (SKIP, s\<^sub>3)"
  by (blast intro: star_seq2 star_trans)

(* Lemma 7.15 *)
lemma small_big_comp: "\<lbrakk> cs \<rightarrow> cs'; cs' \<Rightarrow> t \<rbrakk> \<Longrightarrow> cs \<Rightarrow> t"
  apply  (induction arbitrary: t rule: small_step.induct)
       apply blast+
done

(* Lemma 7.14 *)

(* The induction here was interesting because we didn't have to use "arbitrary" in
proof (induction "cs" "(SKIP, t)" rule: star.induct *)
lemma small_step_imp_big_step: "cs \<rightarrow>* (SKIP, t) \<Longrightarrow> cs \<Rightarrow> t"
proof (induction "cs" "(SKIP, t)" rule: star.induct)
  case refl
  then show ?case by blast
next
  case (step cs cs')
  assume "cs \<rightarrow> cs'"
     and "cs' \<Rightarrow> t"
  thus ?case by (rule small_big_comp)
qed

(* The textbook got us to prove "(c,s) \<Rightarrow> t \<longleftrightarrow> (c,s) \<rightarrow>* (SKIP, t)"
   which ended up meaning that the proof for 7.18 did not go through easily.
   The form below, using "cs" insteand of "(c,s)" is the same as the form for
   final_iff_SKIP
 *)

(* Lemma 7.16 *)
lemma big_iff_small: "cs \<Rightarrow> t \<longleftrightarrow> cs \<rightarrow>* (SKIP, t)"
proof
  show "cs \<Rightarrow> t \<Longrightarrow> cs \<rightarrow>* (SKIP, t)" by (rule big_step_imp_small_step)
next
  show "cs \<rightarrow>* (SKIP, t) \<Longrightarrow> cs \<Rightarrow> t" by (rule small_step_imp_big_step)
qed

definition final :: "com \<times> state \<Rightarrow> bool" where
  "final cs \<longleftrightarrow> \<not>(\<exists>cs'. cs \<rightarrow> cs')"

(* Lemma 7.17 *)
lemma final_iff_SKIP: "final (c,s) = (c = SKIP)"
proof
  show "c = SKIP \<Longrightarrow> final (c, s)" by (auto simp: final_def)
next
  show "final (c, s) \<Longrightarrow> c = SKIP"
    apply (simp add: final_def)
    apply (induction c rule: com.induct)
        apply blast+
    done
qed

(* Lemma 7.18 *)
lemma "(\<exists>t. cs \<Rightarrow> t) \<longleftrightarrow> (\<exists>cs'. cs \<rightarrow>* cs' \<and> final cs')"
  apply (simp add: final_iff_SKIP)
  apply (simp add: big_iff_small)
  done

end


(*<*)
\<comment>\<open> ********************************************************************
 * Project         : HOL-CSP - A Shallow Embedding of CSP in  Isabelle/HOL
 * Version         : 2.0
 *
 * Author          : Burkhart Wolff, Safouan Taha, Lina Ye.
 *                   (Based on HOL-CSP 1.0 by Haykal Tej and Burkhart Wolff)
 *
 * This file       : A Combined CSP Theory
 *
 * Copyright (c) 2009 Université Paris-Sud, France
 *
 * All rights reserved.
 *
 * Redistribution and use in source and binary forms, with or without
 * modification, are permitted provided that the following conditions are
 * met:
 *
 *     * Redistributions of source code must retain the above copyright
 *       notice, this list of conditions and the following disclaimer.
 *
 *     * Redistributions in binary form must reproduce the above
 *       copyright notice, this list of conditions and the following
 *       disclaimer in the documentation and/or other materials provided
 *       with the distribution.
 *
 *     * Neither the name of the copyright holders nor the names of its
 *       contributors may be used to endorse or promote products derived
 *       from this software without specific prior written permission.
 *
 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
 * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
 * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
 * A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
 * OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
 * SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
 * LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
 * DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
 * THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
 * (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
 * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 ******************************************************************************\<close>
(*>*)

chapter\<open> Annex: Refinement Example with Buffer over infinite Alphabet\<close>

theory     CopyBuffer
 imports    "Assertions"
begin

section\<open> Defining the Copy-Buffer Example \<close>

datatype 'a channel = left 'a | right 'a | mid 'a | ack

definition SYN  :: "('a channel) set"
where     "SYN  \<equiv> (range mid) \<union> {ack}"

definition COPY :: "('a channel) process"
where     "COPY \<equiv> (\<mu> COPY. left`?`x \<rightarrow> (right`!`x \<rightarrow> COPY))"

definition SEND :: "('a channel) process"
where     "SEND \<equiv> (\<mu> SEND. left`?`x \<rightarrow> (mid`!`x \<rightarrow>( ack \<rightarrow> SEND)))"

definition REC  :: "('a channel) process"
where     "REC  \<equiv> (\<mu> REC. mid`?`x \<rightarrow> (right`!`x \<rightarrow> (ack \<rightarrow> REC)))"

definition SYSTEM :: "('a channel) process"
where     "SYSTEM \<equiv> ((SEND \<lbrakk> SYN \<rbrakk> REC) \\ SYN)"

section\<open> The Standard Proof \<close>

subsection\<open> Channels and Synchronization Sets\<close>

text\<open> First part: abstract properties for these events to SYN.
       This kind of stuff could be automated easily by some
       extra-syntax for channels and SYN-sets. \<close>

lemma [simp]: "ack \<in> SYN"
    by(auto simp: SYN_def)

lemma [simp]: "mid x \<in> SYN"
    by(auto simp: SYN_def)

lemma [simp]: "inj mid"
  by(auto simp: inj_on_def)

lemma "finite (SYN:: 'a channel set) \<Longrightarrow> finite {(t::'a). True}"
  by (metis (no_types) SYN_def UNIV_def channel.inject(3) finite_Un finite_imageD inj_on_def)

subsection\<open> Definitions by Recursors \<close>

text\<open> Second part: Derive recursive process equations, which
       are easier to handle in proofs. This part IS actually
       automated if we could reuse the fixrec-syntax below. \<close>

lemma COPY_rec:
  "COPY = (left`?`x \<rightarrow> (right`!`x \<rightarrow> COPY))"
  by(simp add: COPY_def,rule trans, rule fix_eq, simp)

lemma SEND_rec:
  "SEND = (left`?`x \<rightarrow> (mid`!`x \<rightarrow> (ack \<rightarrow> SEND)))"
  by(simp add: SEND_def,rule trans, rule fix_eq, simp)

lemma REC_rec:
  "REC = (mid`?`x \<rightarrow> (right`!`x \<rightarrow> (ack \<rightarrow> REC)))"
  by(simp add: REC_def,rule trans, rule fix_eq, simp)

subsection\<open> A Refinement Proof \<close>

text\<open> Third part: No comes the proof by fixpoint induction.
       Not too bad in automation considering what is inferred,
       but wouldn't scale for large examples. \<close>

lemma spec_refines_impl :
  assumes fin: "finite (SYN:: 'a channel set)"
  shows        "SYSTEM \<sqsubseteq> (COPY :: 'a channel process)"
  apply(simp add: SYSTEM_def SEND_def)
  apply(rule fix_ind, simp_all)
    using adm_below hiding_cont[of SYN "\<lambda>(a:: 'a channel process). (a \<lbrakk>SYN\<rbrakk> REC)", OF fin]
      apply (simp add: contI cont_left_sync chain_Sync1 thelubE)
   apply (simp add: hide_set_bot par_Int_bot sync_commute)
  by (subst COPY_rec, subst REC_rec, simp add:sync_rules hide_rules mono_rules)

text\<open> Note that this was actually proven for the
       Process ordering, not the refinement ordering.
       But the former implies the latter.
       And due to anti-symmetry, equality follows
       for the case of finite alphabets \ldots \<close>

lemma spec_equal_impl :
assumes fin:  "finite (SYN::('a channel)set)"
shows         "SYSTEM = (COPY::'a channel process)"
  by (simp add: below_antisym fin impl_refines_spec spec_refines_impl)

subsection\<open>Deadlock Freeness Proof \<close>

text\<open>HOL-CSP can be used to prove deadlock-freeness of processes with infinite alphabet. In the
case of the @{term COPY} - process, this can be formulated as the following refinement problem:\<close>

lemma "(DF (range left \<union> range right)) \<sqsubseteq>\<^sub>F\<^sub>D COPY"
  apply(simp add:DF_def,rule fix_ind2,simp_all)
  unfolding failure_divergence_refine_def
proof -
  show "adm (\<lambda>a. a \<le> COPY)"   by(rule le_adm, simp_all add:monofunI)
next
  show "\<bottom> \<le> COPY" by(simp_all)
next
    have 1:"(\<sqinter>xa\<in> range left \<union> range right \<rightarrow> \<bottom>) \<le> (\<sqinter>xa\<in> range left \<rightarrow>  \<bottom>)"
      using mndet_subset_FD by (metis UNIV_I empty_iff imageI)
    have 2:"(\<sqinter>xa\<in> range left \<rightarrow>  \<bottom>) \<le> (left`?`x \<rightarrow>  \<bottom>)"
      unfolding read_def
      by (metis Mprefix_refines_Mndet comp_apply dual_order.antisym mono_mprefix_FD order_refl)

  show "(\<sqinter>x\<in>range left \<union> range right \<rightarrow>  \<bottom>) \<le> COPY"
    by (metis (mono_tags, lifting)  1 2 COPY_rec bot_less1 mono_read_FD order.trans)
next
  fix P::"'a channel process"
  assume  *: "P \<le> COPY" and ** : "(\<sqinter>x\<in>range left \<union> range right \<rightarrow>  P) \<le> COPY"
    have 1:"(\<sqinter>xa\<in> range left \<union> range right \<rightarrow>  P) \<le> (\<sqinter>xa\<in> range right \<rightarrow>  P)"
      using mndet_subset_FD by (metis UNIV_I Un_commute empty_iff imageI)
    have 2:"(\<sqinter>xa\<in> range right \<rightarrow>  P) \<le> (right`!`x \<rightarrow>  P)" for x
      using mndet_subset_FD[of "{right x}" "range right"]
      by(simp add:write_def write0_def mndet_unit)
    from 1 2 have ab:"(\<sqinter>xa\<in> range left \<union> range right \<rightarrow>  P) \<le> (right`!`x \<rightarrow>  P)" for x
      using dual_order.trans by blast
    hence 3:"(left`?`x \<rightarrow> (\<sqinter>xa\<in> range left \<union> range right \<rightarrow>  P)) \<le> (left`?`x \<rightarrow>(right`!`x \<rightarrow>  P))"
      by (simp add: mono_read_FD)
    have 4:"\<And>X. (\<sqinter>xa\<in> range left \<union> range right \<rightarrow> X) \<le> (\<sqinter>xa\<in> range left \<rightarrow> X)"
      using mndet_subset_FD by (metis UNIV_I empty_iff imageI)
    have 5:"\<And>X. (\<sqinter>xa\<in> range left \<rightarrow> X) \<le> (left`?`x \<rightarrow> X)"
      unfolding read_def
      by (metis Mprefix_refines_Mndet comp_apply dual_order.antisym mono_mprefix_FD order_refl)
    from 3 4[of "(\<sqinter>xa\<in> range left \<union> range right \<rightarrow>  P)"]
         5  [of "(\<sqinter>xa\<in> range left \<union> range right \<rightarrow>  P)"]
    have 6:"(\<sqinter>xa\<in> range left \<union> range right \<rightarrow>
                    (\<sqinter>xa\<in> range left \<union> range right \<rightarrow>  P)) \<le> (left`?`x \<rightarrow> (right`!`x \<rightarrow>  P))"
      by (meson dual_order.trans)
    from * ** have 7:"(left`?`x \<rightarrow> (right`!`x \<rightarrow>  P)) \<le> (left`?`x \<rightarrow> (right`!`x \<rightarrow>  COPY))"
      by (simp add: mono_read_FD mono_write_FD)

  show "(\<sqinter>x\<in>range left \<union> range right \<rightarrow>  \<sqinter>x\<in>range left \<union> range right \<rightarrow>  P) \<le> COPY"
    by (metis (mono_tags, lifting) 6 7  COPY_rec dual_order.trans)
qed

section\<open> An Alternative Approach: Using the fixrec-Package \<close>

subsection\<open> Channels and Synchronisation Sets \<close>

text\<open> As before. \<close>

subsection\<open> Process Definitions via fixrec-Package  \<close>

fixrec
  COPY' :: "('a channel) process"
and
  SEND' :: "('a channel) process"
and
  REC' :: "('a channel) process"
where
   COPY'_rec[simp del]:  "COPY' = (left`?`x \<rightarrow> (right`!`x \<rightarrow> COPY'))"
|  SEND'_rec[simp del]:  "SEND' = (left`?`x \<rightarrow> (mid`!`x \<rightarrow> (ack \<rightarrow> SEND')))"
|  REC'_rec[simp del] :  "REC'  = (mid`?`x \<rightarrow> (right`!`x \<rightarrow> (ack \<rightarrow> REC')))"

definition SYSTEM' :: "('a channel) process"
where     "SYSTEM' \<equiv> ((SEND' \<lbrakk> SYN \<rbrakk> REC') \\ SYN)"

subsection\<open> Another Refinement Proof on fixrec-infrastructure \<close>

text\<open> Third part: No comes the proof by fixpoint induction.
       Not too bad in automation considering what is inferred,
       but wouldn't scale for large examples. \<close>

lemma impl_refines_spec' : "(COPY'::'a channel process) \<sqsubseteq> SYSTEM'"
  apply(unfold SYSTEM'_def)
  apply(rule_tac P="\<lambda> a b c. a \<sqsubseteq> (SEND' \<lbrakk>SYN\<rbrakk> REC') \\ SYN" in COPY'_SEND'_REC'.induct, simp_all)
  by (subst SEND'_rec, subst REC'_rec, simp add: sync_rules hide_rules mono_rules)

lemma spec_refines_impl' :
assumes fin:  "finite (SYN::('a channel)set)"
shows         "SYSTEM' \<sqsubseteq> (COPY'::'a channel process)"
proof(unfold SYSTEM'_def, rule_tac P="\<lambda> a b c. ((b \<lbrakk>SYN\<rbrakk> REC') \\ SYN) \<sqsubseteq> COPY'" in COPY'_SEND'_REC'.induct, goal_cases)
  case 1
  have aa:"adm (\<lambda>(a::'a channel process). ((a \<lbrakk>SYN\<rbrakk> REC') \\ SYN) \<sqsubseteq> COPY')"
    by (simp add: contI cont_left_sync chain_Sync1 thelubE fin)
  thus ?case using adm_subst[of "\<lambda>(a,b,c). b", simplified, OF aa] by (simp add:split_def)
next
  case 2
  then show ?case by (simp add: hide_set_bot par_Int_bot sync_commute)
next
  case (3 a aa b)
  then show ?case   by (subst COPY'_rec, subst REC'_rec, simp add:sync_rules hide_rules mono_rules)
qed

lemma spec_equal_impl' :
assumes fin:  "finite (SYN::('a channel)set)"
shows         "SYSTEM' = (COPY'::'a channel process)"
  apply(rule Porder.po_class.below_antisym)
   apply(rule spec_refines_impl'[OF fin])
  apply(rule impl_refines_spec')
done

end


(* Author: Tobias Nipkow *)

subsubsection "VCG for Total Correctness With Logical Variables"

theory VCG_Total_EX2
imports Hoare_Total_EX2
begin

text \<open>
Theory \<open>VCG_Total_EX\<close> conatins a VCG built on top of a Hoare logic without logical variables.
As a result the completeness proof runs into a problem. This theory uses a Hoare logic
with logical variables and proves soundness and completeness.
\<close>

text\<open>Annotated commands: commands where loops are annotated with
invariants.\<close>

datatype acom =
  Askip                  ("SKIP") |
  Aassign vname aexp     ("(_ ::= _)" [1000, 61] 61) |
  Aseq   acom acom       ("_;;/ _"  [60, 61] 60) |
  Aif bexp acom acom     ("(IF _/ THEN _/ ELSE _)"  [0, 0, 61] 61) |
  Awhile assn2 lvname bexp acom
    ("({_'/_}/ WHILE _/ DO _)"  [0, 0, 0, 61] 61)

notation com.SKIP ("SKIP")

text\<open>Strip annotations:\<close>

fun strip :: "acom \<Rightarrow> com" where
"strip SKIP = SKIP" |
"strip (x ::= a) = (x ::= a)" |
"strip (C\<^sub>1;; C\<^sub>2) = (strip C\<^sub>1;; strip C\<^sub>2)" |
"strip (IF b THEN C\<^sub>1 ELSE C\<^sub>2) = (IF b THEN strip C\<^sub>1 ELSE strip C\<^sub>2)" |
"strip ({_/_} WHILE b DO C) = (WHILE b DO strip C)"

text\<open>Weakest precondition from annotated commands:\<close>

fun pre :: "acom \<Rightarrow> assn2 \<Rightarrow> assn2" where
"pre SKIP Q = Q" |
"pre (x ::= a) Q = (\<lambda>l s. Q l (s(x := aval a s)))" |
"pre (C\<^sub>1;; C\<^sub>2) Q = pre C\<^sub>1 (pre C\<^sub>2 Q)" |
"pre (IF b THEN C\<^sub>1 ELSE C\<^sub>2) Q =
  (\<lambda>l s. if bval b s then pre C\<^sub>1 Q l s else pre C\<^sub>2 Q l s)" |
"pre ({I/x} WHILE b DO C) Q = (\<lambda>l s. \<exists>n. I (l(x:=n)) s)"

text\<open>Verification condition:\<close>

fun vc :: "acom \<Rightarrow> assn2 \<Rightarrow> bool" where
"vc SKIP Q = True" |
"vc (x ::= a) Q = True" |
"vc (C\<^sub>1;; C\<^sub>2) Q = (vc C\<^sub>1 (pre C\<^sub>2 Q) \<and> vc C\<^sub>2 Q)" |
"vc (IF b THEN C\<^sub>1 ELSE C\<^sub>2) Q = (vc C\<^sub>1 Q \<and> vc C\<^sub>2 Q)" |
"vc ({I/x} WHILE b DO C) Q =
  (\<forall>l s. (I (l(x:=Suc(l x))) s \<longrightarrow> pre C I l s) \<and>
       (l x > 0 \<and> I l s \<longrightarrow> bval b s) \<and>
       (I (l(x := 0)) s \<longrightarrow> \<not> bval b s \<and> Q l s) \<and>
       vc C I)"

lemma vc_sound: "vc C Q \<Longrightarrow> \<turnstile>\<^sub>t {pre C Q} strip C {Q}"
proof(induction C arbitrary: Q)
  case (Awhile I x b C)
  show ?case
  proof(simp, rule weaken_post[OF While[of I x]], goal_cases)
    case 1 show ?case
      using Awhile.IH[of "I"] Awhile.prems by (auto intro: strengthen_pre)
  next
    case 3 show ?case
      using Awhile.prems by (simp) (metis fun_upd_triv)
  qed (insert Awhile.prems, auto)
qed (auto intro: conseq Seq If simp: Skip Assign)

text\<open>Completeness:\<close>

lemma pre_mono:
  "\<forall>l s. P l s \<longrightarrow> P' l s \<Longrightarrow> pre C P l s \<Longrightarrow> pre C P' l s"
proof (induction C arbitrary: P P' l s)
  case Aseq thus ?case by simp metis
qed simp_all

lemma vc_mono:
  "\<forall>l s. P l s \<longrightarrow> P' l s \<Longrightarrow> vc C P \<Longrightarrow> vc C P'"
proof(induction C arbitrary: P P')
  case Aseq thus ?case by simp (metis pre_mono)
qed simp_all

lemma vc_complete:
 "\<turnstile>\<^sub>t {P}c{Q} \<Longrightarrow> \<exists>C. strip C = c \<and> vc C Q \<and> (\<forall>l s. P l s \<longrightarrow> pre C Q l s)"
  (is "_ \<Longrightarrow> \<exists>C. ?G P c Q C")
proof (induction rule: hoaret.induct)
  case Skip
  show ?case (is "\<exists>C. ?C C")
  proof show "?C Askip" by simp qed
next
  case (Assign P a x)
  show ?case (is "\<exists>C. ?C C")
  proof show "?C(Aassign x a)" by simp qed
next
  case (Seq P c1 Q c2 R)
  from Seq.IH obtain C1 where ih1: "?G P c1 Q C1" by blast
  from Seq.IH obtain C2 where ih2: "?G Q c2 R C2" by blast
  show ?case (is "\<exists>C. ?C C")
  proof
    show "?C(Aseq C1 C2)"
      using ih1 ih2 by (fastforce elim!: pre_mono vc_mono)
  qed
next
  case (If P b c1 Q c2)
  from If.IH obtain C1 where ih1: "?G (\<lambda>l s. P l s \<and> bval b s) c1 Q C1"
    by blast
  from If.IH obtain C2 where ih2: "?G (\<lambda>l s. P l s \<and> \<not>bval b s) c2 Q C2"
    by blast
  show ?case (is "\<exists>C. ?C C")
  proof
    show "?C(Aif b C1 C2)" using ih1 ih2 by simp
  qed
next
  case (While P x c b)
  from While.IH obtain C where
    ih: "?G (\<lambda>l s. P (l(x:=Suc(l x))) s \<and> bval b s) c P C"
    by blast
  show ?case (is "\<exists>C. ?C C")
  proof
    have "vc ({P/x} WHILE b DO C) (\<lambda>l. P (l(x := 0)))"
      using ih While.hyps(2,3)
      by simp (metis fun_upd_same zero_less_Suc)
    thus "?C(Awhile P x b C)" using ih by simp
 qed
next
  case conseq thus ?case by(fast elim!: pre_mono vc_mono)
qed

text \<open>Two examples:\<close>

lemma vc1: "vc
 ({\<lambda>l s. l ''x'' = nat(s ''x'') / ''x''} WHILE Less (N 0) (V ''x'') DO ''x'' ::= Plus (V ''x'') (N (-1)))
 (\<lambda>l s. s ''x'' \<le> 0)"
by auto

thm vc_sound[OF vc1, simplified]

lemma vc2: "vc
 ({\<lambda>l s. l ''x'' = nat(s ''x'') / ''x''} WHILE Less (N 0) (V ''x'')
 DO (''x'' ::= Plus (V ''x'') (N (-1));;
    (''y'' ::= V ''x'';;
     {\<lambda>l s. l ''x'' = nat(s ''x'') \<and> l ''y'' = nat(s ''y'') / ''y''}
     WHILE Less (N 0) (V ''y'') DO ''y'' ::= Plus (V ''y'') (N (-1)))))
(\<lambda>l s. s ''x'' \<le> 0)"
by auto

thm vc_sound[OF vc2, simplified]

end


(*  Title:      HOL/Proofs/Lambda/ListApplication.thy
    Author:     Tobias Nipkow
    Copyright   1998 TU Muenchen
*)

section {* Application of a term to a list of terms *}

theory ListApplication imports Lambda begin

abbreviation
  list_application :: "dB => dB list => dB"  (infixl "\<degree>\<degree>" 150) where
  "t \<degree>\<degree> ts == foldl (op \<degree>) t ts"

lemma apps_eq_tail_conv [iff]: "(r \<degree>\<degree> ts = s \<degree>\<degree> ts) = (r = s)"
  by (induct ts rule: rev_induct) auto

lemma Var_eq_apps_conv [iff]: "(Var m = s \<degree>\<degree> ss) = (Var m = s \<and> ss = [])"
  by (induct ss arbitrary: s) auto

lemma Var_apps_eq_Var_apps_conv [iff]:
    "(Var m \<degree>\<degree> rs = Var n \<degree>\<degree> ss) = (m = n \<and> rs = ss)"
  apply (induct rs arbitrary: ss rule: rev_induct)
   apply simp
   apply blast
  apply (induct_tac ss rule: rev_induct)
   apply auto
  done

lemma App_eq_foldl_conv:
  "(r \<degree> s = t \<degree>\<degree> ts) =
    (if ts = [] then r \<degree> s = t
    else (\<exists>ss. ts = ss @ [s] \<and> r = t \<degree>\<degree> ss))"
  apply (rule_tac xs = ts in rev_exhaust)
   apply auto
  done

lemma Abs_eq_apps_conv [iff]:
    "(Abs r = s \<degree>\<degree> ss) = (Abs r = s \<and> ss = [])"
  by (induct ss rule: rev_induct) auto

lemma apps_eq_Abs_conv [iff]: "(s \<degree>\<degree> ss = Abs r) = (s = Abs r \<and> ss = [])"
  by (induct ss rule: rev_induct) auto

lemma Abs_apps_eq_Abs_apps_conv [iff]:
    "(Abs r \<degree>\<degree> rs = Abs s \<degree>\<degree> ss) = (r = s \<and> rs = ss)"
  apply (induct rs arbitrary: ss rule: rev_induct)
   apply simp
   apply blast
  apply (induct_tac ss rule: rev_induct)
   apply auto
  done

lemma Abs_App_neq_Var_apps [iff]:
    "Abs s \<degree> t \<noteq> Var n \<degree>\<degree> ss"
  by (induct ss arbitrary: s t rule: rev_induct) auto

lemma Var_apps_neq_Abs_apps [iff]:
    "Var n \<degree>\<degree> ts \<noteq> Abs r \<degree>\<degree> ss"
  apply (induct ss arbitrary: ts rule: rev_induct)
   apply simp
  apply (induct_tac ts rule: rev_induct)
   apply auto
  done

lemma ex_head_tail:
  "\<exists>ts h. t = h \<degree>\<degree> ts \<and> ((\<exists>n. h = Var n) \<or> (\<exists>u. h = Abs u))"
  apply (induct t)
    apply (rule_tac x = "[]" in exI)
    apply simp
   apply clarify
   apply (rename_tac ts1 ts2 h1 h2)
   apply (rule_tac x = "ts1 @ [h2 \<degree>\<degree> ts2]" in exI)
   apply simp
  apply simp
  done

lemma size_apps [simp]:
  "size (r \<degree>\<degree> rs) = size r + foldl (op +) 0 (map size rs) + length rs"
  by (induct rs rule: rev_induct) auto

lemma lem0: "[| (0::nat) < k; m <= n |] ==> m < n + k"
  by simp

lemma lift_map [simp]:
    "lift (t \<degree>\<degree> ts) i = lift t i \<degree>\<degree> map (\<lambda>t. lift t i) ts"
  by (induct ts arbitrary: t) simp_all

lemma subst_map [simp]:
    "subst (t \<degree>\<degree> ts) u i = subst t u i \<degree>\<degree> map (\<lambda>t. subst t u i) ts"
  by (induct ts arbitrary: t) simp_all

lemma app_last: "(t \<degree>\<degree> ts) \<degree> u = t \<degree>\<degree> (ts @ [u])"
  by simp

text {* \medskip A customized induction schema for @{text "\<degree>\<degree>"}. *}

lemma lem:
  assumes "!!n ts. \<forall>t \<in> set ts. P t ==> P (Var n \<degree>\<degree> ts)"
    and "!!u ts. [| P u; \<forall>t \<in> set ts. P t |] ==> P (Abs u \<degree>\<degree> ts)"
  shows "size t = n \<Longrightarrow> P t"
  apply (induct n arbitrary: t rule: nat_less_induct)
  apply (cut_tac t = t in ex_head_tail)
  apply clarify
  apply (erule disjE)
   apply clarify
   apply (rule assms)
   apply clarify
   apply (erule allE, erule impE)
    prefer 2
    apply (erule allE, erule mp, rule refl)
   apply simp
   apply (simp only: foldl_conv_fold add.commute fold_plus_listsum_rev)
   apply (fastforce simp add: listsum_map_remove1)
  apply clarify
  apply (rule assms)
   apply (erule allE, erule impE)
    prefer 2
    apply (erule allE, erule mp, rule refl)
   apply simp
  apply clarify
  apply (erule allE, erule impE)
   prefer 2
   apply (erule allE, erule mp, rule refl)
  apply simp
  apply (rule le_imp_less_Suc)
  apply (rule trans_le_add1)
  apply (rule trans_le_add2)
  apply (simp only: foldl_conv_fold add.commute fold_plus_listsum_rev)
  apply (simp add: member_le_listsum_nat)
  done

theorem Apps_dB_induct:
  assumes "!!n ts. \<forall>t \<in> set ts. P t ==> P (Var n \<degree>\<degree> ts)"
    and "!!u ts. [| P u; \<forall>t \<in> set ts. P t |] ==> P (Abs u \<degree>\<degree> ts)"
  shows "P t"
  apply (rule_tac t = t in lem)
    prefer 3
    apply (rule refl)
    using assms apply iprover+
  done

end


section \<open>Compiler Between Static Representations\<close>

theory Compiler
  imports Language Simulation
begin

definition option_comp :: "('a \<Rightarrow> 'b option) \<Rightarrow> ('c \<Rightarrow> 'a option) \<Rightarrow> 'c \<Rightarrow> 'b option" (infix "\<Lleftarrow>" 50) where
  "(f \<Lleftarrow> g) x \<equiv> Option.bind (g x) f"

context
  fixes f :: "('a \<Rightarrow> 'a option)"
begin

fun option_comp_pow :: "nat \<Rightarrow> 'a \<Rightarrow> 'a option" where
  "option_comp_pow 0 = (\<lambda>_. None)" |
  "option_comp_pow (Suc 0) = f" |
  "option_comp_pow (Suc n) = (option_comp_pow n \<Lleftarrow> f)"

end

locale compiler =
  L1: language step1 final1 load1 +
  L2: language step2 final2 load2 +
  backward_simulation step1 step2 final1 final2 order match
  for
    step1 and step2 and
    final1 and final2 and
    load1 :: "'prog1 \<Rightarrow> 'state1 \<Rightarrow> bool" and
    load2 :: "'prog2 \<Rightarrow> 'state2 \<Rightarrow> bool" and
    order :: "'index \<Rightarrow> 'index \<Rightarrow> bool" and
    match +
  fixes
    compile :: "'prog1 \<Rightarrow> 'prog2 option"
  assumes
    compile_load:
      "compile p1 = Some p2 \<Longrightarrow> load2 p2 s2 \<Longrightarrow> \<exists>s1 i. load1 p1 s1 \<and> match i s1 s2"
begin

text \<open>
The @{locale compiler} locale relates two languages, L1 and L2, by a backward simulation and provides a @{term compile} partial function from a concrete program in L1 to a concrete program in L2.
The only assumption is that a successful compilation results in a program which, when loaded, is equivalent to the loaded initial program.
\<close>

subsection \<open>Preservation of behaviour\<close>

corollary behaviour_preservation:
  assumes
    compiles: "compile p1 = Some p2" and
    behaves: "L2.prog_behaves p2 b2" and
    not_wrong: "\<not> is_wrong b2"
  shows "\<exists>b1 i.  L1.prog_behaves p1 b1 \<and> rel_behaviour (match i) b1 b2"
proof -
  obtain s2 where "load2 p2 s2" and "L2.state_behaves s2 b2"
    using behaves L2.prog_behaves_def by auto
  obtain i s1 where "load1 p1 s1" "match i s1 s2"
    using compile_load[OF compiles \<open>load2 p2 s2\<close>]
    by auto
  then show ?thesis
    using simulation_behaviour[OF \<open>L2.state_behaves s2 b2\<close> not_wrong \<open>match i s1 s2\<close>]
    by (auto simp: L1.prog_behaves_def)
qed

end

subsection \<open>Composition of compilers\<close>

lemma compiler_composition:
  assumes
    "compiler step1 step2 final1 final2 load1 load2 order1 match1 compile1" and
    "compiler step2 step3 final2 final3 load2 load3 order2 match2 compile2"
  shows "compiler step1 step3 final1 final3 load1 load3
    (lex_prodp order1\<^sup>+\<^sup>+ order2) (rel_comp match1 match2) (compile2 \<Lleftarrow> compile1)"
proof (rule compiler.intro)
  show "language step1 final1"
    using assms(1)[THEN compiler.axioms(1)] .
next
  show "language step3 final3"
    using assms(2)[THEN compiler.axioms(2)] .
next
  show "backward_simulation step1 step3 final1 final3
     (lex_prodp order1\<^sup>+\<^sup>+ order2) (rel_comp match1 match2)"
    using backward_simulation_composition[OF assms[THEN compiler.axioms(3)]] .
next
  show "compiler_axioms load1 load3 (rel_comp match1 match2) (compile2 \<Lleftarrow> compile1)"
  proof unfold_locales
    fix p1 p3 s3
    assume
      compile: "(compile2 \<Lleftarrow> compile1) p1 = Some p3" and
      load: "load3 p3 s3"
    obtain p2 where c1: "compile1 p1 = Some p2" and c2: "compile2 p2 = Some p3"
      using compile by (auto simp: bind_eq_Some_conv option_comp_def)
    obtain s2 i' where l2: "load2 p2 s2" and "match2 i' s2 s3"
      using assms(2)[THEN compiler.compile_load, OF c2 load]
      by auto
    moreover obtain s1 i where "load1 p1 s1" and "match1 i s1 s2"
      using assms(1)[THEN compiler.compile_load, OF c1 l2]
      by auto
    ultimately show "\<exists>s1 i. load1 p1 s1 \<and> rel_comp match1 match2 i s1 s3"
      unfolding rel_comp_def by auto
  qed
qed

lemma compiler_composition_pow:
  assumes
    "compiler step step final final load load order match compile"
  shows "compiler step step final final load load
    (lexp order\<^sup>+\<^sup>+) (rel_comp_pow match) (option_comp_pow compile n)"
proof (induction n rule: option_comp_pow.induct)
  case 1
  show ?case
    using assms
    by (auto intro: compiler.axioms compiler.intro compiler_axioms.intro backward_simulation_pow)
next
  case 2
  show ?case
  proof (rule compiler.intro)
    show "compiler_axioms load load (rel_comp_pow match) (option_comp_pow compile (Suc 0))"
    proof unfold_locales
      fix p1 p2 s2
      assume
        "option_comp_pow compile (Suc 0) p1 = Some p2" and
        "load p2 s2"
      thus "\<exists>s1 i. load p1 s1 \<and> rel_comp_pow match i s1 s2"
        using compiler.compile_load[OF assms(1)]
        by (metis option_comp_pow.simps(2) rel_comp_pow.simps(2))
    qed
  qed (auto intro: assms compiler.axioms backward_simulation_pow)
next
  case (3 n')
  show ?case
  proof (rule compiler.intro)
    show "compiler_axioms load load (rel_comp_pow match) (option_comp_pow compile (Suc (Suc n')))"
    proof unfold_locales
      fix p1 p3 s3
      assume
        "option_comp_pow compile  (Suc (Suc n')) p1 = Some p3" and
        "load p3 s3"
      then obtain p2 where
        comp: "compile p1 = Some p2" and
        comp_IH: "option_comp_pow compile (Suc n') p2 = Some p3"
        by (auto simp: option_comp_def bind_eq_Some_conv)
      obtain s2 i' where "load p2 s2" and "rel_comp_pow match i' s2 s3"
        using compiler.compile_load[OF "3.IH" comp_IH \<open>load p3 s3\<close>]
        by auto
      moreover obtain s1 i where "load p1 s1" and "match i s1 s2"
        using compiler.compile_load[OF assms comp \<open>load p2 s2\<close>]
        by auto
      moreover have "rel_comp_pow match (i # i') s1 s3"
        using \<open>rel_comp_pow match i' s2 s3\<close> \<open>match i s1 s2\<close> rel_comp_pow.elims(2) by fastforce
      ultimately show "\<exists>s1 i. load p1 s1 \<and> rel_comp_pow match i s1 s3"
        by blast
    qed
  qed (auto intro: assms compiler.axioms backward_simulation_pow)
qed

end


theory NumberWang_IPv6
imports
  Word_Lib.Word_Lemmas
begin

section\<open>Helper Lemmas for Low-Level Operations on Machine Words\<close>
text\<open>Needed for IPv6 Syntax\<close>

lemma length_drop_bl: "length (dropWhile Not (to_bl (of_bl bs))) \<le> length bs"
proof -
  have length_takeWhile_Not_replicate_False:
    "length (takeWhile Not (replicate n False @ ls)) = n + length (takeWhile Not ls)"
  for n ls by(subst takeWhile_append2) simp+
  show ?thesis by(simp add: word_rep_drop dropWhile_eq_drop length_takeWhile_Not_replicate_False)
qed

lemma bl_drop_leading_zeros:
      "(of_bl:: bool list \<Rightarrow> 'a::len word) (dropWhile Not bs) =
       (of_bl:: bool list \<Rightarrow> 'a::len word) bs"
by(induction bs) simp_all

lemma bl_length_drop_bound: assumes "length (dropWhile Not bs) \<le> n"
  shows "length (dropWhile Not (to_bl ((of_bl:: bool list \<Rightarrow> 'a::len word) bs))) \<le> n"
proof -
  have bl_length_drop_twice:
      "length (dropWhile Not (to_bl ((of_bl:: bool list \<Rightarrow> 'a::len word) (dropWhile Not bs)))) =
       length (dropWhile Not (to_bl ((of_bl:: bool list \<Rightarrow> 'a::len word) bs)))"
    by(simp add: bl_drop_leading_zeros)
  from length_drop_bl
  have *: "length (dropWhile Not (to_bl ((of_bl:: bool list \<Rightarrow> 'a::len word) bs))) \<le> length (dropWhile Not bs)"
   apply(rule dual_order.trans)
   apply(subst bl_length_drop_twice)
   ..
  show ?thesis
  apply(rule order.trans, rule *)
  using assms by(simp)
qed

lemma length_drop_mask_outer: fixes ip::"'a::len word"
  shows "LENGTH('a) - n' = len \<Longrightarrow> length (dropWhile Not (to_bl (ip AND (mask n << n') >> n'))) \<le> len"
  apply(subst Word_Lemmas.word_and_mask_shiftl)
  apply(subst Word_Lib.shiftl_shiftr1)
   apply(simp; fail)
  apply(simp)
  apply(subst Word_Lib.and_mask)
  apply(simp add: word_size)
  apply(simp add: length_drop_mask)
  done
lemma length_drop_mask_inner: fixes ip::"'a::len word"
  shows "n \<le> LENGTH('a) - n' \<Longrightarrow> length (dropWhile Not (to_bl (ip AND (mask n << n') >> n'))) \<le> n"
  apply(subst Word_Lemmas.word_and_mask_shiftl)
  apply(subst Word_Lemmas.shiftl_shiftr3)
   apply(simp; fail)
  apply(simp)
  apply(simp add: word_size)
  apply(simp add: Word_Lemmas.mask_twice)
  apply(simp add: length_drop_mask)
  done

lemma mask128: "0xFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF = mask 128"
  by(simp add: mask_def)

(*-------------- things for ipv6 syntax round trip property two ------------------*)

(*n small, m large*)
lemma helper_masked_ucast_generic:
  fixes b::"16 word"
  assumes "n + 16 \<le> m" and "m < 128"
  shows "((ucast:: 16 word \<Rightarrow> 128 word) b << n) && (mask 16 << m) = 0"
proof -
  have "x < 2 ^ (m - n)" if mnh2: "x < 0x10000"
    for x::"128 word"
  proof -
    from assms(1) have mnh3: "16 \<le> m - n" by fastforce
    have power_2_16_nat: "(16::nat) \<le> n \<Longrightarrow> (65535::nat) < 2 ^ n" if a:"16 \<le> n"for n
    proof -
      have power2_rule: "a \<le> b \<Longrightarrow> (2::nat)^a \<le> 2 ^ b" for a b by fastforce
      show ?thesis
       apply(subgoal_tac "65536 \<le> 2 ^ n")
        apply(subst Nat.less_eq_Suc_le)
        apply(simp; fail)
       apply(subgoal_tac "(65536::nat) = 2^16")
        subgoal using power2_rule \<open>16 \<le> n\<close> by presburger
       by(simp)
    qed
    have "65536 = unat (65536::128 word)" by auto
    moreover from mnh2 have "unat x <  unat (65536::128 word)" by(rule Word.unat_mono)
    ultimately have x: "unat x < 65536" by simp
    with mnh3 have "unat x < 2 ^ (m - n)"
      apply(rule_tac b=65535 in Orderings.order_class.order.strict_trans1)
       apply(simp_all)
      using power_2_16_nat apply blast
      done
    with assms(2) show ?thesis by(subst word_less_nat_alt) simp
  qed
  hence mnhelper2: "(of_bl::bool list \<Rightarrow> 128 word) (to_bl b) < 2 ^ (m - n)"
    apply(subgoal_tac "(of_bl::bool list \<Rightarrow> 128 word) (to_bl b) < 2^(LENGTH(16))")
     apply(simp; fail)
    by(rule Word.of_bl_length_less) simp+
  have mnhelper3: "(of_bl::bool list \<Rightarrow> 128 word) (to_bl b) * 2 ^ n < 2 ^ m"
    apply(rule Word.div_lt_mult)
     apply(rule Word_Lemmas.word_less_two_pow_divI)
       using assms by(simp_all add: mnhelper2 Word_Lib.p2_gt_0)

  from assms show ?thesis
    apply(subst Word.ucast_bl)+
    apply(subst Word.shiftl_of_bl)
    apply(subst Word.of_bl_append)
    apply simp
    apply(subst Word_Lemmas.word_and_mask_shiftl)
    apply(subst Word_Lib.shiftr_div_2n_w)
     subgoal by(simp add: word_size; fail)
    apply(subst Word_Lemmas.word_div_less)
     subgoal by(rule mnhelper3)
    apply simp
    done
qed

lemma unat_of_bl_128_16_less_helper:
  fixes b::"16 word"
  shows "unat ((of_bl::bool list \<Rightarrow> 128 word) (to_bl b)) < 2^16"
proof -
  from Word.word_bl_Rep' have 1: "length (to_bl b) = 16" by simp
  have "unat ((of_bl::bool list \<Rightarrow> 128 word) (to_bl b)) < 2^(length (to_bl b))"
    by(fact Word_Lemmas.unat_of_bl_length)
  with 1 show ?thesis by auto
qed
lemma unat_of_bl_128_16_le_helper: "unat ((of_bl:: bool list \<Rightarrow> 128 word) (to_bl (b::16 word))) \<le> 65535"
proof -
  from unat_of_bl_128_16_less_helper[of b] have
    "unat ((of_bl:: bool list \<Rightarrow> 128 word) (to_bl b)) < 65536" by simp
  from Nat.Suc_leI[OF this] show ?thesis by simp
qed

(*reverse*)
 lemma helper_masked_ucast_reverse_generic:
   fixes b::"16 word"
   assumes "m + 16 \<le> n" and "n \<le> 128 - 16"
   shows "((ucast:: 16 word \<Rightarrow> 128 word) b << n) && (mask 16 << m) = 0"
 proof -

   have power_less_128_helper: "2 ^ n * unat ((of_bl::bool list \<Rightarrow> 128 word) (to_bl b)) < 2 ^ LENGTH(128)"
     if n: "n \<le> 128 - 16" for n
   proof -
     have help_mult: "n \<le> l \<Longrightarrow> 2 ^ n * x < 2 ^ l \<longleftrightarrow> x < 2 ^ (l - n)" for x::nat and l
       by (simp add: nat_mult_power_less_eq semiring_normalization_rules(7))
     from n show ?thesis
       apply(subst help_mult)
        subgoal by (simp)
       apply(rule order_less_le_trans)
        apply(rule unat_of_bl_128_16_less_helper)
       apply(rule Power.power_increasing)
        apply(simp_all)
       done
   qed

   have *: "2 ^ m * (2 ^ (n - m) * unat ((of_bl::bool list \<Rightarrow> 128 word) (to_bl b))) =
            2 ^ n * unat ((of_bl::bool list \<Rightarrow> 128 word) (to_bl b))"
   proof(cases "unat ((of_bl::bool list \<Rightarrow> 128 word) (to_bl b)) = 0")
   case True thus ?thesis by simp
   next
   case False
    have help_mult: "x \<noteq> 0 \<Longrightarrow> b * (c * x) = a * (x::nat)  \<longleftrightarrow> b * c = a" for x a b c by simp
    from assms show ?thesis
     apply(subst help_mult[OF False])
     apply(subst Power.monoid_mult_class.power_add[symmetric])
     apply(simp)
     done
   qed

  from assms have "unat ((2 ^ n)::128 word) * unat ((of_bl::bool list \<Rightarrow> 128 word) (to_bl b)) mod 2 ^ LENGTH(128) =
        2 ^ m * (2 ^ (n - m) * unat ((of_bl::bool list \<Rightarrow> 128 word) (to_bl b)) mod 2 ^ LENGTH(128))"
     apply(subst nat_mod_eq')
      subgoal apply(subst Aligned.unat_power_lower)
       subgoal by(simp; fail)
      subgoal by (rule power_less_128_helper) simp
      done
     apply(subst nat_mod_eq')
      subgoal by(rule power_less_128_helper) simp
     apply(subst Aligned.unat_power_lower)
      apply(simp; fail)
     apply(simp only: *)
     done
   hence ex_k: "\<exists>k. unat ((2 ^ n)::128 word) * unat ((of_bl::bool list \<Rightarrow> 128 word) (to_bl b)) mod 2 ^ LENGTH(128) = 2 ^ m * k"
     by blast

   hence aligned: "is_aligned ((of_bl::bool list \<Rightarrow> 128 word) (to_bl b) << n) m"
     unfolding is_aligned_def
     unfolding dvd_def
     unfolding Word.shiftl_t2n
     unfolding Word.unat_word_ariths(2)
     by assumption

   from assms have of_bl_to_bl_shift_mask: "((of_bl::bool list \<Rightarrow> 128 word) (to_bl b) << n) && mask (16 + m) = 0"
    using is_aligned_mask is_aligned_shiftl by force (*sledgehammer*)

   show ?thesis
    apply(subst Word.ucast_bl)+
    apply(subst Word_Lemmas.word_and_mask_shiftl)
    apply(subst Aligned.aligned_shiftr_mask_shiftl)
     subgoal by (fact aligned)
    subgoal by (fact of_bl_to_bl_shift_mask)
    done
qed

lemma helper_masked_ucast_equal_generic:
  fixes b::"16 word"
  assumes "n \<le> 128 - 16"
  shows "ucast (((ucast:: 16 word \<Rightarrow> 128 word) b << n) && (mask 16 << n) >> n) = b"
proof -
 have ucast_mask: "(ucast:: 16 word \<Rightarrow> 128 word) b && mask 16 = ucast b"
  apply(subst Word_Lib.and_mask_eq_iff_le_mask)
  apply(subst Word.ucast_bl)
  apply(simp add: mask_def)
  thm Word.word_uint_eqI word_le_nat_alt
  apply(subst word_le_nat_alt)
  apply(simp)
  using unat_of_bl_128_16_le_helper by simp

 from assms have "ucast (((ucast:: 16 word \<Rightarrow> 128 word) b && mask (128 - n) && mask 16) && mask (128 - n)) = b"
  apply(subst Word_Lemmas.mask_and_mask)
  apply(simp)
  apply(subst Word.word_bool_alg.conj.assoc)
  apply(subst Word_Lemmas.mask_and_mask)
  apply(simp)
  apply(simp add: ucast_mask Word_Lemmas.ucast_ucast_mask)
  apply(subst Word.mask_eq_iff)
  apply(rule order_less_trans)
   apply(rule Word.uint_lt)
  apply(simp; fail)
  done

 thus ?thesis
  apply(subst Word_Lemmas.word_and_mask_shiftl)
  apply(subst Word_Lemmas.shiftl_shiftr3)
   apply(simp; fail)
  apply(simp)
  apply(subst Word_Lemmas.shiftl_shiftr3)
   apply(simp; fail)
  apply(simp add: word_size)
  apply(subst Word.word_bool_alg.conj.assoc)
  apply assumption
  done
qed

end


(*  Title:      ZF/UNITY/Distributor.thy
    Author:     Sidi O Ehmety, Cambridge University Computer Laboratory
    Copyright   2002  University of Cambridge

A multiple-client allocator from a single-client allocator:
Distributor specification.
*)

theory Distributor imports AllocBase Follows  Guar GenPrefix begin

text\<open>Distributor specification (the number of outputs is Nclients)\<close>

text\<open>spec (14)\<close>

definition
  distr_follows :: "[i, i, i, i \<Rightarrow>i] \<Rightarrow>i"  where
    "distr_follows(A, In, iIn, Out) \<equiv>
     (lift(In) IncreasingWrt prefix(A)/list(A)) \<inter>
     (lift(iIn) IncreasingWrt prefix(nat)/list(nat)) \<inter>
     Always({s \<in> state. \<forall>elt \<in> set_of_list(s`iIn). elt < Nclients})
         guarantees
         (\<Inter>n \<in> Nclients.
          lift(Out(n))
              Fols
          (\<lambda>s. sublist(s`In, {k \<in> nat. k<length(s`iIn) \<and> nth(k, s`iIn) = n}))
          Wrt prefix(A)/list(A))"

definition
  distr_allowed_acts :: "[i\<Rightarrow>i]\<Rightarrow>i"  where
    "distr_allowed_acts(Out) \<equiv>
     {D \<in> program. AllowedActs(D) =
     cons(id(state), \<Union>G \<in> (\<Inter>n\<in>nat. preserves(lift(Out(n)))). Acts(G))}"

definition
  distr_spec :: "[i, i, i, i \<Rightarrow>i]\<Rightarrow>i"  where
    "distr_spec(A, In, iIn, Out) \<equiv>
     distr_follows(A, In, iIn, Out) \<inter> distr_allowed_acts(Out)"

locale distr =
  fixes In  \<comment> \<open>items to distribute\<close>
    and iIn \<comment> \<open>destinations of items to distribute\<close>
    and Out \<comment> \<open>distributed items\<close>
    and A   \<comment> \<open>the type of items being distributed\<close>
    and D
 assumes
     var_assumes [simp]:  "In \<in> var \<and> iIn \<in> var \<and> (\<forall>n. Out(n):var)"
 and all_distinct_vars:   "\<forall>n. all_distinct([In, iIn, Out(n)])"
 and type_assumes [simp]: "type_of(In)=list(A) \<and>  type_of(iIn)=list(nat) \<and>
                          (\<forall>n. type_of(Out(n))=list(A))"
 and default_val_assumes [simp]:
                         "default_val(In)=Nil \<and>
                          default_val(iIn)=Nil \<and>
                          (\<forall>n. default_val(Out(n))=Nil)"
 and distr_spec:  "D \<in> distr_spec(A, In, iIn, Out)"

lemma (in distr) In_value_type [simp,TC]: "s \<in> state \<Longrightarrow> s`In \<in> list(A)"
  unfolding state_def
apply (drule_tac a = In in apply_type, auto)
done

lemma (in distr) iIn_value_type [simp,TC]:
     "s \<in> state \<Longrightarrow> s`iIn \<in> list(nat)"
  unfolding state_def
apply (drule_tac a = iIn in apply_type, auto)
done

lemma (in distr) Out_value_type [simp,TC]:
     "s \<in> state \<Longrightarrow> s`Out(n):list(A)"
  unfolding state_def
apply (drule_tac a = "Out (n)" in apply_type)
apply auto
done

lemma (in distr) D_in_program [simp,TC]: "D \<in> program"
apply (cut_tac distr_spec)
apply (auto simp add: distr_spec_def distr_allowed_acts_def)
done

lemma (in distr) D_ok_iff:
     "G \<in> program \<Longrightarrow>
        D ok G \<longleftrightarrow> ((\<forall>n \<in> nat. G \<in> preserves(lift(Out(n)))) \<and> D \<in> Allowed(G))"
apply (cut_tac distr_spec)
apply (auto simp add: INT_iff distr_spec_def distr_allowed_acts_def
                      Allowed_def ok_iff_Allowed)
apply (drule safety_prop_Acts_iff [THEN [2] rev_iffD1])
apply (auto intro: safety_prop_Inter)
done

lemma (in distr) distr_Increasing_Out:
"D \<in> ((lift(In) IncreasingWrt prefix(A)/list(A)) \<inter>
      (lift(iIn) IncreasingWrt prefix(nat)/list(nat)) \<inter>
      Always({s \<in> state. \<forall>elt \<in> set_of_list(s`iIn). elt<Nclients}))
      guarantees
          (\<Inter>n \<in> Nclients. lift(Out(n)) IncreasingWrt
                            prefix(A)/list(A))"
apply (cut_tac D_in_program distr_spec)
apply (simp (no_asm_use) add: distr_spec_def distr_follows_def)
apply (auto intro!: guaranteesI intro: Follows_imp_Increasing_left
            dest!: guaranteesD)
done

lemma (in distr) distr_bag_Follows_lemma:
"\<lbrakk>\<forall>n \<in> nat. G \<in> preserves(lift(Out(n)));
   D \<squnion> G \<in> Always({s \<in> state.
          \<forall>elt \<in> set_of_list(s`iIn). elt < Nclients})\<rbrakk>
  \<Longrightarrow> D \<squnion> G \<in> Always
          ({s \<in> state. msetsum(\<lambda>n. bag_of (sublist(s`In,
                       {k \<in> nat. k < length(s`iIn) \<and>
                          nth(k, s`iIn)= n})),
                         Nclients, A) =
              bag_of(sublist(s`In, length(s`iIn)))})"
apply (cut_tac D_in_program)
apply (subgoal_tac "G \<in> program")
 prefer 2 apply (blast dest: preserves_type [THEN subsetD])
apply (erule Always_Diff_Un_eq [THEN iffD1])
apply (rule state_AlwaysI [THEN Always_weaken], auto)
apply (rename_tac s)
apply (subst bag_of_sublist_UN_disjoint [symmetric])
   apply (simp (no_asm_simp) add: nat_into_Finite)
  apply blast
 apply (simp (no_asm_simp))
apply (simp add: set_of_list_conv_nth [of _ nat])
apply (subgoal_tac
       "(\<Union>i \<in> Nclients. {k\<in>nat. k < length(s`iIn) \<and> nth(k, s`iIn) = i}) =
        length(s`iIn) ")
apply (simp (no_asm_simp))
apply (rule equalityI)
apply (force simp add: ltD, safe)
apply (rename_tac m)
apply (subgoal_tac "length (s ` iIn) \<in> nat")
apply typecheck
apply (subgoal_tac "m \<in> nat")
apply (drule_tac x = "nth(m, s`iIn) " and P = "\<lambda>elt. X (elt) \<longrightarrow> elt<Nclients" for X in bspec)
apply (simp add: ltI)
apply (simp_all add: Ord_mem_iff_lt)
apply (blast dest: ltD)
apply (blast intro: lt_trans)
done

theorem (in distr) distr_bag_Follows:
 "D \<in> ((lift(In) IncreasingWrt prefix(A)/list(A)) \<inter>
       (lift(iIn) IncreasingWrt prefix(nat)/list(nat)) \<inter>
        Always({s \<in> state. \<forall>elt \<in> set_of_list(s`iIn). elt < Nclients}))
      guarantees
       (\<Inter>n \<in> Nclients.
        (\<lambda>s. msetsum(\<lambda>i. bag_of(s`Out(i)),  Nclients, A))
        Fols
        (\<lambda>s. bag_of(sublist(s`In, length(s`iIn))))
        Wrt MultLe(A, r)/Mult(A))"
apply (cut_tac distr_spec)
apply (rule guaranteesI, clarify)
apply (rule distr_bag_Follows_lemma [THEN Always_Follows2])
apply (simp add: D_ok_iff, auto)
apply (rule Follows_state_ofD1)
apply (rule Follows_msetsum_UN)
   apply (simp_all add: nat_into_Finite bag_of_multiset [of _ A])
apply (auto simp add: distr_spec_def distr_follows_def)
apply (drule guaranteesD, assumption)
apply (simp_all cong add: Follows_cong
                add: refl_prefix
                   mono_bag_of [THEN subset_Follows_comp, THEN subsetD,
                                unfolded metacomp_def])
done

end