(*  Title:      HOL/Library/Permutations.thy
    Author:     Amine Chaieb, University of Cambridge
*)

section {* Permutations, both general and specifically on finite sets.*}

theory Permutations
imports Fact
begin

subsection {* Transpositions *}

lemma swap_id_idempotent [simp]:
  "Fun.swap a b id \<circ> Fun.swap a b id = id"
  by (rule ext, auto simp add: Fun.swap_def)

lemma inv_swap_id:
  "inv (Fun.swap a b id) = Fun.swap a b id"
  by (rule inv_unique_comp) simp_all

lemma swap_id_eq:
  "Fun.swap a b id x = (if x = a then b else if x = b then a else x)"
  by (simp add: Fun.swap_def)

subsection {* Basic consequences of the definition *}

definition permutes  (infixr "permutes" 41)
  where "(p permutes S) \<longleftrightarrow> (\<forall>x. x \<notin> S \<longrightarrow> p x = x) \<and> (\<forall>y. \<exists>!x. p x = y)"

lemma permutes_in_image: "p permutes S \<Longrightarrow> p x \<in> S \<longleftrightarrow> x \<in> S"
  unfolding permutes_def by metis

lemma permutes_image: "p permutes S \<Longrightarrow> p ` S = S"
  unfolding permutes_def
  apply (rule set_eqI)
  apply (simp add: image_iff)
  apply metis
  done

lemma permutes_inj: "p permutes S \<Longrightarrow> inj p"
  unfolding permutes_def inj_on_def by blast

lemma permutes_surj: "p permutes s \<Longrightarrow> surj p"
  unfolding permutes_def surj_def by metis

lemma permutes_inv_o:
  assumes pS: "p permutes S"
  shows "p \<circ> inv p = id"
    and "inv p \<circ> p = id"
  using permutes_inj[OF pS] permutes_surj[OF pS]
  unfolding inj_iff[symmetric] surj_iff[symmetric] by blast+

lemma permutes_inverses:
  fixes p :: "'a \<Rightarrow> 'a"
  assumes pS: "p permutes S"
  shows "p (inv p x) = x"
    and "inv p (p x) = x"
  using permutes_inv_o[OF pS, unfolded fun_eq_iff o_def] by auto

lemma permutes_subset: "p permutes S \<Longrightarrow> S \<subseteq> T \<Longrightarrow> p permutes T"
  unfolding permutes_def by blast

lemma permutes_empty[simp]: "p permutes {} \<longleftrightarrow> p = id"
  unfolding fun_eq_iff permutes_def by simp metis

lemma permutes_sing[simp]: "p permutes {a} \<longleftrightarrow> p = id"
  unfolding fun_eq_iff permutes_def by simp metis

lemma permutes_univ: "p permutes UNIV \<longleftrightarrow> (\<forall>y. \<exists>!x. p x = y)"
  unfolding permutes_def by simp

lemma permutes_inv_eq: "p permutes S \<Longrightarrow> inv p y = x \<longleftrightarrow> p x = y"
  unfolding permutes_def inv_def
  apply auto
  apply (erule allE[where x=y])
  apply (erule allE[where x=y])
  apply (rule someI_ex)
  apply blast
  apply (rule some1_equality)
  apply blast
  apply blast
  done

lemma permutes_swap_id: "a \<in> S \<Longrightarrow> b \<in> S \<Longrightarrow> Fun.swap a b id permutes S"
  unfolding permutes_def Fun.swap_def fun_upd_def by auto metis

lemma permutes_superset: "p permutes S \<Longrightarrow> (\<forall>x \<in> S - T. p x = x) \<Longrightarrow> p permutes T"
  by (simp add: Ball_def permutes_def) metis

subsection {* Group properties *}

lemma permutes_id: "id permutes S"
  unfolding permutes_def by simp

lemma permutes_compose: "p permutes S \<Longrightarrow> q permutes S \<Longrightarrow> q \<circ> p permutes S"
  unfolding permutes_def o_def by metis

lemma permutes_inv:
  assumes pS: "p permutes S"
  shows "inv p permutes S"
  using pS unfolding permutes_def permutes_inv_eq[OF pS] by metis

lemma permutes_inv_inv:
  assumes pS: "p permutes S"
  shows "inv (inv p) = p"
  unfolding fun_eq_iff permutes_inv_eq[OF pS] permutes_inv_eq[OF permutes_inv[OF pS]]
  by blast

subsection {* The number of permutations on a finite set *}

lemma permutes_insert_lemma:
  assumes pS: "p permutes (insert a S)"
  shows "Fun.swap a (p a) id \<circ> p permutes S"
  apply (rule permutes_superset[where S = "insert a S"])
  apply (rule permutes_compose[OF pS])
  apply (rule permutes_swap_id, simp)
  using permutes_in_image[OF pS, of a]
  apply simp
  apply (auto simp add: Ball_def Fun.swap_def)
  done

lemma permutes_insert: "{p. p permutes (insert a S)} =
  (\<lambda>(b,p). Fun.swap a b id \<circ> p) ` {(b,p). b \<in> insert a S \<and> p \<in> {p. p permutes S}}"
proof -
  {
    fix p
    {
      assume pS: "p permutes insert a S"
      let ?b = "p a"
      let ?q = "Fun.swap a (p a) id \<circ> p"
      have th0: "p = Fun.swap a ?b id \<circ> ?q"
        unfolding fun_eq_iff o_assoc by simp
      have th1: "?b \<in> insert a S"
        unfolding permutes_in_image[OF pS] by simp
      from permutes_insert_lemma[OF pS] th0 th1
      have "\<exists>b q. p = Fun.swap a b id \<circ> q \<and> b \<in> insert a S \<and> q permutes S" by blast
    }
    moreover
    {
      fix b q
      assume bq: "p = Fun.swap a b id \<circ> q" "b \<in> insert a S" "q permutes S"
      from permutes_subset[OF bq(3), of "insert a S"]
      have qS: "q permutes insert a S"
        by auto
      have aS: "a \<in> insert a S"
        by simp
      from bq(1) permutes_compose[OF qS permutes_swap_id[OF aS bq(2)]]
      have "p permutes insert a S"
        by simp
    }
    ultimately have "p permutes insert a S \<longleftrightarrow>
        (\<exists>b q. p = Fun.swap a b id \<circ> q \<and> b \<in> insert a S \<and> q permutes S)"
      by blast
  }
  then show ?thesis
    by auto
qed

lemma card_permutations:
  assumes Sn: "card S = n"
    and fS: "finite S"
  shows "card {p. p permutes S} = fact n"
  using fS Sn
proof (induct arbitrary: n)
  case empty
  then show ?case by simp
next
  case (insert x F)
  {
    fix n
    assume H0: "card (insert x F) = n"
    let ?xF = "{p. p permutes insert x F}"
    let ?pF = "{p. p permutes F}"
    let ?pF' = "{(b, p). b \<in> insert x F \<and> p \<in> ?pF}"
    let ?g = "(\<lambda>(b, p). Fun.swap x b id \<circ> p)"
    from permutes_insert[of x F]
    have xfgpF': "?xF = ?g ` ?pF'" .
    have Fs: "card F = n - 1"
      using `x \<notin> F` H0 `finite F` by auto
    from insert.hyps Fs have pFs: "card ?pF = fact (n - 1)"
      using `finite F` by auto
    then have "finite ?pF"
      using fact_gt_zero_nat by (auto intro: card_ge_0_finite)
    then have pF'f: "finite ?pF'"
      using H0 `finite F`
      apply (simp only: Collect_split Collect_mem_eq)
      apply (rule finite_cartesian_product)
      apply simp_all
      done

    have ginj: "inj_on ?g ?pF'"
    proof -
      {
        fix b p c q
        assume bp: "(b,p) \<in> ?pF'"
        assume cq: "(c,q) \<in> ?pF'"
        assume eq: "?g (b,p) = ?g (c,q)"
        from bp cq have ths: "b \<in> insert x F" "c \<in> insert x F" "x \<in> insert x F"
          "p permutes F" "q permutes F"
          by auto
        from ths(4) `x \<notin> F` eq have "b = ?g (b,p) x"
          unfolding permutes_def
          by (auto simp add: Fun.swap_def fun_upd_def fun_eq_iff)
        also have "\<dots> = ?g (c,q) x"
          using ths(5) `x \<notin> F` eq
          by (auto simp add: swap_def fun_upd_def fun_eq_iff)
        also have "\<dots> = c"
          using ths(5) `x \<notin> F`
          unfolding permutes_def
          by (auto simp add: Fun.swap_def fun_upd_def fun_eq_iff)
        finally have bc: "b = c" .
        then have "Fun.swap x b id = Fun.swap x c id"
          by simp
        with eq have "Fun.swap x b id \<circ> p = Fun.swap x b id \<circ> q"
          by simp
        then have "Fun.swap x b id \<circ> (Fun.swap x b id \<circ> p) =
          Fun.swap x b id \<circ> (Fun.swap x b id \<circ> q)"
          by simp
        then have "p = q"
          by (simp add: o_assoc)
        with bc have "(b, p) = (c, q)"
          by simp
      }
      then show ?thesis
        unfolding inj_on_def by blast
    qed
    from `x \<notin> F` H0 have n0: "n \<noteq> 0"
      using `finite F` by auto
    then have "\<exists>m. n = Suc m"
      by presburger
    then obtain m where n[simp]: "n = Suc m"
      by blast
    from pFs H0 have xFc: "card ?xF = fact n"
      unfolding xfgpF' card_image[OF ginj]
      using `finite F` `finite ?pF`
      apply (simp only: Collect_split Collect_mem_eq card_cartesian_product)
      apply simp
      done
    from finite_imageI[OF pF'f, of ?g] have xFf: "finite ?xF"
      unfolding xfgpF' by simp
    have "card ?xF = fact n"
      using xFf xFc unfolding xFf by blast
  }
  then show ?case
    using insert by simp
qed

lemma finite_permutations:
  assumes fS: "finite S"
  shows "finite {p. p permutes S}"
  using card_permutations[OF refl fS] fact_gt_zero_nat
  by (auto intro: card_ge_0_finite)

subsection {* Permutations of index set for iterated operations *}

lemma (in comm_monoid_set) permute:
  assumes "p permutes S"
  shows "F g S = F (g \<circ> p) S"
proof -
  from `p permutes S` have "inj p"
    by (rule permutes_inj)
  then have "inj_on p S"
    by (auto intro: subset_inj_on)
  then have "F g (p ` S) = F (g \<circ> p) S"
    by (rule reindex)
  moreover from `p permutes S` have "p ` S = S"
    by (rule permutes_image)
  ultimately show ?thesis
    by simp
qed

lemma setsum_permute:
  assumes "p permutes S"
  shows "setsum f S = setsum (f \<circ> p) S"
  using assms by (fact setsum.permute)

lemma setsum_permute_natseg:
  assumes pS: "p permutes {m .. n}"
  shows "setsum f {m .. n} = setsum (f \<circ> p) {m .. n}"
  using setsum_permute [OF pS, of f ] pS by blast

lemma setprod_permute:
  assumes "p permutes S"
  shows "setprod f S = setprod (f \<circ> p) S"
  using assms by (fact setprod.permute)

lemma setprod_permute_natseg:
  assumes pS: "p permutes {m .. n}"
  shows "setprod f {m .. n} = setprod (f \<circ> p) {m .. n}"
  using setprod_permute [OF pS, of f ] pS by blast

subsection {* Various combinations of transpositions with 2, 1 and 0 common elements *}

lemma swap_id_common:" a \<noteq> c \<Longrightarrow> b \<noteq> c \<Longrightarrow>
  Fun.swap a b id \<circ> Fun.swap a c id = Fun.swap b c id \<circ> Fun.swap a b id"
  by (simp add: fun_eq_iff Fun.swap_def)

lemma swap_id_common': "a \<noteq> b \<Longrightarrow> a \<noteq> c \<Longrightarrow>
  Fun.swap a c id \<circ> Fun.swap b c id = Fun.swap b c id \<circ> Fun.swap a b id"
  by (simp add: fun_eq_iff Fun.swap_def)

lemma swap_id_independent: "a \<noteq> c \<Longrightarrow> a \<noteq> d \<Longrightarrow> b \<noteq> c \<Longrightarrow> b \<noteq> d \<Longrightarrow>
  Fun.swap a b id \<circ> Fun.swap c d id = Fun.swap c d id \<circ> Fun.swap a b id"
  by (simp add: fun_eq_iff Fun.swap_def)

subsection {* Permutations as transposition sequences *}

inductive swapidseq :: "nat \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> bool"
where
  id[simp]: "swapidseq 0 id"
| comp_Suc: "swapidseq n p \<Longrightarrow> a \<noteq> b \<Longrightarrow> swapidseq (Suc n) (Fun.swap a b id \<circ> p)"

declare id[unfolded id_def, simp]

definition "permutation p \<longleftrightarrow> (\<exists>n. swapidseq n p)"

subsection {* Some closure properties of the set of permutations, with lengths *}

lemma permutation_id[simp]: "permutation id"
  unfolding permutation_def by (rule exI[where x=0]) simp

declare permutation_id[unfolded id_def, simp]

lemma swapidseq_swap: "swapidseq (if a = b then 0 else 1) (Fun.swap a b id)"
  apply clarsimp
  using comp_Suc[of 0 id a b]
  apply simp
  done

lemma permutation_swap_id: "permutation (Fun.swap a b id)"
  apply (cases "a = b")
  apply simp_all
  unfolding permutation_def
  using swapidseq_swap[of a b]
  apply blast
  done

lemma swapidseq_comp_add: "swapidseq n p \<Longrightarrow> swapidseq m q \<Longrightarrow> swapidseq (n + m) (p \<circ> q)"
proof (induct n p arbitrary: m q rule: swapidseq.induct)
  case (id m q)
  then show ?case by simp
next
  case (comp_Suc n p a b m q)
  have th: "Suc n + m = Suc (n + m)"
    by arith
  show ?case
    unfolding th comp_assoc
    apply (rule swapidseq.comp_Suc)
    using comp_Suc.hyps(2)[OF comp_Suc.prems] comp_Suc.hyps(3)
    apply blast+
    done
qed

lemma permutation_compose: "permutation p \<Longrightarrow> permutation q \<Longrightarrow> permutation (p \<circ> q)"
  unfolding permutation_def using swapidseq_comp_add[of _ p _ q] by metis

lemma swapidseq_endswap: "swapidseq n p \<Longrightarrow> a \<noteq> b \<Longrightarrow> swapidseq (Suc n) (p \<circ> Fun.swap a b id)"
  apply (induct n p rule: swapidseq.induct)
  using swapidseq_swap[of a b]
  apply (auto simp add: comp_assoc intro: swapidseq.comp_Suc)
  done

