(*  Title:      CoW_Lyndon.Lyndon_Addition
    Author:     Štěpán Holub, Charles University
    Author:     Štěpán Starosta, CTU in Prague
*)

theory Lyndon_Addition
  imports Lyndon Szpilrajn.Szpilrajn

begin

subsection "The minimal relation"

text \<open>We define the minimal relation which guarantees the lexicographic minimality of w compared to its
nontrivial conjugates.\<close>

inductive_set rotate_rel :: "'a list \<Rightarrow> 'a rel" for w
  where  "0 < n \<Longrightarrow> n < \<^bold>|w\<^bold>| \<Longrightarrow> (mismatch_pair w (rotate n w)) \<in> rotate_rel w"

text\<open>A word is Lyndon iff the corresponding order of letters is compatible with  @{term "rotate_rel w"}.\<close>

lemma (in linorder) rotate_rel_iff: assumes "w \<noteq> \<epsilon>"
  shows  "Lyndon w \<longleftrightarrow> rotate_rel w \<subseteq> {(x,y). x < y}" (is "?L \<longleftrightarrow> ?R")
proof
  assume "Lyndon w" show "rotate_rel w \<subseteq> {(x,y). x < y}"
  proof
    fix  x assume "x \<in> rotate_rel w"
    then obtain n where "x = mismatch_pair w (rotate n w)" and "0 < n" and "n < \<^bold>|w\<^bold>|"
      using rotate_rel.cases by blast
    have "w <lex rotate n w"
      using LyndonD[OF \<open>Lyndon w\<close> \<open>0 < n\<close> \<open>n < \<^bold>|w\<^bold>|\<close>].
    from this[unfolded lexordp_conv_lexord]
      prim_no_rotate[OF Lyndon_prim[OF \<open>Lyndon w\<close>] \<open>0 < n\<close>  \<open>n < \<^bold>|w\<^bold>|\<close>]
    show "x \<in> {(a, b). a < b}"
      using lexord_mismatch[of w "rotate n w" "{(a,b). a < b}", folded \<open>x = mismatch_pair w (rotate n w)\<close>]
        \<open>rotate n w \<noteq> w\<close> rotate_comp_eq[of w n]
      unfolding irrefl_def by blast
  qed
next
  assume "?R"
  show "?L"
    unfolding Lyndon.simps
  proof(simp add: assms)
    have "w <lex rotate n w" if "0 < n"  "n < \<^bold>|w\<^bold>|" for n
    proof-
      have "\<not> w \<bowtie> rotate n w"
        using rotate_comp_eq[of w n] subsetD[OF \<open>?R\<close>, OF rotate_rel.intros[OF \<open>0 < n\<close> \<open>n < \<^bold>|w\<^bold>|\<close>]]
          mismatch_pair_lcp[of w "rotate n w"] by fastforce
      from mismatch_lexord_linorder[OF this subsetD[OF \<open>?R\<close>, OF rotate_rel.intros[OF \<open>0 < n\<close> \<open>n < \<^bold>|w\<^bold>|\<close>]]]
      show "w <lex rotate n w".
    qed
    thus "\<forall>n. 0 < n \<and> n < \<^bold>|w\<^bold>| \<longrightarrow> w <lex rotate n w"  by blast
  qed
qed

text\<open>It is well known that an acyclic order can be extended to a total strict linear order. This means that
a word is Lyndon with respect to some order iff its @{term "rotate_rel w"} is acyclic.
\<close>
lemma Lyndon_rotate_rel_iff:
  "acyclic (rotate_rel w) \<longleftrightarrow> (\<exists> r. strict_linear_order r \<and> rotate_rel w \<subseteq> r)" (is "?L \<longleftrightarrow> ?R")
proof
  assume "?R" thus "?L"
    unfolding strict_linear_order_on_def acyclic_def irrefl_def
    using trancl_id trancl_mono by metis
next
  assume "?L" thus "?R"
    using acyclic_order_extension by auto
qed

lemma slo_linorder: "strict_linear_order r \<Longrightarrow> class.linorder (\<lambda> a b. (a,b) \<in> r\<^sup>=) (\<lambda> a b. (a,b) \<in> r)"
    unfolding strict_linear_order_on_def strict_partial_order_def irrefl_def trans_def total_on_def
    by unfold_locales blast+

text\<open>Application examples\<close>

lemma assumes "w \<noteq> \<epsilon>" and "acyclic (rotate_rel w)" shows "primitive w"
proof-
  obtain r where "strict_linear_order r" and "rotate_rel w \<subseteq> r"
    using Lyndon_rotate_rel_iff assms by auto

  interpret r: linorder "\<lambda> a b. (a,b) \<in> r\<^sup>=" "\<lambda> a b. (a,b) \<in> r"
    using slo_linorder[OF \<open>strict_linear_order r\<close>].

  have "r.Lyndon w"
    using r.rotate_rel_iff[OF \<open>w \<noteq> \<epsilon>\<close>] \<open>rotate_rel w \<subseteq> r\<close> by blast

  from r.Lyndon_prim[OF this]
  show "primitive w".

qed

lemma assumes "w \<noteq> \<epsilon>" and "acyclic (rotate_rel w)" shows "\<not> bordered w"
proof-
  obtain r where "strict_linear_order r" and "rotate_rel w \<subseteq> r"
    using Lyndon_rotate_rel_iff assms by auto

  interpret r: linorder "\<lambda> a b. (a,b) \<in> r\<^sup>=" "\<lambda> a b. (a,b) \<in> r"
    using slo_linorder[OF \<open>strict_linear_order r\<close>].

  have "r.Lyndon w"
    using r.rotate_rel_iff[OF \<open>w \<noteq> \<epsilon>\<close>] \<open>rotate_rel w \<subseteq> r\<close> by blast

  from r.Lyndon_unbordered[OF this]
  show "\<not> bordered w".
qed

end


(* Title:  Euler.thy
   Author: Lars Noschinski, TU München
*)
theory Euler imports
  Arc_Walk
  Digraph_Component
  Digraph_Isomorphism
begin

section \<open>Euler Trails in Digraphs\<close>

text \<open>
  In this section we prove the well-known theorem characterizing the
  existence of an Euler Trail in an directed graph
\<close>

subsection \<open>Trails and Euler Trails\<close>

definition (in pre_digraph) euler_trail :: "'a \<Rightarrow> 'b awalk \<Rightarrow> 'a \<Rightarrow> bool" where
  "euler_trail u p v \<equiv> trail u p v \<and> set p = arcs G \<and> set (awalk_verts u p) = verts G"

context wf_digraph begin

(* XXX move; notused*)

(* XXX move; notused*)
lemma (in fin_digraph) trails_finite: "finite {p. \<exists>u v. trail u p v}"
proof -
  have "{p. \<exists>u v. trail u p v} \<subseteq> {p. distinct p \<and> set p \<subseteq> arcs G}"
    by (auto simp: trail_def)
  with finite_arcs finite_distinct show ?thesis by (blast intro: finite_subset)
qed
(* XXX: simplify apath_finite proof? *)

lemma rotate_awalkE:
  assumes "awalk u p u" "w \<in> set (awalk_verts u p)"
  obtains q r where "p = q @ r" "awalk w (r @ q) w" "set (awalk_verts w (r @ q)) = set (awalk_verts u p)"
proof -
  from assms obtain q r where A: "p = q @ r" and A': "awalk u q w" "awalk w r u"
    by atomize_elim (rule awalk_decomp)

  then have B: "awalk w (r @ q) w" by auto

  have C: "set (awalk_verts w (r @ q)) = set (awalk_verts u p)"
    using \<open>awalk u p u\<close> A A' by (auto simp: set_awalk_verts_append)

  from A B C show ?thesis ..
qed

lemma rotate_trailE:
  assumes "trail u p u" "w \<in> set (awalk_verts u p)"
  obtains q r where "p = q @ r" "trail w (r @ q) w" "set (awalk_verts w (r @ q)) = set (awalk_verts u p)"
  using assms by - (rule rotate_awalkE[where u=u and p=p and w=w], auto simp: trail_def)

lemma rotate_trailE':
  assumes "trail u p u" "w \<in> set (awalk_verts u p)"
  obtains q where "trail w q w" "set q = set p" "set (awalk_verts w q) = set (awalk_verts u p)"
proof -
  from assms obtain q r where "p = q @ r" "trail w (r @ q) w" "set (awalk_verts w (r @ q)) = set (awalk_verts u p)"
    by (rule rotate_trailE)
  then have "set (r @ q) = set p" by auto
  show ?thesis by (rule that) fact+
qed

lemma sym_reachableI_in_awalk:
  assumes walk: "awalk u p v" and
    w1: "w1 \<in> set (awalk_verts u p)" and w2: "w2 \<in> set (awalk_verts u p)"
  shows "w1 \<rightarrow>\<^sup>*\<^bsub>mk_symmetric G\<^esub> w2"
