theory SocialWelfareFunction
  imports Main Common Base
begin

(*
  A social welfare function aggregates an entire profile of preferences into a single collective
  preference relation.
*)
type_synonym 'a SWF = "'a PP \<Rightarrow> 'a relation"

abbreviation invalid_swf :: "'a SWF" where "invalid_swf _ \<equiv> \<lambda>_ _. False"

locale social_welfare_function = social_choice_setting +
  fixes g :: "'a SWF"
  assumes g: "preference_profile U n R\<^sub>N \<Longrightarrow> preference_relation U (g R\<^sub>N)"
  assumes g_invalid: "\<not> preference_profile U n R\<^sub>N = (g R\<^sub>N = invalid_swf R\<^sub>N)"
begin

(*
  A group of voters G is decisive for a against b, if, whenever every voter in G has a strict
  preference for a against b, then the collective preference relation also has that preference
*)
definition D\<^sub>G :: "nat set \<Rightarrow> 'a relation"
  where "D\<^sub>G G a b \<equiv> G \<subseteq> N \<and> (\<forall>R\<^sub>N.
      preference_profile U n R\<^sub>N
  \<longrightarrow> (\<forall>i \<in> G. asymm (R\<^sub>N i) a b)
  \<longrightarrow> asymm (g R\<^sub>N) a b)
"

(*
  Semi-decisiveness is a weaker version of decisiveness. It is merely a technical definition needed
  for the proof
*)
definition SD\<^sub>G :: "nat set \<Rightarrow> 'a relation"
  where "SD\<^sub>G G a b \<equiv> G \<subseteq> N \<and> (\<forall>R\<^sub>N.
      preference_profile U n R\<^sub>N
  \<longrightarrow> (\<forall>i \<in> G. asymm (R\<^sub>N i) a b)
    \<and> (\<forall>i \<in> N - G. asymm (R\<^sub>N i) b a)
  \<longrightarrow> asymm (g R\<^sub>N) a b)
"

(* A group of voters is decisive, if it is decisive for every pair of alternatives *)
definition D :: "nat set \<Rightarrow> bool" where "D G \<equiv> G \<subseteq> N \<and> (\<forall>a b. D\<^sub>G G a b)"

lemma d_sd: "D\<^sub>G G a b \<Longrightarrow> SD\<^sub>G G a b" unfolding D\<^sub>G_def SD\<^sub>G_def by auto
lemma D\<^sub>G_trivial: "G \<sqsubseteq> N \<Longrightarrow> D\<^sub>G G a a" unfolding D\<^sub>G_def SD\<^sub>G_def by auto

(*
  A dictator is a voter who can impose their strict preference onto the whole society.
  That is to say, d is a dictator, iff no matter the preference profile, if d has a strict
  preference for x vs y, then the societal preference will also be to strictly prefer x to y.
*)
abbreviation is_dictator
  where "is_dictator d \<equiv> \<forall>R\<^sub>N x y. preference_profile U n R\<^sub>N \<longrightarrow> (asymm (R\<^sub>N d) x y \<longrightarrow> asymm (g R\<^sub>N) x y)"

end

locale IIA = social_welfare_function +
  assumes IIA: "(\<And>i. R\<^sub>N i x y = R\<^sub>N' i x y) \<Longrightarrow> g R\<^sub>N x y = g R\<^sub>N' x y"

locale pareto = social_welfare_function +
  assumes pareto: "(\<And>i. i \<in> N \<Longrightarrow> asymm (R\<^sub>N i) x y) \<Longrightarrow> asymm (g R\<^sub>N) x y"
begin

lemma "D N" unfolding D_def D\<^sub>G_def using pareto by auto

end

locale dictatorial = social_welfare_function +
  assumes dictatorial: "\<exists>d \<in> N. is_dictator d"

locale at_least_three_alternatives = choice_setting +
  assumes card_U: "3 \<le> card U"

locale dict_3 = dictatorial + at_least_three_alternatives

locale IIA_pareto_3 = IIA + pareto + at_least_three_alternatives
begin

context
  fixes a b c :: 'a and G :: "nat set"
  assumes GN: "G \<sqsubseteq> N"
  assumes au: "a \<in> U" and bu: "b \<in> U" and cu: "c \<in> U"
  assumes ab: "a \<noteq> b" and ca: "c \<noteq> a" and cb: "c \<noteq> b"
begin

(* Slide 66 top *)
lemma first:
  assumes sdg_ab: "SD\<^sub>G G a b"
  shows "D\<^sub>G G a c"
proof - {
  fix R\<^sub>N :: "'a PP"
  assume R\<^sub>N_pp: "preference_profile U n R\<^sub>N"
  then interpret re: preference_profile U n R\<^sub>N by auto
  assume G_R\<^sub>N_ac: "i \<in> G \<Longrightarrow> asymm (R\<^sub>N i) a c" for i

  define R1 :: "'a PP" where "R1 \<equiv> \<lambda>i x y. i \<in> N \<and> x \<in> U \<and> y \<in> U \<and> (
    if i \<in> G
      then if y = a then x = a
      else if y = b then x = a \<or> x = b
      else if y = c then x = a \<or> x = b \<or> x = c
      else True
    else if x = b then True
    else if y = b then False
    else R\<^sub>N i x y
  )"

  interpret r1: preference_profile U n R1 proof
    show "\<And>i x y. i \<in> N \<Longrightarrow> x \<notin> U \<or> y \<notin> U \<Longrightarrow> \<not> R1 i x y" unfolding R1_def by blast
  next
    fix x y z :: 'a and i assume "i \<in> N" "R1 i x y" "R1 i y z"
    interpret pr: preference_relation U "R\<^sub>N i" using \<open>i \<in> N\<close> re.R\<^sub>N by auto
    show "R1 i x z" unfolding R1_def using pr.transitive by (smt (verit, best) R1_def \<open>R1 i x y\<close> \<open>R1 i y z\<close> \<open>i \<in> N\<close> ab cb) next
    show "\<And>i x. i \<in> N \<Longrightarrow> x \<in> U \<Longrightarrow> R1 i x x" unfolding R1_def using R\<^sub>N_pp preference_profile.refl by fastforce
  next
    fix x y :: 'a and i assume "i \<in> N" "x \<in> U" "y \<in> U"
    interpret pr: preference_relation U "R\<^sub>N i" using \<open>i \<in> N\<close> re.R\<^sub>N by auto
    show "R1 i x y \<or> R1 i y x" unfolding R1_def using pr.complete using \<open>i \<in> N\<close> \<open>x \<in> U\<close> \<open>y \<in> U\<close> by presburger next
    show "\<And>i x y. i \<notin> N \<or> x \<notin> U \<or> y \<notin> U \<Longrightarrow> \<not> R1 i x y" unfolding R1_def by blast next
  qed

  have "i \<in> G \<Longrightarrow> asymm (R1 i) a b" for i using GN R1_def au ab bu by fastforce
  moreover have "i \<in> N-G \<Longrightarrow> asymm (R1 i) b a" for i using R1_def ab au bu by force
  ultimately have g_R1_ab: "asymm (g R1) a b" using SD\<^sub>G_def r1.preference_profile_axioms sdg_ab by auto

  have "i \<in> N \<Longrightarrow> asymm (R1 i) b c" for i using G_R\<^sub>N_ac R1_def bu cb cu by auto
  hence g_R1_bc: "asymm (g R1) b c" using pareto by auto

  interpret gr1: preference_relation U "g R1" by (simp add: g r1.preference_profile_axioms)

  have g_R1_ac: "asymm (g R1) a c" using g_R1_ab g_R1_bc gr1.transitive by blast

  have agree_on_ac: "R\<^sub>N i a c = R1 i a c" for i using G_R\<^sub>N_ac R1_def ab cb re.R\<^sub>N_domain by auto
  hence "asymm (g R\<^sub>N) a c" using g_R1_ac IIA[of R\<^sub>N a c R1, OF agree_on_ac] by (smt (verit) G_R\<^sub>N_ac IIA R1_def ab cb re.R\<^sub>N_domain)
} thus "D\<^sub>G G a c" by (simp add: D\<^sub>G_def GN)
qed

lemma first': "G \<sqsubseteq> N \<Longrightarrow> a \<in> U \<Longrightarrow> b \<in> U \<Longrightarrow> a \<noteq> b \<Longrightarrow> D\<^sub>G G a b \<Longrightarrow> c \<in> U \<Longrightarrow> c \<noteq> b \<Longrightarrow> D\<^sub>G G a c"
  using d_sd first by blast

(* Slide 66 bottom *)
lemma second:
  assumes dg_ab: "D\<^sub>G G a b"
  shows "D\<^sub>G G c b"