lemma swapidseq_inverse_exists: "swapidseq n p \<Longrightarrow> \<exists>q. swapidseq n q \<and> p \<circ> q = id \<and> q \<circ> p = id"
proof (induct n p rule: swapidseq.induct)
  case id
  then show ?case
    by (rule exI[where x=id]) simp
next
  case (comp_Suc n p a b)
  from comp_Suc.hyps obtain q where q: "swapidseq n q" "p \<circ> q = id" "q \<circ> p = id"
    by blast
  let ?q = "q \<circ> Fun.swap a b id"
  note H = comp_Suc.hyps
  from swapidseq_swap[of a b] H(3) have th0: "swapidseq 1 (Fun.swap a b id)"
    by simp
  from swapidseq_comp_add[OF q(1) th0] have th1: "swapidseq (Suc n) ?q"
    by simp
  have "Fun.swap a b id \<circ> p \<circ> ?q = Fun.swap a b id \<circ> (p \<circ> q) \<circ> Fun.swap a b id"
    by (simp add: o_assoc)
  also have "\<dots> = id"
    by (simp add: q(2))
  finally have th2: "Fun.swap a b id \<circ> p \<circ> ?q = id" .
  have "?q \<circ> (Fun.swap a b id \<circ> p) = q \<circ> (Fun.swap a b id \<circ> Fun.swap a b id) \<circ> p"
    by (simp only: o_assoc)
  then have "?q \<circ> (Fun.swap a b id \<circ> p) = id"
    by (simp add: q(3))
  with th1 th2 show ?case
    by blast
qed

lemma swapidseq_inverse:
  assumes H: "swapidseq n p"
  shows "swapidseq n (inv p)"
  using swapidseq_inverse_exists[OF H] inv_unique_comp[of p] by auto

lemma permutation_inverse: "permutation p \<Longrightarrow> permutation (inv p)"
  using permutation_def swapidseq_inverse by blast

subsection {* The identity map only has even transposition sequences *}

lemma symmetry_lemma:
  assumes "\<And>a b c d. P a b c d \<Longrightarrow> P a b d c"
    and "\<And>a b c d. a \<noteq> b \<Longrightarrow> c \<noteq> d \<Longrightarrow>
      a = c \<and> b = d \<or> a = c \<and> b \<noteq> d \<or> a \<noteq> c \<and> b = d \<or> a \<noteq> c \<and> a \<noteq> d \<and> b \<noteq> c \<and> b \<noteq> d \<Longrightarrow>
      P a b c d"
  shows "\<And>a b c d. a \<noteq> b \<longrightarrow> c \<noteq> d \<longrightarrow>  P a b c d"
  using assms by metis

lemma swap_general: "a \<noteq> b \<Longrightarrow> c \<noteq> d \<Longrightarrow>
  Fun.swap a b id \<circ> Fun.swap c d id = id \<or>
  (\<exists>x y z. x \<noteq> a \<and> y \<noteq> a \<and> z \<noteq> a \<and> x \<noteq> y \<and>
    Fun.swap a b id \<circ> Fun.swap c d id = Fun.swap x y id \<circ> Fun.swap a z id)"
proof -
  assume H: "a \<noteq> b" "c \<noteq> d"
  have "a \<noteq> b \<longrightarrow> c \<noteq> d \<longrightarrow>
    (Fun.swap a b id \<circ> Fun.swap c d id = id \<or>
      (\<exists>x y z. x \<noteq> a \<and> y \<noteq> a \<and> z \<noteq> a \<and> x \<noteq> y \<and>
        Fun.swap a b id \<circ> Fun.swap c d id = Fun.swap x y id \<circ> Fun.swap a z id))"
    apply (rule symmetry_lemma[where a=a and b=b and c=c and d=d])
    apply (simp_all only: swap_commute)
    apply (case_tac "a = c \<and> b = d")
    apply (clarsimp simp only: swap_commute swap_id_idempotent)
    apply (case_tac "a = c \<and> b \<noteq> d")
    apply (rule disjI2)
    apply (rule_tac x="b" in exI)
    apply (rule_tac x="d" in exI)
    apply (rule_tac x="b" in exI)
    apply (clarsimp simp add: fun_eq_iff Fun.swap_def)
    apply (case_tac "a \<noteq> c \<and> b = d")
    apply (rule disjI2)
    apply (rule_tac x="c" in exI)
    apply (rule_tac x="d" in exI)
    apply (rule_tac x="c" in exI)
    apply (clarsimp simp add: fun_eq_iff Fun.swap_def)
    apply (rule disjI2)
    apply (rule_tac x="c" in exI)
    apply (rule_tac x="d" in exI)
    apply (rule_tac x="b" in exI)
    apply (clarsimp simp add: fun_eq_iff Fun.swap_def)
    done
  with H show ?thesis by metis
qed

lemma swapidseq_id_iff[simp]: "swapidseq 0 p \<longleftrightarrow> p = id"
  using swapidseq.cases[of 0 p "p = id"]
  by auto

lemma swapidseq_cases: "swapidseq n p \<longleftrightarrow>
  n = 0 \<and> p = id \<or> (\<exists>a b q m. n = Suc m \<and> p = Fun.swap a b id \<circ> q \<and> swapidseq m q \<and> a \<noteq> b)"
  apply (rule iffI)
  apply (erule swapidseq.cases[of n p])
  apply simp
  apply (rule disjI2)
  apply (rule_tac x= "a" in exI)
  apply (rule_tac x= "b" in exI)
  apply (rule_tac x= "pa" in exI)
  apply (rule_tac x= "na" in exI)
  apply simp
  apply auto
  apply (rule comp_Suc, simp_all)
  done

lemma fixing_swapidseq_decrease:
  assumes spn: "swapidseq n p"
    and ab: "a \<noteq> b"
    and pa: "(Fun.swap a b id \<circ> p) a = a"
  shows "n \<noteq> 0 \<and> swapidseq (n - 1) (Fun.swap a b id \<circ> p)"
  using spn ab pa
proof (induct n arbitrary: p a b)
  case 0
  then show ?case
    by (auto simp add: Fun.swap_def fun_upd_def)
next
  case (Suc n p a b)
  from Suc.prems(1) swapidseq_cases[of "Suc n" p]
  obtain c d q m where
    cdqm: "Suc n = Suc m" "p = Fun.swap c d id \<circ> q" "swapidseq m q" "c \<noteq> d" "n = m"
    by auto
  {
    assume H: "Fun.swap a b id \<circ> Fun.swap c d id = id"
    have ?case by (simp only: cdqm o_assoc H) (simp add: cdqm)
  }
  moreover
  {
    fix x y z
    assume H: "x \<noteq> a" "y \<noteq> a" "z \<noteq> a" "x \<noteq> y"
      "Fun.swap a b id \<circ> Fun.swap c d id = Fun.swap x y id \<circ> Fun.swap a z id"
    from H have az: "a \<noteq> z"
      by simp

    {
      fix h
      have "(Fun.swap x y id \<circ> h) a = a \<longleftrightarrow> h a = a"
        using H by (simp add: Fun.swap_def)
    }
    note th3 = this
    from cdqm(2) have "Fun.swap a b id \<circ> p = Fun.swap a b id \<circ> (Fun.swap c d id \<circ> q)"
      by simp
    then have "Fun.swap a b id \<circ> p = Fun.swap x y id \<circ> (Fun.swap a z id \<circ> q)"
      by (simp add: o_assoc H)
    then have "(Fun.swap a b id \<circ> p) a = (Fun.swap x y id \<circ> (Fun.swap a z id \<circ> q)) a"
      by simp
    then have "(Fun.swap x y id \<circ> (Fun.swap a z id \<circ> q)) a = a"
      unfolding Suc by metis
    then have th1: "(Fun.swap a z id \<circ> q) a = a"
      unfolding th3 .
    from Suc.hyps[OF cdqm(3)[ unfolded cdqm(5)[symmetric]] az th1]
    have th2: "swapidseq (n - 1) (Fun.swap a z id \<circ> q)" "n \<noteq> 0"
      by blast+
    have th: "Suc n - 1 = Suc (n - 1)"
      using th2(2) by auto
    have ?case
      unfolding cdqm(2) H o_assoc th
      apply (simp only: Suc_not_Zero simp_thms comp_assoc)
      apply (rule comp_Suc)
      using th2 H
      apply blast+
      done
  }
  ultimately show ?case
    using swap_general[OF Suc.prems(2) cdqm(4)] by metis
qed

lemma swapidseq_identity_even:
  assumes "swapidseq n (id :: 'a \<Rightarrow> 'a)"
  shows "even n"
  using `swapidseq n id`
proof (induct n rule: nat_less_induct)
  fix n
  assume H: "\<forall>m<n. swapidseq m (id::'a \<Rightarrow> 'a) \<longrightarrow> even m" "swapidseq n (id :: 'a \<Rightarrow> 'a)"
  {
    assume "n = 0"
    then have "even n" by presburger
  }
  moreover
  {
    fix a b :: 'a and q m
    assume h: "n = Suc m" "(id :: 'a \<Rightarrow> 'a) = Fun.swap a b id \<circ> q" "swapidseq m q" "a \<noteq> b"
    from fixing_swapidseq_decrease[OF h(3,4), unfolded h(2)[symmetric]]
    have m: "m \<noteq> 0" "swapidseq (m - 1) (id :: 'a \<Rightarrow> 'a)"
      by auto
    from h m have mn: "m - 1 < n"
      by arith
    from H(1)[rule_format, OF mn m(2)] h(1) m(1) have "even n"
      by presburger
  }
  ultimately show "even n"
    using H(2)[unfolded swapidseq_cases[of n id]] by auto
qed

subsection {* Therefore we have a welldefined notion of parity *}

definition "evenperm p = even (SOME n. swapidseq n p)"

lemma swapidseq_even_even:
  assumes m: "swapidseq m p"
    and n: "swapidseq n p"
  shows "even m \<longleftrightarrow> even n"
proof -
  from swapidseq_inverse_exists[OF n]
  obtain q where q: "swapidseq n q" "p \<circ> q = id" "q \<circ> p = id"
    by blast
  from swapidseq_identity_even[OF swapidseq_comp_add[OF m q(1), unfolded q]]
  show ?thesis
    by arith
qed

lemma evenperm_unique:
  assumes p: "swapidseq n p"
    and n:"even n = b"
  shows "evenperm p = b"
  unfolding n[symmetric] evenperm_def
  apply (rule swapidseq_even_even[where p = p])
  apply (rule someI[where x = n])
  using p
  apply blast+
  done

subsection {* And it has the expected composition properties *}

lemma evenperm_id[simp]: "evenperm id = True"
  by (rule evenperm_unique[where n = 0]) simp_all

lemma evenperm_swap: "evenperm (Fun.swap a b id) = (a = b)"
  by (rule evenperm_unique[where n="if a = b then 0 else 1"]) (simp_all add: swapidseq_swap)

lemma evenperm_comp:
  assumes p: "permutation p"
    and q:"permutation q"
  shows "evenperm (p \<circ> q) = (evenperm p = evenperm q)"
proof -
  from p q obtain n m where n: "swapidseq n p" and m: "swapidseq m q"
    unfolding permutation_def by blast
  note nm =  swapidseq_comp_add[OF n m]
  have th: "even (n + m) = (even n \<longleftrightarrow> even m)"
    by arith
  from evenperm_unique[OF n refl] evenperm_unique[OF m refl]
    evenperm_unique[OF nm th]
  show ?thesis
    by blast
qed

lemma evenperm_inv:
  assumes p: "permutation p"
  shows "evenperm (inv p) = evenperm p"
proof -
  from p obtain n where n: "swapidseq n p"
    unfolding permutation_def by blast
  from evenperm_unique[OF swapidseq_inverse[OF n] evenperm_unique[OF n refl, symmetric]]
  show ?thesis .
qed

subsection {* A more abstract characterization of permutations *}

lemma bij_iff: "bij f \<longleftrightarrow> (\<forall>x. \<exists>!y. f y = x)"
  unfolding bij_def inj_on_def surj_def
  apply auto
  apply metis
  apply metis
  done

lemma permutation_bijective:
  assumes p: "permutation p"
  shows "bij p"
proof -
  from p obtain n where n: "swapidseq n p"
    unfolding permutation_def by blast
  from swapidseq_inverse_exists[OF n]
  obtain q where q: "swapidseq n q" "p \<circ> q = id" "q \<circ> p = id"
    by blast
  then show ?thesis unfolding bij_iff
    apply (auto simp add: fun_eq_iff)
    apply metis
    done
qed

lemma permutation_finite_support:
  assumes p: "permutation p"
  shows "finite {x. p x \<noteq> x}"
proof -
  from p obtain n where n: "swapidseq n p"
    unfolding permutation_def by blast
  from n show ?thesis
  proof (induct n p rule: swapidseq.induct)
    case id
    then show ?case by simp
  next
    case (comp_Suc n p a b)
    let ?S = "insert a (insert b {x. p x \<noteq> x})"
    from comp_Suc.hyps(2) have fS: "finite ?S"
      by simp
    from `a \<noteq> b` have th: "{x. (Fun.swap a b id \<circ> p) x \<noteq> x} \<subseteq> ?S"
      by (auto simp add: Fun.swap_def)
    from finite_subset[OF th fS] show ?case  .
  qed
qed

lemma bij_inv_eq_iff: "bij p \<Longrightarrow> x = inv p y \<longleftrightarrow> p x = y"
  using surj_f_inv_f[of p] by (auto simp add: bij_def)

lemma bij_swap_comp:
  assumes bp: "bij p"
  shows "Fun.swap a b id \<circ> p = Fun.swap (inv p a) (inv p b) p"
  using surj_f_inv_f[OF bij_is_surj[OF bp]]
  by (simp add: fun_eq_iff Fun.swap_def bij_inv_eq_iff[OF bp])

lemma bij_swap_ompose_bij: "bij p \<Longrightarrow> bij (Fun.swap a b id \<circ> p)"
proof -
  assume H: "bij p"
  show ?thesis
    unfolding bij_swap_comp[OF H] bij_swap_iff
    using H .
qed

lemma permutation_lemma:
  assumes fS: "finite S"
    and p: "bij p"
    and pS: "\<forall>x. x\<notin> S \<longrightarrow> p x = x"
  shows "permutation p"
  using fS p pS
proof (induct S arbitrary: p rule: finite_induct)
  case (empty p)
  then show ?case by simp
