theory Typing_Defs
  imports Set_Semantics "HOL-Library.Adhoc_Overloading"
begin

section \<open>Typing Rules\<close>
text \<open>
  We define the typing rules for set terms and atoms, as well as
  for formulae
\<close>

no_notation Set.member  ("(_/ : _)" [51, 51] 50)

inductive types_pset_term :: "('a \<Rightarrow> nat) \<Rightarrow> 'a pset_term \<Rightarrow> nat \<Rightarrow> bool" ("_ \<turnstile> _ : _" [46, 46, 46] 46) where
  "v \<turnstile> \<emptyset> n : Suc n"
| "v \<turnstile> Var x : v x"
| "v \<turnstile> t : l \<Longrightarrow> v \<turnstile> Single t : Suc l"
| "v \<turnstile> s : l \<Longrightarrow> v \<turnstile> t : l \<Longrightarrow> l \<noteq> 0 \<Longrightarrow> v \<turnstile> s \<squnion>\<^sub>s t : l"
| "v \<turnstile> s : l \<Longrightarrow> v \<turnstile> t : l \<Longrightarrow> l \<noteq> 0 \<Longrightarrow> v \<turnstile> s \<sqinter>\<^sub>s t : l"
| "v \<turnstile> s : l \<Longrightarrow> v \<turnstile> t : l \<Longrightarrow> l \<noteq> 0 \<Longrightarrow> v \<turnstile> s -\<^sub>s t : l"

inductive_cases types_pset_term_cases:
  "v \<turnstile> \<emptyset> n : l" "v \<turnstile> Var x : l" "v \<turnstile> Single t : l"
  "v \<turnstile> s \<squnion>\<^sub>s t : l" "v \<turnstile> s \<sqinter>\<^sub>s t : l" "v \<turnstile> s -\<^sub>s t : l"

lemma types_pset_term_intros':
  "l = Suc n \<Longrightarrow> v \<turnstile> \<emptyset> n : l"
  "l = v x \<Longrightarrow> v \<turnstile> Var x : l"
  "l \<noteq> 0 \<Longrightarrow> v \<turnstile> t : nat.pred l \<Longrightarrow> v \<turnstile> Single t : l"
  by (auto simp add: types_pset_term.intros(1,2,3) pred_def split: nat.splits)

definition type_of_term :: "('a \<Rightarrow> nat) \<Rightarrow> 'a pset_term \<Rightarrow> nat" where
  "type_of_term v t \<equiv> THE l. v \<turnstile> t : l"

inductive types_pset_atom :: "('a \<Rightarrow> nat) \<Rightarrow> 'a pset_atom \<Rightarrow> bool" where
  "\<lbrakk> v \<turnstile> s : l; v \<turnstile> t : l \<rbrakk> \<Longrightarrow> types_pset_atom v (s =\<^sub>s t)"
| "\<lbrakk> v \<turnstile> s : l; v \<turnstile> t : Suc l\<rbrakk> \<Longrightarrow> types_pset_atom v (s \<in>\<^sub>s t)"

definition types_pset_fm :: "('a \<Rightarrow> nat) \<Rightarrow> 'a pset_fm \<Rightarrow> bool" where
  "types_pset_fm v \<phi> \<equiv> (\<forall>a \<in> atoms \<phi>. types_pset_atom v a)"

consts types :: "('a \<Rightarrow> nat) \<Rightarrow> 'b \<Rightarrow> bool" (infix "\<turnstile>" 45)
adhoc_overloading types types_pset_atom types_pset_fm

inductive_cases types_pset_atom_Member_cases:
  "v \<turnstile> s \<in>\<^sub>s t1 \<squnion>\<^sub>s t2" "v \<turnstile> s \<in>\<^sub>s t1 \<sqinter>\<^sub>s t2" "v \<turnstile> s \<in>\<^sub>s t1 -\<^sub>s t2" "v \<turnstile> s \<in>\<^sub>s Single t"

abbreviation "urelem' v (\<phi> :: 'a pset_fm) t \<equiv> v \<turnstile> \<phi> \<and> v \<turnstile> t : 0"

definition urelem :: "'a pset_fm \<Rightarrow> 'a pset_term \<Rightarrow> bool" where
  "urelem \<phi> t \<equiv> (\<exists>v. urelem' v \<phi> t)"

end


(*
   Title: The Calculus of Communicating Systems
   Author/Maintainer: Jesper Bengtson (jebe@itu.dk), 2012
*)
theory Weak_Bisim_Pres
  imports Weak_Bisim Weak_Sim_Pres Strong_Bisim_SC
begin

lemma actPres:
  fixes P :: ccs
  and   Q :: ccs
  and   \<alpha> :: act

  assumes "P \<approx> Q"

  shows "\<alpha>.(P) \<approx> \<alpha>.(Q)"
proof -
  let ?X = "{(\<alpha>.(P), \<alpha>.(Q)) | P Q. P \<approx> Q}"
  from assms have "(\<alpha>.(P), \<alpha>.(Q)) \<in> ?X" by auto
  thus ?thesis
    by(coinduct rule: weakBisimulationCoinduct) (auto dest: weakBisimulationE intro: actPres)
qed

lemma parPres:
  fixes P :: ccs
  and   Q :: ccs
  and   R :: ccs

  assumes "P \<approx> Q"

  shows "P \<parallel> R \<approx> Q \<parallel> R"
proof -
  let ?X = "{(P \<parallel> R, Q \<parallel> R) | P Q R. P \<approx> Q}"
  from assms have "(P \<parallel> R, Q \<parallel> R) \<in> ?X" by blast
  thus ?thesis
    by(coinduct rule: weakBisimulationCoinduct, auto)
      (blast intro: parPres dest: weakBisimulationE)+
qed

  assumes "P \<approx> Q"

  shows "\<lparr>\<nu>x\<rparr>P \<approx> \<lparr>\<nu>x\<rparr>Q"
proof -
  let ?X = "{(\<lparr>\<nu>x\<rparr>P, \<lparr>\<nu>x\<rparr>Q) | x P Q. P \<approx> Q}"
  from assms have "(\<lparr>\<nu>x\<rparr>P, \<lparr>\<nu>x\<rparr>Q) \<in> ?X" by auto
  thus ?thesis
    by(coinduct rule: weakBisimulationCoinduct) (auto intro: resPres dest: weakBisimulationE)
qed

  assumes "P \<approx> Q"

  shows "!P \<approx> !Q"
proof -
  let ?X = "bangRel weakBisimulation"
  let ?Y = "weakBisimulation O ?X O bisim"
  {
    fix R T P Q
    assume "R \<approx> T" and "(P, Q) \<in> ?Y"
    from `(P, Q) \<in> ?Y` obtain P' Q' where "P \<approx> P'" and "(P', Q') \<in> ?X" and "Q' \<sim> Q"
      by auto
    from `P \<approx> P'` have "R \<parallel> P \<approx> R \<parallel> P'"
      by(metis parPres bisimWeakBisimulation transitive parComm)
    moreover from `R \<approx> T` `(P', Q') \<in> ?X` have "(R \<parallel> P', T \<parallel> Q') \<in> ?X" by(auto dest: BRPar)
    moreover from `Q' \<sim> Q` have "T \<parallel> Q' \<sim> T \<parallel> Q" by(metis Strong_Bisim_Pres.parPres Strong_Bisim.transitive parComm)
    ultimately have "(R \<parallel> P, T \<parallel> Q) \<in> ?Y" by auto
  } note BRParAux = this

  from assms have "(!P, !Q) \<in> ?X" by(auto intro: BRBang)
  thus ?thesis
  proof(coinduct rule: weakBisimWeakUpto)
    case(cSim P Q)
    from `(P, Q) \<in> bangRel weakBisimulation` show ?case
    proof(induct)
      case(BRBang P Q)
      note `P \<approx> Q` weakBisimulationE(1) BRParAux
      moreover have "?X \<subseteq> ?Y" by(auto intro: Strong_Bisim.reflexive reflexive)
      moreover {
        fix P Q
        assume "(P \<parallel> !P, Q) \<in> ?Y"
        hence "(!P, Q) \<in> ?Y" using bangUnfold
          by(blast dest: Strong_Bisim.transitive transitive bisimWeakBisimulation)
      }
      ultimately show ?case by(rule bangPres)
    next
      case(BRPar R T P Q)
      from `R \<approx> T` have "R \<leadsto>\<^sup>^<weakBisimulation> T" by(rule weakBisimulationE)
      moreover note `R \<approx> T` `P \<leadsto>\<^sup>^<?Y> Q`
      moreover from `(P, Q) \<in> ?X` have "(P, Q) \<in> ?Y" by(blast intro: Strong_Bisim.reflexive reflexive)
      ultimately show ?case using BRParAux by(rule Weak_Sim_Pres.parPresAux)
    qed
  next
    case(cSym P Q)
    thus ?case
      by induct (auto dest: weakBisimulationE intro: BRPar BRBang)
  qed
qed

end


section\<open>Theory Main: Everything Except AC\<close>

theory Main_ZF imports List_ZF IntDiv_ZF CardinalArith begin

