(*
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 -
  def R \<equiv> "{(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 -
  def R \<equiv> "{(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 StutterEquivalence
imports Samplers

begin

section \<open>Stuttering Equivalence\<close>

text \<open>
  Stuttering equivalence of two sequences is formally defined as the equality
  of their maximally reduced versions.
\<close>

definition stutter_equiv  (infix "\<approx>" 50) where
  "\<sigma> \<approx> \<tau> \<equiv> \<natural>\<sigma> = \<natural>\<tau>"

text \<open>
  Stuttering equivalence is an equivalence relation.
\<close>

lemma stutter_equiv_refl: "\<sigma> \<approx> \<sigma>"
  unfolding stutter_equiv_def ..

lemma stutter_equiv_sym [sym]: "\<sigma> \<approx> \<tau> \<Longrightarrow> \<tau> \<approx> \<sigma>"
  unfolding stutter_equiv_def by (rule sym)

lemma stutter_equiv_trans [trans]: "\<rho> \<approx> \<sigma> \<Longrightarrow> \<sigma> \<approx> \<tau> \<Longrightarrow> \<rho> \<approx> \<tau>"
  unfolding stutter_equiv_def by simp

text \<open>
  In particular, any sequence sampled by a stuttering sampler
  is stuttering equivalent to the original one.
\<close>
lemma sampled_stutter_equiv:
  assumes "stutter_sampler f \<sigma>"
  shows "\<sigma> \<circ> f \<approx> \<sigma>"
  using assms unfolding stutter_equiv_def by (rule sample_max_sample)

lemma stutter_reduced_equivalent: "\<natural>\<sigma> \<approx> \<sigma>"
  unfolding stutter_equiv_def by (rule stutter_reduced_reduced)

text \<open>
  For proving stuttering equivalence of two sequences, it is enough
  to exhibit two arbitrary sampling functions that equalize the reductions
  of the sequences. This can be more convenient than computing the
  maximal stutter-reduced version of the sequences.
\<close>

lemma stutter_equivI:
  assumes f: "stutter_sampler f \<sigma>" and g: "stutter_sampler g \<tau>"
      and eq: "\<sigma> \<circ> f = \<tau> \<circ> g"
  shows "\<sigma> \<approx> \<tau>"
proof -
  from f have "\<natural>\<sigma> = \<natural>(\<sigma> \<circ> f)" by (rule sample_max_sample[THEN sym])
  also from eq have "... = \<natural>(\<tau> \<circ> g)" by simp
  also from g have "... = \<natural>\<tau>" by (rule sample_max_sample)
  finally show ?thesis by (unfold stutter_equiv_def)
qed

text \<open>
  The corresponding elimination rule is easy to prove, given that the
  maximal stuttering sampling function is a stuttering sampling function.
\<close>

lemma stutter_equivE:
  assumes eq: "\<sigma> \<approx> \<tau>"
  and p: "\<And>f g. \<lbrakk> stutter_sampler f \<sigma>; stutter_sampler g \<tau>; \<sigma> \<circ> f = \<tau> \<circ> g \<rbrakk> \<Longrightarrow> P"
  shows "P"
proof (rule p)
  from eq show "\<sigma> \<circ> (max_stutter_sampler \<sigma>) = \<tau> \<circ> (max_stutter_sampler \<tau>)"
    by (unfold stutter_equiv_def stutter_reduced_def)
qed (rule max_stutter_sampler)+

text \<open>
  Therefore we get the following alternative characterization: two
  sequences are stuttering equivalent iff there are stuttering sampling
  functions that equalize the two sequences.
\<close>
lemma stutter_equiv_eq:
  "\<sigma> \<approx> \<tau> = (\<exists>f g. stutter_sampler f \<sigma> \<and> stutter_sampler g \<tau> \<and> \<sigma> \<circ> f = \<tau> \<circ> g)"
  by (blast intro: stutter_equivI elim: stutter_equivE)

text \<open>
  The initial elements of stutter equivalent sequences are equal.
\<close>
lemma stutter_equiv_0:
  assumes "\<sigma> \<approx> \<tau>"
  shows "\<sigma> 0 = \<tau> 0"
proof -
  have "\<sigma> 0 = (\<natural>\<sigma>) 0" by (rule stutter_reduced_0[THEN sym])
  with assms[unfolded stutter_equiv_def] show ?thesis
    by (simp add: stutter_reduced_0)
qed

abbreviation suffix_notation ("_ [_..]")
where
  "suffix_notation w k \<equiv> suffix k w"

text \<open>
  Given any stuttering sampling function \<open>f\<close> for sequence \<open>\<sigma>\<close>,
  any suffix of \<open>\<sigma>\<close> starting at index \<open>f n\<close> is stuttering
  equivalent to the suffix of the stutter-reduced version of \<open>\<sigma>\<close>
  starting at \<open>n\<close>.
\<close>

text \<open>
  Given a stuttering sampling function \<open>f\<close> and a point \<open>n\<close>
  within the interval from \<open>f k\<close> to \<open>f (k+1)\<close>, the suffix
  starting at \<open>n\<close> is stuttering equivalent to the suffix starting
  at \<open>f k\<close>.
\<close>
lemma stutter_equiv_within_interval:
  assumes f: "stutter_sampler f \<sigma>"
      and lo: "f k \<le> n" and hi: "n < f (Suc k)"
  shows "\<sigma>[n ..] \<approx> \<sigma>[f k ..]"
proof -
  have "stutter_sampler id (\<sigma>[n ..])" by (rule id_stutter_sampler)
  moreover
  from lo have "stutter_sampler (\<lambda>i. if i=0 then 0 else n + i - f k) (\<sigma>[f k ..])"
    (is "stutter_sampler ?f _")
  proof (auto simp: stutter_sampler_def strict_mono_def)
    fix i
    assume i: "i < Suc n - f k"
    from f show "\<sigma> (f k + i) = \<sigma> (f k)"
    proof (rule stutter_sampler_between)
      from i hi show "f k + i < f (Suc k)" by simp
    qed simp
  qed
  moreover
  have "(\<sigma>[n ..]) \<circ> id = (\<sigma>[f k ..]) \<circ> ?f"
  proof (rule ext, auto)
    from f lo hi show "\<sigma> n = \<sigma> (f k)" by (rule stutter_sampler_between)
  next
    fix i
    from lo show "\<sigma> (n+i) = \<sigma> (f k + (n + i - f k))" by simp
  qed
  ultimately show ?thesis by (rule stutter_equivI)
qed

text \<open>
  Given two stuttering equivalent sequences \<open>\<sigma>\<close> and \<open>\<tau>\<close>,
  we obtain a zig-zag relationship as follows: for any suffix \<open>\<tau>[n..]\<close>
  there is a suffix \<open>\<sigma>[m..]\<close> such that:
  \begin{enumerate}
  \item \<open>\<sigma>[m..] \<approx> \<tau>[n..]\<close> and
  \item for every suffix \<open>\<sigma>[j..]\<close> where \<open>j<m\<close> there is a
    corresponding suffix \<open>\<tau>[k..]\<close> for some \<open>k<n\<close>.
  \end{enumerate}
\<close>
theorem stutter_equiv_suffixes_left:
  assumes "\<sigma> \<approx> \<tau>"
  obtains m where "\<sigma>[m..] \<approx> \<tau>[n..]" and "\<forall>j<m. \<exists>k<n. \<sigma>[j..] \<approx> \<tau>[k..]"
using assms proof (rule stutter_equivE)
  fix f g
  assume f: "stutter_sampler f \<sigma>"
     and g: "stutter_sampler g \<tau>"
     and eq: "\<sigma> \<circ> f = \<tau> \<circ> g"
  from g obtain i where i: "g i \<le> n" "n < g (Suc i)"
    by (rule stutter_sampler_interval)
  with g have "\<tau>[n..] \<approx> \<tau>[g i ..]"
    by (rule stutter_equiv_within_interval)
  also from g have "... \<approx> (\<tau> \<circ> g)[i ..]"
    by (rule suffix_stutter_equiv)
  also from eq have "... = (\<sigma> \<circ> f)[i ..]"
    by simp
  also from f have "... \<approx> \<sigma>[f i ..]"
    by (rule suffix_stutter_equiv[THEN stutter_equiv_sym])
  finally have "\<sigma>[f i ..] \<approx> \<tau>[n ..]"
    by (rule stutter_equiv_sym)
  moreover
  {
    fix j
    assume j: "j < f i"
    from f obtain a where a: "f a \<le> j" "j < f (Suc a)"
      by (rule stutter_sampler_interval)
    from a j have "f a < f i" by simp
    with f[THEN stutter_sampler_mono] have "a < i"
      by (simp add: strict_mono_less)
    with g[THEN stutter_sampler_mono] have "g a < g i"
      by (simp add: strict_mono_less)
    with i have 1: "g a < n" by simp

    from f a have "\<sigma>[j..] \<approx> \<sigma>[f a ..]"
      by (rule stutter_equiv_within_interval)
    also from f have "... \<approx> (\<sigma> \<circ> f)[a ..]"
      by (rule suffix_stutter_equiv)
    also from eq have "... = (\<tau> \<circ> g)[a ..]" by simp
    also from g have "... \<approx> \<tau>[g a ..]"
      by (rule suffix_stutter_equiv[THEN stutter_equiv_sym])
    finally have "\<sigma>[j ..] \<approx> \<tau>[g a ..]" .
    with 1 have "\<exists>k<n. \<sigma>[j..] \<approx> \<tau>[k ..]" by blast
  }
  moreover
  note that
  ultimately show ?thesis by blast
qed

theorem stutter_equiv_suffixes_right:
  assumes "\<sigma> \<approx> \<tau>"
  obtains n where "\<sigma>[m..] \<approx> \<tau>[n..]" and "\<forall>j<n. \<exists>k<m. \<sigma>[k..] \<approx> \<tau>[j..]"
proof -
  from assms have "\<tau> \<approx> \<sigma>"
    by (rule stutter_equiv_sym)
  then obtain n where "\<tau>[n..] \<approx> \<sigma>[m..]" "\<forall>j<n. \<exists>k<m. \<tau>[j..] \<approx> \<sigma>[k..]"
    by (rule stutter_equiv_suffixes_left)
  with that show ?thesis
    by (blast dest: stutter_equiv_sym)
qed

text \<open>
  In particular, if \<open>\<sigma>\<close> and \<open>\<tau>\<close> are stutter equivalent then
  every element that occurs in one sequence also occurs in the other.
\<close>
lemma stutter_equiv_element_left:
  assumes "\<sigma> \<approx> \<tau>"
  obtains m where "\<sigma> m = \<tau> n" and "\<forall>j<m. \<exists>k<n. \<sigma> j = \<tau> k"
proof -
  from assms obtain m where "\<sigma>[m..] \<approx> \<tau>[n..]" "\<forall>j<m. \<exists>k<n. \<sigma>[j..] \<approx> \<tau>[k..]"
    by (rule stutter_equiv_suffixes_left)
  with that show ?thesis
    by (force dest: stutter_equiv_0)
qed

lemma stutter_equiv_element_right:
  assumes "\<sigma> \<approx> \<tau>"
  obtains n where "\<sigma> m = \<tau> n" and "\<forall>j<n. \<exists>k<m. \<sigma> k = \<tau> j"
proof -
  from assms obtain n where "\<sigma>[m..] \<approx> \<tau>[n..]" "\<forall>j<n. \<exists>k<m. \<sigma>[k..] \<approx> \<tau>[j..]"
    by (rule stutter_equiv_suffixes_right)
  with that show ?thesis
    by (force dest: stutter_equiv_0)
qed

end


(* Author: Tobias Nipkow *)

section \<open>Pairing Heap According to Okasaki\<close>

theory Pairing_Heap_List1
imports
  "HOL-Library.Multiset"
  "HOL-Library.Pattern_Aliases"
  "HOL-Data_Structures.Priority_Queue_Specs"
begin

subsection \<open>Definitions\<close>

text
\<open>This implementation follows Okasaki \<^cite>\<open>"Okasaki"\<close>.
It satisfies the invariant that \<open>Empty\<close> only occurs
at the root of a pairing heap. The functional correctness proof does not
require the invariant but the amortized analysis (elsewhere) makes use of it.\<close>

datatype 'a heap = Empty | Hp 'a "'a heap list"

fun get_min  :: "'a heap \<Rightarrow> 'a" where
"get_min (Hp x _) = x"

hide_const (open) insert

context includes pattern_aliases
begin

fun merge :: "('a::linorder) heap \<Rightarrow> 'a heap \<Rightarrow> 'a heap" where
"merge h Empty = h" |
"merge Empty h = h" |
"merge (Hp x hsx =: hx) (Hp y hsy =: hy) =
    (if x < y then Hp x (hy # hsx) else Hp y (hx # hsy))"

end

fun insert :: "('a::linorder) \<Rightarrow> 'a heap \<Rightarrow> 'a heap" where
"insert x h = merge (Hp x []) h"

fun pass\<^sub>1 :: "('a::linorder) heap list \<Rightarrow> 'a heap list" where
"pass\<^sub>1 (h1#h2#hs) = merge h1 h2 # pass\<^sub>1 hs" |
"pass\<^sub>1 hs = hs"

fun pass\<^sub>2 :: "('a::linorder) heap list \<Rightarrow> 'a heap" where
  "pass\<^sub>2 [] = Empty"
| "pass\<^sub>2 (h#hs) = merge h (pass\<^sub>2 hs)"

fun merge_pairs :: "('a::linorder)  heap list \<Rightarrow> 'a heap" where
  "merge_pairs [] = Empty"
| "merge_pairs [h] = h"
| "merge_pairs (h1 # h2 # hs) = merge (merge h1 h2) (merge_pairs hs)"

fun del_min :: "('a::linorder) heap \<Rightarrow> 'a heap" where
  "del_min Empty = Empty"
| "del_min (Hp x hs) = pass\<^sub>2 (pass\<^sub>1 hs)"

subsection \<open>Correctness Proofs\<close>

text \<open>An optimization:\<close>

lemma pass12_merge_pairs: "pass\<^sub>2 (pass\<^sub>1 hs) = merge_pairs hs"
by (induction hs rule: merge_pairs.induct) (auto split: option.split)

declare pass12_merge_pairs[code_unfold]

subsubsection \<open>Invariants\<close>

fun mset_heap :: "'a heap \<Rightarrow>'a multiset" where
"mset_heap Empty = {#}" |
"mset_heap (Hp x hs) = {#x#} + sum_mset(mset(map mset_heap hs))"

fun pheap :: "('a :: linorder) heap \<Rightarrow> bool" where
"pheap Empty = True" |
"pheap (Hp x hs) = (\<forall>h \<in> set hs. (\<forall>y \<in># mset_heap h. x \<le> y) \<and> pheap h)"

lemma pheap_merge: "pheap h1 \<Longrightarrow> pheap h2 \<Longrightarrow> pheap (merge h1 h2)"
by (induction h1 h2 rule: merge.induct) fastforce+

lemma pheap_merge_pairs: "\<forall>h \<in> set hs. pheap h \<Longrightarrow> pheap (merge_pairs hs)"
by (induction hs rule: merge_pairs.induct)(auto simp: pheap_merge)

lemma pheap_insert: "pheap h \<Longrightarrow> pheap (insert x h)"
by (auto simp: pheap_merge)
(*
lemma pheap_pass1: "\<forall>h \<in> set hs. pheap h \<Longrightarrow> \<forall>h \<in> set (pass\<^sub>1 hs). pheap h"
by(induction hs rule: pass\<^sub>1.induct) (auto simp: pheap_merge)

lemma pheap_pass2: "\<forall>h \<in> set hs. pheap h \<Longrightarrow> pheap (pass\<^sub>2 hs)"
by (induction hs)(auto simp: pheap_merge)
*)
lemma pheap_del_min: "pheap h \<Longrightarrow> pheap (del_min h)"
by(cases h) (auto simp: pass12_merge_pairs pheap_merge_pairs)

subsubsection \<open>Functional Correctness\<close>

lemma mset_heap_empty_iff: "mset_heap h = {#} \<longleftrightarrow> h = Empty"
by (cases h) auto

lemma get_min_in: "h \<noteq> Empty \<Longrightarrow> get_min h \<in># mset_heap(h)"
by(induction rule: get_min.induct)(auto)

lemma get_min_min: "\<lbrakk> h \<noteq> Empty; pheap h; x \<in># mset_heap(h) \<rbrakk> \<Longrightarrow> get_min h \<le> x"
by(induction h rule: get_min.induct)(auto)

lemma get_min: "\<lbrakk> pheap h;  h \<noteq> Empty \<rbrakk> \<Longrightarrow> get_min h = Min_mset (mset_heap h)"
by (metis Min_eqI finite_set_mset get_min_in get_min_min )

lemma mset_merge: "mset_heap (merge h1 h2) = mset_heap h1 + mset_heap h2"
by(induction h1 h2 rule: merge.induct)(auto simp: add_ac)

lemma mset_insert: "mset_heap (insert a h) = {#a#} + mset_heap h"
by(cases h) (auto simp add: mset_merge insert_def add_ac)

lemma mset_merge_pairs: "mset_heap (merge_pairs hs) = sum_mset(image_mset mset_heap(mset hs))"
by(induction hs rule: merge_pairs.induct)(auto simp: mset_merge)

lemma mset_del_min: "h \<noteq> Empty \<Longrightarrow>
  mset_heap (del_min h) = mset_heap h - {#get_min h#}"
by(cases h) (auto simp: pass12_merge_pairs mset_merge_pairs)

text \<open>Last step: prove all axioms of the priority queue specification:\<close>

interpretation pairing: Priority_Queue_Merge
where empty = Empty and is_empty = "\<lambda>h. h = Empty"
and merge = merge and insert = insert
and del_min = del_min and get_min = get_min
and invar = pheap and mset = mset_heap
proof(standard, goal_cases)
  case 1 show ?case by simp
next
  case (2 q) show ?case by (cases q) auto
next
  case 3 show ?case by(simp add: mset_insert mset_merge)
next
  case 4 thus ?case by(simp add: mset_del_min mset_heap_empty_iff)
next
  case 5 thus ?case using get_min mset_heap.simps(1) by blast
next
  case 6 thus ?case by(simp)
next
  case 7 thus ?case by(rule pheap_insert)
next
  case 8 thus ?case by (simp add: pheap_del_min)
next
  case 9 thus ?case by (simp add: mset_merge)
next
  case 10 thus ?case by (simp add: pheap_merge)
qed

end


(*
 * 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\<open>Arrow's General Possibility Theorem\<close>

text\<open>

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.

\<close>

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

subsection\<open>Semi-decisiveness Implies Decisiveness\<close>

text\<open>

I follow \<^cite>\<open>\<open>Chapter~3*\<close> in "Sen:70a"\<close> quite closely here. Formalising his
appeal to the @{term "iia"} assumption is the main complication here.

\<close>

text\<open>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.\<close>

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 \<open>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.)
\<close>

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\<open>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.)\<close>

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 \<open>The following results permute $x$, $y$ and $z$ to show how
decisiveness can be obtained from semi-decisiveness in all cases. Again,
quite tedious.\<close>

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 \<open>The first result: if $j$ is semidecisive for some alternatives $u$
and $v$, then they are actually a dictator.\<close>

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\<open>The Existence of a Semi-decisive Individual\<close>

text\<open>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.\<close>

text \<open>This proof is unfortunately long. Many of the statements rely on a
lot of context, making it difficult to split it up.\<close>

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
      \<comment> \<open>The weak pareto requirement implies that the set of all
      individuals is decisive between any given alternatives.\<close>
  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
      \<comment> \<open>Obtain a minimally-sized semi-decisive set.\<close>
  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)
      \<comment> \<open>Show that minimal set contains a single individual.\<close>
  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
        \<comment> \<open>Split an individual from the "minimal" set.\<close>
    let ?V1 = "{j}"
    let ?V2 = "V - ?V1"
    let ?V3 = "Is - V"
    from jV card_Diff_singleton 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
        \<comment> \<open>Show that that individual is semi-decisive for $x$ over $z$.\<close>
    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
        \<comment> \<open>V2 is semi-decisive, and everyone else opposes their choice. Ergo they prevail.\<close>
      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
      \<comment> \<open>This result is unfortunately quite tortuous.\<close>
      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
      \<comment> \<open>Use @{term "iia"} to show the SWF must allow the individual to prevail.\<close>
      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\<open>Arrow's General Possibility Theorem\<close>

text\<open>

Finally we conclude with the celebrated ``possibility'' result. Note that we
assume the set of individuals is finite; \<^cite>\<open>"Routley:79"\<close> 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>\<open>\<open>p54\<close> in "Sen:70a"\<close>.

\<close>

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
(*>*)