proof -
  from walk w1 obtain q r where "p = q @ r" "awalk u q w1" "awalk w1 r v"
    by (atomize_elim) (rule awalk_decomp)
  then have w2_in: "w2 \<in> set (awalk_verts u q) \<union> set (awalk_verts w1 r)"
    using w2 by (auto simp: set_awalk_verts_append)

  show ?thesis
  proof cases
    assume A: "w2 \<in> set (awalk_verts u q)"
    obtain s where "awalk w2 s w1"
      using awalk_decomp[OF \<open>awalk u q w1\<close> A] by blast
    then have "w2 \<rightarrow>\<^sup>*\<^bsub>mk_symmetric G\<^esub> w1"
      by (intro reachable_awalkI reachable_mk_symmetricI)
    with symmetric_mk_symmetric show ?thesis by (rule symmetric_reachable)
  next
    assume "w2 \<notin> set (awalk_verts u q)"
    then have A: "w2 \<in> set (awalk_verts w1 r)"
      using w2_in by blast
    obtain s where "awalk w1 s w2"
      using awalk_decomp[OF \<open>awalk w1 r v\<close> A] by blast
    then show "w1 \<rightarrow>\<^sup>*\<^bsub>mk_symmetric G\<^esub> w2"
      by (intro reachable_awalkI reachable_mk_symmetricI)
  qed
qed

lemma euler_imp_connected:
  assumes "euler_trail u p v" shows "connected G"
proof -
  { have "verts G \<noteq> {}" using assms unfolding euler_trail_def trail_def by auto }
  moreover
  { fix w1 w2 assume "w1 \<in> verts G" "w2 \<in> verts G"
    then have "awalk u p v " "w1 \<in> set (awalk_verts u p)" "w2 \<in> set (awalk_verts u p)"
      using assms by (auto simp: euler_trail_def trail_def)
    then have "w1 \<rightarrow>\<^sup>*\<^bsub>mk_symmetric G\<^esub> w2" by (rule sym_reachableI_in_awalk) }
  ultimately show "connected G" by (rule connectedI)
qed

end

subsection \<open>Arc Balance of Walks\<close>

context pre_digraph begin

(* XXX change order of arguments? *)
definition arc_set_balance :: "'a \<Rightarrow> 'b set \<Rightarrow> int" where
  "arc_set_balance w A = int (card (in_arcs G w \<inter> A)) - int (card (out_arcs G w \<inter> A))"

definition  arc_set_balanced :: "'a \<Rightarrow> 'b set \<Rightarrow> 'a \<Rightarrow> bool" where
  "arc_set_balanced u A v \<equiv>
      if u = v then (\<forall>w \<in> verts G. arc_set_balance w A = 0)
      else (\<forall>w \<in> verts G. (w \<noteq> u \<and> w \<noteq> v) \<longrightarrow> arc_set_balance w A = 0)
        \<and> arc_set_balance u A = -1
        \<and> arc_set_balance v A = 1"

abbreviation arc_balance :: "'a \<Rightarrow> 'b awalk \<Rightarrow> int" where
  "arc_balance w p \<equiv> arc_set_balance w (set p)"

abbreviation arc_balanced :: "'a \<Rightarrow> 'b awalk \<Rightarrow> 'a \<Rightarrow> bool" where
  "arc_balanced u p v \<equiv> arc_set_balanced u (set p) v"

lemma arc_set_balanced_all:
  "arc_set_balanced u (arcs G) v =
      (if u = v then (\<forall>w \<in> verts G. in_degree G w = out_degree G w)
      else (\<forall>w \<in> verts G. (w \<noteq> u \<and> w \<noteq> v) \<longrightarrow> in_degree G w = out_degree G w)
        \<and> in_degree G u + 1 = out_degree G u
        \<and> out_degree G v + 1 = in_degree G v)"
  unfolding arc_set_balanced_def arc_set_balance_def in_degree_def out_degree_def by auto

end

context wf_digraph begin

(* XXX tune assumption? e \<notin> set es oder so? *)
lemma arc_balance_Cons:
  assumes "trail u (e # es) v"
  shows "arc_set_balance w (insert e (set es)) = arc_set_balance w {e} + arc_balance w es"
proof -
  from assms have "e \<notin> set es" "e \<in> arcs G" by (auto simp: trail_def)

  with \<open>e \<notin> set es\<close> show ?thesis
    apply (cases "w = tail G e")
     apply (case_tac [!] "w = head G e")
       apply (auto simp: arc_set_balance_def)
    done
qed

lemma arc_balancedI_trail:
  assumes "trail u p v" shows "arc_balanced u p v"
  using assms
proof (induct p arbitrary: u)
  case Nil then show ?case by (auto simp: arc_set_balanced_def arc_set_balance_def trail_def)
next
  case (Cons e es)
  then have "arc_balanced (head G e) es v" "u = tail G e" "e \<in> arcs G"
    by (auto simp: awalk_Cons_iff trail_def)
  moreover
  have "\<And>w. arc_balance w [e] = (if w = tail G e \<and> tail G e \<noteq> head G e then -1
      else if w = head G e \<and> tail G e \<noteq> head G e then 1 else 0)"
      using \<open>e \<in> _\<close> by (case_tac "w = tail G e") (auto simp: arc_set_balance_def)
  ultimately show ?case
    by (auto simp: arc_set_balanced_def arc_balance_Cons[OF \<open>trail u _ _\<close>])
qed

lemma trail_arc_balanceE:
  assumes "trail u p v"
  obtains "\<And>w. \<lbrakk> u = v \<or> (w \<noteq> u \<and> w \<noteq> v); w \<in> verts G \<rbrakk>
      \<Longrightarrow> arc_balance w p = 0"
    and "\<lbrakk> u \<noteq> v \<rbrakk> \<Longrightarrow> arc_balance u p = - 1"
    and "\<lbrakk> u \<noteq> v \<rbrakk> \<Longrightarrow> arc_balance v p = 1"
  using arc_balancedI_trail[OF assms] unfolding arc_set_balanced_def by (intro that) (metis,presburger+)

end

subsection \<open>Closed Euler Trails\<close>

lemma (in wf_digraph) awalk_vertex_props:
  assumes "awalk u p v" "p \<noteq> []"
  assumes "\<And>w. w \<in> set (awalk_verts u p) \<Longrightarrow> P w \<or> Q w"
  assumes "P u" "Q v"
  shows "\<exists>e \<in> set p. P (tail G e) \<and> Q (head G e)"
  using assms(2,1,3-)
proof (induct p arbitrary: u rule: list_nonempty_induct)
  case (cons e es)
  show ?case
  proof (cases "P (tail G e) \<and> Q (head G e)")
    case False
    then have "P (head G e) \<or> Q (head G e)"
      using cons.prems(1) cons.prems(2)[of "head G e"]
      by (auto simp: awalk_Cons_iff set_awalk_verts)
    then have "P (tail G e) \<and> P (head G e)"
      using False using cons.prems(1,3) by auto

    then have "\<exists>e \<in> set es. P (tail G e) \<and> Q (head G e)"
      using cons by (auto intro: cons simp: awalk_Cons_iff)
    then show ?thesis by auto
  qed auto
qed (simp add: awalk_simps)

lemma (in wf_digraph) connected_verts:
  assumes "connected G" "arcs G \<noteq> {}"
  shows "verts G = tail G ` arcs G \<union> head G ` arcs G"
proof -
  { assume "verts G = {}" then have ?thesis by (auto dest: tail_in_verts) }
  moreover
  { assume "\<exists>v. verts G = {v}"
    then obtain v where "verts G = {v}" by (auto simp: card_Suc_eq)
    moreover
    with \<open>arcs G \<noteq> {}\<close> obtain e where "e \<in> arcs G" "tail G e = v" "head G e = v"
      by (auto dest: tail_in_verts head_in_verts)
    moreover have "tail G ` arcs G \<union> head G ` arcs G \<subseteq> verts G" by auto
    ultimately have ?thesis by auto }
  moreover
  { assume A: "\<exists>u v. u \<in> verts G \<and> v \<in> verts G \<and> u \<noteq> v"
    { fix u assume "u \<in> verts G"

      interpret S: pair_wf_digraph "mk_symmetric G" by rule
      from A obtain v where "v \<in> verts G" "u \<noteq> v" by blast
      then obtain p where "S.awalk u p v"
        using \<open>connected G\<close> \<open>u \<in> verts G\<close> by (auto elim: connected_awalkE)
      with \<open>u \<noteq> v\<close> obtain e where "e \<in> parcs (mk_symmetric G)" "fst e = u"
        by (metis S.awalk_Cons_iff S.awalk_empty_ends list_exhaust2)
      then obtain e' where "tail G e' = u \<or> head G e' = u" "e' \<in> arcs G"
        by (force simp: parcs_mk_symmetric)
      then have "u \<in> tail G ` arcs G \<union> head G `arcs G" by auto }
    then have ?thesis by auto }
  ultimately show ?thesis by blast
qed