next
  case (insert a F p)
  let ?r = "Fun.swap a (p a) id \<circ> p"
  let ?q = "Fun.swap a (p a) id \<circ> ?r"
  have raa: "?r a = a"
    by (simp add: Fun.swap_def)
  from bij_swap_ompose_bij[OF insert(4)]
  have br: "bij ?r"  .

  from insert raa have th: "\<forall>x. x \<notin> F \<longrightarrow> ?r x = x"
    apply (clarsimp simp add: Fun.swap_def)
    apply (erule_tac x="x" in allE)
    apply auto
    unfolding bij_iff
    apply metis
    done
  from insert(3)[OF br th]
  have rp: "permutation ?r" .
  have "permutation ?q"
    by (simp add: permutation_compose permutation_swap_id rp)
  then show ?case
    by (simp add: o_assoc)
qed

lemma permutation: "permutation p \<longleftrightarrow> bij p \<and> finite {x. p x \<noteq> x}"
  (is "?lhs \<longleftrightarrow> ?b \<and> ?f")
proof
  assume p: ?lhs
  from p permutation_bijective permutation_finite_support show "?b \<and> ?f"
    by auto
next
  assume "?b \<and> ?f"
  then have "?f" "?b" by blast+
  from permutation_lemma[OF this] show ?lhs
    by blast
qed

lemma permutation_inverse_works:
  assumes p: "permutation p"
  shows "inv p \<circ> p = id"
    and "p \<circ> inv p = id"
  using permutation_bijective [OF p]
  unfolding bij_def inj_iff surj_iff by auto

lemma permutation_inverse_compose:
  assumes p: "permutation p"
    and q: "permutation q"
  shows "inv (p \<circ> q) = inv q \<circ> inv p"
proof -
  note ps = permutation_inverse_works[OF p]
  note qs = permutation_inverse_works[OF q]
  have "p \<circ> q \<circ> (inv q \<circ> inv p) = p \<circ> (q \<circ> inv q) \<circ> inv p"
    by (simp add: o_assoc)
  also have "\<dots> = id"
    by (simp add: ps qs)
  finally have th0: "p \<circ> q \<circ> (inv q \<circ> inv p) = id" .
  have "inv q \<circ> inv p \<circ> (p \<circ> q) = inv q \<circ> (inv p \<circ> p) \<circ> q"
    by (simp add: o_assoc)
  also have "\<dots> = id"
    by (simp add: ps qs)
  finally have th1: "inv q \<circ> inv p \<circ> (p \<circ> q) = id" .
  from inv_unique_comp[OF th0 th1] show ?thesis .
qed

subsection {* Relation to "permutes" *}

lemma permutation_permutes: "permutation p \<longleftrightarrow> (\<exists>S. finite S \<and> p permutes S)"
  unfolding permutation permutes_def bij_iff[symmetric]
  apply (rule iffI, clarify)
  apply (rule exI[where x="{x. p x \<noteq> x}"])
  apply simp
  apply clarsimp
  apply (rule_tac B="S" in finite_subset)
  apply auto
  done

subsection {* Hence a sort of induction principle composing by swaps *}

lemma permutes_induct: "finite S \<Longrightarrow> P id \<Longrightarrow>
  (\<And> a b p. a \<in> S \<Longrightarrow> b \<in> S \<Longrightarrow> P p \<Longrightarrow> P p \<Longrightarrow> permutation p \<Longrightarrow> P (Fun.swap a b id \<circ> p)) \<Longrightarrow>
  (\<And>p. p permutes S \<Longrightarrow> P p)"
proof (induct S rule: finite_induct)
  case empty
  then show ?case by auto
next
  case (insert x F p)
  let ?r = "Fun.swap x (p x) id \<circ> p"
  let ?q = "Fun.swap x (p x) id \<circ> ?r"
  have qp: "?q = p"
    by (simp add: o_assoc)
  from permutes_insert_lemma[OF insert.prems(3)] insert have Pr: "P ?r"
    by blast
  from permutes_in_image[OF insert.prems(3), of x]
  have pxF: "p x \<in> insert x F"
    by simp
  have xF: "x \<in> insert x F"
    by simp
  have rp: "permutation ?r"
    unfolding permutation_permutes using insert.hyps(1)
      permutes_insert_lemma[OF insert.prems(3)]
    by blast
  from insert.prems(2)[OF xF pxF Pr Pr rp]
  show ?case
    unfolding qp .
qed

subsection {* Sign of a permutation as a real number *}

definition "sign p = (if evenperm p then (1::int) else -1)"

lemma sign_nz: "sign p \<noteq> 0"
  by (simp add: sign_def)

lemma sign_id: "sign id = 1"
  by (simp add: sign_def)

lemma sign_inverse: "permutation p \<Longrightarrow> sign (inv p) = sign p"
  by (simp add: sign_def evenperm_inv)

lemma sign_compose: "permutation p \<Longrightarrow> permutation q \<Longrightarrow> sign (p \<circ> q) = sign p * sign q"
  by (simp add: sign_def evenperm_comp)

lemma sign_swap_id: "sign (Fun.swap a b id) = (if a = b then 1 else -1)"
  by (simp add: sign_def evenperm_swap)

lemma sign_idempotent: "sign p * sign p = 1"
  by (simp add: sign_def)

subsection {* More lemmas about permutations *}

lemma permutes_natset_le:
  fixes S :: "'a::wellorder set"
  assumes p: "p permutes S"
    and le: "\<forall>i \<in> S. p i \<le> i"
  shows "p = id"
proof -
  {
    fix n
    have "p n = n"
      using p le
    proof (induct n arbitrary: S rule: less_induct)
      fix n S
      assume H:
        "\<And>m S. m < n \<Longrightarrow> p permutes S \<Longrightarrow> \<forall>i\<in>S. p i \<le> i \<Longrightarrow> p m = m"
        "p permutes S" "\<forall>i \<in>S. p i \<le> i"
      {
        assume "n \<notin> S"
        with H(2) have "p n = n"
          unfolding permutes_def by metis
      }
      moreover
      {
        assume ns: "n \<in> S"
        from H(3)  ns have "p n < n \<or> p n = n"
          by auto
        moreover {
          assume h: "p n < n"
          from H h have "p (p n) = p n"
            by metis
          with permutes_inj[OF H(2)] have "p n = n"
            unfolding inj_on_def by blast
          with h have False
            by simp
        }
        ultimately have "p n = n"
          by blast
      }
      ultimately show "p n = n"
        by blast
    qed
  }
  then show ?thesis
    by (auto simp add: fun_eq_iff)
qed

lemma permutes_natset_ge:
  fixes S :: "'a::wellorder set"
  assumes p: "p permutes S"
    and le: "\<forall>i \<in> S. p i \<ge> i"
  shows "p = id"
proof -
  {
    fix i
    assume i: "i \<in> S"
    from i permutes_in_image[OF permutes_inv[OF p]] have "inv p i \<in> S"
      by simp
    with le have "p (inv p i) \<ge> inv p i"
      by blast
    with permutes_inverses[OF p] have "i \<ge> inv p i"
      by simp
  }
  then have th: "\<forall>i\<in>S. inv p i \<le> i"
    by blast
  from permutes_natset_le[OF permutes_inv[OF p] th]
  have "inv p = inv id"
    by simp
  then show ?thesis
    apply (subst permutes_inv_inv[OF p, symmetric])
    apply (rule inv_unique_comp)
    apply simp_all
    done
qed

lemma image_inverse_permutations: "{inv p |p. p permutes S} = {p. p permutes S}"
  apply (rule set_eqI)
  apply auto
  using permutes_inv_inv permutes_inv
  apply auto
  apply (rule_tac x="inv x" in exI)
  apply auto
  done

lemma image_compose_permutations_left:
  assumes q: "q permutes S"
  shows "{q \<circ> p | p. p permutes S} = {p . p permutes S}"
  apply (rule set_eqI)
  apply auto
  apply (rule permutes_compose)
  using q
  apply auto
  apply (rule_tac x = "inv q \<circ> x" in exI)
  apply (simp add: o_assoc permutes_inv permutes_compose permutes_inv_o)
  done

lemma image_compose_permutations_right:
  assumes q: "q permutes S"
  shows "{p \<circ> q | p. p permutes S} = {p . p permutes S}"
  apply (rule set_eqI)
  apply auto
  apply (rule permutes_compose)
  using q
  apply auto
  apply (rule_tac x = "x \<circ> inv q" in exI)
  apply (simp add: o_assoc permutes_inv permutes_compose permutes_inv_o comp_assoc)
  done

lemma permutes_in_seg: "p permutes {1 ..n} \<Longrightarrow> i \<in> {1..n} \<Longrightarrow> 1 \<le> p i \<and> p i \<le> n"
  by (simp add: permutes_def) metis

lemma setsum_permutations_inverse:
  "setsum f {p. p permutes S} = setsum (\<lambda>p. f(inv p)) {p. p permutes S}"
  (is "?lhs = ?rhs")
proof -
  let ?S = "{p . p permutes S}"
  have th0: "inj_on inv ?S"
  proof (auto simp add: inj_on_def)
    fix q r
    assume q: "q permutes S"
      and r: "r permutes S"
      and qr: "inv q = inv r"
    then have "inv (inv q) = inv (inv r)"
      by simp
    with permutes_inv_inv[OF q] permutes_inv_inv[OF r] show "q = r"
      by metis
  qed
  have th1: "inv ` ?S = ?S"
    using image_inverse_permutations by blast
  have th2: "?rhs = setsum (f \<circ> inv) ?S"
    by (simp add: o_def)
  from setsum.reindex[OF th0, of f] show ?thesis unfolding th1 th2 .
qed

lemma setum_permutations_compose_left:
  assumes q: "q permutes S"
  shows "setsum f {p. p permutes S} = setsum (\<lambda>p. f(q \<circ> p)) {p. p permutes S}"
  (is "?lhs = ?rhs")
proof -
  let ?S = "{p. p permutes S}"
  have th0: "?rhs = setsum (f \<circ> (op \<circ> q)) ?S"
    by (simp add: o_def)
  have th1: "inj_on (op \<circ> q) ?S"
  proof (auto simp add: inj_on_def)
    fix p r
    assume "p permutes S"
      and r: "r permutes S"
      and rp: "q \<circ> p = q \<circ> r"
    then have "inv q \<circ> q \<circ> p = inv q \<circ> q \<circ> r"
      by (simp add: comp_assoc)
    with permutes_inj[OF q, unfolded inj_iff] show "p = r"
      by simp
  qed
  have th3: "(op \<circ> q) ` ?S = ?S"
    using image_compose_permutations_left[OF q] by auto
  from setsum.reindex[OF th1, of f] show ?thesis unfolding th0 th1 th3 .
qed

lemma sum_permutations_compose_right:
  assumes q: "q permutes S"
  shows "setsum f {p. p permutes S} = setsum (\<lambda>p. f(p \<circ> q)) {p. p permutes S}"
  (is "?lhs = ?rhs")
proof -
  let ?S = "{p. p permutes S}"
  have th0: "?rhs = setsum (f \<circ> (\<lambda>p. p \<circ> q)) ?S"
    by (simp add: o_def)
  have th1: "inj_on (\<lambda>p. p \<circ> q) ?S"
  proof (auto simp add: inj_on_def)
    fix p r
    assume "p permutes S"
      and r: "r permutes S"
      and rp: "p \<circ> q = r \<circ> q"
    then have "p \<circ> (q \<circ> inv q) = r \<circ> (q \<circ> inv q)"
      by (simp add: o_assoc)
    with permutes_surj[OF q, unfolded surj_iff] show "p = r"
      by simp
  qed
  have th3: "(\<lambda>p. p \<circ> q) ` ?S = ?S"
    using image_compose_permutations_right[OF q] by auto
  from setsum.reindex[OF th1, of f]
  show ?thesis unfolding th0 th1 th3 .
qed

subsection {* Sum over a set of permutations (could generalize to iteration) *}

lemma setsum_over_permutations_insert:
  assumes fS: "finite S"
    and aS: "a \<notin> S"
  shows "setsum f {p. p permutes (insert a S)} =
    setsum (\<lambda>b. setsum (\<lambda>q. f (Fun.swap a b id \<circ> q)) {p. p permutes S}) (insert a S)"
proof -
  have th0: "\<And>f a b. (\<lambda>(b,p). f (Fun.swap a b id \<circ> p)) = f \<circ> (\<lambda>(b,p). Fun.swap a b id \<circ> p)"
    by (simp add: fun_eq_iff)
  have th1: "\<And>P Q. P \<times> Q = {(a,b). a \<in> P \<and> b \<in> Q}"
    by blast
  have th2: "\<And>P Q. P \<Longrightarrow> (P \<Longrightarrow> Q) \<Longrightarrow> P \<and> Q"
    by blast
  show ?thesis
    unfolding permutes_insert
    unfolding setsum.cartesian_product
    unfolding th1[symmetric]
    unfolding th0
  proof (rule setsum.reindex)
    let ?f = "(\<lambda>(b, y). Fun.swap a b id \<circ> y)"
    let ?P = "{p. p permutes S}"
    {
      fix b c p q
      assume b: "b \<in> insert a S"
      assume c: "c \<in> insert a S"
      assume p: "p permutes S"
      assume q: "q permutes S"
      assume eq: "Fun.swap a b id \<circ> p = Fun.swap a c id \<circ> q"
      from p q aS have pa: "p a = a" and qa: "q a = a"
        unfolding permutes_def by metis+
      from eq have "(Fun.swap a b id \<circ> p) a  = (Fun.swap a c id \<circ> q) a"
        by simp
      then have bc: "b = c"
        by (simp add: permutes_def pa qa o_def fun_upd_def Fun.swap_def id_def
            cong del: if_weak_cong split: split_if_asm)
      from eq[unfolded bc] have "(\<lambda>p. Fun.swap a c id \<circ> p) (Fun.swap a c id \<circ> p) =
        (\<lambda>p. Fun.swap a c id \<circ> p) (Fun.swap a c id \<circ> q)" by simp
      then have "p = q"
        unfolding o_assoc swap_id_idempotent
        by (simp add: o_def)
      with bc have "b = c \<and> p = q"
        by blast
    }
    then show "inj_on ?f (insert a S \<times> ?P)"
      unfolding inj_on_def by clarify metis
  qed
qed

end


section "Topological Sorting"

theory topological_sort
  imports Main "HOL-Library.Multiset"
    "fuzzyrule.fuzzyrule"
begin

text "A list is sorted by a partial order, if no element in the list is followed by a smaller
element with respect to the relation."

definition sorted_by where
"sorted_by rel xs \<equiv> \<forall>i j. i<j \<longrightarrow> j<length xs \<longrightarrow> (xs!j,xs!i)\<notin>rel"

lemma sorted_by_empty:
"sorted_by R []"
  by (auto simp add: sorted_by_def)

lemma sorted_by_single:
"sorted_by R [x]"
  by (auto simp add: sorted_by_def)

lemma sorted_by_prepend_smallest:
  assumes "\<forall>y\<in>set xs. (y,x)\<notin>R"
    and "sorted_by R xs"
  shows "sorted_by R (x#xs)"
  using assms by (auto simp add: sorted_by_def nth_Cons split: nat.splits)

