(*
   File:      Analysis/Simplex_Content.thy
   Author:    Manuel Eberl <eberlm@in.tum.de>

   The content of an n-dimensional simplex, including the formula for the content of a
   triangle and Heron's formula.
*)
section \<open>Volume of a Simplex\<close>

theory Simplex_Content
imports Change_Of_Vars
begin

lemma fact_neq_top_ennreal [simp]: "fact n \<noteq> (top :: ennreal)"
  by (induction n) (auto simp: ennreal_mult_eq_top_iff)

lemma ennreal_fact: "ennreal (fact n) = fact n"
  by (induction n) (auto simp: ennreal_mult algebra_simps ennreal_of_nat_eq_real_of_nat)

context
  fixes S :: "'a set \<Rightarrow> real \<Rightarrow> ('a \<Rightarrow> real) set"
  defines "S \<equiv> (\<lambda>A t. {x. (\<forall>i\<in>A. 0 \<le> x i) \<and> sum x A \<le> t})"
begin

lemma emeasure_std_simplex_aux_step:
  assumes "b \<notin> A" "finite A"
  shows   "x(b := y) \<in> S (insert b A) t \<longleftrightarrow> y \<in> {0..t} \<and> x \<in> S A (t - y)"
  using assms sum_nonneg[of A x] unfolding S_def
  by (force simp: sum_delta_notmem algebra_simps)

lemma emeasure_std_simplex_aux:
  fixes t :: real
  assumes "finite (A :: 'a set)" "t \<ge> 0"
  shows   "emeasure (Pi\<^sub>M A (\<lambda>_. lborel))
             (S A t \<inter> space (Pi\<^sub>M A (\<lambda>_. lborel))) = t ^ card A / fact (card A)"
  using assms(1,2)
proof (induction arbitrary: t rule: finite_induct)
  case (empty t)
  thus ?case by (simp add: PiM_empty S_def)
next
  case (insert b A t)
  define n where "n = Suc (card A)"
  have n_pos: "n > 0" by (simp add: n_def)
  let ?M = "\<lambda>A. (Pi\<^sub>M A (\<lambda>_. lborel))"
  {
    fix A :: "'a set" and t :: real assume "finite A"
    have "S A t \<inter> space (Pi\<^sub>M A (\<lambda>_. lborel)) =
            Pi\<^sub>E A (\<lambda>_. {0..}) \<inter> (\<lambda>x. sum x A) -` {..t} \<inter> space (Pi\<^sub>M A (\<lambda>_. lborel))"
      by (auto simp: S_def space_PiM)
    also have "\<dots> \<in> sets (Pi\<^sub>M A (\<lambda>_. lborel))"
      using \<open>finite A\<close> by measurable
    finally have "S A t \<inter> space (Pi\<^sub>M A (\<lambda>_. lborel)) \<in> sets (Pi\<^sub>M A (\<lambda>_. lborel))" .
  } note meas [measurable] = this

  interpret product_sigma_finite "\<lambda>_. lborel"
    by standard
  have "emeasure (?M (insert b A)) (S (insert b A) t \<inter> space (?M (insert b A))) =
        nn_integral (?M (insert b A))
          (\<lambda>x. indicator (S (insert b A) t \<inter> space (?M (insert b A))) x)"
    using insert.hyps by (subst nn_integral_indicator) auto
  also have "\<dots> = (\<integral>\<^sup>+ y. \<integral>\<^sup>+ x. indicator (S (insert b A) t \<inter> space (?M (insert b A)))
                    (x(b := y)) \<partial>?M A \<partial>lborel)"
    using insert.prems insert.hyps by (intro product_nn_integral_insert_rev) auto
  also have "\<dots> = (\<integral>\<^sup>+ y. \<integral>\<^sup>+ x. indicator {0..t} y * indicator (S A (t - y) \<inter> space (?M A)) x
                    \<partial>?M A \<partial>lborel)"
    using insert.hyps insert.prems emeasure_std_simplex_aux_step[of b A]
    by (intro nn_integral_cong)
       (auto simp: fun_eq_iff indicator_def space_PiM PiE_def extensional_def)
  also have "\<dots> = (\<integral>\<^sup>+ y. indicator {0..t} y * (\<integral>\<^sup>+ x. indicator (S A (t - y) \<inter> space (?M A)) x
                    \<partial>?M A) \<partial>lborel)" using \<open>finite A\<close>
    by (subst nn_integral_cmult) auto
  also have "\<dots> = (\<integral>\<^sup>+ y. indicator {0..t} y * emeasure (?M A) (S A (t - y) \<inter> space (?M A)) \<partial>lborel)"
    using \<open>finite A\<close> by (subst nn_integral_indicator) auto
  also have "\<dots> = (\<integral>\<^sup>+ y. indicator {0..t} y * (t - y) ^ card A / ennreal (fact (card A)) \<partial>lborel)"
    using insert.IH by (intro nn_integral_cong) (auto simp: indicator_def divide_ennreal)
  also have "\<dots> = (\<integral>\<^sup>+ y. indicator {0..t} y * (t - y) ^ card A \<partial>lborel) / ennreal (fact (card A))"
    using \<open>finite A\<close> by (subst nn_integral_divide) auto
  also have "(\<integral>\<^sup>+ y. indicator {0..t} y * (t - y) ^ card A \<partial>lborel) =
               (\<integral>\<^sup>+y\<in>{0..t}. ennreal ((t - y) ^ (n - 1)) \<partial>lborel)"
    by (intro nn_integral_cong) (auto simp: indicator_def n_def)
  also have "((\<lambda>x. - ((t - x) ^ n / n)) has_real_derivative (t - x) ^ (n - 1)) (at x)"
    if "x \<in> {0..t}" for x by (rule derivative_eq_intros refl | simp add: n_pos)+
  hence "(\<integral>\<^sup>+y\<in>{0..t}. ennreal ((t - y) ^ (n - 1)) \<partial>lborel) =
           ennreal (-((t - t) ^ n / n) - (-((t - 0) ^ n / n)))"
    using insert.prems insert.hyps by (intro nn_integral_FTC_Icc) auto
  also have "\<dots> = ennreal (t ^ n / n)" using n_pos by (simp add: zero_power)
  also have "\<dots> / ennreal (fact (card A)) = ennreal (t ^ n / n / fact (card A))"
    using n_pos \<open>t \<ge> 0\<close> by (subst divide_ennreal) auto
  also have "t ^ n / n / fact (card A) = t ^ n / fact n"
    by (simp add: n_def)
  also have "n = card (insert b A)"
    using insert.hyps by (subst card_insert) (auto simp: n_def)
  finally show ?case .
qed

end

lemma emeasure_std_simplex:
  "emeasure lborel (convex hull (insert 0 Basis :: 'a :: euclidean_space set)) =
     ennreal (1 / fact DIM('a))"
proof -
  have "emeasure lborel {x::'a. (\<forall>i\<in>Basis. 0 \<le> x \<bullet> i) \<and> sum ((\<bullet>) x) Basis \<le> 1} =
               emeasure (distr (Pi\<^sub>M Basis (\<lambda>b. lborel)) borel (\<lambda>f. \<Sum>b\<in>Basis. f b *\<^sub>R b))
                 {x::'a. (\<forall>i\<in>Basis. 0 \<le> x \<bullet> i) \<and> sum ((\<bullet>) x) Basis \<le> 1}"
    by (subst lborel_eq) simp
  also have "\<dots> = emeasure (Pi\<^sub>M Basis (\<lambda>b. lborel))
                    ({y::'a \<Rightarrow> real. (\<forall>i\<in>Basis. 0 \<le> y i) \<and> sum y Basis \<le> 1} \<inter>
                      space (Pi\<^sub>M Basis (\<lambda>b. lborel)))"
    by (subst emeasure_distr) auto
  also have "\<dots> = ennreal (1 / fact DIM('a))"
    by (subst emeasure_std_simplex_aux) auto
  finally show ?thesis by (simp only: std_simplex)
qed

theorem content_std_simplex:
  "measure lborel (convex hull (insert 0 Basis :: 'a :: euclidean_space set)) =
     1 / fact DIM('a)"
  by (simp add: measure_def emeasure_std_simplex)

(* TODO: move to Change_of_Vars *)
proposition measure_lebesgue_linear_transformation:
  fixes A :: "(real ^ 'n :: {finite, wellorder}) set"
  fixes f :: "_ \<Rightarrow> real ^ 'n :: {finite, wellorder}"
  assumes "bounded A" "A \<in> sets lebesgue" "linear f"
  shows   "measure lebesgue (f ` A) = \<bar>det (matrix f)\<bar> * measure lebesgue A"
proof -
  from assms have [intro]: "A \<in> lmeasurable"
    by (intro bounded_set_imp_lmeasurable) auto
  hence [intro]: "f ` A \<in> lmeasurable"
    by (intro lmeasure_integral measurable_linear_image assms)
  have "measure lebesgue (f ` A) = integral (f ` A) (\<lambda>_. 1)"
    by (intro lmeasure_integral measurable_linear_image assms) auto
  also have "\<dots> = integral (f ` A) (\<lambda>_. 1 :: real ^ 1) $ 0"
    by (subst integral_component_eq_cart [symmetric]) (auto intro: integrable_on_const)
  also have "\<dots> = \<bar>det (matrix f)\<bar> * integral A (\<lambda>x. 1 :: real ^ 1) $ 0"
    using assms
    by (subst integral_change_of_variables_linear)
       (auto simp: o_def absolutely_integrable_on_def intro: integrable_on_const)
  also have "integral A (\<lambda>x. 1 :: real ^ 1) $ 0 = integral A (\<lambda>x. 1)"
    by (subst integral_component_eq_cart [symmetric]) (auto intro: integrable_on_const)
  also have "\<dots> = measure lebesgue A"
    by (intro lmeasure_integral [symmetric]) auto
  finally show ?thesis .
qed

theorem content_simplex:
  fixes X :: "(real ^ 'n :: {finite, wellorder}) set" and f :: "'n :: _ \<Rightarrow> real ^ ('n :: _)"
  assumes "finite X" "card X = Suc CARD('n)" and x0: "x0 \<in> X" and bij: "bij_betw f UNIV (X - {x0})"
  defines "M \<equiv> (\<chi> i. \<chi> j. f j $ i - x0 $ i)"
  shows "content (convex hull X) = \<bar>det M\<bar> / fact (CARD('n))"
proof -
  define g where "g = (\<lambda>x. M *v x)"
  have [simp]: "M *v axis i 1 = f i - x0" for i :: 'n
    by (simp add: M_def matrix_vector_mult_basis column_def vec_eq_iff)
  define std where "std = (convex hull insert 0 Basis :: (real ^ 'n :: _) set)"
  have compact: "compact std" unfolding std_def
    by (intro finite_imp_compact_convex_hull) auto

  have "measure lebesgue (convex hull X) = measure lebesgue (((+) (-x0)) ` (convex hull X))"
    by (rule measure_translation [symmetric])
  also have "((+) (-x0)) ` (convex hull X) = convex hull (((+) (-x0)) ` X)"
    by (rule convex_hull_translation [symmetric])
  also have "((+) (-x0)) ` X = insert 0 ((\<lambda>x. x - x0) ` (X - {x0}))"
    using x0 by (auto simp: image_iff)
  finally have eq: "measure lebesgue (convex hull X) = measure lebesgue (convex hull \<dots>)" .

  from compact have "measure lebesgue (g ` std) = \<bar>det M\<bar> * measure lebesgue std"
    by (subst measure_lebesgue_linear_transformation)
       (auto intro: finite_imp_bounded_convex_hull dest: compact_imp_closed simp: g_def std_def)
  also have "measure lebesgue std = content std" using compact
    by (intro measure_completion) (auto dest: compact_imp_closed)
  also have "content std = 1 / fact CARD('n)" unfolding std_def
    by (simp add: content_std_simplex)
  also have "g ` std = convex hull (g ` insert 0 Basis)" unfolding std_def
    by (rule convex_hull_linear_image) (auto simp: g_def)
  also have "g ` insert 0 Basis = insert 0 (g ` Basis)"
    by (auto simp: g_def)
  also have "g ` Basis = (\<lambda>x. x - x0) ` range f"
    by (auto simp: g_def Basis_vec_def image_iff)
  also have "range f = X - {x0}" using bij
    using bij_betw_imp_surj_on by blast
  also note eq [symmetric]
  finally show ?thesis
    using finite_imp_compact_convex_hull[OF \<open>finite X\<close>] by (auto dest: compact_imp_closed)
