(* Author: Joshua Schneider, ETH Zurich *)

section \<open>Regression tests for applicative lifting\<close>

theory Applicative_Test imports
  Stream_Algebra
  Applicative_Environment
  Applicative_List
  Applicative_Option
  Applicative_Set
  Applicative_Sum
  Abstract_AF
begin

unbundle applicative_syntax

subsection \<open>Normal form conversion\<close>

notepad
begin
  have "\<forall>x. x = af_pure (\<lambda>x. x) \<diamondop> x" by applicative_nf rule
  have "\<forall>x. af_pure x = af_pure x" by applicative_nf rule
  have "\<forall>f x. af_pure f \<diamondop> x = af_pure f \<diamondop> x" by applicative_nf rule
  have "\<forall>f x y. af_pure f \<diamondop> x \<diamondop> y = af_pure f \<diamondop> x \<diamondop> y" by applicative_nf rule
  have "\<forall>g f x. af_pure g \<diamondop> (f \<diamondop> x) = af_pure (\<lambda>f x. g (f x)) \<diamondop> f \<diamondop> x" by applicative_nf rule
  have "\<forall>f x y. f \<diamondop> x \<diamondop> y = af_pure (\<lambda>f x y. f x y) \<diamondop> f \<diamondop> x \<diamondop> y" by applicative_nf rule
  have "\<forall>g f x. g \<diamondop> (f \<diamondop> x) = af_pure (\<lambda>g f x. g (f x)) \<diamondop> g \<diamondop> f \<diamondop> x" by applicative_nf rule
  have "\<forall>f x. f \<diamondop> af_pure x = af_pure (\<lambda>f. f x) \<diamondop> f" by applicative_nf rule
  have "\<forall>x y. af_pure x \<diamondop> af_pure y = af_pure (x y)" by applicative_nf rule
  have "\<forall>f x y. f \<diamondop> x \<diamondop> af_pure y = af_pure (\<lambda>f x. f x y) \<diamondop> f \<diamondop> x" by applicative_nf rule
  have "\<forall>f x y. af_pure f \<diamondop> x \<diamondop> af_pure y = af_pure (\<lambda>x. f x y) \<diamondop> x" by applicative_nf rule
  have "\<forall>f x y z. af_pure f \<diamondop> x \<diamondop> af_pure y \<diamondop> z = af_pure (\<lambda>x z. f x y z) \<diamondop> x \<diamondop> z" by applicative_nf rule
  have "\<forall>f x g y. af_pure f \<diamondop> x \<diamondop> (af_pure g \<diamondop> y) = af_pure (\<lambda>x y. f x (g y)) \<diamondop> x \<diamondop> y" by applicative_nf rule
  have "\<forall>f g x y. f \<diamondop> (g \<diamondop> x) \<diamondop> y = af_pure (\<lambda>f g x y. f (g x) y) \<diamondop> f \<diamondop> g \<diamondop> x \<diamondop> y" by applicative_nf rule
  have "\<forall>f g x y z. f \<diamondop> (g \<diamondop> x \<diamondop> y) \<diamondop> z = af_pure (\<lambda>f g x y z. f (g x y) z) \<diamondop> f \<diamondop> g \<diamondop> x \<diamondop> y \<diamondop> z" by applicative_nf rule
  have "\<forall>f g x y z. f \<diamondop> (g \<diamondop> (x \<diamondop> af_pure y)) \<diamondop> z = af_pure (\<lambda>f g x z. f (g (x y)) z) \<diamondop> f \<diamondop> g \<diamondop> x \<diamondop> z" by applicative_nf rule
  have "\<forall>f g x. f \<diamondop> (g \<diamondop> x \<diamondop> x) = af_pure (\<lambda>f g x x'. f (g x x')) \<diamondop> f \<diamondop> g \<diamondop> x \<diamondop> x" by applicative_nf rule
  have "\<forall>f x y. f x \<diamondop> y = af_pure (\<lambda>f x. f x) \<diamondop> f x \<diamondop> y" by applicative_nf rule
next
  fix f :: "('a \<Rightarrow> 'b) af" and g :: "('b \<Rightarrow> 'c) af" and x
  have "g \<diamondop> (f \<diamondop> x) = af_pure (\<lambda>g f x. g (f x)) \<diamondop> g \<diamondop> f \<diamondop> x" by applicative_nf rule
end
(* TODO automatic test for names of new variables *)

lemma "\<And>f x::'a af. f \<diamondop> x = x"
apply applicative_nf
oops

subsection \<open>Sets\<close>

instantiation set :: (plus) plus
begin
  definition set_plus_def[applicative_unfold]: "(X::('a::plus)set) + Y = {plus} \<diamondop> X \<diamondop> Y"
  instance ..
end

lemma "(X :: _ :: semigroup_add set) + Y + Z = X + (Y + Z)"
by (fact add.assoc[applicative_lifted set])

instantiation set :: (semigroup_add) semigroup_add begin
instance proof
  fix X Y Z :: "'a set"
  from add.assoc
  show "X + Y + Z = X + (Y + Z)" by applicative_lifting
qed
end

instantiation set :: (ab_semigroup_add) ab_semigroup_add begin
instance proof
  fix X Y :: "'a set"
  from add.commute
  show "X + Y = Y + X" by applicative_lifting
qed
end

subsection \<open>Sum type (a.k.a. either)\<close>

lemma "Inl plus \<diamondop> (x :: nat + 'e list) \<diamondop> x = Inl (\<lambda>x. 2 * x) \<diamondop> x"
by applicative_lifting simp

lemma "rel_sum (\<le>) (\<le>) (x :: nat + nat) (Inl Suc \<diamondop> x)"
proof -
  interpret either_af "(\<le>) :: nat \<Rightarrow> _" by unfold_locales (rule reflpI, simp)
  show ?thesis by applicative_lifting simp
qed

subsection \<open>Streams\<close>

lemma "(x::int stream) * sconst 0 = sconst 0"
by applicative_lifting simp

lemma "(x::int stream) * (y + z) = x * y + x * z"
by applicative_lifting algebra

definition "lift_streams xs = foldr (smap2 Cons) xs (sconst [])"

lemma lift_streams_Nil[applicative_unfold]: "lift_streams [] = sconst []"
unfolding lift_streams_def
by simp

lemma lift_streams_Cons[applicative_unfold]:
  "lift_streams (x # xs) = smap2 Cons x (lift_streams xs)"
unfolding lift_streams_def
by applicative_unfold

lemma stream_append_Cons: "smap2 append (smap2 Cons x ys) zs = smap2 Cons x (smap2 append ys zs)"
by applicative_lifting simp

lemma lift_streams_append[applicative_unfold]:
  "lift_streams (xs @ ys) = smap2 append (lift_streams xs) (lift_streams ys)"
proof (induction xs)
  case Nil
  (*
    case could be proved directly if "lift_streams ([] @ ys) = lift_streams ys" is solved
    in head_cong_tac (invoke simplifier?) -- but only with applicative_nf
  *)
  have "lift_streams ys = sconst append \<diamondop> lift_streams [] \<diamondop> lift_streams ys"
    by applicative_lifting simp
  thus ?case by applicative_unfold
next
  case (Cons x xs)
  with stream_append_Cons  (* the actual lifted fact *)
  show ?case by applicative_unfold (rule sym)
qed

lemma "lift_streams (rev x) = smap rev (lift_streams x)"
proof (induction x)
  case Nil
  have "lift_streams [] = smap rev (lift_streams [])"
    by applicative_lifting simp
  thus ?case by simp
next
  case (Cons x xs)
  have "\<forall>y ys. rev ys @ [y] = rev (y # ys)" by simp
  hence "\<forall>y ys. smap2 append (smap rev ys) (smap2 Cons y (sconst [])) = smap rev (smap2 Cons y ys)"
    by applicative_lifting simp
  with Cons.IH show ?case by applicative_unfold blast
qed

definition [applicative_unfold]: "sconcat xs = smap concat xs"

lemma "sconcat (lift_streams [sconst ''Hello '', sconst ''world!'']) = sconst ''Hello world!''"
by applicative_lifting simp

subsection \<open>Relators\<close>

lemma "rel_fun (=) (\<le>) (const (0::nat)) x"
by applicative_lifting simp

lemma "list_all2 (\<subseteq>) (map (\<lambda>_. {}) x) (map set x)"
by applicative_nf simp

lemma "x = Some a \<Longrightarrow> rel_option (\<le>) (map_option (\<lambda>_. a) x) (map_option Suc x)"
by applicative_lifting simp

schematic_goal "\<forall>g f x. rel_sum ?R (=) (ap_either f x) (ap_either (ap_either (Inl g) f) x)"
apply applicative_lifting
oops

schematic_goal "stream_all2 ?R (?f \<diamondop> (pure ?g \<diamondop> ?x + ?y)) (?x + ?z)"
apply applicative_lifting
oops

print_applicative

end


(*
 * Copyright 2014, NICTA
 *
 * This software may be distributed and modified according to the terms of
 * the BSD 2-Clause license. Note that NO WARRANTY is provided.
 * See "LICENSE_BSD2.txt" for details.
 *
 * @TAG(NICTA_BSD)
 *)

(*
   Decompose a meta-conjunction as a proper fact (list of theorems)
*)

theory Conjuncts
imports Main
begin

ML\<open>

structure Conjuncts =
struct