proof -
  {
    fix R\<^sub>N :: "'a PP"
    assume R\<^sub>N_pp: "preference_profile U n R\<^sub>N"
    then interpret re: preference_profile U n R\<^sub>N by auto
    assume G_R\<^sub>N_ab: "i \<in> G \<Longrightarrow> asymm (R\<^sub>N i) c b" for i

    define R :: "'a PP" where "R \<equiv> \<lambda>i x y. i \<in> N \<and> x \<in> U \<and> y \<in> U \<and> (
      if i \<in> G
        then if y = c then x = c
        else if y = a then x = c \<or> x = a
        else if y = b then x = c \<or> x = a \<or> x = b
        else True
      else if y = a then True
      else if x = a then False
      else R\<^sub>N i x y
    )"

    interpret r: preference_profile U n R proof
      show "\<And>i x y. i \<in> N \<Longrightarrow> x \<notin> U \<or> y \<notin> U \<Longrightarrow> \<not> R i x y" unfolding R_def by blast
    next
      fix x y z :: 'a and i assume "i \<in> N" "R i x y" "R i y z"
      interpret pr: preference_relation U "R\<^sub>N i" using \<open>i \<in> N\<close> re.R\<^sub>N by auto
      show "R i x z" unfolding R_def using pr.transitive by (smt (z3) R_def \<open>R i x y\<close> \<open>R i y z\<close> \<open>i \<in> N\<close> ab) next
      show "\<And>i x. i \<in> N \<Longrightarrow> x \<in> U \<Longrightarrow> R i x x" unfolding R_def using re.refl by presburger
    next
      fix x y :: 'a and i assume "i \<in> N" "x \<in> U" "y \<in> U"
      interpret pr: preference_relation U "R\<^sub>N i" using \<open>i \<in> N\<close> re.R\<^sub>N by auto
      show "R i x y \<or> R i y x" unfolding R_def using pr.complete using \<open>i \<in> N\<close> \<open>x \<in> U\<close> \<open>y \<in> U\<close> by presburger next
      show "\<And>i x y. i \<notin> N \<or> x \<notin> U \<or> y \<notin> U \<Longrightarrow> \<not> R i x y" unfolding R_def by blast next
    qed

    interpret gr: preference_relation U "g R" by (simp add: g r.preference_profile_axioms)

    have "i \<in> G \<Longrightarrow> asymm (R i) c a" for i using GN R_def au ca cu by fastforce
    moreover have "i \<in> N-G \<Longrightarrow> asymm (R i) c a" for i using R_def ca au cu by force
    ultimately have gr_ca: "asymm (g R) c a" using R_def au pareto by force

    have gr_ab: "asymm (g R) a b" by (smt (verit, del_insts) D\<^sub>G_def G_R\<^sub>N_ab R_def ab au bu dg_ab r.preference_profile_axioms subsetD)
    have gr_cb: "asymm (g R) c b" using gr_ab gr_ca gr.transitive by blast
    have R_agree: "R\<^sub>N i c b = R i c b" for i using G_R\<^sub>N_ab R_def ca ab re.R\<^sub>N_domain by auto
    have g_R\<^sub>N_cb: "asymm (g R\<^sub>N) c b" using gr_cb IIA[of R\<^sub>N c b R, OF R_agree] by (smt (verit) G_R\<^sub>N_ab IIA R_def ca ab re.R\<^sub>N_domain)
  }
  thus "D\<^sub>G G c b" by (simp add: D\<^sub>G_def GN)
qed

end

(* Slide 66 *)
lemma field_expansion:
  fixes G
  assumes GN: "G \<sqsubseteq> N"
  assumes semi_decisive: "\<exists>a \<in> U. \<exists>b \<in> U. a \<noteq> b \<and> SD\<^sub>G G a b"
  shows "D G"