lemma sorted_by_sublist_left:
  assumes a: "sorted_by R (xs@ys)"
  shows "sorted_by R xs"
  using a by (auto simp add: sorted_by_def nth_append split: if_splits)

lemma sorted_by_sublist_right:
  assumes a: "sorted_by R (xs@ys)"
  shows "sorted_by R ys"
  using a by (auto simp add: sorted_by_def nth_append split: if_splits,
      metis add.commute add_diff_cancel_left' add_less_cancel_right add_less_same_cancel1 not_less_zero)

lemma sorted_by_append:
  assumes "sorted_by R (xs @ ys)"
      and c1: "x \<in> set xs"
      and c2: "y \<in> set ys"
    shows "(y, x) \<notin> R"
  using assms apply (auto simp add: sorted_by_def nth_append in_set_conv_nth split: if_splits)
  by (smt add_diff_cancel_left' add_diff_cancel_right' diff_le_self less_diff_conv less_le_trans not_add_less2)

lemma sorted_by_append_iff:
  shows "sorted_by R (xs@ys) \<longleftrightarrow> (sorted_by R xs \<and> sorted_by R ys \<and> (\<forall>x\<in>set xs. \<forall>y\<in>set ys. (y,x)\<notin>R))"
proof auto
  show "sorted_by R (xs @ ys) \<Longrightarrow> sorted_by R xs"
    using sorted_by_sublist_left by blast
  show "sorted_by R (xs @ ys) \<Longrightarrow> sorted_by R ys"
    using sorted_by_sublist_right by blast

  show "False"
    if c0: "sorted_by R (xs @ ys)"
      and c1: "x \<in> set xs"
      and c2: "y \<in> set ys"
      and c3: "(y, x) \<in> R"
    for  x y
    by (meson c0 c1 c2 c3 sorted_by_append)

  show "sorted_by R (xs @ ys)"
    if c0: "sorted_by R xs"
      and c1: "sorted_by R ys"
      and c2: "\<forall>x\<in>set xs. \<forall>y\<in>set ys. (y, x) \<notin> R"
    apply (auto simp add: sorted_by_def nth_append)
    using c0 sorted_by_def apply blast
    apply (simp add: c2)
    by (metis add_diff_inverse_nat c1 dual_order.strict_trans nat_add_left_cancel_less sorted_by_def)
qed

lemma sorted_by_cons_iff:
  shows "sorted_by R (x#xs) \<longleftrightarrow> (sorted_by R xs \<and> (\<forall>y\<in>set xs. (y,x)\<notin>R))"
  using sorted_by_append_iff[where R=R and xs="[x]" and ys="xs"]
  by (auto simp add: sorted_by_single)

text "For strict linear orders, @{term sorted_by} is the same as @{term sorted}:"

lemma sorted_by_eq_sorted:
"sorted_by {(x::'a::linorder,y). x < y} xs = sorted xs"
  by (induct xs, auto simp add: sorted_by_empty sorted_by_cons_iff)

fun top_sort where
  "top_sort R [] = []"
| "top_sort R (x#xs) = (
    let (greater, not_greater) = partition (\<lambda>y. R x y) xs in
    top_sort R not_greater @ x # top_sort R greater)"

value "top_sort (\<subset>) [{1,2,3}, {1}, {1}, {2,3,4}, {2}, {1,3::int}, {}]"

lemma top_sort_mset[simp]:
"mset (top_sort R xs) = mset xs"
proof (induct R xs rule: top_sort.induct)
  case (1 R)
  show "mset (top_sort R []) = mset [] "
    by simp
next
  case (2 R x xs)
  show " mset (top_sort R (x # xs)) = mset (x # xs)"
    using 2 by auto
qed

lemma top_sort_set[simp]:
"set (top_sort R xs) = set xs"
  by (metis set_mset_mset top_sort_mset)

lemma top_sort_sorts_irrefl:
  assumes trans: "trans {(x,y). R x y}"
    and irrefl: "irrefl {(x,y). R x y}"
  shows "sorted_by {(x,y). R x y} (top_sort R xs)"
using trans irrefl proof (induct R xs rule: top_sort.induct)
case (1 R)
  then show ?case
    by (auto simp add: sorted_by_empty)
next
  case (2 R x xs)
  show ?case
  proof (auto simp add: sorted_by_append_iff sorted_by_cons_iff)
    show "sorted_by {(x, y). R x y} (top_sort R (filter (Not \<circ> R x) xs))"
      by (simp add: 2)
    show "sorted_by {(x, y). R x y} (top_sort R (filter (R x) xs))"
      by (simp add: 2)
    show "\<And>y. \<lbrakk>y \<in> set xs; R x y; R y x\<rbrakk> \<Longrightarrow> False"
      by (metis "2.prems"(1) "2.prems"(2) case_prodI irrefl_def mem_Collect_eq trans_def)
    show "\<And>xa y. \<lbrakk>xa \<in> set xs; \<not> R x xa; y \<in> set xs; R x y; R y xa\<rbrakk> \<Longrightarrow> False"
      by (smt "2.prems"(1) case_prodD case_prodI mem_Collect_eq transE)
  qed
qed

lemma top_sort_sorts_distinct:
  assumes trans: "trans {(x,y). R x y}"
    and irrefl: "\<And>x y. x\<in>set xs \<Longrightarrow> y\<in>set xs \<Longrightarrow> R x y \<Longrightarrow> x\<noteq>y \<Longrightarrow> \<not>R y x"
    and distinct: "distinct xs"
  shows "sorted_by {(x,y). R x y} (top_sort R xs)"
using trans irrefl distinct proof (induct R xs rule: top_sort.induct)
case (1 R)
  then show ?case
    by (auto simp add: sorted_by_empty)
next
  case (2 R x xs)
  have irrefl: "\<And>x y. x\<in>set xs \<Longrightarrow> y\<in>set xs \<Longrightarrow> R x y \<Longrightarrow> x\<noteq>y \<Longrightarrow> \<not>R y x"
    by (simp add: "2.prems"(2))

  show ?case
  proof (auto simp add: sorted_by_append_iff sorted_by_cons_iff)
    show "sorted_by {(x, y). R x y} (top_sort R (filter (Not \<circ> R x) xs))"
      by (rule 2, insert "2.prems"(3) irrefl, auto simp add: "2.prems"(1))
    show "sorted_by {(x, y). R x y} (top_sort R (filter (R x) xs))"
      by (rule 2, insert "2.prems"(3) irrefl, auto simp add: "2.prems"(1))
    show "\<And>y. \<lbrakk>y \<in> set xs; R x y; R y x\<rbrakk> \<Longrightarrow> False"
      using "2.prems"(2) "2.prems"(3) by auto
    show "\<And>xa y. \<lbrakk>xa \<in> set xs; \<not> R x xa; y \<in> set xs; R x y; R y xa\<rbrakk> \<Longrightarrow> False"
      by (smt "2.prems"(1) case_prodD case_prodI mem_Collect_eq transE)
  qed
qed

lemma exists_sorted_by:
  assumes fin: "finite S"
    and trans: "trans R"
    and irrefl2: "\<And>x y. x\<in>S \<Longrightarrow> y\<in>S \<Longrightarrow> (x,y)\<in>R \<Longrightarrow> x\<noteq>y \<Longrightarrow> (y,x)\<notin>R"
shows "\<exists>l. set l = S \<and> sorted_by R l"
proof -
  obtain ul where "set ul = S" and "distinct ul"
    using fin finite_distinct_list by auto

  have "sorted_by R (top_sort (\<lambda>x y. (x,y)\<in>R) ul)"
    by (fuzzy_rule top_sort_sorts_distinct; (simp add: trans `distinct ul`  \<open>set ul = S\<close> irrefl2)?)

  thus ?thesis
    by (metis \<open>set ul = S\<close> top_sort_set)
qed

lemma exists_sorted_by_irrefl:
  assumes fin: "finite S"
    and trans: "trans R"
    and irrefl: "irrefl R"
  shows "\<exists>l. set l = S \<and> sorted_by R l"
  by (meson exists_sorted_by fin irrefl irrefl_def local.trans transE)

lemma exists_sorted_by_antisym:
  assumes fin: "finite S"
    and trans: "trans R"
    and irrefl: "antisym R"
  shows "\<exists>l. set l = S \<and> sorted_by R l"
  by (meson antisym_def exists_sorted_by fin irrefl local.trans)

end


theory Van_der_Waerden
  imports Main "HOL-Library.FuncSet" Digits
begin

section \<open>Van der Waerden's Theorem\<close>

text \<open>In combinatorics, Van der Waerden's Theorem is about arithmetic progressions of a certain
length of the same colour in a colouring of an interval. In order to state the theorem and to
prove it, we need to formally introduce arithmetic progressions. We will express $k$-colourings as
functions mapping an integer interval to the set $\{0,\dots , k-1 \}$ of colours.\<close>

subsection \<open>Arithmetic progressions\<close>

text \<open>A sequence of integer numbers with the same step size is called an arithmetic progression.
 We say an  $m$-fold arithmetic progression is an arithmetic progression with multiple step
lengths.\<close>

text \<open> Arithmetic progressions are defined in the following using the variables:

\begin{tabular}{lcp{8cm}}
$start$:& \<open>int\<close>& starting value\\
$step$:&  \<open>nat\<close>& positive integer for step length\\
$i$:&     \<open>nat\<close>& $i$-th value in the arithmetic progression \\
\end{tabular}\<close>

definition arith_prog :: "int \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> int"
  where "arith_prog start step i = start + int (i * step)"

text \<open> An $m$-fold arithmetic progression (which we will also call a multi-arithmetic progression)
is defined in the following using the variables:

\begin{tabular}{lcp{8cm}}
$dims$:&   \<open>nat\<close>& number of dimensions/step directions of $m$-fold arithmetic progression\\
$start$:&  \<open>int\<close>& starting value\\
$steps$:&  \<open>nat \<Rightarrow> nat\<close>& function of steps, returns step in $i$-th dimension for $i\in[0..<dims]$\\
$c$:&      \<open>nat \<Rightarrow> nat\<close>& function of coefficients, returns coefficient in $i$-th dimension for
           $i\in[0..<dims]$ \\
\end{tabular}\<close>

definition multi_arith_prog ::
    "nat \<Rightarrow> int \<Rightarrow> (nat \<Rightarrow> nat) \<Rightarrow> (nat \<Rightarrow> nat) \<Rightarrow> int"
  where "multi_arith_prog dims start steps c =
           start + int (\<Sum>i<dims. c i * steps i)"

text \<open>An $m$-fold arithmetic progression of dimension $1$ is also an arithmetic progression and
  vice versa. This is shown in the following lemmas.\<close>
lemma multi_to_arith_prog:
  "multi_arith_prog 1 start steps c =
    arith_prog start (steps 0) (c 0)"
  unfolding multi_arith_prog_def arith_prog_def by auto

lemma arith_prog_to_multi:
  "arith_prog start step c =
    multi_arith_prog 1 start (\<lambda>_. step) (\<lambda>_. c)"
  unfolding multi_arith_prog_def arith_prog_def by auto

text \<open>To show that an arithmetic progression is well-defined, we introduce the following predicate.
It assures that \<open>arith_prog start step ` [0..<l]\<close> is contained in the integer interval $[a..b]$.\<close>
definition is_arith_prog_on ::
    "nat \<Rightarrow> int \<Rightarrow> nat \<Rightarrow> int \<Rightarrow> int \<Rightarrow> bool"
  where "is_arith_prog_on l start step a b \<longleftrightarrow>
    (start \<ge> a \<and> arith_prog start step (l-1) \<le> b)"

text \<open>Furthermore, we have monotonicity for arithmetic progressions.\<close>
lemma arith_prog_mono:
  assumes "c \<le> c'"
  shows   "arith_prog start step c \<le> arith_prog start step c'"
  using assms unfolding arith_prog_def by (auto intro: mult_mono)

text \<open>Now, we state the well-definedness of an arithmetic progression of length $l$ in an integer
interval $[a..b]$.
Indeed, \<open>is_arith_prog_on\<close> guarantees that every element of \<open>arith_prog start step\<close> of length $l$
  lies in $[a..b]$.\<close>
lemma is_arith_prog_onD:
  assumes "is_arith_prog_on l start step a b"
  assumes "c \<in> {0..<l}"
  shows   "arith_prog start step c \<in> {a..b}"
proof -
  have "arith_prog start step 0 \<le> arith_prog start step c"
    by (rule arith_prog_mono) auto
  hence "arith_prog start step c \<ge> a"
    using assms by (simp add: arith_prog_def is_arith_prog_on_def
                      add_increasing2)
  moreover have "arith_prog start step (l-1) \<ge>
                   arith_prog start step c"
    by (rule arith_prog_mono) (use assms(2) in auto)
  hence "arith_prog start step c \<le> b"
    using assms unfolding arith_prog_def is_arith_prog_on_def
    by linarith
  ultimately show ?thesis
    by auto
qed

text \<open>We also need a predicate for an $m$-fold arithmetic progression to be well-defined.
It assures that \<open>multi_arith_prog start step ` [0..<l]^m\<close> is contained in $[a..b]$.\<close>
definition is_multi_arith_prog_on ::
    "nat \<Rightarrow> nat \<Rightarrow> int \<Rightarrow> (nat \<Rightarrow> nat) \<Rightarrow> int \<Rightarrow> int \<Rightarrow> bool"
  where "is_multi_arith_prog_on l m start steps a b \<longleftrightarrow>
     (start \<ge> a \<and> multi_arith_prog m start steps (\<lambda>_. l-1) \<le> b)"

text \<open>Moreover, we have monotonicity for $m$-fold arithmetic progressions as well.\<close>
lemma multi_arith_prog_mono:
  assumes "\<And>i. i < m \<Longrightarrow> c i \<le> c' i"
  shows   "multi_arith_prog m start steps c \<le>
            multi_arith_prog m start steps c'"
  using assms unfolding multi_arith_prog_def
  by (auto intro!: sum_mono intro: mult_right_mono)

text \<open>Finally, we get the well-definedness for $m$-fold arithmetic progressions of length $l$.
Here, \<open>is_multi_arith_prog_on\<close> guarantees that every element of \<open>multi_arith_prog start step\<close>
  of length $l$ lies in $[a..b]$.\<close>
lemma is_multi_arith_prog_onD:
  assumes "is_multi_arith_prog_on l m start steps a b"
  assumes "c \<in> {0..<m} \<rightarrow> {0..<l}"
  shows   "multi_arith_prog m start steps c \<in> {a..b}"
proof -
  have "multi_arith_prog m start steps (\<lambda>_. 0) \<le>
          multi_arith_prog m start steps c"
    by (rule multi_arith_prog_mono) auto
  hence "multi_arith_prog m start steps c \<ge> a"
    using assms by (simp add: multi_arith_prog_def
       is_multi_arith_prog_on_def)
  moreover have "multi_arith_prog m start steps (\<lambda>_. l-1) \<ge>
                   multi_arith_prog m start steps c"
    by (rule multi_arith_prog_mono) (use assms in force)
  hence "multi_arith_prog m start steps c \<le> b"
    using assms by (simp add: multi_arith_prog_def
        is_multi_arith_prog_on_def)
  ultimately show ?thesis
    by auto
qed

subsection \<open>Van der Waerden's Theorem\<close>

text \<open>The property for a number $n$ to fulfill Van der Waerden's theorem is the following:\\
For a $k$-colouring col of $[a..b]$ there exist
\begin{itemize}
\item $start$: starting value of an arithmetic progression
\item $step$:  step length of an arithmetic progression
\item $j$: colour
\end{itemize}
such that \<open>arith_prog start step\<close> is a valid arithmetic progression of length $l$ lying
in $[a..b]$ of the same colour $j$.

The following variables will be used:\\
\begin{tabular}{lcp{8cm}}
$k$:& \<open>nat\<close>& number of colours in segment colouring on $[a..b]$\\
$l$:& \<open>nat\<close>& length of arithmetic progression\\
$n$:& \<open>nat\<close>& number fulfilling Van der Waerden's Theorem\\
\end{tabular}
\<close>
definition vdw ::
    "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> bool"
  where "vdw k l n \<longleftrightarrow>
     (\<forall>a b col. b + 1 \<ge> a + int n \<and> col \<in> {a..b} \<rightarrow> {..<k} \<longrightarrow>
       (\<exists>j start step. j < k \<and> step > 0 \<and>
        is_arith_prog_on l start step a b \<and>
        arith_prog start step ` {..<l} \<subseteq> col -` {j} \<inter> {a..b}))"

text \<open>To better work with the property of Van der Waerden's theorem, we introduce an
  elimination rule.\<close>
lemma vdwE:
  assumes "vdw k l n"
          "b + 1 \<ge> a + int n"
          "col \<in> {a..b} \<rightarrow> {..<k}"
  obtains j start step where
    "j < k" "step > 0"
    "is_arith_prog_on l start step a b"
    "arith_prog start step ` {..<l} \<subseteq> col -` {j} \<inter> {a..b}"
  using assms that unfolding vdw_def by metis

text \<open>Van der Waerden's theorem implies that the number fulfilling it is positive. This is show
in the following lemma.\<close>
lemma vdw_imp_pos:
  assumes "vdw k l n"
          "l > 0"
  shows "n > 0"
proof (rule Nat.gr0I)
  assume [simp]: "n = 0"
  show False
    using assms
    by (elim vdwE[where a = 1 and b = 0 and col = "\<lambda>_. 0"])
       (auto simp: lessThan_empty_iff)
qed

text \<open>Van der Waerden's Theorem is trivial for a non-existent colouring.
It also makes no sense for arithmetic progressions of length 0.\<close>
lemma vdw_0_left [simp, intro]: "n>0 \<Longrightarrow> vdw 0 l n"
  by (auto simp: vdw_def)

text \<open>In the case of $k=1$, Van der Waerden's Theorem holds. Then every number has the same colour,
hence also the arithmetic progression. A possible choice for the number fulfilling Van der
Waerden Theorem is $l$.\<close>
lemma vdw_1_left:
  assumes "l>0"
  shows "vdw 1 l l"
unfolding vdw_def
proof (safe, goal_cases)
  case (1 a b col)
  have "arith_prog a 1 ` {..<l} \<subseteq> {a..b}"
    using 1(1) by (auto simp: arith_prog_def)
  also have "{a..b} = col -` {0} \<inter> {a..b}"
    using 1(2) by auto
  finally have "arith_prog a 1 ` {..<l} \<subseteq> col -` {0} \<inter> {a..b}"
    by auto
  moreover have "is_arith_prog_on l a 1 a b"
    unfolding is_arith_prog_on_def arith_prog_def using 1 assms
    by auto
  ultimately show "\<exists>j start step. j < 1 \<and> 0 < step \<and>
        is_arith_prog_on l start step a b \<and>
        arith_prog start step ` {..<l} \<subseteq> col -` {j} \<inter> {a..b}"
    by auto
qed

text \<open>In the case $l=1$, Van der Waerden's Theorem holds. As the length of the arithmetic
progression is $1$, it consists of just one element. Thus every nonempty integer interval fulfills
the Van der Waerden property. We can prove $N_{k,1}$ to be $1$.\<close>
lemma vdw_1_right: "vdw k 1 1"
unfolding vdw_def
proof safe
  fix a b :: int and col :: "int \<Rightarrow> nat"
  assume *: "a + int 1 \<le> b + 1" "col \<in> {a..b} \<rightarrow> {..<k}"
  have "col a < k" using * by auto
  have "arith_prog a 1 ` {..<1} = {a}"
    using *(1) by (auto simp: arith_prog_def)
  also have "{a} \<subseteq> col -` {col a} \<inter> {a..b}"
    using * by auto
  finally have "arith_prog a 1 ` {..<1} \<subseteq> col -` {col a} \<inter> {a..b}"
    by auto
  moreover have "is_arith_prog_on 1 a 1 a b"
    unfolding is_arith_prog_on_def arith_prog_def
    using * by auto
  ultimately show  "\<exists>j start step.
          j < k \<and> 0 < step \<and> is_arith_prog_on 1 start step a b \<and>
          arith_prog start step ` {..<1} \<subseteq> col -` {j} \<inter> {a..b}"
    using \<open>col a <k\<close> by blast
qed

text \<open>In the case $l=2$, Van der Waerden's Theorem holds as well. Here, any two distinct numbers
form an arithmetic progression of length $2$. Thus we only have to find two numbers with the same
colour.
Using the pigeonhole principle on $k+1$ values, we can find two integers with the same colour.\<close>
lemma vdw_2_right: "vdw k 2 (k+1)"
unfolding vdw_def
proof safe
  fix a b :: int and col :: "int \<Rightarrow> nat"
  assume *: "a + int (k + 1) \<le> b + 1" "col \<in> {a..b} \<rightarrow> {..<k}"

  have "col ` {a..b} \<subseteq> {..<k}" using *(2) by auto
  moreover have "k+1 \<le> card {a..b}" using *(1) by auto
  ultimately have "card (col ` {a..b}) < card {a..b}" using *
    by (metis card_lessThan card_mono finite_lessThan le_less_trans
        less_add_one not_le)
  then have "\<not> inj_on col {a..b}" using pigeonhole[of col "{a..b}"]
    by auto
  then obtain start start_step
    where pigeon: "col start = col start_step"
      "start < start_step"
      "start \<in> {a..b}"
      "start_step \<in> {a..b}"
    using inj_onI[of "{a..b}" col]
    by (metis not_less_iff_gr_or_eq)

  define step where "step = nat (start_step - start)"
  define j where "j = col start"

  have "j < k" unfolding j_def using *(2) pigeon(3) by auto
  moreover have "0 < step" unfolding step_def using pigeon(2) by auto
  moreover have "is_arith_prog_on 2 start step a b"
    unfolding is_arith_prog_on_def arith_prog_def step_def
    using pigeon by auto
  moreover {
  have "arith_prog start step i \<in> {start, start_step}" if "i<2" for i
    using that arith_prog_def step_def by (auto simp: less_2_cases_iff)
  also have "\<dots> \<subseteq> col -` {j} \<inter> {a..b}"
    using pigeon unfolding j_def by auto
  finally have "arith_prog start step ` {..<2} \<subseteq> col -` {j} \<inter> {a..b}"
    by auto
  }
  ultimately show "\<exists>j start step.
          j < k \<and>
          0 < step \<and>
          is_arith_prog_on 2 start step a b \<and>
          arith_prog start step ` {..<2} \<subseteq> col -` {j} \<inter> {a..b}" by blast
qed

text \<open>In order to prove Van der Waerden's Theorem, we first prove a slightly different lemma.
The statement goes as follows:\\
For a $k$-colouring $col$ on $[a..b]$ there exist
\begin{itemize}
\item  $start$: starting value of an arithmetic progression
\item  $steps$: step length of an arithmetic progression
\end{itemize}
such that \<open>f = multi_arith_prog m start step\<close> is a valid $m$-fold arithmetic progression of
length $l$ lying in $[a..b]$ such that for every $s<m$ have: if $c j < l$ for all $j\leq s$ then
$f(c_0, c_1, \dots, c_{m-1})$ and $f(0,\dots,0, c_{s+1},\dots, c_{m-1})$ have the same colour.

The property of the lemma uses the following variables:\\
\begin{tabular}{lcp{8cm}}
$k$:& \<open>nat\<close>& number of colours in segment colouring of $[a..b]$\\
$m$:& \<open>nat\<close>& dimension of $m$-fold arithmetic progression\\
$l$:& \<open>nat\<close>& $l+1$ is length of $m$-fold arithmetic progression\\
$n$:& \<open>nat\<close>& number fulfilling \<open>vdw_lemma\<close>\\
\end{tabular}
\<close>
definition vdw_lemma :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> bool" where
  "vdw_lemma k m l n \<longleftrightarrow>
     (\<forall>a b col. b + 1 \<ge> a + int n \<and> col \<in> {a..b} \<rightarrow> {..<k} \<longrightarrow>
       (\<exists>start steps. (\<forall>i<m. steps i > 0) \<and>
        is_multi_arith_prog_on (l+1) m start steps a b \<and> (
           let f = multi_arith_prog m start steps
           in  (\<forall>c \<in> {0..<m} \<rightarrow> {0..l}. \<forall>s<m. (\<forall> j \<le> s. c j < l) \<longrightarrow>
                  col (f c) = col (f (\<lambda>i. if i \<le> s then 0 else c i))))))"

text \<open>To better work with this property, we introduce an elimination rule for \<open>vdw_lemma\<close>.\<close>
lemma vdw_lemmaE:
  fixes a b :: int
  assumes "vdw_lemma k m l n"
    "b + 1 \<ge> a + int n" "col \<in> {a..b} \<rightarrow> {..<k}"
  obtains start steps where
    "\<And>i. i < m \<Longrightarrow> steps i > 0"
    "is_multi_arith_prog_on (l+1) m start steps a b"
    "let f = multi_arith_prog m start steps
     in  \<forall>c \<in> {0..<m} \<rightarrow> {0..l}. \<forall>s<m. (\<forall> j \<le> s. c j < l) \<longrightarrow>
            col (f c) = col (f (\<lambda>i. if i \<le> s then 0 else c i))"
  using assms that unfolding vdw_lemma_def by blast

text \<open>To simplify the following proof, we show the following formula.\<close>
lemma sum_mod_poly:
  assumes "(k::nat)>0"
  shows "(k - 1) * (\<Sum> n\<in>{..<q}. k^n) < k^q "
proof -
  have "int ((k - 1) * (\<Sum>n<q. k ^ n)) =
        (int k - 1) * (\<Sum>n<q. int k ^ n)"
    using assms by (simp add: of_nat_diff)
  also have "\<dots> = int k ^ q - 1"
    by (induction q) (auto simp: algebra_simps)
  also have "\<dots> < int (k ^ q)"
    by simp
  finally show ?thesis by linarith
qed

text \<open>The proof of Van der Waerden's Theorem now proceeds in three steps:\\
\begin{itemize}
\item Firstly, we show that the \<open>vdw\<close> property for all $k$ proves the \<open>vdw_lemma\<close> for fixed $l$ but
arbitrary $k$ and $m$. This is done by induction over $m$.
\item Secondly, we show that \<open>vdw_lemma\<close> implies the induction step of \<open>vdw\<close> using the pigeonhole
principle.
\item Lastly, we combine the previous steps in an induction over $l$ to show Van der Waerden's
Theorem in the general setting.
\end{itemize}\<close>

text \<open>Firstly, we need to show that \<open>vdw\<close> for arbitrary $k$ implies \<open>vdw_lemma\<close> for fixed $l$.
As mentioned earlier, we use induction over $m$.\<close>
lemma vdw_imp_vdw_lemma:
  fixes l
  assumes vdw_assms: "\<And>k'. k'>0 \<Longrightarrow> \<exists>n_k'. vdw k' l n_k'"
    and "l \<ge> 2"
    and "m > 0"
    and "k > 0"
  shows   "\<exists>N. vdw_lemma k m l N"
using \<open>m>0\<close> \<open>k>0\<close> proof (induction m rule: less_induct)
  case (less m)
  consider  "m=1" | "m>1" using less.prems by linarith
  then show ?case
  proof cases
    text \<open> Case $m=1$: Show \<open>vdw_lemma\<close> for arithmetic progression, Induction start. \<close>
    assume "m = 1"

    obtain n where vdw: "vdw k l n" using vdw_assms \<open>k>0\<close> by blast
    define N where "N = 2*n"
    have "l>0" and "l>1" using \<open>l\<ge>2\<close> by auto

    have "vdw_lemma k m l N"
      unfolding vdw_lemma_def
    proof (safe, goal_cases)
      case (1 a b col)
      text \<open> Divide $[a..b]$ in two intervals $I_1$, $I_2$ of same length and obtain arithmetic
        progression of length $l$ in $I_1$. \<close>
      have col_restr: "col \<in> {a..a + int n - 1} \<rightarrow> {..<k}"
        using 1 by (auto simp: N_def)
      then obtain j start step where prog:
        "j < k" "step > 0"
        "is_arith_prog_on l start step a (a + int n -1)"
        "arith_prog start step ` {..<l} \<subseteq>
          col -` {j} \<inter> {a..a + int n - 1}"
        using vdw 1 unfolding N_def by (elim vdwE)(auto simp:is_arith_prog_on_def)
      have range_prog_lessThan_l:
        "arith_prog start step i \<in> {a..a + int n -1}" if "i < l" for i
        using that prog by auto

      have "{a..a + int n-1}\<subseteq>{a..b}" using N_def "1"(1) by auto
      then have "a + 2* int n - 1 \<le> b" using 1(1) unfolding N_def
        by auto

      text \<open> Show that \<open>arith_prog start step\<close> is an arithmetic progression of length $l+1$
         in $[a..b]$. \<close>
      have prog_in_ivl: "arith_prog start step i \<in> {a..b}"
        if "i \<le> l" for i
      proof (cases "i=l")
        case False
        have "i<l" using that False by auto
        then show ?thesis
          using range_prog_lessThan_l \<open>{a..a + int n-1}\<subseteq>{a..b}\<close> by force
      next
        case True
        text \<open> Show $\<open>step\<close>\leq |I_1|$ then have \<open>arith_prog start step (l+1)\<in>[a..b]\<close> as
           \<open>arith_prog start step (l+1) = arith_prog start step l + step\<close> \<close>
        have "start \<in> {a..a + int n -1}"
          using range_prog_lessThan_l[of 0]
          unfolding arith_prog_def by (simp add: \<open>0 < l\<close>)
        moreover have "start + int step \<in> {a..a + int n -1}"
          using range_prog_lessThan_l[of 1]
          unfolding arith_prog_def by (metis \<open>1 < l\<close> mult.left_neutral)
        ultimately have "step \<le> n" by auto
        have "arith_prog start step (l-1) \<in> {a..a + int n -1}"
          using range_prog_lessThan_l[of "l-1"] unfolding arith_prog_def
          using \<open>0 < l\<close> diff_less less_numeral_extra(1) by blast
        moreover have "arith_prog start step l =
                        arith_prog start step (l-1) + int step"
          unfolding arith_prog_def using \<open>0 < l\<close> mult_eq_if by force
        ultimately have "arith_prog start step l \<in> {a..b}"
          using \<open>step\<le>n\<close> N_def \<open>a + 2* int n -1 \<le> b\<close> by auto
        then show ?thesis using range_prog_lessThan_l using True
          by force
      qed

      have col_prog_eq: "col (arith_prog start step k) = j"
        if "k < l" for k
        using prog that by blast

      define steps :: "nat \<Rightarrow> nat" where steps_def: "steps = (\<lambda>i. step)"
      define f where "f = multi_arith_prog 1 start steps"

      have rel_prop_1:
        "col (f c) = col (f (\<lambda>i. if i < s then 0 else c i))"
        if "c \<in> {0..<1} \<rightarrow> {0..l}" "s<1" "\<forall>j\<le>s. c j < l" for c s
        using that by auto

      have arith_prog_on:
        "is_multi_arith_prog_on (l+1) m start steps a b"
        using prog(3) unfolding is_arith_prog_on_def is_multi_arith_prog_on_def
        using \<open>m=1\<close> arith_prog_to_multi steps_def prog_in_ivl by auto

      show ?case
        by (rule exI[of _ start], rule exI[of _ steps])
           (use rel_prop_1 \<open>step > 0\<close> \<open>m = 1\<close> arith_prog_on col_prog_eq
             multi_to_arith_prog in \<open>auto simp: f_def Let_def steps_def\<close>)
    qed
    then show ?case ..

  next
    text \<open> Case $m>1$: Show \<open>vdw_lemma\<close> for $m$-fold arithmetic progression,
          Induction step $(m-1) \longrightarrow m$. \<close>
    assume "m>1"

    obtain q where vdw_lemma_IH:"vdw_lemma k (m-1) l q"
      using \<open>1 < m\<close> less by force
    have "k^q>0" using \<open>k>0\<close> by auto
    obtain n_kq where vdw: "vdw (k^q) l n_kq"
      using vdw_assms \<open>k^q>0\<close> by blast
    define N where "N = q + 2 * n_kq"

    text \<open>Idea: $[a..b] = I_1 \cup I_2$ where $|I_1| = 2*n_{k,q}$ and $|I_2| = q$.
                Divide $I_1$ into blocks of length $q$ and define a new colouring on the set of
                $q$-blocks where the colour of the block is the $k$-basis representation where
                the $i$-th digit corresponds to the colour of the $i$-th element in the block.
                Get an arithmetic progression of $q$-blocks of length $l+1$ in $I_1$, such that
                the first $l$ $q$-blocks have the same colour.
                The step of the block-arithmetic progression is going to be the additional
                step in the induction over $m$. \<close>

    have "vdw_lemma k m l N"
      unfolding vdw_lemma_def
    proof (safe, goal_cases)
      case (1 a b col)
      have "n_kq>0" using vdw_imp_pos vdw \<open>l\<ge>2\<close> by auto
      then have "N>0" by (simp add:N_def)
      then have "a\<le>b" using 1 by auto
      then have "k>0" using 1 by (intro Nat.gr0I) force
      have "l>0" and "l>1" using \<open>l\<ge>2\<close> by auto
      interpret digits k by (simp add: \<open>0 < k\<close> digits_def)
      define col1 where "col1 = (\<lambda> x. from_digits q (\<lambda>y. col (x + y)))"
      have range_col1: "col1\<in>{a..a + int n_kq - 1} \<rightarrow> {..<k^q}"
      unfolding Pi_def
      proof safe
        fix x assume "x\<in>{a..a + int n_kq - 1}"
        then have col_xn:"col (x + int n)\<in>{..<k}" if "n<q" for n :: nat
          using that 1 PiE N_def by auto
        have col_xn_upper_bound:"col (x + int n) \<le> k - 1"
          if "n<q" for n ::nat
          using that col_xn[of n] \<open>k>0\<close> by (auto)
        have "(\<Sum>n<q. col (x + int n) * k ^ n)\<le>
               (\<Sum>n<q. (k-1) *  k ^ n)"
          using col_xn_upper_bound by (intro sum_mono mult_right_mono)
            auto
        also have "\<dots> = (k-1) * (\<Sum>n<q. k ^ n)"
          by (rule sum_distrib_left[symmetric])
        also have "\<dots> < k^q" using sum_mod_poly \<open>k>0\<close> by auto
        finally show "col1 x <k^q" unfolding col1_def from_digits_altdef
          by auto
      qed

      obtain j start step where prog:
        "j < k^q" "step > 0"
        "is_arith_prog_on l start step a (a + int n_kq - 1)"
        "arith_prog start step ` {..<l} \<subseteq>
          col1 -` {j} \<inter> {a..a + int n_kq -1}"
        using vdw range_col1 by (elim vdwE) (auto simp: \<open>k>0\<close>)

      have range_prog_lessThan_l:
        "arith_prog start step i \<in> {a..a + int n_kq -1}"
        if "i < l" for i
        using that prog by auto

      have prog_in_ivl:
        "arith_prog start step i \<in> {a..a + 2 * int n_kq -1}"
        if "i \<le> l" for i
      proof (cases "i=l")
        case False
        then have "i<l" using that by auto
        then show ?thesis using prog by auto
      next
        case True
        have "start \<in> {a..a + int n_kq -1}"
          using range_prog_lessThan_l[of 0] unfolding arith_prog_def
          by (simp add: \<open>0 < l\<close>)
        moreover have "start + step \<in> {a..a + int n_kq -1}"
          using range_prog_lessThan_l[of 1] unfolding arith_prog_def
          by (metis \<open>1 < l\<close> mult.left_neutral)
        ultimately have "step \<le> n_kq" by auto
        have "arith_prog start step (l-1) \<in> {a..a + int n_kq -1}"
          using range_prog_lessThan_l[of "l-1"] unfolding arith_prog_def
          using \<open>0 < l\<close> diff_less less_numeral_extra(1) by blast
        moreover have "arith_prog start step l =
            arith_prog start step (l-1) + step"
          unfolding arith_prog_def using \<open>0 < l\<close> mult_eq_if by force
        ultimately have "arith_prog start step l \<in>
            {a..a + 2 * int n_kq - 1}"
          using \<open>step\<le>n_kq\<close> by auto
        then show ?thesis using range_prog_lessThan_l using True
          by force
      qed

      have col_prog_eq: "col1 (arith_prog start step k) = j"
        if "k < l" for k
        using prog that by blast

      have digit_col1:"digit (col1 x) y = col (x+int y)"
        if "x\<in>{a..<a + 2*int n_kq}" "y\<in>{..<q}"
        for x::int and y::nat unfolding col1_def using that
      proof -
        have "\<And>j'. j'<q \<Longrightarrow> x+j'\<in>{a..b}"
          using "1"(1) N_def that(1) by force
        then have "\<And>j'. j'<q \<Longrightarrow> (\<lambda>y. col (x+int y)) j' < k"
          using 1 that by auto
        then show "digit (from_digits q (\<lambda>xa. col (x + int xa))) y =
                    col (x + int y)"
          using digit_from_digits that 1 by auto
      qed

      text \<open> Impact on the colour when taking the block-step. \<close>
      have one_step_more:
        "col (arith_prog start' step i) = digit j (nat (start'-start))"
        if "start'\<in>{start..<start+q}" "i\<in>{..<l}" for start' i
      proof -
        have "start \<le> start'" using that by simp
        have shift_arith_prog:
          "arith_prog start step i + (start' - start) =
            arith_prog start' step i"
          unfolding arith_prog_def by simp
        define diff where "diff = nat (start'-start)"
        have "diff \<in>{..<q}" using that unfolding diff_def by auto
        have "col (arith_prog start step i + int diff) = digit j diff"
        proof -
          have "col1 (arith_prog start step i) = j"
            using col1_def prog that by blast
          moreover have " arith_prog start step i\<in>{a..a + 2 * int n_kq-1}"
            using prog(4) that by auto
          ultimately show ?thesis
            using digit_col1[where x = "arith_prog start step i"
                and y = "diff"]
              prog 1 \<open>diff \<in>{..<q}\<close> by auto
        qed
        then show ?thesis unfolding diff_def 1
          by (auto simp: \<open>start\<le>start'\<close> shift_arith_prog)
      qed

      have one_step_more': "col (arith_prog start' step i) =
        col (arith_prog start' step 0)"
        if "start'\<in>{start..<start+q}" "i\<in>{..<l}" for start' i
        using that one_step_more[of start' 0]
          one_step_more[of start' i] by auto

      have start_q: "start + int q \<le> start + int q - 1 + 1" by linarith
      have "{start..start + int q-1} \<subseteq> {a..b}"
        using prog N_def 1(1) by (force simp: arith_prog_def is_arith_prog_on_def)
      then have col': "col \<in> {start..start + int q-1} \<rightarrow> {..<k}"
        using 1 prog(4) by auto

      text \<open> Obtain an $(m-1)$-fold arithmetic progression in the starting $q$-bolck of the
             block arithmetic progression. \<close>
      obtain start_m steps_m where
        step_m_pos: "\<And>i. i < m - 1 \<Longrightarrow> 0 < steps_m i" and
        is_multi_arith_prog: "is_multi_arith_prog_on (l+1) (m - 1)
          start_m steps_m start (start + int q - 1)" and
        g_aux: "let g = multi_arith_prog (m - 1) start_m steps_m
          in  \<forall>c\<in>{0..<m - 1} \<rightarrow> {0..l}. \<forall>s<m - 1. (\<forall>j\<le>s. c j < l) \<longrightarrow>
          col (g c) = col (g (\<lambda>i. if i \<le> s then 0 else c i))"
        by (rule vdw_lemmaE[OF vdw_lemma_IH start_q col']) blast

      define g where "g = multi_arith_prog (m-1) start_m steps_m"
      have g: "col (g c) = col (g (\<lambda>i. if i \<le> s then 0 else c i))"
        if "c \<in> {0..<(m-1)} \<rightarrow> {0..l}" "s < m - 1" "\<forall>j \<le> s. c j < l"
        for c s using g_aux that unfolding g_def Let_def by blast

      have range_g: "g c \<in> {start..start + int q - 1}"
        if "c \<in> {0..<m - 1} \<rightarrow> {0..<(l+1)}" for c
        using is_multi_arith_prog_onD[OF is_multi_arith_prog that]
        by (auto simp: g_def)

      text \<open>Obtain an $m$-fold arithmetic progression by adding the block-step.\<close>
      define steps :: "nat \<Rightarrow> nat" where steps_def:
        "steps = (\<lambda>i.  (if i=0 then step else steps_m (i-1)))"
      define f where "f = multi_arith_prog m start_m steps"
      have f_step_g: "f c = int (c 0*step) + g (c \<circ> Suc)" for c
      proof -
        have "f c = start_m + int (\<Sum>i<Suc (m-1). c i * steps i)"
          using f_def unfolding multi_arith_prog_def
          using less.prems by auto
        also have "\<dots> = start_m + int (c 0 * steps 0) +
                       int (\<Sum>i<m-1. c (Suc i) * steps (Suc i))"
          using sum.lessThan_Suc_shift[where n = "m-1"] by auto
        also have "\<dots> = start_m + int (c 0 * step) +
                       int (\<Sum>i<m-1. c (Suc i) * steps_m i)"
          using steps_def by (auto split:if_splits)
        finally show ?thesis unfolding multi_arith_prog_def g_def
          by simp
      qed

      text \<open> Show that this $m$-fold arithmetic progression fulfills all needed properties. \<close>
      have steps_gr_0: "\<forall>i<m. 0 < steps i"
        unfolding steps_def using step_m_pos prog by auto

      have is_multi_on_f:
        "is_multi_arith_prog_on (l+1) m start_m steps a b"
      proof -
        have "a \<le> start_m" using is_multi_arith_prog
          unfolding is_multi_arith_prog_on_def
          using is_arith_prog_on_def prog(3) by force
        moreover {
          have "f (\<lambda>_. l) = arith_prog (g ((\<lambda>_. l) \<circ> Suc)) step l"
            using f_step_g unfolding arith_prog_def by auto
          also have "g ((\<lambda>_. l) \<circ> Suc) \<le> start + q"
            using range_g[of "(\<lambda>_. l) \<circ> Suc"] by auto
          then have "arith_prog (g ((\<lambda>_. l) \<circ> Suc)) step l \<le>
            arith_prog start step l + q"
            unfolding arith_prog_def by auto
          also have "\<dots>\<le> b" using prog_in_ivl[of l]
            using is_multi_arith_prog unfolding is_multi_arith_prog_on_def
            using "1"(1) N_def by auto
          finally have "f (\<lambda>_. l) \<le> b" by auto
         }
         ultimately show ?thesis
           unfolding is_multi_arith_prog_on_def f_def by auto
      qed

      text \<open> Show the relational property for all $s$. \<close>
      have rel_prop_1:
        "col (f c) = col (f (\<lambda>i. if i \<le> s then 0 else c i))"
        if "c \<in> {0..<m} \<rightarrow> {0..l}" "s<m" "\<forall>j\<le>s. c j < l" for c s
      proof (cases "s = 0")
        case True
        have "c 0 < l" using that(3) True by auto
        have range_c_Suc: "c \<circ> Suc \<in> {0..<m-1} \<rightarrow> {0..l}"
          using that(1) by auto
        have "f c = arith_prog (g (c \<circ> Suc)) step (c 0)"
          using f_step_g unfolding arith_prog_def by auto
        then have "col (f c) = col (arith_prog (g (c \<circ> Suc)) step 0)"
          using one_step_more'[of "g (c \<circ> Suc)" "c 0"] \<open>c 0 < l\<close>
            range_g[of "c \<circ> Suc"] range_c_Suc
            atLeastLessThanSuc_atLeastAtMost by auto
        also {
          have "(\<Sum>x<m - 1. int (c (Suc x)) * int (steps_m x)) =
                   (\<Sum>x=1..<m. int(c x) * int (steps x))"
            by(rule sum.reindex_bij_witness[of _ "(\<lambda>x. x-1)" "Suc"])
              (auto simp: steps_def split:if_splits)
          also have "\<dots> = (\<Sum>x<m. int (if x = 0 then 0 else c x) *
            int (steps x))"
            by (rule sum.mono_neutral_cong_left) auto
          finally have "arith_prog (g (c \<circ> Suc)) step 0 =
            f (\<lambda>i. if i \<le> s then 0 else c i)"
            unfolding f_def g_def multi_arith_prog_def arith_prog_def
            using True by auto
      }
        finally show ?thesis by auto
      next
        case False
        hence s_greater_0: "s > 0" by auto
        have range_c_Suc: "c \<circ> Suc \<in> {0..<m-1} \<rightarrow> {0..l}"
          using that(1) by auto
        have "c 0 < l" using \<open>s>0\<close> that by auto
        have g_IH:
          "col (g c') = col (g (\<lambda>i. if i \<le> s' then 0 else c' i))"
          if "c' \<in> {0..<m-1} \<rightarrow> {0..l}" "s'<m-1" "\<forall>j\<le>s'. c' j < l"
          for c' s'
          using g_aux that unfolding multi_arith_prog_def g_def
          by (auto simp: Let_def)
        have g_shift_IH: "col (g (c \<circ> Suc)) =
          col (g ((\<lambda>i. if i\<in>{1..t} then 0 else c i) \<circ> Suc))"
          if "c \<in> {1..<m} \<rightarrow> {0..l}" "t\<in>{1..<m}" "\<forall>j\<in>{1..t}. c j < l"
          for c t
        proof -
          have "(\<lambda>i. (if i \<le> t - 1 then 0 else (c \<circ> Suc) i)) =
                (\<lambda>i. (if i \<in> {1..t} then 0 else c i)) \<circ> Suc"
            using that by (auto split: if_splits simp:fun_eq_iff)
          then have right:
            "g (\<lambda>i. if i \<le> (t-1) then 0 else (c \<circ> Suc) i) =
             g ((\<lambda>i. if i\<in>{1..t} then 0 else c i) \<circ> Suc)" by auto
          have "(c \<circ> Suc)\<in> {0..<m-1} \<rightarrow> {0..l}" using that(1) by auto
          moreover have "t-1<m-1" using that(2) by auto
          moreover have"\<forall>j\<le>t-1. (c \<circ> Suc) j < l" using that by auto
          ultimately have "col (g (c \<circ> Suc)) =
            col (g (\<lambda>i. (if i \<le> t-1 then 0 else (c \<circ> Suc) i)))"
            using g_IH[of "(c \<circ> Suc)" "t-1"] by auto
          with right show ?thesis by auto
        qed

        have "col (f c) = col (int (c 0 * step) + g (c \<circ> Suc))"
          using f_step_g by simp
        also have "int (c 0 * step) + g (c \<circ> Suc) =
          arith_prog (g (c \<circ> Suc)) step (c 0)"
          by (simp add: arith_prog_def)
        also have "col \<dots> = col (arith_prog (g (c \<circ> Suc)) step 0)"
          using one_step_more'[of "g (c \<circ> Suc)" "c 0"] \<open>c 0 < l\<close>
            range_g[of "c \<circ> Suc"] range_c_Suc
            atLeastLessThanSuc_atLeastAtMost by auto
        also have "\<dots> = col (g (c \<circ> Suc))"
          unfolding arith_prog_def by auto
        also have "\<dots> = col (g ((\<lambda>i. if  i\<in>{1..s} then 0 else c i) \<circ>
          Suc))" using g_shift_IH[of "c" s] \<open>s>0\<close> that by force
        also have "\<dots> = col ((\<lambda>c. int (c 0 * step) +
          g (c \<circ> Suc))(\<lambda>i. if i\<le>s then 0 else c i))"
          by (auto simp: g_def multi_arith_prog_def)
        also have "\<dots> = col (f (\<lambda>i. if i \<le> s then 0 else c i))"
          unfolding f_step_g by auto
        finally show ?thesis by simp
      qed

      show ?case
        by (rule exI[of _ start_m], rule exI[of _ steps])
           (use steps_gr_0 is_multi_on_f rel_prop_1 in
             \<open>auto simp: f_def Let_def steps_def\<close>)
    qed
    then show ?case ..
  qed
qed

text \<open> Secondly, we show that \<open>vdw_lemma\<close> implies the induction step of Van der Waerden's Theorem
using the pigeonhole principle. \<close>
lemma vdw_lemma_imp_vdw:
  assumes "vdw_lemma k k l N"
  shows   "vdw k (Suc l) N"
unfolding vdw_def proof (safe, goal_cases)
text \<open>Idea: Proof uses pigeonhole principle to guarantee the existence of an arithmetic
            progression of length $l+1$ with the same colour. \<close>
  case (1 a b col)
  obtain start steps where prog:
    "\<And>i. i < k \<Longrightarrow> steps i > 0"
    "is_multi_arith_prog_on (l+1) k start steps a b"
    "let f = multi_arith_prog k start steps
     in  \<forall>c \<in> {0..<k} \<rightarrow> {0..l}. \<forall>s<k. (\<forall> j \<le> s. c j < l) \<longrightarrow>
            col (f c) = col (f (\<lambda>i. if i \<le> s then 0 else c i))"
    using assms 1
    by (elim vdw_lemmaE[where a=a and b=b and col=col and m=k
          and k=k and l=l and n=N]) auto

  text \<open> Obtain a $k$-fold arithmetic progression $f$ of length $l$ from assumptions. \<close>
  define f where "f = multi_arith_prog k start steps"
  have rel_propE: "col (f c) = col (f (\<lambda>i. if i \<le> s then 0 else c i))"
    if "c \<in> {0..<k} \<rightarrow> {0..l}" "s<k" "\<forall> j \<le> s. c j < l"
    for c s
    using prog(3) that unfolding f_def Let_def by auto

  text \<open>There are $k+1$ values $a_r = f(0,\dots,0,l,\dots,l)$ with $0\leq r\leq k$ zeros.\<close>
  define a_r where "a_r = (\<lambda>r. f (\<lambda>i. (if i<r then 0 else l)))"
  have range_col_a_r: "col (a_r x) < k" if "x < k+1" for x
  proof -
    have "a_r x \<in> {a..b}" unfolding a_r_def f_def
      by (intro is_multi_arith_prog_onD[OF prog(2)]) auto
    thus ?thesis using 1 by blast
  qed
  then have "(col \<circ> a_r) ` {..<k + 1} \<subseteq> {..<k}" using 1(2) by auto
  then have "card ((col \<circ> a_r) ` {..<k + 1}) \<le> card {..<k}"
    by (intro card_mono) auto
  then have "\<not> inj_on (col \<circ> a_r) {..<k+1}"
    using pigeonhole[of "col \<circ> a_r" "{..<k+1}"] by auto
  text \<open>Using the pigeonhole principle get $r_1$ and $r_2$ where $a_{r_1}$ and $a_{r_2}$ have the
    same colour.\<close>
  then obtain r1 r2 where pigeon_cols:
      "r1\<in>{..<k+1}"
      "r2\<in>{..<k+1}"
      "r1 < r2"
      "(col \<circ> a_r) r1 = (col \<circ> a_r) r2"
    by (metis (mono_tags, lifting) linear linorder_inj_onI)
  text \<open> Show that the following function $h$ is an arithmetic progression which fulfills all
         properties for Van der Waerden's Theorem. \<close>
  define h where
    "h = (\<lambda>x. f (\<lambda>i. (if i<r1 then 0 else (if i<r2 then x else l))))"
  have "h 0 = a_r r2" unfolding h_def a_r_def using \<open>r1<r2\<close>
    by (intro arg_cong[where f = f]) auto
  moreover have "h l = a_r r1"  unfolding h_def a_r_def using \<open>r1<r2\<close>
    by (metis le_eq_less_or_eq less_le_trans)
  ultimately have "col (h 0) = col (h l)" using pigeon_cols(4) by auto
  have h_col: "col (h 0) = col (h i)" if "i\<in>{..<l+1}" for i
  proof (cases "i=l")
    case True
    then show ?thesis using \<open>col (h 0) = col (h l)\<close> by auto
  next
    case False
    then have "i<l" using that by auto
    let ?c = "(\<lambda>idx. if idx < r1 then 0 else if idx < r2 then i else l)"
    have "?c\<in>{0..<k} \<rightarrow> {0..l}"
      using that by auto
    moreover have "(\<forall>j\<le>r2-1. ?c j < l)"
      using \<open>i<l\<close> pigeon_cols(3) by force
    ultimately have "col (f ?c) =
      col (f (\<lambda>i. if i \<le> r2-1 then 0 else ?c i))"
      using rel_propE[of ?c "r2-1"] pigeon_cols by simp
    then show ?thesis unfolding h_def f_def
      by (smt (z3) Nat.lessE One_nat_def add_diff_cancel_left'
          le_less less_Suc_eq_le multi_arith_prog_mono plus_1_eq_Suc)
  qed

  define h_start where "h_start = start + l*(\<Sum>i\<in>{r2..<k}. steps i)"
  define h_step where "h_step = (\<Sum>i\<in>{r1..<r2}. steps i)"
  have h_arith_prog: "h = arith_prog h_start h_step"
  proof -
    have "(\<Sum>x<k. int (if x < r1 then 0 else if x < r2 then y else l)
        * int (steps x)) =
      int l * (\<Sum>x = r2..<k. int (steps x)) +
        int y * (\<Sum>x = r1..<r2. int (steps x))"
      for y
    proof (cases "r2 = k")
      case True
      then have "r1<k" using pigeon_cols by auto
      with True have
        "(\<Sum>x<k. int (if x < r1 then 0 else if x < r2 then y else l)
           * int (steps x)) =
         (\<Sum>x<k. int (if x < r1 then 0 else y) * int (steps x))"
        by (intro sum.cong) auto
      also have "\<dots> = (\<Sum>x<r1. int (if x < r1 then 0 else y) *
          int (steps x)) + (\<Sum>x=r1..<k. int (if x < r1 then 0 else y)
          * int (steps x))"
        using split_sum_mid_less[of r1 k
            "(\<lambda>x. int (if x < r1 then 0 else y) * int (steps x))"]
            \<open>r1<k\<close> by auto
      also have "\<dots> = (\<Sum>x=r1..<k. int y * int (steps x))" by auto
      also have "\<dots> = int y * (\<Sum>x=r1..<k. int (steps x))"
        by (auto simp: sum_distrib_left[of "int y"])
      finally show ?thesis using True by auto
    next
      case False
      then have "r2<k" using pigeon_cols by auto
      define aux_left where "aux_left =
        (\<lambda>x. int (if x < r1 then 0 else if x < r2 then y else l)
          * int (steps x))"
      have "(\<Sum>x<k. aux_left x) = (\<Sum>x=r1..<k. aux_left x)"
        by (intro sum.mono_neutral_right) (auto simp: aux_left_def)
      also have "{r1..<k} = {r1..<r2} \<union> {r2..<k}"
        using \<open>r1 < r2\<close> \<open>r2 < k\<close> by auto
      also have "(\<Sum>x\<in>\<dots>. aux_left x) = (\<Sum>x=r1..<r2. aux_left x) +
        (\<Sum>x=r2..<k. aux_left x)"
        by (intro sum.union_disjoint) auto
      also have "(\<Sum>x=r1..<r2. aux_left x) =
        (\<Sum>x=r1..<r2. int y * int (steps x))"
        by (intro sum.cong) (auto simp: aux_left_def)
      also have "(\<Sum>x=r2..<k. aux_left x) =
        (\<Sum>x=r2..<k. int l * int (steps x))"
        using \<open>r1 < r2\<close> by (intro sum.cong) (auto simp: aux_left_def)
      finally show ?thesis
        by (simp add: aux_left_def sum_distrib_left)
    qed
    then show ?thesis
      unfolding arith_prog_def h_start_def h_step_def h_def f_def
        multi_arith_prog_def by (auto split:if_splits)
  qed

  define j where "j = col (h 0)"
  have case_j: "j<k" using 1 range_col_a_r \<open>col (h 0) = col (h l)\<close>
      \<open>h l = a_r r1\<close> j_def pigeon_cols(1) by auto
  have case_step: "h_step > 0" unfolding h_step_def
    using pigeon_cols by (intro sum_pos prog(1)) auto

  have range_h: "h i \<in> {a..b}" if "i < l + 1" for i
    unfolding h_def f_def by (rule is_multi_arith_prog_onD[OF prog(2)])
      (use that in auto)

  have case_on: "is_arith_prog_on (l+1) h_start h_step a b"
    unfolding is_arith_prog_on_def h_arith_prog
    using range_h[of 0] range_h[of l]
    by (auto simp: Max_ge[of "{a..b}"] Min_le[of "{a..b}"]
        h_arith_prog arith_prog_def)

  have case_col: "h ` {..<Suc l} \<subseteq> col -` {j} \<inter> {a..b}"
    using h_col range_h unfolding j_def by auto

  show ?case using case_j case_step case_on case_col
    by (auto simp: h_arith_prog)