qed

theorem content_triangle:
  fixes A B C :: "real ^ 2"
  shows "content (convex hull {A, B, C}) =
           \<bar>(C $ 1 - A $ 1) * (B $ 2 - A $ 2) - (B $ 1 - A $ 1) * (C $ 2 - A $ 2)\<bar> / 2"
proof -
  define M :: "real ^ 2 ^ 2" where "M \<equiv> (\<chi> i. \<chi> j. (if j = 1 then B else C) $ i - A $ i)"
  define g where "g = (\<lambda>x. M *v x)"
  define std where "std = (convex hull insert 0 Basis :: (real ^ 2) set)"
  have [simp]: "M *v axis i 1 = (if i = 1 then B - A else C - A)" for i
    by (auto simp: M_def matrix_vector_mult_basis column_def vec_eq_iff)
  have compact: "compact std" unfolding std_def
    by (intro finite_imp_compact_convex_hull) auto

  have "measure lebesgue (convex hull {A, B, C}) =
          measure lebesgue (((+) (-A)) ` (convex hull {A, B, C}))"
    by (rule measure_translation [symmetric])
  also have "((+) (-A)) ` (convex hull {A, B, C}) = convex hull (((+) (-A)) ` {A, B, C})"
    by (rule convex_hull_translation [symmetric])
  also have "((+) (-A)) ` {A, B, C} = {0, B - A, C - A}"
    by (auto simp: image_iff)
  finally have eq: "measure lebesgue (convex hull {A, B, C}) =
                      measure lebesgue (convex hull {0, B - A, C - A})" .

  from compact have "measure lebesgue (g ` std) = \<bar>det M\<bar> * measure lebesgue std"
    by (subst measure_lebesgue_linear_transformation)
       (auto intro: finite_imp_bounded_convex_hull dest: compact_imp_closed simp: g_def std_def)
  also have "measure lebesgue std = content std" using compact
    by (intro measure_completion) (auto dest: compact_imp_closed)
  also have "content std = 1 / 2" unfolding std_def
    by (simp add: content_std_simplex)
  also have "g ` std = convex hull (g ` insert 0 Basis)" unfolding std_def
    by (rule convex_hull_linear_image) (auto simp: g_def)
  also have "g ` insert 0 Basis = insert 0 (g ` Basis)"
    by (auto simp: g_def)
  also have "(2 :: 2) \<noteq> 1" by auto
  hence "\<not>(\<forall>y::2. y = 1)" by blast
  hence "g ` Basis = {B - A, C - A}"
    by (auto simp: g_def Basis_vec_def image_iff)
  also note eq [symmetric]
  finally show ?thesis
    using finite_imp_compact_convex_hull[of "{A, B, C}"]
    by (auto dest!: compact_imp_closed simp: det_2 M_def)
qed

theorem heron:
  fixes A B C :: "real ^ 2"
  defines "a \<equiv> dist B C" and "b \<equiv> dist A C" and "c \<equiv> dist A B"
  defines "s \<equiv> (a + b + c) / 2"
  shows   "content (convex hull {A, B, C}) = sqrt (s * (s - a) * (s - b) * (s - c))"
proof -
  have [simp]: "(UNIV :: 2 set) = {1, 2}"
    using exhaust_2 by auto
  have dist_eq: "dist (A :: real ^ 2) B ^ 2 = (A $ 1 - B $ 1) ^ 2 + (A $ 2 - B $ 2) ^ 2"
    for A B by (simp add: dist_vec_def dist_real_def)
  have nonneg: "s * (s - a) * (s - b) * (s - c) \<ge> 0"
    using dist_triangle[of A B C] dist_triangle[of A C B] dist_triangle[of B C A]
    by (intro mult_nonneg_nonneg) (auto simp: s_def a_def b_def c_def dist_commute)

  have "16 * content (convex hull {A, B, C}) ^ 2 =
          4 * ((C $ 1 - A $ 1) * (B $ 2 - A $ 2) - (B $ 1 - A $ 1) * (C $ 2 - A $ 2)) ^ 2"
    by (subst content_triangle) (simp add: power_divide)
  also have "\<dots> = (2 * (dist A B ^ 2 * dist A C ^ 2 + dist A B ^ 2 * dist B C ^ 2 +
      dist A C ^ 2 * dist B C ^ 2) - (dist A B ^ 2) ^ 2 - (dist A C ^ 2) ^ 2 - (dist B C ^ 2) ^ 2)"
    unfolding dist_eq unfolding power2_eq_square by algebra
  also have "\<dots> = (a + b + c) * ((a + b + c) - 2 * a) * ((a + b + c) - 2 * b) *
                    ((a + b + c) - 2 * c)"
    unfolding power2_eq_square by (simp add: s_def a_def b_def c_def algebra_simps)
  also have "\<dots> = 16 * s * (s - a) * (s - b) * (s - c)"
    by (simp add: s_def field_split_simps)
  finally have "content (convex hull {A, B, C}) ^ 2 = s * (s - a) * (s - b) * (s - c)"
    by simp
  also have "\<dots> = sqrt (s * (s - a) * (s - b) * (s - c)) ^ 2"
    by (intro real_sqrt_pow2 [symmetric] nonneg)
  finally show ?thesis using nonneg
    by (subst (asm) power2_eq_iff_nonneg) auto
qed

end


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

section\<open>Strong Eventual Consistency\<close>

text\<open>In this section we formalise the notion of strong eventual consistency.
     We do not make any assumptions about networks or data structures; instead,
     we use an abstract model of operations that may be reordered, and we reason about
    the properties that those operations must satisfy.
    We then provide concrete implementations of that abstract model in later sections.\<close>

theory
  Convergence
imports
  Util
begin

text\<open>The \emph{happens-before} relation, as introduced by \<^cite>\<open>"Lamport:1978jq"\<close>, captures
     causal dependencies between operations. It can be defined in terms of sending and receiving
     messages on a network.
     However, for now, we keep it abstract, our only restriction on the happens-before relation is
     that it must be a \emph{strict partial order},
     that is, it must be irreflexive and transitive, which implies that it is also antisymmetric.
     We describe the state of a node using an abstract type variable.
     To model state changes, we assume the existence of an \emph{interpretation} function \isa{interp}
     which lifts an operation into a \emph{state transformer}---a function that either maps
     an old state to a new state, or fails.\<close>

locale happens_before = preorder hb_weak hb
  for hb_weak :: "'a \<Rightarrow> 'a \<Rightarrow> bool"  (infix "\<preceq>" 50)
  and hb :: "'a \<Rightarrow> 'a \<Rightarrow> bool"       (infix "\<prec>" 50) +
  fixes interp :: "'a \<Rightarrow> 'b \<rightharpoonup> 'b" ("\<langle>_\<rangle>" [0] 1000)
begin

(*************************************************************************)
subsection\<open>Concurrent operations\<close>
(*************************************************************************)

text\<open>We say that two operations $x$ and $y$ are \emph{concurrent}, written
    $\isa{x} \mathbin{\isasymparallel} \isa{y}$, whenever one does not happen before the other:
    $\neg (\isa{x} \prec \isa{y})$ and $\neg (\isa{y} \prec \isa{x})$.\<close>

definition concurrent :: "'a \<Rightarrow> 'a \<Rightarrow> bool" (infix "\<parallel>" 50) where
  "s1 \<parallel> s2 \<equiv> \<not> (s1 \<prec> s2) \<and> \<not> (s2 \<prec> s1)"

lemma concurrentI [intro!]: "\<not> (s1 \<prec> s2) \<Longrightarrow> \<not> (s2 \<prec> s1) \<Longrightarrow> s1 \<parallel> s2"
  by (auto simp: concurrent_def)

lemma concurrentD1 [dest]: "s1 \<parallel> s2 \<Longrightarrow> \<not> (s1 \<prec> s2)"
  by (auto simp: concurrent_def)

lemma concurrentD2 [dest]: "s1 \<parallel> s2 \<Longrightarrow> \<not> (s2 \<prec> s1)"
  by (auto simp: concurrent_def)

lemma concurrent_refl [intro!, simp]: "s \<parallel> s"
  by (auto simp: concurrent_def)

lemma concurrent_comm: "s1 \<parallel> s2 \<longleftrightarrow> s2 \<parallel> s1"
  by (auto simp: concurrent_def)

definition concurrent_set :: "'a \<Rightarrow> 'a list \<Rightarrow> bool" where
  "concurrent_set x xs \<equiv> \<forall>y \<in> set xs. x \<parallel> y"

lemma concurrent_set_empty [simp, intro!]:
  "concurrent_set x []"
  by (auto simp: concurrent_set_def)

lemma concurrent_set_ConsE [elim!]:
  assumes "concurrent_set a (x#xs)"
      and "concurrent_set a xs \<Longrightarrow> concurrent x a \<Longrightarrow> G"
    shows "G"
  using assms by (auto simp: concurrent_set_def)

lemma concurrent_set_ConsI [intro!]:
  "concurrent_set a xs \<Longrightarrow> concurrent a x \<Longrightarrow> concurrent_set a (x#xs)"
  by (auto simp: concurrent_set_def)

lemma concurrent_set_appendI [intro!]:
  "concurrent_set a xs \<Longrightarrow> concurrent_set a ys \<Longrightarrow> concurrent_set a (xs@ys)"
  by (auto simp: concurrent_set_def)

lemma concurrent_set_Cons_Snoc [simp]:
  "concurrent_set a (xs@[x]) = concurrent_set a (x#xs)"
  by (auto simp: concurrent_set_def)

(*************************************************************************)
subsection\<open>Happens-before consistency\<close>
(*************************************************************************)

text\<open>The purpose of the happens-before relation is to require that some operations must be applied
     in a particular order, while allowing concurrent operations to be reordered with respect to each other.
     We assume that each node applies operations in some sequential order (a standard assumption
     for distributed algorithms), and so we can model the execution history of a node as a list of operations.\<close>

inductive hb_consistent :: "'a list \<Rightarrow> bool" where
  [intro!]: "hb_consistent []" |
  [intro!]: "\<lbrakk> hb_consistent xs; \<forall>x \<in> set xs. \<not> y \<prec> x \<rbrakk> \<Longrightarrow> hb_consistent (xs @ [y])"

text\<open>As a result, whenever two operations $\isa{x}$ and $\isa{y}$ appear in a hb-consistent list,
     and $\isa{x}\prec\isa{y}$, then $\isa{x}$ must appear before $\isa{y}$ in the list.
     However, if $\isa{x}\mathbin{\isasymparallel}\isa{y}$, the operations can appear in the list
     in either order.\<close>

lemma "(x \<prec> y \<or> concurrent x y) = (\<not> y \<prec> x)"
  using less_asym by blast

lemma consistentI [intro!]:
  assumes "hb_consistent (xs @ ys)"
  and     "\<forall>x \<in> set (xs @ ys). \<not> z \<prec> x"
  shows   "hb_consistent (xs @ ys @ [z])"
  using assms hb_consistent.intros append_assoc by metis

inductive_cases  hb_consistent_elim [elim]:
  "hb_consistent []"
  "hb_consistent (xs@[y])"
  "hb_consistent (xs@ys)"
  "hb_consistent (xs@ys@[z])"

inductive_cases  hb_consistent_elim_gen:
  "hb_consistent zs"

lemma hb_consistent_append_D1 [dest]:
  assumes "hb_consistent (xs @ ys)"
  shows   "hb_consistent xs"
  using assms by(induction ys arbitrary: xs rule: List.rev_induct) auto

lemma hb_consistent_append_D2 [dest]:
  assumes "hb_consistent (xs @ ys)"
  shows   "hb_consistent ys"
  using assms by(induction ys arbitrary: xs rule: List.rev_induct) fastforce+

lemma hb_consistent_append_elim_ConsD [elim]:
  assumes "hb_consistent (y#ys)"
  shows   "hb_consistent ys"
  using assms hb_consistent_append_D2 by(metis append_Cons append_Nil)

lemma hb_consistent_remove1 [intro]:
  assumes "hb_consistent xs"
  shows   "hb_consistent (remove1 x xs)"
  using assms by (induction rule: hb_consistent.induct) (auto simp: remove1_append)

lemma hb_consistent_singleton [intro!]:
  shows "hb_consistent [x]"
  using hb_consistent.intros by fastforce