proof-
  from semi_decisive obtain a b
    where au: "a \<in> U"
      and bu: "b \<in> U"
      and ab: "a \<noteq> b"
      and sdg_ab: "SD\<^sub>G G a b"
    by auto

  have "U - {a, b} \<noteq> {}" proof (rule ccontr)
    assume "\<not> U - {a, b} \<noteq> {}"
    hence "U = {a, b}" using au bu by auto
    hence "card U = 2" using au bu ab by auto
    thus "False" using card_U by auto
  qed
  then obtain c where cu: "c \<in> U" and ca: "c \<noteq> a" and cb: "c \<noteq> b" by blast

  have dg_ab: "D\<^sub>G G a b" by (metis GN ab au bu ca cb cu first first' sdg_ab)
  note dg_ac = first[OF GN au bu cu ab ca cb sdg_ab]
  have dg_bc: "D\<^sub>G G b c" using GN au bu ca cb cu dg_ac second by blast
  have dg_ba: "D\<^sub>G G b a" using GN au bu ab cb ca cu dg_bc first' by blast

  {
    fix x y R\<^sub>N
    assume R\<^sub>N_pp: "preference_profile U n R\<^sub>N"
    assume G_agree_xy: "i \<in> G \<Longrightarrow> asymm (R\<^sub>N i) x y" for i
    have dg_by: "D\<^sub>G G b y" by (metis D\<^sub>G_def GN cb cu d_sd dg_ab dg_ba dg_bc first preference_profile.R\<^sub>N_domain)
    have "asymm (g R\<^sub>N) x y" by (smt (verit, ccfv_threshold) D\<^sub>G_def GN G_agree_xy R\<^sub>N_pp ab au bu dg_ab dg_by ex_min_if_finite filled_G preference_profile.R\<^sub>N_domain second)
  }
  thus "D G" by (simp add: GN social_welfare_function.D\<^sub>G_def social_welfare_function.D_def social_welfare_function_axioms)
qed

context
  fixes G :: "nat set"
  assumes GN: "G \<sqsubseteq> N"
  assumes G_decisive: "D G"
begin

(*
  Lemma: When partitioning a decisive group into two nonempty groups, then at least one of them is
  decisive as well.
*)
lemma split_decisive:
  fixes G\<^sub>1 G\<^sub>2 :: "nat set"
  assumes G\<^sub>1G: "G\<^sub>1 \<sqsubseteq> G"
      and G\<^sub>2G: "G\<^sub>2 \<sqsubseteq> G"
      and disjoint: "G\<^sub>1 \<inter> G\<^sub>2 = {}"
      and cover: "G\<^sub>1 \<union> G\<^sub>2 = G"
    shows "D G\<^sub>1 \<or> D G\<^sub>2"
proof -
  have G\<^sub>1N: "G\<^sub>1 \<sqsubseteq> N" using GN G\<^sub>1G by auto
  have G\<^sub>2N: "G\<^sub>2 \<sqsubseteq> N" using GN G\<^sub>2G by auto

  have "U \<noteq> {}" using nonempty_universe by auto
  then obtain a where au: "a \<in> U" by auto

  have "U \<noteq> {a}" using card_U by auto
  then obtain b where bu: "b \<in> U" and ab: "a \<noteq> b" using au by auto

  have "U \<noteq> {a, b}" using card_U au bu ab by auto
  then obtain c where cu: "c \<in> U" and ca: "c \<noteq> a" and bc: "b \<noteq> c" using au bu ab by auto

  define G\<^sub>1_rel :: "'a relation" where "G\<^sub>1_rel \<equiv> \<lambda>x y. x \<in> U \<and> y \<in> U \<and> (
    if y = a then x = a else
    if y = b then x = a \<or> x = b else
    if y = c then x = a \<or> x = b \<or> x = c else
    True
  )"
  interpret G\<^sub>1_pref: preference_relation U G\<^sub>1_rel
    apply unfold_locales unfolding G\<^sub>1_rel_def apply blast apply metis apply simp apply presburger done

  define G\<^sub>2_rel :: "'a relation" where "G\<^sub>2_rel \<equiv> \<lambda>x y. x \<in> U \<and> y \<in> U \<and> (
    if y = b then x = b else
    if y = c then x = b \<or> x = c else
    if y = a then x = b \<or> x = c \<or> x = a else
    True
  )"
  interpret G\<^sub>2_pref: preference_relation U G\<^sub>2_rel
    apply unfold_locales unfolding G\<^sub>2_rel_def apply blast apply metis apply simp apply presburger done

  define NG_rel :: "'a relation" where "NG_rel \<equiv> \<lambda>x y. x \<in> U \<and> y \<in> U \<and> (
    if y = c then x = c else
    if y = a then x = c \<or> x = a else
    if y = b then x = c \<or> x = a \<or> x = b else
    True
  )"
  interpret NG_pref: preference_relation U NG_rel
    apply unfold_locales unfolding NG_rel_def apply blast apply metis apply simp apply presburger done

  define R :: "nat set \<Rightarrow> nat set \<Rightarrow> 'a PP" where "R \<equiv> \<lambda>G\<^sub>1 G\<^sub>2 i x y. x \<in> U \<and> y \<in> U \<and> (
    if i \<in> G\<^sub>1 then G\<^sub>1_rel x y else
    if i \<in> G\<^sub>2 then G\<^sub>2_rel x y else
    if i \<in> N then NG_rel x y else
    False
  )"

  interpret R_pp: preference_profile U n "R G\<^sub>1 G\<^sub>2" proof unfold_locales
    show "\<And>i x y. i \<in> N \<Longrightarrow> x \<notin> U \<or> y \<notin> U \<Longrightarrow> \<not> R G\<^sub>1 G\<^sub>2 i x y" using R_def by blast
  next
    fix x y z :: 'a and i assume "i \<in> N" "R G\<^sub>1 G\<^sub>2 i x y" "R G\<^sub>1 G\<^sub>2 i y z"
    thus "R G\<^sub>1 G\<^sub>2 i x z" unfolding R_def by (metis (no_types, lifting) G\<^sub>1_pref.transitive G\<^sub>2_pref.transitive NG_pref.transitive) next
    show "\<And>i x. i \<in> N \<Longrightarrow> x \<in> U \<Longrightarrow> R G\<^sub>1 G\<^sub>2 i x x" unfolding R_def using G\<^sub>1_pref.reflexive G\<^sub>2_pref.reflexive NG_pref.reflexive by auto
  next
    fix x y :: 'a and i assume "i \<in> N" "x \<in> U" "y \<in> U"
    thus "R G\<^sub>1 G\<^sub>2 i x y \<or> R G\<^sub>1 G\<^sub>2 i y x" unfolding R_def using G\<^sub>1_pref.complete G\<^sub>2_pref.complete NG_pref.complete by auto next
    show "\<And>i x y. i \<notin> N \<or> x \<notin> U \<or> y \<notin> U \<Longrightarrow> \<not> R G\<^sub>1 G\<^sub>2 i x y" by (metis G\<^sub>1N G\<^sub>2N R_def psubsetD psubsetI)
  qed
  interpret g_R_pr: preference_relation U "g (R G\<^sub>1 G\<^sub>2)" using g[OF R_pp.preference_profile_axioms] .

  have G\<^sub>1_bc: "i \<in> G\<^sub>1 \<Longrightarrow> asymm (R G\<^sub>1 G\<^sub>2 i) b c" for i using G\<^sub>1_rel_def R_def bc bu ca cu by auto
  have G\<^sub>2_bc: "i \<in> G\<^sub>2 \<Longrightarrow> asymm (R G\<^sub>1 G\<^sub>2 i) b c" for i using G\<^sub>1_bc G\<^sub>2_rel_def R_def bc bu cu by auto
  have G_bc: "i \<in> G \<Longrightarrow> asymm (R G\<^sub>1 G\<^sub>2 i) b c" for i using cover G\<^sub>1_bc G\<^sub>2_bc by blast
  have g_bc: "asymm (g (R G\<^sub>1 G\<^sub>2)) b c" using G_decisive R_pp.preference_profile_axioms D\<^sub>G_def D_def G_bc by auto

  show "D G\<^sub>1 \<or> D G\<^sub>2" proof (cases "g (R G\<^sub>1 G\<^sub>2) c a")
    case True
    hence g_ba: "asymm (g (R G\<^sub>1 G\<^sub>2)) b a" by (metis R_pp.preference_profile_axioms g g_bc preference_relation.axioms(1) transitive_preference.transitive)
    have sdg_G\<^sub>2_ba: "SD\<^sub>G G\<^sub>2 b a" unfolding SD\<^sub>G_def proof
      show "G\<^sub>2 \<subseteq> N" using GN G\<^sub>2N by auto next
      {
        fix R\<^sub>N assume "preference_profile U n R\<^sub>N"
        then interpret R\<^sub>N_pp: preference_profile U n R\<^sub>N .

        assume assm: "(\<forall>i\<in>G\<^sub>2. asymm (R\<^sub>N i) b a) \<and> (\<forall>i\<in>N - G\<^sub>2. asymm (R\<^sub>N i) a b)"
        hence in_G\<^sub>2: "i\<in>G\<^sub>2 \<Longrightarrow> asymm (R\<^sub>N i) b a" for i by auto

        have RG\<^sub>2_ba: "i \<in> G\<^sub>2 \<Longrightarrow> asymm (R G\<^sub>1 G\<^sub>2 i) b a" for i unfolding R_def G\<^sub>2_rel_def by (smt (z3) IntI R\<^sub>N_pp.R\<^sub>N_domain disjoint empty_iff in_G\<^sub>2)
        have R_not_G\<^sub>2_ab: "i \<in> N-G\<^sub>2 \<Longrightarrow> asymm (R G\<^sub>1 G\<^sub>2 i) a b" for i unfolding R_def G\<^sub>1_rel_def NG_rel_def using ab au bc bu by auto
        have R\<^sub>N_G\<^sub>2_ba: "i \<in> G\<^sub>2 \<Longrightarrow> asymm (R\<^sub>N i) b a" for i by (smt (z3) IntI R\<^sub>N_pp.R\<^sub>N_domain disjoint empty_iff in_G\<^sub>2)
        have R\<^sub>N_not_G\<^sub>2_ba: "i \<in> N-G\<^sub>2 \<Longrightarrow> asymm (R\<^sub>N i) a b" for i using assm by auto

        have "asymm (g R\<^sub>N) b a = asymm (g (R G\<^sub>1 G\<^sub>2)) b a" by (metis Diff_iff IIA R\<^sub>N_pp.R\<^sub>N_domain R_pp.R\<^sub>N_domain RG\<^sub>2_ba R_not_G\<^sub>2_ab assm g_ba in_G\<^sub>2)
        hence "asymm (g R\<^sub>N) b a" using g_ba by simp
      }
      thus "\<forall>R\<^sub>N. preference_profile U n R\<^sub>N \<longrightarrow> (\<forall>i\<in>G\<^sub>2. asymm (R\<^sub>N i) b a) \<and> (\<forall>i\<in>N - G\<^sub>2. asymm (R\<^sub>N i) a b) \<longrightarrow> asymm (g R\<^sub>N) b a " by auto
    qed
    show ?thesis by (metis G\<^sub>2N sdg_G\<^sub>2_ba ab au bu field_expansion)
  next
    case False
    hence g_ca: "asymm (g (R G\<^sub>1 G\<^sub>2)) a c" using g_R_pr.complete au cu by blast

    have sdg_G\<^sub>1ac: "SD\<^sub>G G\<^sub>1 a c" unfolding SD\<^sub>G_def proof
      show "G\<^sub>1 \<subseteq> N" using GN G\<^sub>1N by auto next
      {
        fix R\<^sub>N
        assume "preference_profile U n R\<^sub>N"
        then interpret R\<^sub>N_pp: preference_profile U n R\<^sub>N .
        assume assm: "(\<forall>i\<in>G\<^sub>1. asymm (R\<^sub>N i) a c) \<and> (\<forall>i\<in>N - G\<^sub>1. asymm (R\<^sub>N i) c a)"
        hence in_G\<^sub>1: "i\<in>G\<^sub>1 \<Longrightarrow> asymm (R\<^sub>N i) a c" for i by auto

        have RG\<^sub>1_ac: "i \<in> G\<^sub>1 \<Longrightarrow> asymm (R G\<^sub>1 G\<^sub>2 i) a c" for i unfolding R_def G\<^sub>1_rel_def by (smt (z3) IntI R\<^sub>N_pp.R\<^sub>N_domain disjoint empty_iff in_G\<^sub>1)
        have R_not_G\<^sub>1_ca: "i \<in> N-G\<^sub>1 \<Longrightarrow> asymm (R G\<^sub>1 G\<^sub>2 i) c a" for i unfolding R_def G\<^sub>1_rel_def NG_rel_def using ab au bc bu G\<^sub>2_rel_def ca cu by force
        have R\<^sub>N_G\<^sub>1_ac: "i \<in> G\<^sub>1 \<Longrightarrow> asymm (R\<^sub>N i) a c" for i by (smt (z3) IntI R\<^sub>N_pp.R\<^sub>N_domain disjoint empty_iff in_G\<^sub>1)
        have R\<^sub>N_not_G\<^sub>1_ac: "i \<in> N-G\<^sub>1 \<Longrightarrow> asymm (R\<^sub>N i) c a" for i using assm by auto

        have "asymm (g R\<^sub>N) a c = asymm (g (R G\<^sub>1 G\<^sub>2)) a c" by (metis Diff_iff IIA R\<^sub>N_pp.R\<^sub>N_domain R_pp.R\<^sub>N_domain RG\<^sub>1_ac R_not_G\<^sub>1_ca assm g_ca in_G\<^sub>1)
        hence "asymm (g R\<^sub>N) a c" using g_ca by simp
      }
      thus "\<forall>R\<^sub>N. preference_profile U n R\<^sub>N \<longrightarrow> (\<forall>i\<in>G\<^sub>1. asymm (R\<^sub>N i) a c) \<and> (\<forall>i\<in>N - G\<^sub>1. asymm (R\<^sub>N i) c a) \<longrightarrow> asymm (g R\<^sub>N) a c" by auto
    qed
    show ?thesis by (metis G\<^sub>1N au ca cu field_expansion sdg_G\<^sub>1ac)
  qed
qed

(*
  Partition a decisive group G into nonempty blocks and use the above theorem to show that therefore
  G has a decisive subset.
*)
lemma decisive_subset:
  assumes "card G \<noteq> 1"
  shows "\<exists>G' \<subset> G. G' \<noteq> {} \<and> D G'"
proof -
  have "filled G" using GN filled_G by auto

  obtain g where "g \<in> G" using \<open>filled G\<close> by auto
  define G\<^sub>1 :: "nat set" where "G\<^sub>1 \<equiv> {g}"
  define G\<^sub>2 :: "nat set" where "G\<^sub>2 \<equiv> G - {g}"

  have "card G - 1 \<le> card G\<^sub>2" using G\<^sub>2_def by (metis \<open>filled G\<close> \<open>g \<in> G\<close> card_Diff_singleton order_eq_iff)
  hence "G\<^sub>2 \<noteq> {}" using \<open>card G \<noteq> 1\<close> \<open>filled G\<close> by (metis G\<^sub>2_def \<open>g \<in> G\<close> insert_Diff is_singletonI is_singleton_altdef)

  have "G\<^sub>1 \<sqsubseteq> G" unfolding G\<^sub>1_def by (simp add: \<open>g \<in> G\<close>)
  moreover have "G\<^sub>2 \<sqsubseteq> G" unfolding G\<^sub>2_def using G\<^sub>2_def \<open>G\<^sub>2 \<noteq> {}\<close> by blast
  moreover have "G\<^sub>1 \<inter> G\<^sub>2 = {}" unfolding G\<^sub>1_def G\<^sub>2_def using G\<^sub>2_def \<open>G\<^sub>2 \<noteq> {}\<close> by blast
  moreover have "G\<^sub>1 \<union> G\<^sub>2 = G" unfolding G\<^sub>1_def G\<^sub>2_def using \<open>g \<in> G\<close> by auto
  ultimately have "D G\<^sub>1 \<or> D G\<^sub>2" using split_decisive by metis

  thus ?thesis proof
    assume "D G\<^sub>1"
    hence "G\<^sub>1 \<subset> G \<and> (filled G) \<and> G\<^sub>1 \<sqsubseteq> N \<and> D G\<^sub>1" using D_def G\<^sub>1_def G\<^sub>2_def \<open>D G\<^sub>1\<close> \<open>G\<^sub>1 \<sqsubseteq> G\<close> \<open>G\<^sub>2 \<sqsubseteq> G\<close> \<open>filled G\<close> by auto
    thus ?thesis using finite_subset by auto
  next
    assume "D G\<^sub>2"
    have "G\<^sub>2 \<subset> G \<and> (filled G) \<and> G\<^sub>2 \<sqsubseteq> N \<and> D G\<^sub>2" using G\<^sub>2_def \<open>D G\<^sub>2\<close> \<open>G \<sqsubseteq> N\<close> \<open>D G\<close> \<open>G\<^sub>2 \<sqsubseteq> G\<close> \<open>filled G\<close> \<open>g \<in> G\<close> by blast
    thus ?thesis using finite_subset by auto
  qed