lemma (in wf_digraph) connected_arcs_empty:
  assumes "connected G" "arcs G = {}" "verts G \<noteq> {}" obtains v where "verts G = {v}"
proof (atomize_elim, rule ccontr)
  assume A: "\<not> (\<exists>v. verts G = {v})"

  interpret S: pair_wf_digraph "mk_symmetric G" by rule

  from \<open>verts G \<noteq> {}\<close> obtain u where "u \<in> verts G" by auto
  with A obtain v where "v \<in> verts G" "u \<noteq> v" by auto

  from \<open>connected G\<close> \<open>u \<in> verts G\<close> \<open>v \<in> verts G\<close>
  obtain p where "S.awalk u p v"
    using \<open>connected G\<close> \<open>u \<in> verts G\<close> by (auto elim: connected_awalkE)
  with \<open>u \<noteq> v\<close> obtain e where "e \<in> parcs (mk_symmetric G)"
    by (metis S.awalk_Cons_iff S.awalk_empty_ends list_exhaust2)
  with \<open>arcs G = {}\<close> show False
    by (auto simp: parcs_mk_symmetric)
qed

lemma (in wf_digraph) euler_trail_conv_connected:
  assumes "connected G"
  shows "euler_trail u p v \<longleftrightarrow> trail u p v \<and> set p = arcs G" (is "?L \<longleftrightarrow> ?R")
proof
  assume ?R show ?L
  proof cases
    assume "p = []" with assms \<open>?R\<close> show ?thesis
      by (auto simp: euler_trail_def trail_def awalk_def elim: connected_arcs_empty)
  next
    assume "p \<noteq> []" then have "arcs G \<noteq> {}" using \<open>?R\<close> by auto
    with assms \<open>?R\<close> \<open>p \<noteq> []\<close> show ?thesis
      by (auto simp: euler_trail_def trail_def set_awalk_verts_not_Nil connected_verts)
  qed
qed (simp add: euler_trail_def)

lemma (in wf_digraph) awalk_connected:
  assumes "connected G" "awalk u p v" "set p \<noteq> arcs G"
  shows "\<exists>e. e \<in> arcs G - set p \<and> (tail G e \<in> set (awalk_verts u p) \<or> head G e \<in> set (awalk_verts u p))"
proof (rule ccontr)
  assume A: "\<not>?thesis"

  obtain e where "e \<in> arcs G - set p"
    using assms by (auto simp: trail_def)
  with A have "tail G e \<notin> set (awalk_verts u p)" "tail G e \<in> verts G"
    by auto

  interpret S: pair_wf_digraph "mk_symmetric G" ..

  have "u \<in> verts G" using \<open>awalk u p v\<close> by (auto simp: awalk_hd_in_verts)
  with \<open>tail G e \<in> _\<close> and \<open>connected G\<close>
  obtain q where q: "S.awalk u q (tail G e)"
    by (auto elim: connected_awalkE)

  have "u \<in> set (awalk_verts u p)"
    using \<open>awalk u p v\<close> by (auto simp: set_awalk_verts)

  have "q \<noteq> []" using \<open>u \<in> set _\<close> \<open>tail G e \<notin> _\<close> q by auto

  have "\<exists>e \<in> set q. fst e \<in> set (awalk_verts u p) \<and> snd e \<notin> set (awalk_verts u p)"
    by (rule S.awalk_vertex_props[OF \<open>S.awalk _ _ _\<close> \<open>q \<noteq> []\<close>]) (auto simp: \<open>u \<in> set _\<close> \<open>tail G e \<notin> _\<close>)
  then obtain se' where se': "se' \<in> set q" "fst se' \<in> set (awalk_verts u p)" "snd se' \<notin> set (awalk_verts u p)"
    by auto

  from se' have "se' \<in> parcs (mk_symmetric G)" using q by auto
  then obtain e' where "e' \<in> arcs G" "(tail G e' = fst se' \<and> head G e' = snd se') \<or> (tail G e' = snd se' \<and> head G e' = fst se')"
    by (auto simp: parcs_mk_symmetric)
  moreover
  then have "e' \<notin> set p" using se' \<open>awalk u p v\<close>
    by (auto dest: awalk_verts_arc2 awalk_verts_arc1)
  ultimately show False using se'
    using A by auto
qed

lemma (in wf_digraph) trail_connected:
  assumes "connected G" "trail u p v" "set p \<noteq> arcs G"
  shows "\<exists>e. e \<in> arcs G - set p \<and> (tail G e \<in> set (awalk_verts u p) \<or> head G e \<in> set (awalk_verts u p))"
  using assms by (intro awalk_connected) (auto simp: trail_def)

theorem (in fin_digraph) closed_euler1:
  assumes con: "connected G"
  assumes deg: "\<And>u. u \<in> verts G \<Longrightarrow> in_degree G u = out_degree G u"
  shows "\<exists>u p. euler_trail u p u"