qed

text \<open> Lastly, we assemble all lemmas to finally prove Van der Waerden's Theorem by induction on
$l$. The cases $l=1$ and the induction start $l=2$ are treated separately and have been shown
earlier.\<close>
theorem van_der_Waerden: assumes "l>0" "k>0" shows "\<exists>n. vdw k l n"
using assms proof (induction l arbitrary: k rule: less_induct)
  case (less l)
  consider  "l=1" | "l=2" | "l>2" using less.prems by linarith
  then show ?case
  proof (cases)
    assume "l=1"
    then show ?thesis using vdw_1_right by auto
  next
    assume "l=2"
    then show ?thesis using vdw_2_right by auto
  next
    assume "l > 2"
    then have "2\<le>l-1" by auto
    from less.IH[of "l-1"] \<open>l>2\<close>
    have "\<And>k'. k'>0 \<Longrightarrow> \<exists>n. vdw k' (l-1) n" by auto
    with vdw_imp_vdw_lemma[of "l-1" k k] \<open>l-1\<ge>2\<close> \<open>k>0\<close>
      obtain N where "vdw_lemma k k (l-1) N" by auto
    then have "vdw k l N" using vdw_lemma_imp_vdw[of k "l-1" N]
      by (simp add: less.prems(1))
    then show ?thesis by auto
  qed