qed

end

end

(* Arrows impossibility theorem *)
(*
  We take a decisive group (here the group N of all voters is decisive because of pareto
  optimality) and keep splitting it until we arrive at a decisive group of a single voter. That
  voter is therefore a dictator.
*)
sublocale IIA_pareto_3 \<subseteq> dictatorial proof(unfold_locales)
  (* The invariant *)
  define P where "P \<equiv> \<lambda>G. G \<sqsubseteq> N \<and> D G"

  have initial: "P N" unfolding P_def D\<^sub>G_def D_def using pareto by (metis empty_iff subset_refl)
  have step: "P s \<and> s \<sqsubseteq> N \<and> card s \<noteq> 1 \<Longrightarrow> \<exists>G'. P G' \<and> G' \<subseteq> N \<and> G' \<noteq> {} \<and> G' \<subset> s" for s unfolding P_def using decisive_subset by (metis D_def)

  obtain d where "d \<in> N" "D {d}" using subset_descent[of N P, OF filled_N initial, simplified, OF step] P_def by auto
  hence "D\<^sub>G {d} a b" for a b unfolding D_def by auto
  hence "preference_profile U n R\<^sub>N \<longrightarrow> (\<forall>i \<in> {d}. asymm (R\<^sub>N i) a b) \<longrightarrow> asymm (g R\<^sub>N) a b" for R\<^sub>N a b unfolding D\<^sub>G_def by auto
  thus "\<exists>d \<in> N. is_dictator d" using \<open>d \<in> N\<close> by auto
qed

end


(*  Author:     John Harrison
    Author:     Robert Himmelmann, TU Muenchen (translation from HOL light)
*)

section \<open>Fashoda Meet Theorem\<close>

theory Fashoda_Theorem
imports Brouwer_Fixpoint Path_Connected Cartesian_Euclidean_Space
begin

subsection \<open>Bijections between intervals\<close>

definition\<^marker>\<open>tag important\<close> interval_bij :: "'a \<times> 'a \<Rightarrow> 'a \<times> 'a \<Rightarrow> 'a \<Rightarrow> 'a::euclidean_space"
  where "interval_bij =
    (\<lambda>(a, b) (u, v) x. (\<Sum>i\<in>Basis. (u\<bullet>i + (x\<bullet>i - a\<bullet>i) / (b\<bullet>i - a\<bullet>i) * (v\<bullet>i - u\<bullet>i)) *\<^sub>R i))"

lemma interval_bij_affine:
  "interval_bij (a,b) (u,v) = (\<lambda>x. (\<Sum>i\<in>Basis. ((v\<bullet>i - u\<bullet>i) / (b\<bullet>i - a\<bullet>i) * (x\<bullet>i)) *\<^sub>R i) +
    (\<Sum>i\<in>Basis. (u\<bullet>i - (v\<bullet>i - u\<bullet>i) / (b\<bullet>i - a\<bullet>i) * (a\<bullet>i)) *\<^sub>R i))"
  by (auto simp add: interval_bij_def sum.distrib [symmetric] scaleR_add_left [symmetric]
    fun_eq_iff intro!: sum.cong)
    (simp add: algebra_simps diff_divide_distrib [symmetric])

lemma continuous_interval_bij:
  fixes a b :: "'a::euclidean_space"
  shows "continuous (at x) (interval_bij (a, b) (u, v))"
  by (auto simp add: divide_inverse interval_bij_def intro!: continuous_sum continuous_intros)

lemma continuous_on_interval_bij: "continuous_on s (interval_bij (a, b) (u, v))"
  apply(rule continuous_at_imp_continuous_on)
  apply (rule, rule continuous_interval_bij)
  done

lemma in_interval_interval_bij:
  fixes a b u v x :: "'a::euclidean_space"
  assumes "x \<in> cbox a b"
    and "cbox u v \<noteq> {}"
  shows "interval_bij (a, b) (u, v) x \<in> cbox u v"
  apply (simp only: interval_bij_def split_conv mem_box inner_sum_left_Basis cong: ball_cong)
  apply safe
proof -
  fix i :: 'a
  assume i: "i \<in> Basis"
  have "cbox a b \<noteq> {}"
    using assms by auto
  with i have *: "a\<bullet>i \<le> b\<bullet>i" "u\<bullet>i \<le> v\<bullet>i"
    using assms(2) by (auto simp add: box_eq_empty)
  have x: "a\<bullet>i\<le>x\<bullet>i" "x\<bullet>i\<le>b\<bullet>i"
    using assms(1)[unfolded mem_box] using i by auto
  have "0 \<le> (x \<bullet> i - a \<bullet> i) / (b \<bullet> i - a \<bullet> i) * (v \<bullet> i - u \<bullet> i)"
    using * x by auto
  then show "u \<bullet> i \<le> u \<bullet> i + (x \<bullet> i - a \<bullet> i) / (b \<bullet> i - a \<bullet> i) * (v \<bullet> i - u \<bullet> i)"
    using * by auto
  have "((x \<bullet> i - a \<bullet> i) / (b \<bullet> i - a \<bullet> i)) * (v \<bullet> i - u \<bullet> i) \<le> 1 * (v \<bullet> i - u \<bullet> i)"
    apply (rule mult_right_mono)
    unfolding divide_le_eq_1
    using * x
    apply auto
    done
  then show "u \<bullet> i + (x \<bullet> i - a \<bullet> i) / (b \<bullet> i - a \<bullet> i) * (v \<bullet> i - u \<bullet> i) \<le> v \<bullet> i"
    using * by auto
qed

lemma interval_bij_bij:
  "\<forall>(i::'a::euclidean_space)\<in>Basis. a\<bullet>i < b\<bullet>i \<and> u\<bullet>i < v\<bullet>i \<Longrightarrow>
    interval_bij (a, b) (u, v) (interval_bij (u, v) (a, b) x) = x"
  by (auto simp: interval_bij_def euclidean_eq_iff[where 'a='a])

lemma interval_bij_bij_cart: fixes x::"real^'n" assumes "\<forall>i. a$i < b$i \<and> u$i < v$i"
  shows "interval_bij (a,b) (u,v) (interval_bij (u,v) (a,b) x) = x"
  using assms by (intro interval_bij_bij) (auto simp: Basis_vec_def inner_axis)

subsection \<open>Fashoda meet theorem\<close>

lemma infnorm_2:
  fixes x :: "real^2"
  shows "infnorm x = max \<bar>x$1\<bar> \<bar>x$2\<bar>"
  unfolding infnorm_cart UNIV_2 by (rule cSup_eq) auto

lemma infnorm_eq_1_2:
  fixes x :: "real^2"
  shows "infnorm x = 1 \<longleftrightarrow>
    \<bar>x$1\<bar> \<le> 1 \<and> \<bar>x$2\<bar> \<le> 1 \<and> (x$1 = -1 \<or> x$1 = 1 \<or> x$2 = -1 \<or> x$2 = 1)"
  unfolding infnorm_2 by auto

lemma infnorm_eq_1_imp:
  fixes x :: "real^2"
  assumes "infnorm x = 1"
  shows "\<bar>x$1\<bar> \<le> 1" and "\<bar>x$2\<bar> \<le> 1"
  using assms unfolding infnorm_eq_1_2 by auto

proposition fashoda_unit:
  fixes f g :: "real \<Rightarrow> real^2"
  assumes "f ` {-1 .. 1} \<subseteq> cbox (-1) 1"
    and "g ` {-1 .. 1} \<subseteq> cbox (-1) 1"
    and "continuous_on {-1 .. 1} f"
    and "continuous_on {-1 .. 1} g"
    and "f (- 1)$1 = - 1"
    and "f 1$1 = 1" "g (- 1) $2 = -1"
    and "g 1 $2 = 1"
  shows "\<exists>s\<in>{-1 .. 1}. \<exists>t\<in>{-1 .. 1}. f s = g t"
