(*
 * Arrow's General Possibility Theorem, following Sen.
 * (C)opyright Peter Gammie, peteg42 at gmail.com, commenced July 2006.
 * License: BSD
 *)

(*<*)
theory Arrow

imports SCFs

begin
(*>*)

section{* Arrow's General Possibility Theorem *}

text{*

The proof falls into two parts: showing that a semi-decisive individual is
in fact a dictator, and that a semi-decisive individual exists. I take them
in that order.

It might be good to do some of this in a locale. The complication is
untangling where various witnesses need to be quantified over.

*}

(* **************************************** *)

subsection{* Semi-decisiveness Implies Decisiveness *}

text{*

I follow \cite[Chapter~3*]{Sen:70a} quite closely here. Formalising his
appeal to the @{term "iia"} assumption is the main complication here.

*}

text{* The witness for the first lemma: in the profile $P'$, special agent
$j$ strictly prefers $x$ to $y$ to $z$, and doesn't care about the other
alternatives. Everyone else strictly prefers $y$ to each of $x$ to $z$, and
inherits the relative preferences between $x$ and $z$ from profile $P$.

The model has to be specific about ordering all the other alternatives, but
these are immaterial in the proof that uses this witness. Note also that the
following lemma is used with different instantiations of $x$, $y$ and $z$,
so we need to quantify over them here. This happens implicitly, but in a
locale we would have to be more explicit.

This is just tedious. *}

lemma decisive1_witness:
  assumes has3A: "hasw [x,y,z] A"
      and profileP: "profile A Is P"
      and jIs: "j \<in> Is"
  obtains P'
  where "profile A Is P'"
    and "x \<^bsub>(P' j)\<^esub>\<prec> y \<and> y \<^bsub>(P' j)\<^esub>\<prec> z"
    and "\<And>i. i \<noteq> j \<Longrightarrow> y \<^bsub>(P' i)\<^esub>\<prec> x \<and> y \<^bsub>(P' i)\<^esub>\<prec> z \<and> ((x \<^bsub>(P' i)\<^esub>\<preceq> z) = (x \<^bsub>(P i)\<^esub>\<preceq> z)) \<and> ((z \<^bsub>(P' i)\<^esub>\<preceq> x) = (z \<^bsub>(P i)\<^esub>\<preceq> x))"
proof
  let ?P' = "\<lambda>i. (if i = j then ({ (x, u) | u. u \<in> A }
                               \<union> { (y, u) | u. u \<in> A - {x} }
                               \<union> { (z, u) | u. u \<in> A - {x,y} })
                           else ({ (y, u) | u. u \<in> A }
                               \<union> { (x, u) | u. u \<in> A - {y,z} }
                               \<union> { (z, u) | u. u \<in> A - {x,y} }
                               \<union> (if x \<^bsub>(P i)\<^esub>\<preceq> z then {(x,z)} else {})
                               \<union> (if z \<^bsub>(P i)\<^esub>\<preceq> x then {(z,x)} else {})))
                      \<union> (A - {x,y,z}) \<times> (A - {x,y,z})"
  show "profile A Is ?P'"
  proof
    fix i assume iIs: "i \<in> Is"
    show "rpr A (?P' i)"
    proof(cases "i = j")
      case True with has3A show ?thesis
        by - (rule rprI, simp_all add: trans_def, blast+)
    next
      case False hence ij: "i \<noteq> j" .
      show ?thesis
      proof
        from iIs profileP have "complete A (P i)" by (blast dest: rpr_complete)
        with ij show "complete A (?P' i)" by (simp add: complete_def, blast)
        from iIs profileP have "refl_on A (P i)" by (auto simp add: rpr_def)
        with has3A ij show "refl_on A (?P' i)" by (simp, blast)
        from ij has3A show "trans (?P' i)" by (clarsimp simp add: trans_def)
      qed
    qed
  next
    from profileP show "Is \<noteq> {}" by (rule profile_non_empty)
  qed
  from has3A
  show "x \<^bsub>(?P' j)\<^esub>\<prec> y \<and> y \<^bsub>(?P' j)\<^esub>\<prec> z"
   and "\<And>i. i \<noteq> j \<Longrightarrow> y \<^bsub>(?P' i)\<^esub>\<prec> x \<and> y \<^bsub>(?P' i)\<^esub>\<prec> z \<and> ((x \<^bsub>(?P' i)\<^esub>\<preceq> z) = (x \<^bsub>(P i)\<^esub>\<preceq> z)) \<and> ((z \<^bsub>(?P' i)\<^esub>\<preceq> x) = (z \<^bsub>(P i)\<^esub>\<preceq> x))"
    unfolding strict_pref_def by auto
qed

text {* The key lemma: in the presence of Arrow's assumptions, an individual
who is semi-decisive for $x$ and $y$ is actually decisive for $x$ over any
other alternative $z$. (This is where the quantification becomes important.)
*}

lemma decisive1:
  assumes has3A: "hasw [x,y,z] A"
      and iia: "iia swf A Is"
      and swf: "SWF swf A Is universal_domain"
      and wp: "weak_pareto swf A Is universal_domain"
      and sd: "semidecisive swf A Is {j} x y"
  shows "decisive swf A Is {j} x z"
proof
  from sd show jIs: "{j} \<subseteq> Is" by blast
  fix P
  assume profileP: "profile A Is P"
     and jxzP: "\<And>i. i \<in> {j} \<Longrightarrow> x \<^bsub>(P i)\<^esub>\<prec> z"
  from has3A profileP jIs
  obtain P'
    where profileP': "profile A Is P'"
      and jxyzP': "x \<^bsub>(P' j)\<^esub>\<prec> y" "y \<^bsub>(P' j)\<^esub>\<prec> z"
      and ixyzP': "\<And>i. i \<noteq> j \<longrightarrow> y \<^bsub>(P' i)\<^esub>\<prec> x \<and> y \<^bsub>(P' i)\<^esub>\<prec> z \<and> ((x \<^bsub>(P' i)\<^esub>\<preceq> z) = (x \<^bsub>(P i)\<^esub>\<preceq> z)) \<and> ((z \<^bsub>(P' i)\<^esub>\<preceq> x) = (z \<^bsub>(P i)\<^esub>\<preceq> x))"
    by - (rule decisive1_witness, blast+)
  from iia have "\<And>a b. \<lbrakk> a \<in> {x, z}; b \<in> {x, z} \<rbrakk> \<Longrightarrow> (a \<^bsub>(swf P)\<^esub>\<preceq> b) = (a \<^bsub>(swf P')\<^esub>\<preceq> b)"
  proof(rule iiaE)
    from has3A show "{x,z} \<subseteq> A" by simp
  next
    fix i assume iIs: "i \<in> Is"
    fix a b assume ab: "a \<in> {x, z}" "b \<in> {x, z}"
    show "(a \<^bsub>(P' i)\<^esub>\<preceq> b) = (a \<^bsub>(P i)\<^esub>\<preceq> b)"
    proof(cases "i = j")
      case False
      with ab iIs ixyzP' profileP profileP' has3A
      show ?thesis unfolding profile_def by auto
    next
      case True
      from profileP' jIs jxyzP' have "x \<^bsub>(P' j)\<^esub>\<prec> z"
        by (auto dest: rpr_less_trans)
      with True ab iIs jxzP profileP profileP' has3A
      show ?thesis unfolding profile_def strict_pref_def by auto
    qed
  qed (simp_all add: profileP profileP')
  moreover have "x \<^bsub>(swf P')\<^esub>\<prec> z"
  proof -
    from profileP' sd jxyzP' ixyzP' have "x \<^bsub>(swf P')\<^esub>\<prec> y" by (simp add: semidecisive_def)
    moreover
    from jxyzP' ixyzP' have "\<And>i. i \<in> Is \<Longrightarrow> y \<^bsub>(P' i)\<^esub>\<prec> z" by (case_tac "i=j", auto)
    with wp profileP' has3A have "y \<^bsub>(swf P')\<^esub>\<prec> z" by (auto dest: weak_paretoD)
    moreover note SWF_rpr[OF swf] profileP'
    ultimately show "x \<^bsub>(swf P')\<^esub>\<prec> z"
      unfolding universal_domain_def by (blast dest: rpr_less_trans)
  qed
  ultimately show "x \<^bsub>(swf P)\<^esub>\<prec> z" unfolding strict_pref_def by blast
qed

text{* The witness for the second lemma: special agent $j$ strictly prefers
$z$ to $x$ to $y$, and everyone else strictly prefers $z$ to $x$ and $y$ to
$x$. (In some sense the last part is upside-down with respect to the first
witness.) *}

lemma decisive2_witness:
  assumes has3A: "hasw [x,y,z] A"
      and profileP: "profile A Is P"
      and jIs: "j \<in> Is"
  obtains P'
    where "profile A Is P'"
      and "z \<^bsub>(P' j)\<^esub>\<prec> x \<and> x \<^bsub>(P' j)\<^esub>\<prec> y"
      and "\<And>i. i \<noteq> j \<Longrightarrow> z \<^bsub>(P' i)\<^esub>\<prec> x \<and> y \<^bsub>(P' i)\<^esub>\<prec> x \<and> ((y \<^bsub>(P' i)\<^esub>\<preceq> z) = (y \<^bsub>(P i)\<^esub>\<preceq> z)) \<and> ((z \<^bsub>(P' i)\<^esub>\<preceq> y) = (z \<^bsub>(P i)\<^esub>\<preceq> y))"
proof
  let ?P' = "\<lambda>i. (if i = j then ({ (z, u) | u. u \<in> A }
                               \<union> { (x, u) | u. u \<in> A - {z} }
                               \<union> { (y, u) | u. u \<in> A - {x,z} })
                           else ({ (z, u) | u. u \<in> A - {y} }
                               \<union> { (y, u) | u. u \<in> A - {z} }
                               \<union> { (x, u) | u. u \<in> A - {y,z} }
                               \<union> (if y \<^bsub>(P i)\<^esub>\<preceq> z then {(y,z)} else {})
                               \<union> (if z \<^bsub>(P i)\<^esub>\<preceq> y then {(z,y)} else {})))
                      \<union> (A - {x,y,z}) \<times> (A - {x,y,z})"
  show "profile A Is ?P'"
  proof
    fix i assume iIs: "i \<in> Is"
    show "rpr A (?P' i)"
    proof(cases "i = j")
      case True with has3A show ?thesis
        by - (rule rprI, simp_all add: trans_def, blast+)
    next
      case False hence ij: "i \<noteq> j" .
      show ?thesis
      proof
        from iIs profileP have "complete A (P i)" by (auto simp add: rpr_def)
        with ij show "complete A (?P' i)" by (simp add: complete_def, blast)
        from iIs profileP have "refl_on A (P i)" by (auto simp add: rpr_def)
        with has3A ij show "refl_on A (?P' i)" by (simp, blast)
        from ij has3A show "trans (?P' i)" by (clarsimp simp add: trans_def)
      qed
    qed
  next
    show "Is \<noteq> {}" by (rule profile_non_empty[OF profileP])
  qed
  from has3A
  show "z \<^bsub>(?P' j)\<^esub>\<prec> x \<and> x \<^bsub>(?P' j)\<^esub>\<prec> y"
   and "\<And>i. i \<noteq> j \<Longrightarrow> z \<^bsub>(?P' i)\<^esub>\<prec> x \<and> y \<^bsub>(?P' i)\<^esub>\<prec> x \<and> ((y \<^bsub>(?P' i)\<^esub>\<preceq> z) = (y \<^bsub>(P i)\<^esub>\<preceq> z)) \<and> ((z \<^bsub>(?P' i)\<^esub>\<preceq> y) = (z \<^bsub>(P i)\<^esub>\<preceq> y))"
    unfolding strict_pref_def by auto
qed

lemma decisive2:
  assumes has3A: "hasw [x,y,z] A"
      and iia: "iia swf A Is"
      and swf: "SWF swf A Is universal_domain"
      and wp: "weak_pareto swf A Is universal_domain"
      and sd: "semidecisive swf A Is {j} x y"
  shows "decisive swf A Is {j} z y"
