(*
  File: Union_Find_Impl.thy
  Author: Bohua Zhan
*)

section \<open>Implementation of union find\<close>

theory Union_Find_Impl
  imports SepAuto "../Functional/Union_Find"
begin

text \<open>
  Development follows theory Union\_Find in
  \<^cite>\<open>"Separation_Logic_Imperative_HOL-AFP"\<close> by Lammich and Meis.
\<close>

type_synonym uf = "nat array \<times> nat array"

definition is_uf :: "nat \<Rightarrow> (nat\<times>nat) set \<Rightarrow> uf \<Rightarrow> assn" where [rewrite_ent]:
  "is_uf n R u = (\<exists>\<^sub>Al szl. snd u \<mapsto>\<^sub>a l * fst u \<mapsto>\<^sub>a szl *
        \<up>(ufa_invar l) * \<up>(ufa_\<alpha> l = R) * \<up>(length l = n) * \<up>(length szl = n))"

definition uf_init :: "nat \<Rightarrow> uf Heap" where
  "uf_init n = do {
     l \<leftarrow> Array.of_list [0..<n];
     szl \<leftarrow> Array.new n (1::nat);
     return (szl, l)
   }"

text \<open>Correctness of uf\_init.\<close>
theorem uf_init_rule [hoare_triple]:
  "<emp> uf_init n <is_uf n (uf_init_rel n)>" by auto2

partial_function (heap) uf_rep_of :: "nat array \<Rightarrow> nat \<Rightarrow> nat Heap" where
  "uf_rep_of p i = do {
     n \<leftarrow> Array.nth p i;
     if n = i then return i else uf_rep_of p n
   }"

lemma uf_rep_of_rule [hoare_triple]:
  "ufa_invar l \<Longrightarrow> i < length l \<Longrightarrow>
   <p \<mapsto>\<^sub>a l>
   uf_rep_of p i
   <\<lambda>r. p \<mapsto>\<^sub>a l * \<up>(r = rep_of l i)>"
@proof @prop_induct "ufa_invar l \<and> i < length l" @qed

partial_function (heap) uf_compress :: "nat \<Rightarrow> nat \<Rightarrow> nat array \<Rightarrow> unit Heap" where
  "uf_compress i ci p = (
    if i = ci then return ()
    else do {
      ni \<leftarrow> Array.nth p i;
      uf_compress ni ci p;
      Array.upd i ci p;
      return ()
    })"

lemma uf_compress_rule [hoare_triple]:
  "ufa_invar l \<Longrightarrow> i < length l \<Longrightarrow>
   <p \<mapsto>\<^sub>a l>
    uf_compress i (rep_of l i) p
   <\<lambda>_. \<exists>\<^sub>Al'. p \<mapsto>\<^sub>a l' * \<up>(ufa_invar l' \<and> length l' = length l \<and>
              (\<forall>i<length l. rep_of l' i = rep_of l i))>"
@proof @prop_induct "ufa_invar l \<and> i < length l" @qed

definition uf_rep_of_c :: "nat array \<Rightarrow> nat \<Rightarrow> nat Heap" where
  "uf_rep_of_c p i = do {
    ci \<leftarrow> uf_rep_of p i;
    uf_compress i ci p;
    return ci
  }"

lemma uf_rep_of_c_rule [hoare_triple]:
  "ufa_invar l \<Longrightarrow> i < length l \<Longrightarrow>
   <p \<mapsto>\<^sub>a l>
   uf_rep_of_c p i
   <\<lambda>r. \<exists>\<^sub>Al'. p \<mapsto>\<^sub>a l' * \<up>(r = rep_of l i \<and> ufa_invar l' \<and> length l' = length l \<and>
                          (\<forall>i<length l. rep_of l' i = rep_of l i))>"
  by auto2

definition uf_cmp :: "uf \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> bool Heap" where
  "uf_cmp u i j = do {
    n \<leftarrow> Array.len (snd u);
    if (i\<ge>n \<or> j\<ge>n) then return False
    else do {
      ci \<leftarrow> uf_rep_of_c (snd u) i;
      cj \<leftarrow> uf_rep_of_c (snd u) j;
      return (ci = cj)
    }
  }"

text \<open>Correctness of compare.\<close>
theorem uf_cmp_rule [hoare_triple]:
  "<is_uf n R u>
   uf_cmp u i j
   <\<lambda>r. is_uf n R u * \<up>(r \<longleftrightarrow> (i,j)\<in>R)>" by auto2

definition uf_union :: "uf \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> uf Heap" where
  "uf_union u i j = do {
    ci \<leftarrow> uf_rep_of (snd u) i;
    cj \<leftarrow> uf_rep_of (snd u) j;
    if (ci = cj) then return u
    else do {
      si \<leftarrow> Array.nth (fst u) ci;
      sj \<leftarrow> Array.nth (fst u) cj;
      if si < sj then do {
        Array.upd ci cj (snd u);
        Array.upd cj (si+sj) (fst u);
        return u
      } else do {
        Array.upd cj ci (snd u);
        Array.upd ci (si+sj) (fst u);
        return u
      }
    }
  }"

text \<open>Correctness of union.\<close>
theorem uf_union_rule [hoare_triple]:
  "i < n \<Longrightarrow> j < n \<Longrightarrow>
   <is_uf n R u>
   uf_union u i j
   <is_uf n (per_union R i j)>" by auto2

setup \<open>del_prfstep_thm @{thm is_uf_def}\<close>

end


theory Velocity
  imports BigStepParallel
begin

subsection \<open>Case study: velocity control\<close>

definition V :: char where "V = CHR ''v''"
definition A :: char where "A = CHR ''a''"
definition T :: char where "T = CHR ''t''"

text \<open>
  plant ::= (t := 0; \<langle>v_dot = a, t_dot = 1 & t < 1\<rangle>; p2c!v; c2p?a)*
\<close>
definition plant :: proc where
  "plant = Rep (T ::= (\<lambda>_. 0);
                Cont (ODE ((\<lambda>_ _. 0)(V := (\<lambda>s. s A), T := (\<lambda>_. 1)))) (\<lambda>s. s T < 1);
                Cm (''p2c''[!](\<lambda>s. s V));
                Cm (''c2p''[?]A))"

text \<open>
  control ::= (p2c?v; if v < 10 then c2p!1 else c2p!(-1))*
\<close>
definition control :: proc where
  "control = Rep (Cm (''p2c''[?]V);
                  IF (\<lambda>s. s V < 10) THEN Cm (''c2p''[!](\<lambda>_. 1))
                  ELSE Cm (''c2p''[!](\<lambda>_. -1)) FI)"

text \<open>
  system ::= plant || control
\<close>
definition system :: pproc where
  "system = Parallel (Single plant) {''p2c'', ''c2p''} (Single control)"

text \<open>
  Analysis of the ODE for plant. This involves checking the solution and
  showing that the ODE satisfies the Lipschitz condition (and hence has
  unique solutions).
\<close>
lemma plant_ODE:
  "\<Turnstile> {\<lambda>s tr. s = (\<lambda>_. 0)(V := v0, A := a0, T := 0) \<and> P tr}
        Cont (ODE ((\<lambda>_ _. 0)(V := (\<lambda>s. s A), T := (\<lambda>_. 1)))) (\<lambda>s. s T < 1)
      {\<lambda>s tr. s = (\<lambda>_. 0)(V := v0 + a0 * 1, A := a0, T := 1) \<and>
              (P @\<^sub>t Wait\<^sub>t 1 (\<lambda>t. State ((\<lambda>_. 0)(V := v0 + a0 * t, A := a0, T := t))) ({}, {})) tr}"