proof (rule ccontr)
  assume "\<not> ?thesis"
  note as = this[unfolded bex_simps,rule_format]
  define sqprojection
    where [abs_def]: "sqprojection z = (inverse (infnorm z)) *\<^sub>R z" for z :: "real^2"
  define negatex :: "real^2 \<Rightarrow> real^2"
    where "negatex x = (vector [-(x$1), x$2])" for x
  have lem1: "\<forall>z::real^2. infnorm (negatex z) = infnorm z"
    unfolding negatex_def infnorm_2 vector_2 by auto
  have lem2: "\<forall>z. z \<noteq> 0 \<longrightarrow> infnorm (sqprojection z) = 1"
    unfolding sqprojection_def infnorm_mul[unfolded scalar_mult_eq_scaleR]
    by (simp add: real_abs_infnorm infnorm_eq_0)
  let ?F = "\<lambda>w::real^2. (f \<circ> (\<lambda>x. x$1)) w - (g \<circ> (\<lambda>x. x$2)) w"
  have *: "\<And>i. (\<lambda>x::real^2. x $ i) ` cbox (- 1) 1 = {-1..1}"
  proof
    show "(\<lambda>x::real^2. x $ i) ` cbox (- 1) 1 \<subseteq> {-1..1}" for i
      by (auto simp: mem_box_cart)
    show "{-1..1} \<subseteq> (\<lambda>x::real^2. x $ i) ` cbox (- 1) 1" for i
      by (clarsimp simp: image_iff mem_box_cart Bex_def) (metis (no_types, opaque_lifting) vec_component)
  qed
  {
    fix x
    assume "x \<in> (\<lambda>w. (f \<circ> (\<lambda>x. x $ 1)) w - (g \<circ> (\<lambda>x. x $ 2)) w) ` (cbox (- 1) (1::real^2))"
    then obtain w :: "real^2" where w:
        "w \<in> cbox (- 1) 1"
        "x = (f \<circ> (\<lambda>x. x $ 1)) w - (g \<circ> (\<lambda>x. x $ 2)) w"
      unfolding image_iff ..
    then have "x \<noteq> 0"
      using as[of "w$1" "w$2"]
      unfolding mem_box_cart atLeastAtMost_iff
      by auto
  } note x0 = this
  have 1: "box (- 1) (1::real^2) \<noteq> {}"
    unfolding interval_eq_empty_cart by auto
  have "negatex (x + y) $ i = (negatex x + negatex y) $ i \<and> negatex (c *\<^sub>R x) $ i = (c *\<^sub>R negatex x) $ i"
    for i x y c
    using exhaust_2 [of i] by (auto simp: negatex_def)
  then have "bounded_linear negatex"
    by (simp add: bounded_linearI' vec_eq_iff)
  then have 2: "continuous_on (cbox (- 1) 1) (negatex \<circ> sqprojection \<circ> ?F)"
    apply (intro continuous_intros continuous_on_component)
    unfolding * sqprojection_def
    apply (intro assms continuous_intros)+
     apply (simp_all add: infnorm_eq_0 x0 linear_continuous_on)
    done
  have 3: "(negatex \<circ> sqprojection \<circ> ?F) ` cbox (-1) 1 \<subseteq> cbox (-1) 1"
    unfolding subset_eq
  proof (rule, goal_cases)
    case (1 x)
    then obtain y :: "real^2" where y:
        "y \<in> cbox (- 1) 1"
        "x = (negatex \<circ> sqprojection \<circ> (\<lambda>w. (f \<circ> (\<lambda>x. x $ 1)) w - (g \<circ> (\<lambda>x. x $ 2)) w)) y"
      unfolding image_iff ..
    have "?F y \<noteq> 0"
      by (rule x0) (use y in auto)
    then have *: "infnorm (sqprojection (?F y)) = 1"
      unfolding y o_def
      by - (rule lem2[rule_format])
    have inf1: "infnorm x = 1"
      unfolding *[symmetric] y o_def
      by (rule lem1[rule_format])
    show "x \<in> cbox (-1) 1"
      unfolding mem_box_cart interval_cbox_cart infnorm_2
    proof
      fix i
      show "(- 1) $ i \<le> x $ i \<and> x $ i \<le> 1 $ i"
        using exhaust_2 [of i] inf1 by (auto simp: infnorm_2)
    qed
  qed
  obtain x :: "real^2" where x:
      "x \<in> cbox (- 1) 1"
      "(negatex \<circ> sqprojection \<circ> (\<lambda>w. (f \<circ> (\<lambda>x. x $ 1)) w - (g \<circ> (\<lambda>x. x $ 2)) w)) x = x"
    apply (rule brouwer_weak[of "cbox (- 1) (1::real^2)" "negatex \<circ> sqprojection \<circ> ?F"])
    apply (rule compact_cbox convex_box)+
    unfolding interior_cbox
    apply (rule 1 2 3)+
    apply blast
    done
  have "?F x \<noteq> 0"
    by (rule x0) (use x in auto)
  then have *: "infnorm (sqprojection (?F x)) = 1"
    unfolding o_def
    by (rule lem2[rule_format])
  have nx: "infnorm x = 1"
    apply (subst x(2)[symmetric])
    unfolding *[symmetric] o_def
    apply (rule lem1[rule_format])
    done
  have iff: "0 < sqprojection x$i \<longleftrightarrow> 0 < x$i" "sqprojection x$i < 0 \<longleftrightarrow> x$i < 0" if "x \<noteq> 0" for x i
  proof -
    have "inverse (infnorm x) > 0"
      by (simp add: infnorm_pos_lt that)
    then show "(0 < sqprojection x $ i) = (0 < x $ i)"
      and "(sqprojection x $ i < 0) = (x $ i < 0)"
      unfolding sqprojection_def vector_component_simps vector_scaleR_component real_scaleR_def
      unfolding zero_less_mult_iff mult_less_0_iff
      by (auto simp add: field_simps)
  qed
  have x1: "x $ 1 \<in> {- 1..1::real}" "x $ 2 \<in> {- 1..1::real}"
    using x(1) unfolding mem_box_cart by auto
  then have nz: "f (x $ 1) - g (x $ 2) \<noteq> 0"
    using as by auto
  consider "x $ 1 = -1" | "x $ 1 = 1" | "x $ 2 = -1" | "x $ 2 = 1"
    using nx unfolding infnorm_eq_1_2 by auto
  then show False
  proof cases
    case 1
    then have *: "f (x $ 1) $ 1 = - 1"
      using assms(5) by auto
    have "sqprojection (f (x$1) - g (x$2)) $ 1 > 0"
      using x(2)[unfolded o_def vec_eq_iff,THEN spec[where x=1]]
      by (auto simp: negatex_def 1)
    moreover
    from x1 have "g (x $ 2) \<in> cbox (-1) 1"
      using assms(2) by blast
    ultimately show False
      unfolding iff[OF nz] vector_component_simps * mem_box_cart
      using not_le by auto
  next
    case 2
    then have *: "f (x $ 1) $ 1 = 1"
      using assms(6) by auto
    have "sqprojection (f (x$1) - g (x$2)) $ 1 < 0"
      using x(2)[unfolded o_def vec_eq_iff,THEN spec[where x=1]] 2
      by (auto simp: negatex_def)
    moreover have "g (x $ 2) \<in> cbox (-1) 1"
      using assms(2) x1 by blast
    ultimately show False
      unfolding iff[OF nz] vector_component_simps * mem_box_cart
      using not_le by auto
  next
    case 3
    then have *: "g (x $ 2) $ 2 = - 1"
      using assms(7) by auto
    have "sqprojection (f (x$1) - g (x$2)) $ 2 < 0"
      using x(2)[unfolded o_def vec_eq_iff,THEN spec[where x=2]] 3 by (auto simp: negatex_def)
    moreover
    from x1 have "f (x $ 1) \<in> cbox (-1) 1"
      using assms(1) by blast
    ultimately show False
      unfolding iff[OF nz] vector_component_simps * mem_box_cart
      by (erule_tac x=2 in allE) auto
  next
    case 4
    then have *: "g (x $ 2) $ 2 = 1"
      using assms(8) by auto
    have "sqprojection (f (x$1) - g (x$2)) $ 2 > 0"
      using x(2)[unfolded o_def vec_eq_iff,THEN spec[where x=2]] 4 by (auto simp: negatex_def)
    moreover
    from x1 have "f (x $ 1) \<in> cbox (-1) 1"
      using assms(1) by blast
    ultimately show False
      unfolding iff[OF nz] vector_component_simps * mem_box_cart
      by (erule_tac x=2 in allE) auto
  qed
qed

proposition fashoda_unit_path:
  fixes f g :: "real \<Rightarrow> real^2"
  assumes "path f"
    and "path g"
    and "path_image f \<subseteq> cbox (-1) 1"
    and "path_image g \<subseteq> cbox (-1) 1"
    and "(pathstart f)$1 = -1"
    and "(pathfinish f)$1 = 1"
    and "(pathstart g)$2 = -1"
    and "(pathfinish g)$2 = 1"
  obtains z where "z \<in> path_image f" and "z \<in> path_image g"
proof -
  note assms=assms[unfolded path_def pathstart_def pathfinish_def path_image_def]
  define iscale where [abs_def]: "iscale z = inverse 2 *\<^sub>R (z + 1)" for z :: real
  have isc: "iscale ` {- 1..1} \<subseteq> {0..1}"
    unfolding iscale_def by auto
  have "\<exists>s\<in>{- 1..1}. \<exists>t\<in>{- 1..1}. (f \<circ> iscale) s = (g \<circ> iscale) t"
  proof (rule fashoda_unit)
    show "(f \<circ> iscale) ` {- 1..1} \<subseteq> cbox (- 1) 1" "(g \<circ> iscale) ` {- 1..1} \<subseteq> cbox (- 1) 1"
      using isc and assms(3-4) by (auto simp add: image_comp [symmetric])
    have *: "continuous_on {- 1..1} iscale"
      unfolding iscale_def by (rule continuous_intros)+
    show "continuous_on {- 1..1} (f \<circ> iscale)" "continuous_on {- 1..1} (g \<circ> iscale)"
      apply -
      apply (rule_tac[!] continuous_on_compose[OF *])
      apply (rule_tac[!] continuous_on_subset[OF _ isc])
      apply (rule assms)+
      done
    have *: "(1 / 2) *\<^sub>R (1 + (1::real^1)) = 1"
      unfolding vec_eq_iff by auto
    show "(f \<circ> iscale) (- 1) $ 1 = - 1"
      and "(f \<circ> iscale) 1 $ 1 = 1"
      and "(g \<circ> iscale) (- 1) $ 2 = -1"
      and "(g \<circ> iscale) 1 $ 2 = 1"
      unfolding o_def iscale_def
      using assms
      by (auto simp add: *)
  qed
  then obtain s t where st:
      "s \<in> {- 1..1}"
      "t \<in> {- 1..1}"
      "(f \<circ> iscale) s = (g \<circ> iscale) t"
    by auto
  show thesis
    apply (rule_tac z = "f (iscale s)" in that)
    using st
    unfolding o_def path_image_def image_iff
    apply -
    apply (rule_tac x="iscale s" in bexI)
    prefer 3
    apply (rule_tac x="iscale t" in bexI)
    using isc[unfolded subset_eq, rule_format]
    apply auto
    done
qed

theorem fashoda:
  fixes b :: "real^2"
  assumes "path f"
    and "path g"
    and "path_image f \<subseteq> cbox a b"
    and "path_image g \<subseteq> cbox a b"
    and "(pathstart f)$1 = a$1"
    and "(pathfinish f)$1 = b$1"
    and "(pathstart g)$2 = a$2"
    and "(pathfinish g)$2 = b$2"
  obtains z where "z \<in> path_image f" and "z \<in> path_image g"
proof -
  fix P Q S
  presume "P \<or> Q \<or> S" "P \<Longrightarrow> thesis" and "Q \<Longrightarrow> thesis" and "S \<Longrightarrow> thesis"
  then show thesis
    by auto
next
  have "cbox a b \<noteq> {}"
    using assms(3) using path_image_nonempty[of f] by auto
  then have "a \<le> b"
    unfolding interval_eq_empty_cart less_eq_vec_def by (auto simp add: not_less)
  then show "a$1 = b$1 \<or> a$2 = b$2 \<or> (a$1 < b$1 \<and> a$2 < b$2)"
    unfolding less_eq_vec_def forall_2 by auto
next
  assume as: "a$1 = b$1"
  have "\<exists>z\<in>path_image g. z$2 = (pathstart f)$2"
    apply (rule connected_ivt_component_cart)
    apply (rule connected_path_image assms)+
    apply (rule pathstart_in_path_image)
    apply (rule pathfinish_in_path_image)
    unfolding assms using assms(3)[unfolded path_image_def subset_eq,rule_format,of "f 0"]
    unfolding pathstart_def
    apply (auto simp add: less_eq_vec_def mem_box_cart)
    done
  then obtain z :: "real^2" where z: "z \<in> path_image g" "z $ 2 = pathstart f $ 2" ..
  have "z \<in> cbox a b"
    using z(1) assms(4)
    unfolding path_image_def
    by blast
  then have "z = f 0"
    unfolding vec_eq_iff forall_2
    unfolding z(2) pathstart_def
    using assms(3)[unfolded path_image_def subset_eq mem_box_cart,rule_format,of "f 0" 1]
    unfolding mem_box_cart
    apply (erule_tac x=1 in allE)
    using as
    apply auto
    done
  then show thesis
    apply -
    apply (rule that[OF _ z(1)])
    unfolding path_image_def
    apply auto
    done
next
  assume as: "a$2 = b$2"
  have "\<exists>z\<in>path_image f. z$1 = (pathstart g)$1"
    apply (rule connected_ivt_component_cart)
    apply (rule connected_path_image assms)+
    apply (rule pathstart_in_path_image)
    apply (rule pathfinish_in_path_image)
    unfolding assms
    using assms(4)[unfolded path_image_def subset_eq,rule_format,of "g 0"]
    unfolding pathstart_def
    apply (auto simp add: less_eq_vec_def mem_box_cart)
    done
  then obtain z where z: "z \<in> path_image f" "z $ 1 = pathstart g $ 1" ..
  have "z \<in> cbox a b"
    using z(1) assms(3)
    unfolding path_image_def
    by blast
  then have "z = g 0"
    unfolding vec_eq_iff forall_2
    unfolding z(2) pathstart_def
    using assms(4)[unfolded path_image_def subset_eq mem_box_cart,rule_format,of "g 0" 2]
    unfolding mem_box_cart
    apply (erule_tac x=2 in allE)
    using as
    apply auto
    done
  then show thesis
    apply -
    apply (rule that[OF z(1)])
    unfolding path_image_def
    apply auto
    done
next
  assume as: "a $ 1 < b $ 1 \<and> a $ 2 < b $ 2"
  have int_nem: "cbox (-1) (1::real^2) \<noteq> {}"
    unfolding interval_eq_empty_cart by auto
  obtain z :: "real^2" where z:
      "z \<in> (interval_bij (a, b) (- 1, 1) \<circ> f) ` {0..1}"
      "z \<in> (interval_bij (a, b) (- 1, 1) \<circ> g) ` {0..1}"
    apply (rule fashoda_unit_path[of "interval_bij (a,b) (- 1,1) \<circ> f" "interval_bij (a,b) (- 1,1) \<circ> g"])
    unfolding path_def path_image_def pathstart_def pathfinish_def
    apply (rule_tac[1-2] continuous_on_compose)
    apply (rule assms[unfolded path_def] continuous_on_interval_bij)+
    unfolding subset_eq
    apply(rule_tac[1-2] ballI)
  proof -
    fix x
    assume "x \<in> (interval_bij (a, b) (- 1, 1) \<circ> f) ` {0..1}"
    then obtain y where y:
        "y \<in> {0..1}"
        "x = (interval_bij (a, b) (- 1, 1) \<circ> f) y"
      unfolding image_iff ..
    show "x \<in> cbox (- 1) 1"
      unfolding y o_def
      apply (rule in_interval_interval_bij)
      using y(1)
      using assms(3)[unfolded path_image_def subset_eq] int_nem
      apply auto
      done
  next
    fix x
    assume "x \<in> (interval_bij (a, b) (- 1, 1) \<circ> g) ` {0..1}"
    then obtain y where y:
        "y \<in> {0..1}"
        "x = (interval_bij (a, b) (- 1, 1) \<circ> g) y"
      unfolding image_iff ..
    show "x \<in> cbox (- 1) 1"
      unfolding y o_def
      apply (rule in_interval_interval_bij)
      using y(1)
      using assms(4)[unfolded path_image_def subset_eq] int_nem
      apply auto
      done
  next
    show "(interval_bij (a, b) (- 1, 1) \<circ> f) 0 $ 1 = -1"
      and "(interval_bij (a, b) (- 1, 1) \<circ> f) 1 $ 1 = 1"
      and "(interval_bij (a, b) (- 1, 1) \<circ> g) 0 $ 2 = -1"
      and "(interval_bij (a, b) (- 1, 1) \<circ> g) 1 $ 2 = 1"
      using assms as
      by (simp_all add: cart_eq_inner_axis pathstart_def pathfinish_def interval_bij_def)
         (simp_all add: inner_axis)
  qed
  from z(1) obtain zf where zf:
      "zf \<in> {0..1}"
      "z = (interval_bij (a, b) (- 1, 1) \<circ> f) zf"
    unfolding image_iff ..
  from z(2) obtain zg where zg:
      "zg \<in> {0..1}"
      "z = (interval_bij (a, b) (- 1, 1) \<circ> g) zg"
    unfolding image_iff ..
  have *: "\<forall>i. (- 1) $ i < (1::real^2) $ i \<and> a $ i < b $ i"
    unfolding forall_2
    using as
    by auto
  show thesis
  proof (rule_tac z="interval_bij (- 1,1) (a,b) z" in that)
    show "interval_bij (- 1, 1) (a, b) z \<in> path_image f"
      using zf by (simp add: interval_bij_bij_cart[OF *] path_image_def)
    show "interval_bij (- 1, 1) (a, b) z \<in> path_image g"
      using zg by (simp add: interval_bij_bij_cart[OF *] path_image_def)
  qed
qed

subsection\<^marker>\<open>tag unimportant\<close> \<open>Some slightly ad hoc lemmas I use below\<close>

lemma segment_vertical:
  fixes a :: "real^2"
  assumes "a$1 = b$1"
  shows "x \<in> closed_segment a b \<longleftrightarrow>
    x$1 = a$1 \<and> x$1 = b$1 \<and> (a$2 \<le> x$2 \<and> x$2 \<le> b$2 \<or> b$2 \<le> x$2 \<and> x$2 \<le> a$2)"
  (is "_ = ?R")
proof -
  let ?L = "\<exists>u. (x $ 1 = (1 - u) * a $ 1 + u * b $ 1 \<and> x $ 2 = (1 - u) * a $ 2 + u * b $ 2) \<and> 0 \<le> u \<and> u \<le> 1"
  {
    presume "?L \<Longrightarrow> ?R" and "?R \<Longrightarrow> ?L"
    then show ?thesis
      unfolding closed_segment_def mem_Collect_eq
      unfolding vec_eq_iff forall_2 scalar_mult_eq_scaleR[symmetric] vector_component_simps
      by blast
  }
  {
    assume ?L
    then obtain u where u:
        "x $ 1 = (1 - u) * a $ 1 + u * b $ 1"
        "x $ 2 = (1 - u) * a $ 2 + u * b $ 2"
        "0 \<le> u"
        "u \<le> 1"
      by blast
    { fix b a
      assume "b + u * a > a + u * b"
      then have "(1 - u) * b > (1 - u) * a"
        by (auto simp add:field_simps)
      then have "b \<ge> a"
        apply (drule_tac mult_left_less_imp_less)
        using u
        apply auto
        done
      then have "u * a \<le> u * b"
        apply -
        apply (rule mult_left_mono[OF _ u(3)])
        using u(3-4)
        apply (auto simp add: field_simps)
        done
    } note * = this
    {
      fix a b
      assume "u * b > u * a"
      then have "(1 - u) * a \<le> (1 - u) * b"
        apply -
        apply (rule mult_left_mono)
        apply (drule mult_left_less_imp_less)
        using u
        apply auto
        done
      then have "a + u * b \<le> b + u * a"
        by (auto simp add: field_simps)
    } note ** = this
    then show ?R
      unfolding u assms
      using u
      by (auto simp add:field_simps not_le intro: * **)
  }
  {
    assume ?R
    then show ?L
    proof (cases "x$2 = b$2")
      case True
      then show ?L
        apply (rule_tac x="(x$2 - a$2) / (b$2 - a$2)" in exI)
        unfolding assms True using \<open>?R\<close> apply (auto simp add: field_simps)
        done
    next
      case False
      then show ?L
        apply (rule_tac x="1 - (x$2 - b$2) / (a$2 - b$2)" in exI)
        unfolding assms using \<open>?R\<close> apply (auto simp add: field_simps)
        done
    qed
  }
qed

lemma segment_horizontal:
  fixes a :: "real^2"
  assumes "a$2 = b$2"
  shows "x \<in> closed_segment a b \<longleftrightarrow>
    x$2 = a$2 \<and> x$2 = b$2 \<and> (a$1 \<le> x$1 \<and> x$1 \<le> b$1 \<or> b$1 \<le> x$1 \<and> x$1 \<le> a$1)"
  (is "_ = ?R")
proof -
  let ?L = "\<exists>u. (x $ 1 = (1 - u) * a $ 1 + u * b $ 1 \<and> x $ 2 = (1 - u) * a $ 2 + u * b $ 2) \<and> 0 \<le> u \<and> u \<le> 1"
  {
    presume "?L \<Longrightarrow> ?R" and "?R \<Longrightarrow> ?L"
    then show ?thesis
      unfolding closed_segment_def mem_Collect_eq
      unfolding vec_eq_iff forall_2 scalar_mult_eq_scaleR[symmetric] vector_component_simps
      by blast
  }
  {
    assume ?L
    then obtain u where u:
        "x $ 1 = (1 - u) * a $ 1 + u * b $ 1"
        "x $ 2 = (1 - u) * a $ 2 + u * b $ 2"
        "0 \<le> u"
        "u \<le> 1"
      by blast
    {
      fix b a
      assume "b + u * a > a + u * b"
      then have "(1 - u) * b > (1 - u) * a"
        by (auto simp add: field_simps)
      then have "b \<ge> a"
        apply (drule_tac mult_left_less_imp_less)
        using u
        apply auto
        done
      then have "u * a \<le> u * b"
        apply -
        apply (rule mult_left_mono[OF _ u(3)])
        using u(3-4)
        apply (auto simp add: field_simps)
        done
    } note * = this
    {
      fix a b
      assume "u * b > u * a"
      then have "(1 - u) * a \<le> (1 - u) * b"
        apply -
        apply (rule mult_left_mono)
        apply (drule mult_left_less_imp_less)
        using u
        apply auto
        done
      then have "a + u * b \<le> b + u * a"
        by (auto simp add: field_simps)
    } note ** = this
    then show ?R
      unfolding u assms
      using u
      by (auto simp add: field_simps not_le intro: * **)
  }
  {
    assume ?R
    then show ?L
    proof (cases "x$1 = b$1")
      case True
      then show ?L
        apply (rule_tac x="(x$1 - a$1) / (b$1 - a$1)" in exI)
        unfolding assms True
        using \<open>?R\<close>
        apply (auto simp add: field_simps)
        done
    next
      case False
      then show ?L
        apply (rule_tac x="1 - (x$1 - b$1) / (a$1 - b$1)" in exI)
        unfolding assms
        using \<open>?R\<close>
        apply (auto simp add: field_simps)
        done
    qed
  }
qed

subsection \<open>Useful Fashoda corollary pointed out to me by Tom Hales\<close>(*FIXME change title? *)

corollary fashoda_interlace:
  fixes a :: "real^2"
  assumes "path f"
    and "path g"
    and paf: "path_image f \<subseteq> cbox a b"
    and pag: "path_image g \<subseteq> cbox a b"
    and "(pathstart f)$2 = a$2"
    and "(pathfinish f)$2 = a$2"
    and "(pathstart g)$2 = a$2"
    and "(pathfinish g)$2 = a$2"
    and "(pathstart f)$1 < (pathstart g)$1"
    and "(pathstart g)$1 < (pathfinish f)$1"
    and "(pathfinish f)$1 < (pathfinish g)$1"
  obtains z where "z \<in> path_image f" and "z \<in> path_image g"
proof -
  have "cbox a b \<noteq> {}"
    using path_image_nonempty[of f] using assms(3) by auto
  note ab=this[unfolded interval_eq_empty_cart not_ex forall_2 not_less]
  have "pathstart f \<in> cbox a b"
    and "pathfinish f \<in> cbox a b"
    and "pathstart g \<in> cbox a b"
    and "pathfinish g \<in> cbox a b"
    using pathstart_in_path_image pathfinish_in_path_image
    using assms(3-4)
    by auto
  note startfin = this[unfolded mem_box_cart forall_2]
  let ?P1 = "linepath (vector[a$1 - 2, a$2 - 2]) (vector[(pathstart f)$1,a$2 - 2]) +++
     linepath(vector[(pathstart f)$1,a$2 - 2])(pathstart f) +++ f +++
     linepath(pathfinish f)(vector[(pathfinish f)$1,a$2 - 2]) +++
     linepath(vector[(pathfinish f)$1,a$2 - 2])(vector[b$1 + 2,a$2 - 2])"
  let ?P2 = "linepath(vector[(pathstart g)$1, (pathstart g)$2 - 3])(pathstart g) +++ g +++
     linepath(pathfinish g)(vector[(pathfinish g)$1,a$2 - 1]) +++
     linepath(vector[(pathfinish g)$1,a$2 - 1])(vector[b$1 + 1,a$2 - 1]) +++
     linepath(vector[b$1 + 1,a$2 - 1])(vector[b$1 + 1,b$2 + 3])"
  let ?a = "vector[a$1 - 2, a$2 - 3]"
  let ?b = "vector[b$1 + 2, b$2 + 3]"
  have P1P2: "path_image ?P1 = path_image (linepath (vector[a$1 - 2, a$2 - 2]) (vector[(pathstart f)$1,a$2 - 2])) \<union>
      path_image (linepath(vector[(pathstart f)$1,a$2 - 2])(pathstart f)) \<union> path_image f \<union>
      path_image (linepath(pathfinish f)(vector[(pathfinish f)$1,a$2 - 2])) \<union>
      path_image (linepath(vector[(pathfinish f)$1,a$2 - 2])(vector[b$1 + 2,a$2 - 2]))"
    "path_image ?P2 = path_image(linepath(vector[(pathstart g)$1, (pathstart g)$2 - 3])(pathstart g)) \<union> path_image g \<union>
      path_image(linepath(pathfinish g)(vector[(pathfinish g)$1,a$2 - 1])) \<union>
      path_image(linepath(vector[(pathfinish g)$1,a$2 - 1])(vector[b$1 + 1,a$2 - 1])) \<union>
      path_image(linepath(vector[b$1 + 1,a$2 - 1])(vector[b$1 + 1,b$2 + 3]))" using assms(1-2)
      by(auto simp add: path_image_join)
  have abab: "cbox a b \<subseteq> cbox ?a ?b"
    unfolding interval_cbox_cart[symmetric]
    by (auto simp add:less_eq_vec_def forall_2)
  obtain z where
    "z \<in> path_image
          (linepath (vector [a $ 1 - 2, a $ 2 - 2]) (vector [pathstart f $ 1, a $ 2 - 2]) +++
           linepath (vector [pathstart f $ 1, a $ 2 - 2]) (pathstart f) +++
           f +++
           linepath (pathfinish f) (vector [pathfinish f $ 1, a $ 2 - 2]) +++
           linepath (vector [pathfinish f $ 1, a $ 2 - 2]) (vector [b $ 1 + 2, a $ 2 - 2]))"
    "z \<in> path_image
          (linepath (vector [pathstart g $ 1, pathstart g $ 2 - 3]) (pathstart g) +++
           g +++
           linepath (pathfinish g) (vector [pathfinish g $ 1, a $ 2 - 1]) +++
           linepath (vector [pathfinish g $ 1, a $ 2 - 1]) (vector [b $ 1 + 1, a $ 2 - 1]) +++
           linepath (vector [b $ 1 + 1, a $ 2 - 1]) (vector [b $ 1 + 1, b $ 2 + 3]))"
    apply (rule fashoda[of ?P1 ?P2 ?a ?b])
    unfolding pathstart_join pathfinish_join pathstart_linepath pathfinish_linepath vector_2
  proof -
    show "path ?P1" and "path ?P2"
      using assms by auto
    show "path_image ?P1 \<subseteq> cbox ?a ?b" "path_image ?P2 \<subseteq> cbox ?a ?b"
      unfolding P1P2 path_image_linepath using startfin paf pag
      by (auto simp: mem_box_cart segment_horizontal segment_vertical forall_2)
    show "a $ 1 - 2 = a $ 1 - 2"
      and "b $ 1 + 2 = b $ 1 + 2"
      and "pathstart g $ 2 - 3 = a $ 2 - 3"
      and "b $ 2 + 3 = b $ 2 + 3"
      by (auto simp add: assms)
  qed
  note z=this[unfolded P1P2 path_image_linepath]
  show thesis
  proof (rule that[of z])
    have "(z \<in> closed_segment (vector [a $ 1 - 2, a $ 2 - 2]) (vector [pathstart f $ 1, a $ 2 - 2]) \<or>
      z \<in> closed_segment (vector [pathstart f $ 1, a $ 2 - 2]) (pathstart f)) \<or>
      z \<in> closed_segment (pathfinish f) (vector [pathfinish f $ 1, a $ 2 - 2]) \<or>
      z \<in> closed_segment (vector [pathfinish f $ 1, a $ 2 - 2]) (vector [b $ 1 + 2, a $ 2 - 2]) \<Longrightarrow>
    (((z \<in> closed_segment (vector [pathstart g $ 1, pathstart g $ 2 - 3]) (pathstart g)) \<or>
      z \<in> closed_segment (pathfinish g) (vector [pathfinish g $ 1, a $ 2 - 1])) \<or>
      z \<in> closed_segment (vector [pathfinish g $ 1, a $ 2 - 1]) (vector [b $ 1 + 1, a $ 2 - 1])) \<or>
      z \<in> closed_segment (vector [b $ 1 + 1, a $ 2 - 1]) (vector [b $ 1 + 1, b $ 2 + 3]) \<Longrightarrow> False"
    proof (simp only: segment_vertical segment_horizontal vector_2, goal_cases)
      case prems: 1
      have "pathfinish f \<in> cbox a b"
        using assms(3) pathfinish_in_path_image[of f] by auto
      then have "1 + b $ 1 \<le> pathfinish f $ 1 \<Longrightarrow> False"
        unfolding mem_box_cart forall_2 by auto
      then have "z$1 \<noteq> pathfinish f$1"
        using prems(2)
        using assms ab
        by (auto simp add: field_simps)
      moreover have "pathstart f \<in> cbox a b"
        using assms(3) pathstart_in_path_image[of f]
        by auto
      then have "1 + b $ 1 \<le> pathstart f $ 1 \<Longrightarrow> False"
        unfolding mem_box_cart forall_2
        by auto
      then have "z$1 \<noteq> pathstart f$1"
        using prems(2) using assms ab
        by (auto simp add: field_simps)
      ultimately have *: "z$2 = a$2 - 2"
        using prems(1) by auto
      have "z$1 \<noteq> pathfinish g$1"
        using prems(2) assms ab
        by (auto simp add: field_simps *)
      moreover have "pathstart g \<in> cbox a b"
        using assms(4) pathstart_in_path_image[of g]
        by auto
      note this[unfolded mem_box_cart forall_2]
      then have "z$1 \<noteq> pathstart g$1"
        using prems(1) assms ab
        by (auto simp add: field_simps *)
      ultimately have "a $ 2 - 1 \<le> z $ 2 \<and> z $ 2 \<le> b $ 2 + 3 \<or> b $ 2 + 3 \<le> z $ 2 \<and> z $ 2 \<le> a $ 2 - 1"
        using prems(2)  unfolding * assms by (auto simp add: field_simps)
      then show False
        unfolding * using ab by auto
    qed
    then have "z \<in> path_image f \<or> z \<in> path_image g"
      using z unfolding Un_iff by blast
    then have z': "z \<in> cbox a b"
      using assms(3-4) by auto
    have "a $ 2 = z $ 2 \<Longrightarrow> (z $ 1 = pathstart f $ 1 \<or> z $ 1 = pathfinish f $ 1) \<Longrightarrow>
      z = pathstart f \<or> z = pathfinish f"
      unfolding vec_eq_iff forall_2 assms
      by auto
    with z' show "z \<in> path_image f"
      using z(1)
      unfolding Un_iff mem_box_cart forall_2
      by (simp only: segment_vertical segment_horizontal vector_2) (auto simp: assms)
    have "a $ 2 = z $ 2 \<Longrightarrow> (z $ 1 = pathstart g $ 1 \<or> z $ 1 = pathfinish g $ 1) \<Longrightarrow>
      z = pathstart g \<or> z = pathfinish g"
      unfolding vec_eq_iff forall_2 assms
      by auto
    with z' show "z \<in> path_image g"
      using z(2)
      unfolding Un_iff mem_box_cart forall_2
      by (simp only: segment_vertical segment_horizontal vector_2) (auto simp: assms)
  qed