local

  structure Data = Generic_Data
  (
    type T = thm;
    val empty: T = Drule.dummy_thm;
    val extend = I;
    val merge : T * T -> T = (K Drule.dummy_thm);
  );

  fun elim_conjuncts thm =
    case try Conjunction.elim thm of
    SOME (thm', thm'') => elim_conjuncts thm' @ elim_conjuncts thm''
    | NONE => if Thm.prop_of thm = Thm.prop_of (Drule.dummy_thm) then [] else [thm]

  in

  val _ = Context.>> (Context.map_theory (
    (Attrib.setup @{binding "conjuncts"}
      (Scan.lift (Args.mode "accumulate") >> (fn acc =>
        if acc then
        Thm.declaration_attribute (Data.map o (fn x => fn y => Conjunction.intr y x))
        else
        Thm.declaration_attribute Data.put))
      "add meta_conjuncts to \"conjuncts\" named theorem") #>
    Global_Theory.add_thms_dynamic (@{binding "conjuncts"}, elim_conjuncts o Data.get)))

end

end

\<close>

notepad begin

  fix A B C D
  assume ABC[conjuncts]: "(A &&& B) &&& (B &&& C)"
  note ABC' = conjuncts

  have "A" by (rule ABC')
  have "B" by (rule \<open>B\<close>)
  have "C" by (rule ABC'(4))

  (* Disclaimer: only the last declared lemma is stored *)
  assume ABCD[conjuncts]: "A &&& B" "C &&& D"
  note CD = conjuncts

  have "A" by ((rule CD)?,rule ABC')
  have "C" by (rule CD)

  note ABCD(1)[conjuncts]
  note AB = conjuncts

  note ABCD(2)[conjuncts]
  note CD = conjuncts

  (* We can accumulate multi-thms, we just need to clear conjuncts first *)
  note [[conjuncts]]

  note ABCD[conjuncts (accumulate)]
  note ABCD' = conjuncts

end

end


(*  Title:      JinjaThreads/J/DefAssPreservation.thy
    Author:     Andreas Lochbihler, Tobias Nipkow
*)
header {* \isaheader{Preservation of definite assignment} *}

theory DefAssPreservation
imports
  DefAss
  JWellForm
  SmallStep
begin

text{* Preservation of definite assignment more complex and requires a
few lemmas first. *}

lemma D_extRetJ [intro!]: "\<D> e A \<Longrightarrow> \<D> (extRet2J e va) A"
by(cases va) simp_all

lemma blocks_defass [iff]: "\<And>A. \<lbrakk> length Vs = length Ts; length vs = length Ts\<rbrakk> \<Longrightarrow>
 \<D> (blocks Vs Ts vs e) A = \<D> e (A \<squnion> \<lfloor>set Vs\<rfloor>)"
(*<*)
apply(induct Vs Ts vs e rule:blocks.induct)
apply(simp_all add:hyperset_defs)
done
(*>*)

context J_heap_base begin

lemma red_lA_incr: "extTA,P,t \<turnstile> \<langle>e,s\<rangle> -ta\<rightarrow> \<langle>e',s'\<rangle> \<Longrightarrow> \<lfloor>dom (lcl s)\<rfloor> \<squnion> \ e \<sqsubseteq>  \<lfloor>dom (lcl s')\<rfloor> \<squnion> \ e'"
  and reds_lA_incr: "extTA,P,t \<turnstile> \<langle>es,s\<rangle> [-ta\<rightarrow>] \<langle>es',s'\<rangle> \<Longrightarrow> \<lfloor>dom (lcl s)\<rfloor> \<squnion> \s es \<sqsubseteq>  \<lfloor>dom (lcl s')\<rfloor> \<squnion> \s es'"
apply(induct rule:red_reds.inducts)
apply(simp_all del:fun_upd_apply add:hyperset_defs)
apply blast
apply blast
apply blast
apply blast
apply blast
apply blast
apply blast
apply blast
apply blast
apply blast
apply blast
apply blast
apply(force split: split_if_asm)
apply blast
apply blast
apply blast
apply blast
apply blast
apply(blast dest: red_lcl_incr)
apply(blast dest: red_lcl_incr)
by blast+

end

text{* Now preservation of definite assignment. *}

declare hyperUn_comm [simp del]
declare hyperUn_leftComm [simp del]

context J_heap_base begin

lemma assumes wf: "wf_J_prog P"
  shows red_preserves_defass: "extTA,P,t \<turnstile> \<langle>e,s\<rangle> -ta\<rightarrow> \<langle>e',s'\<rangle> \<Longrightarrow> \<D> e \<lfloor>dom (lcl s)\<rfloor> \<Longrightarrow> \<D> e' \<lfloor>dom (lcl s')\<rfloor>"
  and reds_preserves_defass: "extTA,P,t \<turnstile> \<langle>es,s\<rangle> [-ta\<rightarrow>] \<langle>es',s'\<rangle> \<Longrightarrow> \<D>s es \<lfloor>dom (lcl s)\<rfloor> \<Longrightarrow> \<D>s es' \<lfloor>dom (lcl s')\<rfloor>"
proof (induct rule:red_reds.inducts)
  case BinOpRed1 thus ?case by (auto elim!: D_mono[OF red_lA_incr])
next
  case AAccRed1 thus ?case by (auto elim!: D_mono[OF red_lA_incr])
next
  case (AAssRed1 a s ta a' s' i e)
  have ss: "extTA,P,t \<turnstile> \<langle>a,s\<rangle> -ta\<rightarrow> \<langle>a',s'\<rangle>"
    and IH: "\<D> a \<lfloor>dom (lcl s)\<rfloor> \<Longrightarrow> \<D> a' \<lfloor>dom (lcl s')\<rfloor>"
    and D: "\<D> (a\<lfloor>i\<rceil> := e) \<lfloor>dom (lcl s)\<rfloor>" by fact+
  from D have "\<D> a \<lfloor>dom (lcl s)\<rfloor>" by simp
  with IH have Da: "\<D> a' \<lfloor>dom (lcl s')\<rfloor>" by simp
  from ss have domgrow: "\<lfloor>dom (lcl s)\<rfloor> \<squnion> \ a \<sqsubseteq>  \<lfloor>dom (lcl s')\<rfloor> \<squnion> \ a'" by - (erule red_lA_incr)
  from D have "\<D> i (\<lfloor>dom (lcl s)\<rfloor> \<squnion> \ a)" by simp
  with domgrow have Di: "\<D> i (\<lfloor>dom (lcl s')\<rfloor> \<squnion> \ a')" by - (erule D_mono)
  from domgrow have domgrow2: "\<lfloor>dom (lcl s)\<rfloor> \<squnion> \ a \<squnion> \ i \<sqsubseteq> \<lfloor>dom (lcl s')\<rfloor> \<squnion> \ a' \<squnion> \ i" by - (rule sqUn_lem)
  from D have "\<D> e (\<lfloor>dom (lcl s)\<rfloor> \<squnion> \ a \<squnion> \ i)" by simp
  with domgrow2 have De: "\<D> e (\<lfloor>dom (lcl s')\<rfloor> \<squnion> \ a' \<squnion> \ i)" by - (erule D_mono)
  from Da Di De show ?case by simp
next
  case AAssRed2 thus ?case by (auto elim!: D_mono[OF red_lA_incr])
next
  case FAssRed1 thus ?case by (auto elim!: D_mono[OF red_lA_incr])
next
  case CallObj thus ?case by (auto elim!: Ds_mono[OF red_lA_incr])
next
  case CallParams thus ?case by(auto elim!: Ds_mono[OF red_lA_incr])
next
  case RedCall thus ?case by(auto dest!:sees_wf_mdecl[OF wf] simp:wf_mdecl_def elim!:D_mono')
next
  case BlockRed thus ?case
    by(auto simp:hyperset_defs elim!:D_mono' simp del:fun_upd_apply split: split_if_asm)
next
  case SynchronizedRed1 thus ?case by(auto elim!: D_mono[OF red_lA_incr])
next
  case SeqRed thus ?case by (auto elim!: D_mono[OF red_lA_incr])
next
  case CondRed thus ?case by (auto elim!: D_mono[OF red_lA_incr])
next
  case TryRed thus ?case
    by (fastforce dest:red_lcl_incr intro:D_mono' simp:hyperset_defs)
next
  case RedWhile thus ?case by(auto simp:hyperset_defs elim!:D_mono')
next
  case ListRed1 thus ?case by (auto elim!: Ds_mono[OF red_lA_incr])
qed (auto simp:hyperset_defs)

end

end


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

  The proof that there exists no anonymous and neutral SDS for at least
  four voters and alternatives that satisfies SD-Efficiency and
  SD-Strategy-Proofness.
*)

section \<open>Incompatibility of SD-Efficiency and SD-Strategy-Proofness\<close>

theory SDS_Impossibility
imports
  "../Randomised_Social_Choice/Automation/SDS_Automation"
  "../Randomised_Social_Choice/Randomised_Social_Choice"
begin

subsection \<open>Preliminary Definitions\<close>

locale sds_impossibility =
  anonymous_sds agents alts sds +
  neutral_sds agents alts sds +
  sd_efficient_sds agents alts sds +
  strategyproof_sds agents alts sds
  for agents :: "'agent set" and alts :: "'alt set" and sds +
  assumes agents_ge_4: "card agents \<ge> 4"
      and alts_ge_4:   "card alts \<ge> 4"

locale sds_impossibility_4_4 = sds_impossibility agents alts sds
  for agents :: "'agent set" and alts :: "'alt set" and sds +
  fixes A1 A2 A3 A4 :: 'agent and a b c d :: 'alt
  assumes distinct_agents: "distinct [A1, A2, A3, A4]"
      and distinct_alts: "distinct [a, b, c, d]"
      and agents: "agents = {A1, A2, A3, A4}"
      and alts:   "alts   = {a, b, c, d}"
begin

lemma an_sds: "an_sds agents alts sds" by unfold_locales
lemma ex_post_efficient_sds: "ex_post_efficient_sds agents alts sds" by unfold_locales
lemma sd_efficient_sds: "sd_efficient_sds agents alts sds" by unfold_locales
lemma strategyproof_an_sds: "strategyproof_an_sds agents alts sds" by unfold_locales

lemma distinct_agents' [simp]:
  "A1 \<noteq> A2" "A1 \<noteq> A3" "A1 \<noteq> A4" "A2 \<noteq> A1" "A2 \<noteq> A3" "A2 \<noteq> A4"
  "A3 \<noteq> A1" "A3 \<noteq> A2" "A3 \<noteq> A4" "A4 \<noteq> A1" "A4 \<noteq> A2" "A4 \<noteq> A3"
  using distinct_agents by auto

lemma distinct_alts' [simp]:
  "a \<noteq> b" "a \<noteq> c" "a \<noteq> d" "b \<noteq> a" "b \<noteq> c" "b \<noteq> d"
  "c \<noteq> a" "c \<noteq> b" "c \<noteq> d" "d \<noteq> a" "d \<noteq> b" "d \<noteq> c"
  using distinct_alts by auto

lemma card_agents [simp]: "card agents = 4" and card_alts [simp]: "card alts = 4"
  using distinct_agents distinct_alts by (simp_all add: agents alts)

lemma in_agents [simp]: "A1 \<in> agents" "A2 \<in> agents" "A3 \<in> agents" "A4 \<in> agents"
  by (simp_all add: agents)

lemma in_alts [simp]: "a \<in> alts" "b \<in> alts" "c \<in> alts" "d \<in> alts"
  by (simp_all add: alts)

lemma agent_iff: "x \<in> agents \<longleftrightarrow> x \<in> {A1, A2, A3, A4}"
                 "(\<forall>x\<in>agents. P x) \<longleftrightarrow> P A1 \<and> P A2 \<and> P A3 \<and> P A4"
                 "(\<exists>x\<in>agents. P x) \<longleftrightarrow> P A1 \<or> P A2 \<or> P A3 \<or> P A4"
  by (auto simp add: agents)

lemma alt_iff: "x \<in> alts \<longleftrightarrow> x \<in> {a,b,c,d}"
               "(\<forall>x\<in>alts. P x) \<longleftrightarrow> P a \<and> P b \<and> P c \<and> P d"
               "(\<exists>x\<in>alts. P x) \<longleftrightarrow> P a \<or> P b \<or> P c \<or> P d"
  by (auto simp add: alts)

subsection \<open>Definition of Preference Profiles and Fact Gathering\<close>

preference_profile
  agents: agents
  alts:   alts
where R1  = A1: [c, d], [a, b]    A2: [b, d], a, c      A3: a, b, [c, d]      A4: [a, c], [b, d]
  and R2  = A1: [a, c], [b, d]    A2: [c, d], a, b      A3: [b, d], a, c      A4: a, b, [c, d]
  and R3  = A1: [a, b], [c, d]    A2: [c, d], [a, b]    A3: d, [a, b], c      A4: c, a, [b, d]
  and R4  = A1: [a, b], [c, d]    A2: [a, d], [b, c]    A3: c, [a, b], d      A4: d, c, [a, b]
  and R5  = A1: [c, d], [a, b]    A2: [a, b], [c, d]    A3: [a, c], d, b      A4: d, [a, b], c
  and R6  = A1: [a, b], [c, d]    A2: [c, d], [a, b]    A3: [a, c], [b, d]    A4: d, b, a, c
  and R7  = A1: [a, b], [c, d]    A2: [c, d], [a, b]    A3: a, c, d, b        A4: d, [a, b], c
  and R8  = A1: [a, b], [c, d]    A2: [a, c], [b, d]    A3: d, [a, b], c      A4: d, c, [a, b]
  and R9  = A1: [a, b], [c, d]    A2: [a, d], c, b      A3: d, c, [a, b]      A4: [a, b, c], d
  and R10 = A1: [a, b], [c, d]    A2: [c, d], [a, b]    A3: [a, c], d, b      A4: [b, d], a, c
  and R11 = A1: [a, b], [c, d]    A2: [c, d], [a, b]    A3: d, [a, b], c      A4: c, a, b, d
  and R12 = A1: [c, d], [a, b]    A2: [a, b], [c, d]    A3: [a, c], d, b      A4: [a, b, d], c
  and R13 = A1: [a, c], [b, d]    A2: [c, d], a, b      A3: [b, d], a, c      A4: a, b, d, c
  and R14 = A1: [a, b], [c, d]    A2: d, c, [a, b]      A3: [a, b, c], d      A4: a, d, c, b
  and R15 = A1: [a, b], [c, d]    A2: [c, d], [a, b]    A3: [b, d], a, c      A4: a, c, d, b
  and R16 = A1: [a, b], [c, d]    A2: [c, d], [a, b]    A3: a, c, d, b        A4: [a, b, d], c
  and R17 = A1: [a, b], [c, d]    A2: [c, d], [a, b]    A3: [a, c], [b, d]    A4: d, [a, b], c
  and R18 = A1: [a, b], [c, d]    A2: [a, d], [b, c]    A3: [a, b, c], d      A4: d, c, [a, b]
  and R19 = A1: [a, b], [c, d]    A2: [c, d], [a, b]    A3: [b, d], a, c      A4: [a, c], [b, d]
  and R20 = A1: [b, d], a, c      A2: b, a, [c, d]      A3: a, c, [b, d]      A4: d, c, [a, b]
  and R21 = A1: [a, d], c, b      A2: d, c, [a, b]      A3: c, [a, b], d      A4: a, b, [c, d]
  and R22 = A1: [a, c], d, b      A2: d, c, [a, b]      A3: d, [a, b], c      A4: a, b, [c, d]
  and R23 = A1: [a, b], [c, d]    A2: [c, d], [a, b]    A3: [a, c], [b, d]    A4: [a, b, d], c
  and R24 = A1: [c, d], [a, b]    A2: d, b, a, c        A3: c, a, [b, d]      A4: b, a, [c, d]
  and R25 = A1: [c, d], [a, b]    A2: [b, d], a, c      A3: a, b, [c, d]      A4: a, c, [b, d]
  and R26 = A1: [b, d], [a, c]    A2: [c, d], [a, b]    A3: a, b, [c, d]      A4: a, c, [b, d]
  and R27 = A1: [a, b], [c, d]    A2: [b, d], a, c      A3: [a, c], [b, d]    A4: [c, d], a, b
  and R28 = A1: [c, d], a, b      A2: [b, d], a, c      A3: a, b, [c, d]      A4: a, c, [b, d]
  and R29 = A1: [a, c], d, b      A2: [b, d], a, c      A3: a, b, [c, d]      A4: d, c, [a, b]
  and R30 = A1: [a, d], c, b      A2: d, c, [a, b]      A3: c, [a, b], d      A4: [a, b], d, c
  and R31 = A1: [b, d], a, c      A2: [a, c], d, b      A3: c, d, [a, b]      A4: [a, b], c, d
  and R32 = A1: [a, c], d, b      A2: d, c, [a, b]      A3: d, [a, b], c      A4: [a, b], d, c
  and R33 = A1: [c, d], [a, b]    A2: [a, c], d, b      A3: a, b, [c, d]      A4: d, [a, b], c
  and R34 = A1: [a, b], [c, d]    A2: a, c, d, b        A3: b, [a, d], c      A4: c, d, [a, b]
  and R35 = A1: [a, d], c, b      A2: a, b, [c, d]      A3: [a, b, c], d      A4: d, c, [a, b]
  and R36 = A1: [c, d], [a, b]    A2: [a, c], d, b      A3: [b, d], a, c      A4: a, b, [c, d]
  and R37 = A1: [a, c], [b, d]    A2: [b, d], [a, c]    A3: a, b, [c, d]      A4: c, d, [a, b]
  and R38 = A1: [c, d], a, b      A2: [b, d], a, c      A3: a, b, [c, d]      A4: [a, c], b, d
  and R39 = A1: [a, c], d, b      A2: [b, d], a, c      A3: a, b, [c, d]      A4: [c, d], a, b
  and R40 = A1: [a, d], c, b      A2: [a, b], c, d      A3: [a, b, c], d      A4: d, c, [a, b]
  and R41 = A1: [a, d], c, b      A2: [a, b], d, c      A3: [a, b, c], d      A4: d, c, [a, b]
  and R42 = A1: [c, d], [a, b]    A2: [a, b], [c, d]    A3: d, b, a, c        A4: c, a, [b, d]
  and R43 = A1: [a, b], [c, d]    A2: [c, d], [a, b]    A3: d, [a, b], c      A4: a, [c, d], b
  and R44 = A1: [c, d], [a, b]    A2: [a, c], d, b      A3: [a, b], d, c      A4: [a, b, d], c
  and R45 = A1: [a, c], d, b      A2: [b, d], a, c      A3: [a, b], c, d      A4: [c, d], b, a
  and R46 = A1: [b, d], a, c      A2: d, c, [a, b]      A3: [a, c], [b, d]    A4: b, a, [c, d]
  and R47 = A1: [a, b], [c, d]    A2: [a, d], c, b      A3: d, c, [a, b]      A4: c, [a, b], d
  by (simp_all add: agents alts)

derive_orbit_equations (an_sds)
  R10 R26 R27 R28 R29 R43 R45
  by simp_all

prove_inefficient_supports (ex_post_efficient_sds sd_efficient_sds)
  R3 [b] and R4 [b] and R5 [b] and R7 [b] and R8 [b] and
  R9 [b] and R11 [b] and R12 [b] and R14 [b] and R16 [b] and
  R17 [b] and R18 [b] and R21 [b] and R22 [b] and R23 [b] and
  R30 [b] and R32 [b] and R33 [b] and R35 [b] and R40 [b] and
  R41 [b] and R43 [b] and R44 [b] and R47 [b] and
  R10 [c, b] witness: [a: 1 / 2, b: 0, c: 0, d: 1 / 2] and
  R15 [c, b] witness: [a: 1 / 2, b: 0, c: 0, d: 1 / 2] and
  R19 [c, b] witness: [a: 1 / 2, b: 0, c: 0, d: 1 / 2] and
  R25 [b, c] witness: [c: 0, d: 1 / 2, a: 1 / 2, b: 0] and
  R26 [c, b] witness: [b: 0, d: 1 / 2, a: 1 / 2, c: 0] and
  R27 [c, b] witness: [a: 1 / 2, b: 0, c: 0, d: 1 / 2] and
  R28 [b, c] witness: [c: 0, d: 1 / 2, a: 1 / 2, b: 0] and
  R29 [b, c] witness: [a: 1 / 2, c: 0, d: 1 / 2, b: 0] and
  R39 [b, c] witness: [a: 1 / 2, c: 0, d: 1 / 2, b: 0]
  by (simp_all add: agent_iff alt_iff)

derive_strategyproofness_conditions (strategyproof_an_sds)
  distance: 2
  R1 R2 R3 R4 R5 R6 R7 R8 R9 R10 R11 R12 R13 R14 R15 R16 R17 R18 R19 R20
  R21 R22 R23 R24 R25 R26 R27 R28 R29 R30 R31 R32 R33 R34 R35 R36 R37 R38 R39 R40
  R41 R42 R43 R44 R45 R46 R47
  by (simp_all add: agent_iff alt_iff)

lemma lottery_conditions:
  assumes "is_pref_profile R"
  shows   "pmf (sds R) a \<ge> 0" "pmf (sds R) b \<ge> 0" "pmf (sds R) c \<ge> 0" "pmf (sds R) d \<ge> 0"
          "pmf (sds R) a + pmf (sds R) b + pmf (sds R) c + pmf (sds R) d = 1"
  using lottery_prob_alts[OF sds_wf[OF assms]]
  by (simp_all add: alts pmf_nonneg measure_measure_pmf_finite)

subsection \<open>Main Proof\<close>

lemma R45 [simp]: "pmf (sds R45) a = 1/4" "pmf (sds R45) b = 1/4"
           "pmf (sds R45) c = 1/4" "pmf (sds R45) d = 1/4"
  using R45.orbits lottery_conditions[OF R45.wf] by simp_all

lemma R10_bc [simp]: "pmf (sds R10) b = 0" "pmf (sds R10) c = 0"
  using R10.support R10.orbits by auto

lemma R10_ad [simp]: "pmf (sds R10) a = 1/2" "pmf (sds R10) d = 1/2"
  using lottery_conditions[OF R10.wf] R10_bc R10.orbits by simp_all

lemma R26_bc [simp]: "pmf (sds R26) b = 0" "pmf (sds R26) c = 0"
  using R26.support R26.orbits by auto

lemma R26_d [simp]: "pmf (sds R26) d = 1 - pmf (sds R26) a"
  using lottery_conditions[OF R26.wf] R26_bc by simp

lemma R27_bc [simp]: "pmf (sds R27) b = 0" "pmf (sds R27) c = 0"
  using R27.support R27.orbits by auto

lemma R27_d [simp]: "pmf (sds R27) d = 1 - pmf (sds R27) a"
  using lottery_conditions[OF R27.wf] R27_bc by simp

lemma R28_bc [simp]: "pmf (sds R28) b = 0" "pmf (sds R28) c = 0"
  using R28.support R28.orbits by auto

lemma R28_d [simp]: "pmf (sds R28) d = 1 - pmf (sds R28) a"
  using lottery_conditions[OF R28.wf] R28_bc by simp

lemma R29_ac [simp]: "pmf (sds R29) a = 1/2" "pmf (sds R29) d = 1/2"
  using lottery_conditions[OF R29.wf] R29_bc R29.orbits by simp_all

lemmas R43_bc [simp] = R43.support

lemma R43_ad [simp]: "pmf (sds R43) a = 1/2" "pmf (sds R43) d = 1/2"
  using lottery_conditions[OF R43.wf] R43_bc R43.orbits by simp_all

lemma R39_b [simp]: "pmf (sds R39) b = 0"
proof -
  {
    assume [simp]: "pmf (sds R39) c = 0"
    with R29_R39.strategyproofness(1)
      have "pmf (sds R39) d \<le> 1/2" by auto
    with R39_R29.strategyproofness(1) lottery_conditions[OF R39.wf]
      have "pmf (sds R39) b = 0" by auto
  }
  with R39.support show ?thesis by blast
qed

lemma R36_a [simp]: "pmf (sds R36) a = 1/2" and R36_b [simp]: "pmf (sds R36) b = 0"
proof -
  from R10_R36.strategyproofness(1) lottery_conditions[OF R36.wf]
    have "pmf (sds R36) a + pmf (sds R36) b \<le> 1/2" by auto
  with R36_R10.strategyproofness(1) lottery_conditions[OF R36.wf]
    show "pmf (sds R36) a = 1/2" "pmf (sds R36) b = 0" by auto
qed

lemma R36_d [simp]: "pmf (sds R36) d = 1/2 - pmf (sds R36) c"
  using lottery_conditions[OF R36.wf] by simp

lemma R39_a [simp]: "pmf (sds R39) a = 1/2"
proof -
  from R36_R39.strategyproofness(1) lottery_conditions[OF R39.wf]
    have "pmf (sds R39) a \<ge> 1/2" by auto
  with R39_R36.strategyproofness(1) lottery_conditions[OF R39.wf]
    show ?thesis by auto
qed

lemma R39_d [simp]: "pmf (sds R39) d = 1/2 - pmf (sds R39) c"
  using lottery_conditions[OF R39.wf] by simp

lemmas R12_b [simp] = R12.support

lemma R12_c [simp]: "pmf (sds R12) c = 0"
  using R12_R10.strategyproofness(1) lottery_conditions[OF R12.wf] by auto

lemma R12_d [simp]: "pmf (sds R12) d = 1 - pmf (sds R12) a"
  using lottery_conditions[OF R12.wf] by simp

lemma R12_a_ge_one_half: "pmf (sds R12) a \<ge> 1/2"
  using R10_R12.strategyproofness(1) lottery_conditions[OF R12.wf]
  by auto

lemma R44 [simp]:
  "pmf (sds R44) a = pmf (sds R12) a" "pmf (sds R44) d = 1 - pmf (sds R12) a"
  "pmf (sds R44) b = 0" "pmf (sds R44) c = 0"
proof -
  from R12_R44.strategyproofness(1) R44.support have "pmf (sds R44) a \<le> pmf (sds R12) a" by simp
  with R44_R12.strategyproofness(1) R44.support lottery_conditions[OF R44.wf]
    show "pmf (sds R44) a = pmf (sds R12) a" "pmf (sds R44) c = 0"
         "pmf (sds R44) d = 1 - pmf (sds R12) a" by auto
qed (insert R44.support, simp_all)

lemma R9_a [simp]: "pmf (sds R9) a = pmf (sds R35) a"
proof -
  from R9_R35.strategyproofness(1) R35.support R9.support
    have "pmf (sds R35) a \<le> pmf (sds R9) a" by simp
  with R35_R9.strategyproofness(1) R9.support R35.support show ?thesis by simp
qed

lemma R18_c [simp]: "pmf (sds R18) c = pmf (sds R9) c"
proof -
  from R18_R9.strategyproofness(1) R18.support R9.support
    have "pmf (sds R18) d + pmf (sds R18) a \<ge> pmf (sds R9) d + pmf (sds R9) a" by auto
  with R9_R18.strategyproofness(1) R18.support R9.support
        lottery_conditions[OF R9.wf] lottery_conditions[OF R18.wf]
    show ?thesis by auto
qed

lemma R5_d_ge_one_half: "pmf (sds R5) d \<ge> 1/2"
  using R5_R10.strategyproofness(1) R5.support lottery_conditions[OF R5.wf] by auto

lemma R7 [simp]: "pmf (sds R7) a = 1/2" "pmf (sds R7) b = 0" "pmf (sds R7) c = 0" "pmf (sds R7) d = 1/2"
proof -
  from R5_d_ge_one_half have "1/2 \<le> pmf (sds R5) d" by simp
  also from R5_R17.strategyproofness(1) R17.support lottery_conditions[OF R5.wf] lottery_conditions[OF R17.wf]
    have "\<dots> \<le> pmf (sds R17) d" by auto
  also from R17_R7.strategyproofness(1) lottery_conditions[OF R7.wf] lottery_conditions[OF R17.wf] R7.support
    have "pmf (sds R17) d \<le> pmf (sds R7) d" by auto
  finally have "pmf (sds R7) d \<ge> 1/2" .
  with R7_R43.strategyproofness(1) lottery_conditions[OF R7.wf] R7.support
    show "pmf (sds R7) a = 1/2" "pmf (sds R7) b = 0" "pmf (sds R7) c = 0" "pmf (sds R7) d = 1/2"
    by auto
qed

lemma R5 [simp]: "pmf (sds R5) a = 1/2" "pmf (sds R5) b = 0" "pmf (sds R5) c = 0" "pmf (sds R5) d = 1/2"
proof -
  from R5_R7.strategyproofness(1) lottery_conditions[OF R5.wf] R5.support
    have "pmf (sds R5) d \<le> 1/2" by auto
  with R5_d_ge_one_half show d: "pmf (sds R5) d = 1 / 2" by simp
  with R5_R10.strategyproofness(1) lottery_conditions[OF R5.wf] R5.support
    show "pmf (sds R5) c = 0" "pmf (sds R5) a = 1/2" by simp_all
qed (simp_all add: R5.support)

lemma R15 [simp]: "pmf (sds R15) a = 1/2" "pmf (sds R15) b = 0" "pmf (sds R15) c = 0" "pmf (sds R15) d = 1/2"
proof -
  {
    assume "pmf (sds R15) b = 0"
    with R10_R15.strategyproofness(1) lottery_conditions[OF R15.wf]
      have "pmf (sds R15) a + pmf (sds R15) c \<le> 1/2" by auto
    with R15_R10.strategyproofness(1) lottery_conditions[OF R15.wf]
      have "pmf (sds R15) c = 0" by auto
  }
  with R15.support show [simp]: "pmf (sds R15) c = 0" by blast
  with R15_R5.strategyproofness(1) lottery_conditions[OF R15.wf]
    have "pmf (sds R15) a \<ge> 1/2" by auto
  moreover from R15_R7.strategyproofness(1) lottery_conditions[OF R15.wf]
    have "pmf (sds R15) b + pmf (sds R15) d \<ge> 1/2" by auto
  ultimately show "pmf (sds R15) a = 1/2" using lottery_conditions[OF R15.wf] by auto
  with R15_R5.strategyproofness(1) lottery_conditions[OF R15.wf]
    show "pmf (sds R15) d = 1/2" "pmf (sds R15) b = 0" by auto
qed

lemma R13_aux: "pmf (sds R13) b = 0" "pmf (sds R13) c = 0" "pmf (sds R13) d = 1 - pmf (sds R13) a"
  and R27_R13 [simp]: "pmf (sds R27) a = pmf (sds R13) a"
  using R27_R13.strategyproofness(1) R13_R27.strategyproofness(1) lottery_conditions[OF R13.wf] by auto

lemma R13 [simp]: "pmf (sds R13) a = 1/2" "pmf (sds R13) b = 0" "pmf (sds R13) c = 0" "pmf (sds R13) d = 1/2"
  using R15_R13.strategyproofness(1) R13_R15.strategyproofness(1) R13_aux by simp_all

lemma R27 [simp]: "pmf (sds R27) a = 1/2" "pmf (sds R27) b = 0" "pmf (sds R27) c = 0" "pmf (sds R27) d = 1/2"
  by simp_all

lemma R19 [simp]: "pmf (sds R19) a = 1/2" "pmf (sds R19) b = 0" "pmf (sds R19) c = 0" "pmf (sds R19) d = 1/2"
proof -
  have "pmf (sds R19) a = 1/2 \<and> pmf (sds R19) b = 0 \<and> pmf (sds R19) c = 0 \<and> pmf (sds R19) d = 1/2"
  proof (rule disjE[OF R19.support]; safe)
    assume [simp]: "pmf (sds R19) b = 0"
    from R10_R19.strategyproofness(1) lottery_conditions[OF R19.wf]
      have "pmf (sds R19) a + pmf (sds R19) c \<le> 1/2" by auto
    moreover from R19_R10.strategyproofness(1)
      have "pmf (sds R19) a + pmf (sds R19) c \<ge> 1/2" by simp
    ultimately show "pmf (sds R19) d = 1/2" using lottery_conditions[OF R19.wf] by simp
    with R27_R19.strategyproofness(1) lottery_conditions[OF R19.wf]
      show "pmf (sds R19) a = 1/2" "pmf (sds R19) c = 0" by auto
  next
    assume [simp]: "pmf (sds R19) c = 0"
    from R19_R10.strategyproofness(1) have "pmf (sds R19) a \<ge> 1/2" by auto
    moreover from R19_R27.strategyproofness(1) have "pmf (sds R19) d \<ge> 1/2" by auto
    ultimately show "pmf (sds R19) a = 1/2" "pmf (sds R19) d = 1/2" "pmf (sds R19) b = 0"
      using lottery_conditions[OF R19.wf] by auto
  qed
  thus "pmf (sds R19) a = 1/2" "pmf (sds R19) b = 0" "pmf (sds R19) c = 0" "pmf (sds R19) d = 1/2"
    by blast+
qed

lemma R1 [simp]: "pmf (sds R1) a = 1/2" "pmf (sds R1) b = 0"
proof -
  from R19_R1.strategyproofness(1) lottery_conditions[OF R1.wf]
    have "pmf (sds R1) a + pmf (sds R1) b \<le> 1/2" by simp
  with R1_R19.strategyproofness(1) lottery_conditions[OF R1.wf]
    show "pmf (sds R1) a = 1/2" "pmf (sds R1) b = 0" by auto
qed

lemma R22 [simp]: "pmf (sds R22) a = 1/2" "pmf (sds R22) b = 0" "pmf (sds R22) c = 0" "pmf (sds R22) d = 1/2"
proof -
  from R33_R5.strategyproofness(1) R33.support
    have "1/2 \<le> pmf (sds R33) a" by auto
  also from R33_R22.strategyproofness(1) R22.support R33.support
    lottery_conditions[OF R22.wf] lottery_conditions[OF R33.wf]
    have "\<dots> \<le> pmf (sds R22) a" by simp
  finally show "pmf (sds R22) a = 1/2" "pmf (sds R22) b = 0" "pmf (sds R22) c = 0" "pmf (sds R22) d = 1/2"
    using R22_R29.strategyproofness(1) lottery_conditions[OF R22.wf] by auto
qed

lemma R28 [simp]: "pmf (sds R28) a = 1/2" "pmf (sds R28) b = 0" "pmf (sds R28) c = 0" "pmf (sds R28) d = 1/2"
proof -
  have "pmf (sds R28) a \<le> pmf (sds R32) d"
    using R32_R28.strategyproofness(1) lottery_conditions[OF R32.wf] by auto
  hence R32_d: "pmf (sds R32) d = pmf (sds R28) a"
    using R28_R32.strategyproofness(1) lottery_conditions[OF R32.wf] by auto

  from R22_R32.strategyproofness(1) lottery_conditions[OF R32.wf] R32.support
    have "pmf (sds R32) a \<le> 1/2" by auto
  with R32_R22.strategyproofness(1) lottery_conditions[OF R32.wf] R32.support
    show "pmf (sds R28) a = 1/2" "pmf (sds R28) b = 0" "pmf (sds R28) c = 0" "pmf (sds R28) d = 1/2"
    by (auto simp: R32_d)
qed

lemma R39 [simp]: "pmf (sds R39) a = 1/2" "pmf (sds R39) b = 0" "pmf (sds R39) c = 0" "pmf (sds R39) d = 1/2"
proof -
  from R28_R39.strategyproofness(1) show "pmf (sds R39) c = 0" by simp
  thus "pmf (sds R39) a = 1/2" "pmf (sds R39) b = 0" "pmf (sds R39) d = 1/2"
    by simp_all
qed

lemma R2 [simp]: "pmf (sds R2) a = 1/2" "pmf (sds R2) b = 0" "pmf (sds R2) c = 0" "pmf (sds R2) d = 1/2"
proof -
  from R1_R2.strategyproofness(1) R2_R1.strategyproofness(1) lottery_conditions[OF R2.wf] lottery_conditions[OF R1.wf]
    have "pmf (sds R2) a = 1/2" "pmf (sds R2) c + pmf (sds R2) d = 1/2" by (auto simp: algebra_simps)
  with R39_R2.strategyproofness(1) lottery_conditions[OF R2.wf]
    show "pmf (sds R2) a = 1/2" "pmf (sds R2) b = 0" "pmf (sds R2) c = 0" "pmf (sds R2) d = 1/2"
    by auto
qed

lemma R42 [simp]: "pmf (sds R42) a = 0" "pmf (sds R42) b = 0" "pmf (sds R42) c = 1/2" "pmf (sds R42) d = 1/2"
proof -
  from R17_R5.strategyproofness(1) lottery_conditions[OF R17.wf] R17.support
    have "pmf (sds R17) d \<le> 1/2" by auto
  moreover from R5_R17.strategyproofness(1) R17.support lottery_conditions[OF R17.wf]
    have "pmf (sds R17) d \<ge> 1/2" by auto
  ultimately have R17_d: "pmf (sds R17) d = 1/2" by simp

  from R6_R42.strategyproofness(1)
    have "pmf (sds R42) a + pmf (sds R42) c \<le> pmf (sds R6) a + pmf (sds R6) c" by simp
  also from R6_R19.strategyproofness(1) lottery_conditions[OF R6.wf]
    have "pmf (sds R6) a + pmf (sds R6) c \<le> 1/2" by auto
  finally have "pmf (sds R42) a + pmf (sds R42) c \<le> 1 / 2" .
  moreover from R17_R11.strategyproofness(1) R11.support R17.support
       lottery_conditions[OF R11.wf] lottery_conditions[OF R17.wf]
    have "pmf (sds R11) d \<ge> 1/2" by (auto simp: R17_d)
  ultimately have "pmf (sds R42) a + pmf (sds R42) c \<le> pmf (sds R11) d" by simp
  with R42_R11.strategyproofness(1) R11.support
    have E: "pmf (sds R11) d \<le> pmf (sds R42) c" by auto
  with \<open>pmf (sds R11) d \<ge> 1/2\<close> have "pmf (sds R42) c \<ge> 1/2" by simp
  moreover from R17_R3.strategyproofness(1) R3.support R17.support
       lottery_conditions[OF R17.wf] lottery_conditions[OF R3.wf]
    have "pmf (sds R3) d \<ge> 1/2" by (auto simp: R17_d)
  ultimately show "pmf (sds R42) a = 0" "pmf (sds R42) b = 0" "pmf (sds R42) c = 1/2" "pmf (sds R42) d = 1/2"
    using R42_R3.strategyproofness(1) lottery_conditions[OF R3.wf] lottery_conditions[OF R42.wf]
    by auto
qed

lemma R37 [simp]: "pmf (sds R37) a = 1/2" "pmf (sds R37) b = 0" "pmf (sds R37) c = 1/2" "pmf (sds R37) d = 0"
proof -
  from R37_R42.strategyproofness(1) lottery_conditions[OF R37.wf]
    have "pmf (sds R37) a = 1/2 \<or> pmf (sds R37) a + pmf (sds R37) b > 1/2" by auto
  moreover from R37_R42.strategyproofness(2) lottery_conditions[OF R37.wf]
    have "pmf (sds R37) c = 1/2 \<or> pmf (sds R37) c + pmf (sds R37) d > 1/2" by auto
  ultimately show "pmf (sds R37) a = 1/2" "pmf (sds R37) b = 0" "pmf (sds R37) c = 1/2" "pmf (sds R37) d = 0"
    using lottery_conditions[OF R37.wf] by auto
qed

lemma R24 [simp]: "pmf (sds R24) a = 0" "pmf (sds R24) b = 0" "pmf (sds R24) d = 1 - pmf (sds R24) c"
  using R42_R24.strategyproofness(1) lottery_conditions[OF R24.wf] by auto

lemma R34 [simp]:
  "pmf (sds R34) a = 1 - pmf (sds R24) c" "pmf (sds R34) b = pmf (sds R24) c"
  "pmf (sds R34) c = 0" "pmf (sds R34) d = 0"
proof -
  from R24_R34.strategyproofness(1) lottery_conditions[OF R34.wf]
    have "pmf (sds R34) b \<le> pmf (sds R24) c" by auto
  moreover from R34_R24.strategyproofness(1) lottery_conditions[OF R34.wf]
    have "pmf (sds R34) b \<ge> pmf (sds R24) c" by auto
  ultimately show bc: "pmf (sds R34) b = pmf (sds R24) c" by simp
  from R34_R24.strategyproofness(1) bc lottery_conditions[OF R34.wf]
    show "pmf (sds R34) c = 0" by auto
  moreover from R24_R34.strategyproofness(1) bc show "pmf (sds R34) d = 0" by simp
  ultimately show "pmf (sds R34) a = 1 - pmf (sds R24) c"
    using bc lottery_conditions[OF R34.wf] by auto
qed

lemma R14 [simp]: "pmf (sds R14) b = 0" "pmf (sds R14) d = 0" "pmf (sds R14) c = 1 - pmf (sds R14) a"
  using R14_R34.strategyproofness(1) R14.support lottery_conditions[OF R14.wf] by auto

lemma R46 [simp]: "pmf (sds R46) a = 0" "pmf (sds R46) c = 0" "pmf (sds R46) d = 1 - pmf (sds R46) b"
  using R46_R37.strategyproofness(1) lottery_conditions[OF R46.wf] by auto

lemma R20 [simp]: "pmf (sds R20) a = 0" "pmf (sds R20) c = 0" "pmf (sds R20) d = 1 - pmf (sds R20) b"
  using R46_R20.strategyproofness(1) lottery_conditions[OF R20.wf] by auto

lemma R21 [simp]: "pmf (sds R21) d = 1 - pmf (sds R21) a" "pmf (sds R21) b = 0" "pmf (sds R21) c = 0"
  using R20_R21.strategyproofness(1) lottery_conditions[OF R21.wf] by auto

lemma R16_R12: "pmf (sds R16) c + pmf (sds R16) a \<le> pmf (sds R12) a"
  using R12_R16.strategyproofness(1) R16.support lottery_conditions[OF R16.wf] by auto

lemma R16 [simp]: "pmf (sds R16) b = 0" "pmf (sds R16) c = 0" "pmf (sds R16) d = 1 - pmf (sds R16) a"
proof -
  from R16_R12 have "pmf (sds R16) c + pmf (sds R16) a \<le> pmf (sds R12) a" by simp
  also from R44_R40.strategyproofness(1) lottery_conditions[OF R40.wf] R40.support
    have "pmf (sds R12) a \<le> pmf (sds R40) a" by auto
  also from R9_R40.strategyproofness(1) R9.support R40.support
    have "pmf (sds R40) a \<le> pmf (sds R9) a" by auto
  finally have "pmf (sds R16) c + pmf (sds R16) a \<le> pmf (sds R9) a" by simp
  moreover from R14_R16.strategyproofness(1) R16.support lottery_conditions[OF R16.wf]
    have "pmf (sds R16) a \<ge> pmf (sds R14) a" by auto
  ultimately have "pmf (sds R16) c \<le> pmf (sds R9) a - pmf (sds R14) a" by simp
  also from R14_R9.strategyproofness(1) R9.support lottery_conditions[OF R9.wf]
    have "pmf (sds R9) a - pmf (sds R14) a \<le> 0" by auto
  finally show "pmf (sds R16) b = 0" "pmf (sds R16) c = 0" "pmf (sds R16) d = 1 - pmf (sds R16) a"
    using lottery_conditions[OF R16.wf] R16.support by auto
qed

lemma R12_R14: "pmf (sds R14) a \<le> pmf (sds R12) a"
  using R14_R16.strategyproofness(1) R16_R12 by auto

lemma R12_a [simp]: "pmf (sds R12) a = pmf (sds R9) a"
proof -
  from R44_R40.strategyproofness(1) R40.support lottery_conditions[OF R40.wf]
    have "pmf (sds R12) a \<le> pmf (sds R40) a" by auto
  also from R9_R40.strategyproofness(1) R9.support R40.support
    have "pmf (sds R40) a \<le> pmf (sds R9) a" by auto
  finally have B: "pmf (sds R12) a \<le> pmf (sds R9) a" by simp
  moreover from R14_R9.strategyproofness(1) lottery_conditions[OF R9.wf] R9.support
    have "pmf (sds R9) a \<le> pmf (sds R14) a" by auto
  with R12_R14 have "pmf (sds R9) a \<le> pmf (sds R12) a" by simp
  ultimately show "pmf (sds R12) a = pmf (sds R9) a" by simp
qed

lemma R9 [simp]: "pmf (sds R9) b = 0" "pmf (sds R9) d = 0" "pmf (sds R14) a = pmf (sds R35) a" "pmf (sds R9) c = 1 - pmf (sds R35) a"
  using R12_R14 R14_R9.strategyproofness(1) lottery_conditions[OF R9.wf] R9.support
  by auto

lemma R23 [simp]: "pmf (sds R23) b = 0" "pmf (sds R23) c = 0" "pmf (sds R23) d = 1 - pmf (sds R23) a"
  using R23_R19.strategyproofness(1) lottery_conditions[OF R23.wf] R23.support by auto

lemma R35 [simp]: "pmf (sds R35) a = pmf (sds R21) a" "pmf (sds R35) b = 0" "pmf (sds R35) c = 0" "pmf (sds R35) d = 1 - pmf (sds R21) a"
proof -
  from R35_R21.strategyproofness(1) R35.support
    have "pmf (sds R21) a \<le> pmf (sds R35) a + pmf (sds R35) c" by auto
  with R21_R35.strategyproofness(1) R35.support lottery_conditions[OF R35.wf]
    show "pmf (sds R35) a = pmf (sds R21) a" "pmf (sds R35) b = 0"
         "pmf (sds R35) c = 0" "pmf (sds R35) d = 1 - pmf (sds R21) a" by simp_all
qed

lemma R18 [simp]: "pmf (sds R18) a = pmf (sds R14) a" "pmf (sds R18) b = 0"
                  "pmf (sds R18) d = 0" "pmf (sds R18) c = 1 - pmf (sds R14) a"
proof -
 from R23_R12.strategyproofness(1)
    have R21_R23: "pmf (sds R21) a \<le> pmf (sds R23) a" by simp

  from R23_R18.strategyproofness(1)
    have "pmf (sds R18) d \<le> pmf (sds R21) a - pmf (sds R23) a" by simp
  also from R21_R23 have "\<dots> \<le> 0" by simp
  finally show "pmf (sds R18) d = 0" by simp
  with lottery_conditions[OF R18.wf] R18.support
    show "pmf (sds R18) a = pmf (sds R14) a"
         "pmf (sds R18) c = 1 - pmf (sds R14) a" by auto
qed (insert R18.support, simp_all)

lemma R4 [simp]: "pmf (sds R4) a = pmf (sds R21) a" "pmf (sds R4) b = 0"
                 "pmf (sds R4) c = 1 - pmf (sds R4) a" "pmf (sds R4) d = 0"
proof -
  from R30_R21.strategyproofness(1) R30.support lottery_conditions[OF R30.wf]
    have "pmf (sds R4) c + pmf (sds R21) a \<le> pmf (sds R4) c + pmf (sds R30) a" by auto
  also {
    have "pmf (sds R30) a \<le> pmf (sds R47) a"
      using R47_R30.strategyproofness(1) R30.support R47.support
             lottery_conditions[OF R4.wf] lottery_conditions[OF R47.wf] by auto
    moreover from R4_R47.strategyproofness(1) R4.support R47.support
           lottery_conditions[OF R4.wf] lottery_conditions[OF R47.wf]
      have "pmf (sds R4) c \<le> pmf (sds R47) c" by simp
    ultimately have "pmf (sds R4) c + pmf (sds R30) a \<le> 1 - pmf (sds R47) d"
      using lottery_conditions[OF R47.wf] R47.support by simp
  }
  finally have "pmf (sds R4) c + pmf (sds R14) a \<le> 1"
    using lottery_conditions[OF R47.wf] by simp
  with R4_R18.strategyproofness(1) lottery_conditions[OF R4.wf] R4.support
    show "pmf (sds R4) a = pmf (sds R21) a" "pmf (sds R4) b = 0"
         "pmf (sds R4) c = 1 - pmf (sds R4) a" "pmf (sds R4) d = 0" by auto
qed

lemma R8_d [simp]: "pmf (sds R8) d = 1 - pmf (sds R8) a"
  and R8_c [simp]: "pmf (sds R8) c = 0"
  and R26_a [simp]: "pmf (sds R26) a = 1 - pmf (sds R8) a"
proof -
  from R8_R26.strategyproofness(2) R8.support lottery_conditions[OF R8.wf]
    have "pmf (sds R26) a \<le> pmf (sds R8) d" by auto
  with R26_R8.strategyproofness(2) R8.support lottery_conditions[OF R8.wf]
    have "pmf (sds R26) a = pmf (sds R8) d" by auto
  with R8_R26.strategyproofness(2) R8.support lottery_conditions[OF R8.wf]
    show "pmf (sds R8) c = 0" "pmf (sds R8) d = 1 - pmf (sds R8) a"
         "pmf (sds R26) a = 1 - pmf (sds R8) a" by auto
qed

lemma R21_R47: "pmf (sds R21) d \<le> pmf (sds R47) c"
  using R4_R47.strategyproofness(1) R4.support R47.support
         lottery_conditions[OF R4.wf] lottery_conditions[OF R47.wf]
  by auto

lemma R30 [simp]: "pmf (sds R30) a = pmf (sds R47) a" "pmf (sds R30) b = 0"
  "pmf (sds R30) c = 0" "pmf (sds R30) d = 1 - pmf (sds R47) a"
proof -
  have A: "pmf (sds R30) a \<le> pmf (sds R47) a"
    using R47_R30.strategyproofness(1) R30.support R47.support
           lottery_conditions[OF R4.wf] lottery_conditions[OF R47.wf] by auto
  with R21_R47 R30_R21.strategyproofness(1)
    lottery_conditions[OF R30.wf] lottery_conditions[OF R47.wf]
    show "pmf (sds R30) a = pmf (sds R47) a" "pmf (sds R30) b = 0"
         "pmf (sds R30) c = 0" "pmf (sds R30) d = 1 - pmf (sds R47) a"
      by (auto simp: R30.support R47.support) (* tricky step! *)
qed

lemma R31_c_ge_one_half: "pmf (sds R31) c \<ge> 1/2"
proof -
  from R25.support have "pmf (sds R25) a \<ge> 1/2"
  proof
    assume "pmf (sds R25) c = 0"
    with R25_R36.strategyproofness(1) lottery_conditions[OF R36.wf]
       show "pmf (sds R25) a \<ge> 1/2" by auto
  next
    assume [simp]: "pmf (sds R25) b = 0"
    from R36_R25.strategyproofness(1) lottery_conditions[OF R25.wf]
      have "pmf (sds R25) c + pmf (sds R25) a \<le> pmf (sds R36) c + 1 / 2" by auto
    with R25_R36.strategyproofness(1) show "pmf (sds R25) a \<ge> 1/2" by auto
  qed
  hence "pmf (sds R26) a \<ge> 1/2"
    using R25_R26.strategyproofness(1) lottery_conditions[OF R25.wf] by auto
  with lottery_conditions[OF R47.wf]
    have "1/2 \<le> pmf (sds R26) a + pmf (sds R47) d" by simp
  also have "\<dots> = 1 - pmf (sds R8) a + pmf (sds R47) d" by simp
  also from R4_R8.strategyproofness(1)
    have "1 - pmf (sds R8) a \<le> pmf (sds R21) d" by auto
  also note R21_R47
  also from R30_R41.strategyproofness(1) R41.support
            lottery_conditions[OF R41.wf] lottery_conditions[OF R47.wf]
    have "pmf (sds R47) c + pmf (sds R47) d \<le> pmf (sds R41) d" by auto
  also from R41_R31.strategyproofness(1) R41.support lottery_conditions[OF R31.wf]
       lottery_conditions[OF R41.wf]
    have "pmf (sds R41) d \<le> pmf (sds R31) c" by auto
  finally show "pmf (sds R31) c \<ge> 1/2" by simp
qed

lemma R31: "pmf (sds R31) a = 0" "pmf (sds R31) c = 1/2" "pmf (sds R31) b + pmf (sds R31) d = 1/2"
proof -
  from R2_R38.strategyproofness(1) lottery_conditions[OF R38.wf]
    have A: "pmf (sds R38) b + pmf (sds R38) d \<ge> 1/2" by auto
  with R31_c_ge_one_half R31_R38.strategyproofness(1)
        lottery_conditions[OF R31.wf] lottery_conditions[OF R38.wf]
  have "pmf (sds R38) b + pmf (sds R38) d = pmf (sds R31) d + pmf (sds R31) b" by auto
  with R31_c_ge_one_half A lottery_conditions[OF R31.wf] lottery_conditions[OF R38.wf]
    show "pmf (sds R31) a = 0" "pmf (sds R31) c = 1/2" "pmf (sds R31) b + pmf (sds R31) d = 1/2"
    by auto
qed

lemma absurd: False
  using R31 R45_R31.strategyproofness(2) by simp

(* TODO (Re-)move *)
ML_val \<open>
let
val thms = @{thms
R1_R2.strategyproofness(1)
R1_R19.strategyproofness(1)
R2_R1.strategyproofness(1)
R2_R38.strategyproofness(1)
R4_R8.strategyproofness(1)
R4_R18.strategyproofness(1)
R4_R47.strategyproofness(1)
R5_R7.strategyproofness(1)
R5_R10.strategyproofness(1)
R5_R17.strategyproofness(1)
R6_R19.strategyproofness(1)
R6_R42.strategyproofness(1)
R7_R43.strategyproofness(1)
R8_R26.strategyproofness(2)
R9_R18.strategyproofness(1)
R9_R35.strategyproofness(1)
R9_R40.strategyproofness(1)
R10_R12.strategyproofness(1)
R10_R15.strategyproofness(1)
R10_R19.strategyproofness(1)
R10_R36.strategyproofness(1)
R12_R10.strategyproofness(1)
R12_R16.strategyproofness(1)
R12_R44.strategyproofness(1)
R13_R15.strategyproofness(1)
R13_R27.strategyproofness(1)
R14_R9.strategyproofness(1)
R14_R16.strategyproofness(1)
R14_R34.strategyproofness(1)
R15_R5.strategyproofness(1)
R15_R7.strategyproofness(1)
R15_R10.strategyproofness(1)
R15_R13.strategyproofness(1)
R17_R3.strategyproofness(1)
R17_R5.strategyproofness(1)
R17_R7.strategyproofness(1)
R17_R11.strategyproofness(1)
R18_R9.strategyproofness(1)
R19_R1.strategyproofness(1)
R19_R10.strategyproofness(1)
R19_R27.strategyproofness(1)
R20_R21.strategyproofness(1)
R21_R35.strategyproofness(1)
R22_R29.strategyproofness(1)
R22_R32.strategyproofness(1)
R23_R12.strategyproofness(1)
R23_R18.strategyproofness(1)
R23_R19.strategyproofness(1)
R24_R34.strategyproofness(1)
R25_R26.strategyproofness(1)
R25_R36.strategyproofness(1)
R26_R8.strategyproofness(2)
R27_R13.strategyproofness(1)
R27_R19.strategyproofness(1)
R28_R32.strategyproofness(1)
R28_R39.strategyproofness(1)
R29_R39.strategyproofness(1)
R30_R21.strategyproofness(1)
R30_R41.strategyproofness(1)
R31_R38.strategyproofness(1)
R32_R22.strategyproofness(1)
R32_R28.strategyproofness(1)
R33_R5.strategyproofness(1)
R33_R22.strategyproofness(1)
R34_R24.strategyproofness(1)
R35_R9.strategyproofness(1)
R35_R21.strategyproofness(1)
R36_R10.strategyproofness(1)
R36_R25.strategyproofness(1)
R36_R39.strategyproofness(1)
R37_R42.strategyproofness(1)
R37_R42.strategyproofness(2)
R39_R2.strategyproofness(1)
R39_R29.strategyproofness(1)
R39_R36.strategyproofness(1)
R41_R31.strategyproofness(1)
R42_R3.strategyproofness(1)
R42_R11.strategyproofness(1)
R42_R24.strategyproofness(1)
R44_R12.strategyproofness(1)
R44_R40.strategyproofness(1)
R45_R31.strategyproofness(2)
R46_R20.strategyproofness(1)
R46_R37.strategyproofness(1)
R47_R30.strategyproofness(1)
};
in
 thms
 |> map (Pretty.quote o Pretty.str o Pretty.unformatted_string_of o Syntax.pretty_term @{context} o Thm.prop_of)
 |> Pretty.list "[" "]"
 |> (fn x => Pretty.block [Pretty.str "thms = ", x])
 |> Pretty.string_of
 |> writeln
end
\<close>

end

subsection \<open>Lifting to more than 4 agents and alternatives\<close>

(* TODO: Move? *)
lemma finite_list':
  assumes "finite A"
  obtains xs where "A = set xs" "distinct xs" "length xs = card A"
proof -
  from assms obtain xs where "set xs = A" using finite_list by blast
  thus ?thesis using distinct_card[of "remdups xs"]
    by (intro that[of "remdups xs"]) simp_all
qed

lemma finite_list_subset:
  assumes "finite A" "card A \<ge> n"
  obtains xs where "set xs \<subseteq> A" "distinct xs" "length xs = n"
proof -
  obtain xs where "A = set xs" "distinct xs" "length xs = card A"
    using finite_list'[OF assms(1)] by blast
  with assms show ?thesis
    by (intro that[of "take n xs"]) (simp_all add: set_take_subset)
qed

lemma card_ge_4E:
  assumes "finite A" "card A \<ge> 4"
  obtains a b c d where "distinct [a,b,c,d]" "{a,b,c,d} \<subseteq> A"
proof -
  from finite_list_subset[OF assms] guess xs .
  moreover then obtain a b c d where "xs = [a, b, c, d]"
    by (auto simp: eval_nat_numeral length_Suc_conv)
  ultimately show ?thesis by (intro that[of a b c d]) simp_all
qed

context sds_impossibility
begin

lemma absurd: False
proof -
  from card_ge_4E[OF finite_agents agents_ge_4] guess A1 A2 A3 A4 .
  note agents = this
  from card_ge_4E[OF finite_alts alts_ge_4] guess a b c d .
  note alts = this
  def agents' \<equiv> "{A1,A2,A3,A4}" and alts' \<equiv> "{a,b,c,d}"
  from agents alts
    interpret sds_lowering_anonymous_neutral_sdeff_stratproof agents alts sds agents' alts'
    unfolding agents'_def alts'_def by unfold_locales simp_all
  from agents alts
    interpret sds_impossibility_4_4 agents' alts' lowered A1 A2 A3 A4 a b c d
    by unfold_locales (simp_all add: agents'_def alts'_def)
  from absurd show False .
qed

end

end


header {* \isaheader{Partial Function Package Setup} *}
theory Refine_Pfun
imports Refine_Basic Refine_Det
begin

text {*
  In this theory, we set up the partial function package to be used
  with our refinement framework.
*}

subsection {* Nondeterministic Result Monad *}

interpretation nrec!:
  partial_function_definitions "op \<le>" "Sup::'a nres set \<Rightarrow> 'a nres"
  by unfold_locales (auto simp add: Sup_upper Sup_least)

lemma nrec_admissible: "nrec.admissible (\<lambda>(f::'a \<Rightarrow> 'b nres).
  (\<forall>x0. f x0 \<le> SPEC (P x0)))"
  apply (rule ccpo.admissibleI)
  apply (unfold fun_lub_def)
  apply (intro allI impI)
  apply (rule Sup_least)
  apply auto
  done

(*
lemma fixp_induct_nrec:
  fixes F :: "'c \<Rightarrow> 'c" and
    U :: "'c \<Rightarrow> 'b \<Rightarrow> 'a nres" and
    C :: "('b \<Rightarrow> 'a nres) \<Rightarrow> 'c" and
    P :: "'b \<Rightarrow> 'a \<Rightarrow> bool"
  assumes mono: "\<And>x. nrec_mono (\<lambda>f. U (F (C f)) x)"
  assumes eq: "f \<equiv> C (nrec_ffix (\<lambda>f. U (F (C f))))"
  assumes inverse2: "\<And>f. U (C f) = f"
  assumes step: "\<And>f x. (\<And>x. U f x \<le> SPEC (P x)) \<Longrightarrow> U (F f) x \<le> SPEC (P x)"
  assumes defined: "RETURN y \<le> U f x"
  shows "U f x \<le> SPEC (P x)"
  using step defined
    nrec.fixp_induct_uc[of U F C, OF mono eq inverse2 nrec_admissible]
  by blast

lemma fixp_induct_nrec':
  fixes F :: "'c \<Rightarrow> 'c" and
    U :: "'c \<Rightarrow> 'b \<Rightarrow> 'a nres" and
    C :: "('b \<Rightarrow> 'a nres) \<Rightarrow> 'c" and
    P :: "'b \<Rightarrow> 'a \<Rightarrow> bool"
  assumes mono: "\<And>x. nrec_mono (\<lambda>f. U (F (C f)) x)"
  assumes eq: "f \<equiv> C (nrec_ffix (\<lambda>f. U (F (C f))))"
  assumes inverse2: "\<And>f. U (C f) = f"
  assumes step: "\<And>f x0. (\<And>x0. U f x0 \<le> SPEC (P x0))
    \<Longrightarrow> U (F f) x0 \<le> SPEC (P x0)"
  assumes defined: "RETURN y \<le> U f x"
  shows "P x y"
proof -
  note defined
  also have "\<forall>x0. U f x0 \<le> SPEC (P x0)"
    apply (rule nrec.fixp_induct_uc[of U F C, OF mono eq inverse2
      nrec_admissible])
    using step by blast
  hence "U f x \<le> SPEC (P x)" by simp
  finally show "P x y" by auto
qed
*)
(* TODO/FIXME: Induction rule seems not to work here !
    Function package expects induction rule where conclusion is a binary
    predicate as free variable.
*)

declaration {* Partial_Function.init "nrec" @{term nrec.fixp_fun}
  @{term nrec.mono_body} @{thm nrec.fixp_rule_uc} @{thm nrec.fixp_induct_uc}
  (*SOME @{thm fixp_induct_nrec'}*) NONE *}

lemma bind_mono_pfun[partial_function_mono]:
  fixes C :: "'a \<Rightarrow> ('b \<Rightarrow> 'c nres) \<Rightarrow> ('d nres)"
  shows
  "\<lbrakk> monotone (fun_ord op \<le>) op \<le> B;
    \<And>y. monotone (fun_ord op \<le>) op \<le> (\<lambda>f. C y f) \<rbrakk> \<Longrightarrow>
     monotone (fun_ord op \<le>) op \<le> (\<lambda>f. bind (B f) (\<lambda>y. C y f))"
  apply rule
  apply (rule Refine_Basic.bind_mono)
  apply (blast dest: monotoneD)+
  done

subsection {* Deterministic Result Monad *}

interpretation drec!:
  partial_function_definitions "op \<le>" "Sup::'a dres set \<Rightarrow> 'a dres"
  by unfold_locales (auto simp add: Sup_upper Sup_least)

lemma drec_admissible: "drec.admissible (\<lambda>(f::'a \<Rightarrow> 'b dres).
  (\<forall>x. P x \<longrightarrow>
    (f x \<noteq> dFAIL \<and>
    (\<forall>r. f x = dRETURN r \<longrightarrow> Q x r))))"
proof -
  have [simp]: "fun_ord (op \<le>::'b dres \<Rightarrow> _ \<Rightarrow> _) = op \<le>"
    apply (intro ext)
    unfolding fun_ord_def le_fun_def
    by (rule refl)

  have [simp]: "\<And>A x. {y. \<exists>f\<in>A. y = f x} = (\<lambda>f. f x)`A" by auto

  show ?thesis
    apply (rule ccpo.admissibleI)
    apply (unfold fun_lub_def)
    apply clarsimp
    apply (drule_tac x=x in point_chainI)
    apply (erule dres_Sup_chain_cases)
    apply (simp only: SUP_def)
    apply simp
    apply (simp only: SUP_def)
    apply auto []
    apply (simp only: SUP_def)
    apply force
    done
qed

declaration {* Partial_Function.init "drec" @{term drec.fixp_fun}
  @{term drec.mono_body} @{thm drec.fixp_rule_uc} @{thm drec.fixp_induct_uc}
  NONE *}

lemma drec_bind_mono_pfun[partial_function_mono]:
  fixes C :: "'a \<Rightarrow> ('b \<Rightarrow> 'c dres) \<Rightarrow> ('d dres)"
  shows
  "\<lbrakk> monotone (fun_ord op \<le>) op \<le> B;
    \<And>y. monotone (fun_ord op \<le>) op \<le> (\<lambda>f. C y f) \<rbrakk> \<Longrightarrow>
     monotone (fun_ord op \<le>) op \<le> (\<lambda>f. dbind (B f) (\<lambda>y. C y f))"
  apply rule
  apply (rule dbind_mono)
  apply (blast dest: monotoneD)+
  done

end