proof
  from sd show jIs: "{j} \<subseteq> Is" by blast
  fix P
  assume profileP: "profile A Is P"
     and jyzP: "\<And>i. i \<in> {j} \<Longrightarrow> z \<^bsub>(P i)\<^esub>\<prec> y"
  from has3A profileP jIs
  obtain P'
    where profileP': "profile A Is P'"
      and jxyzP': "z \<^bsub>(P' j)\<^esub>\<prec> x" "x \<^bsub>(P' j)\<^esub>\<prec> y"
      and ixyzP': "\<And>i. i \<noteq> j \<longrightarrow> z \<^bsub>(P' i)\<^esub>\<prec> x \<and> y \<^bsub>(P' i)\<^esub>\<prec> x \<and> ((y \<^bsub>(P' i)\<^esub>\<preceq> z) = (y \<^bsub>(P i)\<^esub>\<preceq> z)) \<and> ((z \<^bsub>(P' i)\<^esub>\<preceq> y) = (z \<^bsub>(P i)\<^esub>\<preceq> y))"
    by - (rule decisive2_witness, blast+)
  from iia have "\<And>a b. \<lbrakk> a \<in> {y, z}; b \<in> {y, z} \<rbrakk> \<Longrightarrow> (a \<^bsub>(swf P)\<^esub>\<preceq> b) = (a \<^bsub>(swf P')\<^esub>\<preceq> b)"
  proof(rule iiaE)
    from has3A show "{y,z} \<subseteq> A" by simp
  next
    fix i assume iIs: "i \<in> Is"
    fix a b assume ab: "a \<in> {y, z}" "b \<in> {y, z}"
    show "(a \<^bsub>(P' i)\<^esub>\<preceq> b) = (a \<^bsub>(P i)\<^esub>\<preceq> b)"
    proof(cases "i = j")
      case False
      with ab iIs ixyzP' profileP profileP' has3A
      show ?thesis unfolding profile_def by auto
    next
      case True
      from profileP' jIs jxyzP' have "z \<^bsub>(P' j)\<^esub>\<prec> y"
        by (auto dest: rpr_less_trans)
      with True ab iIs jyzP profileP profileP' has3A
      show ?thesis unfolding profile_def strict_pref_def by auto
    qed
  qed (simp_all add: profileP profileP')
  moreover have "z \<^bsub>(swf P')\<^esub>\<prec> y"
  proof -
    from profileP' sd jxyzP' ixyzP' have "x \<^bsub>(swf P')\<^esub>\<prec> y" by (simp add: semidecisive_def)
    moreover
    from jxyzP' ixyzP' have "\<And>i. i \<in> Is \<Longrightarrow> z \<^bsub>(P' i)\<^esub>\<prec> x" by (case_tac "i=j", auto)
    with wp profileP' has3A have "z \<^bsub>(swf P')\<^esub>\<prec> x" by (auto dest: weak_paretoD)
    moreover note SWF_rpr[OF swf] profileP'
    ultimately show "z \<^bsub>(swf P')\<^esub>\<prec> y"
      unfolding universal_domain_def by (blast dest: rpr_less_trans)
  qed
  ultimately show "z \<^bsub>(swf P)\<^esub>\<prec> y" unfolding strict_pref_def by blast
qed

text {* The following results permute $x$, $y$ and $z$ to show how
decisiveness can be obtained from semi-decisiveness in all cases. Again,
quite tedious. *}

lemma decisive3:
  assumes has3A: "hasw [x,y,z] A"
      and iia: "iia swf A Is"
      and swf: "SWF swf A Is universal_domain"
      and wp: "weak_pareto swf A Is universal_domain"
      and sd: "semidecisive swf A Is {j} x z"
  shows "decisive swf A Is {j} y z"
  using has3A decisive2[OF _ iia swf wp sd] by (simp, blast)

lemma decisive4:
  assumes has3A: "hasw [x,y,z] A"
      and iia: "iia swf A Is"
      and swf: "SWF swf A Is universal_domain"
      and wp: "weak_pareto swf A Is universal_domain"
      and sd: "semidecisive swf A Is {j} y z"
  shows "decisive swf A Is {j} y x"
  using has3A decisive1[OF _ iia swf wp sd] by (simp, blast)

lemma decisive5:
  assumes has3A: "hasw [x,y,z] A"
      and iia: "iia swf A Is"
      and swf: "SWF swf A Is universal_domain"
      and wp: "weak_pareto swf A Is universal_domain"
      and sd: "semidecisive swf A Is {j} x y"
  shows "decisive swf A Is {j} y x"
proof -
  from sd
  have "decisive swf A Is {j} x z" by (rule decisive1[OF has3A iia swf wp])
  hence "semidecisive swf A Is {j} x z" by (rule d_imp_sd)
  hence "decisive swf A Is {j} y z" by (rule decisive3[OF has3A iia swf wp])
  hence "semidecisive swf A Is {j} y z" by (rule d_imp_sd)
  thus "decisive swf A Is {j} y x" by (rule decisive4[OF has3A iia swf wp])
qed

lemma decisive6:
  assumes has3A: "hasw [x,y,z] A"
      and iia: "iia swf A Is"
      and swf: "SWF swf A Is universal_domain"
      and wp: "weak_pareto swf A Is universal_domain"
      and sd: "semidecisive swf A Is {j} y x"
  shows "decisive swf A Is {j} y z" "decisive swf A Is {j} z x" "decisive swf A Is {j} x y"
proof -
  from has3A have has3A': "hasw [y,x,z] A" by auto
  show "decisive swf A Is {j} y z" by (rule decisive1[OF has3A' iia swf wp sd])
  show "decisive swf A Is {j} z x" by (rule decisive2[OF has3A' iia swf wp sd])
  show "decisive swf A Is {j} x y" by (rule decisive5[OF has3A' iia swf wp sd])
qed

lemma decisive7:
  assumes has3A: "hasw [x,y,z] A"
      and iia: "iia swf A Is"
      and swf: "SWF swf A Is universal_domain"
      and wp: "weak_pareto swf A Is universal_domain"
      and sd: "semidecisive swf A Is {j} x y"
  shows "decisive swf A Is {j} y z" "decisive swf A Is {j} z x" "decisive swf A Is {j} x y"
proof -
  from sd
  have "decisive swf A Is {j} y x" by (rule decisive5[OF has3A iia swf wp])
  hence "semidecisive swf A Is {j} y x" by (rule d_imp_sd)
  thus "decisive swf A Is {j} y z" "decisive swf A Is {j} z x" "decisive swf A Is {j} x y"
    by (rule decisive6[OF has3A iia swf wp])+
qed

lemma j_decisive_xy:
  assumes has3A: "hasw [x,y,z] A"
      and iia: "iia swf A Is"
      and swf: "SWF swf A Is universal_domain"
      and wp: "weak_pareto swf A Is universal_domain"
      and sd: "semidecisive swf A Is {j} x y"
      and uv: "hasw [u,v] {x,y,z}"
  shows "decisive swf A Is {j} u v"
  using uv decisive1[OF has3A iia swf wp sd]
           decisive2[OF has3A iia swf wp sd]
           decisive5[OF has3A iia swf wp sd]
           decisive7[OF has3A iia swf wp sd]
  by (simp, blast)

lemma j_decisive:
  assumes has3A: "has 3 A"
      and iia: "iia swf A Is"
      and swf: "SWF swf A Is universal_domain"
      and wp: "weak_pareto swf A Is universal_domain"
      and xyA: "hasw [x,y] A"
      and sd: "semidecisive swf A Is {j} x y"
      and uv: "hasw [u,v] A"
  shows "decisive swf A Is {j} u v"
proof -
  from has_extend_witness'[OF has3A xyA]
  obtain z where xyzA: "hasw [x,y,z] A" by auto
  {
    assume ux: "u = x" and vy: "v = y"
    with xyzA iia swf wp sd have ?thesis by (auto intro: j_decisive_xy)
  }
  moreover
  {
    assume ux: "u = x" and vNEy: "v \<noteq> y"
    with uv xyA iia swf wp sd have ?thesis by(auto intro: j_decisive_xy[of x y])
  }
  moreover
  {
    assume uy: "u = y" and vx: "v = x"
    with xyzA iia swf wp sd have ?thesis by (auto intro: j_decisive_xy)
  }
  moreover
  {
    assume uy: "u = y" and vNEx: "v \<noteq> x"
    with uv xyA iia swf wp sd have ?thesis by (auto intro: j_decisive_xy)
  }
  moreover
  {
    assume uNExy: "u \<notin> {x,y}" and vx: "v = x"
    with uv xyA iia swf wp sd have ?thesis by (auto intro: j_decisive_xy[of x y])
  }
  moreover
  {
    assume uNExy: "u \<notin> {x,y}" and vy: "v = y"
    with uv xyA iia swf wp sd have ?thesis by (auto intro: j_decisive_xy[of x y])
  }
  moreover
  {
    assume uNExy: "u \<notin> {x,y}" and vNExy: "v \<notin> {x,y}"
    with uv xyA iia swf wp sd
    have "decisive swf A Is {j} x u" by (auto intro: j_decisive_xy[where x=x and z=u])
    hence sdxu: "semidecisive swf A Is {j} x u" by (rule d_imp_sd)
    with uNExy vNExy uv xyA iia swf wp have ?thesis by (auto intro: j_decisive_xy[of x])
  }
  ultimately show ?thesis by blast
qed

text {* The first result: if $j$ is semidecisive for some alternatives $u$
and $v$, then they are actually a dictator. *}

lemma sd_imp_dictator:
  assumes has3A: "has 3 A"
      and iia: "iia swf A Is"
      and swf: "SWF swf A Is universal_domain"
      and wp: "weak_pareto swf A Is universal_domain"
      and uv: "hasw [u,v] A"
      and sd: "semidecisive swf A Is {j} u v"
  shows "dictator swf A Is j"
proof
  fix x y assume x: "x \<in> A" and y: "y \<in> A"
  show "decisive swf A Is {j} x y"
  proof(cases "x = y")
    case True with sd show "decisive swf A Is {j} x y" by (blast intro: d_refl)
  next
    case False
    with x y iia swf wp has3A uv sd show "decisive swf A Is {j} x y"
      by (auto intro: j_decisive)
  qed
next
  from sd show "j \<in> Is" by blast
qed

(* **************************************** *)

subsection{* The Existence of a Semi-decisive Individual *}

text{* The second half of the proof establishes the existence of a
semi-decisive individual. The required witness is essentially an encoding of
the Condorcet pardox (aka "the paradox of voting" that shows we get tied up
in knots if a certain agent didn't have dictatorial powers. *}

text {* This proof is unfortunately long. Many of the statements rely on a
lot of context, making it difficult to split it up. *}

lemma sd_exists:
  assumes has3A: "has 3 A"
      and finiteIs: "finite Is"
      and twoIs: "has 2 Is"
      and iia: "iia swf A Is"
      and swf: "SWF swf A Is universal_domain"
      and wp: "weak_pareto swf A Is universal_domain"
  shows "\<exists>j u v. hasw [u,v] A \<and> semidecisive swf A Is {j} u v"
proof -
  let ?P = "\<lambda>S. S \<subseteq> Is \<and> S \<noteq> {} \<and> (\<exists>u v. hasw [u,v] A \<and> semidecisive swf A Is S u v)"
  obtain u v where uvA: "hasw [u,v] A"
    using has_witness_two[OF has3A] by auto
      -- {* The weak pareto requirement implies that the set of all
      individuals is decisive between any given alternatives. *}
  hence "decisive swf A Is Is u v"
    by - (rule, auto intro: weak_paretoD[OF wp])
  hence "semidecisive swf A Is Is u v" by (rule d_imp_sd)
  with uvA twoIs has_suc_notempty[where n=1] nat_2[symmetric]
  have "?P Is" by auto
      -- {* Obtain a minimally-sized semi-decisive set. *}
  from ex_has_least_nat[where P="?P" and m="card", OF this]
  obtain V x y where VIs: "V \<subseteq> Is"
    and Vnotempty: "V \<noteq> {}"
    and xyA: "hasw [x,y] A"
    and Vsd: "semidecisive swf A Is V x y"
    and Vmin: "\<And>V'. ?P V' \<Longrightarrow> card V \<le> card V'"
    by blast
  from VIs finiteIs have Vfinite: "finite V" by (rule finite_subset)
      -- {* Show that minimal set contains a single individual. *}
  from Vfinite Vnotempty have "\<exists>j. V = {j}"
  proof(rule finite_set_singleton_contra)
    assume Vcard: "1 < card V"
    then obtain j where jV: "{j} \<subseteq> V"
      using has_extend_witness[where xs="[]", OF card_has[where n="card V"]] by auto
        -- {* Split an individual from the "minimal" set. *}
    let ?V1 = "{j}"
    let ?V2 = "V - ?V1"
    let ?V3 = "Is - V"
    from jV card_Diff_singleton[OF Vfinite] Vcard
    have V2card: "card ?V2 > 0" "card ?V2 < card V" by auto
    hence V2notempty: "{} \<noteq> ?V2" by auto
    from jV VIs
    have jV2V3: "Is = ?V1 \<union> ?V2 \<union> ?V3 \<and> ?V1 \<inter> ?V2 = {} \<and> ?V1 \<inter> ?V3 = {} \<and> ?V2 \<inter> ?V3 = {}"
      by auto
        -- {* Show that that individual is semi-decisive for $x$ over $z$. *}
    from has_extend_witness'[OF has3A xyA]
    obtain z where threeDist: "hasw [x,y,z] A" by auto
    from sd_exists_witness[OF threeDist jV2V3] VIs Vnotempty
    obtain P where profileP: "profile A Is P"
               and V1xyzP: "x \<^bsub>(P j)\<^esub>\<prec> y \<and> y \<^bsub>(P j)\<^esub>\<prec> z"
               and V2xyzP: "\<forall>i \<in> ?V2. z \<^bsub>(P i)\<^esub>\<prec> x \<and> x \<^bsub>(P i)\<^esub>\<prec> y"
               and V3xyzP: "\<forall>i \<in> ?V3. y \<^bsub>(P i)\<^esub>\<prec> z \<and> z \<^bsub>(P i)\<^esub>\<prec> x"
      by (simp, blast)
    have xPz: "x \<^bsub>(swf P)\<^esub>\<prec> z"
    proof(rule rpr_less_le_trans[where y="y"])
      from profileP swf show "rpr A (swf P)" by auto
    next
        -- {* V2 is semi-decisive, and everyone else opposes their choice. Ergo they prevail. *}
      show "x \<^bsub>(swf P)\<^esub>\<prec> y"
      proof -
        from profileP V3xyzP
        have "\<forall>i \<in> ?V3. y \<^bsub>(P i)\<^esub>\<prec> x" by (blast dest: rpr_less_trans)
        with profileP V1xyzP V2xyzP Vsd
        show ?thesis unfolding semidecisive_def by auto
      qed
    next
      -- {* This result is unfortunately quite tortuous. *}
      from SWF_rpr[OF swf] show "y \<^bsub>(swf P)\<^esub>\<preceq> z"
      proof(rule rpr_less_not[OF _ _ notI])
        from threeDist show "hasw [z, y] A" by auto
      next
        assume zPy: "z \<^bsub>(swf P)\<^esub>\<prec> y"
        have "semidecisive swf A Is ?V2 z y"
        proof
          from VIs show "V - {j} \<subseteq> Is" by blast
        next
          fix P'
          assume profileP': "profile A Is P'"
            and V2yz': "\<And>i. i \<in> ?V2 \<Longrightarrow> z \<^bsub>(P' i)\<^esub>\<prec> y"
            and nV2yz': "\<And>i. i \<in> Is - ?V2 \<Longrightarrow> y \<^bsub>(P' i)\<^esub>\<prec> z"
          from iia have "\<And>a b. \<lbrakk> a \<in> {y, z}; b \<in> {y, z} \<rbrakk> \<Longrightarrow> (a \<^bsub>(swf P)\<^esub>\<preceq> b) = (a \<^bsub>(swf P')\<^esub>\<preceq> b)"
          proof(rule iiaE)
            from threeDist show yzA: "{y,z} \<subseteq> A" by simp
          next
            fix i assume iIs: "i \<in> Is"
            fix a b assume ab: "a \<in> {y, z}" "b \<in> {y, z}"
            with VIs profileP V2xyzP
            have V2yzP: "\<forall>i \<in> ?V2. z \<^bsub>(P i)\<^esub>\<prec> y" by (blast dest: rpr_less_trans)
            show "(a \<^bsub>(P' i)\<^esub>\<preceq> b) = (a \<^bsub>(P i)\<^esub>\<preceq> b)"
            proof(cases "i \<in> ?V2")
              case True
              with VIs profileP profileP' ab V2yz' V2yzP threeDist
              show ?thesis unfolding strict_pref_def profile_def by auto
            next
              case False
              from V1xyzP V3xyzP
              have "\<forall>i \<in> Is - ?V2. y \<^bsub>(P i)\<^esub>\<prec> z" by auto
              with iIs False VIs jV profileP profileP' ab nV2yz' threeDist
              show ?thesis unfolding profile_def strict_pref_def by auto
            qed
          qed (simp_all add: profileP profileP')
          with zPy show "z \<^bsub>(swf P')\<^esub>\<prec> y" unfolding strict_pref_def by blast
        qed
        with VIs Vsd Vmin[where V'="?V2"] V2card V2notempty threeDist show False
          by auto
      qed (simp add: profileP threeDist)
    qed
    have "semidecisive swf A Is ?V1 x z"
    proof
      from jV VIs show "{j} \<subseteq> Is" by blast
    next
      -- {* Use @{term "iia"} to show the SWF must allow the individual to prevail. *}
      fix P'
      assume profileP': "profile A Is P'"
         and V1yz': "\<And>i. i \<in> ?V1 \<Longrightarrow> x \<^bsub>(P' i)\<^esub>\<prec> z"
         and nV1yz': "\<And>i. i \<in> Is - ?V1 \<Longrightarrow> z \<^bsub>(P' i)\<^esub>\<prec> x"
      from iia have "\<And>a b. \<lbrakk> a \<in> {x, z}; b \<in> {x, z} \<rbrakk> \<Longrightarrow> (a \<^bsub>(swf P)\<^esub>\<preceq> b) = (a \<^bsub>(swf P')\<^esub>\<preceq> b)"
      proof(rule iiaE)
        from threeDist show xzA: "{x,z} \<subseteq> A" by simp
      next
        fix i assume iIs: "i \<in> Is"
        fix a b assume ab: "a \<in> {x, z}" "b \<in> {x, z}"
        show "(a \<^bsub>(P' i)\<^esub>\<preceq> b) = (a \<^bsub>(P i)\<^esub>\<preceq> b)"
        proof(cases "i \<in> ?V1")
          case True
          with jV VIs profileP V1xyzP
          have "\<forall>i \<in> ?V1. x \<^bsub>(P i)\<^esub>\<prec> z" by (blast dest: rpr_less_trans)
          with True jV VIs profileP profileP' ab V1yz' threeDist
          show ?thesis unfolding strict_pref_def profile_def by auto
        next
          case False
          from V2xyzP V3xyzP
          have "\<forall>i \<in> Is - ?V1. z \<^bsub>(P i)\<^esub>\<prec> x" by auto
          with iIs False VIs jV profileP profileP' ab nV1yz' threeDist
          show ?thesis unfolding strict_pref_def profile_def by auto
        qed
      qed (simp_all add: profileP profileP')
      with xPz show "x \<^bsub>(swf P')\<^esub>\<prec> z" unfolding strict_pref_def by blast
    qed
    with jV VIs Vsd Vmin[where V'="?V1"] V2card threeDist show False
      by auto
  qed
  with xyA Vsd show ?thesis by blast
qed

(* **************************************** *)

subsection{* Arrow's General Possibility Theorem *}

text{*

Finally we conclude with the celebrated ``possibility'' result. Note that we
assume the set of individuals is finite; \cite{Routley:79} relaxes this with
some fancier set theory. Having an infinite set of alternatives doesn't
matter, though the result is a bit more plausible if we assume finiteness
\cite[p54]{Sen:70a}.

*}

theorem ArrowGeneralPossibility:
  assumes has3A: "has 3 A"
      and finiteIs: "finite Is"
      and has2Is: "has 2 Is"
      and iia: "iia swf A Is"
      and swf: "SWF swf A Is universal_domain"
      and wp: "weak_pareto swf A Is universal_domain"
  obtains j where "dictator swf A Is j"
  using sd_imp_dictator[OF has3A iia swf wp]
        sd_exists[OF has3A finiteIs has2Is iia swf wp]
  by blast

(*<*)
end
(*>*)


section \<open>Lazy evaluation within the logic\<close>
theory Lazy_Eval
imports
  Complex_Main
begin

text \<open>
  This is infrastructure to lazily evaluate an expression (typically something corecursive)
  within the logic by simple rewriting. A signature of supported (co-)datatype constructures
  upon which pattern matching is allowed and a list of function equations that are used in
  rewriting must be provided.

  One can then e.\,g.\ determine whether a given pattern matches a given expression. To do this,
  the expression will be rewritten using the given function equations until enough constructors
  have been exposed to decide whether the pattern matches.

  This infrastructure was developed specifically for evaluating Multiseries expressions, but
  can, in principle, be used for other purposes as well.
\<close>

lemma meta_eq_TrueE: "PROP P \<equiv> Trueprop True \<Longrightarrow> PROP P" by simp

datatype cmp_result = LT | EQ | GT

definition COMPARE :: "real \<Rightarrow> real \<Rightarrow> cmp_result" where
  "COMPARE x y = (if x < y then LT else if x > y then GT else EQ)"

lemma COMPARE_intros:
  "x < y \<Longrightarrow> COMPARE x y \<equiv> LT" "x > y \<Longrightarrow> COMPARE x y \<equiv> GT" "x = y \<Longrightarrow> COMPARE x y \<equiv> EQ"
  by (simp_all add: COMPARE_def)

primrec CMP_BRANCH :: "cmp_result \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a" where
  "CMP_BRANCH LT x y z = x"
| "CMP_BRANCH EQ x y z = y"
| "CMP_BRANCH GT x y z = z"

ML_file \<open>lazy_eval.ML\<close>

end


(*  Title:      ZF/AC/Hartog.thy
    Author:     Krzysztof Grabczewski

Hartog's function.
*)

theory Hartog
imports AC_Equiv
begin

definition
  Hartog :: "i => i"  where
   "Hartog(X) == \<mu> i. ~ i \<lesssim> X"

lemma Ords_in_set: "\<forall>a. Ord(a) \<longrightarrow> a \<in> X ==> P"
apply (rule_tac X = "{y \<in> X. Ord (y) }" in ON_class [elim_format])
apply fast
done

lemma Ord_lepoll_imp_ex_well_ord:
     "[| Ord(a); a \<lesssim> X |]
      ==> \<exists>Y. Y \<subseteq> X & (\<exists>R. well_ord(Y,R) & ordertype(Y,R)=a)"
apply (unfold lepoll_def)
apply (erule exE)
apply (intro exI conjI)
  apply (erule inj_is_fun [THEN fun_is_rel, THEN image_subset])
 apply (rule well_ord_rvimage [OF bij_is_inj well_ord_Memrel])
  apply (erule restrict_bij [THEN bij_converse_bij])
apply (rule subset_refl, assumption)
apply (rule trans)
apply (rule bij_ordertype_vimage)
apply (erule restrict_bij [THEN bij_converse_bij])
apply (rule subset_refl)
apply (erule well_ord_Memrel)
apply (erule ordertype_Memrel)
done

lemma Ord_lepoll_imp_eq_ordertype:
     "[| Ord(a); a \<lesssim> X |] ==> \<exists>Y. Y \<subseteq> X & (\<exists>R. R \<subseteq> X*X & ordertype(Y,R)=a)"
apply (drule Ord_lepoll_imp_ex_well_ord, assumption, clarify)
apply (intro exI conjI)
apply (erule_tac [3] ordertype_Int, auto)
done

lemma Ords_lepoll_set_lemma:
     "(\<forall>a. Ord(a) \<longrightarrow> a \<lesssim> X) ==>
       \<forall>a. Ord(a) \<longrightarrow>
        a \<in> {b. Z \<in> Pow(X)*Pow(X*X), \<exists>Y R. Z=<Y,R> & ordertype(Y,R)=b}"
apply (intro allI impI)
apply (elim allE impE, assumption)
apply (blast dest!: Ord_lepoll_imp_eq_ordertype intro: sym)
done

lemma Ords_lepoll_set: "\<forall>a. Ord(a) \<longrightarrow> a \<lesssim> X ==> P"
by (erule Ords_lepoll_set_lemma [THEN Ords_in_set])

lemma ex_Ord_not_lepoll: "\<exists>a. Ord(a) & ~a \<lesssim> X"
apply (rule ccontr)
apply (best intro: Ords_lepoll_set)
done

lemma not_Hartog_lepoll_self: "~ Hartog(A) \<lesssim> A"
apply (unfold Hartog_def)
apply (rule ex_Ord_not_lepoll [THEN exE])
apply (rule LeastI, auto)
done

lemmas Hartog_lepoll_selfE = not_Hartog_lepoll_self [THEN notE]

lemma Ord_Hartog: "Ord(Hartog(A))"
by (unfold Hartog_def, rule Ord_Least)

lemma less_HartogE1: "[| i < Hartog(A); ~ i \<lesssim> A |] ==> P"
by (unfold Hartog_def, fast elim: less_LeastE)

lemma less_HartogE: "[| i < Hartog(A); i \<approx> Hartog(A) |] ==> P"
by (blast intro: less_HartogE1 eqpoll_sym eqpoll_imp_lepoll
                 lepoll_trans [THEN Hartog_lepoll_selfE])

lemma Card_Hartog: "Card(Hartog(A))"
by (fast intro!: CardI Ord_Hartog elim: less_HartogE)

end


(*<*)
theory Regex
  imports
    "MFOTL_Monitor_Devel.Trace"
    "HOL-Library.Lattice_Syntax"
    "HOL-Library.Extended_Nat"
begin
(*>*)

section \<open>Regular expressions\<close>

context begin

qualified datatype (atms: 'a) regex = Skip nat | Test 'a
  | Plus "'a regex" "'a regex" | Times "'a regex" "'a regex"  | Star "'a regex"

lemma finite_atms[simp]: "finite (atms r)"
  by (induct r) auto

definition "Wild = Skip 1"

lemma size_regex_estimation[termination_simp]: "x \<in> atms r \<Longrightarrow> y < f x \<Longrightarrow> y < size_regex f r"
  by (induct r) auto

lemma size_regex_estimation'[termination_simp]: "x \<in> atms r \<Longrightarrow> y \<le> f x \<Longrightarrow> y \<le> size_regex f r"
  by (induct r) auto

qualified definition "TimesL r S = Times r ` S"
qualified definition "TimesR R s = (\<lambda>r. Times r s) ` R"

qualified primrec fv_regex where
  "fv_regex fv (Skip n) = {}"
| "fv_regex fv (Test \<phi>) = fv \<phi>"
| "fv_regex fv (Plus r s) = fv_regex fv r \<union> fv_regex fv s"
| "fv_regex fv (Times r s) = fv_regex fv r \<union> fv_regex fv s"
| "fv_regex fv (Star r) = fv_regex fv r"

lemma fv_regex_cong[fundef_cong]:
  "r = r' \<Longrightarrow> (\<And>z. z \<in> atms r \<Longrightarrow> fv z = fv' z) \<Longrightarrow> fv_regex fv r = fv_regex fv' r'"
  by (induct r arbitrary: r') auto

lemma finite_fv_regex[simp]: "(\<And>z. z \<in> atms r \<Longrightarrow> finite (fv z)) \<Longrightarrow> finite (fv_regex fv r)"
  by (induct r) auto

lemma fv_regex_commute:
  "(\<And>z. z \<in> atms r \<Longrightarrow> x \<in> fv z \<longleftrightarrow> g x \<in> fv' z) \<Longrightarrow> x \<in> fv_regex fv r \<longleftrightarrow> g x \<in> fv_regex fv' r"
  by (induct r) auto

lemma fv_regex_alt: "fv_regex fv r = (\<Union>z \<in> atms r. fv z)"
  by (induct r) auto

qualified definition nfv_regex where
  "nfv_regex fv r = Max (insert 0 (Suc ` fv_regex fv r))"

lemma insert_Un: "insert x (A \<union> B) = insert x A \<union> insert x B"
  by auto

lemma nfv_regex_simps[simp]:
  assumes [simp]: "(\<And>z. z \<in> atms r \<Longrightarrow> finite (fv z))" "(\<And>z. z \<in> atms s \<Longrightarrow> finite (fv z))"
  shows
  "nfv_regex fv (Skip n) = 0"
  "nfv_regex fv (Test \<phi>) = Max (insert 0 (Suc ` fv \<phi>))"
  "nfv_regex fv (Plus r s) = max (nfv_regex fv r) (nfv_regex fv s)"
  "nfv_regex fv (Times r s) = max (nfv_regex fv r) (nfv_regex fv s)"
  "nfv_regex fv (Star r) = nfv_regex fv r"
  unfolding nfv_regex_def
  by (auto simp add: image_Un Max_Un insert_Un simp del: Un_insert_right Un_insert_left)

abbreviation "min_regex_default f r j \<equiv> (if atms r = {} then j else Min ((\<lambda>z. f z j) ` atms r))"

qualified primrec match :: "(nat \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a regex \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> bool" where
  "match test (Skip n) = (\<lambda>i j. j = i + n)"
| "match test (Test \<phi>) = (\<lambda>i j. i = j \<and> test i \<phi>)"
| "match test (Plus r s) = match test r \<squnion> match test s"
| "match test (Times r s) = match test r OO match test s"
| "match test (Star r) = (match test r)\<^sup>*\<^sup>*"

lemma match_cong[fundef_cong]:
  "r = r' \<Longrightarrow> (\<And>i z. z \<in> atms r \<Longrightarrow> t i z = t' i z) \<Longrightarrow> match t r = match t' r'"
  by (induct r arbitrary: r') auto

qualified primrec eps where
  "eps test i (Skip n) = (n = 0)"
| "eps test i (Test \<phi>) = test i \<phi>"
| "eps test i (Plus r s) = (eps test i r \<or> eps test i s)"
| "eps test i (Times r s) = (eps test i r \<and> eps test i s)"
| "eps test i (Star r) = True"

qualified primrec lpd where
  "lpd test i (Skip n) = (case n of 0 \<Rightarrow> {} | Suc m \<Rightarrow> {Skip m})"
| "lpd test i (Test \<phi>) = {}"
| "lpd test i (Plus r s) = (lpd test i r \<union> lpd test i s)"
| "lpd test i (Times r s) = TimesR (lpd test i r) s \<union> (if eps test i r then lpd test i s else {})"
| "lpd test i (Star r) = TimesR (lpd test i r) (Star r)"

qualified primrec lpd\<kappa> where
  "lpd\<kappa> \<kappa> test i (Skip n) = (case n of 0 \<Rightarrow> {} | Suc m \<Rightarrow> {\<kappa> (Skip m)})"
| "lpd\<kappa> \<kappa> test i (Test \<phi>) = {}"
| "lpd\<kappa> \<kappa> test i (Plus r s) = lpd\<kappa> \<kappa> test i r \<union> lpd\<kappa> \<kappa> test i s"
| "lpd\<kappa> \<kappa> test i (Times r s) = lpd\<kappa> (\<lambda>t. \<kappa> (Times t s)) test i r \<union> (if eps test i r then lpd\<kappa> \<kappa> test i s else {})"
| "lpd\<kappa> \<kappa> test i (Star r) = lpd\<kappa> (\<lambda>t. \<kappa> (Times t (Star r))) test i r"

qualified primrec rpd where
  "rpd test i (Skip n) = (case n of 0 \<Rightarrow> {} | Suc m \<Rightarrow> {Skip m})"
| "rpd test i (Test \<phi>) = {}"
| "rpd test i (Plus r s) = (rpd test i r \<union> rpd test i s)"
| "rpd test i (Times r s) = TimesL r (rpd test i s) \<union> (if eps test i s then rpd test i r else {})"
| "rpd test i (Star r) = TimesL (Star r) (rpd test i r)"

qualified primrec rpd\<kappa> where
  "rpd\<kappa> \<kappa> test i (Skip n) = (case n of 0 \<Rightarrow> {} | Suc m \<Rightarrow> {\<kappa> (Skip m)})"
| "rpd\<kappa> \<kappa> test i (Test \<phi>) = {}"
| "rpd\<kappa> \<kappa> test i (Plus r s) = rpd\<kappa> \<kappa> test i r \<union> rpd\<kappa> \<kappa> test i s"
| "rpd\<kappa> \<kappa> test i (Times r s) = rpd\<kappa> (\<lambda>t. \<kappa> (Times r t)) test i s \<union> (if eps test i s then rpd\<kappa> \<kappa> test i r else {})"
| "rpd\<kappa> \<kappa> test i (Star r) = rpd\<kappa> (\<lambda>t. \<kappa> (Times (Star r) t)) test i r"

lemma lpd\<kappa>_lpd: "lpd\<kappa> \<kappa> test i r = \<kappa> ` lpd test i r"
  by (induct r arbitrary: \<kappa>) (auto simp: TimesR_def split: nat.splits)

lemma rpd\<kappa>_rpd: "rpd\<kappa> \<kappa> test i r = \<kappa> ` rpd test i r"
  by (induct r arbitrary: \<kappa>) (auto simp: TimesL_def split: nat.splits)

lemma match_le: "match test r i j \<Longrightarrow> i \<le> j"
proof (induction r arbitrary: i j)
  case (Times r s)
  then show ?case using order.trans by fastforce
next
  case (Star r)
  from Star.prems show ?case
    unfolding match.simps by (induct i j rule: rtranclp.induct) (force dest: Star.IH)+
qed auto

lemma match_rtranclp_le: "(match test r)\<^sup>*\<^sup>* i j \<Longrightarrow> i \<le> j"
  by (metis match.simps(5) match_le)

lemma eps_match: "eps test i r \<longleftrightarrow> match test r i i"
  by (induction r) (auto dest: antisym[OF match_le match_le])

lemma lpd_match: "i < j \<Longrightarrow> match test r i j \<longleftrightarrow> (\<Squnion>s \<in> lpd test i r. match test s) (i + 1) j"
proof (induction r arbitrary: i j)
  case (Times r s)
  have "match test (Times r s) i j \<longleftrightarrow> (\<exists>k. match test r i k \<and> match test s k j)"
    by auto
  also have "\<dots> \<longleftrightarrow> match test r i i \<and> match test s i j \<or>
    (\<exists>k>i. match test r i k \<and> match test s k j)"
    using match_le[of test r i] nat_less_le by auto
  also have "\<dots> \<longleftrightarrow> match test r i i \<and> (\<Squnion>t \<in> lpd test i s. match test t) (i + 1) j \<or>
    (\<exists>k>i. (\<Squnion>t \<in> lpd test i r. match test t) (i + 1) k \<and> match test s k j)"
    using Times.IH(1) Times.IH(2)[OF Times.prems] by metis
  also have "\<dots> \<longleftrightarrow> match test r i i \<and> (\<Squnion>t \<in> lpd test i s. match test t) (i + 1) j \<or>
    (\<exists>k. (\<Squnion>t \<in> lpd test i r. match test t) (i + 1) k \<and> match test s k j)"
    using Times.prems by (intro disj_cong[OF refl] iff_exI) (auto dest: match_le)
  also have "\<dots> \<longleftrightarrow> (\<Squnion> (match test ` lpd test i (Times r s))) (i + 1) j"
    by (force simp: TimesL_def TimesR_def eps_match)
  finally show ?case .
next
  case (Star r)
  have "\<exists>s\<in>lpd test i r. (match test s OO (match test r)\<^sup>*\<^sup>*) (i + 1) j" if "(match test r)\<^sup>*\<^sup>* i j"
    using that Star.prems match_le[of test _ "i + 1"]
  proof (induct rule: converse_rtranclp_induct)
    case (step i k)
    then show ?case
      by (cases "i < k") (auto simp: not_less Star.IH dest: match_le)
  qed simp
  with Star.prems show ?case using match_le[of test _  "i + 1"]
    by (auto simp: TimesL_def TimesR_def Suc_le_eq Star.IH[of i]
      elim!: converse_rtranclp_into_rtranclp[rotated])
qed (auto split: nat.splits)

lemma rpd_match: "i < j \<Longrightarrow> match test r i j \<longleftrightarrow> (\<Squnion>s \<in> rpd test j r. match test s) i (j - 1)"
proof (induction r arbitrary: i j)
  case (Times r s)
  have "match test (Times r s) i j \<longleftrightarrow> (\<exists>k. match test r i k \<and> match test s k j)"
    by auto
  also have "\<dots> \<longleftrightarrow> match test r i j \<and> match test s j j \<or>
    (\<exists>k<j. match test r i k \<and> match test s k j)"
    using match_le[of test s _ j] nat_less_le by auto
  also have "\<dots> \<longleftrightarrow> (\<Squnion>t \<in> rpd test j r. match test t) i (j - 1) \<and> match test s j j  \<or>
    (\<exists>k<j. match test r i k \<and> (\<Squnion>t \<in> rpd test j s. match test t) k (j - 1))"
    using Times.IH(1)[OF Times.prems] Times.IH(2) by metis
  also have "\<dots> \<longleftrightarrow> (\<Squnion>t \<in> rpd test j r. match test t) i (j - 1) \<and> match test s j j  \<or>
    (\<exists>k. match test r i k \<and> (\<Squnion>t \<in> rpd test j s. match test t) k (j - 1))"
    using Times.prems by (intro disj_cong[OF refl] iff_exI) (auto dest: match_le)
  also have "\<dots> \<longleftrightarrow> (\<Squnion> (match test ` rpd test j (Times r s))) i (j - 1)"
    by (force simp: TimesL_def TimesR_def eps_match)
  finally show ?case .
next
  case (Star r)
  have "\<exists>s\<in>rpd test j r. ((match test r)\<^sup>*\<^sup>* OO match test s) i (j - 1)" if "(match test r)\<^sup>*\<^sup>* i j"
    using that Star.prems match_le[of test _ _ "j - 1"]
  proof (induct rule: rtranclp_induct)
    case (step k j)
    then show ?case
      by (cases "k < j") (auto simp: not_less Star.IH dest: match_le)
  qed simp
  with Star.prems show ?case
    by (auto 0 3 simp: TimesL_def TimesR_def intro: Star.IH[of _ j, THEN iffD2]
      elim!: rtranclp.rtrancl_into_rtrancl dest: match_le[of test _ _ "j - 1", unfolded One_nat_def])
qed (auto split: nat.splits)

lemma lpd_fv_regex: "s \<in> lpd test i r \<Longrightarrow> fv_regex fv s \<subseteq> fv_regex fv r"
  by (induct r arbitrary: s) (auto simp: TimesR_def TimesL_def split: if_splits nat.splits)+

lemma rpd_fv_regex: "s \<in> rpd test i r \<Longrightarrow> fv_regex fv s \<subseteq> fv_regex fv r"
  by (induct r arbitrary: s) (auto simp: TimesR_def TimesL_def split: if_splits nat.splits)+

lemma match_fv_cong:
  "(\<And>i x. x \<in> atms r \<Longrightarrow> test i x = test' i x) \<Longrightarrow> match test r = match test' r"
  by (induct r) auto

lemma eps_fv_cong:
  "(\<And>i x. x \<in> atms r \<Longrightarrow> test i x = test' i x) \<Longrightarrow> eps test i r = eps test' i r"
  by (induct r) auto

datatype modality = Past | Futu
datatype safety = Strict | Lax

context
  fixes fv :: "'a \<Rightarrow> 'b set"
  and safe :: "safety \<Rightarrow> 'a \<Rightarrow> bool"
begin

qualified fun safe_regex :: "modality \<Rightarrow> safety \<Rightarrow> 'a regex \<Rightarrow> bool" where
  "safe_regex m _ (Skip n) = True"
| "safe_regex m g (Test \<phi>) = safe g \<phi>"
| "safe_regex m g (Plus r s) = ((g = Lax \<or> fv_regex fv r = fv_regex fv s) \<and> safe_regex m g r \<and> safe_regex m g s)"
| "safe_regex Futu g (Times r s) =
    ((g = Lax \<or> fv_regex fv r \<subseteq> fv_regex fv s) \<and> safe_regex Futu g s \<and> safe_regex Futu Lax r)"
| "safe_regex Past g (Times r s) =
    ((g = Lax \<or> fv_regex fv s \<subseteq> fv_regex fv r) \<and> safe_regex Past g r \<and> safe_regex Past Lax s)"
| "safe_regex m g (Star r) = ((g = Lax \<or> fv_regex fv r = {}) \<and> safe_regex m g r)"

lemmas safe_regex_induct = safe_regex.induct[case_names Skip Test Plus TimesF TimesP Star]

lemma safe_cosafe:
  "(\<And>x. x \<in> atms r \<Longrightarrow> safe Strict x \<Longrightarrow> safe Lax x) \<Longrightarrow> safe_regex m Strict r \<Longrightarrow> safe_regex m Lax r"
  by (induct r; cases m) auto

lemma safe_lpd_fv_regex_le: "safe_regex Futu Strict r \<Longrightarrow> s \<in> lpd test i r \<Longrightarrow> fv_regex fv r \<subseteq> fv_regex fv s"
  by (induct r) (auto simp: TimesR_def split: if_splits)

lemma safe_lpd_fv_regex: "safe_regex Futu Strict r \<Longrightarrow> s \<in> lpd test i r \<Longrightarrow> fv_regex fv s = fv_regex fv r"
  by (simp add: eq_iff lpd_fv_regex safe_lpd_fv_regex_le)

lemma cosafe_lpd: "safe_regex Futu Lax r \<Longrightarrow> s \<in> lpd test i r \<Longrightarrow> safe_regex Futu Lax s"
proof (induct r arbitrary: s)
  case (Plus r1 r2)
  from Plus(3,4) show ?case
    by (auto elim: Plus(1,2))
next
  case (Times r1 r2)
  from Times(3,4) show ?case
    by (auto simp: TimesR_def elim: Times(1,2) split: if_splits)
qed (auto simp: TimesR_def split: nat.splits)

lemma safe_lpd: "(\<forall>x \<in> atms r. safe Strict x \<longrightarrow> safe Lax x) \<Longrightarrow>
  safe_regex Futu Strict r \<Longrightarrow> s \<in> lpd test i r \<Longrightarrow> safe_regex Futu Strict s"
proof (induct r arbitrary: s)
  case (Plus r1 r2)
  from Plus(3,4,5) show ?case
    by (auto elim: Plus(1,2) simp: ball_Un)
next
  case (Times r1 r2)
  from Times(3,4,5) show ?case
    by (force simp: TimesR_def ball_Un elim: Times(1,2) cosafe_lpd dest: lpd_fv_regex split: if_splits)
next
  case (Star r)
  from Star(2,3,4) show ?case
    by (force simp: TimesR_def elim: Star(1) cosafe_lpd
      dest: safe_cosafe[rotated] lpd_fv_regex[where fv=fv] split: if_splits)
qed (auto split: nat.splits)

lemma safe_rpd_fv_regex_le: "safe_regex Past Strict r \<Longrightarrow> s \<in> rpd test i r \<Longrightarrow> fv_regex fv r \<subseteq> fv_regex fv s"
  by (induct r) (auto simp: TimesL_def split: if_splits)

lemma safe_rpd_fv_regex: "safe_regex Past Strict r \<Longrightarrow> s \<in> rpd test i r \<Longrightarrow> fv_regex fv s = fv_regex fv r"
  by (simp add: eq_iff rpd_fv_regex safe_rpd_fv_regex_le)

lemma cosafe_rpd: "safe_regex Past Lax r \<Longrightarrow> s \<in> rpd test i r \<Longrightarrow> safe_regex Past Lax s"
proof (induct r arbitrary: s)
  case (Plus r1 r2)
  from Plus(3,4) show ?case
    by (auto elim: Plus(1,2))
next
  case (Times r1 r2)
  from Times(3,4) show ?case
    by (auto simp: TimesL_def elim: Times(1,2) split: if_splits)
qed (auto simp: TimesL_def split: nat.splits)

lemma safe_rpd: "(\<forall>x \<in> atms r. safe Strict x \<longrightarrow> safe Lax x) \<Longrightarrow>
  safe_regex Past Strict r \<Longrightarrow> s \<in> rpd test i r \<Longrightarrow> safe_regex Past Strict s"
proof (induct r arbitrary: s)
  case (Plus r1 r2)
  from Plus(3,4,5) show ?case
    by (auto elim: Plus(1,2) simp: ball_Un)
next
  case (Times r1 r2)
  from Times(3,4,5) show ?case
    by (force simp: TimesL_def ball_Un elim: Times(1,2) cosafe_rpd dest: rpd_fv_regex split: if_splits)
next
  case (Star r)
  from Star(2,3,4) show ?case
    by (force simp: TimesL_def elim: Star(1) cosafe_rpd
      dest: safe_cosafe[rotated] rpd_fv_regex[where fv=fv] split: if_splits)
qed (auto split: nat.splits)

lemma safe_regex_safe: "(\<And>g r. safe g r \<Longrightarrow> safe Lax r) \<Longrightarrow>
  safe_regex m g r \<Longrightarrow> x \<in> atms r \<Longrightarrow> safe Lax x"
  by (induct m g r rule: safe_regex.induct) auto

lemma safe_regex_map_regex:
  "(\<And>g x. x \<in> atms r \<Longrightarrow> safe g x \<Longrightarrow>  safe g (f x)) \<Longrightarrow> (\<And>x. x \<in> atms r \<Longrightarrow> fv (f x) = fv x) \<Longrightarrow>
   safe_regex m g r \<Longrightarrow> safe_regex m g (map_regex f r)"
  by (induct m g r rule: safe_regex.induct) (auto simp: fv_regex_alt regex.set_map)

end

lemma safe_regex_cong[fundef_cong]:
  "(\<And>g x. x \<in> atms r \<Longrightarrow> safe g x = safe' g x) \<Longrightarrow>
  Regex.safe_regex fv safe m g r = Regex.safe_regex fv safe' m g r"
  by (induct m g r rule: safe_regex.induct) auto

lemma safe_regex_mono:
  "(\<And>g x. x \<in> atms r \<Longrightarrow> safe g x \<Longrightarrow> safe' g x) \<Longrightarrow>
  Regex.safe_regex fv safe m g r \<Longrightarrow> Regex.safe_regex fv safe' m g r"
  by (induct m g r rule: safe_regex.induct) auto

lemma match_map_regex: "match t (map_regex f r) = match (\<lambda>k z. t k (f z)) r"
  by (induct r) auto

lemma match_cong_strong:
  "(\<And>k z. k \<in> {i ..< j + 1} \<Longrightarrow> z \<in> atms r \<Longrightarrow> t k z = t' k z) \<Longrightarrow> match t r i j = match t' r i j"
proof (induction r arbitrary: i j)
  case (Times r s)
  from Times.prems show ?case
    by (auto 0 4 simp: relcompp_apply intro: le_less_trans match_le less_Suc_eq_le
      dest: Times.IH[THEN iffD1, rotated -1] Times.IH[THEN iffD2, rotated -1] match_le)
next
  case (Star r)
  show ?case unfolding match.simps
  proof (rule iffI)
    assume *: "(match t r)\<^sup>*\<^sup>* i j"
    then have "i \<le> j" unfolding match.simps(5)[symmetric]
      by (rule match_le)
    with * show "(match t' r)\<^sup>*\<^sup>* i j" using Star.prems
    proof (induction i j rule: rtranclp.induct)
      case (rtrancl_into_rtrancl a b c)
      from rtrancl_into_rtrancl(1,2,4,5) show ?case
        by (intro rtranclp.rtrancl_into_rtrancl[OF rtrancl_into_rtrancl.IH])
          (auto dest!: Star.IH[THEN iffD1, rotated -1]
            dest: match_le match_rtranclp_le simp: less_Suc_eq_le)
    qed simp
  next
    assume *: "(match t' r)\<^sup>*\<^sup>* i j"
    then have "i \<le> j" unfolding match.simps(5)[symmetric]
      by (rule match_le)
    with * show "(match t r)\<^sup>*\<^sup>* i j" using Star.prems
    proof (induction i j rule: rtranclp.induct)
      case (rtrancl_into_rtrancl a b c)
      from rtrancl_into_rtrancl(1,2,4,5) show ?case
        by (intro rtranclp.rtrancl_into_rtrancl[OF rtrancl_into_rtrancl.IH])
          (auto dest!: Star.IH[THEN iffD2, rotated -1]
            dest: match_le match_rtranclp_le simp: less_Suc_eq_le)
    qed simp
  qed
qed auto

end

(*<*)
end
(*>*)


theory Refinement
imports AT
begin

(* Improvement possibility:
The first two conditions in mod_trans could be part of Kripke type_def and thus become implicit *)
definition refinement :: "[('a::state) kripke,('a'::state) \<Rightarrow> 'a, 'a' kripke] \<Rightarrow> bool" ("(_ \<sqsubseteq>\<^sub>_ _)" 50)
  where "K \<sqsubseteq>\<^sub>E K' = (init K' \<subseteq> states K' \<and> init K \<subseteq> states K \<and>
    (\<forall> s' \<in> (states K'). (\<forall> s \<in> (init K'). (s \<rightarrow>\<^sub>i* s') \<longrightarrow> (E s) \<in> (init K) \<and> (E s) \<rightarrow>\<^sub>i* (E s'))))"

lemma init_ref: "K \<sqsubseteq>\<^sub>E K' \<Longrightarrow> E ` (init K') \<subseteq> (init K)"
  apply (simp add: refinement_def)
  apply (rule subsetI)
  apply (erule imageE)
  apply (rotate_tac -2)
  apply (erule ssubst)
  apply (erule conjE)+
  apply (drule_tac x = xa in bspec)
  apply (erule subsetD, assumption)
  apply (drule_tac x = xa in bspec)
  apply assumption
  apply (erule impE)
  apply (simp add: state_transition_refl_def)
by (erule conjE, assumption)

(* This version allows that the init in the refinement "deletes" some initial states *)
theorem prop_pres:  "K \<sqsubseteq>\<^sub>E K' \<Longrightarrow> (\<forall> s' \<in> (Pow (states K')).
                      (K' \<turnstile> EF s') \<longrightarrow> (Kripke (states K)(E ` (init K')) \<turnstile> EF (E ` s')))"
  apply clarify
  apply (frule init_ref)
  apply (unfold refinement_def)
  apply (erule conjE)+
  apply (simp add: check_def)
  apply (rule subsetI)
  apply (rule CollectI)
  apply (rule conjI)
  apply (rule_tac A = "init K" in subsetD, assumption)
   apply (rule_tac A = "E ` init K'" in subsetD, assumption+)
  apply (subgoal_tac "? y. y \<in> init K' \<and> E y = x")
   prefer 2
  apply force
  apply (erule exE)
  apply (erule conjE)
   apply (rotate_tac 1)
   apply (drule subsetD, assumption)
   apply (erule CollectE)
  apply (erule conjE)
   apply (drule EF_step_star_rev)
  apply (erule bexE)
  apply (drule_tac x = ya in bspec)
  apply (erule subsetD, assumption)
  apply (drule_tac x = y in bspec, assumption)
  apply (drule mp, assumption)
  apply (erule conjE)
  apply (rule_tac y = "E ya" in EF_step_star)
   apply (erule subst, assumption)
by simp

(* In this version of the property preservation theorem, the init_ref condition is
   stronger so it will be disallowed to "delete" initial states during refinement.
   Then the second more complex Kripke structure in prop_pres becomes simply K *)
lemma Kripke_self: "K = Kripke (states K) (init K)"
  apply (case_tac K)
by simp

theorem prop_pres':  "K \<sqsubseteq>\<^sub>E K' \<Longrightarrow> init K \<subseteq> E ` (init K') \<Longrightarrow> (\<forall> s' \<in> (Pow (states K')).
                      (K' \<turnstile> EF s') \<longrightarrow> (K \<turnstile> EF (E ` s')))"
  apply (subgoal_tac "init K = E ` (init K')")
   apply (subgoal_tac "K = Kripke (states K)(init K)")
  apply (rotate_tac -1)
  apply (erule ssubst)
    apply (erule ssubst)
  apply (rule prop_pres, assumption)
   apply (rule Kripke_self)
  apply (rule subset_antisym, assumption)
by (erule init_ref)

theorem strong_mt[rule_format]:
"init K' \<subseteq> states K' \<and> init K \<subseteq> states K \<and> E ` (init K') \<subseteq> (init K) \<and> (\<forall> s s'. s \<rightarrow>\<^sub>i s' \<longrightarrow> (E s) \<rightarrow>\<^sub>i (E s')) \<Longrightarrow>
                                K \<sqsubseteq>\<^sub>E K'"
  apply (unfold refinement_def)
  apply simp
  apply (erule conjE)+
  apply (rule ballI)+
  apply (rule impI)
  apply (rule conjI)
   apply (erule subsetD)
   apply (erule imageI)
  apply (subgoal_tac "(\<forall>s::'a. s \<rightarrow>\<^sub>i s' \<longrightarrow> E s \<rightarrow>\<^sub>i E s') \<longrightarrow> s \<rightarrow>\<^sub>i* s' \<longrightarrow> E s \<rightarrow>\<^sub>i* E s'")
   apply simp
  apply (simp add: state_transition_refl_def)
  apply (erule_tac rtrancl_induct)
   apply simp
  apply (drule_tac x = y in spec)
  apply (drule_tac x = z in spec)
  apply (drule mp, simp)
  apply (erule rtrancl_into_rtrancl)
  apply (rule CollectI)
  by simp

theorem strong_mt'[rule_format]:
"init K' \<subseteq> states K' \<and> init K \<subseteq> states K \<and> E ` (init K') \<subseteq> (init K) \<and>
     (\<forall> s s'. (\<exists> s0 \<in> init K'. s0  \<rightarrow>\<^sub>i* s) \<longrightarrow> s \<rightarrow>\<^sub>i s' \<longrightarrow> (E s) \<rightarrow>\<^sub>i (E s')) \<Longrightarrow>
                                K \<sqsubseteq>\<^sub>E K'"
  apply (unfold refinement_def)
  apply simp
  apply (erule conjE)+
  apply (rule ballI)+
  apply (rule impI)
  apply (rule conjI)
   apply (erule subsetD)
   apply (erule imageI)
  apply (subgoal_tac "(\<forall>s::'a. (\<exists> s0 \<in> init K'. s0  \<rightarrow>\<^sub>i* s) \<longrightarrow> s \<rightarrow>\<^sub>i s' \<longrightarrow> E s \<rightarrow>\<^sub>i E s') \<longrightarrow>
                                  (\<exists> s0 \<in> init K'. s0  \<rightarrow>\<^sub>i* s) \<longrightarrow> s \<rightarrow>\<^sub>i* s' \<longrightarrow> E s \<rightarrow>\<^sub>i* E s'")
   apply simp
   apply (erule mp)
   apply (rule_tac x = s in bexI)
    apply (simp add: state_transition_refl_def, assumption)
     apply (simp add: state_transition_refl_def)
  apply (erule_tac rtrancl_induct)
   apply simp
  apply (rule impI)
  apply (drule mp)
  apply assumption
   apply (drule_tac x = y in spec)
(* *)
  apply (rotate_tac -1)
   apply (drule mp)
    apply (rule_tac x = s in bexI)
  apply assumption+
  apply (erule rtrancl_into_rtrancl)
   apply (rule CollectI)
by simp

theorem strong_mt''[rule_format]:
"init K' \<subseteq> states K' \<and> init K \<subseteq> states K \<and> E ` (init K') \<subseteq> (init K) \<and>
     (\<forall> s s'. (\<exists> s0 \<in> init K'. s0  \<rightarrow>\<^sub>i* s) \<longrightarrow> s \<rightarrow>\<^sub>i s' \<longrightarrow> (E s) \<rightarrow>\<^sub>i* (E s')) \<Longrightarrow>
                                K \<sqsubseteq>\<^sub>E K'"
  apply (unfold refinement_def)
  apply simp
  apply (erule conjE)+
  apply (rule ballI)+
  apply (rule impI)
  apply (rule conjI)
   apply (erule subsetD)
   apply (erule imageI)
  apply (subgoal_tac "(\<forall>s::'a. (\<exists> s0 \<in> init K'. s0  \<rightarrow>\<^sub>i* s) \<longrightarrow> s \<rightarrow>\<^sub>i s' \<longrightarrow> E s \<rightarrow>\<^sub>i* E s') \<longrightarrow>
                                  (\<exists> s0 \<in> init K'. s0  \<rightarrow>\<^sub>i* s) \<longrightarrow> s \<rightarrow>\<^sub>i* s' \<longrightarrow> E s \<rightarrow>\<^sub>i* E s'")
   apply simp
   apply (erule mp)
   apply (rule_tac x = s in bexI)
    apply (simp add: state_transition_refl_def, assumption)
     apply (simp add: state_transition_refl_def)
  apply (erule_tac rtrancl_induct)
   apply simp
  apply (rule impI)
  apply (drule mp)
  apply assumption
  apply (drule_tac x = y in spec)
  apply (rotate_tac -1)
   apply (drule mp)
    apply (rule_tac x = s in bexI)
    apply assumption+
  thm rtrancl_trans
  apply (erule rtrancl_trans)
by simp

definition RR_cycle :: "[('a::state) kripke, ('a'::state)kripke, 'a' set] \<Rightarrow> bool"
  where "RR_cycle K K' s = (\<exists> (E:: ('a'::state) \<Rightarrow> 'a). (K \<turnstile> EF (E `s)) \<and> (K \<sqsubseteq>\<^sub>E K')  \<longrightarrow> \<not>(K' \<turnstile> EF s))"

end


theory Assertions
  imports "../Algebra/BBI" Heap "$ISABELLE_HOME/src/HOL/Eisbach/Eisbach"
begin

no_notation
  times (infixl "*" 70) and
  sup (infixl "+" 65) and
  bot ("\<bottom>")

notation plus (infixl "+" 65)

type_synonym 'a pred = "('a \<times> heap) set"

(*****************************************************************************************)
section {* Separation Conjunction *}
(*****************************************************************************************)

definition emp :: "'a pred" where
  "emp \<equiv> {(s, h). h = Map.empty}"

definition sep :: "'a pred \<Rightarrow> 'a pred \<Rightarrow> 'a pred" (infixl "*" 80) where
  "p * q \<equiv> {(s, h1 ++ h2) | s h1 h2. h1 \<bottom> h2 \<and> (s, h1) \<in> p \<and> (s, h2) \<in> q}"

lemma sep_assoc: "(p * q) * r = p * (q * r)"
  apply (auto simp: sep_def)
  using Heap.pmult_ab1 Heap.pmult_ab2 Heap.pmult_ab_assoc apply blast
  using Heap.pmult_def_eq by blast

lemma sep_comm: "p * q = q * p"
  apply (auto simp: sep_def)
  using Heap.pmult_comm Heap.pmult_comm_def apply blast
  using Heap.pmult_comm Heap.pmult_comm_def by blast

(*****************************************************************************************)
section {* Algebraic structure *}
(*****************************************************************************************)

interpretation bbi!: bbi Inf Sup inf less_eq less sup bot top minus uminus sep emp
  apply default
  apply (simp_all add: sep_assoc)
  apply (simp add: sep_comm)
  apply (auto simp: sep_def emp_def)
done

abbreviation wand :: "'a pred \<Rightarrow> 'a pred \<Rightarrow> 'a pred" (infixl "-*" 75) where
  "p -* q \<equiv> bbi.sep_impl p q"

abbreviation (input)
  constants :: "'b \<Rightarrow> ('a \<Rightarrow> 'b)" ("$_") where
  "$x \<equiv> \<lambda>_. x"

abbreviation
  pred_ex :: "('b \<Rightarrow> 'a set) \<Rightarrow> 'a set" (binder "EXS " 10) where
  "EXS x. P x \<equiv> {s. \<exists>x. s \<in> P x}"

abbreviation (input)
  pred_all :: "('b \<Rightarrow> 'a set) \<Rightarrow> 'a set" (binder "ALLS " 10) where
  "ALLS x. P x \<equiv> {s. \<forall>x. s \<in> P x}"

abbreviation (input)
  pred_eq :: "('a \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> 'a pred" (infix "\<Midarrow>" 50) where
  "e \<Midarrow> e' \<equiv> {(s, h). e s = e' s}"

abbreviation true :: "'a pred" where
  "true \<equiv> \<top>"

abbreviation false :: "'a pred" where
  "false \<equiv> {}"

lemma pred_le_exI: "P x \<subseteq> (EXS x. P x)"
  by auto

lemma pred_le_exE: "(\<And>x. P x \<subseteq> Q) \<Longrightarrow> (EXS x. P x) \<subseteq> Q"
  by auto

lemma exs_sepl: "(EXS x. P x) * Q = (EXS x. P x * Q)"
  by (auto simp: sep_def)

lemma exs_sepr: "P * (EXS x. Q x) = (EXS x. P * Q x)"
  by (auto simp: sep_def)

lemma mono_exs: "(\<And>x. P x \<subseteq> Q x) \<Longrightarrow> (EXS x. P x) \<subseteq> (EXS y. Q y)"
  by auto

(*****************************************************************************************)
section {* Assertions only about store *}
(*****************************************************************************************)

definition store_pred :: "'a set \<Rightarrow> 'a pred" ("<_>") where
  "<P> \<equiv> {(s, h). s \<in> P} \<sqinter> emp"

lemma sp_sep: "<p> * <q> = <p \<sqinter> q>"
  by (auto simp: store_pred_def emp_def sep_def)

lemma sp_sep_inf: "<p> * (<q> * r) = <p \<sqinter> q> * r"
  by (auto simp: store_pred_def emp_def sep_def)

lemma sp_sep_comm: "p * <q>  = <q> * p"
  by (simp add: sep_comm)

lemma sp_sep_comm_var: "q * (<p> * r) = <p> * (q * r)"
  by (auto simp: store_pred_def emp_def sep_def)

lemma sp_emp [simp]: "<UNIV> = emp"
  by (auto simp: store_pred_def)

(*****************************************************************************************)
section {* Variables and Expressions *}
(*****************************************************************************************)

type_synonym ('v, 's) exp = "'s \<Rightarrow> 'v"
type_synonym 'a nat_exp = "'a \<Rightarrow> nat"

text {* The left value of a variable is an update function. *}
type_synonym ('v, 's) lval = "('v \<Rightarrow> 'v) \<Rightarrow> 's \<Rightarrow> 's"

text {* The right value of a variable is a retrieve function. *}
type_synonym ('v, 's) rval = "'s \<Rightarrow> 'v"

text {* A variable is then a pair of left and right values, satisfying some properties. *}
type_synonym ('v, 's) var = "('v, 's) lval \<times> ('v, 's) rval"

abbreviation (input) subst :: "('s \<Rightarrow> 'v) \<Rightarrow> ('v, 's) lval \<Rightarrow> ('v, 's) rval \<Rightarrow> 's \<Rightarrow> 'v" where
  "subst e u_upd v \<equiv> \<lambda>s. e (u_upd (\<lambda>_. v s) s)"

abbreviation free :: "('v, 's) lval \<Rightarrow> ('s \<Rightarrow> 'v) \<Rightarrow> bool" where
  "free u_upd e \<equiv> \<forall>s t. e (u_upd (\<lambda>_. t) s) = e s"

abbreviation vars1 :: "('v, 's) lval \<Rightarrow> ('v, 's) rval \<Rightarrow> bool" where
  "vars1 u_upd u \<equiv> \<forall>s t. u (u_upd (\<lambda>_. t) s) = t"

abbreviation vars2 :: "('v, 's) lval \<Rightarrow> ('v, 's) rval \<Rightarrow> ('v, 's) rval \<Rightarrow> bool" where
  "vars2 u_upd u v \<equiv> \<forall>s. u (u_upd (\<lambda>_. v s) s) = v s"

abbreviation vars3 :: "('v, 's) lval \<Rightarrow> ('v, 's) rval \<Rightarrow> bool" where
  "vars3 u_upd v \<equiv> \<forall>s t. v (u_upd (\<lambda>_. t s) s) = v s"

definition subst_pred :: "('s \<times> 'h) set \<Rightarrow> ('v, 's) lval \<Rightarrow> ('v, 's) rval \<Rightarrow> ('s \<times> 'h) set" where
  "subst_pred P u t \<equiv> Collect (\<lambda>(s, h). (u (\<lambda>_. t s) s, h) \<in> P)"

abbreviation subst_pred_s :: "'s set \<Rightarrow> ('v, 's) lval \<Rightarrow> ('v, 's) rval \<Rightarrow> 's set" where
  "subst_pred_s P u t \<equiv> Collect (\<lambda>s. (u (\<lambda>_. t s) s) \<in> P)"

abbreviation (input) free_pred :: "('v, 's) lval \<Rightarrow> 's pred \<Rightarrow> bool" where
  "free_pred v R \<equiv> \<forall>t. R = subst_pred R v t"

(*****************************************************************************************)
section {* Substitution Lemmas *}
(*****************************************************************************************)

named_theorems spred

lemma subst_true [spred]: "subst_pred true j_update i = true"
  by (auto simp: subst_pred_def)

lemma subst_inf [spred]: "subst_pred (P \<sqinter> Q) i_update j = (subst_pred P i_update j) \<sqinter> (subst_pred Q i_update j)"
  by (auto simp: subst_pred_def)

lemma subst_sep [spred]: "subst_pred (P * Q) i_update j = (subst_pred P i_update j) * (subst_pred Q i_update j)"
  by (auto simp: subst_pred_def sep_def)

lemma subst_wand [spred]: "subst_pred (P -* Q) i_update j = (subst_pred P i_update j) -* (subst_pred Q i_update j)"
  oops

lemma subst_exs [spred]: "subst_pred (EXS k. (P k)) i_update j = (EXS k. (subst_pred (P k) i_update j))"
  by (auto simp: subst_pred_def)

(*****************************************************************************************)
section {* Predicates over the Heaplet Model*}
(*****************************************************************************************)

definition singleton :: "'a nat_exp \<Rightarrow> 'a nat_exp \<Rightarrow> 'a pred" ("_ \<mapsto> _" [50, 50] 60) where
  "e \<mapsto> e' \<equiv> {(s, h). h = [e s \<mapsto> e' s]}"

definition any_singleton :: "'a nat_exp \<Rightarrow> 'a pred" ("_ \<mapsto> -" [50] 60) where
  "e \<mapsto> - \<equiv> EXS e'. e \<mapsto> $e'"

definition points_to :: "'a nat_exp \<Rightarrow> 'a nat_exp \<Rightarrow> 'a pred" ("_ \<hookrightarrow> _" [50, 50] 60) where
  "e \<hookrightarrow> e' \<equiv> (e \<mapsto> e') * \<top>"

definition any_points_to :: "'a nat_exp \<Rightarrow> 'a pred" ("_ \<hookrightarrow> -" [50] 60) where
  "e \<hookrightarrow> - \<equiv> (e \<mapsto> -) * \<top>"

definition doublet :: "'a nat_exp \<Rightarrow> 'a nat_exp \<Rightarrow> 'a nat_exp \<Rightarrow> 'a pred" ("_ \<mapsto> _, _" [50, 50, 50] 60) where
  "e \<mapsto> e1, e2 \<equiv> (e \<mapsto> e1) * ((\<lambda>s. plus (e s) 1) \<mapsto> e2)"

lemma subst_singleton [spred]: "subst_pred (x \<mapsto> y) i_update j = (subst x i_update j \<mapsto> subst y i_update j)"
  by (auto simp: subst_pred_def singleton_def)

lemma subst_any_singleton [spred]: "subst_pred (x \<mapsto> -) i_update j = (subst x i_update j \<mapsto> -)"
  by (auto simp: subst_pred_def any_singleton_def singleton_def)

lemma subst_doublet [spred]: "subst_pred (x \<mapsto> y, z) i_update j = (subst x i_update j \<mapsto> subst y i_update j, subst z i_update j)"
  by (simp add: doublet_def spred)

lemma subst_no_state [spred]: "subst_pred {(s, h). P} i_update j = {(s, h). P}"
  by (simp add: subst_pred_def)

lemma [spred]: "subst_pred <P> i_update j = <subst_pred_s P i_update j>"
  by (auto simp: subst_pred_def store_pred_def emp_def)

(*****************************************************************************************)
section {* Arbitrary Lemmas *}
(*****************************************************************************************)

lemma wand_ineq: "{(s, h). \<forall>h'. h \<bottom> h' \<and> (s, h') \<in> P \<longrightarrow> (s, h ++ h') \<in> Q} \<le> P -* Q"
  apply (rule bbi.sep_implI1)
  apply (clarsimp simp: sep_def)
done

lemma reynolds1: "(a \<mapsto> a') \<sqinter> (b \<mapsto> b') = (a \<mapsto> a') \<sqinter> (a \<Midarrow> b) \<sqinter> (a' \<Midarrow> b')"
  apply (auto simp: singleton_def)
  apply (metis fun_upd_apply option.distinct(1))
  by (metis fun_upd_apply option.sel)

lemma reynolds2: "(a \<hookrightarrow> a') * (b \<hookrightarrow> b') \<le> -(a \<Midarrow> b)"
  by (auto simp: points_to_def singleton_def sep_def ortho_def)

lemma reynolds3: "(ALLS x. - P x) = - (EXS x. P x)"
  by auto

lemma reynolds4_helper: "\<forall>s h. - Q h \<longrightarrow> P (s, h) \<Longrightarrow> - {s. P s} \<subseteq> {(s, h). Q h}"
  by auto

lemma reynolds4: "emp = (ALLS x. -(x \<hookrightarrow> -))"
  apply (subst reynolds3)
  apply (rule antisym)
  apply (simp add: emp_def)
  prefer 2
  apply (subst emp_def)
  apply (rule reynolds4_helper)
  apply (auto simp: any_points_to_def any_singleton_def singleton_def sep_def ortho_def)
  apply (subgoal_tac "\<exists>n. n \<in> dom h")
  prefer 2
  apply force
  apply auto
  apply (rule_tac x="\<lambda>x. n" in exI)
  apply (rule_tac x="[n \<mapsto> y]" in exI)
  apply (rule_tac x="h(n := None)" in exI)
  apply (auto intro: heap_split)
  by (metis fun_upd_same map_add_None)

lemma reynolds5: "(e \<mapsto> e') * ((e \<mapsto> e') -* p) \<le> (e \<hookrightarrow> e') \<sqinter> p"
  apply (subst points_to_def)
  apply (rule bbi.sep_impl_to_meet)
done

lemma reynolds6_helper: "R * {(s, h). \<forall>h'. h \<bottom> h' \<and> (s, h') \<in> P \<longrightarrow> (s, h ++ h') \<in> Q} \<le> R * (P -* Q)"
  using bbi.Sup.qisol wand_ineq by blast

lemma reynolds6: "(e \<hookrightarrow> e') \<sqinter> p \<le> (e \<mapsto> e') * ((e \<mapsto> e') -* p)"
  apply (rule order_trans)
  prefer 2
  apply (rule reynolds6_helper)
  apply (auto simp: points_to_def singleton_def sep_def ortho_def)
  apply (erule_tac x=h2 in allE)
  apply auto
  by (simp add: domIff map_add_upd_left)

lemma reynolds6_var: "P \<le> (e \<mapsto> e') * true \<Longrightarrow> P \<le> Q \<Longrightarrow> P \<le> (e \<mapsto> e') * ((e \<mapsto> e') -* Q)"
  apply (rule order_trans[rotated])
  apply (rule reynolds6)
  apply (auto simp: points_to_def)
done

(*****************************************************************************************)
section {* Tactics *}
(*****************************************************************************************)

(* sep_simp lemmas *)

named_theorems sep_simp

lemmas [sep_simp] =
  bbi.mult_1_left
  bbi.mult_1_right
  bbi.mult_1_left
  bbi.sep_conj_top
  doublet_def
  points_to_def
  any_singleton_def
  any_points_to_def
  Set.Diff_eq
  sep_assoc
  exs_sepl
  exs_sepr
  sp_sep
  sp_sep_inf
  sp_sep_comm
  sp_sep_comm_var
  sp_emp

lemma [sep_simp]: "true * p = p * true"
  by (simp add: sep_comm)

lemma [sep_simp, simp]: "<{}> = bot"
  by (auto simp: store_pred_def)

lemma [sep_simp, simp]: "s \<in> (if P then UNIV else {}) = P"
  by auto

(* some intro and elim lemmas *)

lemma infI: "(s, h) \<in> P \<Longrightarrow> (s, h) \<in> Q \<Longrightarrow> (s, h) \<in> P \<sqinter> Q"
  by auto

lemma infE: "(s, h) \<in> P \<sqinter> Q \<Longrightarrow> ((s, h) \<in> P \<Longrightarrow> (s, h) \<in> Q \<Longrightarrow> G) \<Longrightarrow> G"
  by auto

lemma pred_exI: "(s, h) \<in> P x \<Longrightarrow> (s, h) \<in> (EXS x. P x)"
  by auto

lemma pred_exE: "(s, h) \<in> (EXS x. P x) \<Longrightarrow> (\<And>x. (s, h) \<in> P x \<Longrightarrow> Q) \<Longrightarrow> Q"
  by auto

lemma spE: "(s, h) \<in> <P> * Q \<Longrightarrow> (s \<in> P \<Longrightarrow> (s, h) \<in> Q \<Longrightarrow> R) \<Longrightarrow> R"
  by (auto simp: store_pred_def emp_def sep_def)

lemma spI: "s \<in> P \<Longrightarrow> (s, h) \<in> Q \<Longrightarrow> (s, h) \<in> <P> * Q"
  by (auto simp: store_pred_def emp_def sep_def)

(* Heap reduction lemmas *)

lemma heap_reductl: "(s, h) \<in> p \<Longrightarrow> (q = emp) \<Longrightarrow> (s, h) \<in> p * q"
  by (auto simp: sep_def emp_def)

lemma heap_reductr: "(s, h) \<in> q \<Longrightarrow> (p = emp) \<Longrightarrow> (s, h) \<in> p * q"
  by (auto simp: sep_def emp_def)

lemma heap_reduct2: "(s, h) \<in> p * q \<Longrightarrow> (\<And>h'. dom h' \<subseteq> dom h \<Longrightarrow> (s, h') \<in> q \<Longrightarrow> (s, h') \<in> q') \<Longrightarrow> (s, h) \<in> p * q'"
  apply (auto simp: sep_def)
  apply (rule_tac x=h1 in exI)
  apply (rule_tac x=h2 in exI)
  apply auto
done

lemma pure_allE: "(\<And>x. P x \<Longrightarrow> Q x) \<Longrightarrow> P y \<Longrightarrow> Q y"
  by auto

lemma heap_reduct3: "(s, h) \<in> p * q \<Longrightarrow> (\<And>h. (s, h) \<in> q \<Longrightarrow> (s, h) \<in> p' * q') \<Longrightarrow> (s, h) \<in> p' * (p * q')"
  apply (auto simp: sep_def ortho_def)
  apply (drule pure_allE, auto)
  apply (rule_tac x=h1a in exI)
  apply (rule_tac x="h1 ++ h2a" in exI)
  apply auto
  apply (metis Heap.pmult_def_eq dom_map_add heap_add_comm ortho_def)
  apply (rule_tac x=h1 in exI)
  apply (rule_tac x="h2a" in exI)
  apply force
done

lemma heap_reduct4: "(s, h) \<in> p * r \<Longrightarrow> (\<And>h. (s, h) \<in> p \<Longrightarrow> (s, h) \<in> q1 * (q2 * q3)) \<Longrightarrow> (s, h) \<in> q1 * (q2 * (q3 * r))"
  apply (auto simp: sep_def ortho_def)
  apply (drule pure_allE, auto)
  apply (rule_tac x=h1a in exI)
  apply (rule_tac x="h1b ++ h2b ++ h2" in exI)
  apply auto
  apply (rule_tac x=h1b in exI)
  apply (rule_tac x="h2b ++ h2" in exI)
  apply auto
  apply (rule_tac x=h2b in exI)
  apply (rule_tac x=h2 in exI)
  apply auto
done

(* Some intro and elim rules *)

named_theorems sep_intro
named_theorems sep_elim

lemma singlE [sep_elim]: "(s, h) \<in> (i \<mapsto> e) * p \<Longrightarrow> e s = e' s \<Longrightarrow> (\<And>h'. (s, h') \<in> p \<Longrightarrow> (s, h') \<in> q) \<Longrightarrow> (s, h) \<in> (i \<mapsto> e') * q"
  by (auto simp: sep_def ortho_def singleton_def)

lemma singlE_var [sep_elim]: "(s, h) \<in> (i \<mapsto> e) * p \<Longrightarrow> e s = e' s \<Longrightarrow> (\<And>h'. (s, h') \<in> p \<Longrightarrow> (s, h') \<in> q * r) \<Longrightarrow> (s, h) \<in> q * ((i \<mapsto> e') * r)"
  apply (auto simp: sep_def ortho_def singleton_def)
  apply (drule pure_allE, auto)
  apply (erule_tac x=h1 in allE)
  apply auto
  apply (erule_tac x="[i s \<mapsto> e' s] ++ h2a" in allE)
  apply auto
  apply (erule contrapos_pp) back back back back back back
  apply simp
by (simp add: domIff map_add_upd_left)

(* Tactics*)

method sep_simp =
  (subst sep_simp | subst (asm) sep_simp | subst spred | subst (asm) spred | rule pred_le_exE)+

named_theorems sep_safe_intro
named_theorems sep_safe_elim

method sep_same = (
    ((erule heap_reductl | erule heap_reductr| erule heap_reduct2 | erule heap_reduct3 | erule heap_reduct4)+)?
)

method sep_safe_split =
  (
    ((rule Set.IntI)+)?;
      (
        ((erule Set.IntE)+)?,
        ((erule pred_exE)+)?,
        ((erule spE)+)?,

        sep_same?,
        (sep_simp, sep_safe_split)?,
        (assumption | rule HOL.refl)?
      )
  )

method sep_split =
  (
    sep_safe_split;
    ((rule pred_exI)+)?,
    ((rule spI)+)?;
    simp?;
    (
      (sep_same | sep_simp, sep_split)?,
      (assumption | rule HOL.refl)?
    )
  )

method sep_safe = (
    sep_simp?,
    (rule subrelI)?,
    sep_safe_split?;

    (((erule sep_safe_elim)+, force); sep_safe_split?)?;
    sep_same?;
    (assumption | rule HOL.refl)?
)

method sep_auto uses elim intro =
  (
    sep_simp?,
    (rule subrelI)?,

    sep_split?;
    ((erule sep_elim | rule sep_intro)+; simp?, sep_split?)?;
    sep_same?;
    (assumption | rule HOL.refl)?;
    auto?
  )

end


theory BinarySearch_HL
imports
  Main
  "../../HL_State"
begin

section\<open>Binary Search\<close>
text\<open>This is proof of the binary search algorithm. It is inspired by the proof of the same algorithm in "Verification of Sequential and Concurrent Programs".
     The algorithm is straightforward; it searches recursively after a specific value in a sorted list of numbers. It halves the size of the array it is looking at for each iteration (using the fact that the array is sorted).
     If the number exists in the array it will be found - which in this case means that @{text mid} is the index that is storing the value.\<close>

subsection\<open>Definition of the environment\<close>
record env =
  right :: "nat"
  left  :: "nat"
  arr   :: "nat list"
  mid   :: "nat"
  val   :: "nat"

subsubsection\<open>Monad update functions\<close>
text\<open>Each of the definitions takes an environment and a value of one of the variables. They update the value of the variable and outputs a new environment.\<close>
definition right_Env:: "env \<Rightarrow> nat \<Rightarrow> env" where "right_Env s v = s \<lparr> right := v \<rparr>"
definition left_Env:: "env \<Rightarrow> nat \<Rightarrow> env" where "left_Env s v = s \<lparr> left := v \<rparr>"
definition arr_Env:: "env \<Rightarrow> nat list  \<Rightarrow> env" where "arr_Env s v = s \<lparr> arr := v \<rparr>"
definition mid_Env:: "env \<Rightarrow> nat \<Rightarrow> env" where "mid_Env s v = s \<lparr> mid := v \<rparr>"
definition val_Env:: "env \<Rightarrow> nat \<Rightarrow> env" where "val_Env s v = s \<lparr> val := v \<rparr>"

subsubsection\<open>Theorems about how the update functions changes the environment\<close>
theorem put_right_rule: "spec (\<lambda>x. p () (x \<lparr> right := v \<rparr>)) (put right_Env v) p"
  by (simp add: spec_def put_def get_state_def put_state_def right_Env_def)

theorem put_left_rule: "spec (\<lambda>x. p () (x \<lparr> left := v \<rparr>)) (put left_Env v) p"
  by (simp add: spec_def put_def get_state_def put_state_def left_Env_def)

theorem put_arr_rule: "spec (\<lambda>x. p () (x \<lparr> arr := v \<rparr>)) (put arr_Env v) p"
  by (simp add: spec_def put_def get_state_def put_state_def arr_Env_def)

theorem put_mid_rule: "spec (\<lambda>x. p () (x \<lparr> mid := v \<rparr>)) (put mid_Env v) p"
  by (simp add: spec_def put_def get_state_def put_state_def mid_Env_def)

theorem put_val_rule: "spec (\<lambda>x. p () (x \<lparr> val := v \<rparr>)) (put val_Env v) p"
  by (simp add: spec_def put_def get_state_def put_state_def val_Env_def)

subsection\<open>Definitions of the methods\<close>
definition update_left where
  "update_left \<equiv>
    left_Env := mid
   "

definition update_right where
  "update_right \<equiv> do{
    right_Env := mid
  }"

lemma update_right_isSet_toMid:
   "Valid
     (\<lambda>e. mid e = x)
     update_right
     (\<lambda>e. right e = x \<and> mid e = x)"
  unfolding Valid_def
  apply(simp add: update_right_def assign1_def)

  sledgehammer
  sorry

lemma skip_lemma:
   "Valid
     (\<lambda>e. mid e = x)
     SKIP
     (\<lambda>e. mid e = x)"
  apply (simp add: SkipRule)

text\<open>This method will update either the @{text right} or @{text left} variable, if @{text mid} is not the index that is pointing to @{text val}. If @{text mid} is pointing at @{text val} it will do nothing.\<close>
definition update_range where
"update_range \<equiv> do{
                    (mid, xs, v) \<leftarrow> get (\<lambda>e. (mid e, arr e, val e));
                    (if xs ! mid < v then do {
                        update_left
                    }else (if (xs ! mid > v) then do{
                        update_right
                    }else SKIP
                    ))
                }"

fun BinarySearch:: "nat  \<Rightarrow> (env, unit) state" where
  case0:"BinarySearch 0  = skip"|
  caseN:"BinarySearch (Suc n) = do {
                        (l, r) \<leftarrow> get (\<lambda>e. (left e, right e));
                        put mid_Env ((r + l) div 2);
                        (if (l < r) then do{
                          update_range;
                          BinarySearch n
                         }
                       else skip
                      )}"

text\<open>The definiton of how to set up the state-monad/environment with the right values based on an array.\<close>
definition init_env:: "nat list \<Rightarrow> nat \<Rightarrow> env" where
  "init_env l v \<equiv> \<lparr>right = length l,  left = 0, arr = sort(l), mid = 0, val = v\<rparr>"

definition init_env2:: "nat list \<Rightarrow> nat \<Rightarrow> env" where
  "init_env2 l v \<equiv> env.make (length l) 0 (sort l) 0 v"

value \<open>snd(run_state (BinarySearch 6) (init_env [0,3,2,1,5,8] 8))\<close>

subsection\<open>Definition of pre- and postcondition\<close>
text\<open>This method states the invariants of the environment. It is also used as the pre- and post-condition of the function.
    The main thing to note here is that @{text mid} should be a valid index in @{text arr} and all values outside the range of @{text left} and @{text right} should be different (greater or smaller than @{text val}.)\<close>
definition env_invariant:: "env \<Rightarrow> bool" where
"env_invariant e \<equiv> sorted(arr e) \<and> left e \<le> right e \<and> right e \<le> length (arr e) \<and> left e \<le> mid e
    \<and> mid e \<le> right e  \<and> (\<forall>x:: nat. x < left e \<longrightarrow> arr e ! x < val e) \<and> (\<forall>x. x > right e \<and> x < length (arr e) \<longrightarrow>  arr e ! x> val e)"

text\<open>This is the post-condition of binary-search. It is taken from the book "Verification of Sequential and Concurrent Programs" on page 145.
  It states that the variable @{text mid} should be a valid index in the array
   and that if the value we are searching for is inside the array, it should be at position @{text mid}.\<close>
definition q where
"q e \<equiv> left e \<le> mid e \<and> mid e \<le> right e \<and> (arr e ! mid e = val e \<longrightarrow>
  (\<exists>x. x \<ge> left e \<and> x \<le> right e \<and> x \<le> length (arr e) \<and> arr e  ! x = val e))"

text\<open>The definitions of the pre-condition for each of the three definitions. They are all basically extending the basic pre-condition @{text env_invariant} with the infromation that can be infered from the conditional-statements.\<close>
definition update_range_pre where
"update_range_pre e \<equiv> env_invariant e \<and> mid e = (left e + right e) div 2  \<and> right e > left e"

definition update_left_pre where
"update_left_pre e \<equiv> update_range_pre e \<and> arr e ! mid e < val e"

definition update_right_pre where
"update_right_pre e \<equiv> update_range_pre e \<and> arr e ! mid e > val e"

subsection\<open>Aux lemmas\<close>
text\<open>This lemmas are useful to prove that the update of @{text mid} will still be between @{text left} and @{text right}\<close>
lemma isSmaller: "(x::nat) < y \<Longrightarrow> (y + x) div 2 < y"
  by linarith

lemma isGreater1: "(x::nat) < y \<Longrightarrow> ((y + x) div 2) \<ge> x"
  by linarith

lemma sorted_smaller: "sorted xs \<and>
        m < length xs \<and>
        xs ! m < v \<Longrightarrow>
        (\<forall>x < m. xs ! x < v)"
  by (meson le_less_trans sorted_iff_nth_mono_less)

subsection\<open>Proofs of the definitions\<close>
lemma update_left_spec: "spec (update_left_pre) update_left (GG (env_invariant))"
  unfolding update_range_pre_def env_invariant_def GG_def update_left_pre_def
  apply(simp add: update_left_def)
  apply(intro get_rule; intro allI; simp)
  apply(intro conj_rule_right)
  apply (simp_all add: spec_def put_def put_state_def get_state_def left_Env_def)
  by (metis add.commute sorted_smaller isSmaller less_le_trans)

lemma update_right_spec: "spec (update_right_pre) update_right (GG (env_invariant))"
  unfolding env_invariant_def GG_def update_right_pre_def update_range_pre_def
  apply(simp add: update_right_def)
  apply(intro get_rule; intro allI; simp)
  apply(intro conj_rule_right)
  apply (simp_all add: spec_def put_def put_state_def get_state_def right_Env_def)
  by (metis less_le_trans sorted_iff_nth_mono_less)

lemma update_range_spec: "spec (update_range_pre) update_range (GG (env_invariant))"
  unfolding  GG_def
  apply(simp add: update_range_def)
  apply(intro get_rule; intro allI; clarify)
  apply(intro cond_rule)
  apply (smt GG_def Pair_inject case_prodI2 case_prod_conv spec_def update_left_pre_def update_left_spec)
  apply (smt GG_def Pair_inject case_prodI2 case_prod_conv spec_def update_right_pre_def update_right_spec)
  by(simp add: skip_def spec_def env_invariant_def update_range_pre_def)

section\<open>Proof of BinarySearch\<close>
text\<open>This proof shows how it satisfies the invariants on the environment. It is one of the key-proofs.\<close>
lemma inv_binarySearch: "spec (env_invariant) (BinarySearch n) (GG (env_invariant))"
  unfolding  GG_def
  apply(induction n rule: BinarySearch.induct)
  apply(simp add: spec_def skip_def)
  apply(simp only: caseN)
  apply(intro get_rule; intro allI; clarify)
  apply(intro seq_rule[of _ _ "(\<lambda>x y. env_invariant y \<and> mid y = (left y + right y) div 2)"])
   apply (simp add: spec_def put_def put_state_def get_state_def mid_Env_def env_invariant_def)
  apply linarith
  apply(intro allI)
  apply(intro cond_rule; simp)
  apply(intro seq_rule[of _ _ "(\<lambda>x y. env_invariant y)"])
  apply(simp add: update_range_def)
  apply(intro get_rule; intro allI; clarify)
  apply(intro cond_rule; simp)
  apply(simp add: update_left_def)
  apply(intro get_rule; intro allI; simp)
  apply(simp add: env_invariant_def)
  apply(intro conj_rule_right)
  apply (simp add: spec_def put_def put_state_def get_state_def left_Env_def)
  apply (simp add: spec_def put_def put_state_def get_state_def left_Env_def)
  apply (simp add: spec_def put_def put_state_def get_state_def left_Env_def)
  apply (simp add: spec_def put_def put_state_def get_state_def left_Env_def)
  apply (simp add: spec_def put_def put_state_def get_state_def left_Env_def)
  apply (simp add: spec_def put_def put_state_def get_state_def left_Env_def)
  apply (metis (no_types, hide_lams) add.commute isSmaller leI less_le_trans sorted_smaller)
  apply (simp add: spec_def put_def put_state_def get_state_def left_Env_def)
  apply(simp add: update_right_def)
  apply(intro get_rule; intro allI; simp)
  apply(simp add: env_invariant_def)
  apply(intro conj_rule_right)
  apply (simp add: spec_def put_def put_state_def get_state_def right_Env_def env_invariant_def)
  apply (simp add: spec_def put_def put_state_def get_state_def right_Env_def env_invariant_def)
  apply (simp add: spec_def put_def put_state_def get_state_def right_Env_def env_invariant_def)
  apply (simp add: spec_def put_def put_state_def get_state_def right_Env_def env_invariant_def)
  apply (simp add: spec_def put_def put_state_def get_state_def right_Env_def env_invariant_def)
  apply (simp add: spec_def put_def put_state_def get_state_def right_Env_def env_invariant_def)
  apply (simp add: spec_def put_def put_state_def get_state_def right_Env_def env_invariant_def)
  apply (metis less_le_trans sorted_iff_nth_mono_less)
  apply(simp add: spec_def skip_def)
  apply blast
  by(simp add: spec_def skip_def)

subsection\<open>Proof of lemma of pre-condition\<close>
text\<open>These proofs show how the @{text init_env} implies/satisfies the invariant on the environment\<close>
lemma empty_range: "(\<forall>i. i > length xs \<and> i \<le> length xs  \<longrightarrow> xs ! i = v)"
  using not_le by blast

lemma init_env_implies_env_inariant: "e = init_env xs v \<Longrightarrow> env_invariant e"
  unfolding init_env_def env_invariant_def
  using empty_range by force

lemma env_inv_implies_q: "env_invariant e \<Longrightarrow> q e"
  unfolding q_def env_invariant_def
  using order_trans by auto

text\<open>This lemma states that pre-condition @{text p1} is enough to show that @{text mid} will point to the value we are looking for if it exists in the array. \<close>
lemma binarySearch_main: "spec (env_invariant) (BinarySearch n) (GG (q))"
  unfolding GG_def
  apply(induction n rule: BinarySearch.induct)
  apply(simp add: spec_def skip_def env_inv_implies_q)
  by (metis GG_def inv_binarySearch env_inv_implies_q strengthen_rule)

text\<open>I can some times be useful to show the correctness of a function using rewriting of the pre-condition to show that the pre-condition and potentially some additional assumptions imply the post-condition. This strategy consists of two proofs:
\begin{enumerate}
\item A proof of the implication from the pre-condition to the post-condition
\item A proof of how the function you want to prove satisfied/keeps the invariant/pre-condition.
\end{enumerate}

I have also learned some valuable lessons about the use of quantifiers.
The universal quantifier should always contain an implication, while the existential should use conjunction instead.
This concerns in this theory the ranges from which the quantified variables are taken from.
\begin{itemize}
\item \<forall>x \<in> A. P(x) is in Isabelle \<forall> x. x \<in> A \<longrightarrow> P(x)
\item \<exists>x \<in> A. P(x) is in Isabelle \<exists> x. x \<in> A /\ P(x)
\end{itemize}
When working with quantifiers and arrays, it is important to make sure that all variables that are satisfying the predicates of the range are also valid indexes in the array. This does often require an addition predicate about the quantified variable should be in the array (less than the length of the array)

I will also like to add that some algorithms are easier constructed using a syntax that contains a while-loop.

It is easier to prove something where all variables are stored in the state-monad and not being passed around in the program.
This makes all functions simpler and has the benefit that the state of the program can be expected and used in pre- and post-conditions.
\<close>

end