qed

end


(*
Authors:
  Anthony Bordg, University of Cambridge, apdb3@cam.ac.uk
  Hanna Lachnitt, TU Wien, lachnitt@student.tuwien.ac.at
*)

theory Binary_Nat
imports
  HOL.Nat
  HOL.List
  Basics
begin

primrec bin_rep_aux:: "nat \<Rightarrow> nat \<Rightarrow> nat list" where
  "bin_rep_aux 0 m = [m]"
| "bin_rep_aux (Suc n) m = m div 2^n # bin_rep_aux n (m mod 2^n)"

lemma length_of_bin_rep_aux:
  fixes n m:: nat
  assumes "m < 2^n"
  shows "length (bin_rep_aux n m) = n+1"
  using assms
proof(induction n arbitrary: m)
  case 0
  then show "length (bin_rep_aux 0 m) = 0 + 1" by simp
next
  case (Suc n)
  assume a0:"\<And>m. m < 2^n \<Longrightarrow> length (bin_rep_aux n m) = n + 1" and "m < 2^(Suc n)"
  then show "length (bin_rep_aux (Suc n) m) = Suc n + 1"
    using a0 by simp
qed

lemma bin_rep_aux_neq_nil:
  fixes n m:: nat
  shows "bin_rep_aux n m \<noteq> []"
  using bin_rep_aux.simps by (metis list.distinct(1) old.nat.exhaust)