lemma hb_consistent_prefix_suffix_exists:
  assumes "hb_consistent ys"
          "hb_consistent (xs @ [x])"
          "{x} \<union> set xs = set ys"
          "distinct (x#xs)"
          "distinct ys"
  shows "\<exists>prefix suffix. ys = prefix @ x # suffix \<and> concurrent_set x suffix"
using assms proof (induction arbitrary: xs rule: hb_consistent.induct, simp)
  fix xs y ys
  assume IH: "(\<And>xs. hb_consistent (xs @ [x]) \<Longrightarrow>
               {x} \<union> set xs = set ys \<Longrightarrow>
               distinct (x # xs) \<Longrightarrow> distinct ys \<Longrightarrow>
             \<exists>prefix suffix. ys = prefix @ x # suffix \<and> concurrent_set x suffix) "
  assume assms: "hb_consistent ys" "\<forall>x\<in>set ys. \<not> hb y x"
                "hb_consistent (xs @ [x])"
                "{x} \<union> set xs = set (ys @ [y])"
                "distinct (x # xs)" "distinct (ys @ [y])"
  hence "x = y \<or> y \<in> set xs"
    using assms by auto
  moreover {
    assume "x = y"
    hence "\<exists>prefix suffix. ys @ [y] = prefix @ x # suffix \<and> concurrent_set x suffix"
      by force
  }
  moreover {
    assume y_in_xs: "y \<in> set xs"
    hence "{x} \<union> (set xs - {y}) = set ys"
      using assms by (auto intro: set_equality_technical)
    hence remove_y_in_xs: "{x} \<union> set (remove1 y xs) = set ys"
      using assms by auto
    moreover have "hb_consistent ((remove1 y xs) @ [x])"
      using assms hb_consistent_remove1 by force
    moreover have "distinct (x # (remove1 y xs))"
      using assms by simp
    moreover have "distinct ys"
      using assms by simp
    ultimately obtain prefix suffix where ys_split: "ys = prefix @ x # suffix \<and> concurrent_set x suffix"
      using IH by force
    moreover {
      have "concurrent x y"
        using assms y_in_xs remove_y_in_xs concurrent_def by blast
      hence "concurrent_set x (suffix@[y])"
        using ys_split by clarsimp
    }
    ultimately have "\<exists>prefix suffix. ys @ [y] = prefix @ x # suffix \<and> concurrent_set x suffix"
      by force
  }
  ultimately show "\<exists>prefix suffix. ys @ [y] = prefix @ x # suffix \<and> concurrent_set x suffix"
    by auto
qed

lemma hb_consistent_append [intro!]:
  assumes "hb_consistent suffix"
          "hb_consistent prefix"
          "\<And>s p. s \<in> set suffix \<Longrightarrow> p \<in> set prefix \<Longrightarrow> \<not> s \<prec> p"
  shows "hb_consistent (prefix @ suffix)"
using assms by (induction rule: hb_consistent.induct) force+

lemma hb_consistent_append_porder:
  assumes "hb_consistent (xs @ ys)"
          "x \<in> set xs"
          "y \<in> set ys"
  shows   "\<not> y \<prec> x"
using assms by (induction ys arbitrary: xs rule: rev_induct) force+

(*************************************************************************)
subsection\<open>Apply operations\<close>
(*************************************************************************)

text\<open>We can now define a function \isa{apply-operations} that composes an arbitrary list of operations
     into a state transformer. We first map \isa{interp} across the list to obtain a state transformer
     for each operation, and then collectively compose them using the Kleisli arrow composition combinator.\<close>

definition apply_operations :: "'a list \<Rightarrow> 'b \<rightharpoonup> 'b" where
  "apply_operations es \<equiv> foldl (\<rhd>) Some (map interp es)"

lemma apply_operations_empty [simp]: "apply_operations [] s = Some s"
  by(auto simp: apply_operations_def)

lemma apply_operations_Snoc [simp]:
  "apply_operations (xs@[x]) = (apply_operations xs) \<rhd> \<langle>x\<rangle>"
  by(auto simp add: apply_operations_def kleisli_def)

(*************************************************************************)
subsection\<open>Concurrent operations commute\<close>
(*************************************************************************)

text\<open>We say that two operations $\isa{x}$ and $\isa{y}$ \emph{commute} whenever
     $\langle\isa{x}\rangle \mathbin{\isasymrhd} \langle\isa{y}\rangle = \langle\isa{y}\rangle \mathbin{\isasymrhd} \langle\isa{x}\rangle$,
     i.e. when we can swap the order of the composition of their interpretations without changing
     the resulting state transformer. For our purposes, requiring that this property holds for
     \emph{all} pairs of operations is too strong. Rather, the commutation property is only required
     to hold for operations that are concurrent.\<close>

definition concurrent_ops_commute :: "'a list \<Rightarrow> bool" where
  "concurrent_ops_commute xs \<equiv>
    \<forall>x y. {x, y} \<subseteq> set xs \<longrightarrow> concurrent x y \<longrightarrow> \<langle>x\<rangle>\<rhd>\<langle>y\<rangle> = \<langle>y\<rangle>\<rhd>\<langle>x\<rangle>"

lemma concurrent_ops_commute_empty [intro!]: "concurrent_ops_commute []"
  by(auto simp: concurrent_ops_commute_def)

lemma concurrent_ops_commute_singleton [intro!]: "concurrent_ops_commute [x]"
  by(auto simp: concurrent_ops_commute_def)

lemma concurrent_ops_commute_appendD [dest]:
  assumes "concurrent_ops_commute (xs@ys)"
    shows "concurrent_ops_commute xs"
using assms by (auto simp: concurrent_ops_commute_def)

lemma concurrent_ops_commute_rearrange:
  "concurrent_ops_commute (xs@x#ys) = concurrent_ops_commute (xs@ys@[x])"
  by (clarsimp simp: concurrent_ops_commute_def)

lemma concurrent_ops_commute_concurrent_set:
  assumes "concurrent_ops_commute (prefix@suffix@[x])"
          "concurrent_set x suffix"
          "distinct (prefix @ x # suffix)"
  shows   "apply_operations (prefix @ suffix @ [x]) = apply_operations (prefix @ x # suffix)"
using assms proof(induction suffix arbitrary: rule: rev_induct, force)
  fix a xs
  assume IH: "concurrent_ops_commute (prefix @ xs @ [x]) \<Longrightarrow>
              concurrent_set x xs \<Longrightarrow> distinct (prefix @ x # xs) \<Longrightarrow>
              apply_operations (prefix @ xs @ [x]) = apply_operations (prefix @ x # xs)"
  assume assms: "concurrent_ops_commute (prefix @ (xs @ [a]) @ [x])"
                "concurrent_set x (xs @ [a])" "distinct (prefix @ x # xs @ [a])"
  hence ac_comm: "\<langle>a\<rangle> \<rhd> \<langle>x\<rangle> = \<langle>x\<rangle> \<rhd> \<langle>a\<rangle>"
    by (clarsimp simp: concurrent_ops_commute_def) blast
  have copc: "concurrent_ops_commute (prefix @ xs @ [x])"
    using assms by (clarsimp simp: concurrent_ops_commute_def) blast
  have "apply_operations ((prefix @ x # xs) @ [a]) = (apply_operations (prefix @ x # xs)) \<rhd> \<langle>a\<rangle>"
    by (simp del: append_assoc)
  also have "... = (apply_operations (prefix @ xs @ [x])) \<rhd> \<langle>a\<rangle>"
    using IH assms copc by auto
  also have "... = ((apply_operations (prefix @ xs)) \<rhd> \<langle>x\<rangle>) \<rhd> \<langle>a\<rangle>"
    by (simp add: append_assoc[symmetric] del: append_assoc)
  also have "... = (apply_operations (prefix @ xs)) \<rhd> (\<langle>a\<rangle> \<rhd> \<langle>x\<rangle>)"
    using ac_comm kleisli_comm_cong kleisli_assoc by simp
  finally show "apply_operations (prefix @ (xs @ [a]) @ [x]) = apply_operations (prefix @ x # xs @ [a])"
    by (metis Cons_eq_appendI append_assoc apply_operations_Snoc kleisli_assoc)
qed

(*************************************************************************)
subsection\<open>Abstract convergence theorem\<close>
(*************************************************************************)

text\<open>We can now state and prove our main theorem, $\isa{convergence}$.
     This theorem states that two hb-consistent lists of distinct operations, which are permutations
     of each other and in which concurrent operations commute, have the same interpretation.\<close>

theorem  convergence:
  assumes "set xs = set ys"
          "concurrent_ops_commute xs"
          "concurrent_ops_commute ys"
          "distinct xs"
          "distinct ys"
          "hb_consistent xs"
          "hb_consistent ys"
  shows   "apply_operations xs = apply_operations ys"
using assms proof(induction xs arbitrary: ys rule: rev_induct, simp)
  case assms: (snoc x xs)
  then obtain prefix suffix where ys_split: "ys = prefix @ x # suffix \<and> concurrent_set x suffix"
    using hb_consistent_prefix_suffix_exists by fastforce
  moreover hence *: "distinct (prefix @ suffix)" "hb_consistent xs"
    using assms by auto
  moreover {
    have "hb_consistent prefix" "hb_consistent suffix"
      using ys_split assms hb_consistent_append_D2 hb_consistent_append_elim_ConsD by blast+
    hence "hb_consistent (prefix @ suffix)"
      by (metis assms(8) hb_consistent_append hb_consistent_append_porder list.set_intros(2) ys_split)
  }
  moreover have **: "concurrent_ops_commute (prefix @ suffix @ [x])"
    using assms ys_split by (clarsimp simp: concurrent_ops_commute_def)
  moreover hence "concurrent_ops_commute (prefix @ suffix)"
    by (force simp del: append_assoc simp add: append_assoc[symmetric])
  ultimately have "apply_operations xs = apply_operations (prefix@suffix)"
    using assms by simp (metis Diff_insert_absorb Un_iff * concurrent_ops_commute_appendD set_append)
  moreover have "apply_operations (prefix@suffix @ [x]) = apply_operations (prefix@x # suffix)"
    using ys_split assms ** concurrent_ops_commute_concurrent_set by force
  ultimately show ?case
    using ys_split by (force simp: append_assoc[symmetric] simp del: append_assoc)
qed

corollary convergence_ext:
  assumes "set xs = set ys"
          "concurrent_ops_commute xs"
          "concurrent_ops_commute ys"
          "distinct xs"
          "distinct ys"
          "hb_consistent xs"
          "hb_consistent ys"
  shows   "apply_operations xs s = apply_operations ys s"
  using convergence assms by metis
end

subsection\<open>Convergence and progress\<close>

text\<open>Besides convergence, another required property of SEC is \emph{progress}: if a valid operation
     was issued on one node, then applying that operation on other nodes must also succeed---that is,
     the execution must not become stuck in an error state.
     Although the type signature of the interpretation function allows operations to fail, we need to
     prove that in all $\isa{hb-consistent}$ network behaviours such failure never actually occurs.
     We capture the combined requirements in the $\isa{strong-eventual-consistency}$ locale,
     which extends $\isa{happens-before}$.\<close>

locale strong_eventual_consistency = happens_before +
  fixes op_history :: "'a list \<Rightarrow> bool"
    and initial_state :: "'b"
  assumes causality:     "op_history xs \<Longrightarrow> hb_consistent xs"
  assumes distinctness:  "op_history xs \<Longrightarrow> distinct xs"
  assumes commutativity: "op_history xs \<Longrightarrow> concurrent_ops_commute xs"
  assumes no_failure:    "op_history(xs@[x]) \<Longrightarrow> apply_operations xs initial_state = Some state \<Longrightarrow> \<langle>x\<rangle> state \<noteq> None"
  assumes trunc_history: "op_history(xs@[x]) \<Longrightarrow> op_history xs"
begin

theorem sec_convergence:
  assumes "set xs = set ys"
          "op_history xs"
          "op_history ys"
  shows   "apply_operations xs = apply_operations ys"
  by (meson assms convergence causality commutativity distinctness)

theorem sec_progress:
  assumes "op_history xs"
  shows   "apply_operations xs initial_state \<noteq> None"
using assms proof(induction xs rule: rev_induct, simp)
  case (snoc x xs)
  have "apply_operations xs initial_state \<noteq> None"
    using snoc.IH snoc.prems trunc_history kleisli_def bind_def by blast
  moreover have "apply_operations (xs @ [x]) = apply_operations xs \<rhd> \<langle>x\<rangle>"
    by simp
  ultimately show ?case
    using no_failure snoc.prems by (clarsimp simp add: kleisli_def split: bind_splits)
qed

end
end


(* Title:      Examples using Hoare Logic for Total Correctness
   Author:     Walter Guttmann
*)

section \<open>Examples using Hoare Logic for Total Correctness\<close>

theory ExamplesTC
  imports Hoare_Logic
begin

text \<open>
This theory demonstrates a few simple partial- and total-correctness proofs.
The first example is taken from HOL/Hoare/Examples.thy written by N. Galm.
We have added the invariant \<open>m \<le> a\<close>.
\<close>

lemma multiply_by_add: "VARS m s a b
  {a=A \<and> b=B}
  m := 0; s := 0;
  WHILE m\<noteq>a
  INV {s=m*b \<and> a=A \<and> b=B \<and> m\<le>a}
  DO s := s+b; m := m+(1::nat) OD
  {s = A*B}"
  by vcg_simp

text \<open>
Here is the total-correctness proof for the same program.
It needs the additional invariant \<open>m \<le> a\<close>.
\<close>

lemma multiply_by_add_tc: "VARS m s a b
  [a=A \<and> b=B]
  m := 0; s := 0;
  WHILE m\<noteq>a
  INV {s=m*b \<and> a=A \<and> b=B \<and> m\<le>a}
  VAR {a-m}
  DO s := s+b; m := m+(1::nat) OD
  [s = A*B]"
  apply vcg_tc_simp
  by auto

text \<open>
Next, we prove partial correctness of a program that computes powers.
\<close>

lemma power: "VARS (p::int) i
  { True }
  p := 1;
  i := 0;
  WHILE i < n
    INV { p = x^i \<and> i \<le> n }
     DO p := p * x;
        i := i + 1
     OD
  { p = x^n }"
  apply vcg_simp
  by auto

text \<open>
Here is its total-correctness proof.
\<close>

lemma power_tc: "VARS (p::int) i
  [ True ]
  p := 1;
  i := 0;
  WHILE i < n
    INV { p = x^i \<and> i \<le> n }
    VAR { n - i }
     DO p := p * x;
        i := i + 1
     OD
  [ p = x^n ]"
  apply vcg_tc
  by auto

text \<open>
The last example is again taken from HOL/Hoare/Examples.thy.
We have modified it to integers so it requires precondition \<open>0 \<le> x\<close>.
\<close>

lemma sqrt_tc: "VARS r
  [0 \<le> (x::int)]
  r := 0;
  WHILE (r+1)*(r+1) <= x
  INV {r*r \<le> x}
  VAR {nat (x-r)}
  DO r := r+1 OD
  [r*r \<le> x \<and> x < (r+1)*(r+1)]"
  apply vcg_tc_simp
  by (smt (verit) div_pos_pos_trivial mult_less_0_iff nonzero_mult_div_cancel_left)

text \<open>
A total-correctness proof allows us to extract a function for further use.
For every input satisfying the precondition the function returns an output satisfying the postcondition.
\<close>

lemma sqrt_exists:
  "0 \<le> (x::int) \<Longrightarrow> \<exists>r' . r'*r' \<le> x \<and> x < (r'+1)*(r'+1)"
  using tc_extract_function sqrt_tc by blast

definition "sqrt (x::int) \<equiv> (SOME r' . r'*r' \<le> x \<and> x < (r'+1)*(r'+1))"

lemma sqrt_function:
  assumes "0 \<le> (x::int)"
    and "r' = sqrt x"
  shows "r'*r' \<le> x \<and> x < (r'+1)*(r'+1)"
proof -
  let ?P = "\<lambda>r' . r'*r' \<le> x \<and> x < (r'+1)*(r'+1)"
  have "?P (SOME z . ?P z)"
    by (metis (mono_tags, lifting) assms(1) sqrt_exists some_eq_imp)
  thus ?thesis
    using assms(2) sqrt_def by auto
qed

end


(*
 * Copyright Data61, CSIRO (ABN 41 687 119 230)
 *
 * SPDX-License-Identifier: BSD-2-Clause
 *)

section \<open>Signed division on word\<close>

theory Signed_Division_Word
  imports "HOL-Library.Signed_Division" "HOL-Library.Word"
begin

instantiation word :: (len) signed_division
begin

lift_definition signed_divide_word :: \<open>'a::len word \<Rightarrow> 'a word \<Rightarrow> 'a word\<close>
  is \<open>\<lambda>k l. signed_take_bit (LENGTH('a) - Suc 0) k sdiv signed_take_bit (LENGTH('a) - Suc 0) l\<close>
  by (simp flip: signed_take_bit_decr_length_iff)

lift_definition signed_modulo_word :: \<open>'a::len word \<Rightarrow> 'a word \<Rightarrow> 'a word\<close>
  is \<open>\<lambda>k l. signed_take_bit (LENGTH('a) - Suc 0) k smod signed_take_bit (LENGTH('a) - Suc 0) l\<close>
  by (simp flip: signed_take_bit_decr_length_iff)

lemma sdiv_word_def [code]:
  \<open>v sdiv w = word_of_int (sint v sdiv sint w)\<close>
  for v w :: \<open>'a::len word\<close>
  by transfer simp

lemma smod_word_def [code]:
  \<open>v smod w = word_of_int (sint v smod sint w)\<close>
  for v w :: \<open>'a::len word\<close>
  by transfer simp

instance proof
  fix v w :: \<open>'a word\<close>
  have \<open>sint v sdiv sint w * sint w + sint v smod sint w = sint v\<close>
    by (fact sdiv_mult_smod_eq)
  then have \<open>word_of_int (sint v sdiv sint w * sint w + sint v smod sint w) = (word_of_int (sint v) :: 'a word)\<close>
    by simp
  then show \<open>v sdiv w * w + v smod w = v\<close>
    by (simp add: sdiv_word_def smod_word_def)
qed

end

lemma sdiv_smod_id:
  \<open>(a sdiv b) * b + (a smod b) = a\<close>
  for a b :: \<open>'a::len word\<close>
  by (fact sdiv_mult_smod_eq)

lemma signed_div_arith:
    "sint ((a::('a::len) word) sdiv b) = signed_take_bit (LENGTH('a) - 1) (sint a sdiv sint b)"
  apply transfer
  apply simp
  done

lemma signed_mod_arith:
    "sint ((a::('a::len) word) smod b) = signed_take_bit (LENGTH('a) - 1) (sint a smod sint b)"
  apply transfer
  apply simp
  done

lemma word_sdiv_div0 [simp]:
    "(a :: ('a::len) word) sdiv 0 = 0"
  apply (auto simp: sdiv_word_def signed_divide_int_def sgn_if)
  done

lemma smod_word_zero [simp]:
  \<open>w smod 0 = w\<close> for w :: \<open>'a::len word\<close>
  by transfer (simp add: take_bit_signed_take_bit)

lemma smod_word_one [simp]:
  \<open>w smod 1 = 0\<close> for w :: \<open>'a::len word\<close>
  by (simp add: smod_word_def signed_modulo_int_def)

lemma word_sdiv_div_minus1 [simp]:
    "(a :: ('a::len) word) sdiv -1 = -a"
  apply (auto simp: sdiv_word_def signed_divide_int_def sgn_if)
  apply transfer
  apply simp
  apply (metis Suc_pred len_gt_0 signed_take_bit_eq_iff_take_bit_eq signed_take_bit_of_0 take_bit_of_0)
  done

lemma smod_word_minus_one [simp]:
  \<open>w smod - 1 = 0\<close> for w :: \<open>'a::len word\<close>
  by (simp add: smod_word_def signed_modulo_int_def)

lemma one_sdiv_word_eq [simp]:
  \<open>1 sdiv w = of_bool (w = 1 \<or> w = - 1) * w\<close> for w :: \<open>'a::len word\<close>
proof (cases \<open>1 < \<bar>sint w\<bar>\<close>)
  case True
  then show ?thesis
    by (auto simp add: sdiv_word_def signed_divide_int_def split: if_splits)
next
  case False
  then have \<open>\<bar>sint w\<bar> \<le> 1\<close>
    by simp
  then have \<open>sint w \<in> {- 1, 0, 1}\<close>
    by auto
  then have \<open>(word_of_int (sint w) :: 'a::len word) \<in> word_of_int ` {- 1, 0, 1}\<close>
    by blast
  then have \<open>w \<in> {- 1, 0, 1}\<close>
    by simp
  then show ?thesis by auto
qed

lemma one_smod_word_eq [simp]:
  \<open>1 smod w = 1 - of_bool (w = 1 \<or> w = - 1)\<close> for w :: \<open>'a::len word\<close>
  using sdiv_smod_id [of 1 w] by auto

lemma minus_one_sdiv_word_eq [simp]:
  \<open>- 1 sdiv w = - (1 sdiv w)\<close> for w :: \<open>'a::len word\<close>
  apply (auto simp add: sdiv_word_def signed_divide_int_def)
  apply transfer
  apply simp
  done

lemma minus_one_smod_word_eq [simp]:
  \<open>- 1 smod w = - (1 smod w)\<close> for w :: \<open>'a::len word\<close>
  using sdiv_smod_id [of \<open>- 1\<close> w] by auto

lemma smod_word_alt_def:
  "(a :: ('a::len) word) smod b = a - (a sdiv b) * b"
  by (simp add: minus_sdiv_mult_eq_smod)

lemmas sdiv_word_numeral_numeral [simp] =
  sdiv_word_def [of \<open>numeral a\<close> \<open>numeral b\<close>, simplified sint_sbintrunc sint_sbintrunc_neg]
  for a b
lemmas sdiv_word_minus_numeral_numeral [simp] =
  sdiv_word_def [of \<open>- numeral a\<close> \<open>numeral b\<close>, simplified sint_sbintrunc sint_sbintrunc_neg]
  for a b
lemmas sdiv_word_numeral_minus_numeral [simp] =
  sdiv_word_def [of \<open>numeral a\<close> \<open>- numeral b\<close>, simplified sint_sbintrunc sint_sbintrunc_neg]
  for a b
lemmas sdiv_word_minus_numeral_minus_numeral [simp] =
  sdiv_word_def [of \<open>- numeral a\<close> \<open>- numeral b\<close>, simplified sint_sbintrunc sint_sbintrunc_neg]
  for a b

lemmas smod_word_numeral_numeral [simp] =
  smod_word_def [of \<open>numeral a\<close> \<open>numeral b\<close>, simplified sint_sbintrunc sint_sbintrunc_neg]
  for a b
lemmas smod_word_minus_numeral_numeral [simp] =
  smod_word_def [of \<open>- numeral a\<close> \<open>numeral b\<close>, simplified sint_sbintrunc sint_sbintrunc_neg]
  for a b
lemmas smod_word_numeral_minus_numeral [simp] =
  smod_word_def [of \<open>numeral a\<close> \<open>- numeral b\<close>, simplified sint_sbintrunc sint_sbintrunc_neg]
  for a b
lemmas smod_word_minus_numeral_minus_numeral [simp] =
  smod_word_def [of \<open>- numeral a\<close> \<open>- numeral b\<close>, simplified sint_sbintrunc sint_sbintrunc_neg]
  for a b

lemmas word_sdiv_0 = word_sdiv_div0

lemma sdiv_word_min:
    "- (2 ^ (size a - 1)) \<le> sint (a :: ('a::len) word) sdiv sint (b :: ('a::len) word)"
  using sdiv_int_range [where a="sint a" and b="sint b"]
  apply auto
  apply (cases \<open>LENGTH('a)\<close>)
   apply simp_all
  apply transfer
  apply simp
  apply (rule order_trans)
   defer
   apply assumption
  apply simp
  apply (metis abs_le_iff add.inverse_inverse le_cases le_minus_iff not_le signed_take_bit_int_eq_self_iff signed_take_bit_minus)
  done

lemma sdiv_word_max:
  \<open>sint a sdiv sint b \<le> 2 ^ (size a - Suc 0)\<close>
  for a b :: \<open>'a::len word\<close>
proof (cases \<open>sint a = 0 \<or> sint b = 0 \<or> sgn (sint a) \<noteq> sgn (sint b)\<close>)
  case True then show ?thesis
    apply (auto simp add: sgn_if not_less signed_divide_int_def split: if_splits)
     apply (smt (z3) pos_imp_zdiv_neg_iff zero_le_power)
    apply (smt (z3) not_exp_less_eq_0_int pos_imp_zdiv_neg_iff)
    done
next
  case False
  then have \<open>\<bar>sint a\<bar> div \<bar>sint b\<bar> \<le> \<bar>sint a\<bar>\<close>
    by (subst nat_le_eq_zle [symmetric]) (simp_all add: div_abs_eq_div_nat)
  also have \<open>\<bar>sint a\<bar> \<le> 2 ^ (size a - Suc 0)\<close>
    using sint_range_size [of a] by auto
  finally show ?thesis
    using False by (simp add: signed_divide_int_def)
qed

lemmas word_sdiv_numerals_lhs = sdiv_word_def[where v="numeral x" for x]
    sdiv_word_def[where v=0] sdiv_word_def[where v=1]

lemmas word_sdiv_numerals = word_sdiv_numerals_lhs[where w="numeral y" for y]
    word_sdiv_numerals_lhs[where w=0] word_sdiv_numerals_lhs[where w=1]

lemma smod_word_mod_0:
  "x smod (0 :: ('a::len) word) = x"
  by (fact smod_word_zero)

lemma smod_word_0_mod [simp]:
  "0 smod (x :: ('a::len) word) = 0"
  by (clarsimp simp: smod_word_def)

lemma smod_word_max:
  "sint (a::'a word) smod sint (b::'a word) < 2 ^ (LENGTH('a::len) - Suc 0)"
  apply (cases \<open>sint b = 0\<close>)
   apply (simp_all add: sint_less)
  apply (cases \<open>LENGTH('a)\<close>)
   apply simp_all
  using smod_int_range [where a="sint a" and b="sint b"]
  apply auto
  apply (rule less_le_trans)
   apply assumption
  apply (auto simp add: abs_le_iff)
   apply (metis diff_Suc_1 le_cases linorder_not_le sint_lt)
  apply (metis add.inverse_inverse diff_Suc_1 linorder_not_less neg_less_iff_less sint_ge)
  done

lemma smod_word_min:
  "- (2 ^ (LENGTH('a::len) - Suc 0)) \<le> sint (a::'a word) smod sint (b::'a word)"
  apply (cases \<open>LENGTH('a)\<close>)
   apply simp_all
  apply (cases \<open>sint b = 0\<close>)
   apply simp_all
   apply (metis diff_Suc_1 sint_ge)
  using smod_int_range [where a="sint a" and b="sint b"]
  apply auto
  apply (rule order_trans)
   defer
   apply assumption
  apply (auto simp add: algebra_simps abs_le_iff)
   apply (metis abs_zero add.left_neutral add_mono_thms_linordered_semiring(1) diff_Suc_1 le_cases linorder_not_less sint_lt zabs_less_one_iff)
  apply (metis abs_zero add.inverse_inverse add.left_neutral add_mono_thms_linordered_semiring(1) diff_Suc_1 le_cases le_minus_iff linorder_not_less sint_ge zabs_less_one_iff)
  done

lemmas word_smod_numerals_lhs = smod_word_def[where v="numeral x" for x]
    smod_word_def[where v=0] smod_word_def[where v=1]

lemmas word_smod_numerals = word_smod_numerals_lhs[where w="numeral y" for y]
    word_smod_numerals_lhs[where w=0] word_smod_numerals_lhs[where w=1]

end


(*
Title: Strong-Security
Authors: Sylvia Grewe, Alexander Lux, Heiko Mantel, Jens Sauer
*)
theory Parallel_Composition
imports Up_To_Technique
begin

context Strong_Security
begin

theorem parallel_composition:
  assumes eqlen: "length V = length V'"
  assumes partsrelated: "\<forall>i < length V. [V!i] \<approx>\<^bsub>d\<^esub> [V'!i]"
  shows "V \<approx>\<^bsub>d\<^esub> V'"
proof -
  define R where "R = {(V,V'). length V = length V'
    \<and> (\<forall>i < length V. [V!i] \<approx>\<^bsub>d\<^esub> [V'!i])}"
  from eqlen partsrelated have inR: "(V,V') \<in> R"
    by (simp add: R_def)

  have "d_Bisimulation_Up_To_USdB d R"
    proof (simp add: d_Bisimulation_Up_To_USdB_def, auto)
      from USdBsym show "sym R"
        by (simp add: R_def sym_def)
    next
      fix V V'
      assume "(V,V') \<in> R"
      with USdBeqlen show "length V = length V'"
        by (simp add: R_def)
    next
      fix V V' i m1 m1' RS m2
      assume inR: "(V,V') \<in> R"
      assume irange: "i < length V"
      assume step: "\<langle>V!i,m1\<rangle> \<rightarrow> \<langle>RS,m2\<rangle>"
      assume dequal: "m1 =\<^bsub>d\<^esub> m1'"

      from inR have Vassump:
        "length V = length V' \<and> (\<forall>i < length V. [V!i] \<approx>\<^bsub>d\<^esub> [V'!i])"
        by (simp add: R_def)

      with step dequal USdB_Strong_d_Bisimulation irange
      strongdB_aux[of "d" "\<approx>\<^bsub>d\<^esub>" "0" "[V!i]" "[V'!i]" "m1" "RS" "m2" "m1'"]
      show "\<exists>RS' m2'. \<langle>V'!i,m1'\<rangle> \<rightarrow> \<langle>RS',m2'\<rangle> \<and>
        ((RS,RS') \<in> R \<or> RS \<approx>\<^bsub>d\<^esub> RS') \<and> m2 =\<^bsub>d\<^esub> m2'"
        by (simp, fastforce)
    qed

    hence "R \<subseteq> (\<approx>\<^bsub>d\<^esub>)"
      by (rule Up_To_Technique)

    with inR show ?thesis by auto
qed

lemma parallel_decomposition:
  assumes related: "V \<approx>\<^bsub>d\<^esub> V'"
  shows "\<forall>i < length V. [V!i] \<approx>\<^bsub>d\<^esub> [V'!i]"
proof -
  define R where "R = {(C,C'). \<exists>i W W'. W \<approx>\<^bsub>d\<^esub> W' \<and> i < length W
    \<and> C = [W!i] \<and> C' = [W'!i]}"

  with related have inR: "\<forall>i < length V. ([V!i],[V'!i]) \<in> R"
    by auto
  have "d_Bisimulation_Up_To_USdB d R"
    proof (simp add: d_Bisimulation_Up_To_USdB_def, auto)
      from USdBsym USdBeqlen show "sym R"
        by (simp add: sym_def R_def, metis)
    next
      fix C C'
      assume "(C,C') \<in> R"
      with USdBeqlen show "length C = length C'"
        by (simp add: R_def, auto)
    next
      fix C C' i m1 m1' RS m2
      assume inR: "(C,C') \<in> R"
      assume irange: "i < length C"
      assume step: "\<langle>C!i,m1\<rangle> \<rightarrow> \<langle>RS,m2\<rangle>"
      assume dequal: "m1 =\<^bsub>d\<^esub> m1'"

     from inR obtain j W W' where Rassump:
       "W \<approx>\<^bsub>d\<^esub> W' \<and> j < length W \<and> C = [W!j] \<and> C' = [W'!j]"
       by (simp add: R_def, auto)

     with irange have i0: "i = 0" by auto

     from Rassump i0 strongdB_aux[of "d" "\<approx>\<^bsub>d\<^esub>" "j" "W" "W'"
       "m1" "RS" "m2" "m1'"]
       USdB_Strong_d_Bisimulation step dequal
     show "\<exists>RS' m2'. \<langle>C'!i,m1'\<rangle> \<rightarrow> \<langle>RS',m2'\<rangle>
       \<and> ((RS,RS') \<in> R \<or> RS \<approx>\<^bsub>d\<^esub> RS') \<and> m2 =\<^bsub>d\<^esub> m2'"
       by auto
   qed

   hence "R \<subseteq> (\<approx>\<^bsub>d\<^esub>)"
     by (rule Up_To_Technique)

   with inR show ?thesis
     by auto

qed

lemma USdB_comp_head_tail:
  assumes relatedhead: "[c] \<approx>\<^bsub>d\<^esub> [c']"
  assumes relatedtail: "V \<approx>\<^bsub>d\<^esub> V'"
  shows "(c#V) \<approx>\<^bsub>d\<^esub> (c'#V')"
proof -
  from relatedtail USdBeqlen have eqlen: "length (c#V) = length (c'#V')"
    by force

  from relatedtail parallel_decomposition have singleV:
    "\<forall>i < length V. [V!i] \<approx>\<^bsub>d\<^esub> [V'!i]"
    by force

  with relatedhead have intermediate:
    "\<forall>i < length (c#V). [(c#V)!i] \<approx>\<^bsub>d\<^esub> [(c'#V')!i]"
    by (auto, case_tac i, auto)

  with eqlen parallel_composition
  show ?thesis
    by blast
qed

lemma USdB_decomp_head_tail:
  assumes relatedlist: "(c#V) \<approx>\<^bsub>d\<^esub> (c'#V')"
  shows "[c] \<approx>\<^bsub>d\<^esub> [c'] \<and> V \<approx>\<^bsub>d\<^esub> V'"
proof auto
  from relatedlist USdBeqlen[of "c#V" "c'#V'"]
  have eqlen: "length V = length V'"
    by auto

  from relatedlist parallel_decomposition[of "c#V" "c'#V'" "d"]
  have intermediate:
    "\<forall>i < length (c#V). [(c#V)!i] \<approx>\<^bsub>d\<^esub> [(c'#V')!i]"
    by auto
  thus "[c] \<approx>\<^bsub>d\<^esub> [c']"
    by force

  from intermediate eqlen show "V \<approx>\<^bsub>d\<^esub> V'"
  proof (case_tac V)
    assume Vcase1: "V = []"
    with eqlen have "V' = []" by auto
    with Vcase1 trivialpair_in_USdB show "V \<approx>\<^bsub>d\<^esub> V'"
      by auto
  next
    fix c1 W
    assume Vcase2: "V = c1#W"
    hence Vlen: "length V > 0" by auto

    from intermediate have intermediate_aux:
      "\<And>i. i < length V
      \<Longrightarrow> [V!i] \<approx>\<^bsub>d\<^esub> [V'!i]"
      by force

    with parallel_composition[of "V" "V'"] eqlen
    show "V \<approx>\<^bsub>d\<^esub> V'"
      by blast

  qed
qed

end

end


theory mInf
  imports mUnion
begin

context GZF_Model begin

subsection \<open>Empty Set\<close>

lemma memp_mset : "m\<emptyset> : mSet"
  unfolding mEmp_def
proof (rule msetI, rule mI_mset[OF zero_typ emp_set])
  show "\<emptyset> \<subseteq> Tier 0 \<ominus> set"
    using empty_subsetI[OF tier_set[OF zero_typ]]
    by auto
qed

lemma memp_empty : "\<not> b m m\<emptyset>"
  using mmem_iff memp_mset
  unfolding mEmp_def
  by auto

lemma memp_ax :
  "m\<forall>b. \<not> b m m\<emptyset>"
  using memp_empty by auto

subsection \<open>Successor Operation\<close>

lemma msng_mset :
  assumes x: "x : mSet"
  shows "<set, {x}> : mSet"
proof (rule msetI)
  obtain j where
    j : "j : Ord" and xj :"x \<in> Tier j"
    by (metis mE[OF mset_m[OF x]])
  hence "{x} \<subseteq> Tier j \<ominus> set"
    using sng_subset[OF mset_smem[OF x] tier_ex_set[OF j]]
          exsetI[OF tier_set[OF j] xj not_excluded_mset[OF x]] by auto
  thus "<set, {x}> : M"
    by (rule mI_mset[OF j sng_set[OF mset_smem[OF x]]])
qed

lemma mupair_msetof :
  assumes x : "x : mSet" and y : "y : mSet"
  shows "<set, {x,y}> : mSetOf mSet"
proof (rule setof_msetof)
  obtain i j where
    "i : Ord" "x \<in> Tier i"
    "j : Ord" "y \<in> Tier j"
    using mE[OF mset_m] x y by metis
  then obtain k where
    k : "k : Ord" and xk : "x \<in> Tier k" and yk : "y \<in> Tier k"
    by (metis greatest_tier)
  hence "{x,y} \<subseteq> Tier k \<ominus> set"
    using upair_subset[OF mset_smem mset_smem tier_ex_set[OF k]] x y
          exsetI[OF tier_set[OF k] _ not_excluded_mset] by metis
  thus "<set, {x,y}> : mSet"
    using msetI[OF mI_mset[OF k upair_set[OF mset_smem mset_smem]]]
          x y by metis
  show "{x,y} : SetOf mSet"
    using setofI[OF upair_set[OF mset_smem[OF x] mset_smem[OF y]]]
          upairE[OF mset_smem[OF x] mset_smem[OF y]] x y by auto
qed

lemmas mcons_msetof = mupair_msetof[OF _ msng_mset]
lemmas mcons_mset = msetof_mset[OF mcons_msetof]

lemma mSucc_eq :
  assumes "x : mSet"
  shows "mSucc x = mUnion <set, {x, <set, {x}>}>"
  unfolding mSucc_def mSucc'_def mUnion'_def
  using mUnion_eq[OF mcons_msetof] assms by auto

lemma msucc_typ :
  "mSucc : mSet \<rightarrow> mSet"
  by (rule funI, unfold mSucc_eq, rule munion_mset,
      metis mcons_msetof)

lemmas msucc_mset = funE[OF msucc_typ]

lemma msucc_iff :
  assumes x : "x : mSet"
  shows "y m mSucc x \<longleftrightarrow> (y m x \<or> y = x)"
  unfolding mSucc_eq[OF x] munion_iff[OF mcons_msetof[OF x x]]
proof (rule, erule exE, erule conjE)
  fix z assume "z m <set, {x, <set, {x}>}>"
  hence z:"z \<in> {x, <set, {x}>}"
    using mmem_iff_eq[OF mcons_mset[OF x x]] by auto
  assume yz : "y m z"
  show "y m x \<or> y = x"
  proof (rule upairE[OF mset_smem[OF x] mset_smem[OF msng_mset[OF x]] z])
    assume "z = x" thus "y m x \<or> y = x"
      using yz by simp
  next
    assume "z = <set,{x}>"
    hence "y \<in> {x}"
      using yz mmem_iff_eq[OF msng_mset[OF x]] by auto
    thus "y m x \<or> y = x"
      unfolding sng_iff[OF mset_smem[OF x]] ..
  qed
next
  assume "y m x \<or> y = x"
  thus "\<exists>z. z m \<langle>set,{x,\<langle>set,{x}\<rangle>}\<rangle> \<and> y m z"
  proof
   assume "y m x"
   moreover have "x m <set, {x, <set,{x}>}>"
    using mmem_iff[OF mcons_mset[OF x x]]
          upairI1[OF mset_smem[OF x] mset_smem[OF msng_mset[OF x]]] by auto
   ultimately show "\<exists>z. z m <set, {x, <set,{x}>}> \<and> y m z"
    by auto
  next
    assume "y = x"
    hence "y m <set, {x}>"
      unfolding mmem_iff[OF msng_mset[OF x]]
      using sngI[OF mset_smem[OF x]] by auto
    moreover have "<set, {x}> m <set, {x, <set,{x}>}>"
      unfolding mmem_iff[OF mcons_mset[OF x x]]
          using upairI2[OF mset_smem[OF x] mset_smem[OF msng_mset[OF x]]] .
    ultimately show "\<exists>z. z m <set, {x, <set,{x}>}> \<and> y m z"
      by auto
  qed
qed

lemma msucc_ax :
  "m\<forall>x:mSet. m\<forall>b. (b m mSucc x) = (b m x \<or> b = x)"
  unfolding mtall_def
  using msucc_iff by auto

subsection \<open>Model infinity witness\<close>

lemma Theta_lim_smem :
  assumes \<mu>:"\<mu> : Limit" and tj:"\<forall>j : Ord. j < \<mu> \<longrightarrow> \<Theta> j : mSet"
  shows "\<Theta> : (predSet \<mu>) \<leadsto> SetMem"
proof (rule mem_funI)
  fix j assume "j \<in> predSet \<mu>"
  hence "j : Ord" "j < \<mu>"
    using predsetD[OF limit_ord[OF \<mu>]] by auto
  thus "\<Theta> j : SetMem"
    using tj mset_smem by auto
qed

(* lemma Theta_lim_fmem :
  assumes \<mu>:"\<mu> : Limit" and tj:"\<forall>j : Ord. j < \<mu> \<longrightarrow> \<Theta> j : mSet"
  shows "\<Theta> : (predSet \<mu>) \<leadsto> FunMem"
  by (rule mem_funI, rule smem_fmem,
      erule mem_funE[OF Theta_lim_smem[OF \<mu> tj]]) *)

lemma theta_tier :
 assumes i:"j : Ord"
   shows "\<Theta> j : mSet ""\<Theta> j \<in> Tier (succ j)"
proof (induct rule: trans_induct3[OF i])
  have t0:"\<Theta> 0 = m\<emptyset>"
    unfolding ord_to_mvnord_def
    using ordrec_0 by auto
  thus "\<Theta> 0 : mSet"
    using memp_mset  by auto
  show "\<Theta> 0 \<in> Tier (succ 0)"
    unfolding t0 mEmp_def
    using tierI_mset[OF zero_typ emp_set] empty_subsetI[OF tier_ex_set[OF zero_typ]]
    by auto
next
  fix j assume j:"j : Ord" "\<Theta> j : mSet" "\<Theta> j \<in> Tier (succ j)"
  hence tj:"\<Theta> j \<in> Tier (succ j) \<ominus> set"
    using exsetI[OF tier_set[OF succ_ord[OF j(1)]] _ not_excluded_mset] by auto
  have tsucc:"\<Theta> (succ j) = mSucc (\<Theta> j)"
    unfolding ord_to_mvnord_def ordrec_succ[OF j(1)] ..
  thus "\<Theta> (succ j) : mSet"
    using msucc_mset[OF j(2)] by auto
  show "\<Theta> (succ j) \<in> Tier (succ (succ j))"
    unfolding tsucc
  proof (rule msetE[OF msucc_mset[OF j(2)]])
    fix x' assume x':"mSucc (\<Theta> j) = <set,x'>" "x' : Set"
    show "mSucc (\<Theta> j) \<in> Tier (succ (succ j))"
    proof (unfold x'(1), rule tierI_mset[OF succ_ord[OF j(1)] x'(2)], rule)
      fix a assume "a \<in> x'"
      hence "a m <set, x'>"
        using x' mmem_iff_eq[OF msucc_mset[OF j(2)]] by auto
      hence "a m (\<Theta> j) \<or> a = \<Theta> j"
        using x'(1) msucc_iff[OF j(2)] by auto
      thus "a \<in> Tier (succ j) \<ominus> set"
      proof (rule)
        from msetE[OF j(2)] obtain y' where y':"\<Theta> j = <set, y'>" "y' : Set" by auto
        assume "a m (\<Theta> j)"
        hence "a \<in> Tier j \<ominus> set"
           using mmem_tier[OF j(1)] j(3) unfolding y' by auto
        thus "a \<in> Tier (succ j) \<ominus> set"
          using ex_subset1[OF tier_set[OF j(1)] tier_set[OF succ_ord[OF j(1)]]
                              tier_subset_succ[OF j(1)] subset_refl] by auto
      next
        assume "a = \<Theta> j"
        thus "a \<in> Tier (succ j) \<ominus> set" using tj by auto
      qed
    qed
  qed
next
  fix \<mu> assume u:"\<mu> : Limit" and tj:"\<forall>j : Ord. j < \<mu> \<longrightarrow> \<Theta> j : mSet \<and> \<Theta> j \<in> Tier (succ j)"
  hence t_mset: "\<forall>j : Ord. j < \<mu> \<longrightarrow> \<Theta> j : mSet" by auto
  have tu:"\<Theta> \<mu> = <set, { \<Theta> j | j < \<mu>}>"
    unfolding ord_to_mvnord_def ordrec_lim[OF u]
      repfun_ordrec_lim_restrict[OF u] ..

  have tfun:"(\<lambda>j<\<mu>. \<Theta> j) : Function"
    using lam_fun[OF lim_predset_set[OF u]] by auto
  show "\<Theta> \<mu> \<in> Tier (succ \<mu>)" unfolding tu
  proof (rule tierI_mset[OF limit_ord[OF u]])
    show "{ \<Theta> j | j < \<mu> } : Set"
      using repfun_lim_set[OF u] by auto

    show "{ \<Theta> j | j < \<mu> } \<subseteq> Tier \<mu> \<ominus> set"
    proof (rule, erule repfunE[OF lim_predset_set[OF u]],
           drule predsetD[OF limit_ord[OF u]], auto)
      fix i assume "i : Ord" "i < \<mu>"
      moreover hence "\<Theta> i : mSet" "\<Theta> i \<in> Tier (succ i)"
        using tj by auto
      ultimately have "\<Theta> i \<in> Tier \<mu>"
        using tier_limI1[OF u succ_ord limit_lt_succ[OF u]]
        by auto
      thus "\<Theta> i \<in> Tier \<mu> \<ominus> set"
        using exsetI[OF tier_set[OF limit_ord[OF u]]]
              not_excluded_mset[OF \<open>\<Theta> i : mSet\<close>] by auto
    qed
  qed
  thus "\<Theta> \<mu> : mSet"
    using msetI[OF mI[OF succ_ord[OF limit_ord[OF u]]]]
    unfolding tu by metis
qed

lemma theta_lam_fun :
  assumes u:"\<mu> : Limit"
  shows "(\<lambda>j<\<mu>. \<Theta> j) : Function"
    using lam_fun[OF lim_predset_set[OF u]] by auto

lemma Theta_lim_setfun :
  assumes u:"\<mu> : Limit"
  shows "\<Theta> : (predSet \<mu>) \<leadsto> SetMem"
proof (rule mem_funI)
 fix j assume j:"j \<in> predSet \<mu>"
 hence "j : Ord" "j < \<mu>"
   using predsetD[OF limit_ord[OF u]] by auto
 thus "\<Theta> j : SetMem" using theta_tier mset_smem by auto
qed

(* lemma theta_fmem :
  assumes \<mu>:"\<mu> : Limit"
  shows "\<Theta> : (predSet \<mu>) \<leadsto> FunMem"
  using theta_tier Theta_lim_fmem[OF \<mu>] by auto *)

lemma Theta_eq :
  "\<Theta> \<omega> = <set, {\<Theta> i | i < \<omega>}>"
   unfolding ordrec_lim[OF omega_typ] ord_to_mvnord_def
             repfun_ordrec_lim_restrict[OF omega_typ] ..

lemma minf_mset : "mInf : mSet"
  unfolding mInf_def
  using theta_tier(1)[OF omega_ord] by simp

lemma minf_iff : "b m mInf \<longleftrightarrow> (\<exists>i<\<omega>. b = \<Theta> i)"
  using
    mmem_iff_eq[OF minf_mset]
  unfolding
    mInf_def Theta_eq
  using
    repfun_iff[OF predset_set[OF omega_ord]]
    ord_ex_iff[OF omega_ord]
    mset_smem[OF theta_tier(1)]
 by auto

lemma minf_msetof :
  "mInf : mSetOf mSet"
proof (rule msetofI[OF minf_mset])
  fix b assume "b m mInf"
  thus "b : mSet"
    unfolding minf_iff
    using theta_tier by auto
qed

lemma memp_mem_minf :
  "mEmp m mInf"
  unfolding minf_iff
proof (rule texI[OF zero_typ], auto)
  show "0 < \<omega>"
    using omega_zero .
  show "m\<emptyset> = \<Theta> 0"
    unfolding ord_to_mvnord_def
    using ordrec_0 by auto
qed

lemma msucc_mem_minf :
  assumes x:"x m mInf"
  shows "mSucc x m mInf"
  unfolding minf_iff
proof -
  from x obtain i where
    i : "i : Ord" "i < \<omega>" "x = \<Theta> i"
    using minf_iff by auto
  hence "mSucc x = \<Theta> (succ i)"
    unfolding ord_to_mvnord_def
    using ordrec_succ[OF i(1)] by auto
  thus "\<exists>j: Ord. j < \<omega> \<and> mSucc x = \<Theta> j"
    using succ_ord omega_succ i by auto
qed

lemma minf_ax :
  "mEmp m mInf \<and> (m\<forall>a. a m mInf \<longrightarrow> mSucc a m mInf)"
  using memp_mem_minf msucc_mem_minf by auto

theorem memp_rsp :
  "m\<emptyset> : M"
  using mset_m[OF memp_mset] .

theorem msucc_rsp :
  "x : M \<Longrightarrow> mSucc x : M"
  using mset_m[OF msucc_mset] GZF_Model_mdefault_m
  unfolding mSucc_def
  by auto

theorem minf_rsp :
  "mInf : M"
  using mset_m[OF minf_mset] .

end
end


theory Expressive_Completeness
imports
  Bisimilarity_Implies_Equivalence
  Equivalence_Implies_Bisimilarity
  Disjunction
begin

section \<open>Expressive Completeness\<close>

context indexed_nominal_ts
begin

  subsection \<open>Distinguishing formulas\<close>

  text \<open>Lemma \emph{distinguished\_bounded\_support} only shows the existence of a distinguishing
    formula, without stating what this formula looks like. We now define an explicit function that
    returns a distinguishing formula, in a way that this function is equivariant (on pairs of
    non-equivalent states).

    Note that this definition uses Hilbert's choice operator~$\varepsilon$, which is not necessarily
    equivariant. This is immediately remedied by a hull construction.\<close>

  definition distinguishing_formula :: "'state \<Rightarrow> 'state \<Rightarrow> ('idx, 'pred, 'act) formula" where
    "distinguishing_formula P Q \<equiv> Conj (Abs_bset {-p \<bullet> (\<some>x. supp x \<subseteq> supp (p \<bullet> P) \<and> x distinguishes (p \<bullet> P) from (p \<bullet> Q))|p. True})"

  \<comment> \<open>just an auxiliary lemma that will be useful further below\<close>
  lemma distinguishing_formula_card_aux:
    "|{-p \<bullet> (\<some>x. supp x \<subseteq> supp (p \<bullet> P) \<and> x distinguishes (p \<bullet> P) from (p \<bullet> Q))|p. True}| <o natLeq +c |UNIV :: 'idx set|"
  proof -
    let ?some = "\<lambda>p. (\<some>x. supp x \<subseteq> supp (p \<bullet> P) \<and> x distinguishes (p \<bullet> P) from (p \<bullet> Q))"
    let ?B = "{-p \<bullet> ?some p|p. True}"

    have "?B \<subseteq> (\<lambda>p. -p \<bullet> ?some p) ` UNIV"
      by auto
    then have "|?B| \<le>o |UNIV :: perm set|"
      by (rule surj_imp_ordLeq)
    also have "|UNIV :: perm set| <o |UNIV :: 'idx set|"
      by (metis card_idx_perm)
    also have "|UNIV :: 'idx set| \<le>o natLeq +c |UNIV :: 'idx set|"
      by (metis Cnotzero_UNIV ordLeq_csum2)
    finally show ?thesis .
  qed

  \<comment> \<open>just an auxiliary lemma that will be useful further below\<close>
  lemma distinguishing_formula_supp_aux:
    assumes "\<not> (P =\<cdot> Q)"
    shows "supp (Abs_bset {-p \<bullet> (\<some>x. supp x \<subseteq> supp (p \<bullet> P) \<and> x distinguishes (p \<bullet> P) from (p \<bullet> Q))|p. True} :: _ set['idx]) \<subseteq> supp P"
  proof -
    let ?some = "\<lambda>p. (\<some>x. supp x \<subseteq> supp (p \<bullet> P) \<and> x distinguishes (p \<bullet> P) from (p \<bullet> Q))"
    let ?B = "{-p \<bullet> ?some p|p. True}"

    {
      fix p
      from assms have "\<not> (p \<bullet> P =\<cdot> p \<bullet> Q)"
        by (metis logically_equivalent_eqvt permute_minus_cancel(2))
      then have "supp (?some p) \<subseteq> supp (p \<bullet> P)"
        using distinguished_bounded_support by (metis (mono_tags, lifting) equivalent_iff_not_distinguished someI_ex)
    }
    note supp_some = this

    {
      fix x
      assume "x \<in> ?B"
      then obtain p where "x = -p \<bullet> ?some p"
        by blast
      with supp_some have "supp (p \<bullet> x) \<subseteq> supp (p \<bullet> P)"
        by simp
      then have "supp x \<subseteq> supp P"
        by (metis (full_types) permute_boolE subset_eqvt supp_eqvt)
    }
    note "*" = this
    have supp_B: "supp ?B \<subseteq> supp P"
      by (rule set_bounded_supp, fact finite_supp, cut_tac "*", blast)

    from supp_B and distinguishing_formula_card_aux show ?thesis
      using supp_Abs_bset by blast
  qed

  lemma distinguishing_formula_eqvt [simp]:
    assumes "\<not> (P =\<cdot> Q)"
    shows "p \<bullet> distinguishing_formula P Q = distinguishing_formula (p \<bullet> P) (p \<bullet> Q)"
  proof -
    let ?some = "\<lambda>p. (\<some>x. supp x \<subseteq> supp (p \<bullet> P) \<and> x distinguishes (p \<bullet> P) from (p \<bullet> Q))"
    let ?B = "{-p \<bullet> ?some p|p. True}"

    from assms have "supp (Abs_bset ?B :: _ set['idx]) \<subseteq> supp P"
      by (rule distinguishing_formula_supp_aux)
    then have "finite (supp (Abs_bset ?B :: _ set['idx]))"
      using finite_supp rev_finite_subset by blast
    with distinguishing_formula_card_aux have *: "p \<bullet> Conj (Abs_bset ?B) = Conj (Abs_bset (p \<bullet> ?B))"
      by simp

    let ?some' = "\<lambda>p'. (\<some>x. supp x \<subseteq> supp (p' \<bullet> p \<bullet> P) \<and> x distinguishes (p' \<bullet> p \<bullet> P) from (p' \<bullet> p \<bullet> Q))"
    let ?B' = "{-p' \<bullet> ?some' p'|p'. True}"

    have "p \<bullet> ?B = ?B'"
    proof
      {
        fix px
        assume "px \<in> p \<bullet> ?B"
        then obtain x where 1: "px = p \<bullet> x" and 2: "x \<in> ?B"
          by (metis (no_types, lifting) image_iff permute_set_eq_image)
        from 2 obtain p' where 3: "x = -p' \<bullet> ?some p'"
          by blast
        from 1 and 3 have "px = -(p' - p) \<bullet> ?some' (p' - p)"
          by simp
        then have "px \<in> ?B'"
          by blast
      }
      then show "p \<bullet> ?B \<subseteq> ?B'"
        by blast
    next
      {
        fix x
        assume "x \<in> ?B'"
        then obtain p' where "x = -p' \<bullet> ?some' p'"
          by blast
        then have "x = p \<bullet> -(p' + p) \<bullet> ?some (p' + p)"
          by (simp add: add.inverse_distrib_swap)
        then have "x \<in> p \<bullet> ?B"
          using mem_permute_iff by blast
      }
      then show "?B' \<subseteq> p \<bullet> ?B"
        by blast
    qed

    with "*" show ?thesis
      unfolding distinguishing_formula_def by simp
  qed

  lemma supp_distinguishing_formula:
    assumes "\<not> (P =\<cdot> Q)"
    shows "supp (distinguishing_formula P Q) \<subseteq> supp P"
  proof -
    let ?some = "\<lambda>p. (\<some>x. supp x \<subseteq> supp (p \<bullet> P) \<and> x distinguishes (p \<bullet> P) from (p \<bullet> Q))"
    let ?B = "{- p \<bullet> ?some p|p. True}"

    from assms have "supp (Abs_bset ?B :: _ set['idx]) \<subseteq> supp P"
      by (rule distinguishing_formula_supp_aux)
    moreover from this have "finite (supp (Abs_bset ?B :: _ set['idx]))"
      using finite_supp rev_finite_subset by blast
    ultimately show ?thesis
      unfolding distinguishing_formula_def by simp
  qed

  lemma distinguishing_formula_distinguishes:
    assumes "\<not> (P =\<cdot> Q)"
    shows "(distinguishing_formula P Q) distinguishes P from Q"
  proof -
    let ?some = "\<lambda>p. (\<some>x. supp x \<subseteq> supp (p \<bullet> P) \<and> x distinguishes (p \<bullet> P) from (p \<bullet> Q))"
    let ?B = "{- p \<bullet> ?some p|p. True}"

    {
      fix p
      have "(?some p) distinguishes (p \<bullet> P) from (p \<bullet> Q)"
        using assms
        by (metis (mono_tags, lifting) is_distinguishing_formula_eqvt distinguished_bounded_support equivalent_iff_not_distinguished someI_ex)
    }
    note some_distinguishes = this

    {
      fix P'
      from assms have "supp (Abs_bset ?B :: _ set['idx]) \<subseteq> supp P"
        by (rule distinguishing_formula_supp_aux)
      then have "finite (supp (Abs_bset ?B :: _ set['idx]))"
        using finite_supp rev_finite_subset by blast
      with distinguishing_formula_card_aux have "P' \<Turnstile> distinguishing_formula P Q \<longleftrightarrow> (\<forall>x\<in>?B. P' \<Turnstile> x)"
        unfolding distinguishing_formula_def by simp
    }
    note valid_distinguishing_formula = this

    {
      fix p
      have "P \<Turnstile> -p \<bullet> ?some p"
        by (metis (mono_tags) is_distinguishing_formula_def permute_minus_cancel(2) some_distinguishes valid_eqvt)
    }
    then have "P \<Turnstile> distinguishing_formula P Q"
      using valid_distinguishing_formula by blast

    moreover have "\<not> Q \<Turnstile> distinguishing_formula P Q"
      using valid_distinguishing_formula by (metis (mono_tags, lifting) is_distinguishing_formula_def mem_Collect_eq permute_minus_cancel(1) some_distinguishes valid_eqvt)

    ultimately show "(distinguishing_formula P Q) distinguishes P from Q"
      using is_distinguishing_formula_def by blast
  qed

  subsection \<open>Characteristic formulas\<close>

  text \<open>A \emph{characteristic formula} for a state~$P$ is valid for (exactly) those states that are
    bisimilar to~$P$.\<close>

  definition characteristic_formula :: "'state \<Rightarrow> ('idx, 'pred, 'act) formula" where
    "characteristic_formula P \<equiv> Conj (Abs_bset {distinguishing_formula P Q|Q. \<not> (P =\<cdot> Q)})"

  \<comment> \<open>just an auxiliary lemma that will be useful further below\<close>
  lemma characteristic_formula_card_aux:
    "|{distinguishing_formula P Q|Q. \<not> (P =\<cdot> Q)}| <o natLeq +c |UNIV :: 'idx set|"
  proof -
    let ?B = "{distinguishing_formula P Q|Q. \<not> (P =\<cdot> Q)}"

    have "?B \<subseteq> (distinguishing_formula P) ` UNIV"
      by auto
    then have "|?B| \<le>o |UNIV :: 'state set|"
      by (rule surj_imp_ordLeq)
    also have "|UNIV :: 'state set| <o |UNIV :: 'idx set|"
      by (metis card_idx_state)
    also have "|UNIV :: 'idx set| \<le>o natLeq +c |UNIV :: 'idx set|"
      by (metis Cnotzero_UNIV ordLeq_csum2)
    finally show ?thesis .
  qed

  \<comment> \<open>just an auxiliary lemma that will be useful further below\<close>
  lemma characteristic_formula_supp_aux:
    shows "supp (Abs_bset {distinguishing_formula P Q|Q. \<not> (P =\<cdot> Q)} :: _ set['idx]) \<subseteq> supp P"
  proof -
    let ?B = "{distinguishing_formula P Q|Q. \<not> (P =\<cdot> Q)}"

    {
      fix x
      assume "x \<in> ?B"
      then obtain Q where "x = distinguishing_formula P Q" and "\<not> (P =\<cdot> Q)"
        by blast
      with supp_distinguishing_formula have "supp x \<subseteq> supp P"
        by metis
    }
    note "*" = this
    have supp_B: "supp ?B \<subseteq> supp P"
      by (rule set_bounded_supp, fact finite_supp, cut_tac "*", blast)

    from supp_B and characteristic_formula_card_aux show ?thesis
      using supp_Abs_bset by blast
  qed

  lemma characteristic_formula_eqvt (*[eqvt]*) [simp]:
    "p \<bullet> characteristic_formula P = characteristic_formula (p \<bullet> P)"
  proof -
    let ?B = "{distinguishing_formula P Q|Q. \<not> (P =\<cdot> Q)}"

    have "supp (Abs_bset ?B :: _ set['idx]) \<subseteq> supp P"
      by (fact characteristic_formula_supp_aux)
    then have "finite (supp (Abs_bset ?B :: _ set['idx]))"
      using finite_supp rev_finite_subset by blast
    with characteristic_formula_card_aux have *: "p \<bullet> Conj (Abs_bset ?B) = Conj (Abs_bset (p \<bullet> ?B))"
      by simp

    let ?B' = "{distinguishing_formula (p \<bullet> P) Q|Q. \<not> ((p \<bullet> P) =\<cdot> Q)}"

    have "p \<bullet> ?B = ?B'"
    proof
      {
        fix px
        assume "px \<in> p \<bullet> ?B"
        then obtain x where 1: "px = p \<bullet> x" and 2: "x \<in> ?B"
          by (metis (no_types, lifting) image_iff permute_set_eq_image)
        from 2 obtain Q where 3: "x = distinguishing_formula P Q" and 4: "\<not> (P =\<cdot> Q)"
          by blast
        with 1 have "px = distinguishing_formula (p \<bullet> P) (p \<bullet> Q)"
          by simp
        moreover from 4 have "\<not> ((p \<bullet> P) =\<cdot> (p \<bullet> Q))"
          by (metis logically_equivalent_eqvt permute_minus_cancel(2))
        ultimately have "px \<in> ?B'"
          by blast
      }
      then show "p \<bullet> ?B \<subseteq> ?B'"
        by blast
    next
      {
        fix x
        assume "x \<in> ?B'"
        then obtain Q where 1: "x = distinguishing_formula (p \<bullet> P) Q" and 2: "\<not> ((p \<bullet> P) =\<cdot> Q)"
          by blast
        from 2 have "\<not> (P =\<cdot> (-p \<bullet> Q))"
          by (metis logically_equivalent_eqvt permute_minus_cancel(1))
        moreover from this and 1 have "x = p \<bullet> distinguishing_formula P (-p \<bullet> Q)"
          by simp
        ultimately have "x \<in> p \<bullet> ?B"
          using mem_permute_iff by blast
      }
      then show "?B' \<subseteq> p \<bullet> ?B"
        by blast
    qed

    with "*" show ?thesis
      unfolding characteristic_formula_def by simp
  qed

  lemma characteristic_formula_eqvt_raw [simp]:
    "p \<bullet> characteristic_formula = characteristic_formula"
    by (simp add: permute_fun_def)

  lemma characteristic_formula_is_characteristic':
    "Q \<Turnstile> characteristic_formula P \<longleftrightarrow> P =\<cdot> Q"
  proof -
    let ?B = "{distinguishing_formula P Q|Q. \<not> (P =\<cdot> Q)}"

    {
      fix P'
      have "supp (Abs_bset ?B :: _ set['idx]) \<subseteq> supp P"
        by (fact characteristic_formula_supp_aux)
      then have "finite (supp (Abs_bset ?B :: _ set['idx]))"
        using finite_supp rev_finite_subset by blast
      with characteristic_formula_card_aux have "P' \<Turnstile> characteristic_formula P \<longleftrightarrow> (\<forall>x\<in>?B. P' \<Turnstile> x)"
        unfolding characteristic_formula_def by simp
    }
    note valid_characteristic_formula = this

    show ?thesis
    proof
      assume *: "Q \<Turnstile> characteristic_formula P"
      show "P =\<cdot> Q"
      proof (rule ccontr)
        assume "\<not> (P =\<cdot> Q)"
        with "*" show False
          using distinguishing_formula_distinguishes is_distinguishing_formula_def valid_characteristic_formula by auto
      qed
    next
      assume "P =\<cdot> Q"
      moreover have "P \<Turnstile> characteristic_formula P"
        using distinguishing_formula_distinguishes is_distinguishing_formula_def valid_characteristic_formula by auto
      ultimately show "Q \<Turnstile> characteristic_formula P"
        using logically_equivalent_def by blast
    qed
  qed

  lemma characteristic_formula_is_characteristic:
    "Q \<Turnstile> characteristic_formula P \<longleftrightarrow> P \<sim>\<cdot> Q"
    using characteristic_formula_is_characteristic' by (meson bisimilarity_implies_equivalence equivalence_implies_bisimilarity)

  subsection \<open>Expressive completeness\<close>

  text \<open>Every finitely supported set of states that is closed under bisimulation can be described by
    a formula; namely, by a disjunction of characteristic formulas.\<close>

  theorem expressive_completeness:
    assumes "finite (supp S)"
    and "\<And>P Q. P \<in> S \<Longrightarrow> P \<sim>\<cdot> Q \<Longrightarrow> Q \<in> S"
    shows "P \<Turnstile> Disj (Abs_bset (characteristic_formula ` S)) \<longleftrightarrow> P \<in> S"
  proof -
    let ?B = "characteristic_formula ` S"

    have "?B \<subseteq> characteristic_formula ` UNIV"
      by auto
    then have "|?B| \<le>o |UNIV :: 'state set|"
      by (rule surj_imp_ordLeq)
    also have "|UNIV :: 'state set| <o |UNIV :: 'idx set|"
      by (metis card_idx_state)
    also have "|UNIV :: 'idx set| \<le>o natLeq +c |UNIV :: 'idx set|"
      by (metis Cnotzero_UNIV ordLeq_csum2)
    finally have card_B: "|?B| <o natLeq +c |UNIV :: 'idx set|" .

    have "eqvt image" and "eqvt characteristic_formula"
      by (simp add: eqvtI)+
    then have "supp ?B \<subseteq> supp S"
      using supp_fun_eqvt supp_fun_app supp_fun_app_eqvt by blast
    with card_B have "supp (Abs_bset ?B :: _ set['idx]) \<subseteq> supp S"
      using supp_Abs_bset by blast
    with \<open>finite (supp S)\<close> have "finite (supp (Abs_bset ?B :: _ set['idx]))"
      using finite_supp rev_finite_subset by blast
    with card_B have "P \<Turnstile> Disj (Abs_bset (characteristic_formula ` S)) \<longleftrightarrow> (\<exists>x\<in>?B. P \<Turnstile> x)"
      by simp

    with \<open>\<And>P Q. P \<in> S \<Longrightarrow> P \<sim>\<cdot> Q \<Longrightarrow> Q \<in> S\<close> show ?thesis
      using characteristic_formula_is_characteristic characteristic_formula_is_characteristic' logically_equivalent_def by fastforce
  qed

end

end


theory identity2 imports Complex_Main HOL.Power begin

lemma identity2: fixes f :: "nat \<Rightarrow> nat"
assumes "f(k) = k" and "k \<ge> 2"
and f_times: "\<And>m n. f(m*n) = f(m)*f(n)"
and f_mono: "\<And>m n. m<n \<Longrightarrow> f m < f n"
shows "f(n) = n"
proof -
  have incr: "\<And>n. f(n+1) \<ge> f(n) + 1"
    using f_mono mono_nat_linear_lb by blast
  have add_m: "\<And>n m. m\<ge>0 \<Longrightarrow> f(n+m) \<ge> f(n) + m"
    using f_mono mono_nat_linear_lb incr by blast
  have leq_than_k: "\<And>m. m\<le>k \<Longrightarrow> f(m) = m"
  proof -
    have "\<And>m. m\<le>k \<Longrightarrow> k = m + (k-m)" by arith
    then show "\<And>m. m\<le>k \<Longrightarrow> f(m) = m" using add_m
    proof -
      fix m :: nat
      assume a1: "m \<le> k"
      assume "\<And>m. m \<le> k \<Longrightarrow> k = m + (k - m)"
      have "m + (k - m) = k" using a1 by presburger
      then show "f m = m"
        using a1 by (metis (no_types) Nat.le_diff_conv2 \<open>\<And>n m. 0 \<le> m \<Longrightarrow> f n + m \<le> f (n + m)\<close>
            add.commute add.left_neutral add_diff_cancel_right' add_leD1 assms(1) le_antisym)
    qed
  qed
  have 0: "f(0) = 0" using assms(2) by (simp add: leq_than_k)
  have 1: "f(1) = 1" using assms(2) by (simp add: leq_than_k)
  have 2: "f(2) = 2" using assms(2) by (simp add: leq_than_k)
  have two_power: "f ((2::nat) ^ n) = 2 ^ n"
  proof (induct n)
    case 0
    then show ?case using 1 by simp
  next
    case (Suc x)
    then show ?case using 2 f_times by auto
  qed
  have interval: "\<And>n1 n2. f(n1) = n1 \<Longrightarrow> f(n2) = n2 \<Longrightarrow> (\<And>p. p\<ge>n1 \<Longrightarrow> p\<le>n2 \<Longrightarrow> f(p) = p)"
    by (metis add.commute add_le_cancel_right add_m le_add_diff_inverse2 le_antisym zero_le)
  have u_bound: "\<exists>n2. 2^n2 \<ge> n" using self_le_ge2_pow by blast

  show ?thesis
  proof (cases "n\<ge>2")
    case True
    then have "n \<ge> 2^0" by simp
    have "f (2^0) = 2^0" using 1 by simp
    have "n \<le> 2^n" by simp
    have "f (2^n) = 2^n" using two_power by blast
    then show ?thesis using interval two_power
      using "2" True \<open>n \<le> 2 ^ n\<close> by blast
  next
    case False
    then show ?thesis using 0 1
      using assms(2) le_trans leq_than_k nat_le_linear by blast
  qed
qed

end


(*  Title:      HOL/UNITY/Detects.thy
    Author:     Tanja Vos, Cambridge University Computer Laboratory
    Copyright   2000  University of Cambridge

Detects definition (Section 3.8 of Chandy & Misra) using LeadsTo
*)

section\<open>The Detects Relation\<close>

theory Detects imports FP SubstAx begin

definition Detects :: "['a set, 'a set] => 'a program set"  (infixl "Detects" 60)
  where "A Detects B = (Always (-A \<union> B)) \<inter> (B LeadsTo A)"

definition Equality :: "['a set, 'a set] => 'a set"  (infixl "<==>" 60)
  where "A <==> B = (-A \<union> B) \<inter> (A \<union> -B)"

(* Corollary from Sectiom 3.6.4 *)

lemma Always_at_FP:
     "[|F \<in> A LeadsTo B; all_total F|] ==> F \<in> Always (-((FP F) \<inter> A \<inter> -B))"
supply [[simproc del: boolean_algebra_cancel_inf]] inf_compl_bot_right[simp del]
apply (rule LeadsTo_empty)
apply (subgoal_tac "F \<in> (FP F \<inter> A \<inter> - B) LeadsTo (B \<inter> (FP F \<inter> -B))")
apply (subgoal_tac [2] " (FP F \<inter> A \<inter> - B) = (A \<inter> (FP F \<inter> -B))")
apply (subgoal_tac "(B \<inter> (FP F \<inter> -B)) = {}")
apply auto
apply (blast intro: PSP_Stable stable_imp_Stable stable_FP_Int)
done

lemma Detects_Trans:
     "[| F \<in> A Detects B; F \<in> B Detects C |] ==> F \<in> A Detects C"
apply (unfold Detects_def Int_def)
apply (simp (no_asm))
apply safe
apply (rule_tac [2] LeadsTo_Trans, auto)
apply (subgoal_tac "F \<in> Always ((-A \<union> B) \<inter> (-B \<union> C))")
 apply (blast intro: Always_weaken)
apply (simp add: Always_Int_distrib)
done

lemma Detects_refl: "F \<in> A Detects A"
apply (unfold Detects_def)
apply (simp (no_asm) add: Un_commute Compl_partition subset_imp_LeadsTo)
done

lemma Detects_eq_Un: "(A<==>B) = (A \<inter> B) \<union> (-A \<inter> -B)"
by (unfold Equality_def, blast)

(*Not quite antisymmetry: sets A and B agree in all reachable states *)
lemma Detects_antisym:
     "[| F \<in> A Detects B;  F \<in> B Detects A|] ==> F \<in> Always (A <==> B)"
apply (unfold Detects_def Equality_def)
apply (simp add: Always_Int_I Un_commute)
done

(* Theorem from Section 3.8 *)

lemma Detects_Always:
     "[|F \<in> A Detects B; all_total F|] ==> F \<in> Always (-(FP F) \<union> (A <==> B))"
apply (unfold Detects_def Equality_def)
apply (simp add: Un_Int_distrib Always_Int_distrib)
apply (blast dest: Always_at_FP intro: Always_weaken)
done

(* Theorem from exercise 11.1 Section 11.3.1 *)

lemma Detects_Imp_LeadstoEQ:
     "F \<in> A Detects B ==> F \<in> UNIV LeadsTo (A <==> B)"
apply (unfold Detects_def Equality_def)
apply (rule_tac B = B in LeadsTo_Diff)
 apply (blast intro: Always_LeadsToI subset_imp_LeadsTo)
apply (blast intro: Always_LeadsTo_weaken)
done

end