proof -
  have 1: "ODEsol (ODE ((\<lambda>_ _. 0)(V := (\<lambda>s. s A), T := (\<lambda>_. 1))))
                  (\<lambda>t. (\<lambda>_. 0)(V := v0 + a0 * t, A := a0, T := t)) 1"
    unfolding ODEsol_def has_vderiv_on_def
    apply auto
    apply(rule exI[where x=1])
    apply auto
    apply (rule has_vector_derivative_projI)
    apply (auto simp add: state2vec_def A_def V_def T_def)
     apply (rule has_vector_derivative_eq_rhs)
      apply (auto intro!: derivative_intros)[1] apply simp
    subgoal for x i
      apply (cases "i = CHR ''a''") by auto
    done
  have 2: "local_lipschitz {- (1::real)<..} UNIV (\<lambda>t v. ODE2Vec (ODE ((\<lambda>_ _. 0)(V := \<lambda>s. s A, T := \<lambda>_. 1))) (vec2state v))"
  proof -
    show ?thesis
      unfolding state2vec_def vec2state_def fun_upd_def
      apply (rule c1_implies_local_lipschitz[where f'="(\<lambda>(t,v). Blinfun(\<lambda>(v::vec) . \<chi> x. if x = V then (v$A) else if x = T then 0 else 0))"])
         apply auto
      subgoal for t x
        apply (subst bounded_linear_Blinfun_apply)
        subgoal
          apply (rule bounded_linearI')
          by (auto simp add: vec_lambda_unique[symmetric])
        unfolding has_derivative_def
        apply auto
          apply (rule bounded_linearI')
        apply (auto simp add: vec_lambda_unique[symmetric])
        apply (rule vec_tendstoI)
        by (auto simp add: state2vec_def)
      done
  qed
  show ?thesis
    apply (rule Valid_ode_unique_solution_st[OF _ 1 _ _ _ 2])
    by auto
qed

text \<open>
  Trace invariant for plant. Here
   - v0, a0, t0 is the starting velocity, acceleration, and time.
   - as is the list of acceleration commands received from c2p.
\<close>
fun plant_inv :: "real \<times> real \<times> real \<Rightarrow> real list \<Rightarrow> tassn" where
  "plant_inv (v0, a0, t0) [] = emp\<^sub>t"
| "plant_inv (v0, a0, t0) (a # as) =
     Wait\<^sub>t 1 (\<lambda>t. State ((\<lambda>_. 0)(V := v0 + a0 * t, A := a0, T := t))) ({}, {}) @\<^sub>t
     Out\<^sub>t (State ((\<lambda>_. 0)(V := v0 + a0, A := a0, T := 1))) ''p2c'' (v0 + a0) @\<^sub>t
     In\<^sub>t (State ((\<lambda>_. 0)(V := v0 + a0, A := a0, T := 1))) ''c2p'' a @\<^sub>t
     plant_inv (v0 + a0, a, 1) as"

text \<open>
  Final state given the initial v0, a0, t0 and acceleration commands as.
\<close>
fun plant_end_state :: "real \<times> real \<times> real \<Rightarrow> real list \<Rightarrow> state" where
  "plant_end_state (v0, a0, t0) [] = ((\<lambda>_. 0)(V := v0, A := a0, T := t0))"
| "plant_end_state (v0, a0, t0) (a # as) =
   plant_end_state (v0 + a0, a, 1) as"

lemma plant_end_state_rw:
  "(plant_end_state (v0, a0, t0) as)(T := 0) =
   (\<lambda>_. 0)(V := plant_end_state (v0, a0, t0) as V,
           A := plant_end_state (v0, a0, t0) as A,
           T := 0)"
  apply (induct as arbitrary: v0 a0 t0) by auto

lemma plant_end_state_snoc:
  "plant_end_state (v0, a0, t0) (as @ [a]) =
   (\<lambda>_. 0)(V := plant_end_state (v0, a0, t0) as V + plant_end_state (v0, a0, t0) as A, T := 1, A := a)"
  apply (induct as arbitrary: v0 a0 t0) by auto

lemma plant_inv_snoc:
  "plant_inv (v0, a0, t0) (xs @ [a]) =
  (plant_inv (v0, a0, t0) xs @\<^sub>t
   Wait\<^sub>t 1 (\<lambda>t. State ((\<lambda>_. 0)(V := plant_end_state (v0, a0, t0) xs V + plant_end_state (v0, a0, t0) xs A * t,
                               A := plant_end_state (v0, a0, t0) xs A, T := t))) ({}, {})) @\<^sub>t
   Out\<^sub>t (State ((\<lambda>_. 0)(V := plant_end_state (v0, a0, t0) xs V + plant_end_state (v0, a0, t0) xs A,
                        A := plant_end_state (v0, a0, t0) xs A, T := 1)))
       ''p2c'' (plant_end_state (v0, a0, t0) xs V + plant_end_state (v0, a0, t0) xs A) @\<^sub>t
   In\<^sub>t (State ((\<lambda>_. 0) (V := plant_end_state (v0, a0, t0) xs V + plant_end_state (v0, a0, t0) xs A,
                        A := plant_end_state (v0, a0, t0) xs A, T := 1)))
       ''c2p'' a"
proof (induct xs arbitrary: v0 a0 t0)
  case Nil
  have a: "(\<lambda>_. 0)(V := v0 + a0 * t, A := a0, T := t) =
        (\<lambda> a. if a = T then t else if a = A then a0 else if a = V then v0 + a0 * t else 0)" for t
    apply (rule ext) by auto
  have b: "(\<lambda>_. 0)(V := v0 + a0, A := a0, T := 1) =
        (\<lambda> a. if a = T then 1 else if a = A then a0 else if a = V then v0 + a0 else 0)"
    apply (rule ext) by auto
  show ?case
    by (auto simp add: a b)
next
  case (Cons a as)
  show ?case
    by (auto simp add: Cons join_assoc)
qed

lemma plant_prop:
  "\<Turnstile> {\<lambda>s tr. s = (\<lambda>_. 0)(V := v0, A := a0, T := t0) \<and> emp\<^sub>t tr}
        plant
      {\<lambda>s tr. \<exists>as. s = plant_end_state (v0, a0, t0) as \<and>
                   plant_inv (v0, a0, t0) as tr}"
  unfolding plant_def
  apply (rule Valid_weaken_pre)
   prefer 2 apply (rule Valid_rep)
  apply (rule Valid_ex_pre)
  subgoal for xs
    apply (rule Valid_seq)
    apply (rule Valid_assign_sp_st)
    apply (rule Valid_seq)
    unfolding plant_end_state_rw
     apply (rule plant_ODE)
    apply (rule Valid_seq)
     apply (rule Valid_send_sp_st)
    apply (rule Valid_strengthen_post)
     prefer 2 apply (rule Valid_receive_sp_st)
    apply (auto simp add: entails_def)
    subgoal for tr a
      apply (rule exI[where x="xs @ [a]"])
      by (auto simp add: plant_end_state_snoc plant_inv_snoc join_assoc)
    done
  apply (auto simp add: entails_def)
  apply (rule exI[where x="[]"])
  by auto

text \<open>
  Trace invariant for control. Here
   - v0 is the initial value of velocity
   - vs is the list of velocity values received from p2c.
\<close>
fun control_inv :: "real \<Rightarrow> real list \<Rightarrow> tassn" where
  "control_inv v0 [] = emp\<^sub>t"
| "control_inv v0 (v # vs) =
   In\<^sub>t (State ((\<lambda>_. 0)(V := v0))) ''p2c'' v @\<^sub>t
   Out\<^sub>t (State ((\<lambda>_. 0)(V := v))) ''c2p'' (if v < 10 then 1 else -1) @\<^sub>t
   control_inv v vs"

fun control_end_state :: "real \<Rightarrow> real list \<Rightarrow> state" where
  "control_end_state v0 [] = ((\<lambda>_. 0)(V := v0))"
| "control_end_state v0 (v # vs) = control_end_state v vs"

lemma control_end_state_snoc:
  "control_end_state v0 (vs @ [v]) = (control_end_state v0 vs)(V := v)"
  apply (induct vs arbitrary: v0) by auto

lemma control_inv_snoc:
  "control_inv v0 (vs @ [v]) =
   control_inv v0 vs @\<^sub>t In\<^sub>t (State (control_end_state v0 vs)) ''p2c'' v @\<^sub>t
                        Out\<^sub>t (State ((control_end_state v0 vs)(V := v))) ''c2p''
   (if v < 10 then 1 else -1)"
proof (induct vs arbitrary: v0)
  case Nil
  have a: "(\<lambda>_. 0)(V := v0) = (\<lambda>a. if a = V then v0 else 0)"
    apply (rule ext) by auto
  have aa: "(\<lambda>_. 0)(V := v) = (\<lambda>a. if a = V then v else if a = V then v0 else 0)"
    apply (rule ext) by auto
  show ?case
    by (auto simp add: a aa)
next
  case (Cons a vs v0)
  then show ?case
    by (auto simp add: join_assoc)
qed

lemma control_prop:
  "\<Turnstile> {\<lambda>s tr. s = (\<lambda>_. 0)(V := v0) \<and> emp\<^sub>t tr}
        control
      {\<lambda>s tr. \<exists>vs. s = control_end_state v0 vs \<and>
                   control_inv v0 vs tr}"
  unfolding control_def
  apply (rule Valid_weaken_pre)
   prefer 2 apply (rule Valid_rep)
   apply (rule Valid_ex_pre)
  subgoal for vs
    apply (rule Valid_seq)
     apply (rule Valid_receive_sp_st)
    apply (rule Valid_ex_pre)
    subgoal for v
      apply (rule Valid_strengthen_post)
       prefer 2 apply (rule Valid_cond_sp)
        apply (rule Valid_send_sp)
      apply (rule Valid_send_sp)
      apply (auto simp add: entails_def)
      apply (rule exI[where x="vs @ [v]"])
       apply (auto simp add: control_end_state_snoc control_inv_snoc conj_assn_def pure_assn_def join_assoc)
      apply (rule exI[where x="vs @ [v]"])
      by (auto simp add: control_end_state_snoc control_inv_snoc join_assoc)
    done
  apply (auto simp add: entails_def)
  apply (rule exI[where x="[]"])
  by auto

text \<open>
  Loop invariant:
   - velocity always stays in the interval [9, 11].
   - acceleration is 1 if v < 10, and -1 if otherwise.
\<close>
fun loop_inv :: "real \<times> real \<Rightarrow> bool" where
  "loop_inv (v, a) \<longleftrightarrow> (v \<ge> 9 \<and> v \<le> 11 \<and> a = (if v < 10 then 1 else -1))"

declare loop_inv.simps [simp del]

text \<open>
  Trace invariant for the whole system. Note it includes the
  invariant on velocity and acceleration.
\<close>
fun system_inv :: "nat \<Rightarrow> tassn" where
  "system_inv 0 = emp\<^sub>t"
| "system_inv (Suc n) = (\<exists>\<^sub>tv0 a0 v0'. \<up>(loop_inv (v0, a0)) \<and>\<^sub>t
     Wait\<^sub>t 1 (\<lambda>t. ParState (State ((\<lambda>_. 0)(V := v0 + a0 * t, A := a0, T := t))) (State ((\<lambda>_. 0)(V := v0')))) ({}, {''p2c''}) @\<^sub>t
     IO\<^sub>t ''p2c'' (v0 + a0) @\<^sub>t
     IO\<^sub>t ''c2p'' (if v0 + a0 < 10 then 1 else -1) @\<^sub>t
     system_inv n)"

lemma combine:
  "loop_inv (v0, a0) \<Longrightarrow>
   combine_assn {''p2c'', ''c2p''}
    (plant_inv (v0, a0, t0) as) (control_inv v0' vs) \<Longrightarrow>\<^sub>t
     system_inv (length as)"
proof (induct as arbitrary: v0 a0 t0 v0' vs)
  case Nil
  note Nil1 = Nil
  then show ?case
  proof (cases vs)
    case Nil
    then show ?thesis
      using Nil1 by (auto simp add: conj_assn_def pure_assn_def)
  next
    case (Cons a list)
    then show ?thesis
      by (auto simp add: combine_assn_emp_in)
  qed
next
  case (Cons a as)
  note Cons1 = Cons
  then show ?case
  proof (cases vs)
    case Nil
    then show ?thesis
      apply auto
      apply (rule entails_tassn_trans)
      apply (rule combine_assn_wait_emp)
      by (rule false_assn_entails)
  next
    case (Cons v vs)
    show ?thesis
      apply (auto simp add: Cons split del: if_split)
      apply (rule entails_tassn_trans)
      apply (rule combine_assn_wait_in)
         apply (auto split del: if_split)
      apply (rule entails_tassn_exI[where x=v0])
      apply (rule entails_tassn_exI[where x=a0])
      apply (rule entails_tassn_exI[where x=v0'])
      apply (rule entails_tassn_conj)
      subgoal
        by (auto simp add: pure_assn_def Cons1(2) entails_tassn_def)
      apply (rule entails_tassn_cancel_left)
      apply (rule entails_tassn_trans)
       apply (rule combine_assn_out_in)
       apply (auto split del: if_split)
      apply (rule entails_tassn_cancel_left)
      apply (rule entails_tassn_trans)
       apply (rule combine_assn_in_out)
       apply (auto split del: if_split)
      apply (rule entails_tassn_cancel_left)
      apply (rule Cons1(1))
      using Cons1(2) by (auto simp add: loop_inv.simps)
  qed
qed

theorem system_prop:
  assumes "loop_inv (v0, a0)"
  shows "\<Turnstile>\<^sub>p
    {pair_assn (\<lambda>s. s = ((\<lambda>_. 0)(V := v0, A := a0, T := t0)))
               (\<lambda>s. s = ((\<lambda>_. 0)(V := v0')))}
      system
    {\<exists>\<^sub>gn. trace_gassn (system_inv n)}"
  unfolding system_def
  apply (rule ParValid_conseq')
  apply (rule ParValid_Parallel')
  apply (rule plant_prop)
  apply (rule control_prop)
   apply (auto simp add: sing_gassn_split sing_gassn_ex)
  apply (rule sync_gassn_ex_pre_left)
  apply (rule sync_gassn_ex_pre_right)
  subgoal for as vs
    unfolding sync_gassn_state_left sync_gassn_state_right
    apply (rule entails_ex_gassn)
    apply (rule exI[where x="length as"])
    apply (rule and_entails_gassn2[OF sync_gassn_traces])
    apply (rule and_entails_gassn2[OF entails_trace_gassn])
    apply (rule combine[OF assms])
    by (auto simp add: entails_tassn_def entails_gassn_def and_gassn_def)
  done

end


(*  File:       Copeland_Module.thy
    Copyright   2021  Karlsruhe Institute of Technology (KIT)
*)
\<^marker>\<open>creator "Stephan Bohr, Karlsruhe Institute of Technology (KIT)"\<close>
\<^marker>\<open>contributor "Michael Kirsten, Karlsruhe Institute of Technology (KIT)"\<close>

section \<open>Copeland Module\<close>

theory Copeland_Module
  imports "Component_Types/Elimination_Module"
begin

text \<open>
  This is the Copeland module used by the Copeland voting rule. The Copeland
  rule elects the alternatives with the highest difference between the amount
  of simple-majority wins and the amount of simple-majority losses. The module
  implemented herein only rejects the alternatives not elected by the voting
  rule, and defers the alternatives that would be elected by the full voting
  rule.
\<close>

subsection \<open>Definition\<close>

fun copeland_score :: "'a Evaluation_Function" where
  "copeland_score x A p =
    card {y \<in> A . wins x p y} - card {y \<in> A . wins y p x}"

fun copeland :: "'a Electoral_Module" where
  "copeland A p = max_eliminator copeland_score A p"

subsection \<open>Lemmata\<close>

text \<open>
  For a Condorcet winner w, we have: "card {y in A . wins x p y} = |A| - 1".
\<close>

lemma cond_winner_imp_win_count:
  assumes "condorcet_winner A p w"
  shows "card {y \<in> A . wins w p y} = card A - 1"
proof -
  from assms
  have 0: "\<forall> x \<in> A - {w} . wins w p x"
    by simp
  have 1: "\<forall> M . {x \<in> M . True} = M"
    by blast
  from 0 1
  have "{x \<in> A - {w} . wins w p x} = A - {w}"
    by blast
  hence 10: "card {x \<in> A - {w} . wins w p x} = card (A - {w})"
    by simp
  from assms
  have 11: "w \<in> A"
    by simp
  hence "card (A - {w}) = card A - 1"
    using card_Diff_singleton assms
    by metis
  hence amount1:
    "card {x \<in> A - {w} . wins w p x} = card (A) - 1"
    using "10"
    by linarith
  have 2: "\<forall> x \<in> {w} . \<not> wins x p x"
    by (simp add: wins_irreflex)
  have 3: "\<forall> M . {x \<in> M . False} = {}"
    by blast
  from 2 3
  have "{x \<in> {w} . wins w p x} = {}"
    by blast
  hence amount2: "card {x \<in> {w} . wins w p x} = 0"
    by simp
  have disjunct:
    "{x \<in> A - {w} . wins w p x} \<inter> {x \<in> {w} . wins w p x} = {}"
    by blast
  have union:
    "{x \<in> A - {w} . wins w p x} \<union> {x \<in> {w} . wins w p x} =
        {x \<in> A . wins w p x}"
    using 2
    by blast
  have finiteness1: "finite {x \<in> A - {w} . wins w p x}"
    using assms
    by simp
  have finiteness2: "finite {x \<in> {w} . wins w p x}"
    by simp
  from finiteness1 finiteness2 disjunct card_Un_disjoint
  have
    "card ({x \<in> A - {w} . wins w p x} \<union> {x \<in> {w} . wins w p x}) =
        card {x \<in> A - {w} . wins w p x} + card {x \<in> {w} . wins w p x}"
    by blast
  with union
  have "card {x \<in> A . wins w p x} =
          card {x \<in> A - {w} . wins w p x} + card {x \<in> {w} . wins w p x}"
    by simp
  with amount1 amount2
  show ?thesis
    by linarith
qed

text \<open>
  For a Condorcet winner w, we have: "card {y in A . wins y p x} = 0".
\<close>

lemma cond_winner_imp_loss_count:
  assumes winner: "condorcet_winner A p w"
  shows "card {y \<in> A . wins y p w} = 0"
  using Collect_empty_eq card_eq_0_iff insert_Diff insert_iff
        wins_antisym winner
  unfolding condorcet_winner.simps
  by (metis (no_types, lifting))

text \<open>
  Copeland score of a Condorcet winner.
\<close>

lemma cond_winner_imp_copeland_score:
  assumes winner: "condorcet_winner A p w"
  shows "copeland_score w A p = card A - 1"
proof (unfold copeland_score.simps)
  have card_A_sub_one: "card {a \<in> A. wins w p a} = card A - 1"
    using cond_winner_imp_win_count winner
    by simp
  have card_zero: "card {a \<in> A. wins a p w} = 0"
    using cond_winner_imp_loss_count winner
    by (metis (no_types))
  have "card A - 1 - 0 = card A - 1"
    by simp
  thus
    "card {y \<in> A. wins w p y} - card {y \<in> A. wins y p w} =
      card A - 1"
    using card_zero card_A_sub_one
    by simp
qed

text \<open>
  For a non-Condorcet winner l, we have:
  "card {y in A . wins x p y} <= |A| - 1 - 1".
\<close>

lemma non_cond_winner_imp_win_count:
  assumes
    winner: "condorcet_winner A p w" and
    loser: "l \<noteq> w" and
    l_in_A: "l \<in> A"
  shows "card {y \<in> A . wins l p y} \<le> card A - 2"
proof -
  from winner loser l_in_A
  have "wins w p l"
    by simp
  hence 0: "\<not> wins l p w"
    using wins_antisym
    by simp
  have 1: "\<not> wins l p l"
    using wins_irreflex
    by simp
  from 0 1 have 2:
    "{y \<in> A . wins l p y} =
        {y \<in> A - {l, w} . wins l p y}"
    by blast
  have 3: "\<forall> M f . finite M \<longrightarrow> card {x \<in> M . f x} \<le> card M"
    by (simp add: card_mono)
  have 4: "finite (A - {l, w})"
    using finite_Diff winner
    by simp
  from 3 4
  have 5:
    "card {y \<in> A - {l, w} . wins l p y} \<le>
      card (A - {l, w})"
    by (metis (full_types))
  have "w \<in> A"
    using winner
    by simp
  with l_in_A
  have "card (A - {l, w}) = card A - card {l, w}"
    by (simp add: card_Diff_subset)
  hence "card (A - {l, w}) = card A - 2"
    using loser
    by simp
  with 5 2
  show ?thesis
    by simp
qed

subsection \<open>Property\<close>

text \<open>
  The Copeland score is Condorcet rating.
\<close>

theorem copeland_score_is_cr: "condorcet_rating copeland_score"
proof (unfold condorcet_rating_def, unfold copeland_score.simps, safe)
  fix
    A :: "'a set" and
    p :: "'a Profile" and
    w :: "'a" and
    l :: "'a"
  assume
    winner: "condorcet_winner A p w" and
    l_in_A: "l \<in> A" and
    l_neq_w: "l \<noteq> w"
  from winner
  have 0:
    "card {y \<in> A. wins w p y} - card {y \<in> A. wins y p w} = card A - 1"
    using cond_winner_imp_copeland_score
    by fastforce
  from winner l_neq_w l_in_A
  have 1:
    "card {y \<in> A. wins l p y} - card {y \<in> A. wins y p l} \<le> card A - 2"
    using non_cond_winner_imp_win_count
    by fastforce
  have 2: "card A - 2 < card A - 1"
    using card_0_eq card_Diff_singleton diff_less_mono2
          empty_iff finite_Diff insertE insert_Diff
          l_in_A l_neq_w neq0_conv one_less_numeral_iff
          semiring_norm(76) winner zero_less_diff
    unfolding condorcet_winner.simps
    by metis
  hence
    "card {y \<in> A. wins l p y} - card {y \<in> A. wins y p l} < card A - 1"
    using 1 le_less_trans
    by blast
  thus
    "card {y \<in> A. wins l p y} - card {y \<in> A. wins y p l} <
      card {y \<in> A. wins w p y} - card {y \<in> A. wins y p w}"
    using 0
    by linarith
qed

theorem copeland_is_dcc: "defer_condorcet_consistency copeland"
proof (unfold defer_condorcet_consistency_def electoral_module_def, safe)
  fix
    A :: "'a set" and
    p :: "'a Profile"
  assume
    finA: "finite A" and
    profA: "profile A p"
  have "well_formed A (max_eliminator copeland_score A p)"
    using finA max_elim_sound profA
    unfolding electoral_module_def
    by metis
  thus "well_formed A (copeland A p)"
    by simp
next
  fix
    A :: "'a set" and
    p :: "'a Profile" and
    w :: "'a"
  assume
    cwin_w: "condorcet_winner A p w" and
    finA: "finite A"
  have max_cplscore_dcc:
    "defer_condorcet_consistency (max_eliminator copeland_score)"
    using cr_eval_imp_dcc_max_elim
    by (simp add: copeland_score_is_cr)
  have
    "\<forall> A p. (copeland A p = max_eliminator copeland_score A p)"
    by simp
  thus
    "copeland A p =
      ({},
       A - defer copeland A p,
       {d \<in> A. condorcet_winner A p d})"
    using Collect_cong cwin_w finA max_cplscore_dcc
    unfolding defer_condorcet_consistency_def
    by (metis (no_types, lifting))
qed

end


(*  Title:      HOL/Analysis/Embed_Measure.thy
    Author:     Manuel Eberl, TU München

    Defines measure embeddings with injective functions, i.e. lifting a measure on some values
    to a measure on "tagged" values (e.g. embed_measure M Inl lifts a measure on values 'a to a
    measure on the left part of the sum type 'a + 'b)
*)

section \<open>Embed Measure Spaces with a Function\<close>

theory Embed_Measure
imports Binary_Product_Measure
begin

definition embed_measure :: "'a measure \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> 'b measure" where
  "embed_measure M f = measure_of (f ` space M) {f ` A |A. A \<in> sets M}
                           (\<lambda>A. emeasure M (f -` A \<inter> space M))"

lemma space_embed_measure: "space (embed_measure M f) = f ` space M"
  unfolding embed_measure_def
  by (subst space_measure_of) (auto dest: sets.sets_into_space)

lemma sets_embed_measure':
  assumes inj: "inj_on f (space M)"
  shows "sets (embed_measure M f) = {f ` A |A. A \<in> sets M}"
  unfolding embed_measure_def
proof (intro sigma_algebra.sets_measure_of_eq sigma_algebra_iff2[THEN iffD2] conjI allI ballI impI)
  fix s assume "s \<in> {f ` A |A. A \<in> sets M}"
  then obtain s' where s'_props: "s = f ` s'" "s' \<in> sets M" by auto
  hence "f ` space M - s = f ` (space M - s')" using inj
    by (auto dest: inj_onD sets.sets_into_space)
  also have "... \<in> {f ` A |A. A \<in> sets M}" using s'_props by auto
  finally show "f ` space M - s \<in> {f ` A |A. A \<in> sets M}" .
next
  fix A :: "nat \<Rightarrow> _" assume "range A \<subseteq> {f ` A |A. A \<in> sets M}"
  then obtain A' where A': "\<And>i. A i = f ` A' i" "\<And>i. A' i \<in> sets M"
    by (auto simp: subset_eq choice_iff)
  then have "(\<Union>x. f ` A' x) = f ` (\<Union>x. A' x)" by blast
  with A' show "(\<Union>i. A i) \<in> {f ` A |A. A \<in> sets M}"
    by simp blast
qed (auto dest: sets.sets_into_space)

lemma the_inv_into_vimage:
  "inj_on f X \<Longrightarrow> A \<subseteq> X \<Longrightarrow> the_inv_into X f -` A \<inter> (f`X) = f ` A"
  by (auto simp: the_inv_into_f_f)

lemma sets_embed_eq_vimage_algebra:
  assumes "inj_on f (space M)"
  shows "sets (embed_measure M f) = sets (vimage_algebra (f`space M) (the_inv_into (space M) f) M)"
  by (auto simp: sets_embed_measure'[OF assms] Pi_iff the_inv_into_f_f assms sets_vimage_algebra2 Setcompr_eq_image
           dest: sets.sets_into_space
           intro!: image_cong the_inv_into_vimage[symmetric])

lemma sets_embed_measure:
  assumes inj: "inj f"
  shows "sets (embed_measure M f) = {f ` A |A. A \<in> sets M}"
  using assms by (subst sets_embed_measure') (auto intro!: inj_onI dest: injD)

lemma in_sets_embed_measure: "A \<in> sets M \<Longrightarrow> f ` A \<in> sets (embed_measure M f)"
  unfolding embed_measure_def
  by (intro in_measure_of) (auto dest: sets.sets_into_space)

lemma measurable_embed_measure1:
  assumes g: "(\<lambda>x. g (f x)) \<in> measurable M N"
  shows "g \<in> measurable (embed_measure M f) N"
  unfolding measurable_def
proof safe
  fix A assume "A \<in> sets N"
  with g have "(\<lambda>x. g (f x)) -` A \<inter> space M \<in> sets M"
    by (rule measurable_sets)
  then have "f ` ((\<lambda>x. g (f x)) -` A \<inter> space M) \<in> sets (embed_measure M f)"
    by (rule in_sets_embed_measure)
  also have "f ` ((\<lambda>x. g (f x)) -` A \<inter> space M) = g -` A \<inter> space (embed_measure M f)"
    by (auto simp: space_embed_measure)
  finally show "g -` A \<inter> space (embed_measure M f) \<in> sets (embed_measure M f)" .
qed (insert measurable_space[OF assms], auto simp: space_embed_measure)

lemma measurable_embed_measure2':
  assumes "inj_on f (space M)"
  shows "f \<in> measurable M (embed_measure M f)"
proof-
  {
    fix A assume A: "A \<in> sets M"
    also from A have "A = A \<inter> space M" by auto
    also have "... = f -` f ` A \<inter> space M" using A assms
      by (auto dest: inj_onD sets.sets_into_space)
    finally have "f -` f ` A \<inter> space M \<in> sets M" .
  }
  thus ?thesis using assms unfolding embed_measure_def
    by (intro measurable_measure_of) (auto dest: sets.sets_into_space)
qed

lemma measurable_embed_measure2:
  assumes [simp]: "inj f" shows "f \<in> measurable M (embed_measure M f)"
  by (auto simp: inj_vimage_image_eq embed_measure_def
           intro!: measurable_measure_of dest: sets.sets_into_space)

lemma embed_measure_eq_distr':
  assumes "inj_on f (space M)"
  shows "embed_measure M f = distr M (embed_measure M f) f"
proof-
  have "distr M (embed_measure M f) f =
            measure_of (f ` space M) {f ` A |A. A \<in> sets M}
                       (\<lambda>A. emeasure M (f -` A \<inter> space M))" unfolding distr_def
      by (simp add: space_embed_measure sets_embed_measure'[OF assms])
  also have "... = embed_measure M f" unfolding embed_measure_def ..
  finally show ?thesis ..
qed

lemma embed_measure_eq_distr:
    "inj f \<Longrightarrow> embed_measure M f = distr M (embed_measure M f) f"
  by (rule embed_measure_eq_distr') (auto intro!: inj_onI dest: injD)

lemma nn_integral_embed_measure':
  "inj_on f (space M) \<Longrightarrow> g \<in> borel_measurable (embed_measure M f) \<Longrightarrow>
  nn_integral (embed_measure M f) g = nn_integral M (\<lambda>x. g (f x))"
  apply (subst embed_measure_eq_distr', simp)
  apply (subst nn_integral_distr)
  apply (simp_all add: measurable_embed_measure2')
  done

lemma nn_integral_embed_measure:
  "inj f \<Longrightarrow> g \<in> borel_measurable (embed_measure M f) \<Longrightarrow>
  nn_integral (embed_measure M f) g = nn_integral M (\<lambda>x. g (f x))"
  by(erule nn_integral_embed_measure'[OF subset_inj_on]) simp

lemma emeasure_embed_measure':
    assumes "inj_on f (space M)" "A \<in> sets (embed_measure M f)"
    shows "emeasure (embed_measure M f) A = emeasure M (f -` A \<inter> space M)"
  by (subst embed_measure_eq_distr'[OF assms(1)])
     (simp add: emeasure_distr[OF measurable_embed_measure2'[OF assms(1)] assms(2)])

lemma emeasure_embed_measure:
    assumes "inj f" "A \<in> sets (embed_measure M f)"
    shows "emeasure (embed_measure M f) A = emeasure M (f -` A \<inter> space M)"
 using assms by (intro emeasure_embed_measure') (auto intro!: inj_onI dest: injD)

lemma embed_measure_comp:
  assumes [simp]: "inj f" "inj g"
  shows "embed_measure (embed_measure M f) g = embed_measure M (g \<circ> f)"
proof-
  have [simp]: "inj (\<lambda>x. g (f x))" by (subst o_def[symmetric]) (auto intro: inj_comp)
  note measurable_embed_measure2[measurable]
  have "embed_measure (embed_measure M f) g =
            distr M (embed_measure (embed_measure M f) g) (g \<circ> f)"
      by (subst (1 2) embed_measure_eq_distr)
         (simp_all add: distr_distr sets_embed_measure cong: distr_cong)
  also have "... = embed_measure M (g \<circ> f)"
      by (subst (3) embed_measure_eq_distr, simp add: o_def, rule distr_cong)
         (auto simp: sets_embed_measure o_def image_image[symmetric]
               intro: inj_comp cong: distr_cong)
  finally show ?thesis .
qed

lemma sigma_finite_embed_measure:
  assumes "sigma_finite_measure M" and inj: "inj f"
  shows "sigma_finite_measure (embed_measure M f)"
proof -
  from assms(1) interpret sigma_finite_measure M .
  from sigma_finite_countable obtain A where
      A_props: "countable A" "A \<subseteq> sets M" "\<Union>A = space M" "\<And>X. X\<in>A \<Longrightarrow> emeasure M X \<noteq> \<infinity>" by blast
  from A_props have "countable (op ` f`A)" by auto
  moreover
  from inj and A_props have "op ` f`A \<subseteq> sets (embed_measure M f)"
    by (auto simp: sets_embed_measure)
  moreover
  from A_props and inj have "\<Union>(op ` f`A) = space (embed_measure M f)"
    by (auto simp: space_embed_measure intro!: imageI)
  moreover
  from A_props and inj have "\<forall>a\<in>op ` f ` A. emeasure (embed_measure M f) a \<noteq> \<infinity>"
    by (intro ballI, subst emeasure_embed_measure)
       (auto simp: inj_vimage_image_eq intro: in_sets_embed_measure)
  ultimately show ?thesis by - (standard, blast)
qed

lemma embed_measure_count_space':
    "inj_on f A \<Longrightarrow> embed_measure (count_space A) f = count_space (f`A)"
  apply (subst distr_bij_count_space[of f A "f`A", symmetric])
  apply (simp add: inj_on_def bij_betw_def)
  apply (subst embed_measure_eq_distr')
  apply simp
  apply(auto 4 3 intro!: measure_eqI imageI simp add: sets_embed_measure' subset_image_iff)
  apply (subst (1 2) emeasure_distr)
  apply (auto simp: space_embed_measure sets_embed_measure')
  done

lemma embed_measure_count_space:
    "inj f \<Longrightarrow> embed_measure (count_space A) f = count_space (f`A)"
  by(rule embed_measure_count_space')(erule subset_inj_on, simp)

lemma sets_embed_measure_alt:
    "inj f \<Longrightarrow> sets (embed_measure M f) = (op`f) ` sets M"
  by (auto simp: sets_embed_measure)

lemma emeasure_embed_measure_image':
  assumes "inj_on f (space M)" "X \<in> sets M"
  shows "emeasure (embed_measure M f) (f`X) = emeasure M X"
proof-
  from assms have "emeasure (embed_measure M f) (f`X) = emeasure M (f -` f ` X \<inter> space M)"
    by (subst emeasure_embed_measure') (auto simp: sets_embed_measure')
  also from assms have "f -` f ` X \<inter> space M = X" by (auto dest: inj_onD sets.sets_into_space)
  finally show ?thesis .
qed

lemma emeasure_embed_measure_image:
    "inj f \<Longrightarrow> X \<in> sets M \<Longrightarrow> emeasure (embed_measure M f) (f`X) = emeasure M X"
  by (simp_all add: emeasure_embed_measure in_sets_embed_measure inj_vimage_image_eq)

lemma embed_measure_eq_iff:
  assumes "inj f"
  shows "embed_measure A f = embed_measure B f \<longleftrightarrow> A = B" (is "?M = ?N \<longleftrightarrow> _")
proof
  from assms have I: "inj (op` f)" by (auto intro: injI dest: injD)
  assume asm: "?M = ?N"
  hence "sets (embed_measure A f) = sets (embed_measure B f)" by simp
  with assms have "sets A = sets B" by (simp only: I inj_image_eq_iff sets_embed_measure_alt)
  moreover {
    fix X assume "X \<in> sets A"
    from asm have "emeasure ?M (f`X) = emeasure ?N (f`X)" by simp
    with \<open>X \<in> sets A\<close> and \<open>sets A = sets B\<close> and assms
        have "emeasure A X = emeasure B X" by (simp add: emeasure_embed_measure_image)
  }
  ultimately show "A = B" by (rule measure_eqI)
qed simp

lemma the_inv_into_in_Pi: "inj_on f A \<Longrightarrow> the_inv_into A f \<in> f ` A \<rightarrow> A"
  by (auto simp: the_inv_into_f_f)

lemma map_prod_image: "map_prod f g ` (A \<times> B) = (f`A) \<times> (g`B)"
  using map_prod_surj_on[OF refl refl] .

lemma map_prod_vimage: "map_prod f g -` (A \<times> B) = (f-`A) \<times> (g-`B)"
  by auto

lemma embed_measure_prod:
  assumes f: "inj f" and g: "inj g" and [simp]: "sigma_finite_measure M" "sigma_finite_measure N"
  shows "embed_measure M f \<Otimes>\<^sub>M embed_measure N g = embed_measure (M \<Otimes>\<^sub>M N) (\<lambda>(x, y). (f x, g y))"
    (is "?L = _")
  unfolding map_prod_def[symmetric]
proof (rule pair_measure_eqI)
  have fg[simp]: "\<And>A. inj_on (map_prod f g) A" "\<And>A. inj_on f A" "\<And>A. inj_on g A"
    using f g by (auto simp: inj_on_def)

  note complete_lattice_class.Sup_insert[simp del] ccSup_insert[simp del] SUP_insert[simp del]
     ccSUP_insert[simp del]
  show sets: "sets ?L = sets (embed_measure (M \<Otimes>\<^sub>M N) (map_prod f g))"
    unfolding map_prod_def[symmetric]
    apply (simp add: sets_pair_eq_sets_fst_snd sets_embed_eq_vimage_algebra
      cong: vimage_algebra_cong)
    apply (subst sets_vimage_Sup_eq[where Y="space (M \<Otimes>\<^sub>M N)"])
    apply (simp_all add: space_pair_measure[symmetric])
    apply (auto simp add: the_inv_into_f_f
                simp del: map_prod_simp
                del: prod_fun_imageE) []
    apply auto []
    apply (subst image_insert)
    apply simp
    apply (subst (1 2 3 4 ) vimage_algebra_vimage_algebra_eq)
    apply (simp_all add: the_inv_into_in_Pi Pi_iff[of snd] Pi_iff[of fst] space_pair_measure)
    apply (simp_all add: Pi_iff[of snd] Pi_iff[of fst] the_inv_into_in_Pi vimage_algebra_vimage_algebra_eq
       space_pair_measure[symmetric] map_prod_image[symmetric])
    apply (intro arg_cong[where f=sets] arg_cong[where f=Sup] arg_cong2[where f=insert] vimage_algebra_cong)
    apply (auto simp: map_prod_image the_inv_into_f_f
                simp del: map_prod_simp del: prod_fun_imageE)
    apply (simp_all add: the_inv_into_f_f space_pair_measure)
    done

  note measurable_embed_measure2[measurable]
  fix A B assume AB: "A \<in> sets (embed_measure M f)" "B \<in> sets (embed_measure N g)"
  moreover have "f -` A \<times> g -` B \<inter> space (M \<Otimes>\<^sub>M N) = (f -` A \<inter> space M) \<times> (g -` B \<inter> space N)"
    by (auto simp: space_pair_measure)
  ultimately show "emeasure (embed_measure M f) A * emeasure (embed_measure N g) B =
                     emeasure (embed_measure (M \<Otimes>\<^sub>M N) (map_prod f g)) (A \<times> B)"
    by (simp add: map_prod_vimage sets[symmetric] emeasure_embed_measure
                  sigma_finite_measure.emeasure_pair_measure_Times)
qed (insert assms, simp_all add: sigma_finite_embed_measure)

lemma mono_embed_measure:
  "space M = space M' \<Longrightarrow> sets M \<subseteq> sets M' \<Longrightarrow> sets (embed_measure M f) \<subseteq> sets (embed_measure M' f)"
  unfolding embed_measure_def
  apply (subst (1 2) sets_measure_of)
  apply (blast dest: sets.sets_into_space)
  apply (blast dest: sets.sets_into_space)
  apply simp
  apply (intro sigma_sets_mono')
  apply safe
  apply (simp add: subset_eq)
  apply metis
  done

lemma density_embed_measure:
  assumes inj: "inj f" and Mg[measurable]: "g \<in> borel_measurable (embed_measure M f)"
  shows "density (embed_measure M f) g = embed_measure (density M (g \<circ> f)) f" (is "?M1 = ?M2")
proof (rule measure_eqI)
  fix X assume X: "X \<in> sets ?M1"
  from inj have Mf[measurable]: "f \<in> measurable M (embed_measure M f)"
    by (rule measurable_embed_measure2)
  from Mg and X have "emeasure ?M1 X = \<integral>\<^sup>+ x. g x * indicator X x \<partial>embed_measure M f"
    by (subst emeasure_density) simp_all
  also from X have "... = \<integral>\<^sup>+ x. g (f x) * indicator X (f x) \<partial>M"
    by (subst embed_measure_eq_distr[OF inj], subst nn_integral_distr) auto
  also have "... = \<integral>\<^sup>+ x. g (f x) * indicator (f -` X \<inter> space M) x \<partial>M"
    by (intro nn_integral_cong) (auto split: split_indicator)
  also from X have "... = emeasure (density M (g \<circ> f)) (f -` X \<inter> space M)"
    by (subst emeasure_density) (simp_all add: measurable_comp[OF Mf Mg] measurable_sets[OF Mf])
  also from X and inj have "... = emeasure ?M2 X"
    by (subst emeasure_embed_measure) (simp_all add: sets_embed_measure)
  finally show "emeasure ?M1 X = emeasure ?M2 X" .
qed (simp_all add: sets_embed_measure inj)

lemma density_embed_measure':
  assumes inj: "inj f" and inv: "\<And>x. f' (f x) = x" and Mg[measurable]: "g \<in> borel_measurable M"
  shows "density (embed_measure M f) (g \<circ> f') = embed_measure (density M g) f"
proof-
  have "density (embed_measure M f) (g \<circ> f') = embed_measure (density M (g \<circ> f' \<circ> f)) f"
    by (rule density_embed_measure[OF inj])
       (rule measurable_comp, rule measurable_embed_measure1, subst measurable_cong,
        rule inv, rule measurable_ident_sets, simp, rule Mg)
  also have "density M (g \<circ> f' \<circ> f) = density M g"
    by (intro density_cong) (subst measurable_cong, simp add: o_def inv, simp_all add: Mg inv)
  finally show ?thesis .
qed

lemma inj_on_image_subset_iff:
  assumes "inj_on f C" "A \<subseteq> C"  "B \<subseteq> C"
  shows "f ` A \<subseteq> f ` B \<longleftrightarrow> A \<subseteq> B"
proof (intro iffI subsetI)
  fix x assume A: "f ` A \<subseteq> f ` B" and B: "x \<in> A"
  from B have "f x \<in> f ` A" by blast
  with A have "f x \<in> f ` B" by blast
  then obtain y where "f x = f y" and "y \<in> B" by blast
  with assms and B have "x = y" by (auto dest: inj_onD)
  with \<open>y \<in> B\<close> show "x \<in> B" by simp
qed auto

lemma AE_embed_measure':
  assumes inj: "inj_on f (space M)"
  shows "(AE x in embed_measure M f. P x) \<longleftrightarrow> (AE x in M. P (f x))"
proof
  let ?M = "embed_measure M f"
  assume "AE x in ?M. P x"
  then obtain A where A_props: "A \<in> sets ?M" "emeasure ?M A = 0" "{x\<in>space ?M. \<not>P x} \<subseteq> A"
    by (force elim: AE_E)
  then obtain A' where A'_props: "A = f ` A'" "A' \<in> sets M" by (auto simp: sets_embed_measure' inj)
  moreover have B: "{x\<in>space ?M. \<not>P x} = f ` {x\<in>space M. \<not>P (f x)}"
    by (auto simp: inj space_embed_measure)
  from A_props(3) have "{x\<in>space M. \<not>P (f x)} \<subseteq> A'"
    by (subst (asm) B, subst (asm) A'_props, subst (asm) inj_on_image_subset_iff[OF inj])
       (insert A'_props, auto dest: sets.sets_into_space)
  moreover from A_props A'_props have "emeasure M A' = 0"
    by (simp add: emeasure_embed_measure_image' inj)
  ultimately show "AE x in M. P (f x)" by (intro AE_I)
next
  let ?M = "embed_measure M f"
  assume "AE x in M. P (f x)"
  then obtain A where A_props: "A \<in> sets M" "emeasure M A = 0" "{x\<in>space M. \<not>P (f x)} \<subseteq> A"
    by (force elim: AE_E)
  hence "f`A \<in> sets ?M" "emeasure ?M (f`A) = 0" "{x\<in>space ?M. \<not>P x} \<subseteq> f`A"
    by (auto simp: space_embed_measure emeasure_embed_measure_image' sets_embed_measure' inj)
  thus "AE x in ?M. P x" by (intro AE_I)
qed

lemma AE_embed_measure:
  assumes inj: "inj f"
  shows "(AE x in embed_measure M f. P x) \<longleftrightarrow> (AE x in M. P (f x))"
  using assms by (intro AE_embed_measure') (auto intro!: inj_onI dest: injD)

lemma nn_integral_monotone_convergence_SUP_countable:
  fixes f :: "'a \<Rightarrow> 'b \<Rightarrow> ennreal"
  assumes nonempty: "Y \<noteq> {}"
  and chain: "Complete_Partial_Order.chain op \<le> (f ` Y)"
  and countable: "countable B"
  shows "(\<integral>\<^sup>+ x. (SUP i:Y. f i x) \<partial>count_space B) = (SUP i:Y. (\<integral>\<^sup>+ x. f i x \<partial>count_space B))"
  (is "?lhs = ?rhs")
proof -
  let ?f = "(\<lambda>i x. f i (from_nat_into B x) * indicator (to_nat_on B ` B) x)"
  have "?lhs = \<integral>\<^sup>+ x. (SUP i:Y. f i (from_nat_into B (to_nat_on B x))) \<partial>count_space B"
    by(rule nn_integral_cong)(simp add: countable)
  also have "\<dots> = \<integral>\<^sup>+ x. (SUP i:Y. f i (from_nat_into B x)) \<partial>count_space (to_nat_on B ` B)"
    by(simp add: embed_measure_count_space'[symmetric] inj_on_to_nat_on countable nn_integral_embed_measure' measurable_embed_measure1)
  also have "\<dots> = \<integral>\<^sup>+ x. (SUP i:Y. ?f i x) \<partial>count_space UNIV"
    by(simp add: nn_integral_count_space_indicator ennreal_indicator[symmetric] SUP_mult_right_ennreal nonempty)
  also have "\<dots> = (SUP i:Y. \<integral>\<^sup>+ x. ?f i x \<partial>count_space UNIV)"
  proof(rule nn_integral_monotone_convergence_SUP_nat)
    show "Complete_Partial_Order.chain op \<le> (?f ` Y)"
      by(rule chain_imageI[OF chain, unfolded image_image])(auto intro!: le_funI split: split_indicator dest: le_funD)
  qed fact
  also have "\<dots> = (SUP i:Y. \<integral>\<^sup>+ x. f i (from_nat_into B x) \<partial>count_space (to_nat_on B ` B))"
    by(simp add: nn_integral_count_space_indicator)
  also have "\<dots> = (SUP i:Y. \<integral>\<^sup>+ x. f i (from_nat_into B (to_nat_on B x)) \<partial>count_space B)"
    by(simp add: embed_measure_count_space'[symmetric] inj_on_to_nat_on countable nn_integral_embed_measure' measurable_embed_measure1)
  also have "\<dots> = ?rhs"
    by(intro arg_cong2[where f="SUPREMUM"] ext nn_integral_cong_AE)(simp_all add: AE_count_space countable)
  finally show ?thesis .
qed

end


theory T26
imports Main
begin
lemma "(
(\<forall> x::nat. \<forall> y::nat. meet(x, y) = meet(y, x)) &
(\<forall> x::nat. \<forall> y::nat. join(x, y) = join(y, x)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, meet(y, z)) = meet(meet(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(x, join(y, z)) = join(join(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. meet(x, join(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. join(x, meet(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, join(y, z)) = join(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(join(x, y), z) = join(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, over(join(mult(x, y), z), y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(y, undr(x, join(mult(x, y), z))) = y) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(over(x, y), y), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(y, undr(y, x)), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(meet(x, y), z) = meet(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(x, join(y, z)) = join(undr(x, y), undr(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(join(x, y), z) = join(over(x, z), over(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(meet(x, y), z) = join(undr(x, z), undr(y, z))) &
(\<forall> x::nat. \<forall> y::nat. invo(join(x, y)) = meet(invo(x), invo(y))) &
(\<forall> x::nat. \<forall> y::nat. invo(meet(x, y)) = join(invo(x), invo(y))) &
(\<forall> x::nat. invo(invo(x)) = x)
) \<longrightarrow>
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, meet(y, z)) = meet(mult(x, y), mult(x, z)))
"
nitpick[card nat=4,timeout=86400]
oops
end


theory T88
imports Main
begin
lemma "(
(\<forall> x::nat. \<forall> y::nat. meet(x, y) = meet(y, x)) &
(\<forall> x::nat. \<forall> y::nat. join(x, y) = join(y, x)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, meet(y, z)) = meet(meet(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(x, join(y, z)) = join(join(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. meet(x, join(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. join(x, meet(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, join(y, z)) = join(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(join(x, y), z) = join(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, over(join(mult(x, y), z), y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(y, undr(x, join(mult(x, y), z))) = y) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(over(x, y), y), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(y, undr(y, x)), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, meet(y, z)) = meet(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(meet(x, y), z) = meet(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(join(x, y), z) = join(over(x, z), over(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(meet(x, y), z) = join(undr(x, z), undr(y, z))) &
(\<forall> x::nat. \<forall> y::nat. invo(join(x, y)) = meet(invo(x), invo(y))) &
(\<forall> x::nat. \<forall> y::nat. invo(meet(x, y)) = join(invo(x), invo(y))) &
(\<forall> x::nat. invo(invo(x)) = x)
) \<longrightarrow>
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(x, join(y, z)) = join(undr(x, y), undr(x, z)))
"
nitpick[card nat=8,timeout=86400]
oops
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[Chapter~3*]{Sen:70a} 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[OF Vfinite] Vcard
    have V2card: "card ?V2 > 0" "card ?V2 < card V" by auto
    hence V2notempty: "{} \<noteq> ?V2" by auto
    from jV VIs
    have jV2V3: "Is = ?V1 \<union> ?V2 \<union> ?V3 \<and> ?V1 \<inter> ?V2 = {} \<and> ?V1 \<inter> ?V3 = {} \<and> ?V2 \<inter> ?V3 = {}"
      by auto
        \<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{Routley:79} relaxes this with
some fancier set theory. Having an infinite set of alternatives doesn't
matter, though the result is a bit more plausible if we assume finiteness
\cite[p54]{Sen:70a}.

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


section \<open>Periodic Orbits\<close>
theory Periodic_Orbit
  imports
    Ordinary_Differential_Equations.ODE_Analysis
    Analysis_Misc
    ODE_Misc
    Limit_Set
begin

text \<open> Definition of closed and periodic orbits and their associated properties \<close>

context auto_ll_on_open
begin

text \<open>
   TODO: not sure if the "closed orbit" terminology is standard
   Closed orbits have some non-zero recurrence time T where the flow returns to the initial state
   The period of a closed orbit is the infimum of all positive recurrence times
   Periodic orbits are the subset of closed orbits where the period is non-zero
  \<close>

definition "closed_orbit x \<longleftrightarrow>
  (\<exists>T \<in> existence_ivl0 x. T \<noteq> 0 \<and> flow0 x T = x)"

definition "period x =
  Inf {T \<in> existence_ivl0 x. T > 0 \<and> flow0 x T = x}"

definition "periodic_orbit x \<longleftrightarrow>
  closed_orbit x \<and> period x > 0"

lemma recurrence_time_flip_sign:
  assumes "T \<in> existence_ivl0 x" "flow0 x T = x"
  shows "-T \<in> existence_ivl0 x" "flow0 x (-T) = x"
  using assms existence_ivl_reverse apply fastforce
  using assms flows_reverse by fastforce

lemma closed_orbit_recurrence_times_nonempty:
  assumes "closed_orbit x"
  shows " {T \<in> existence_ivl0 x. T > 0 \<and> flow0 x T = x} \<noteq> {}"
  apply auto
  using assms(1) unfolding closed_orbit_def
  by (smt recurrence_time_flip_sign)

lemma closed_orbit_recurrence_times_bdd_below:
  shows "bdd_below {T \<in> existence_ivl0 x. T > 0 \<and> flow0 x T = x}"
  unfolding bdd_below_def
  by (auto) (meson le_cases not_le)

lemma closed_orbit_period_nonneg:
  assumes "closed_orbit x"
  shows "period x \<ge> 0"
  unfolding period_def
  using assms(1) unfolding closed_orbit_def apply (auto intro!:cInf_greatest)
  by (smt recurrence_time_flip_sign)

lemma closed_orbit_in_domain:
  assumes "closed_orbit x"
  shows "x \<in> X"
  using assms unfolding closed_orbit_def
  using local.mem_existence_ivl_iv_defined(2) by blast

lemma closed_orbit_global_existence:
  assumes "closed_orbit x"
  shows "existence_ivl0 x = UNIV"
proof -
  obtain Tp where "Tp \<noteq> 0" "Tp \<in> existence_ivl0 x" "flow0 x Tp = x" using assms
    unfolding closed_orbit_def by blast
  then obtain T where T: "T > 0" "T \<in> existence_ivl0 x" "flow0 x T = x"
    by (smt recurrence_time_flip_sign)
  have apos: "real n * T \<in> existence_ivl0 x \<and> flow0 x (real n * T) = x" for n
  proof (induction n)
    case 0
    then show ?case using closed_orbit_in_domain assms by auto
  next
    case (Suc n)
    fix n
    assume ih:"real n * T \<in> existence_ivl0 x \<and> flow0 x (real n * T) = x"
    then have "T \<in> existence_ivl0 (flow0 x (real n * T))" using T by metis
    then have l:"real n * T + T \<in> existence_ivl0 x" using ih
      using existence_ivl_trans by blast
    have "flow0 (flow0 x (real n * T)) T = x" using ih T by metis
    then have r: "flow0 x (real n * T + T) = x"
      by (simp add: T(2) ih local.flow_trans)
    show "real (Suc n) * T \<in> existence_ivl0 x \<and> flow0 x (real (Suc n) * T) = x"
      using l r
      by (simp add: add.commute distrib_left mult.commute)
  qed
  then have aneg: "-real n * T \<in> existence_ivl0 x \<and> flow0 x (-real n * T) = x" for n
    by (simp add: recurrence_time_flip_sign)
  have "\<forall>t. t \<in> existence_ivl0 x"
  proof safe
    fix t
    have "t \<ge> 0 \<or> t \<le> (0::real)" by linarith
    moreover {
      assume "t \<ge> 0"
      obtain k where "real k * T > t"
        using T(1) ex_less_of_nat_mult by blast
      then have "t \<in> existence_ivl0 x" using apos
        by (meson \<open>0 \<le> t\<close> atLeastAtMost_iff less_eq_real_def local.ivl_subset_existence_ivl subset_eq)
    }
    moreover {
      assume "t \<le> 0"
      obtain k where "- real k * T < t"
        by (metis T(1) add.inverse_inverse ex_less_of_nat_mult mult.commute mult_minus_right neg_less_iff_less)
      then have "t \<in> existence_ivl0 x" using aneg
        by (smt apos atLeastAtMost_iff calculation(2) local.existence_ivl_trans' local.ivl_subset_existence_ivl mult_minus_left subset_eq)
    }
    ultimately show "t \<in> existence_ivl0 x" by blast
  qed
  thus ?thesis by auto
qed

lemma recurrence_time_multiples:
  fixes n::nat
  assumes "T \<in> existence_ivl0 x" "T \<noteq> 0" "flow0 x T = x"
  shows "\<And>t. flow0 x (t+T*n) = flow0 x t"
proof (induction n)
  case 0
  then show ?case by auto
next
  case (Suc n)
  fix n t
  assume ih : "(\<And>t. flow0 x (t + T * real n) = flow0 x t)"
  have "closed_orbit x" using assms unfolding closed_orbit_def by auto
  from closed_orbit_global_existence[OF this] have ex:"existence_ivl0 x = UNIV" .
  have "flow0 x (t + T * real (Suc n)) = flow0 x (t+T*real n + T)"
    by (simp add: Groups.add_ac(3) add.commute distrib_left)
  also have "... = flow0 (flow0 x (t+ T*real n)) T" using ex
    by (simp add: local.existence_ivl_trans' local.flow_trans)
  also have "... = flow0 (flow0 x t) T" using ih by auto
  also have "... = flow0 (flow0 x T) t" using ex
    by (metis UNIV_I add.commute local.existence_ivl_trans' local.flow_trans)
  finally show "flow0 x (t + T * real (Suc n)) = flow0 x t" using assms(3) by simp
qed

lemma nasty_arithmetic1:
  fixes t T::real
  assumes "T > 0" "t \<ge> 0"
  obtains q r where "t = (q::nat) * T + r" "0 \<le> r" "r < T"
proof -
  define q where "q = floor (t / T)"
  have q:"q \<ge> 0" using assms unfolding q_def by auto
  from floor_divide_lower[OF assms(1), of t]
  have ql: "q * T \<le> t" unfolding q_def .
  from floor_divide_upper[OF assms(1), of t]
  have qu: "t < (q + 1)* T" unfolding q_def by auto
  define r where "r = t - q * T"
  have rl:"0 \<le> r" using ql unfolding r_def by auto
  have ru:"r < T" using qu unfolding r_def  by (simp add: distrib_right)
  show ?thesis using q r_def rl ru
    by (metis le_add_diff_inverse of_int_of_nat_eq plus_int_code(2) ql that zle_iff_zadd)
qed

lemma nasty_arithmetic2:
  fixes t T::real
  assumes "T > 0" "t \<le> 0"
  obtains q r where "t = (q::nat) * (-T) + r" "0 \<le> r" "r < T"
proof -
  have "-t \<ge> 0" using assms(2) by linarith
  from nasty_arithmetic1[OF assms(1) this]
  obtain q r where qr: "-t = (q::nat) * T + r" "0 \<le> r" "r < T" by blast
  then have "t = q * (-T) - r"  by auto
  then have "t = (q+(1::nat)) * (-T) + (T-r)" by (simp add: distrib_right)
  thus ?thesis using qr(2-3)
    by (smt \<open>t = real q * - T - r\<close> that)
qed

lemma recurrence_time_restricts_compact_flow:
  assumes "T \<in> existence_ivl0 x" "T > 0" "flow0 x T = x"
  shows "flow0 x ` UNIV = flow0 x ` {0..T}"
  apply auto
proof -
  fix t
  have "t \<ge> 0 \<or> t \<le> (0::real)" by linarith
  moreover {
    assume "t \<ge> 0"
    from nasty_arithmetic1[OF assms(2) this]
    obtain q r where qr:"t = (q::nat) * T + r" "0 \<le> r" "r < T" by blast
    have "T \<noteq> 0" using assms(2) by auto
    from recurrence_time_multiples[OF assms(1) this assms(3),of "r" "q"]
    have "flow0 x t = flow0 x r"
      by (simp add: qr(1) add.commute mult.commute)
    then have "flow0 x t \<in> flow0 x ` {0..<T}" using qr by auto
  }
  moreover {
    assume "t \<le> 0"
    from nasty_arithmetic2[OF assms(2) this]
    obtain q r where qr:"t = (q::nat) * (-T) + r" "0 \<le> r" "r < T" by blast
    have "-T \<in> existence_ivl0 x" "-T \<noteq> 0" "flow0 x (-T) = x" using recurrence_time_flip_sign assms by auto
    from recurrence_time_multiples[OF this, of r q]
    have "flow0 x t = flow0 x r"
      by (simp add: mult.commute qr(1))
    then have "flow0 x t \<in> flow0 x ` {0..<T}" using qr by auto
  }
  ultimately show "flow0 x t \<in> flow0 x ` {0..T}"
    by auto
qed

lemma closed_orbitI:
  assumes "t \<noteq> t'" "t \<in> existence_ivl0 y" "t' \<in> existence_ivl0 y"
  assumes "flow0 y t = flow0 y t'"
  shows "closed_orbit y"
  unfolding closed_orbit_def
  by (smt assms local.existence_ivl_reverse local.existence_ivl_trans local.flow_trans local.flows_reverse)

(* TODO: can be considerably generalized *)
lemma flow0_image_UNIV:
  assumes "existence_ivl0 x = UNIV"
  shows "flow0 (flow0 x t) ` S = flow0 x ` (\<lambda>s. s + t) ` S"
  apply auto
   apply (metis UNIV_I add.commute assms image_eqI local.existence_ivl_trans' local.flow_trans)
  by (metis UNIV_I add.commute assms imageI local.existence_ivl_trans' local.flow_trans)

lemma recurrence_time_restricts_compact_flow':
  assumes "t < t'" "t \<in> existence_ivl0 y" "t' \<in> existence_ivl0 y"
  assumes "flow0 y t = flow0 y t'"
  shows "flow0 y ` UNIV = flow0 y ` {t..t'}"
proof -
  have "closed_orbit y"
    using assms(1-4) closed_orbitI inf.strict_order_iff by blast
  from closed_orbit_global_existence[OF this]
  have yex: "existence_ivl0 y = UNIV" .
  have a1:"t'- t \<in> existence_ivl0 (flow0 y t)"
    by (simp add: assms(2-3) local.existence_ivl_trans')
  have a2:"t' -t > 0" using assms(1) by auto
  have a3:"flow0 (flow0 y t) (t' - t) = flow0 y t"
    using a1 assms(2) assms(4) local.flow_trans by fastforce
  from recurrence_time_restricts_compact_flow[OF a1 a2 a3]
  have eq:"flow0 (flow0 y t) ` UNIV = flow0 (flow0 y t) ` {0.. t'-t}" .
  from flow0_image_UNIV[OF yex, of _ "UNIV"]
  have eql:"flow0 (flow0 y t) ` UNIV = flow0 y ` UNIV"
    by (metis (no_types) add.commute surj_def surj_plus)
  from flow0_image_UNIV[OF yex, of _ "{0..t'-t}"]
  have eqr:"flow0 (flow0 y t) ` {0.. t'-t} = flow0 y ` {t..t'}" by auto
  show ?thesis using eq eql eqr by auto
qed

lemma closed_orbitE':
  assumes "closed_orbit x"
  obtains T where "T > 0" "\<And>t (n::nat). flow0 x (t+T*n) = flow0 x t"
proof -
  obtain Tp where "Tp \<noteq> 0" "Tp \<in> existence_ivl0 x" "flow0 x Tp = x" using assms
    unfolding closed_orbit_def by blast
  then obtain T where T: "T > 0" "T \<in> existence_ivl0 x" "flow0 x T = x"
    by (smt recurrence_time_flip_sign)
  thus ?thesis using  recurrence_time_multiples T that by blast
qed

lemma closed_orbitE:
  assumes "closed_orbit x"
  obtains T where "T > 0" "\<And>t. flow0 x (t+T) = flow0 x t"
  using closed_orbitE'
  by (metis assms mult.commute reals_Archimedean3)

lemma closed_orbit_flow_compact:
  assumes "closed_orbit x"
  shows "compact(flow0 x ` UNIV)"
proof -
  obtain Tp where "Tp \<noteq> 0" "Tp \<in> existence_ivl0 x" "flow0 x Tp = x" using assms
    unfolding closed_orbit_def by blast
  then obtain T where T: "T \<in> existence_ivl0 x" "T > 0" "flow0 x T = x"
    by (smt recurrence_time_flip_sign)
  from recurrence_time_restricts_compact_flow[OF this]
  have feq: "flow0 x ` UNIV = flow0 x ` {0..T}" .
  have "continuous_on {0..T} (flow0 x)"
    by (meson T(1) continuous_on_sequentially in_mono local.flow_continuous_on local.ivl_subset_existence_ivl)
  from compact_continuous_image[OF this]
  have "compact (flow0 x ` {0..T})" by auto
  thus ?thesis using feq by auto
qed

lemma fixed_point_imp_closed_orbit_period_zero:
  assumes "x \<in> X"
  assumes "f x = 0"
  shows "closed_orbit x" "period x = 0"
proof -
  from fixpoint_sol[OF assms] have fp:"existence_ivl0 x = UNIV" "\<And>t. flow0 x t = x" by auto
  then have co:"closed_orbit x" unfolding closed_orbit_def by blast
  have a: "\<forall>y>0. \<exists>a\<in>{T \<in> existence_ivl0 x. 0 < T \<and> flow0 x T = x}. a < y"
    apply auto
    using fp
    by (simp add: dense)
  from cInf_le_iff[OF closed_orbit_recurrence_times_nonempty[OF co]
      closed_orbit_recurrence_times_bdd_below , of 0]
  have "period x \<le> 0" unfolding period_def using a by auto
  from closed_orbit_period_nonneg[OF co] have "period x \<ge> 0" .
  then have "period x = 0" using \<open>period x \<le> 0\<close> by linarith
  thus "closed_orbit x" "period x = 0" using co by auto
qed

lemma closed_orbit_period_zero_fixed_point:
  assumes "closed_orbit x" "period x = 0"
  shows "f x = 0"
proof (rule ccontr)
  assume "f x \<noteq> 0"
  from regular_locally_noteq[OF closed_orbit_in_domain[OF assms(1)] this]
  have "\<forall>\<^sub>F t in at 0. flow0 x t \<noteq> x " .
  then obtain r where "r>0" "\<forall>t. t \<noteq> 0 \<and> dist t 0 < r \<longrightarrow> flow0 x t \<noteq> x" unfolding eventually_at
    by auto
  then have "period x \<ge> r" unfolding period_def
    apply (auto intro!:cInf_greatest)
     apply (meson assms(1) closed_orbit_def linorder_neqE_linordered_idom neg_0_less_iff_less recurrence_time_flip_sign)
    using not_le by force
  thus False using assms(2) \<open>r >0\<close> by linarith
qed

lemma closed_orbit_subset_\<omega>_limit_set:
  assumes "closed_orbit x"
  shows "flow0 x ` UNIV \<subseteq> \<omega>_limit_set x"
  unfolding \<omega>_limit_set_def \<omega>_limit_point_def
proof clarsimp
  fix t
  from closed_orbitE'[OF assms]
  obtain T where T: "0 < T" "\<And>t n. flow0 x (t + T* real n) = flow0 x t" by blast
  define s where "s = (\<lambda>n::nat. t + T * real n)"
  have exist: "{0..} \<subseteq> existence_ivl0 x"
    by (simp add: assms closed_orbit_global_existence)
  have l:"filterlim s at_top sequentially" unfolding s_def
    using T(1)
    by (auto intro!:filterlim_tendsto_add_at_top filterlim_tendsto_pos_mult_at_top
        simp add: filterlim_real_sequentially)
  have "flow0 x \<circ> s = (\<lambda>n. flow0 x t)" unfolding o_def s_def using T(2) by simp
  then have r:"(flow0 x \<circ> s) \<longlonglongrightarrow> flow0 x t" by auto
  show "{0..} \<subseteq> existence_ivl0 x \<and> (\<exists>s. s \<longlonglongrightarrow>\<^bsub>\<^esub> \<infinity> \<and> (flow0 x \<circ> s) \<longlonglongrightarrow> flow0 x t)"
    using exist l r by blast
qed

lemma closed_orbit_\<omega>_limit_set:
  assumes "closed_orbit x"
  shows "flow0 x ` UNIV = \<omega>_limit_set x"
proof -
  have "\<omega>_limit_set x \<subseteq> flow0 x ` UNIV"
    using closed_orbit_global_existence[OF assms]
    by (intro \<omega>_limit_set_in_compact_subset)
      (auto intro!: flow_in_domain
        simp add: assms closed_orbit_in_domain image_subset_iff trapped_forward_def
        closed_orbit_flow_compact)
  thus ?thesis using closed_orbit_subset_\<omega>_limit_set[OF assms] by auto
qed

lemma flow0_inj_on:
  assumes "t \<le> t'"
  assumes "{t..t'} \<subseteq> existence_ivl0 x"
  assumes "\<And>s. t < s \<Longrightarrow> s \<le> t' \<Longrightarrow> flow0 x s \<noteq> flow0 x t"
  shows "inj_on (flow0 x) {t..t'}"
  apply (rule inj_onI)
proof (rule ccontr)
  fix u v
  assume uv: "u \<in> {t..t'}" "v \<in> {t..t'}" "flow0 x u = flow0 x v" "u \<noteq> v"
  have "u < v \<or> v < u" using uv(4) by linarith
  moreover {
    assume "u < v"
    from recurrence_time_restricts_compact_flow'[OF this _ _ uv(3)]
    have "flow0 x ` UNIV = flow0 x ` {u..v}"  using uv(1-2) assms(2) by blast
    then have "flow0 x t \<in> flow0 x ` {u..v}" by auto
    moreover have "u = t \<or> flow0 x t \<notin> flow0 x ` {u..v}" using assms(3)
      by (smt atLeastAtMost_iff image_iff uv(1) uv(2))
    ultimately have False using uv assms(3)
      by force
  }
  moreover {
    assume "v < u"
    from recurrence_time_restricts_compact_flow'[OF this _ _ ]
    have "flow0 x ` UNIV = flow0 x ` {v..u}"
      by (metis assms(2) subset_iff uv(1) uv(2) uv(3))
    then have "flow0 x t \<in> flow0 x ` {v..u}" by auto
    moreover have "v = t \<or> flow0 x t \<notin> flow0 x ` {v..u}" using assms(3)
      by (smt atLeastAtMost_iff image_iff uv(1) uv(2))
    ultimately have False using uv assms(3) by force
  }
  ultimately show False by blast
qed

(* TODO: Probably has a simpler proof *)
lemma finite_\<omega>_limit_set_in_compact_imp_unique_fixed_point:
  assumes "compact K" "K \<subseteq> X"
  assumes "x \<in> X" "trapped_forward x K"
  assumes "finite (\<omega>_limit_set x)"
  obtains y where "\<omega>_limit_set x = {y}" "f y = 0"
proof -
  from connected_finite_iff_sing[OF \<omega>_limit_set_in_compact_connected]
  obtain y where y: "\<omega>_limit_set x = {y}"
    using \<omega>_limit_set_in_compact_nonempty assms by auto
  have "f y = 0"
  proof (rule ccontr)
    assume fy:"f y \<noteq> 0"
    from \<omega>_limit_set_in_compact_existence[OF assms(1-4)]
    have yex: "existence_ivl0 y = UNIV"
      by (simp add: y)
    then have "y \<in> X"
      by (simp add: local.mem_existence_ivl_iv_defined(2))
    from regular_locally_noteq[OF this fy]
    have "\<forall>\<^sub>F t in at 0. flow0 y t \<noteq> y" .
    then obtain r where r: "r>0" "\<forall>t. t \<noteq> 0 \<and> dist t 0 < r \<longrightarrow> flow0 y t \<noteq> flow0 y 0"
      unfolding eventually_at using \<open>y \<in> X\<close>
      by auto
    then have "\<And>s. 0 < s \<Longrightarrow> s \<le> r/2 \<Longrightarrow> flow0 y s \<noteq> flow0 y 0" by simp
    from flow0_inj_on[OF _ _ this, of "r/2"]
    obtain "inj_on(flow0 y) {0..r/2}" using r yex by simp
    then have "infinite (flow0 y`{0..r/2})" by (simp add: finite_image_iff r(1))
    moreover from \<omega>_limit_set_invariant[of x]
    have "flow0 y `{0..r/2} \<subseteq> \<omega>_limit_set x" using y yex
      unfolding invariant_def trapped_iff_on_existence_ivl0 by auto
    ultimately show False using y
      by (metis assms(5) finite.emptyI subset_singleton_iff)
  qed
  thus ?thesis using that y by auto
qed

lemma closed_orbit_periodic:
  assumes "closed_orbit x" "f x \<noteq> 0"
  shows "periodic_orbit x"
  unfolding periodic_orbit_def
  using assms(1) apply auto
proof (rule ccontr)
  assume "closed_orbit x"
  from closed_orbit_period_nonneg[OF assms(1)] have nneg: "period x \<ge> 0" .
  assume "\<not> 0 < period x"
  then have "period x = 0" using nneg by linarith
  from closed_orbit_period_zero_fixed_point[OF assms(1) this]
  have "f x = 0" .
  thus False using assms(2) by linarith
qed

lemma periodic_orbitI:
  assumes "t \<noteq> t'" "t \<in> existence_ivl0 y" "t' \<in> existence_ivl0 y"
  assumes "flow0 y t = flow0 y t'"
  assumes "f y \<noteq> 0"
  shows "periodic_orbit y"
proof -
  have y:"y \<in> X"
    using assms(3) local.mem_existence_ivl_iv_defined(2) by blast
  from closed_orbitI[OF assms(1-4)] have "closed_orbit y" .
  from closed_orbit_periodic[OF this assms(5)]
  show ?thesis .
qed

lemma periodic_orbit_recurrence_times_closed:
  assumes "periodic_orbit x"
  shows "closed {T \<in> existence_ivl0 x. T > 0 \<and> flow0 x T = x}"
proof -
  have a1:"x \<in> X"
    using assms closed_orbit_in_domain periodic_orbit_def by auto
  have a2:"f x \<noteq> 0"
    using assms closed_orbit_in_domain fixed_point_imp_closed_orbit_period_zero(2) periodic_orbit_def by auto
  from regular_locally_noteq[OF a1 a2] have
    "\<forall>\<^sub>F t in at 0. flow0 x t \<noteq> x" .
  then obtain r where r:"r>0" "\<forall>t. t \<noteq> 0 \<and> dist t 0 < r \<longrightarrow> flow0 x t \<noteq> x" unfolding eventually_at
    by auto
  show ?thesis
  proof (auto intro!:discrete_imp_closed[OF r(1)])
    fix t1 t2
    assume t12: "t1 > 0" "flow0 x t1 = x" "t2 > 0" "flow0 x t2 = x" "dist t2 t1 < r"
    then have fx: "flow0 x (t1-t2) = x"
      by (smt a1 assms closed_orbit_global_existence existence_ivl_zero general.existence_ivl_initial_time_iff local.flow_trans periodic_orbit_def)
    have "dist (t1-t2) 0 < r" using t12(5)
      by (simp add: dist_norm)
    thus "t2 = t1" using r fx
      by smt
  qed
qed

lemma periodic_orbit_period:
  assumes "periodic_orbit x"
  shows "period x > 0" "flow0 x (period x) = x"
proof -
  from periodic_orbit_recurrence_times_closed[OF assms(1)]
  have cl: "closed {T \<in> existence_ivl0 x. T > 0 \<and> flow0 x T = x}" .
  have "closed_orbit x" using assms(1) unfolding periodic_orbit_def by auto
  from closed_contains_Inf[OF closed_orbit_recurrence_times_nonempty[OF this]
      closed_orbit_recurrence_times_bdd_below cl]
  have "period x \<in>  {T \<in> existence_ivl0 x. T > 0 \<and> flow0 x T = x}" unfolding period_def .
  thus "period x > 0" "flow0 x (period x) = x" by auto
qed

lemma closed_orbit_flow0:
  assumes "closed_orbit x"
  shows "closed_orbit (flow0 x t)"
proof -
  from closed_orbit_global_existence[OF assms]
  have "existence_ivl0 x = UNIV" .
  from closed_orbitE[OF assms]
  obtain T where "T > 0" "flow0 x (t+T) = flow0 x t"
    by metis
  thus ?thesis unfolding closed_orbit_def
    by (metis UNIV_I \<open>existence_ivl0 x = UNIV\<close> less_irrefl local.existence_ivl_trans' local.flow_trans)
qed

lemma periodic_orbit_imp_flow0_regular:
  assumes "periodic_orbit x"
  shows "f (flow0 x t) \<noteq> 0"
  by (metis UNIV_I assms closed_orbit_flow0 closed_orbit_global_existence closed_orbit_in_domain fixed_point_imp_closed_orbit_period_zero(2) fixpoint_sol(2) less_irrefl local.flows_reverse periodic_orbit_def)

lemma fixed_point_imp_\<omega>_limit_set:
  assumes "x \<in> X" "f x = 0"
  shows "\<omega>_limit_set x = {x}"
proof -
  have "closed_orbit x"
    by (metis assms fixed_point_imp_closed_orbit_period_zero(1))
  from closed_orbit_\<omega>_limit_set[OF this]
  have "flow0 x ` UNIV = \<omega>_limit_set x" .
  thus ?thesis
    by (metis assms(1) assms(2) fixpoint_sol(2) image_empty image_insert image_subset_iff insertI1 rangeI subset_antisym)
qed

end

context auto_ll_on_open begin

lemma closed_orbit_eq_rev: "closed_orbit x = rev.closed_orbit x"
  unfolding closed_orbit_def rev.closed_orbit_def rev_eq_flow rev_existence_ivl_eq0
  by auto

lemma fixed_point_imp_\<alpha>_limit_set:
  assumes "x \<in> X" "f x = 0"
  shows "\<alpha>_limit_set x = {x}"
  using rev.fixed_point_imp_\<omega>_limit_set assms
  unfolding \<alpha>_limit_set_eq_rev
  by auto

lemma finite_\<alpha>_limit_set_in_compact_imp_unique_fixed_point:
  assumes "compact K" "K \<subseteq> X"
  assumes "x \<in> X"  "trapped_backward x K"
  assumes "finite (\<alpha>_limit_set x)"
  obtains y where "\<alpha>_limit_set x = {y}" "f y = 0"
proof -
  from rev.finite_\<omega>_limit_set_in_compact_imp_unique_fixed_point[OF
      assms(1-5)[unfolded trapped_backward_iff_rev_trapped_forward \<alpha>_limit_set_eq_rev]]
  show ?thesis using that
    unfolding \<alpha>_limit_set_eq_rev
    by auto
qed
end

end