lemma last_of_bin_rep_aux:
  fixes n m:: nat
  assumes "m < 2^n" and "m \<ge> 0"
  shows "last (bin_rep_aux n m) = 0"
  using assms
proof(induction n arbitrary: m)
  case 0
  assume "m < 2^0" and "m \<ge> 0"
  then show "last (bin_rep_aux 0 m) = 0" by simp
next
  case (Suc n)
  assume a0:"\<And>m. m < 2^n \<Longrightarrow> m \<ge> 0 \<Longrightarrow> last (bin_rep_aux n m) = 0" and "m < 2^(Suc n)"
and "m \<ge> 0"
  then show "last (bin_rep_aux (Suc n) m) = 0"
    using bin_rep_aux_neq_nil by simp
qed

lemma mod_mod_power_cancel:
  fixes m n p:: nat
  assumes "m \<le> n"
  shows "p mod 2^n mod 2^m = p mod 2^m"
  using assms by (simp add: dvd_power_le mod_mod_cancel)

lemma bin_rep_aux_index:
  fixes n m i:: nat
  assumes "n \<ge> 1" and "m < 2^n" and "m \<ge> 0" and "i \<le> n"
  shows "bin_rep_aux n m ! i = (m mod 2^(n-i)) div 2^(n-1-i)"
  using assms