proof -
  from con obtain u where "u \<in> verts G" by (auto simp: connected_def strongly_connected_def)
  then have "trail u [] u" by (auto simp: trail_def awalk_simps)
  moreover
  { fix u p v assume  "trail u p v"
    then have "\<exists>u' p' v'. euler_trail u' p' v'"
    proof (induct "card (arcs G) - length p" arbitrary: u p v)
      case 0
      then have "u \<in> verts G" by (auto simp: trail_def)

      have "set p \<subseteq> arcs G" using \<open>trail u p v\<close> by (auto simp: trail_def)
      with 0 have "set p = arcs G"
        by (auto simp: trail_def distinct_card[symmetric] card_seteq)
      then have "euler_trail u p v"
        using 0 by (simp add: euler_trail_conv_connected[OF con])
      then show ?case by blast
    next
      case (Suc n)
      then have neq: "set p \<noteq> arcs G" "u \<in> verts G"
        by (auto simp: trail_def distinct_card[symmetric])

      show ?case
      proof (cases "u = v")
        assume "u \<noteq> v"
        then have "arc_balance u p = -1"
          using Suc neq by (auto elim: trail_arc_balanceE)
        then have "card (in_arcs G u \<inter> set p) < card (out_arcs G u \<inter> set p)"
          unfolding arc_set_balance_def by auto
        also have "\<dots> \<le> card (out_arcs G u)"
          by (rule card_mono) auto
        finally have "card (in_arcs G u \<inter> set p) < card (in_arcs G u)"
          using deg[OF \<open>u \<in> _\<close>] unfolding out_degree_def in_degree_def by simp
        then have "in_arcs G u - set p \<noteq> {}"
          by (auto dest: card_psubset[rotated 2])
        then obtain a where "a \<in> arcs G" "head G a = u" "a \<notin> set p"
          by (auto simp: in_arcs_def)
        then have *: "trail (tail G a) (a # p) v"
          using Suc by (auto simp: trail_def awalk_simps)
        then show ?thesis
          using Suc by (intro Suc) auto
      next
        assume "u = v"
        with neq con Suc
        obtain a where a_in: "a \<in> arcs G - set p"
            and a_end: "(tail G a \<in> set (awalk_verts u p) \<or> head G a \<in> set (awalk_verts u p))"
          by (atomize_elim) (rule trail_connected)
        have "trail u p u" using Suc \<open>u = v\<close> by simp
        show ?case
        proof (cases "tail G a \<in> set (awalk_verts u p)")
          case True
          with \<open>trail u p u\<close> obtain q where q: "set p = set q" "trail (tail G a) q (tail G a)"
            by (rule rotate_trailE') blast
          with True a_in have *: "trail (tail G a) (q @ [a]) (head G a)"
            by (fastforce simp: trail_def awalk_simps )
          moreover
          from q Suc have "length q = length p"
            by (simp add: trail_def distinct_card[symmetric])
          ultimately
          show ?thesis using Suc  by (intro Suc) auto
        next
          case False
          with a_end have "head G a \<in> set (awalk_verts u p)" by blast
          with \<open>trail u p u\<close> obtain q where q: "set p = set q" "trail (head G a) q (head G a)"
            by (rule rotate_trailE') blast
          with False a_in have *: "trail (tail G a) (a # q) (head G a)"
            by (fastforce simp: trail_def awalk_simps )
          moreover
          from q Suc have "length q = length p"
            by (simp add: trail_def distinct_card[symmetric])
          ultimately
          show ?thesis using Suc by (intro Suc) auto
        qed
      qed
    qed }
  ultimately obtain u p v where et: "euler_trail u p v" by blast
  moreover
  have "u = v"
  proof -
    have "arc_balanced u p v"
      using \<open>euler_trail u p v\<close> by (auto simp: euler_trail_def dest: arc_balancedI_trail)
    then show ?thesis
      using \<open>euler_trail u p v\<close> deg
      by (auto simp add: euler_trail_def trail_def arc_set_balanced_all split: if_split_asm)
  qed
  ultimately show ?thesis by blast
qed

lemma (in wf_digraph) closed_euler_imp_eq_degree:
  assumes "euler_trail u p u"
  assumes "v \<in> verts G"
  shows "in_degree G v = out_degree G v"
proof -
  from assms have "arc_balanced u p u" "set p = arcs G"
    unfolding euler_trail_def by (auto dest: arc_balancedI_trail)
  with assms have "arc_balance v p = 0"
    unfolding arc_set_balanced_def by auto
  moreover
  from \<open>set p = _\<close> have "in_arcs G v \<inter> set p = in_arcs G v" "out_arcs G v \<inter> set p = out_arcs G v"
    by (auto intro: in_arcs_in_arcs out_arcs_in_arcs)
  ultimately
  show ?thesis unfolding arc_set_balance_def in_degree_def out_degree_def by auto
qed

theorem (in fin_digraph) closed_euler2:
  assumes "euler_trail u p u"
  shows "connected G"
    and "\<And>u. u \<in> verts G \<Longrightarrow> in_degree G u = out_degree G u" (is "\<And>u. _ \<Longrightarrow> ?eq_deg u")
proof -
  from assms show "connected G" by (rule euler_imp_connected)
next
  fix v assume A: "v \<in> verts G"
  with assms show "?eq_deg v" by (rule closed_euler_imp_eq_degree)
qed

corollary (in fin_digraph) closed_euler:
  "(\<exists>u p. euler_trail u p u) \<longleftrightarrow> connected G \<and> (\<forall>u \<in> verts G. in_degree G u = out_degree G u)"
  by (auto dest: closed_euler1 closed_euler2)

subsection \<open>Open euler trails\<close>

text \<open>
  Intuitively, a graph has an open euler trail if and only if it is possible to add
  an arc such that the resulting graph has a closed euler trail. However, this is
  not true in our formalization, as the arc type @{typ 'b} might be finite:

  Consider for example the graph
  @{term "\<lparr> verts = {0,1}, arcs = {()}, tail = \<lambda>_. 0, head = \<lambda>_. 1 \<rparr>"}. This graph
  obviously has an open euler trail, but we cannot add another arc, as we already
  exhausted the universe.

  However, for each @{term "fin_digraph G"} there exist an isomorphic graph
  @{term H} with arc type @{typ "'a \<times> nat \<times> 'a"}. Hence, we first characterize
  the existence of euler trail for the infinite arc type @{typ "'a \<times> nat \<times> 'a"}
  and transfer that result back to arbitrary arc types.
\<close>

lemma open_euler_infinite_label:
  fixes G :: "('a, 'a \<times> nat \<times> 'a) pre_digraph"
  assumes "fin_digraph G"
  assumes [simp]: "tail G = fst" "head G = snd o snd"
  assumes con: "connected G"
  assumes uv: "u \<in> verts G" "v \<in> verts G"
  assumes deg: "\<And>w. \<lbrakk>w \<in> verts G; u \<noteq> w; v \<noteq> w\<rbrakk> \<Longrightarrow> in_degree G w = out_degree G w"
  assumes deg_in: "in_degree G u + 1 = out_degree G u"
  assumes deg_out: "out_degree G v + 1 = in_degree G v"
  shows "\<exists>p. pre_digraph.euler_trail G u p v"
proof -
  define label :: "'a \<times> nat \<times> 'a \<Rightarrow> nat" where [simp]: "label = fst o snd"

  interpret fin_digraph G by fact

  have "finite (label ` arcs G)" by auto
  moreover have "\<not>finite (UNIV :: nat set)" by blast
  ultimately obtain l where "l \<notin> label ` arcs G" by atomize_elim (rule ex_new_if_finite)

  from deg_in deg_out have "u \<noteq> v" by auto

  let ?e = "(v,l,u)"

  have e_notin:"?e \<notin> arcs G"
    using \<open>l \<notin> _\<close> by (auto simp: image_def)

  let ?H = "add_arc ?e"
    \<comment> \<open>We define a graph which has an closed euler trail\<close>

  have [simp]: "verts ?H = verts G" using uv by simp
  have [intro]: "\<And>a. compatible (add_arc a) G" by (simp add: compatible_def)

  interpret H: fin_digraph "add_arc a"
    rewrites "tail (add_arc a) = tail G" and "head (add_arc a) = head G"
      and "pre_digraph.cas (add_arc a) = cas"
      and "pre_digraph.awalk_verts (add_arc a) = awalk_verts"
     for a
      by unfold_locales (auto dest: wellformed intro: compatible_cas compatible_awalk_verts
          simp: verts_add_arc_conv)

  have "\<exists>u p. H.euler_trail ?e u p u"
  proof (rule H.closed_euler1)
    show "connected ?H"
    proof (rule H.connectedI)
      interpret sH: pair_fin_digraph "mk_symmetric ?H" ..
      fix u v assume "u \<in> verts ?H" "v \<in> verts ?H"
      with con have "u \<rightarrow>\<^sup>*\<^bsub>mk_symmetric G\<^esub> v" by (auto simp: connected_def)
      moreover
      have "subgraph G ?H" by (auto simp: subgraph_def) unfold_locales
      ultimately show "u \<rightarrow>\<^sup>*\<^bsub>with_proj (mk_symmetric ?H)\<^esub> v"
        by (blast intro: sH.reachable_mono subgraph_mk_symmetric)
    qed (simp add: verts_add_arc_conv)
  next
    fix w assume "w \<in> verts ?H"
    then show "in_degree ?H w = out_degree ?H w"
      using deg deg_in deg_out e_notin
      apply (cases "w = u")
       apply (case_tac [!] "w = v")
         by (auto simp: in_degree_add_arc_iff out_degree_add_arc_iff)
  qed

  then obtain w p where Het: "H.euler_trail ?e w p w" by blast
  then have "?e \<in> set p" by (auto simp: pre_digraph.euler_trail_def)
  then obtain q r where p_decomp: "p = q @ [?e] @ r"
    by (auto simp: in_set_conv_decomp)
    \<comment> \<open>We show now that removing the additional arc of @{term ?H}
      from p yields an euler trail in G\<close>

  have "euler_trail u (r @ q) v"
  proof (unfold euler_trail_conv_connected[OF con], intro conjI)
    from Het have Ht': "H.trail ?e v (?e # r @ q) v"
      unfolding p_decomp H.euler_trail_def H.trail_def
      by (auto simp: p_decomp H.awalk_Cons_iff)
    then have "H.trail ?e u (r @ q) v" "?e \<notin> set (r @ q)"
      by (auto simp: H.trail_def H.awalk_Cons_iff)
    then show t': "trail u (r @ q) v"
      by (auto simp: trail_def H.trail_def awalk_def H.awalk_def)

    show "set (r @ q) = arcs G"
    proof -
      have "arcs G = arcs ?H - {?e}" using e_notin by auto
      also have "arcs ?H = set p" using Het
        by (auto simp: pre_digraph.euler_trail_def pre_digraph.trail_def)
      finally show ?thesis using \<open>?e \<notin> set _\<close> by (auto simp: p_decomp)
    qed
  qed
  then show ?thesis by blast
qed

context wf_digraph begin

lemma trail_app_isoI:
  assumes t: "trail u p v"
    and hom: "digraph_isomorphism hom"
  shows "pre_digraph.trail (app_iso hom G) (iso_verts hom u) (map (iso_arcs hom) p) (iso_verts hom v)"
proof -
  interpret H: wf_digraph "app_iso hom G" using hom ..
  from t hom have i: "inj_on (iso_arcs hom) (set p)"
     unfolding trail_def digraph_isomorphism_def by (auto dest:subset_inj_on[where A="set p"])
  then have "distinct (map (iso_arcs hom) p) = distinct p"
    by (auto simp: distinct_map dest: inj_onD)
  with t hom show ?thesis
    by (auto simp: pre_digraph.trail_def awalk_app_isoI)
qed

lemma euler_trail_app_isoI:
  assumes t: "euler_trail u p v"
    and hom: "digraph_isomorphism hom"
  shows "pre_digraph.euler_trail (app_iso hom G) (iso_verts hom u) (map (iso_arcs hom) p) (iso_verts hom v)"
proof -
  from t have "awalk u p v" by (auto simp: euler_trail_def trail_def)
  with assms show ?thesis
    by (simp add: pre_digraph.euler_trail_def trail_app_isoI awalk_verts_app_iso_eq)
qed

end

context fin_digraph begin

(* XXX: We can get rid of "u \<in> verts G" "v \<in> verts G" here and in @{thm open_euler_infinite_label} *)
theorem open_euler1:
  assumes "connected G"
  assumes "u \<in> verts G" "v \<in> verts G"
  assumes "\<And>w. \<lbrakk>w \<in> verts G; u \<noteq> w; v \<noteq> w\<rbrakk> \<Longrightarrow> in_degree G w = out_degree G w"
  assumes "in_degree G u + 1 = out_degree G u"
  assumes "out_degree G v + 1 = in_degree G v"
  shows "\<exists>p. euler_trail u p v"
proof -
  obtain f and n :: nat where "f ` arcs G = {i. i < n}"
      and i: "inj_on f (arcs G)"
    by atomize_elim (rule finite_imp_inj_to_nat_seg, auto)

  define iso_f where "iso_f =
    \<lparr> iso_verts = id, iso_arcs = (\<lambda>a. (tail G a, f a, head G a)),
      head = snd o snd, tail = fst \<rparr>"
  have [simp]: "iso_verts iso_f = id" "iso_head iso_f = snd o snd" "iso_tail iso_f = fst"
    unfolding iso_f_def by auto
  have di_iso_f: "digraph_isomorphism iso_f" unfolding digraph_isomorphism_def iso_f_def
    by (auto intro: inj_onI wf_digraph dest: inj_onD[OF i])

  let ?iso_g = "inv_iso iso_f"
  have [simp]: "\<And>u. u \<in> verts G \<Longrightarrow> iso_verts ?iso_g u = u"
    by (auto simp: inv_iso_def fun_eq_iff the_inv_into_f_eq)

  let ?H = "app_iso iso_f G"
  interpret H: fin_digraph ?H using di_iso_f ..

  have "\<exists>p. H.euler_trail u p v"
    using di_iso_f assms i
    by (intro open_euler_infinite_label) (auto simp: connectedI_app_iso app_iso_eq)
  then obtain p where Het: "H.euler_trail u p v" by blast

  have "pre_digraph.euler_trail (app_iso ?iso_g ?H) (iso_verts ?iso_g u) (map (iso_arcs ?iso_g) p) (iso_verts ?iso_g v)"
    using Het by (intro H.euler_trail_app_isoI digraph_isomorphism_invI di_iso_f)
  then show ?thesis using di_iso_f \<open>u \<in> _\<close> \<open>v \<in> _\<close> by simp rule
qed

theorem open_euler2:
  assumes et: "euler_trail u p v" and "u \<noteq> v"
  shows "connected G \<and>
    (\<forall>w \<in> verts G. u \<noteq> w \<longrightarrow> v \<noteq> w \<longrightarrow> in_degree G w = out_degree G w) \<and>
    in_degree G u + 1 = out_degree G u \<and>
    out_degree G v + 1 = in_degree G v"
proof -
  from et have *: "trail u p v" "u \<in> verts G" "v \<in> verts G"
    by (auto simp: euler_trail_def trail_def awalk_hd_in_verts)

  from et have [simp]: "\<And>u. card (in_arcs G u \<inter> set p) = in_degree G u"
      "\<And>u. card (out_arcs G u \<inter> set p) = out_degree G u"
    by (auto simp: in_degree_def out_degree_def euler_trail_def intro: arg_cong[where f=card])

  from assms * show ?thesis
    by (auto simp: arc_set_balance_def elim: trail_arc_balanceE
        intro: euler_imp_connected)
qed

corollary open_euler:
  "(\<exists>u p v. euler_trail u p v \<and> u \<noteq> v) \<longleftrightarrow>
    connected G \<and> (\<exists>u v. u \<in> verts G \<and> v \<in> verts G \<and>
      (\<forall>w \<in> verts G. u \<noteq> w \<longrightarrow> v \<noteq> w \<longrightarrow> in_degree G w = out_degree G w) \<and>
      in_degree G u + 1 = out_degree G u \<and>
      out_degree G v + 1 = in_degree G v)" (is "?L \<longleftrightarrow> ?R")
proof
  assume ?L
  then obtain u p v where *: "euler_trail u p v" "u \<noteq> v"
    by auto
  then have "u \<in> verts G" "v \<in> verts G"
    by (auto simp: euler_trail_def trail_def awalk_hd_in_verts)
  then show ?R using open_euler2[OF *] by blast
next
  assume ?R
  then obtain u v where *:
    "connected G" "u \<in> verts G" "v \<in> verts G"
    "\<And>w. \<lbrakk>w \<in> verts G; u \<noteq> w; v \<noteq> w\<rbrakk> \<Longrightarrow> in_degree G w = out_degree G w"
    "in_degree G u + 1 = out_degree G u"
    "out_degree G v + 1 = in_degree G v"
    by blast
  then have "u \<noteq> v" by auto
  from * show ?L by (metis open_euler1 \<open>u \<noteq> v\<close>)
qed

end

end


(* License: LGPL *)
(*
Author: Julian Parsert <julian.parsert@gmail.com>
Author: Cezary Kaliszyk
*)

section \<open>Preference Relations\<close>

text \<open> Preferences modeled as a set of pairs \<close>

theory Preferences
  imports
    "HOL-Analysis.Multivariate_Analysis"
    Syntax
begin

subsection \<open>Basic Preference Relation\<close>

text \<open> Basic preference relation locale with carrier and relation modeled as a set of pairs. \<close>

locale preference =
  fixes carrier :: "'a set"
  fixes relation :: "'a relation"
  assumes not_outside: "(x,y) \<in> relation \<Longrightarrow> x \<in> carrier"
    and "(x,y) \<in> relation \<Longrightarrow> y \<in> carrier"
  assumes trans_refl: "preorder_on  carrier relation"

context preference
begin

abbreviation geq ("_ \<succeq> _" [51,51] 60)
  where
    "x \<succeq> y \<equiv> x \<succeq>[relation] y"

abbreviation str_gr ("_ \<succ> _" [51,51] 60)
  where
    "x \<succ> y \<equiv> x \<succeq> y \<and> \<not>y \<succeq> x"

abbreviation indiff ("_ \<approx> _" [51,51] 60)
  where
    "x \<approx> y \<equiv> x \<succeq> y \<and> y \<succeq> x"

lemma reflexivity: "refl_on carrier relation"
  using preorder_on_def trans_refl by blast

lemma transitivity: "trans relation"
  using preorder_on_def trans_refl by auto

lemma indiff_trans [simp]: "x \<approx> y \<Longrightarrow> y \<approx> z \<Longrightarrow> x \<approx> z"
  by (meson transE transitivity)

end

subsubsection \<open> Contour sets \<close>

definition at_least_as_good :: "'a \<Rightarrow> 'a set \<Rightarrow> 'a relation \<Rightarrow> 'a set"
  where
    "at_least_as_good x B P = {y \<in> B. y \<succeq>[P] x }"

definition no_better_than :: "'a \<Rightarrow> 'a set \<Rightarrow> 'a relation \<Rightarrow> 'a set"
  where
    "no_better_than x B P = {y \<in> B. x \<succeq>[P] y}"

definition as_good_as :: "'a \<Rightarrow> 'a set \<Rightarrow> 'a relation \<Rightarrow> 'a set"
  where
    "as_good_as x B P = {y \<in> B. x \<approx>[P] y}"

lemma at_lst_asgd_ge:
  assumes "x \<in> at_least_as_good y B Pr"
  shows "x \<succeq>[Pr] y"
  using assms at_least_as_good_def by fastforce

lemma strict_contour_is_diff:
  "{a \<in> B. a \<succ>[Pr] y} = at_least_as_good y B Pr - as_good_as y B Pr"
  by(auto simp add: at_least_as_good_def as_good_as_def)

lemma strict_countour_def [simp]:
  "(at_least_as_good y B Pr) - as_good_as y B Pr = {x \<in> B. x \<succ>[Pr] y}"
  by (simp add: as_good_as_def at_least_as_good_def strict_contour_is_diff)

lemma at_least_as_goodD [dest]:
  assumes "z \<in> at_least_as_good y B Pr"
  shows "z \<succeq>[Pr] y"
  using assms at_least_as_good_def by fastforce

subsection \<open>Rational Preference Relation\<close>

text \<open> Rational preferences add totality to the basic preferences. \<close>

locale rational_preference = preference +
  assumes total: "total_on carrier relation"
begin

lemma compl: "\<forall>x \<in> carrier . \<forall>y\<in> carrier . x \<succeq> y \<or> y \<succeq> x"
  by (metis refl_onD reflexivity total total_on_def)

lemma strict_not_refl_weak [iff]: "x \<in> carrier \<and> y \<in> carrier \<Longrightarrow> \<not> (y \<succeq> x) \<longleftrightarrow> x \<succ> y"
  by (metis refl_onD reflexivity total total_on_def)

lemma strict_trans [simp]: "x \<succ> y \<Longrightarrow> y \<succ> z \<Longrightarrow> x \<succ> z"
  by (meson transE transitivity)

lemma completeD [dest]: "x \<in> carrier \<Longrightarrow> y \<in> carrier \<Longrightarrow> x \<noteq> y \<Longrightarrow> x \<succeq> y \<or> y \<succeq> x"
  by blast

lemma pref_in_at_least_as:
  assumes "x \<succeq> y"
  shows "x \<in> at_least_as_good y carrier relation"
  by (metis (no_types, lifting) CollectI assms
      at_least_as_good_def preference.not_outside preference_axioms)

lemma worse_in_no_better:
  assumes "x \<succeq> y"
  shows "y \<in> no_better_than y carrier relation"
  by (metis (no_types, lifting) CollectI assms no_better_than_def
      preference_axioms preference_def strict_not_refl_weak)

lemma strict_is_neg_transitive :
  assumes "x \<in> carrier \<and> y \<in> carrier \<and> z \<in> carrier"
  shows "x \<succ> y \<Longrightarrow> x \<succ> z \<or> z \<succ> y"
  by (meson assms compl transE transitivity)

lemma weak_is_transitive:
 assumes "x \<in> carrier \<and> y \<in> carrier \<and> z \<in> carrier"
 shows "x \<succeq> y \<Longrightarrow> y \<succeq> z \<Longrightarrow> x \<succeq> z"
  by (meson transD transitivity)

lemma no_better_than_nonepty:
  assumes "carrier \<noteq> {}"
  shows "\<And>x. x \<in> carrier \<Longrightarrow> (no_better_than x carrier relation) \<noteq> {}"
  by (metis (no_types, lifting) empty_iff mem_Collect_eq
      no_better_than_def refl_onD reflexivity)

lemma no_better_subset_pref :
  assumes "x \<succeq> y"
  shows "no_better_than y carrier relation \<subseteq> no_better_than x carrier relation"
proof
  fix a
  assume "a \<in> no_better_than y carrier relation"
  then show "a \<in> no_better_than x carrier relation"
    by (metis (no_types, lifting) assms mem_Collect_eq no_better_than_def transE transitivity)
qed

lemma no_better_thansubset_rel :
  assumes "x \<in> carrier" and "y \<in> carrier"
  assumes "no_better_than y carrier relation \<subseteq> no_better_than x carrier relation"
  shows "x \<succeq> y"
proof -
  have  "{a \<in> carrier. y \<succeq> a} \<subseteq> {a \<in> carrier. x \<succeq> a}"
    by (metis (no_types) assms(3) no_better_than_def)
  then show ?thesis
    by (metis (mono_tags, lifting) Collect_mono_iff assms(2) compl)
qed

lemma nbt_nest :
  shows "(no_better_than y carrier relation \<subseteq> no_better_than x carrier relation) \<or>
        (no_better_than x carrier relation \<subseteq> no_better_than y carrier relation)"
  by (metis (no_types, lifting) CollectD compl no_better_subset_pref no_better_than_def not_outside subsetI)

lemma at_lst_asgd_not_ge:
  assumes "carrier \<noteq> {}"
  assumes "x \<in> carrier" and "y \<in> carrier"
  assumes "x \<notin> at_least_as_good y carrier relation"
  shows "\<not> x \<succeq> y"
  by (metis (no_types, lifting) CollectI assms(2) assms(4) at_least_as_good_def)

lemma as_good_as_sameIff[iff]:
  "z \<in> as_good_as y carrier relation \<longleftrightarrow> z \<succeq> y \<and> y \<succeq> z"
  by (metis (no_types, lifting) as_good_as_def mem_Collect_eq not_outside)

lemma same_at_least_as_equal:
  assumes "z \<approx> y"
  shows "at_least_as_good z carrier relation =
         at_least_as_good y carrier relation" (is "?az = ?ay")
proof
  have "z \<in> carrier \<and> y \<in> carrier"
    by (meson assms refl_onD2 reflexivity)
  moreover have "\<forall>x \<in> carrier. x \<succeq> z \<longrightarrow> x \<succeq> y"
    by (meson assms transD transitivity)
  ultimately show "?az \<subseteq> ?ay"
    by (metis at_lst_asgd_ge at_lst_asgd_not_ge
        equals0D not_outside subsetI)
next
   have "z \<in> carrier \<and> y \<in> carrier"
    by (meson assms refl_onD2 reflexivity)
  moreover have "\<forall>x \<in> carrier. x \<succeq> y \<longrightarrow> x \<succeq> z"
    by (meson assms transD transitivity)
  ultimately show "?ay \<subseteq> ?az"
    by (metis at_lst_asgd_ge at_lst_asgd_not_ge
        equals0D not_outside subsetI)
qed

lemma as_good_asIff [iff]:
  "x \<in> as_good_as y carrier relation \<longleftrightarrow> x \<approx>[relation] y"
  by blast

lemma nbt_subset:
  assumes "finite carrier"
  assumes "x \<in> carrier" and "y \<in> carrier"
  shows "no_better_than x carrier relation \<subseteq> no_better_than x carrier relation \<or>
         no_better_than x carrier relation \<subseteq> no_better_than x carrier relation"
  by auto

lemma fnt_carrier_fnt_rel: "finite carrier \<Longrightarrow> finite relation"
  by (metis finite_SigmaI refl_on_def reflexivity rev_finite_subset)

lemma nbt_subset_carrier:
  assumes "x \<in> carrier"
  shows "no_better_than x carrier relation \<subseteq> carrier"
  using no_better_than_def by fastforce

lemma xy_in_eachothers_nbt:
  assumes "x \<in> carrier" "y \<in> carrier"
  shows "x \<in> no_better_than y carrier relation \<or>
         y \<in> no_better_than x carrier relation"
  by (meson assms(1) assms(2) contra_subsetD nbt_nest refl_onD reflexivity worse_in_no_better)

lemma same_nbt_same_pref:
  assumes "x \<in> carrier" "y \<in> carrier"
  shows "x \<in> no_better_than y carrier relation \<and>
         y \<in> no_better_than x carrier relation \<longleftrightarrow> x \<approx> y"
    by (metis (mono_tags, lifting) CollectD contra_subsetD no_better_subset_pref
        no_better_than_def worse_in_no_better)

lemma indifferent_imp_weak_pref:
  assumes "x \<approx> y"
  shows" x \<succeq> y" "y \<succeq> x"
  by (simp add: assms)+

subsection \<open> Finite carrier\<close>

context
  assumes "finite carrier"
begin

lemma fnt_carrier_fnt_nbt:
  shows "\<forall>x\<in>carrier. finite (no_better_than x carrier relation)"
proof
  fix x
  assume "x \<in> carrier"
  then show "finite (no_better_than x carrier relation)"
  using  finite_subset nbt_subset_carrier \<open>finite carrier\<close> by blast
qed

lemma nbt_subset_imp_card_leq:
  assumes "x \<in> carrier" and "y \<in> carrier"
  shows "no_better_than x carrier relation \<subseteq> no_better_than y carrier relation \<longleftrightarrow>
  card (no_better_than x carrier relation) \<le> card  (no_better_than y carrier relation)"
  (is "?nbt \<longleftrightarrow> ?card")
proof
  assume "?nbt"
  then show "?card"
    by (simp add: assms(2) card_mono fnt_carrier_fnt_nbt)
next
  assume "?card"
  then show "?nbt"
    by (metis  assms(1) card_seteq fnt_carrier_fnt_nbt nbt_nest)
qed

lemma card_leq_pref:
  assumes "x \<in> carrier" and "y \<in> carrier"
  shows "card (no_better_than x carrier relation) \<le> card (no_better_than y carrier relation)
   \<longleftrightarrow> y \<succeq> x"
proof (rule iffI, goal_cases)
  case 1
  then show ?case
    using assms(1) assms(2) nbt_subset_imp_card_leq no_better_thansubset_rel by presburger
next
  case 2
  then show ?case
    using assms(1) assms(2) nbt_subset_imp_card_leq no_better_subset_pref by blast
qed

lemma finite_ne_remove_induct:
  assumes "finite B" "B \<noteq> {}"
    "\<And>A. finite A  \<Longrightarrow> A \<subseteq> B \<Longrightarrow> A \<noteq> {} \<Longrightarrow>
         (\<And>x. x \<in> A \<Longrightarrow> A - {x} \<noteq> {} \<Longrightarrow> P (A - {x})) \<Longrightarrow> P A"
  shows "P B"
  by (metis assms finite_remove_induct[where P = "\<lambda>F. F = {} \<or> P F" for P])

lemma finite_nempty_preorder_has_max:
  assumes "finite B" "B \<noteq> {}" "refl_on B R" "trans R" "total_on B R"
  shows "\<exists>x \<in> B. \<forall>y \<in> B. (x, y) \<in> R"
  using assms(1) subset_refl[of B] assms(2)
proof (induct B rule: finite_subset_induct)
  case (insert x F)
  then show ?case using assms(3-)
    by (cases "F = {}") (auto simp: refl_onD total_on_def, metis refl_onD2 transE)
qed auto

lemma finite_nempty_preorder_has_min:
  assumes "finite B" "B \<noteq> {}" "refl_on B R" "trans R" "total_on B R"
  shows "\<exists>x \<in> B. \<forall>y \<in> B. (y, x) \<in> R"
  using assms(1) subset_refl[of B] assms(2)
proof (induct B rule: finite_subset_induct)
  case (insert x F)
  then show ?case using assms(3-)
    by (cases "F = {}") (auto simp: refl_onD total_on_def, metis refl_onD2 transE)
qed auto

lemma finite_nonempty_carrier_has_maximum:
  assumes "carrier \<noteq> {}"
  shows "\<exists>e \<in> carrier. \<forall>m \<in> carrier. e \<succeq>[relation] m"
  using finite_nempty_preorder_has_max[of carrier relation] assms
     \<open>finite carrier\<close> reflexivity total transitivity by blast

lemma finite_nonempty_carrier_has_minimum:
  assumes "carrier \<noteq> {}"
  shows "\<exists>e \<in> carrier. \<forall>m \<in> carrier. m \<succeq>[relation] e"
  using finite_nempty_preorder_has_min[of carrier relation] assms
     \<open>finite carrier\<close> reflexivity total transitivity by blast

end (*finite carrier*)

lemma all_carrier_ex_sub_rel:
  "\<forall>c \<subseteq> carrier. \<exists>r \<subseteq> relation. rational_preference c r"
proof (standard,standard)
  fix c
  assume c_in: "c \<subseteq> carrier"
  define r' where
    "r' = {(x,y) \<in> relation. x \<in> c \<and> y \<in> c}"
  have r'_sub: "r' \<subseteq> c \<times> c"
    using r'_def by blast
  have "\<forall>x \<in> c. x \<succeq>[r'] x"
    by (metis (no_types, lifting) CollectI c_in case_prodI compl r'_def subsetCE)
  then have refl: "refl_on c r'"
    by (meson r'_sub refl_onI)
  have trans: "trans r'"
  proof
    fix x y z
    assume a1: "x \<succeq>[r'] y"
    assume a2: "y \<succeq>[r'] z"
    show " x \<succeq>[r'] z"
      by (metis (mono_tags, lifting) CollectD CollectI a1 a2 case_prodD case_prodI r'_def transE transitivity)
  qed
  have total: "total_on c r'"
  proof (standard)
    fix x y
    assume a1:"x \<in> c"
    assume a2: "y \<in> c"
    assume a3: "x \<noteq> y"
    show "x \<succeq>[r'] y \<or> y \<succeq>[r'] x "
      by (metis (no_types, lifting) CollectI a1 a2 c_in case_prodI compl r'_def subset_iff)
  qed
  have "rational_preference c r'"
    by (meson local.refl local.trans preference.intro preorder_on_def rational_preference.intro
        rational_preference_axioms.intro refl_on_domain total)
  thus "\<exists>r\<subseteq>relation. rational_preference c r"
    by (metis (no_types, lifting) CollectD case_prodD r'_def subrelI)
qed

end (*rational preference*)

subsection \<open> Local Non-Satiation \<close>

text \<open> Defining local non-satiation. \<close>

definition local_nonsatiation
  where
  "local_nonsatiation B P \<longleftrightarrow>
   (\<forall>x\<in>B. \<forall>e>0. \<exists>y\<in>B. norm (y - x) \<le> e \<and> y \<succ>[P] x)"

text \<open> Alternate definitions and intro/dest rules with them \<close>

lemma lns_alt_def1 [iff] :
  shows "local_nonsatiation B P \<longleftrightarrow> (\<forall>x \<in> B. \<forall>e>0. (\<exists>y \<in> B. dist y x \<le> e \<and> y \<succ>[P] x))"
  by(simp add : dist_norm local_nonsatiation_def)

lemma lns_normI [intro]:
  assumes "\<And>x e. x \<in> B \<Longrightarrow> e > 0 \<Longrightarrow> (\<exists>y\<in>B. norm (y - x) \<le> e \<and> y \<succ>[P] x)"
  shows "local_nonsatiation B P"
  by (simp add: assms dist_norm)

lemma lns_distI [intro]:
  assumes "\<And>x e. x \<in> B \<Longrightarrow> e > 0 \<Longrightarrow> (\<exists>y\<in>B. (dist y x) \<le> e \<and> y \<succ>[P] x)"
  shows "local_nonsatiation B P"
  by (meson lns_alt_def1 assms)

lemma lns_normD [dest]:
  assumes "local_nonsatiation B P"
  shows "\<forall>x \<in> B. \<forall>e>0. \<exists>y \<in> B. (norm (y - x) \<le> e \<and> y \<succ>[P] x)"
  by (meson assms local_nonsatiation_def)

subsection \<open> Convex preferences \<close>

definition weak_convex_pref :: "('a::real_vector) relation \<Rightarrow> bool"
  where
    "weak_convex_pref Pr \<longleftrightarrow> (\<forall>x y. x \<succeq>[Pr] y \<longrightarrow>
      (\<forall>\<alpha> \<beta>. \<alpha> + \<beta> = 1 \<and> \<alpha> > 0 \<and> \<beta> > 0 \<longrightarrow> \<alpha> *\<^sub>R x + \<beta> *\<^sub>R y \<succeq>[Pr] y))"

definition convex_pref :: "('a::real_vector) relation \<Rightarrow> bool"
  where
    "convex_pref Pr \<longleftrightarrow> (\<forall>x y. x \<succ>[Pr] y \<longrightarrow>
      (\<forall>\<alpha>. 1 > \<alpha> \<and> \<alpha> > 0 \<longrightarrow> \<alpha> *\<^sub>R x + (1-\<alpha>) *\<^sub>R y \<succ>[Pr] y))"

definition strict_convex_pref :: "('a::real_vector) relation \<Rightarrow> bool"
  where
    "strict_convex_pref Pr \<longleftrightarrow> (\<forall>x y. x \<succeq>[Pr] y \<and> x \<noteq> y \<longrightarrow>
      (\<forall>\<alpha>. 1 > \<alpha> \<and> \<alpha> > 0 \<longrightarrow> \<alpha> *\<^sub>R x + (1-\<alpha>) *\<^sub>R y \<succ>[Pr] y))"

lemma convex_ge_imp_conved:
  assumes "\<forall>x y. x \<succeq>[Pr] y \<longrightarrow> (\<forall>\<alpha> \<beta>. \<alpha> + \<beta> = 1 \<and> \<alpha> \<ge> 0 \<and> \<beta> \<ge> 0 \<longrightarrow> \<alpha> *\<^sub>R x + \<beta> *\<^sub>R y \<succeq>[Pr] y)"
  shows "weak_convex_pref Pr"
  by (simp add: assms weak_convex_pref_def)

lemma weak_convexI [intro]:
  assumes "\<And>x y \<alpha> \<beta>. x \<succeq>[Pr] y \<Longrightarrow> \<alpha> + \<beta> = 1 \<Longrightarrow> 0 < \<alpha> \<Longrightarrow> 0 < \<beta> \<Longrightarrow> \<alpha> *\<^sub>R x + \<beta> *\<^sub>R y \<succeq>[Pr] y"
  shows "weak_convex_pref Pr"
  by (simp add: assms weak_convex_pref_def)

lemma weak_convexD [dest]:
  assumes "weak_convex_pref Pr" and "x \<succeq>[Pr] y" and "0 < u" and "0 < v" and "u + v = 1"
  shows "u *\<^sub>R x + v *\<^sub>R y \<succeq>[Pr] y"
    using assms weak_convex_pref_def by blast

subsection \<open> Real Vector Preferences \<close>

text \<open> Preference relations on real vector type class. \<close>

locale real_vector_rpr = rational_preference carrier relation
for carrier :: "'a::real_vector set"
and relation :: "'a relation"

sublocale  real_vector_rpr \<subseteq> rational_preference carrier relation
  by (simp add: rational_preference_axioms)

context real_vector_rpr
begin

lemma have_rpr: "rational_preference carrier relation"
  by (simp add: rational_preference_axioms)

text \<open> Multiple convexity alternate definitions intro/dest rules. \<close>

lemma weak_convex1D [dest]:
  assumes "weak_convex_pref relation" and "x \<succeq>[relation] y" and "0 \<le> u" and "0 \<le> v" and "u + v = 1"
  shows "u *\<^sub>R x + v *\<^sub>R y \<succeq>[relation] y"
proof-
  have u_0: "u = 0 \<longrightarrow> u *\<^sub>R x + v *\<^sub>R y \<succeq>[relation] y"
  proof
    assume u_0: "u = 0"
    have "v = 1"
      using assms(5) u_0 by auto
    then have "?thesis"
      by (metis add.left_neutral assms(2) preference.reflexivity preference_axioms
          real_vector.scale_zero_left refl_onD2 scaleR_one strict_not_refl_weak)
    thus "u *\<^sub>R x + v *\<^sub>R y \<succeq>[relation] y "
      using u_0 by blast
  qed
  have "u \<noteq> 0 \<and> u \<noteq> 1 \<longrightarrow> u *\<^sub>R x + v *\<^sub>R y \<succeq>[relation] y"
    by (metis add_cancel_right_right antisym_conv not_le assms weak_convexD )
  then show ?thesis
    by (metis u_0 assms(2,5) add_cancel_right_right real_vector.scale_zero_left scaleR_one)
qed

lemma weak_convex1I [intro] :
  assumes "\<forall>x. convex (at_least_as_good x carrier relation)"
  shows "weak_convex_pref relation"
proof (rule weak_convexI)
  fix x and y and \<alpha> \<beta> :: real
  assume assum : "x \<succeq>[relation] y"
  assume reals: "0 < \<alpha>" "0 < \<beta>" " \<alpha> + \<beta> = 1"
  then have "x \<in> carrier"
    by (meson assum preference.not_outside rational_preference.axioms(1) have_rpr)
  have "y \<in> carrier"
    by (meson assum refl_onD2 reflexivity)
  then have y_in_upper_cont: "y \<in> (at_least_as_good y carrier relation)"
    using assms rational_preference.at_lst_asgd_not_ge
      rational_preference.compl  by (metis empty_iff have_rpr)
  then have "x \<in> (at_least_as_good y carrier relation)"
    using assum pref_in_at_least_as by blast
  moreover have "0 \<le> \<beta>" and "0 \<le> \<alpha>"
    using reals by (auto)
  ultimately show "(\<alpha> *\<^sub>R x + \<beta> *\<^sub>R y) \<succeq>[relation] y"
    by (meson assms(1) at_least_as_goodD convexD reals(3) y_in_upper_cont)
qed

text \<open> Definition of convexity in "Handbook of Social Choice and Welfare"@{cite "arrow2010handbook"}. \<close>

lemma convex_def_alt:
  assumes "rational_preference carrier relation"
  assumes "weak_convex_pref relation"
  shows "(\<forall>x \<in> carrier. convex (at_least_as_good x carrier relation))"
proof
  fix x
  assume x_in: "x \<in> carrier"
  show "convex (at_least_as_good x carrier relation)" (is "convex ?x")
  proof (rule convexI)
    fix a b :: "'a" and  \<alpha> :: "real" and \<beta> :: "real"
    assume a_in: "a \<in> ?x"
    assume b_in: "b \<in> ?x"
    assume reals: " 0 \<le> \<alpha>" "0 \<le> \<beta>" "\<alpha> + \<beta> = 1"
    have a_g_x: "a \<succeq>[relation] x"
      using a_in by blast
    have b_g_x: "b \<succeq>[relation] x"
      using b_in by blast
    have "a \<succeq>[relation] b \<or> b \<succeq>[relation] a"
      by (meson a_in at_least_as_goodD b_in preference.not_outside
          rational_preference.compl rational_preference_def assms(1))
    then show "\<alpha> *\<^sub>R a + \<beta> *\<^sub>R b \<in> ?x"
    proof(rule disjE)
      assume "a \<succeq>[relation] b"
      then have "\<alpha> *\<^sub>R a + \<beta> *\<^sub>R b  \<succeq>[relation] b"
        using assms reals by blast
      then have "\<alpha> *\<^sub>R a + \<beta> *\<^sub>R b \<succeq>[relation] x"
        by (meson b_g_x  assms(1) preference.not_outside x_in
            rational_preference.strict_is_neg_transitive
            rational_preference.strict_not_refl_weak rational_preference_def)
      then show ?thesis
        by (metis (no_types, lifting) CollectI  assms(1)
            at_least_as_good_def preference_def rational_preference_def)
    next
      assume as: "b \<succeq>[relation] a"
      then have "\<alpha> *\<^sub>R a + \<beta> *\<^sub>R b \<succeq>[relation] a"
        by (metis add.commute assms(2) reals weak_convex1D)
      have "\<alpha> *\<^sub>R a + \<beta> *\<^sub>R b \<succeq>[relation] a"
        by (metis as add.commute  assms(2)
            reals(1,2,3) weak_convex1D)
      then have "\<alpha> *\<^sub>R a + \<beta> *\<^sub>R b \<succeq>[relation] x"
        by (meson a_g_x assms(1) preference.indiff_trans x_in
            preference.not_outside rational_preference.axioms(1)
            rational_preference.strict_is_neg_transitive )
      then show ?thesis
        using pref_in_at_least_as by blast
    qed
  qed
qed

lemma convex_imp_convex_str_upper_cnt:
  assumes "\<forall>x \<in> carrier. convex (at_least_as_good x carrier relation)"
  shows "convex (at_least_as_good x carrier relation - as_good_as x carrier relation)"
    (is "convex ( ?a - ?b)")
proof (rule convexI)
  fix a y u v
  assume as_a: "a \<in> ?a - ?b"
  assume as_y: "y \<in> ?a - ?b"
  assume reals: "0 \<le> (u::real)" "0 \<le> v" "u + v = 1"
  have cvx: "weak_convex_pref relation "
    by (meson assms at_least_as_goodD convexI have_rpr
        preference_def rational_preference.axioms(1) weak_convex1I)
  then have a_g_x: "a \<succ>[relation] x"
    using as_a by blast
  then have y_gt_x: "y \<succ>[relation] x"
    using as_y by blast
  show "u *\<^sub>R a + v *\<^sub>R y \<in> ?a - ?b"
  proof
    show "u *\<^sub>R a + v *\<^sub>R y \<in> ?a"
      by (metis DiffD1 a_g_x as_a as_y assms convexD reals have_rpr
          preference_def rational_preference.axioms(1))
  next
    have "a \<succeq>[relation] y \<or> y \<succeq>[relation] a"
      by (meson a_g_x y_gt_x assms(1) preference.not_outside have_rpr
          rational_preference.axioms(1) rational_preference.strict_not_refl_weak)
    then show "u *\<^sub>R a + v *\<^sub>R y \<notin> ?b"
    proof
      assume "a \<succeq>[relation] y"
      then have "u *\<^sub>R a + v *\<^sub>R y \<succeq>[relation] y"
        using cvx assms(1) reals by blast
      then have "u *\<^sub>R a + v *\<^sub>R y \<succ>[relation] x"
        using y_gt_x by (meson assms(1) rational_preference.axioms(1) have_rpr
            rational_preference.strict_is_neg_transitive preference_def)
      then show "u *\<^sub>R a + v *\<^sub>R y \<notin> as_good_as x carrier relation"
        by blast
    next
      assume "y \<succeq>[relation] a"
      then have "u *\<^sub>R a + v *\<^sub>R y \<succeq>[relation] a"
        using cvx assms(1) reals by (metis add.commute weak_convex1D)
      then have "u *\<^sub>R a + v *\<^sub>R y \<succ>[relation] x"
        by (meson a_g_x assms(1) rational_preference.strict_is_neg_transitive
            rational_preference.axioms(1) preference_def have_rpr)
      then show "u *\<^sub>R a + v *\<^sub>R y \<notin> ?b"
        by blast
    qed
  qed
qed

end

subsubsection \<open> Monotone preferences \<close>

definition weak_monotone_prefs :: "'a set \<Rightarrow> ('a::ord) relation \<Rightarrow> bool"
  where
    "weak_monotone_prefs B P \<longleftrightarrow> (\<forall>x \<in> B. \<forall>y \<in> B. x \<ge> y \<longrightarrow> x \<succeq>[P]y)"

definition monotone_preference :: "'a set \<Rightarrow> ('a::ord) relation \<Rightarrow> bool"
  where
    "monotone_preference B P \<longleftrightarrow> (\<forall>x \<in> B. \<forall>y \<in> B. x > y \<longrightarrow> x \<succ>[P] y)"

text \<open> Given a carrier set that is unbounded above (not the "standard" mathematical definition),
       monotonicity implies local non-satiation. \<close>

lemma unbounded_above_mono_imp_lns:
  assumes "\<forall>M \<in> carrier. (\<forall>x > M. x \<in> carrier)"
  assumes mono: "monotone_preference (carrier:: 'a::ordered_euclidean_space set) relation"
  shows "local_nonsatiation carrier relation"
proof(rule lns_distI)
  fix x and e::"real"
  assume x_in: "x \<in> carrier"
  assume gz : "e > 0"
  show "\<exists>y\<in>carrier. dist y x \<le> e \<and> y \<succeq>[relation] x \<and> (x, y) \<notin> relation"
  proof-
    obtain v :: real where
      v:"v < e" "0 < v" using gz dense by blast
    obtain i where
      i:"(i::'a) \<in> Basis" by fastforce
    define y where
      y_value : "y = x + v *\<^sub>R i"
    have ge:"y \<ge> x"
      using y_value i unfolding y_value
      by (simp add: v(2) zero_le_scaleR_iff)
    have "y \<noteq> x"
      using y_value i unfolding y_value
      using v(2) by auto
    hence y_str_g_x : "y > x"
      using ge by auto
    have y_in: "y \<in> carrier"
      using assms(1) x_in y_str_g_x by blast
    then have y_pref_x : "y \<succ>[relation] x"
      using y_str_g_x x_in mono monotone_preference_def  by blast
    hence " norm (y - x) \<le> e"
      using \<open>0 < v\<close> y_value y_value i v by auto
    hence dist_less_e : "dist y x \<le> e"
      by (simp add: dist_norm)
    thus ?thesis
      using y_pref_x dist_less_e y_in by blast
  qed
qed

end