(*The theory of "iterates" logically belongs to Nat, but can't go there because
  primrec isn't available into after Datatype.*)

subsection\<open>Iteration of the function @{term F}\<close>

consts  iterates :: "[i=>i,i,i] => i"   ("(_^_ '(_'))" [60,1000,1000] 60)

primrec
    "F^0 (x) = x"
    "F^(succ(n)) (x) = F(F^n (x))"

definition
  iterates_omega :: "[i=>i,i] => i" ("(_^\<omega> '(_'))" [60,1000] 60) where
    "F^\<omega> (x) == \<Union>n\<in>nat. F^n (x)"

lemma iterates_triv:
     "[| n\<in>nat;  F(x) = x |] ==> F^n (x) = x"
by (induct n rule: nat_induct, simp_all)

lemma iterates_type [TC]:
     "[| n \<in> nat;  a \<in> A; !!x. x \<in> A ==> F(x) \<in> A |]
      ==> F^n (a) \<in> A"
by (induct n rule: nat_induct, simp_all)

lemma iterates_omega_triv:
    "F(x) = x ==> F^\<omega> (x) = x"
by (simp add: iterates_omega_def iterates_triv)

lemma Ord_iterates [simp]:
     "[| n\<in>nat;  !!i. Ord(i) ==> Ord(F(i));  Ord(x) |]
      ==> Ord(F^n (x))"
by (induct n rule: nat_induct, simp_all)

lemma iterates_commute: "n \<in> nat ==> F(F^n (x)) = F^n (F(x))"
by (induct_tac n, simp_all)

subsection\<open>Transfinite Recursion\<close>

text\<open>Transfinite recursion for definitions based on the
    three cases of ordinals\<close>

definition
  transrec3 :: "[i, i, [i,i]=>i, [i,i]=>i] =>i" where
    "transrec3(k, a, b, c) ==
       transrec(k, \<lambda>x r.
         if x=0 then a
         else if Limit(x) then c(x, \<lambda>y\<in>x. r`y)
         else b(Arith.pred(x), r ` Arith.pred(x)))"

lemma transrec3_0 [simp]: "transrec3(0,a,b,c) = a"
by (rule transrec3_def [THEN def_transrec, THEN trans], simp)

lemma transrec3_succ [simp]:
     "transrec3(succ(i),a,b,c) = b(i, transrec3(i,a,b,c))"
by (rule transrec3_def [THEN def_transrec, THEN trans], simp)

lemma transrec3_Limit:
     "Limit(i) ==>
      transrec3(i,a,b,c) = c(i, \<lambda>j\<in>i. transrec3(j,a,b,c))"
by (rule transrec3_def [THEN def_transrec, THEN trans], force)

declaration \<open>fn _ =>
  Simplifier.map_ss (Simplifier.set_mksimps (fn ctxt =>
    map mk_eq o Ord_atomize o Variable.gen_all ctxt))
\<close>

end


theory ARC

imports Main "HOL.Order_Relation" "HOL.Set"

begin

typedecl noun

typedecl verb

datatype Term = Noun noun | All verb Term ("_ all _")
print_theorems

datatype sentence = All Term Term ("All _ _")

(*This definition is a little wonky because a model needs to interpret both terms and verbs*)
type_synonym 'a pre_model = "'a set \<times> (noun \<Rightarrow> 'a set) \<times> (verb => (('a \<times> 'a) set))"

(*I am doing the clunky thing and defining a premodel and a well defined model because models are more complex for ARC.
there may be a better way to do this.*)
definition wf_model :: "'a pre_model \<Rightarrow> bool"
  where "wf_model M \<equiv> let (U, f, g) = M in (\<forall> v :: verb. g v \<subseteq> U \<times> U) \<and>
 (\<forall> n :: noun. f n \<subseteq> U)"

(*The interpretation of a term in a model is a little more complex because we have
to handle nouns, verbs, and complex terms differently*)

(*hacky workaround for now - ideally some kind of polymorphism would be best here*)
(*I think it might be better to have this function also handle verbs
That would require some shenanigans with types because the interpretation
of a verb has type 'a x'a set.*)
fun interp_verb :: "'a pre_model \<Rightarrow> verb \<Rightarrow> ('a \<times> 'a) set"
  where "interp_verb M v = (let (U, f, g) = M in (g v))"

fun interp :: "'a pre_model \<Rightarrow> Term \<Rightarrow> 'a set" ("_ interpreting _")
  where
"interp M (Noun n) = (let (U, f, g) = M in f n)"
| "interp M (r all t) = (let (U, f, g) = M in
 {m \<in> U. \<forall> n. (n \<in> (interp M t)) \<longrightarrow> ((m, n) \<in> (interp_verb M r))})"

print_theorems

fun satisfies :: "'a pre_model \<Rightarrow> sentence \<Rightarrow> bool" ("_ \<Turnstile> _")
  where "satisfies M (All x m) = ((interp M x) \<subseteq> (interp M m))"
print_theorems

datatype example_universe = e1 | e2 | e3

find_theorems name:satisfies

(*assms(3) was the key to this example. I wasn't able to
complete the proof without specifying the universe.*)
lemma example_model:
  fixes M
  assumes "(UNIV::noun set) = {dog, cat}"
  assumes "(UNIV::verb set) = {see}"
  assumes "let (U, f, g) = M in (U = (UNIV:: example_universe set))"
  assumes "interp M (Noun dog) = {e2}"
  assumes "interp M (Noun cat) = {e1, e3}"
  assumes "interp_verb M see = {(e2, e1), (e2, e2), (e2, e3)}"
  assumes "wf_model M"
  shows "M \<Turnstile> (All (Noun dog) (see all (Noun dog)))"
and "M \<Turnstile> All (see all (Noun cat)) (see all (Noun dog))"
proof -
  have "{e2} \<subseteq> interp M (see all (Noun dog))"
    using assms by force
  thus "M \<Turnstile> (All (Noun dog) (see all (Noun dog)))"
    using assms(4) by auto
  have "interp M (see all (Noun cat)) = {e2}"
    using assms by force
  thus "M \<Turnstile> All (see all (Noun cat)) (see all (Noun dog))"
    using \<open>{e2} \<subseteq> interp M (see all( Noun dog))\<close> by auto
qed

definition M_satisfies_G :: "'a pre_model \<Rightarrow> sentence set \<Rightarrow> bool"
  where "M_satisfies_G M G \<equiv> \<forall> g. g \<in> G \<longrightarrow> satisfies M g"

definition entails :: "sentence set \<Rightarrow> sentence \<Rightarrow> 'a itself \<Rightarrow> bool"
  where "entails G phi (ty:: 'a itself) \<equiv> \<forall> (M :: 'a pre_model). M_satisfies_G M G \<and> (wf_model M) \<longrightarrow> satisfies M phi"

find_theorems name:subset_
lemma example_2_6:
  shows "entails {All d (chase all a), All c a} (All d (chase all c)) (TYPE(sentence))"
  unfolding entails_def
proof (rule+)
  fix M assume "M_satisfies_G M {All d (chase all a), All c a}"
  have "M \<Turnstile> All d (chase all a)"
    by (meson M_satisfies_G_def \<open>M_satisfies_G M {All d (chase all a), All c a}\<close> insertI1)
  have "M \<Turnstile> All c a"
    by (meson M_satisfies_G_def \<open>M_satisfies_G M {All d (chase all a), All c a}\<close> insert_subset subset_insertI)
  (*have "M \<Turnstile> All d (chase all c)"*)
  have "M \<Turnstile> All d (chase all c)"
    unfolding satisfies.simps
  proof -
    fix x assume "x = interp M d"
    fix y assume "y = interp M (chase all c)"
    have "interp M c \<subseteq> interp M a"
      using \<open>M \<Turnstile> All c a\<close> by auto
    then have  "interp M (chase all c) \<subseteq> interp M (chase all a)"
      unfolding interp.simps using subset_eq


(*
  File:     Gauss_Sums_Auxiliary.thy
  Authors:  Rodrigo Raya, EPFL; Manuel Eberl, TUM
*)
section \<open>Auxiliary material\<close>
theory Gauss_Sums_Auxiliary
imports
  Dirichlet_L.Dirichlet_Characters
  Dirichlet_Series.Moebius_Mu
  Dirichlet_Series.More_Totient
begin

subsection \<open>Various facts\<close>

lemma sum_div_reduce:
  fixes d :: nat and f :: "nat \<Rightarrow> complex"
  assumes "d dvd k" "d > 0"
  shows "(\<Sum>n | n \<in> {1..k} \<and> d dvd n. f n) = (\<Sum>c \<in> {1..k div d}. f (c*d))"
   by (rule sum.reindex_bij_witness[of _ "\<lambda>k. k * d" "\<lambda>k. k div d"])
     (use assms in \<open>fastforce simp: div_le_mono\<close>)+

lemma prod_div_sub:
  fixes f :: "nat \<Rightarrow> complex"
  assumes "finite A" "B \<subseteq> A" "\<forall>b \<in> B. f b \<noteq> 0"
  shows "(\<Prod> i \<in> A - B. f i) = ((\<Prod> i \<in> A. f i) div (\<Prod> i \<in> B. f i))"
  using assms
proof (induction "card B" arbitrary: B)
case 0
  then show ?case
    using infinite_super by fastforce
next
  case (Suc n)
  then show ?case
  proof -
    obtain B' x where decomp: "B = B' \<union> {x} \<and> x \<notin> B'"
      using card_eq_SucD[OF Suc(2)[symmetric]] insert_is_Un by auto
    then have B'card: "card B' = n" using Suc(2)
      using Suc.prems(2) assms(1) finite_subset by fastforce
    have "prod f (A - B) = prod f ((A-B') - {x})"
      by (simp add: decomp,subst Diff_insert,simp)
    also have "\<dots> = (prod f (A-B')) div f x"
      using prod_diff1[of "A-B'" f x] Suc decomp by auto
    also have "\<dots> = (prod f A div prod f B') div f x"
      using Suc(1)[of B'] Suc(3) B'card decomp
            Suc.prems(2) Suc.prems(3) by force
    also have "\<dots> = prod f A div (prod f B' * f x)" by auto
    also have "\<dots> = prod f A div prod f B"
      using decomp Suc.prems(2) assms(1) finite_subset by fastforce
    finally show ?thesis by blast
  qed
qed

lemma linear_gcd:
  fixes a b c d :: nat
  assumes "a > 0" "b > 0" "c > 0" "d > 0"
  assumes "coprime a c" "coprime b d"
  shows "gcd (a*b) (c*d) = (gcd a d) * (gcd b c)"
  using assms
proof -
  define q1 :: nat where "q1 = a div gcd a d"
  define q2 :: nat where "q2 = c div gcd b c"
  define q3 :: nat where "q3 = b div gcd b c"
  define q4 :: nat where "q4 = d div gcd a d"

  have "coprime q1 q2" "coprime q3 q4"
    unfolding q1_def q2_def q3_def q4_def
  proof -
    have "coprime (a div gcd a d) c"
      using \<open>coprime a c\<close> coprime_mult_left_iff[of "a div gcd a d" "gcd a d" c]
            dvd_mult_div_cancel[OF gcd_dvd1, of a b] by simp
    then show "coprime (a div gcd a d) (c div gcd b c)"
      using coprime_mult_right_iff[of "a div gcd a d" "gcd b c" "c div gcd b c"]
          dvd_div_mult_self[OF gcd_dvd2[of b c]] by auto
    have "coprime (b div gcd b c) d"
      using \<open>coprime b d\<close> coprime_mult_left_iff[of "b div gcd b c" "gcd b c" d]
            dvd_mult_div_cancel[OF gcd_dvd1, of a b] by simp
    then show "coprime (b div gcd b c) (d div gcd a d)"
      using coprime_mult_right_iff[of "b div gcd b c" "gcd a d" "d div gcd a d"]
          dvd_div_mult_self[OF gcd_dvd2[of b c]] by auto
  qed
  moreover have "coprime q1 q4" "coprime q3 q2"
    unfolding q1_def q2_def q3_def q4_def
    using assms div_gcd_coprime by blast+
  ultimately have 1: "coprime (q1*q3) (q2*q4)"
    by simp
  have "gcd (a*b) (c*d) = (gcd a d) * (gcd b c) * gcd (q1*q3) (q2*q4)"
    unfolding q1_def q2_def q3_def q4_def
    by (subst gcd_mult_distrib_nat[of "gcd a d * gcd b c"],
       simp add: field_simps,
       simp add: mult.left_commute semiring_normalization_rules(18))
  from this 1 show "gcd (a*b) (c*d) = (gcd a d) * (gcd b c)" by auto
qed

lemma reindex_product_bij:
  fixes a b m k :: nat
  defines "S \<equiv> {(d1,d2). d1 dvd gcd a m \<and> d2 dvd gcd k b}"
  defines "T \<equiv> {d. d dvd (gcd a m) * (gcd k b)}"
  defines "f \<equiv> (\<lambda>(d1,d2). d1 * d2)"
  assumes "coprime a k"
  shows "bij_betw f S T"
  unfolding bij_betw_def
proof
  show inj: "inj_on f S"
    unfolding f_def
  proof -
    {fix d1 d2 d1' d2'
    assume "(d1,d2) \<in> S" "(d1',d2') \<in> S"
    then have dvd: "d1 dvd gcd a m" "d2 dvd gcd k b"
              "d1' dvd gcd a m" "d2' dvd gcd k b"
      unfolding S_def by simp+
    assume "f (d1,d2) = f (d1',d2')"
    then have eq: "d1 * d2 = d1' * d2'"
      unfolding f_def by simp
    from eq dvd have eq1: "d1 = d1'"
      by (simp,meson assms coprime_crossproduct_nat coprime_divisors)
    from eq dvd have eq2: "d2 = d2'"
      using assms(4) eq1 by auto
    from eq1 eq2 have "d1 = d1' \<and> d2 = d2'" by simp}
   then show "inj_on (\<lambda>(d1, d2). d1 * d2) S"
    using S_def f_def by (intro inj_onI,blast)
  qed
  show surj: "f ` S = T"
  proof -
    {fix d
      have "d dvd (gcd a m) * (gcd k b)
       \<longleftrightarrow> (\<exists>d1 d2. d = d1*d2 \<and> d1 dvd gcd a m \<and> d2 dvd gcd k b)"
        using division_decomp mult_dvd_mono by blast}
      then show ?thesis
        unfolding f_def S_def T_def image_def
        by auto
  qed
qed

lemma p_div_set:
  shows "{p. p \<in>prime_factors a \<and> \<not> p dvd N} =
         ({p. p \<in>prime_factors (a*N)} - {p. p \<in>prime_factors N})"
  (is "?A = ?B")
proof
  show "?A \<subseteq> ?B"
  proof (simp)
    { fix p
      assume as: "p \<in># prime_factorization a" "\<not> p dvd N"
      then have 1: "p \<in> prime_factors (a * N)"
      proof -
        from in_prime_factors_iff[of p a] as
        have "a \<noteq> 0" "p dvd a" "prime p" by simp+
        have "N \<noteq> 0" using \<open>\<not> p dvd N\<close> by blast
        have "a * N \<noteq> 0" using \<open>a \<noteq> 0\<close> \<open>N \<noteq> 0\<close> by auto
        have "p dvd a*N" using \<open>p dvd a\<close> by simp
        show ?thesis
          using \<open>a*N \<noteq> 0\<close> \<open>p dvd a*N\<close> \<open>prime p\<close> in_prime_factors_iff by blast
      qed
      from as have 2: "p \<notin> prime_factors N" by blast
      from 1 2 have "p \<in> prime_factors (a * N) - prime_factors N"
       by blast
    }
    then show "{p. p \<in># prime_factorization a \<and> \<not> p dvd N}
               \<subseteq> prime_factors (a * N) - prime_factors N" by blast
  qed

  show "?B \<subseteq> ?A"
  proof (simp)
    { fix p
      assume as: "p \<in> prime_factors (a * N) - prime_factors N"
      then have 1: "\<not> p dvd N"
      proof -
        from as have "p \<in> prime_factors (a * N)" "p \<notin> prime_factors N"
          using DiffD1 DiffD2 by blast+
        then show ?thesis by (simp add: in_prime_factors_iff)
      qed
      have 2: "p \<in># prime_factorization a"
      proof -
        have "p dvd (a*N)" "prime p" "a*N \<noteq> 0" using in_prime_factors_iff as by blast+
        have "p dvd a" using \<open>\<not> p dvd N\<close> prime_dvd_multD[OF \<open>prime p\<close> \<open>p dvd (a*N)\<close>] by blast
        have "a \<noteq> 0" using \<open>a*N \<noteq> 0\<close> by simp
        show ?thesis using in_prime_factors_iff \<open>a \<noteq> 0\<close> \<open>p dvd a\<close> \<open>prime p\<close> by blast
      qed
      from 1 2 have "p \<in> {p. p \<in># prime_factorization a \<and> \<not> p dvd N}" by blast
    }
    then show "prime_factors (a * N) - prime_factors N
               \<subseteq> {p. p \<in># prime_factorization a \<and> \<not> p dvd N}" by blast
  qed
qed

lemma coprime_iff_prime_factors_disjoint:
  fixes x y :: "'a :: factorial_semiring"
  assumes "x \<noteq> 0" "y \<noteq> 0"
  shows "coprime x y \<longleftrightarrow> prime_factors x \<inter> prime_factors y = {}"
proof
  assume "coprime x y"
  have False if "p \<in> prime_factors x" "p \<in> prime_factors y" for p
  proof -
    from that assms have "p dvd x" "p dvd y"
      by (auto simp: prime_factors_dvd)
    with \<open>coprime x y\<close> have "p dvd 1"
      using coprime_common_divisor by auto
    with that assms show False by (auto simp: prime_factors_dvd)
  qed
  thus "prime_factors x \<inter> prime_factors y = {}" by auto
next
  assume disjoint: "prime_factors x \<inter> prime_factors y = {}"
  show "coprime x y"
  proof (rule coprimeI)
    fix d assume d: "d dvd x" "d dvd y"
    show "is_unit d"
    proof (rule ccontr)
      assume "\<not>is_unit d"
      moreover from this and d assms have "d \<noteq> 0" by auto
      ultimately obtain p where p: "prime p" "p dvd d"
        using prime_divisor_exists by auto
      with d and assms have "p \<in> prime_factors x \<inter> prime_factors y"
        by (auto simp: prime_factors_dvd)
      with disjoint show False by auto
    qed
  qed
qed

lemma coprime_cong_prime_factors:
  fixes x y :: "'a :: factorial_semiring_gcd"
  assumes "x \<noteq> 0" "y \<noteq> 0" "x' \<noteq> 0" "y' \<noteq> 0"
  assumes "prime_factors x = prime_factors x'"
  assumes "prime_factors y = prime_factors y'"
  shows   "coprime x y \<longleftrightarrow> coprime x' y'"
  using assms by (simp add: coprime_iff_prime_factors_disjoint)

lemma moebius_prod_not_coprime:
  assumes "\<not> coprime N d"
  shows "moebius_mu (N*d) = 0"
proof -
  from assms obtain l where l_form: "l dvd N \<and> l dvd d \<and> \<not> is_unit l"
    unfolding coprime_def by blast
  then have "l * l dvd N * d" using mult_dvd_mono by auto
  then have "l\<^sup>2 dvd N*d" by (subst power2_eq_square,blast)
  then have "\<not> squarefree (N*d)"
    unfolding squarefree_def coprime_def using l_form by blast
  then show "moebius_mu (N*d) = 0"
    using moebius_mu_def by auto
qed

text\<open>Theorem 2.18\<close>

(* TODO Place in corresponding theory *)
lemma sum_divisors_moebius_mu_times_multiplicative:
  fixes f :: "nat \<Rightarrow> 'a :: {comm_ring_1}"
  assumes "multiplicative_function f" and "n > 0"
  shows   "(\<Sum>d | d dvd n. moebius_mu d * f d) = (\<Prod>p\<in>prime_factors n. 1 - f p)"
proof -
  define g where "g = (\<lambda>n. \<Sum>d | d dvd n. moebius_mu d * f d)"
  define g' where "g' = dirichlet_prod (\<lambda>n. moebius_mu n * f n) (\<lambda>n. if n = 0 then 0 else 1)"
  interpret f: multiplicative_function f by fact
  have "multiplicative_function (\<lambda>n. if n = 0 then 0 else 1 :: 'a)"
    by standard auto
  interpret multiplicative_function g' unfolding g'_def
    by (intro multiplicative_dirichlet_prod multiplicative_function_mult
              moebius_mu.multiplicative_function_axioms assms) fact+

  have g'_primepow: "g' (p ^ k) = 1 - f p" if "prime p" "k > 0" for p k
  proof -
    have "g' (p ^ k) = (\<Sum>i\<le>k. moebius_mu (p ^ i) * f (p ^ i))"
      using that by (simp add: g'_def dirichlet_prod_prime_power)
    also have "\<dots> = (\<Sum>i\<in>{0, 1}. moebius_mu (p ^ i) * f (p ^ i))"
      using that by (intro sum.mono_neutral_right) (auto simp: moebius_mu_power')
    also have "\<dots> = 1 - f p"
      using that by (simp add: moebius_mu.prime)
    finally show ?thesis .
  qed

  have "g' n = g n"
    by (simp add: g_def g'_def dirichlet_prod_def)
  also from assms have "g' n = (\<Prod>p\<in>prime_factors n. g' (p ^ multiplicity p n))"
   by (intro prod_prime_factors) auto
  also have "\<dots> = (\<Prod>p\<in>prime_factors n. 1 - f p)"
    by (intro prod.cong) (auto simp: g'_primepow prime_factors_multiplicity)
  finally show ?thesis by (simp add: g_def)
qed

lemma multiplicative_ind_coprime [intro]: "multiplicative_function (ind (coprime N))"
  by (intro multiplicative_function_ind) auto

lemma sum_divisors_moebius_mu_times_multiplicative_revisited:
  fixes f :: "nat \<Rightarrow> 'a :: {comm_ring_1}"
  assumes "multiplicative_function f" "n > 0" "N > 0"
  shows   "(\<Sum>d | d dvd n \<and> coprime N d. moebius_mu d * f d) =
           (\<Prod>p\<in>{p. p \<in> prime_factors n \<and> \<not> (p dvd N)}. 1 - f p)"
proof -
  have "(\<Sum>d | d dvd n \<and> coprime N d. moebius_mu d * f d) =
          (\<Sum>d | d dvd n. moebius_mu d * (ind (coprime N) d * f d))"
    using assms by (intro sum.mono_neutral_cong_left) (auto simp: ind_def)
  also have "\<dots> = (\<Prod>p\<in>prime_factors n. 1 - ind (coprime N) p * f p)"
    using assms by (intro sum_divisors_moebius_mu_times_multiplicative)
                   (auto intro: multiplicative_function_mult)
  also from assms have "\<dots> = (\<Prod>p | p \<in> prime_factors n \<and> \<not>(p dvd N). 1 - f p)"
    by (intro prod.mono_neutral_cong_right)
       (auto simp: ind_def prime_factors_dvd coprime_commute dest: prime_imp_coprime)
  finally show ?thesis .
qed

subsection \<open>Neutral element of the Dirichlet product\<close>

definition "dirichlet_prod_neutral n = (if n = 1 then 1 else 0)" for n :: nat

lemma dirichlet_prod_neutral_intro:
  fixes S :: "nat \<Rightarrow> complex" and f :: "nat \<Rightarrow> nat \<Rightarrow> complex"
  defines "S \<equiv> (\<lambda>(n::nat). (\<Sum>k | k \<in> {1..n} \<and> coprime k n. (f k n)))"
  shows "S(n) = (\<Sum>k \<in> {1..n}. f k n * dirichlet_prod_neutral (gcd k n))"
proof -
  let ?g = "\<lambda>k. (f k n)* (dirichlet_prod_neutral (gcd k n))"
  have zeros: "\<forall>k \<in> {1..n} - {k. k \<in> {1..n} \<and> coprime k n}. ?g k = 0"
  proof
    fix k
    assume "k \<in> {1..n} - {k \<in> {1..n}. coprime k n}"
    then show "(f k n) * dirichlet_prod_neutral (gcd k n) = 0"
      by (simp add: dirichlet_prod_neutral_def[of "gcd k n"] split: if_splits,presburger)
  qed

  have "S n = (\<Sum>k | k \<in> {1..n} \<and> coprime k n. (f k n))"
    by (simp add: S_def)
  also have "\<dots> = sum ?g {k. k \<in> {1..n} \<and> coprime k n}"
    by (simp add: dirichlet_prod_neutral_def split: if_splits)
  also have "\<dots> = sum ?g {1..n}"
    by (intro sum.mono_neutral_left, auto simp add: zeros)
  finally show ?thesis by blast
qed

lemma dirichlet_prod_neutral_right_neutral:
 "dirichlet_prod f dirichlet_prod_neutral n = f n " if "n > 0" for f :: "nat \<Rightarrow> complex" and n
proof -
  {fix d :: nat
    assume "d dvd n"
    then have eq: "n = d \<longleftrightarrow> n div d = 1"
      using div_self that dvd_mult_div_cancel by force
    have "f(d)*dirichlet_prod_neutral(n div d) = (if n = d then f(d) else 0)"
      by (simp add: dirichlet_prod_neutral_def eq)}
  note summand = this

  have "dirichlet_prod f dirichlet_prod_neutral n =
          (\<Sum>d | d dvd n. f(d)*dirichlet_prod_neutral(n div d))"
    unfolding dirichlet_prod_def by blast
  also have "\<dots> = (\<Sum>d | d dvd n. (if n = d then f(d) else 0))"
    using summand by simp
  also have "\<dots> = (\<Sum>d | d = n. (if n = d then f(d) else 0))"
    using that by (intro sum.mono_neutral_right, auto)
  also have "\<dots> = f(n)"  by simp
  finally show ?thesis by simp
qed

lemma dirichlet_prod_neutral_left_neutral:
 "dirichlet_prod dirichlet_prod_neutral f n = f n "
 if "n > 0" for f :: "nat \<Rightarrow> complex" and n
  using dirichlet_prod_neutral_right_neutral[OF that, of f]
        dirichlet_prod_commutes[of f dirichlet_prod_neutral]
  by argo

corollary I_right_neutral_0:
  fixes f :: "nat \<Rightarrow> complex"
  assumes "f 0 = 0"
  shows "dirichlet_prod f dirichlet_prod_neutral n = f n"
  using assms dirichlet_prod_neutral_right_neutral by (cases n, simp, blast)

subsection \<open>Multiplicative functions\<close>

lemma mult_id: "multiplicative_function id"
  by (simp add: multiplicative_function_def)

lemma mult_moebius: "multiplicative_function moebius_mu"
  using Moebius_Mu.moebius_mu.multiplicative_function_axioms
  by simp

lemma mult_of_nat: "multiplicative_function of_nat"
  using multiplicative_function_def of_nat_0 of_nat_1 of_nat_mult by blast

lemma mult_of_nat_c: "completely_multiplicative_function of_nat"
  by (simp add: completely_multiplicative_function_def)

lemma completely_multiplicative_nonzero:
  fixes f :: "nat \<Rightarrow> complex"
  assumes "completely_multiplicative_function f"
          "d \<noteq> 0"
          "\<And>p. prime p \<Longrightarrow> f(p) \<noteq> 0"
  shows "f(d) \<noteq> 0"
  using assms(2)
proof (induction d rule: nat_less_induct)
  case (1 n)
  then show ?case
  proof (cases "n = 1")
    case True
    then show ?thesis
      using assms(1)
      unfolding completely_multiplicative_function_def by simp
  next
    case False
    then obtain p where 2:"prime p \<and> p dvd n"
      using prime_factor_nat by blast
    then obtain a where 3: "n = p * a"  "a \<noteq> 0"
      using 1 by auto
    then have 4: "f(a) \<noteq> 0" using 1
      using 2 prime_nat_iff by fastforce
    have 5: "f(p) \<noteq> 0" using assms(3) 2 by simp
    from 3 4 5 show ?thesis
      by (simp add: assms(1) completely_multiplicative_function.mult)
  qed
qed

lemma multipl_div:
  fixes m k d1 d2 :: nat and f :: "nat \<Rightarrow> complex"
  assumes "multiplicative_function f" "d1 dvd m" "d2 dvd k" "coprime m k"
  shows "f ((m*k) div (d1*d2)) = f(m div d1) * f(k div d2)"
  using assms
  unfolding multiplicative_function_def
  using assms(1) multiplicative_function.mult_coprime by fastforce

  from assms(2,3) obtain a where div: "k = a * d " by fastforce
  have "f (k div d) = f ((a*d) div d)" using div by simp
  also have "\<dots> = f(a)" using assms(3) div by simp
  also have "\<dots> = f(a)*f(d) div f(d)" using nz by auto
  also have "\<dots> = f(a*d) div f(d)"
    by (simp add: div assms(1) completely_multiplicative_function.mult)
  also have "\<dots> = f (k) div f(d)" using div by simp
  finally show ?thesis by simp
qed

lemma comp_to_mult: "completely_multiplicative_function f \<Longrightarrow>
       multiplicative_function f"
  unfolding completely_multiplicative_function_def
            multiplicative_function_def by auto

end


theory Pappus_Property
  imports Main Projective_Plane_Axioms
begin

(* Author: Anthony Bordg, University of Cambridge, apdb3@cam.ac.uk .*)

text \<open>
Contents:
\<^item> We give two formulations of Pappus's property for a configuration of nine points
 [is_pappus1] [is_pappus2].
\<^item> We prove the equivalence of these two formulations [pappus_equiv].
\<^item> We state Pappus property for a plane [is_pappus].
\<close>

section \<open>Pappus's Property\<close>

definition col :: "[Points, Points, Points] \<Rightarrow> bool" where
"col A B C \<equiv> \<exists>l. incid A l \<and> incid B l \<and> incid C l"

definition distinct6 ::
  "[Points, Points, Points, Points, Points, Points] \<Rightarrow> bool" where
"distinct6 A B C D E F \<equiv> (A \<noteq> B) \<and> (A \<noteq> C) \<and> (A \<noteq> D) \<and> (A \<noteq> E) \<and> (A \<noteq> F) \<and>
(B \<noteq> C) \<and> (B \<noteq> D) \<and> (B \<noteq> E) \<and> (B \<noteq> F) \<and>
(C \<noteq> D) \<and> (C \<noteq> E) \<and> (C \<noteq> F) \<and>
(D \<noteq> E) \<and> (D \<noteq> F) \<and>
(E \<noteq> F)"

definition lines :: "Points \<Rightarrow> Points \<Rightarrow> Lines set" where
"lines P Q \<equiv> {l. incid P l \<and> incid Q l}"

lemma uniq_line:
  assumes "P \<noteq> Q" and "l \<in> lines P Q" and "m \<in> lines P Q"
  shows "l = m"
  using assms lines_def ax_uniqueness
  by blast

definition line :: "Points \<Rightarrow> Points \<Rightarrow> Lines" where
"line P Q \<equiv> @l. incid P l \<and> incid Q l"

(* The point P is the intersection of the lines AB and CD. For P to be well-defined,
A and B should be distinct, C and D should be distinct, and the lines AB and CD should
be distinct *)
definition is_a_proper_intersec :: "[Points, Points, Points, Points, Points] \<Rightarrow> bool" where
"is_a_proper_intersec P A B C D \<equiv> (A \<noteq> B) \<and> (C \<noteq> D) \<and> (line A B \<noteq> line C D)
\<and> col P A B \<and> col P C D"

(* We state a first form of Pappus's property *)
definition is_pappus1 ::
"[Points, Points, Points, Points, Points, Points, Points, Points, Points] => bool " where
"is_pappus1 A B C A' B' C' P Q R \<equiv>
  distinct6 A B C A' B' C' \<longrightarrow> col A B C \<longrightarrow> col A' B' C'
  \<longrightarrow> is_a_proper_intersec P A B' A' B \<longrightarrow> is_a_proper_intersec Q B C' B' C
  \<longrightarrow> is_a_proper_intersec R A C' A' C
  \<longrightarrow> col P Q R"

definition is_a_intersec :: "[Points, Points, Points, Points, Points] \<Rightarrow> bool" where
"is_a_intersec P A B C D \<equiv> col P A B \<and> col P C D"

(* We state a second form of Pappus's property *)
definition is_pappus2 ::
"[Points, Points, Points, Points, Points, Points, Points, Points, Points] \<Rightarrow> bool" where
"is_pappus2 A B C A' B' C' P Q R \<equiv>
  (distinct6 A B C A' B' C' \<or> (A \<noteq> B' \<and> A'\<noteq> B \<and> line A B' \<noteq> line A' B \<and>
  B \<noteq> C' \<and> B' \<noteq> C \<and> line B C' \<noteq> line B' C \<and>
  A \<noteq> C' \<and> A' \<noteq> C \<and> line A C' \<noteq> line A' C))
  \<longrightarrow> col A B C \<longrightarrow> col A' B' C' \<longrightarrow> is_a_intersec P A B' A' B
  \<longrightarrow> is_a_intersec Q B C' B' C \<longrightarrow> is_a_intersec R A C' A' C
  \<longrightarrow> col P Q R"

lemma is_a_proper_intersec_is_a_intersec:
  assumes "is_a_proper_intersec P A B C D"
  shows "is_a_intersec P A B C D"
  using assms is_a_intersec_def is_a_proper_intersec_def
  by auto

(* The first and the second forms of Pappus's property are equivalent *)
lemma pappus21:
  assumes "is_pappus2 A B C A' B' C' P Q R"
  shows "is_pappus1 A B C A' B' C' P Q R"
  using assms is_pappus2_def is_pappus1_def is_a_proper_intersec_is_a_intersec
  by auto

lemma col_AAB: "col A A B"
  by (simp add: ax1 col_def)

lemma col_ABA: "col A B A"
  using ax1 col_def
  by blast

lemma col_ABB: "col A B B"
  by (simp add: ax1 col_def)

lemma incidA_lAB: "incid A (line A B)"
  by (metis (no_types, lifting) ax1 line_def someI_ex)

lemma incidB_lAB: "incid B (line A B)"
  by (metis (no_types, lifting) ax1 line_def someI_ex)

lemma degenerate_hexagon_is_pappus:
  assumes "distinct6 A B C A' B' C'" and "col A B C" and "col A' B' C'" and
"is_a_intersec P A B' A' B" and "is_a_intersec Q B C' B' C" and "is_a_intersec R A C' A' C"
and "line A B' = line A' B \<or> line B C' = line B' C \<or> line A C' = line A' C"
  shows "col P Q R"
proof -
  have "col P Q R" if "line A B' = line A' B"
    by (smt assms(1) assms(3) assms(4) assms(5) assms(6) ax_uniqueness col_def distinct6_def
        incidA_lAB incidB_lAB is_a_intersec_def that)
  have "col P Q R" if "line B C' = line B' C"
    by (smt \<open>line A B' = line A' B \<Longrightarrow> col P Q R\<close> assms(1) assms(2) assms(3) ax_uniqueness col_def
        distinct6_def incidA_lAB incidB_lAB that)
  have "col P Q R" if "line A C' = line A' C"
    by (smt \<open>line B C' = line B' C \<Longrightarrow> col P Q R\<close> assms(1) assms(2) assms(3) assms(7) ax_uniqueness
        col_def distinct6_def incidA_lAB incidB_lAB)
  show "col P Q R"
    using \<open>line A B' = line A' B \<Longrightarrow> col P Q R\<close> \<open>line A C' = line A' C \<Longrightarrow> col P Q R\<close>
      \<open>line B C' = line B' C \<Longrightarrow> col P Q R\<close> assms(7)
    by blast
qed

lemma pappus12:
  assumes "is_pappus1 A B C A' B' C' P Q R"
  shows "is_pappus2 A B C A' B' C' P Q R"
proof -
  have "col P Q R" if "(A \<noteq> B' \<and> A'\<noteq> B \<and> line A B' \<noteq> line A' B \<and>
  B \<noteq> C' \<and> B' \<noteq> C \<and> line B C' \<noteq> line B' C \<and>
  A \<noteq> C' \<and> A' \<noteq> C \<and> line A C' \<noteq> line A' C)" and h1:"col A B C" and h2:"col A' B' C'"
  and "is_a_intersec P A B' A' B" and "is_a_intersec Q B C' B' C"
  and "is_a_intersec R A C' A' C"
  proof -
    have "col P Q R" if "A = B" (* in this case P = A = B and P, Q, R lie on AC' *)
    proof -
      have "P = A"
        by (metis \<open>A \<noteq> B' \<and> A' \<noteq> B \<and> line A B' \<noteq> line A' B \<and> B \<noteq> C' \<and> B' \<noteq> C \<and> line B C' \<noteq> line B' C
  \<and> A \<noteq> C' \<and> A' \<noteq> C \<and> line A C' \<noteq> line A' C\<close> \<open>is_a_intersec P A B' A' B\<close> ax_uniqueness col_def
            incidA_lAB incidB_lAB is_a_intersec_def that)
      have "col P A C' \<and> col Q A C' \<and> col R A C'"
        using \<open>P = A\<close> \<open>is_a_intersec Q B C' B' C\<close> \<open>is_a_intersec R A C' A' C\<close> col_AAB
          is_a_intersec_def that
        by auto
      then show "col P Q R"
        by (smt \<open>A \<noteq> B' \<and> A' \<noteq> B \<and> line A B' \<noteq> line A' B \<and> B \<noteq> C' \<and> B' \<noteq> C \<and> line B C' \<noteq> line B' C
          \<and> A \<noteq> C' \<and> A' \<noteq> C \<and> line A C' \<noteq> line A' C\<close> ax_uniqueness col_def)
  qed
  have "col P Q R" if "A = C" (* case where P = A = C = Q and P,Q,R belong to AB' *)
  proof -
    have "R = A"
      by (metis \<open>A \<noteq> B' \<and> A' \<noteq> B \<and> line A B' \<noteq> line A' B \<and> B \<noteq> C' \<and> B' \<noteq> C \<and> line B C' \<noteq> line B' C
        \<and> A \<noteq> C' \<and> A' \<noteq> C \<and> line A C' \<noteq> line A' C\<close> \<open>is_a_intersec R A C' A' C\<close> ax_uniqueness col_def incidA_lAB incidB_lAB is_a_intersec_def that)
    have "col P A B' \<and> col Q A B' \<and> col R A B'"
      using \<open>R = A\<close> \<open>is_a_intersec P A B' A' B\<close> \<open>is_a_intersec Q B C' B' C\<close> col_def
        is_a_intersec_def that
      by auto
    then show "col P Q R"
      by (smt \<open>A \<noteq> B' \<and> A' \<noteq> B \<and> line A B' \<noteq> line A' B \<and> B \<noteq> C' \<and> B' \<noteq> C \<and> line B C' \<noteq> line B' C
        \<and> A \<noteq> C' \<and> A' \<noteq> C \<and> line A C' \<noteq> line A' C\<close> ax_uniqueness col_def)
  qed
  have "col P Q R" if "A = A'" (* very degenerate case, all the 9 points are collinear*)
    by (smt \<open>A \<noteq> B' \<and> A' \<noteq> B \<and> line A B' \<noteq> line A' B \<and> B \<noteq> C' \<and> B' \<noteq> C \<and> line B C' \<noteq> line B' C \<and>
      A \<noteq> C' \<and> A' \<noteq> C \<and> line A C' \<noteq> line A' C\<close> \<open>is_a_intersec P A B' A' B\<close> \<open>is_a_intersec R A C' A' C\<close>
        ax_uniqueness col_ABA col_def incidA_lAB incidB_lAB is_a_intersec_def that)
  have "col P Q R" if "B = C" (* case where B = C = Q and P,Q,R belong to A'B *)
    by (smt \<open>A \<noteq> B' \<and> A' \<noteq> B \<and> line A B' \<noteq> line A' B \<and> B \<noteq> C' \<and> B' \<noteq> C \<and> line B C' \<noteq> line B' C \<and>
      A \<noteq> C' \<and> A' \<noteq> C \<and> line A C' \<noteq> line A' C\<close> \<open>is_a_intersec P A B' A' B\<close> \<open>is_a_intersec Q B C' B' C\<close>
        \<open>is_a_intersec R A C' A' C\<close> ax_uniqueness col_def incidA_lAB incidB_lAB is_a_intersec_def that)
  have "col P Q R" if "B = B'" (* very degenerate case, the 9 points are collinear *)
    by (smt \<open>A \<noteq> B' \<and> A' \<noteq> B \<and> line A B' \<noteq> line A' B \<and> B \<noteq> C' \<and> B' \<noteq> C \<and> line B C' \<noteq> line B' C \<and>
      A \<noteq> C' \<and> A' \<noteq> C \<and> line A C' \<noteq> line A' C\<close> \<open>is_a_intersec P A B' A' B\<close> \<open>is_a_intersec Q B C' B' C\<close>
        ax_uniqueness col_AAB col_def incidA_lAB incidB_lAB is_a_intersec_def that)
  have "col P Q R" if "C = C'" (* again, very degenerate case, the 9 points are collinear *)
    by (smt \<open>A \<noteq> B' \<and> A' \<noteq> B \<and> line A B' \<noteq> line A' B \<and> B \<noteq> C' \<and> B' \<noteq> C \<and> line B C' \<noteq> line B' C \<and>
      A \<noteq> C' \<and> A' \<noteq> C \<and> line A C' \<noteq> line A' C\<close> \<open>is_a_intersec Q B C' B' C\<close> \<open>is_a_intersec R A C' A' C\<close>
        ax_uniqueness col_ABB col_def incidA_lAB incidB_lAB is_a_intersec_def that)
  have "col P Q R" if "A' = B'" (* case where P = A' = B', and P,Q,R belong to A'C *)
    by (smt \<open>A \<noteq> B' \<and> A' \<noteq> B \<and> line A B' \<noteq> line A' B \<and> B \<noteq> C' \<and> B' \<noteq> C \<and> line B C' \<noteq> line B' C \<and>
      A \<noteq> C' \<and> A' \<noteq> C \<and> line A C' \<noteq> line A' C\<close> \<open>is_a_intersec P A B' A' B\<close> \<open>is_a_intersec Q B C' B' C\<close>
        \<open>is_a_intersec R A C' A' C\<close> ax_uniqueness col_def incidA_lAB incidB_lAB is_a_intersec_def that)
  have "col P Q R" if "A' = C'" (* case where R = A' = B', the points P,Q,R belong to A'B *)
    by (smt \<open>A \<noteq> B' \<and> A' \<noteq> B \<and> line A B' \<noteq> line A' B \<and> B \<noteq> C' \<and> B' \<noteq> C \<and> line B C' \<noteq> line B' C \<and>
      A \<noteq> C' \<and> A' \<noteq> C \<and> line A C' \<noteq> line A' C\<close> \<open>is_a_intersec P A B' A' B\<close> \<open>is_a_intersec Q B C' B' C\<close>
        \<open>is_a_intersec R A C' A' C\<close> ax_uniqueness col_def incidA_lAB incidB_lAB is_a_intersec_def that)
  have "col P Q R" if "B' = C'" (* case where Q = B' = C', the points P,Q,R belong to AB' *)
    by (smt \<open>A \<noteq> B' \<and> A' \<noteq> B \<and> line A B' \<noteq> line A' B \<and> B \<noteq> C' \<and> B' \<noteq> C \<and> line B C' \<noteq> line B' C \<and>
      A \<noteq> C' \<and> A' \<noteq> C \<and> line A C' \<noteq> line A' C\<close> \<open>is_a_intersec P A B' A' B\<close> \<open>is_a_intersec Q B C' B' C\<close>
        \<open>is_a_intersec R A C' A' C\<close> ax_uniqueness col_def incidA_lAB incidB_lAB is_a_intersec_def that)
  have "col P Q R" if "A \<noteq> B \<and> A \<noteq> C \<and> A \<noteq> A' \<and> B \<noteq> C \<and> B \<noteq> B' \<and> C \<noteq> C' \<and> A'\<noteq> B'
    \<and> A' \<noteq> C' \<and> B' \<noteq> C'"
  proof -
    have a1:"distinct6 A B C A' B' C'"
      using \<open>A \<noteq> B' \<and> A' \<noteq> B \<and> line A B' \<noteq> line A' B \<and> B \<noteq> C' \<and> B' \<noteq> C \<and> line B C' \<noteq> line B' C \<and>
        A \<noteq> C' \<and> A' \<noteq> C \<and> line A C' \<noteq> line A' C\<close> distinct6_def that
      by auto
    have "is_a_proper_intersec P A B' A' B"
      using \<open>A \<noteq> B' \<and> A' \<noteq> B \<and> line A B' \<noteq> line A' B \<and> B \<noteq> C' \<and> B' \<noteq> C \<and> line B C' \<noteq> line B' C \<and>
        A \<noteq> C' \<and> A' \<noteq> C \<and> line A C' \<noteq> line A' C\<close> \<open>is_a_intersec P A B' A' B\<close> is_a_intersec_def
        is_a_proper_intersec_def
      by auto
    have "is_a_proper_intersec Q B C' B' C"
      using \<open>A \<noteq> B' \<and> A' \<noteq> B \<and> line A B' \<noteq> line A' B \<and> B \<noteq> C' \<and> B' \<noteq> C \<and> line B C' \<noteq> line B' C \<and>
        A \<noteq> C' \<and> A' \<noteq> C \<and> line A C' \<noteq> line A' C\<close> \<open>is_a_intersec Q B C' B' C\<close> is_a_intersec_def
        is_a_proper_intersec_def
      by auto
    have "is_a_proper_intersec R A C' A' C"
      using \<open>A \<noteq> B' \<and> A' \<noteq> B \<and> line A B' \<noteq> line A' B \<and> B \<noteq> C' \<and> B' \<noteq> C \<and> line B C' \<noteq> line B' C \<and>
        A \<noteq> C' \<and> A' \<noteq> C \<and> line A C' \<noteq> line A' C\<close> \<open>is_a_intersec R A C' A' C\<close> is_a_intersec_def
        is_a_proper_intersec_def
      by auto
    show "col P Q R"
      using \<open>is_a_proper_intersec P A B' A' B\<close> \<open>is_a_proper_intersec Q B C' B' C\<close>
        \<open>is_a_proper_intersec R A C' A' C\<close> a1 assms h1 h2 is_pappus1_def
      by blast
  qed
    show "col P Q R"
      using \<open>A = A' \<Longrightarrow> col P Q R\<close> \<open>A = B \<Longrightarrow> col P Q R\<close> \<open>A = C \<Longrightarrow> col P Q R\<close>
        \<open>A \<noteq> B \<and> A \<noteq> C \<and> A \<noteq> A' \<and> B \<noteq> C \<and> B \<noteq> B' \<and> C \<noteq> C' \<and> A' \<noteq> B' \<and> A' \<noteq> C' \<and> B' \<noteq> C' \<Longrightarrow> col P Q R\<close>
        \<open>A' = B' \<Longrightarrow> col P Q R\<close> \<open>A' = C' \<Longrightarrow> col P Q R\<close> \<open>B = B' \<Longrightarrow> col P Q R\<close> \<open>B = C \<Longrightarrow> col P Q R\<close>
        \<open>B' = C' \<Longrightarrow> col P Q R\<close> \<open>C = C' \<Longrightarrow> col P Q R\<close>
      by blast
  qed
  have "col P Q R" if "distinct6 A B C A' B' C'" and "col A B C" and "col A' B' C'"
    and "is_a_intersec P A B' A' B" and "is_a_intersec Q B C' B' C" and "is_a_intersec R A C' A' C"
  proof -
    have "col P Q R" if "line A B' = line A' B"
      using \<open>col A B C\<close> \<open>col A' B' C'\<close> \<open>distinct6 A B C A' B' C'\<close> \<open>is_a_intersec P A B' A' B\<close>
        \<open>is_a_intersec Q B C' B' C\<close> \<open>is_a_intersec R A C' A' C\<close> degenerate_hexagon_is_pappus that
      by blast
    have "col P Q R" if "line B C' = line B' C"
      using \<open>col A B C\<close> \<open>col A' B' C'\<close> \<open>distinct6 A B C A' B' C'\<close> \<open>is_a_intersec P A B' A' B\<close>
        \<open>is_a_intersec Q B C' B' C\<close> \<open>is_a_intersec R A C' A' C\<close> degenerate_hexagon_is_pappus that
      by blast
    have "col P Q R" if "line A' C = line A C'"
      using \<open>col A B C\<close> \<open>col A' B' C'\<close> \<open>distinct6 A B C A' B' C'\<close> \<open>is_a_intersec P A B' A' B\<close>
        \<open>is_a_intersec Q B C' B' C\<close> \<open>is_a_intersec R A C' A' C\<close> degenerate_hexagon_is_pappus that
      by auto
    have "col P Q R" if "line A B' \<noteq> line A' B" and "line B C' \<noteq> line B' C" and
      "line A C' \<noteq> line A' C"
    proof -
      have "is_a_proper_intersec P A B' A' B"
        using \<open>distinct6 A B C A' B' C'\<close> \<open>is_a_intersec P A B' A' B\<close> distinct6_def is_a_intersec_def
          is_a_proper_intersec_def that(1)
        by auto
      have "is_a_proper_intersec Q B C' B' C"
        using \<open>distinct6 A B C A' B' C'\<close> \<open>is_a_intersec Q B C' B' C\<close> distinct6_def is_a_intersec_def
          is_a_proper_intersec_def that(2)
        by auto
      have "is_a_proper_intersec R A C' A' C"
        using \<open>distinct6 A B C A' B' C'\<close> \<open>is_a_intersec R A C' A' C\<close> distinct6_def is_a_intersec_def
          is_a_proper_intersec_def that(3)
        by auto
      show "col P Q R"
        using \<open>col A B C\<close> \<open>col A' B' C'\<close> \<open>distinct6 A B C A' B' C'\<close> \<open>is_a_proper_intersec P A B' A' B\<close>
          \<open>is_a_proper_intersec Q B C' B' C\<close> \<open>is_a_proper_intersec R A C' A' C\<close> assms is_pappus1_def
        by blast
    qed
    show "col P Q R"
      using \<open>\<lbrakk>line A B' \<noteq> line A' B; line B C' \<noteq> line B' C; line A C' \<noteq> line A' C\<rbrakk> \<Longrightarrow> col P Q R\<close>
        \<open>line A B' = line A' B \<Longrightarrow> col P Q R\<close> \<open>line A' C = line A C' \<Longrightarrow> col P Q R\<close>
        \<open>line B C' = line B' C \<Longrightarrow> col P Q R\<close>
      by fastforce
  qed
  show "is_pappus2 A B C A' B' C' P Q R"
    by (simp add: \<open>\<lbrakk>A \<noteq> B' \<and> A' \<noteq> B \<and> line A B' \<noteq> line A' B \<and> B \<noteq> C' \<and> B' \<noteq> C \<and> line B C' \<noteq> line B' C
      \<and> A \<noteq> C' \<and> A' \<noteq> C \<and> line A C' \<noteq> line A' C; col A B C; col A' B' C'; is_a_intersec P A B' A' B; is_a_intersec Q B C' B' C; is_a_intersec R A C' A' C\<rbrakk> \<Longrightarrow> col P Q R\<close>
        \<open>\<lbrakk>distinct6 A B C A' B' C'; col A B C; col A' B' C'; is_a_intersec P A B' A' B; is_a_intersec Q B C' B' C; is_a_intersec R A C' A' C\<rbrakk> \<Longrightarrow> col P Q R\<close>
        is_pappus2_def)
qed

lemma pappus_equiv: "is_pappus1 A B C A' B' C' P Q R = is_pappus2 A B C A' B' C' P Q R"
  using pappus12 pappus21
  by blast

(* Finally, we give Pappus's property for a plane stating that the diagonal points
of any hexagon of that plane, whose vertices lie alternately on two lines, are collinear *)

definition is_pappus :: "bool" where
"is_pappus \<equiv> \<forall>A B C D E F P Q R. is_pappus2 A B C D E F P Q R"

end


subsection \<open>IMO 2018 SL - C4\<close>

theory IMO_2018_SL_C4_sol
  imports Main "HOL-Library.Permutation"
begin

definition antipascal :: "(nat \<Rightarrow> nat \<Rightarrow> int) \<Rightarrow> nat \<Rightarrow> bool" where
   "antipascal f n \<longleftrightarrow> (\<forall> r < n. \<forall> c \<le> r. f r c = abs (f (r+1) c - f (r+1) (c+1)))"

definition triangle :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> (nat \<times> nat) set" where
  "triangle r0 c0 n = {(r, c) | r c :: nat. r0 \<le> r \<and> r < r0 + n \<and> c0 \<le> c \<and> c \<le> c0 + r - r0}"

lemma triangle_finite [simp]:
  shows "finite (triangle r0 c0 n)"
proof-
    have "triangle r0 c0 n \<subseteq> {0..<r0 + n} \<times> {0..<c0 + n}"
      unfolding triangle_def
      by auto
    then show ?thesis
      using finite_atLeastLessThan infinite_super
      by blast
qed

lemma triangle_card:
  shows "card (triangle r0 c0 n) = n * (n+1) div 2"
proof (induction n arbitrary: r0 c0)
  case 0
  have *: "{(i, j). r0 \<le> i \<and> i < r0 \<and> c0 \<le> j \<and> j \<le> c0 + i - r0} = {}"
    by auto
  then show ?case
    using 0
    unfolding triangle_def
    by (simp add: *)
next
  case (Suc n)
  let ?row = "{(r0 + n, j) | j. c0 \<le> j \<and> j < c0 + Suc n}"
  have "triangle r0 c0 (Suc n) = triangle r0 c0 n \<union> ?row"
    unfolding triangle_def
    by auto
  moreover
  have "triangle r0 c0 n \<inter> ?row = {}"
    unfolding triangle_def
    by auto
  ultimately
  have "card (triangle r0 c0 (Suc n)) = card (triangle r0 c0 n) + card ?row"
    by (simp add: card_Un_disjoint)
  moreover
  have "card ?row = Suc n"
  proof-
    have "?row = (\<lambda> j. (r0 + n, j)) ` {c0..<c0 + Suc n}"
      by auto
    moreover
    have "inj_on (\<lambda> j. (r0 + n, j)) {c0..<c0 + Suc n}"
      unfolding inj_on_def
      by auto
    then have "card ((\<lambda> j. (r0 + n, j)) ` {c0..<c0 + Suc n}) = card {c0..<c0 + Suc n}"
      using card_image
      by blast
    then have "card ((\<lambda> j. (r0 + n, j)) ` {c0..<c0 + Suc n}) = Suc n"
      by auto
    ultimately
    show ?thesis
      by simp
  qed
  ultimately
  have "card (triangle r0 c0 (Suc n)) = (n * (n + 1)) div 2 + Suc n"
    using Suc
    by simp
  then show ?case
    by auto
qed

fun uncurry where
   "uncurry f (a, b) = f a b"

lemma gauss:
  fixes n :: nat
  shows "sum_list [1..<n] = n * (n - 1) div 2"
proof (induction n)
  case 0
  then show ?case by simp
next
  case (Suc n)
  have "sum_list [1..<Suc n] = sum_list [1..<n] + n"
    by simp
  also have "... = n * (n - 1) div 2 + n"
    using Suc
    by simp
  finally
  show ?case
    by (metis Sum_Ico_nat diff_self_eq_0 distinct_sum_list_conv_Sum distinct_upt minus_nat.diff_0 mult_eq_0_iff set_upt)
qed

lemma sum_list_insort [simp]:
  fixes x :: nat and xs :: "nat list"
  shows "sum_list (insort x xs) = x + sum_list xs"
  by (induction xs, auto)

lemma sum_list_sort [simp]:
  fixes xs :: "nat list"
  shows "sum_list (sort xs) = sum_list xs"
  by (induction xs, auto)

lemma sorted_distinct_strict_increase:
  assumes "sorted (xs @ [x])" "distinct (xs @ [x])" "\<forall> x \<in> set (xs @ [x]). x > a"
  shows "x > a + length xs"
  using assms
proof (induction xs arbitrary: x rule: rev_induct)
  case Nil
  then show ?case
    by simp
next
  case (snoc x' xs)
  show ?case
    using snoc(1)[of x'] snoc(2-)
    by (auto simp add: sorted_append)
qed

lemma sum_list_sorted_distinct_lb:
  assumes "\<forall> x \<in> set xs. x > a" "distinct xs" "sorted xs"
  shows "sum_list xs \<ge> length xs * (2 * a + length xs + 1) div 2"
  using assms
proof (induction xs rule: rev_induct)
  case Nil
  then show ?case
    by simp
next
  case (snoc x xs)
  have "x > a + length xs"
    using sorted_distinct_strict_increase[of xs x a]
    using snoc(2-)
    by auto
  moreover
  have "length xs * (2 * a + length xs + 1) div 2 \<le> sum_list xs"
    using snoc
    by (auto simp add: sorted_append)
  ultimately
  show ?case
    by auto
qed

lemma sum_list_distinct_lb:
  assumes "\<forall> x \<in> set xs. f x > a" "distinct (map f xs)"
  shows "(\<Sum> x \<leftarrow> xs. f x) \<ge> length xs * (2 * a + length xs + 1) div 2"
  using assms
  using sum_list_sorted_distinct_lb[of "sort (map f xs)" a]
  by simp

lemma consecutive_nats_sorted:
  assumes "sorted xs" "length xs = n" "distinct xs" "sum_list xs \<le> n * (n + 1) div 2" "\<forall> x \<in> set xs. x > 0"
  shows "xs = [1..<n+1]"
  using assms
proof (induction xs arbitrary: n rule: rev_induct)
  case Nil
  then show ?case
    by simp
next
  case (snoc x xs)
  have "n > 0"
    using \<open>length (xs @ [x]) = n\<close>
    by simp
  have "xs = [1..<(n-1)+1]"
  proof (rule snoc(1))
    show "sorted xs" "length xs = n-1" "distinct xs" "\<forall>a\<in>set xs. 0 < a"
      using snoc(2-6)
      by (auto simp add: sorted_append)
    show "sum_list xs \<le> (n - 1) * (n - 1 + 1) div 2"
    proof-
      have "x \<ge> n"
        using snoc(2-4) snoc(6)
      proof (induction xs arbitrary: x n rule: rev_induct)
        case Nil
        then show ?case
          by simp
      next
        case (snoc x' xs')
        have "n-1 \<le> x'"
          using snoc(1)[of x' "n-1"] snoc(2-)
          by (simp add: sorted_append)
        moreover
        have "x > x'"
          using snoc(2) snoc(4)
          by (simp add: sorted_append)
        ultimately
        show ?case
          by simp
      qed
      show ?thesis
      proof-
        have "sum_list xs \<le> n * (n + 1) div 2 - x"
          using snoc(5)
          by simp
        also have "... \<le> n * (n + 1) div 2 - n"
          using \<open>n \<le> x\<close>
          by simp
        also have "... = n * (n - 1) div 2"
          by (simp add: diff_mult_distrib2)
        finally
        show ?thesis
          using \<open>n > 0\<close>
          by (auto simp add: mult.commute)
      qed
    qed
  qed
  then have "xs = [1..<n]"
    using \<open>n > 0\<close>
    by simp
  then have "x \<ge> n"
    using snoc(2) snoc(4) snoc(6)
    by (auto simp add: sorted_append)
  have "x = n"
  proof (rule ccontr)
    assume "\<not> ?thesis"
    then have "x > n"
      using \<open>x \<ge> n\<close>
      by simp
    then have "sum_list (xs @ [x]) > n * (n - 1) div 2 + n"
      using \<open>xs = [1..<n]\<close> gauss[of n]
      by simp
    then show False
      using snoc(5)
      by (smt Suc_diff_1 \<open>0 < n\<close> add.commute add_Suc_right distrib_left div_mult_self2 less_le_trans mult_2 mult_2_right nat_neq_iff one_add_one plus_1_eq_Suc zero_neq_numeral)
  qed
  then show ?case
    using \<open>xs = [1..<n]\<close>
    by (simp add: Suc_leI \<open>0 < n\<close>)
qed

lemma consecutive_nats:
  assumes "length xs = n" "distinct xs" "sum_list xs \<le> n * (n + 1) div 2" "\<forall> x \<in> set xs. x > 0"
  shows "set xs = {1..<n+1}"
proof-
  have "sort xs = [1..<n+1]"
    using consecutive_nats_sorted[of "sort xs" n] assms
    by simp
  then show ?thesis
    by (metis set_sort set_upt)
qed

lemma sum_list_cong:
  assumes "\<forall> x \<in> set xs. f x = g x"
  shows "(\<Sum> x \<leftarrow> xs. f x) = (\<Sum> x \<leftarrow> xs. g x)"
  using assms
  by (induction xs, auto)

lemma sum_list_last:
  assumes "a \<le> b"
  shows "(\<Sum> x \<leftarrow> [a..<b+1]. f x) = (\<Sum> x \<leftarrow> [a..<b]. f x) + f b"
proof-
  have *: "[a..<b+1] = [a..<b] @ [b]"
    using assms
    by auto
  show ?thesis
    by (subst *, simp)
qed

lemma sum_list_nat:
  assumes "\<forall> x \<in> set xs. f x \<ge> 0"
  shows "(\<Sum> x \<leftarrow> xs. nat (f x)) = (nat (\<Sum> x \<leftarrow> xs. f x))"
  using assms
proof (induction xs)
  case Nil
  then show ?case
    by simp
next
  case (Cons x xs)
  then show ?case
    using sum_list_mono
    by fastforce
qed

theorem IMO2018SL_C4:
  "\<nexists> f. antipascal f 2018 \<and>
   (uncurry f) ` triangle 0 0 2018  = {1..<2018*(2018 + 1) div 2 + 1}"
proof (rule ccontr)
  assume "\<not> ?thesis"
  then obtain f where
   f: "antipascal f 2018" "(uncurry f) ` triangle 0 0 2018 = {1..<2018*(2018 + 1) div 2+1}"
    by auto

  have "inj_on (uncurry f) (triangle 0 0 2018)"
  proof (rule eq_card_imp_inj_on)
    show "finite (triangle 0 0 2018)"
      by simp
  next
    show "card ((uncurry f) ` triangle 0 0 2018) = card (triangle 0 0 2018)"
      using f(2) triangle_card
      by simp
  qed

  have path: "\<forall> r0 < 2018. \<forall> c0 \<le> r0. \<forall> n. r0 + n \<le> 2018 \<longrightarrow> (\<exists> a b. a r0 = c0 \<and> b r0 = c0 \<and>
                    (\<forall> r. r0 < r \<and> r < r0 + n \<longrightarrow>
                         a r \<noteq> b r \<and> c0 \<le> a r \<and> a r \<le> c0 + (r - r0) \<and> c0 \<le> b r \<and> b r \<le> c0 + (r - r0) \<and>
                         (a r = b (r - 1) \<or> a r = b (r - 1) + 1) \<and>
                         (b r = b (r - 1) \<or> b r = b (r - 1) + 1)) \<and>
                    (\<forall> r. r0 \<le> r \<and> r < r0 + n \<longrightarrow> f r (b r) = (\<Sum> r' \<leftarrow> [r0..<r+1]. f r' (a r'))))" (is "\<forall> r0 < 2018. \<forall> c0 \<le> r0. \<forall> n. r0 + n \<le> 2018 \<longrightarrow> ?P r0 c0 n")
  proof safe
    fix r0 c0 n :: nat
    assume "r0 < 2018" "c0 \<le> r0" "r0 + n \<le> 2018"
    then show "?P r0 c0 n"
    proof (induction n)
      case 0
      then show ?case
        by auto
    next
      case (Suc n)

      show ?case
      proof (cases "n = 0")
        case True
        then show ?thesis
          by auto
      next
        case False
        show ?thesis
        proof-
          obtain a b where *:
            "a r0 = c0" "b r0 = c0"
            "\<forall>r. r0 < r \<and> r < r0 + n \<longrightarrow>
                   a r \<noteq> b r \<and>
                   c0 \<le> a r \<and> a r \<le> c0 + (r - r0) \<and>
                   c0 \<le> b r \<and> b r \<le> c0 + (r - r0) \<and>
                   (a r = b (r - 1) \<or> a r = b (r - 1) + 1) \<and>
                   (b r = b (r - 1) \<or> b r = b (r - 1) + 1)"
            "\<forall>r. r0 \<le> r \<and> r < r0 + n \<longrightarrow> f r (b r) = (\<Sum>r'\<leftarrow>[r0..<r + 1]. f r' (a r'))"
            using Suc
            by auto

          have ap': "\<forall>r c. r0 \<le> r \<and> r \<le> r0 + n \<and> c0 \<le> c \<and> c < c0 + (r - r0) \<longrightarrow> f (r - 1) c = \<bar>f r c - f r (c + 1)\<bar>"
            using \<open>antipascal f 2018\<close> \<open>n \<noteq> 0\<close> Suc(3-4)
            unfolding antipascal_def
            by auto
          have ap: "f (r0 + n - 1) (b (r0 + n - 1)) = \<bar>f (r0 + n) (b (r0 + n - 1)) - f (r0 + n) (b (r0 + n - 1) + 1)\<bar>"
          proof (cases "n = 1")
            case True
            then show ?thesis
              using *(2) ap'[rule_format, of "r0 + 1"]
              by simp
          next
            case False
            then have "n > 1"
              using \<open>n \<noteq> 0\<close>
              by simp
            show ?thesis
            proof (subst ap')
              have "r0 < r0 + n - 1"
                using \<open>n > 1\<close>
                by simp
              then have "b (r0 + n - Suc 0) \<le> c0 + n - Suc 0"
                using *(3)[rule_format, of "r0 + n - 1"] \<open>n > 1\<close>
                by simp
              then show "r0 \<le> r0 + n \<and> r0 + n \<le> r0 + n \<and> c0 \<le> b (r0 + n - 1) \<and> b (r0 + n - 1) < c0 + (r0 + n - r0)"
                using *(3)[rule_format, of "r0 + n - 1"] \<open>n > 1\<close>
                by simp
            qed simp
          qed

          let ?an = "if f (r0 + n) (b (r0 + n - 1)) < f (r0 + n) (b (r0 + n - 1) + 1) then b (r0 + n - 1) else b (r0 + n - 1) + 1"
          let ?bn = "if f (r0 + n) (b (r0 + n - 1)) < f (r0 + n) (b (r0 + n - 1) + 1) then b (r0 + n - 1) + 1 else b (r0 + n - 1)"
          let ?a = "a (r0 + n := ?an)"
          let ?b = "b (r0 + n := ?bn)"

          have "?a r0 = c0" "?b r0 = c0"
            using \<open>n \<noteq> 0\<close> \<open>a r0 = c0\<close> \<open>b r0 = c0\<close>
            by simp_all

          moreover

          have "\<forall>r. r0 \<le> r \<and> r < r0 + Suc n \<longrightarrow> f r (?b r) = (\<Sum> r' \<leftarrow> [r0..<r+1]. f r' (?a r'))"
          proof safe
            fix r
            assume "r0 \<le> r" "r < r0 + Suc n"
            show "f r (?b r) = (\<Sum> r' \<leftarrow> [r0..<r+1]. f r' (?a r'))"
            proof (cases "r < r0 + n")
              case True
              then have "f r (?b r) = (\<Sum> r' \<leftarrow> [r0..<r+1]. f r' (a r'))"
                using *(4) \<open>r0 \<le> r\<close>
                by simp
              also have "... = (\<Sum> r' \<leftarrow> [r0..<r+1]. f r' (?a r'))"
              proof (rule sum_list_cong, safe)
                fix r'
                assume "r' \<in> set [r0..<r + 1]"
                then show "f r' (a r') = f r' (?a r')"
                  using True \<open>r0 \<le> r\<close>
                  by auto
              qed
              finally show ?thesis
                by simp
            next
              case False
              then have "r = r0 + n"
                using \<open>r < r0 + Suc n\<close>
                by simp
              show ?thesis
              proof (cases "f (r0 + n) (b (r0 + n - 1)) < f (r0 + n) (b (r0 + n - 1) + 1)")
                case True
                have "f (r0 + n) (b (r0 + n - 1) + 1) = f (r0 + n - 1) (b (r0 + n - 1)) + f (r0 + n) (b (r0 + n - 1))"
                  using True ap
                  by simp
                then have "f (r0 + n) (b (r0 + n - 1) + 1) = ((\<Sum>r'\<leftarrow>[r0..<r0 + n]. f r' (a r'))) + f (r0 + n) (b (r0 + n - 1))"
                  using *(4) \<open>n \<noteq> 0\<close>
                  by simp
                also have "... = (\<Sum>r'\<leftarrow>[r0..<r0 + n]. f r' (if r' = r0 + n then b (r0 + n - 1) else (a r'))) + f (r0 + n) (if r0 + n = r0 + n then b (r0 + n - 1) else (a (r0 + n)))"
                proof-
                  have "(\<Sum>r'\<leftarrow>[r0..<r0 + n]. f r' (a r')) = (\<Sum>r'\<leftarrow>[r0..<r0 + n]. f r' (if r' = r0 + n then b (r0 + n - 1) else (a r')))"
                    by (rule sum_list_cong, simp)
                  then show ?thesis
                    by simp
                qed
                also have "... = (\<Sum>r'\<leftarrow>[r0..<r0 + n + 1]. f r' (if r' = r0 + n then b (r0 + n - 1) else (a r')))"
                  by (subst sum_list_last, simp_all)
                finally show ?thesis
                  using True \<open>r = r0 + n\<close>
                  by simp (metis One_nat_def)
              next
                case False
                then have "f (r0 + n) (b (r0 + n - 1)) = f (r0 + n - 1) (b (r0 + n - 1)) + f (r0 + n) (b (r0 + n - 1) + 1)"
                  using ap
                  by simp
                then have "f (r0 + n) (b (r0 + n - 1)) = ((\<Sum>r'\<leftarrow>[r0..<r0 + n]. f r' (a r'))) + f (r0 + n) (b (r0 + n - 1) + 1)"
                  using *(4) \<open>n \<noteq> 0\<close>
                  by simp
                also have "... = (\<Sum>r'\<leftarrow>[r0..<r0 + n]. f r' (if r' = r0 + n then b (r0 + n - 1) + 1 else (a r'))) + f (r0 + n) (if r0 + n = r0 + n then b (r0 + n - 1) + 1 else (a (r0 + n)))"
                proof-
                  have "(\<Sum>r'\<leftarrow>[r0..<r0 + n]. f r' (a r')) = (\<Sum>r'\<leftarrow>[r0..<r0 + n]. f r' (if r' = r0 + n then b (r0 + n - 1) + 1 else (a r')))"
                    by (rule sum_list_cong, simp)
                  then show ?thesis
                    by simp
                qed
                also have "... = (\<Sum>r'\<leftarrow>[r0..<r0 + n + 1]. f r' (if r' = r0 + n then b (r0 + n - 1) + 1 else (a r')))"
                  by (subst sum_list_last, simp_all)
                finally
                show ?thesis
                  using False \<open>r = r0 + n\<close>
                  by simp (metis One_nat_def Suc_eq_plus1)
              qed
            qed
          qed

          moreover

          have "\<forall>r. r0 < r \<and> r < r0 + Suc n \<longrightarrow>
                    ?a r \<noteq> ?b r \<and>
                    c0 \<le> ?a r \<and> ?a r \<le> c0 + (r - r0) \<and>
                    c0 \<le> ?b r \<and> ?b r \<le> c0 + (r - r0) \<and>
                    (?a r = ?b (r - 1) \<or> ?a r = ?b (r - 1) + 1) \<and>
                    (?b r = ?b (r - 1) \<or> ?b r = ?b (r - 1) + 1)"
          proof safe
            fix r
            assume "r0 < r" "r < r0 + Suc n" "?a r = ?b r"
            then show False
              using *
              by (simp split: if_split_asm)
          next
            fix r
            assume "r0 < r" "r < r0 + Suc n"
            show "c0 \<le> ?a r"
            proof (cases "r < r0 + n")
              case True
              then show ?thesis
                using * \<open>r0 < r\<close>
                by auto
            next
              case False
              then have "r = r0 + n"
                using \<open>r < r0 + Suc n\<close>
                by simp
              then show ?thesis
                using *(2) *(3)[rule_format, of "r0 + n - 1"]
                by (smt Suc_diff_1 Suc_eq_plus1 Suc_leD Suc_le_mono \<open>r0 < r\<close> add_gr_0 diff_less fun_upd_same less_antisym less_or_eq_imp_le zero_less_one)
            qed
          next
            fix r
            assume "r0 < r" "r < r0 + Suc n"
            show "?a r \<le> c0 + (r - r0)"
            proof (cases "r < r0 + n")
              case True
              then show ?thesis
                using * \<open>r0 < r\<close>
                by auto
            next
              case False
              then have "r = r0 + n"
                using \<open>r < r0 + Suc n\<close>
                by simp
              then show ?thesis
                using *(2) *(3)[rule_format, of "r0 + n - 1"]
                by (smt Suc_diff_Suc \<open>r0 < r\<close> add_Suc_right add_diff_cancel_left' add_diff_cancel_right' fun_upd_same le_Suc_eq less_Suc_eq less_or_eq_imp_le nat_add_left_cancel_le plus_1_eq_Suc)
            qed
          next
            fix r
            assume "r0 < r" "r < r0 + Suc n"
            show "c0 \<le> ?b r"
            proof (cases "r < r0 + n")
              case True
              then show ?thesis
                using * \<open>r0 < r\<close>
                by auto
            next
              case False
              then have "r = r0 + n"
                using \<open>r < r0 + Suc n\<close>
                by simp
              then show ?thesis
                using *(2) *(3)[rule_format, of "r0 + n - 1"]
                by (smt Suc_diff_1 Suc_eq_plus1 Suc_leD Suc_le_mono \<open>r0 < r\<close> add_gr_0 diff_less fun_upd_same less_antisym less_or_eq_imp_le zero_less_one)
            qed
          next
            fix r
            assume "r0 < r" "r < r0 + Suc n"
            show "?b r \<le> c0 + (r - r0)"
            proof (cases "r < r0 + n")
              case True
              then show ?thesis
                using * \<open>r0 < r\<close>
                by auto
            next
              case False
              then have "r = r0 + n"
                using \<open>r < r0 + Suc n\<close>
                by simp
              then show ?thesis
                using *(2) *(3)[rule_format, of "r0 + n - 1"]
                by (smt Suc_diff_Suc \<open>r0 < r\<close> add_Suc_right add_diff_cancel_left' add_diff_cancel_right' fun_upd_same le_Suc_eq less_Suc_eq less_or_eq_imp_le nat_add_left_cancel_le plus_1_eq_Suc)
            qed
          next
            fix r
            assume "r0 < r" "r < r0 + Suc n"
                   "?a r \<noteq> ?b (r - 1) + 1"
            then show "?a r = ?b (r - 1)"
              using *
              by (auto split: if_split_asm)
          next
            fix r
            assume "r0 < r" "r < r0 + Suc n"
                   "?b r \<noteq> ?b (r - 1) + 1"
            then show "?b r = ?b (r - 1)"
              using *
              by (auto split: if_split_asm)
          qed
          ultimately
          show ?thesis
            by blast
        qed
      qed
    qed
  qed

  obtain a b where *:
    "a 0 = 0" "b 0 = 0"
    "\<forall>r. 0 < r \<and> r < 2018 \<longrightarrow> a r \<noteq> b r"
    "\<forall>r. 0 < r \<and> r < 2018 \<longrightarrow> a r \<le> r"
    "\<forall>r. 0 < r \<and> r < 2018 \<longrightarrow> b r \<le> r"
    "\<forall>r. 0 < r \<and> r < 2018 \<longrightarrow> a r = b (r - 1) \<or> a r = b (r - 1) + 1"
    "\<forall>r. 0 < r \<and> r < 2018 \<longrightarrow> b r = b (r - 1) \<or> b r = b (r - 1) + 1"
    "\<forall>r<2018. f r (b r) = (\<Sum>r' \<leftarrow> [0..<r+1]. f r' (a r'))"
    using path[rule_format, of 0 0 2018]
    by auto

  have ab: "\<forall>r < 2018. a r = b r + 1 \<or> a r = b r - 1"
    using *(1-3) *(6-7)
    by (metis Suc_eq_plus1 diff_add_inverse diff_is_0_eq' le0 neq0_conv plus_1_eq_Suc)

  have max_max: "\<forall>r. 0 < r \<and> r < 2018 \<longrightarrow> max (a (r - 1)) (b (r - 1)) \<le> max (a r) (b r)"
  proof safe
    fix r :: nat
    assume r: "0 < r" "r < 2018"
    show "max (a (r - 1)) (b (r - 1)) \<le> max (a r) (b r)"
    proof (cases "r = 1")
      case True
      then show ?thesis
        using \<open>a 0 = 0\<close> \<open>b 0 = 0\<close>
        by simp
    next
      case False
      then have "a r = b (r - 1) \<or> a r = b (r - 1) + 1"
                "b r = b (r - 1) \<or> b r = b (r - 1) + 1"
                "a r \<noteq> b r" "a (r - 1) \<noteq> b (r - 1)"
        using r *
        by simp_all
      moreover
      have "a (r - 1) = b (r - 1) \<or> a (r - 1) = b (r - 1) + 1 \<or> a (r - 1) = b (r - 1) - 1"
        using ab[rule_format, of "r-1"] r False
        by auto
      ultimately
      show ?thesis
        by (smt diff_le_self eq_iff le_add1 max.commute max.mono)
    qed
  qed

  have min_min: "\<forall>r. 0 < r \<and> r < 2018 \<longrightarrow> min (a (r - 1)) (b (r - 1)) \<ge> min (a r) (b r) - 1"
    using "*"(2) "*"(3) "*"(6) "*"(7)
    by (smt One_nat_def Suc_diff_Suc Suc_leD cancel_comm_monoid_add_class.diff_cancel diff_zero le_0_eq le_diff_conv less_Suc_eq min.cobounded1 min_def nat_less_le)

  let ?fa = "map (\<lambda> r. f r (a r)) [0..<2018]"

  have "inj_on (\<lambda> r. f r (a r)) (set [0..<2018])"
    unfolding inj_on_def
  proof safe
    fix r1 r2
    assume "r1 \<in> set [0..<2018]" "r2 \<in> set [0..<2018]"
      "f r1 (a r1) = f r2 (a r2)"
    have "(r1, a r1) \<in> triangle 0 0 2018" "(r2, a r2) \<in> triangle 0 0 2018"
      using \<open>r1 \<in> set [0..<2018]\<close> \<open>r2 \<in> set [0..<2018]\<close> *(4) *(1)
      using le_eq_less_or_eq triangle_def
      by auto
    moreover
    have "f r1 (a r1) = (uncurry f) (r1, a r1)"  "f r2 (a r2) = (uncurry f) (r2, a r2)"
      by auto
    ultimately
    show "r1 = r2"
      using \<open>inj_on (uncurry f) (triangle 0 0 2018)\<close> \<open>f r1 (a r1) = f r2 (a r2)\<close>
      by (metis inj_onD prod.inject)
  qed

  have "distinct ?fa"
    using \<open>inj_on (\<lambda> r. f r (a r)) (set [0..<2018])\<close>
    by (simp add: distinct_map)

  have "\<forall> x \<in> set ?fa. x > 0"
  proof safe
    fix x
    assume "x \<in> set ?fa"
    then obtain r where "r < 2018" "x = f r (a r)"
      by auto

    have "(r, a r) \<in> triangle 0 0 2018"
      using *(4) *(1) \<open>r < 2018\<close>
      by (cases "r = 0", auto simp add: triangle_def)
    moreover
    have "(uncurry f) (r, a r) = f r (a r)"
      by auto
    ultimately
    have "f r (a r) \<in> (uncurry f) ` triangle 0 0 2018"
      by (metis rev_image_eqI)
    then show "x > 0"
      using f(2) \<open>x = f r (a r)\<close>
      by auto
  qed

  have "set (map nat ?fa) = {1..<2018+1}"
  proof (rule consecutive_nats)
    show "length (map nat ?fa) = 2018"
      by simp
  next
    show "distinct (map nat ?fa)"
    proof (subst distinct_map, safe)
      show "distinct (map (\<lambda>r. f r (a r)) [0..<2018])"
        by fact
    next
      show "inj_on nat (set ?fa)"
        using \<open>\<forall> x \<in> set ?fa. x > 0\<close> inj_on_def
        by force
    qed
  next
    show "\<forall> x \<in> set (map nat ?fa). x > 0"
      using \<open>\<forall> x \<in> set ?fa. x > 0\<close>
      by simp
  next
    show "sum_list (map nat ?fa) \<le> 2018 * (2018 + 1) div 2"
    proof-
      have "(\<Sum> x \<leftarrow> ?fa. x) \<in> (uncurry f) ` (triangle 0 0 2018)"
      proof-
        have "(\<Sum> x \<leftarrow> ?fa. x) = f 2017 (b 2017)"
          using *(8)[rule_format, of 2017]
          by simp
        moreover
        have "(2017, b 2017) \<in> triangle 0 0 2018"
          using *(5)
          unfolding triangle_def
          by simp
        moreover
        have "(uncurry f) (2017, b 2017) = f 2017 (b 2017)"
          by simp
        ultimately
        show ?thesis
          by force
      qed
      then have "(\<Sum> x \<leftarrow> ?fa. x) \<le> 2018*(2018 + 1) div 2"
        using f(2)
        by auto
      moreover
      have "\<forall>x\<in>{0..<2018}. 0 \<le> f x (a x)"
        by (simp add: \<open>\<forall>x\<in>set (map (\<lambda>r. f r (a r)) [0..<2018]). 0 < x\<close> le_less)
      ultimately
      show ?thesis
        using sum_list_nat[of "[0..<2018]" "(\<lambda>r. f r (a r))"]
        by (simp add: comp_def)
    qed
  qed

  have "?fa <~~> map int [1..<2018+1]"
  proof-
    have "set ?fa = set (map int [1..<2018+1])"
    proof (subst inj_on_Un_image_eq_iff[symmetric])
      show "nat ` set ?fa = nat ` set (map int [1..<2018+1])"
      proof-
        have "set (map nat ?fa) = nat ` set ?fa"
          by auto
        moreover
        have "nat ` set (map int [1..<2018+1]) = {1..<2018+1}"
          by (metis (no_types, hide_lams) atLeastLessThan_upt map_idI map_map nat_int o_apply set_map)
        ultimately
        show ?thesis
          using \<open>set (map nat ?fa) = {1..<2018+1}\<close>
          by simp
      qed
    next
      show "inj_on nat (set ?fa \<union> set (map int [1..<2018 + 1]))"
      proof-
        have "set ?fa \<union> set (map int [1..<2018 + 1]) \<subseteq> {x::int. x > 0}"
          using \<open>\<forall> x \<in> set ?fa. x > 0\<close>
          by auto
        moreover
        have "inj_on nat {x::int. x > 0}"
          by (metis inj_on_inverseI mem_Collect_eq nat_int zero_less_imp_eq_int)
        ultimately
        show ?thesis
          by (smt inj_onD inj_onI subsetD)
      qed
    qed

    then have "mset ?fa = mset (map int [1..<2018+1])"
    proof (subst set_eq_iff_mset_eq_distinct[symmetric])
      show "distinct ?fa"
        by fact
    next
      show "distinct (map int [1..<2018+1])"
        by (simp add: distinct_map)
    qed simp

    then show ?thesis
      using mset_eq_perm
      by blast
  qed

  let ?l = "min (a 2017) (b 2017)"
  let ?r = "max (a 2017) (b 2017)"
  let ?r0l = "2018 - ?l" and ?c0l = 0 and ?nl = "?l"
  let ?r0r = "?r + 1" and ?c0r = "?r + 1" and ?nr = "2017 - ?r"

  {
    fix r0 c0 n
    assume "triangle r0 c0 n \<subseteq> triangle 0 0 2018"
    assume "\<forall> r < 2018. (r, a r) \<notin> triangle r0 c0 n"
    assume "n \<ge> 1008"
    assume "c0 \<le> r0" "r0 + n \<le> 2018"

    have "\<forall> p \<in> triangle r0 c0 n. (uncurry f) p > 2018"
    proof (rule ccontr)
      assume "\<not> ?thesis"
      then obtain r c where "(r, c) \<in> triangle r0 c0 n" "f r c \<le> 2018"
        by auto
      moreover
      have "(r, c) \<in> triangle 0 0 2018"
        using \<open>triangle r0 c0 n \<subseteq> triangle 0 0 2018\<close> \<open>(r, c) \<in> triangle r0 c0 n\<close>
        by auto
      then have "f r c \<ge> 1"
        using \<open>(uncurry f) ` (triangle 0 0 2018) = {1..<2018*(2018 + 1) div 2 + 1}\<close>
        by force
      then have "nat (f r c) \<in> {1..<2018+1}"
        using \<open>f r c \<le> 2018\<close>
        by auto
      then have "f r c \<in> set (map int [1..<2018+1])"
        by (smt \<open>1 \<le> f r c\<close> atLeastLessThan_upt image_eqI int_nat_eq set_map)
      then have "f r c \<in> set ?fa"
        using \<open>?fa <~~> map int [1..<2018+1]\<close>
        using perm_set_eq
        by blast
      then obtain r' where "r' < 2018" "f r' (a r') = f r c"
        by auto
      have "(r', a r') \<in> triangle 0 0 2018"
        using \<open>r' < 2018\<close> *(1) *(4)
        by (cases "r' = 0") (auto simp add: triangle_def)
      then have "r = r'" "c = a r'"
        using \<open>f r' (a r') = f r c\<close> \<open>inj_on (uncurry f) (triangle 0 0 2018)\<close> \<open>(r, c) \<in> triangle 0 0 2018\<close>
        unfolding inj_on_def
        by force+

      then have "(r', a r') \<in> triangle r0 c0 n"
        using \<open>(r, c) \<in> triangle r0 c0 n\<close>
        by simp

      then show False
        using \<open>r' < 2018\<close> \<open>\<forall> r < 2018. (r, a r) \<notin> triangle r0 c0 n\<close>
        by auto
    qed

    obtain ar br where r:
      "ar r0 = c0" "br r0 = c0"
      "\<forall>r. r0 < r \<and> r < r0 + n \<longrightarrow> ar r \<noteq> br r \<and>
                     c0 \<le> ar r \<and> ar r \<le> c0 + (r - r0) \<and>
                     c0 \<le> br r \<and> br r \<le> c0 + (r - r0) \<and>
                     (ar r = br (r - 1) \<or> ar r = (br (r - 1)) + 1) \<and>
                     (br r = br (r - 1) \<or> br r = (br (r - 1)) + 1)"
      "\<forall>r. r0 \<le> r \<and> r < r0 + n \<longrightarrow>
                     f r (br r) =
                     (\<Sum>r'\<leftarrow>[r0..<r+1]. f r' (ar r'))"
      using \<open>r0 + n \<le> 2018\<close> \<open>c0 \<le> r0\<close> \<open>n \<ge> 1008\<close>
      using path[rule_format, of r0 c0 n]
      by auto

    have "\<forall> r. r0 \<le> r \<and> r < r0 + n \<longrightarrow> (r, ar r) \<in> triangle r0 c0 n"
    proof safe
      fix r
      assume "r0 \<le> r" "r < r0 + n"
      then show "(r, ar r) \<in> triangle r0 c0 n"
        using r(1) r(2) r(3)[rule_format, of r]
        unfolding triangle_def
        by (cases "r = r0") auto
    qed
    then have "\<forall> r. r0 \<le> r \<and> r < r0 + n \<longrightarrow> f r (ar r) > 2018"
      using \<open>\<forall> p \<in> triangle r0 c0 n. (uncurry f) p > 2018\<close>
      by force

    have "(r0 + n - 1, br (r0 + n - 1)) \<in> triangle r0 c0 n"
      using r(3)[rule_format, of "r0 + n - 1"]
      using \<open>r0 + n \<le> 2018\<close> \<open>n \<ge> 1008\<close>
      by (simp add: triangle_def)
    then have "(r0 + n - 1, br (r0 + n - 1)) \<in> triangle 0 0 2018"
      using \<open>triangle r0 c0 n \<subseteq> triangle 0 0 2018\<close>
      by blast
    then have "(uncurry f) (r0 + n - 1, br (r0 + n - 1)) \<in> {1..<2018 * (2018 + 1) div 2 + 1}"
      using f(2)
      by blast
    then have "f (r0 + n - 1) (br (r0 + n - 1)) \<le> 2018*(2018+1) div 2"
      by simp

    moreover

    have "f (r0 + n - 1) (br (r0 + n - 1)) = (\<Sum>r'\<leftarrow>[r0..<(r0 + n - 1) + 1]. f r' (ar r'))"
      using r(4)[rule_format, of "r0 + n - 1"]
      using \<open>r0 + n \<le> 2018\<close> \<open>n \<ge> 1008\<close>
      by simp

    ultimately

    have 1: "(\<Sum>r'\<leftarrow>[r0..<(r0 + n - 1) + 1]. f r' (ar r')) \<le> 2018*(2018+1) div 2"
      by simp

    have "length ([r0..< (r0 + n - 1) + 1]) = n"
      using \<open>n \<ge> 1008\<close>
      by auto

    have "n * (2 * 2018 + n + 1) div 2 \<ge> 1008 * (2*2018 + 1008 + 1) div 2 "
    proof-
      have "n * (2 * 2018 + n + 1) \<ge> 1008 * (2*2018 + 1008 + 1)"
        using \<open>n \<ge> 1008\<close>
        by (metis Suc_eq_plus1 add_Suc mult_le_mono nat_add_left_cancel_le)
      then show ?thesis
        using div_le_mono
        by blast
    qed

    moreover

    have "length [r0..<(r0 + n - 1) + 1] * (2 * 2018 + length [r0..<(r0 + n - 1) + 1] + 1) div 2 \<le>
          (\<Sum>r'\<leftarrow>[r0..<(r0 + n - 1) + 1]. nat (f r' (ar r')))"
    proof (rule sum_list_distinct_lb)
      have "\<forall>r'\<in>set [r0..<(r0 + n - 1) + 1]. 2018 < f r' (ar r')"
        using \<open>\<forall> r. r0 \<le> r \<and> r < r0 + n \<longrightarrow> f r (ar r) > 2018\<close> \<open>n \<ge> 1008\<close>
        by simp
      then show "\<forall>r'\<in>set [r0..<(r0 + n - 1)+ 1]. 2018 < nat (f r' (ar r'))"
        by auto
    next
      show "distinct (map (\<lambda>x. nat (f x (ar x))) [r0..<(r0 + n - 1) + 1])"
      proof (subst distinct_map, safe)
        show "inj_on (\<lambda>x. nat (f x (ar x))) (set [r0..<(r0 + n - 1) + 1])"
          unfolding inj_on_def
        proof safe
          fix r1 r2
          assume "r1 \<in> set [r0..<(r0 + n - 1) + 1]" "r2 \<in> set [r0..<(r0 + n - 1) + 1]"
                 "nat (f r1 (ar r1)) = nat (f r2 (ar r2))"
          have "(r1, ar r1) \<in> triangle r0 c0 n" "(r2, ar r2) \<in> triangle r0 c0 n"
            using \<open>r1 \<in> set [r0..<(r0 + n - 1) + 1]\<close> \<open>r2 \<in> set [r0..<(r0 + n - 1) + 1]\<close>
            using \<open>\<forall> r. r0 \<le> r \<and> r < r0 + n \<longrightarrow> (r, ar r) \<in> triangle r0 c0 n\<close>
            using \<open>n \<ge> 1008\<close>
            by force+

          then have "(r1, ar r1) \<in> triangle 0 0 2018" "(r2, ar r2) \<in> triangle 0 0 2018"
            using \<open>triangle r0 c0 n \<subseteq> triangle 0 0 2018\<close>
            by blast+

          moreover

          have "f r1 (a r1) = (uncurry f) (r1, a r1)"  "f r2 (a r2) = (uncurry f) (r2, a r2)"
            by auto

          moreover

          have "f r1 (a r1) = f r2 (a r2)"
            using \<open>(r1, ar r1) \<in> triangle 0 0 2018\<close> \<open>(r2, ar r2) \<in> triangle 0 0 2018\<close>
            using \<open>nat (f r1 (ar r1)) = nat (f r2 (ar r2))\<close>
            using \<open>(r1, ar r1) \<in> triangle r0 c0 n\<close>
            using \<open>\<forall> p \<in> triangle r0 c0 n. 2018 < uncurry f p\<close>
            using \<open>inj_on (uncurry f) (triangle 0 0 2018)\<close>
            by (smt Pair_inject eq_nat_nat_iff inj_on_def nat_0_iff uncurry.simps)

          ultimately

          show "r1 = r2"
            using \<open>inj_on (uncurry f) (triangle 0 0 2018)\<close>
            using \<open>(r1, ar r1) \<in> triangle r0 c0 n\<close>
                  \<open>\<forall>p\<in>triangle r0 c0 n. 2018 < uncurry f p\<close>
                  \<open>nat (f r1 (ar r1)) = nat (f r2 (ar r2))\<close>
            by (smt Pair_inject inj_on_eq_iff int_nat_eq uncurry.simps)
        qed
      qed simp
    qed

    ultimately

    have "(\<Sum>r'\<leftarrow>[r0..<(r0 + n - 1) + 1]. nat (f r' (ar r'))) \<ge> 1008 * (2*2018 + 1008 + 1) div 2"
      using \<open>length ([r0..< (r0 + n - 1) + 1]) = n\<close>
      by simp

    moreover

    have "(\<Sum>r'\<leftarrow>[r0..<(r0 + n - 1) + 1]. nat (f r' (ar r'))) = nat ((\<Sum>r'\<leftarrow>[r0..<(r0 + n - 1) + 1]. f r' (ar r')))"
    proof (rule sum_list_nat)
      show "\<forall>r'\<in>set [r0..<(r0 + n - 1) + 1]. 0 \<le> f r' (ar r')"
        using \<open>\<forall> r. r0 \<le> r \<and> r < r0 + n \<longrightarrow> f r (ar r) > 2018\<close> \<open>n \<ge> 1008\<close>
        by auto
    qed

    ultimately

    have 2: "nat ((\<Sum>r'\<leftarrow>[r0..<(r0 + n - 1) + 1]. f r' (ar r'))) \<ge> 1008 * (2*2018 + 1008 + 1) div 2"
      by simp

    have False
      using 1 2
      by simp
  } note triangle = this

  show False
  proof (cases "?nl \<le> ?nr")
    case True
    show False
    proof (rule triangle)
      show "triangle ?r0r ?c0r ?nr \<subseteq> triangle 0 0 2018"
        unfolding triangle_def
        by auto
    next
      show "?nr \<ge> 1008"
        using ab[rule_format, of 2017] True
        by (auto simp add: max_def min_def split: if_split_asm)
    next
      show "\<forall> r < 2018. (r, a r) \<notin> triangle ?r0r ?c0r ?nr"
      proof-
        have "\<forall> r < 2018. max (a r) (b r) \<le> ?r"
        proof-
          have "\<forall> r < 2018. max (a (2017 - r)) (b (2017 - r)) \<le> ?r"
          proof safe
            fix r::nat
            assume "r < 2018"
            then show "max (a (2017 - r)) (b (2017 - r)) \<le> ?r"
            proof (induction r)
              case 0
              then show ?case
                by simp
            next
              case (Suc r)
              then show ?case
                using max_max *(1-2)
                by (smt Suc_diff_Suc Suc_lessD add_diff_cancel_left' diff_Suc_Suc diff_less_Suc max.boundedE max.orderE one_plus_numeral plus_1_eq_Suc semiring_norm(4) semiring_norm(5) zero_less_diff)
            qed
          qed
          then show ?thesis
            by (metis Suc_leI add_le_cancel_left diff_diff_cancel diff_less_Suc one_plus_numeral plus_1_eq_Suc semiring_norm(4) semiring_norm(5))
        qed
        then show ?thesis
          unfolding triangle_def
          by auto
      qed
    next
      show "?r0r \<le> ?c0r"
        by simp
    next
      show "?r0r + ?nr \<le> 2018"
        by (simp add: "*"(4) "*"(5))
    qed
  next
    case False
    show ?thesis
    proof (rule triangle)
      show "triangle ?r0l ?c0l ?nl \<subseteq> triangle 0 0 2018"
        using *(4)[rule_format, of 2017] *(5)[rule_format, of 2017]
        unfolding triangle_def
        by auto
    next
      show "?c0l \<le> ?r0l"
        by simp
    next
      show "2018 - min (a 2017) (b 2017) + min (a 2017) (b 2017) \<le> 2018"
        using *(4)[rule_format, of 2017] *(5)[rule_format, of 2017]
        by auto
    next
      show "?nl \<ge> 1008"
        using ab[rule_format, of 2017] False
        by (auto simp add: max_def min_def split: if_split_asm)
    next
      show "\<forall> r < 2018. (r, a r) \<notin> triangle ?r0l ?c0l ?nl"
      proof-
        have "\<forall> r < 2018. min (a r) (b r) \<ge> ?l - (2017 - r)"
        proof-
          have "\<forall> r < 2018. min (a (2017 - r)) (b (2017 - r)) \<ge> ?l - (2017 - (2017 - r))"
          proof safe
            fix r::nat
            assume "r < 2018"
            then show "?l - (2017 - (2017 - r)) \<le> min (a (2017 - r)) (b (2017 - r))"
            proof (induction r)
              case 0
              then show ?case
                by simp
            next
              case (Suc r)
              have "min (a 2017) (b 2017) - (2017 - (2017 - Suc r)) = min (a 2017) (b 2017) - r - 1"
                using \<open>Suc r < 2018\<close>
                by auto
              also have "... \<le>  min (a (2017 - r)) (b (2017 - r)) - 1"
                using Suc
                by (smt Suc_lessD diff_Suc_Suc diff_diff_cancel diff_le_mono le_less one_plus_numeral plus_1_eq_Suc semiring_norm(4) semiring_norm(5) zero_less_diff)
              also have "... \<le> min (a (2017 - r - 1)) (b (2017 - r - 1))"
                using min_min[rule_format, of "2017 - r"] \<open>Suc r < 2018\<close>
                by simp
              finally
              show ?case
                by simp
            qed
          qed
          then show ?thesis
            by (smt diff_diff_cancel diff_less_Suc le_less less_Suc_eq one_plus_numeral plus_1_eq_Suc semiring_norm(4) semiring_norm(5))
        qed
        then show ?thesis
          by (auto simp add: triangle_def)
      qed
    qed
  qed
qed

end


(******************************************************************************)
(* Project: Isabelle/UTP: Unifying Theories of Programming in Isabelle/HOL    *)
(* File: unrest_sf.thy                                                        *)
(* Authors: Frank Zeyda and Simon Foster (University of York, UK)             *)
(* Emails: frank.zeyda@gmail.com and simon.foster@york.ac.uk                  *)
(******************************************************************************)
(* LAST REVIEWED: 09 Jun 2022 *)

section \<open>Unrestriction\<close>

theory unrest_sf
imports uvar ustate
begin

default_sort type

subsection \<open>Definition of Unrestriction\<close>

definition unrest_sf :: "uvar set \<Rightarrow> (ustate \<Rightarrow> 'a) \<Rightarrow> bool" where
"unrest_sf vs f = (\<forall>v\<in>vs. \<forall>s x. f s(v :=\<^sub>u x)\<^sub>s = f s)"

subsection \<open>Theorems\<close>

theorem unrest_sf_empty:
"unrest_sf {} f"
apply (unfold unrest_sf_def)
apply (clarsimp)
done

theorem unrest_sf_subset:
"vs1 \<subseteq> vs2 \<Longrightarrow> unrest_sf vs2 f \<Longrightarrow> unrest_sf vs1 f"
apply (unfold unrest_sf_def)
apply (blast)
done

theorem unrest_sf_const:
"unrest_sf vs (\<lambda>_. c)"
apply (unfold unrest_sf_def)
apply (clarsimp)
done

theorem unrest_sf_uvar:
"unrest_sf (vs - {v}) (\<lambda>s. f s\<cdot>v)"
apply (unfold unrest_sf_def)
apply (transfer)
apply (clarsimp)
done

theorem unrest_sf_var:
"unrest_sf (vs - {v\<down>}) (\<lambda>s. f s\<star>v)"
apply (unfold unrest_sf_def)
apply (transfer)
apply (clarsimp)
done
end


(*  Author:     Tobias Nipkow
    Copyright   1998 TUM
*)

section "Deterministic automata"

theory DA
imports AutoProj
begin

type_synonym ('a,'s)da = "'s * ('a \<Rightarrow> 's \<Rightarrow> 's) * ('s \<Rightarrow> bool)"

definition
 foldl2 :: "('a \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> 'a list \<Rightarrow> 'b \<Rightarrow> 'b" where
"foldl2 f xs a = foldl (\<lambda>a b. f b a) a xs"

definition
 delta :: "('a,'s)da \<Rightarrow> 'a list \<Rightarrow> 's \<Rightarrow> 's" where
"delta A = foldl2 (next A)"

definition
 accepts :: "('a,'s)da \<Rightarrow> 'a list \<Rightarrow> bool" where
"accepts A = (\<lambda>w. fin A (delta A w (start A)))"

lemma delta_Nil[simp]: "delta A [] s = s"
by(simp add:delta_def)

lemma delta_Cons[simp]: "delta A (a#w) s = delta A w (next A a s)"
by(simp add:delta_def)

lemma delta_append[simp]:
 "\<And>q ys. delta A (xs@ys) q = delta A ys (delta A xs q)"
by(induct xs) simp_all

end