proof(induction n arbitrary: m i rule: nat_induct_at_least)
  case base
  assume "m < 2^1" and "i \<le> 1"
  then show "bin_rep_aux 1 m ! i = m mod 2^(1-i) div 2^(1-1-i)"
    using bin_rep_aux.simps
    by (metis One_nat_def base.prems(2) diff_is_0_eq' diff_zero div_by_1 le_Suc_eq le_numeral_extra(3)
nth_Cons' power_0 unique_euclidean_semiring_numeral_class.mod_less)
next
  case (Suc n)
  assume a0:"\<And>m i. m < 2^n \<Longrightarrow> m \<ge> 0 \<Longrightarrow> i \<le> n \<Longrightarrow> bin_rep_aux n m ! i = m mod 2 ^ (n-i) div 2^(n-1-i)"
and a1:"m < 2^(Suc n)" and a2:"i \<le> Suc n" and a3:"m \<ge> 0"
  then show "bin_rep_aux (Suc n) m ! i = m mod 2^(Suc n - i) div 2^(Suc n - 1 - i)"
  proof-
    have "bin_rep_aux (Suc n) m = m div 2^n # bin_rep_aux n (m mod 2^n)" by simp
    then have f0:"bin_rep_aux (Suc n) m ! i = (m div 2^n # bin_rep_aux n (m mod 2^n)) ! i" by simp
    then have "bin_rep_aux (Suc n) m ! i = m div 2^n" if "i = 0" using that by simp
    then have f1:"bin_rep_aux (Suc n) m ! i = m mod 2^(Suc n - i) div 2^(Suc n - 1 - i)" if "i = 0"
    proof-
      have "m mod 2^(Suc n - i) = m"
        using that a1 by (simp add: Suc.prems(2))
      then have "m mod 2^(Suc n - i) div 2^(Suc n - 1 - i) = m div 2^n"
        using that by simp
      thus ?thesis by (simp add: that)
    qed
    then have "bin_rep_aux (Suc n) m ! i = bin_rep_aux n (m mod 2^n) ! (i-1)" if "i \<ge> 1"
      using that f0 by simp
    then have f2:"bin_rep_aux (Suc n) m ! i = ((m mod 2^n) mod 2^(n - (i - 1))) div 2^(n - 1 - (i - 1))" if "i \<ge> 1"
      using that a0 a1 a2 a3 Suc.prems(2) by simp
    then have f3:"bin_rep_aux (Suc n) m ! i = ((m mod 2^n) mod 2^(Suc n - i)) div 2^(Suc n - 1 - i)" if "i \<ge> 1"
      using that by simp
    then have "bin_rep_aux (Suc n) m ! i = m mod 2^(Suc n - i) div 2^(Suc n - 1 - i)" if "i \<ge> 1"
    proof-
      have "Suc n - i \<le> n" using that by simp
      then have "m mod 2^n mod 2^(Suc n - i) = m mod 2^(Suc n - i)"
        using mod_mod_power_cancel[of "Suc n - i" "n" "m"] by simp
      thus ?thesis
        using that f3 by simp
    qed
    thus ?thesis using f1 f2
      using linorder_not_less by blast
  qed
qed

lemma bin_rep_aux_coeff:
  fixes n m i:: nat
  assumes "m < 2^n" and "i \<le> n" and "m \<ge> 0"
  shows "bin_rep_aux n m ! i = 0 \<or> bin_rep_aux n m ! i = 1"
  using assms
proof(induction n arbitrary: m i)
  case 0
  assume "m < 2^0" and "i \<le> 0" and "m \<ge> 0"
  then show "bin_rep_aux 0 m ! i = 0 \<or> bin_rep_aux 0 m ! i = 1" by simp
next
  case (Suc n)
  assume a0:"\<And>m i. m < 2 ^ n \<Longrightarrow> i \<le> n \<Longrightarrow> m \<ge> 0 \<Longrightarrow> bin_rep_aux n m ! i = 0 \<or> bin_rep_aux n m ! i = 1"
and a1:"m < 2^Suc n" and a2:"i \<le> Suc n" and a3:"m \<ge> 0"
  then show "bin_rep_aux (Suc n) m ! i = 0 \<or> bin_rep_aux (Suc n) m ! i = 1"
  proof-
    have "bin_rep_aux (Suc n) m ! i = (m div 2^n # bin_rep_aux n (m mod 2^n)) ! i" by simp
    moreover have "\<dots> = bin_rep_aux n (m mod 2^n) ! (i - 1)" if "i \<ge> 1"
      using that by simp
    moreover have "m mod 2^n < 2^n" by simp
    ultimately have "bin_rep_aux (Suc n) m ! i = 0 \<or> bin_rep_aux (Suc n) m ! i = 1" if "i\<ge>1"
      using that a0[of "m mod 2^n" "i-1"] a2 by simp
    moreover have "m div 2^n = 0 \<or> m div 2^n = 1"
      using a1 a3 less_mult_imp_div_less by(simp add: less_2_cases)
    ultimately show ?thesis by (simp add: nth_Cons')
  qed
qed

definition bin_rep:: "nat \<Rightarrow> nat \<Rightarrow> nat list" where
"bin_rep n m = butlast (bin_rep_aux n m)"

lemma length_of_bin_rep:
  fixes n m:: nat
  assumes "m < 2^n"
  shows "length (bin_rep n m) = n"
  using assms length_of_bin_rep_aux bin_rep_def by simp

lemma bin_rep_coeff:
  fixes n m i:: nat
  assumes "m < 2^n" and "i < n" and "m \<ge> 0"
  shows "bin_rep n m ! i = 0 \<or> bin_rep n m ! i = 1"
  using assms bin_rep_def bin_rep_aux_coeff length_of_bin_rep by(simp add: nth_butlast)

lemma bin_rep_index:
  fixes n m i:: nat
  assumes "n \<ge> 1" and "m < 2^n" and "i < n" and "m \<ge> 0"
  shows "bin_rep n m ! i = (m mod 2^(n-i)) div 2^(n-1-i)"
proof-
  have "bin_rep n m ! i = bin_rep_aux n m ! i"
    using bin_rep_def length_of_bin_rep nth_butlast assms(3)
    by (simp add: nth_butlast assms(2))
  thus ?thesis
    using assms bin_rep_aux_index by simp
qed

lemma bin_rep_eq:
  fixes n m:: nat
  assumes "n \<ge> 1" and "m \<ge> 0" and "m < 2^n" and "m \<ge> 0"
  shows "m = (\<Sum>i<n. bin_rep n m ! i * 2^(n-1-i))"
proof-
  {
    fix i:: nat
    assume "i < n"
    then have "bin_rep n m ! i * 2^(n-1-i) = (m mod 2^(n-i)) div 2^(n-1-i) * 2^(n-1-i)"
      using assms bin_rep_index by simp
    moreover have "\<dots> = m mod 2^(n-i) - m mod 2^(n-i) mod 2^(n-1-i)"
      by (simp add: minus_mod_eq_div_mult)
    moreover have "\<dots> = int(m mod 2^(n-i)) - m mod 2^(n-i) mod 2^(n-1-i)"
      using mod_less_eq_dividend of_nat_diff by blast
    moreover have "\<dots> = int(m mod 2^(n-i)) - m mod 2^(n-1-i)"
      using mod_mod_power_cancel[of "n-1-i" "n-i"] by (simp add: dvd_power_le mod_mod_cancel)
    ultimately have "bin_rep n m ! i * 2^(n-1-i) = int (m mod 2^(n-i)) - m mod 2^(n-1-i)"
      by presburger
  }
  then have f0:"(\<Sum>i<n. bin_rep n m ! i * 2^(n-1-i)) = (\<Sum>i<n. int (m mod 2^(n-i)) - m mod 2^(n-1-i))"
    by auto
  thus ?thesis
  proof-
     have "(\<Sum>i<n. int ((m::nat) mod 2^(n - i)) - (m mod 2^(n - 1 - i))) =
          (\<Sum>i<n. ( m mod 2^(n - i))) -  (\<Sum>i<n. int (m mod 2^(n - 1 - i)))"
      using sum_subtractf[of "(\<lambda>i. (m mod 2^(n-i)))::nat\<Rightarrow>nat" "(\<lambda>i. (m mod 2^(n-1-i)))::nat\<Rightarrow>nat" "{..<(n::nat)}"]
      by auto
    moreover have "\<dots> = m mod 2^n + (\<Sum>i\<in>{1..<n}. (m mod 2^(n-i))) - (\<Sum>i<n-1. int (m mod 2^(n-1-i)))- m mod 2^0"
      using sum.atLeast_Suc_atMost sum.lessThan_Suc assms(1)
      by (smt One_nat_def Suc_le_eq diff_self_eq_0 le_add_diff_inverse lessThan_atLeast0 minus_nat.diff_0
          plus_1_eq_Suc sum.atLeast_Suc_lessThan)
    moreover have "\<dots> = m mod 2^n + (\<Sum>i<n-1. m mod 2^(n-i-1)) - (\<Sum>i<n-1. int ( m mod 2^(n-1-i))) - m mod 2^0"
      apply (auto simp add: sum_of_index_diff[of "\<lambda>i. m mod 2 ^ (n - 1 - i)" "1" "n-1"])
      by (smt One_nat_def assms(1) le_add_diff_inverse lessThan_atLeast0 plus_1_eq_Suc sum.cong sum.shift_bounds_Suc_ivl)
    moreover have "\<dots> = m mod 2^n - m mod 2^0" by simp
    moreover have "\<dots> = m" using assms by auto
    ultimately show "m = (\<Sum>i<n. bin_rep n m ! i * 2^(n-1-i))"
      using assms f0 by linarith
  qed
qed

lemma bin_rep_index_0:
  fixes n m:: nat
  assumes "m < 2^n" and "k > n"
  shows "(bin_rep k m) ! 0 = 0"
proof-
  have "m < 2^(k-1)"
    using assms by(smt Suc_diff_1 Suc_leI gr0I le_trans less_or_eq_imp_le linorder_neqE_nat not_less
one_less_numeral_iff power_strict_increasing semiring_norm(76))
  then have f:"m div 2^(k-1) = 0"
    by auto
  have "k \<ge> 1"
    using assms(2) by simp
  moreover have "bin_rep_aux k m = (m div 2^(k-1)) # (bin_rep_aux (k-1) (m mod 2^(k-1)))"
    using bin_rep_aux.simps(2) by(metis Suc_diff_1 assms(2) diff_0_eq_0 neq0_conv zero_less_diff)
  moreover have "bin_rep k m = butlast ((m div 2^(k-1)) # (bin_rep_aux (k-1) (m mod 2^(k-1))))"
    using bin_rep_def by (simp add: calculation(2))
  moreover have "\<dots> = butlast (0 # (bin_rep_aux (k-1) (m mod 2^(k-1))))"
    using f by simp
  moreover have "\<dots> = 0 # butlast (bin_rep_aux (k-1) (m mod 2^(k-1)))"
    by(simp add: bin_rep_aux_neq_nil)
  ultimately show ?thesis
    by simp
qed

lemma bin_rep_index_0_geq:
  fixes n m:: nat
  assumes "m \<ge> 2^n" and "m < 2^(n+1)"
  shows "bin_rep (n+1) m ! 0 = 1"
proof-
  have "bin_rep (Suc n) m =  butlast (bin_rep_aux (Suc n) m)"
    using bin_rep_def by simp
  moreover have "\<dots> = butlast (1 # (bin_rep_aux n (m mod 2^n)))"
    using assms bin_rep_aux_def by simp
  moreover have "\<dots> = 1 # butlast (bin_rep_aux n (m mod 2^n))"
    by (simp add: bin_rep_aux_neq_nil)
  ultimately show ?thesis
    by (simp add: bin_rep_aux_neq_nil)
qed

end


theory Isar
  imports Main
begin

lemma "\<not> surj(f :: 'a \<Rightarrow> 'a set)"
proof
  assume 0: "surj f"
  from 0 have 1: "\<forall>A. \<exists>a. A = f a" by (simp add: surj_def)
  from 1 have 2: "\<exists>a. {x. x \<notin> f x} = f a" by blast
  from 2 show "False" by blast
qed

lemma
  fixes f :: "'a \<Rightarrow> 'a set"
  assumes s: "surj f"
  shows "False"
proof-
  have "\<exists>a. {x. x \<notin> f x}  = f a" using s by (metis Cantors_paradox Pow_UNIV)
  thus "False" by blast
qed

end