qed

end


theory "1_Lists"
imports Main
begin

(* https://isabelle.in.tum.de/exercises/ *)

(* 1.1 snoc *)
section snoc

fun snoc :: "'a list \<Rightarrow> 'a \<Rightarrow> 'a list" where
  "snoc [] a = [a]" | (* 0 *)
  "snoc (x # xs) a = x # snoc xs a" (* 1 + x *)

lemma snoc_app: "snoc xs x = xs @ [x]"
  by (induction xs, auto)

theorem rev_snoc: "rev (x # xs) = snoc (rev xs) x"
  by (simp add: snoc_app)

(* 1.2 replace *)
section replace

fun replace :: "'a \<Rightarrow> 'a \<Rightarrow> 'a list \<Rightarrow> 'a list" where
  "replace x y [] = []" |
  "replace x y (z # zs) = (if z = x then y else z) # replace x y zs"

lemma replace_app_dist: "replace x y (zsl @ zsr) = replace x y zsl @ replace x y zsr"
  by (induction zsl; simp)

theorem "rev (replace x y zs) = replace x y (rev zs)"
  apply (induction zs, simp add: replace_app_dist)
  apply (auto simp add: replace_app_dist)
  done

theorem "replace x y (replace u v zs) = replace u v (replace x y zs)"
  oops

theorem "replace (0 :: nat) 1 (replace 1 0 [0]) \<noteq> replace 1 0 (replace 0 1 [0])"
  by simp

theorem "replace y z (replace x y zs) = replace x z zs"
  oops

theorem "replace (1 :: nat) 2 (replace 0 1 [1]) \<noteq> replace 0 2 [1]"
  by simp

fun del1 :: "'a \<Rightarrow> 'a list \<Rightarrow> 'a list" where
  "del1 _ [] = []" |
  "del1 a (x # xs) = (if x = a then xs else x # del1 a xs)"

fun delall :: "'a \<Rightarrow> 'a list \<Rightarrow> 'a list" where
  "delall _ [] = []" |
  "delall a (x # xs) = (if x = a then delall a xs else x # delall a xs)"

theorem [simp]: "del1 x (delall x xs) = delall x xs"
  by (induction xs; simp)

theorem "delall x (delall x xs) = delall x xs"
  by (induction xs; simp)

theorem "delall x (del1 x xs) = delall x xs"
  by (induction xs; simp)

theorem "del1 x (del1 y zs) = del1 y (del1 x zs)"
  by (induction zs; simp)

theorem "delall x (del1 y zs) = del1 y (delall x zs)"
  by (induction zs; simp)

theorem "delall x (delall y zs) = delall y (delall x zs)"
  by (induction zs; simp)

theorem "del1 y (replace x y xs) = del1 x xs"
  oops

theorem "del1 (1 :: nat) (replace 0 1 [1]) \<noteq> del1 0 [1]"
  by simp

theorem "delall y (replace x y xs) = delall x xs"
  oops

theorem "delall (1 :: nat) (replace 0 1 [1]) \<noteq> delall 0 [1]"
  by simp

theorem "replace x y (delall x zs) = delall x zs"
  by (induction zs; simp)

theorem "replace x y (delall z zs) = delall z (replace x y zs)"
  oops

theorem "replace (0 :: nat) 1 (delall 0 [0]) \<noteq> delall 0 (replace 0 1 [0])"
  by simp

theorem "rev(del1 x xs) = del1 x (rev xs)"
  oops

theorem "rev(del1 (0 :: nat) [0, 1, 0]) \<noteq> del1 0 (rev [0, 1, 0])"
  by simp

theorem "rev(delall x xs) = delall x (rev xs)"
  by (induction xs; simp)

(* 1.3 quant *)
section quant

end


theory CommOr
  imports Main

begin

text\<open> Apply style \<close>
lemma lem_w_1 : "(p \<or> q) \<longrightarrow> (q \<or> p)"
  apply (rule impI)
  apply (erule disjE)
   apply (rule disjI2)
   apply assumption
  apply (rule disjI1)
  apply assumption
  done

text\<open> Apply style proof, more verbose than the preceding proof \<close>
lemma lem_w_2 : "(p \<or> q) \<longrightarrow> (q \<or> p)"
  apply (rule impI)
  apply (rule disjE)
    apply assumption
   apply (rule disjI2)
   apply assumption
  apply (rule disjI1)
  apply assumption
  done

text\<open> Isar style \<close>
lemma lem_x_1 : "(p \<or> q) \<longrightarrow> (q \<or> p)"
proof
  assume A : "(p \<or> q)"
  from A show "(q \<or> p)"
  proof
    assume "p" thus "(q \<or> p)" by (rule disjI2)
    (* you can substitute '..' for 'by (rule disjI2)'*)
  next
    assume "q" thus "(q \<or> p)" by (rule disjI1)
    (* you can substitute '..' for 'by (rule disjI1)'*)
  qed
qed

end