namespace hide

inductive list (A : Type) : Type :=
| nil {} : list A
| cons : A → list A → list A

namespace list

notation `[` l:(foldr `,` (h t, cons h t) nil) `]` := l

variable {A : Type}

notation h :: t  := cons h t

definition append (s t : list A) : list A :=
list.rec_on s t (λ x l u, x::u)

notation s ++ t := append s t

theorem nil_append (t : list A) : nil ++ t = t := rfl

theorem cons_append (x : A) (s t : list A) : x::s ++ t = x::(s ++ t) := rfl

theorem append_nil (t : list A) : t ++ nil = t :=
list.induction_on t
  (show nil ++ nil = nil, from nil_append nil)
  (take h t,
    assume IH : t ++ nil = t,
    show h :: t ++ nil = h :: t, from
      calc
    h :: t ++ nil = h :: (t ++ nil) : cons_append h t nil
      ... = h :: t : IH)

theorem append_assoc (r s t : list A) : r ++ s ++ t = r ++ (s ++ t) :=
list.induction_on r
  (show nil ++ s ++ t = nil ++ (s ++ t), from
    calc
  nil ++ s ++ t = s ++ t  : rfl
    ... = nil ++ (s ++ t) : rfl)
  (take h r,
    assume IH : r ++ s ++ t = r ++ (s ++ t),
    show h :: r ++ s ++ t = h :: r ++ (s ++ t), from
      calc
    h :: r ++ s ++ t = h :: (r ++ s) ++ t : cons_append h r s
      ... = h :: (r ++ s ++ t) : cons_append h (r ++ s) t
      ... = h :: (r ++ (s ++ t)) : IH
      ... = h :: r ++ (s ++ t) : cons_append h r (s ++ t))

end list

end hide


/-
Copyright (c) 2021 Justus Springer. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Justus Springer

! This file was ported from Lean 3 source module topology.sheaves.sheaf_condition.unique_gluing
! leanprover-community/mathlib commit 618ea3d5c99240cd7000d8376924906a148bf9ff
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Topology.Sheaves.Forget
import Mathbin.CategoryTheory.Limits.Shapes.Types
import Mathbin.Topology.Sheaves.Sheaf
import Mathbin.CategoryTheory.Types

/-!
# The sheaf condition in terms of unique gluings

We provide an alternative formulation of the sheaf condition in terms of unique gluings.

We work with sheaves valued in a concrete category `C` admitting all limits, whose forgetful
functor `C ⥤ Type` preserves limits and reflects isomorphisms. The usual categories of algebraic
structures, such as `Mon`, `AddCommGroup`, `Ring`, `CommRing` etc. are all examples of this kind of
category.

A presheaf `F : presheaf C X` satisfies the sheaf condition if and only if, for every
compatible family of sections `sf : Π i : ι, F.obj (op (U i))`, there exists a unique gluing
`s : F.obj (op (supr U))`.

Here, the family `sf` is called compatible, if for all `i j : ι`, the restrictions of `sf i`
and `sf j` to `U i ⊓ U j` agree. A section `s : F.obj (op (supr U))` is a gluing for the
family `sf`, if `s` restricts to `sf i` on `U i` for all `i : ι`

We show that the sheaf condition in terms of unique gluings is equivalent to the definition
in terms of equalizers. Our approach is as follows: First, we show them to be equivalent for
`Type`-valued presheaves. Then we use that composing a presheaf with a limit-preserving and
isomorphism-reflecting functor leaves the sheaf condition invariant, as shown in
`topology/sheaves/forget.lean`.

-/

noncomputable section

open TopCat

open TopCat.Presheaf

open TopCat.Presheaf.SheafConditionEqualizerProducts

open CategoryTheory

open CategoryTheory.Limits

open TopologicalSpace

open TopologicalSpace.Opens

open Opposite

universe u v

variable {C : Type u} [Category.{v} C] [ConcreteCategory.{v} C]

namespace TopCat

namespace Presheaf

section

attribute [local instance] concrete_category.has_coe_to_sort concrete_category.has_coe_to_fun

variable {X : TopCat.{v}} (F : Presheaf C X) {ι : Type v} (U : ι → Opens X)

/-- A family of sections `sf` is compatible, if the restrictions of `sf i` and `sf j` to `U i ⊓ U j`
agree, for all `i` and `j`
-/
def IsCompatible (sf : ∀ i : ι, F.obj (op (U i))) : Prop :=
  ∀ i j : ι, F.map (inf_le_left (U i) (U j)).op (sf i) = F.map (inf_le_right (U i) (U j)).op (sf j)
#align Top.presheaf.is_compatible TopCat.Presheaf.IsCompatible

/-- A section `s` is a gluing for a family of sections `sf` if it restricts to `sf i` on `U i`,
for all `i`
-/
def IsGluing (sf : ∀ i : ι, F.obj (op (U i))) (s : F.obj (op (supᵢ U))) : Prop :=
  ∀ i : ι, F.map (Opens.leSupr U i).op s = sf i
#align Top.presheaf.is_gluing TopCat.Presheaf.IsGluing

/--
The sheaf condition in terms of unique gluings. A presheaf `F : presheaf C X` satisfies this sheaf
condition if and only if, for every compatible family of sections `sf : Π i : ι, F.obj (op (U i))`,
there exists a unique gluing `s : F.obj (op (supr U))`.

We prove this to be equivalent to the usual one below in
`is_sheaf_iff_is_sheaf_unique_gluing`
-/
def IsSheafUniqueGluing : Prop :=
  ∀ ⦃ι : Type v⦄ (U : ι → Opens X) (sf : ∀ i : ι, F.obj (op (U i))),
    IsCompatible F U sf → ∃! s : F.obj (op (supᵢ U)), IsGluing F U sf s
#align Top.presheaf.is_sheaf_unique_gluing TopCat.Presheaf.IsSheafUniqueGluing

end

section TypeValued

variable {X : TopCat.{v}} (F : Presheaf (Type v) X) {ι : Type v} (U : ι → Opens X)

/-- For presheaves of types, terms of `pi_opens F U` are just families of sections.
-/
def piOpensIsoSectionsFamily : piOpens F U ≅ ∀ i : ι, F.obj (op (U i)) :=
  Limits.IsLimit.conePointUniqueUpToIso
    (limit.isLimit (Discrete.functor fun i : ι => F.obj (op (U i))))
    (Types.productLimitCone.{v, v} fun i : ι => F.obj (op (U i))).IsLimit
#align Top.presheaf.pi_opens_iso_sections_family TopCat.Presheaf.piOpensIsoSectionsFamily

/-- Under the isomorphism `pi_opens_iso_sections_family`, compatibility of sections is the same
as being equalized by the arrows `left_res` and `right_res` of the equalizer diagram.
-/
theorem compatible_iff_leftRes_eq_rightRes (sf : piOpens F U) :
    IsCompatible F U ((piOpensIsoSectionsFamily F U).Hom sf) ↔ leftRes F U sf = rightRes F U sf :=
  by
  constructor <;> intro h
  · ext ⟨i, j⟩
    rw [left_res, types.limit.lift_π_apply', fan.mk_π_app, right_res, types.limit.lift_π_apply',
      fan.mk_π_app]
    exact h i j
  · intro i j
    convert congr_arg (limits.pi.π (fun p : ι × ι => F.obj (op (U p.1 ⊓ U p.2))) (i, j)) h
    · rw [left_res, types.pi_lift_π_apply]
      rfl
    · rw [right_res, types.pi_lift_π_apply]
      rfl
#align Top.presheaf.compatible_iff_left_res_eq_right_res TopCat.Presheaf.compatible_iff_leftRes_eq_rightRes

/-- Under the isomorphism `pi_opens_iso_sections_family`, being a gluing of a family of
sections `sf` is the same as lying in the preimage of `res` (the leftmost arrow of the
equalizer diagram).
-/
@[simp]
theorem isGluing_iff_eq_res (sf : piOpens F U) (s : F.obj (op (supᵢ U))) :
    IsGluing F U ((piOpensIsoSectionsFamily F U).Hom sf) s ↔ res F U s = sf :=
  by
  constructor <;> intro h
  · ext ⟨i⟩
    rw [res, types.limit.lift_π_apply', fan.mk_π_app]
    exact h i
  · intro i
    convert congr_arg (limits.pi.π (fun i : ι => F.obj (op (U i))) i) h
    rw [res, types.pi_lift_π_apply]
    rfl
#align Top.presheaf.is_gluing_iff_eq_res TopCat.Presheaf.isGluing_iff_eq_res

/-- The "equalizer" sheaf condition can be obtained from the sheaf condition
in terms of unique gluings.
-/
theorem isSheaf_of_isSheafUniqueGluing_types (Fsh : F.IsSheafUniqueGluing) : F.IsSheaf :=
  by
  rw [is_sheaf_iff_is_sheaf_equalizer_products]
  intro ι U
  refine' ⟨fork.is_limit.mk' _ _⟩
  intro s
  have h_compatible :
    ∀ x : s.X, F.is_compatible U ((F.pi_opens_iso_sections_family U).Hom (s.ι x)) :=
    by
    intro x
    rw [compatible_iff_left_res_eq_right_res]
    convert congr_fun s.condition x
  choose m m_spec m_uniq using fun x : s.X =>
    Fsh U ((pi_opens_iso_sections_family F U).Hom (s.ι x)) (h_compatible x)
  refine' ⟨m, _, _⟩
  · ext (⟨i⟩x)
    simp [res]
    exact m_spec x i
  · intro l hl
    ext x
    apply m_uniq
    rw [is_gluing_iff_eq_res]
    exact congr_fun hl x
#align Top.presheaf.is_sheaf_of_is_sheaf_unique_gluing_types TopCat.Presheaf.isSheaf_of_isSheafUniqueGluing_types

/-- The sheaf condition in terms of unique gluings can be obtained from the usual
"equalizer" sheaf condition.
-/
theorem isSheafUniqueGluing_of_isSheaf_types (Fsh : F.IsSheaf) : F.IsSheafUniqueGluing :=
  by
  rw [is_sheaf_iff_is_sheaf_equalizer_products] at Fsh
  intro ι U sf hsf
  let sf' := (pi_opens_iso_sections_family F U).inv sf
  have hsf' : left_res F U sf' = right_res F U sf' := by
    rwa [← compatible_iff_left_res_eq_right_res F U sf', inv_hom_id_apply]
  choose s s_spec s_uniq using types.unique_of_type_equalizer _ _ (Fsh U).some sf' hsf'
  use s
  dsimp
  constructor
  · convert(is_gluing_iff_eq_res F U sf' _).mpr s_spec
    rw [inv_hom_id_apply]
  · intro y hy
    apply s_uniq
    rw [← is_gluing_iff_eq_res F U]
    convert hy
    rw [inv_hom_id_apply]
#align Top.presheaf.is_sheaf_unique_gluing_of_is_sheaf_types TopCat.Presheaf.isSheafUniqueGluing_of_isSheaf_types

/-- For type-valued presheaves, the sheaf condition in terms of unique gluings is equivalent to the
usual sheaf condition in terms of equalizer diagrams.
-/
theorem isSheaf_iff_isSheafUniqueGluing_types : F.IsSheaf ↔ F.IsSheafUniqueGluing :=
  Iff.intro (isSheafUniqueGluing_of_isSheaf_types F) (isSheaf_of_isSheafUniqueGluing_types F)
#align Top.presheaf.is_sheaf_iff_is_sheaf_unique_gluing_types TopCat.Presheaf.isSheaf_iff_isSheafUniqueGluing_types

end TypeValued

section

attribute [local instance] concrete_category.has_coe_to_sort concrete_category.has_coe_to_fun

variable [HasLimits C] [ReflectsIsomorphisms (forget C)] [PreservesLimits (forget C)]

variable {X : TopCat.{v}} (F : Presheaf C X) {ι : Type v} (U : ι → Opens X)

/-- For presheaves valued in a concrete category, whose forgetful functor reflects isomorphisms and
preserves limits, the sheaf condition in terms of unique gluings is equivalent to the usual one
in terms of equalizer diagrams.
-/
theorem isSheaf_iff_isSheafUniqueGluing : F.IsSheaf ↔ F.IsSheafUniqueGluing :=
  Iff.trans (isSheaf_iff_isSheaf_comp (forget C) F)
    (isSheaf_iff_isSheafUniqueGluing_types (F ⋙ forget C))
#align Top.presheaf.is_sheaf_iff_is_sheaf_unique_gluing TopCat.Presheaf.isSheaf_iff_isSheafUniqueGluing

end

end Presheaf

namespace Sheaf

open Presheaf

open CategoryTheory

section

attribute [local instance] concrete_category.has_coe_to_sort concrete_category.has_coe_to_fun

variable [HasLimits C] [ReflectsIsomorphisms (ConcreteCategory.Forget C)]

variable [PreservesLimits (ConcreteCategory.Forget C)]

variable {X : TopCat.{v}} (F : Sheaf C X) {ι : Type v} (U : ι → Opens X)

/-- A more convenient way of obtaining a unique gluing of sections for a sheaf.
-/
theorem existsUnique_gluing (sf : ∀ i : ι, F.1.obj (op (U i))) (h : IsCompatible F.1 U sf) :
    ∃! s : F.1.obj (op (supᵢ U)), IsGluing F.1 U sf s :=
  (isSheaf_iff_isSheafUniqueGluing F.1).mp F.cond U sf h
#align Top.sheaf.exists_unique_gluing TopCat.Sheaf.existsUnique_gluing

/-- In this version of the lemma, the inclusion homs `iUV` can be specified directly by the user,
which can be more convenient in practice.
-/
theorem existsUnique_gluing' (V : Opens X) (iUV : ∀ i : ι, U i ⟶ V) (hcover : V ≤ supᵢ U)
    (sf : ∀ i : ι, F.1.obj (op (U i))) (h : IsCompatible F.1 U sf) :
    ∃! s : F.1.obj (op V), ∀ i : ι, F.1.map (iUV i).op s = sf i :=
  by
  have V_eq_supr_U : V = supᵢ U := le_antisymm hcover (supᵢ_le fun i => (iUV i).le)
  obtain ⟨gl, gl_spec, gl_uniq⟩ := F.exists_unique_gluing U sf h
  refine' ⟨F.1.map (eq_to_hom V_eq_supr_U).op gl, _, _⟩
  · intro i
    rw [← comp_apply, ← F.1.map_comp]
    exact gl_spec i
  · intro gl' gl'_spec
    convert congr_arg _ (gl_uniq (F.1.map (eq_to_hom V_eq_supr_U.symm).op gl') fun i => _) <;>
      rw [← comp_apply, ← F.1.map_comp]
    · rw [eq_to_hom_op, eq_to_hom_op, eq_to_hom_trans, eq_to_hom_refl, F.1.map_id, id_apply]
    · convert gl'_spec i
#align Top.sheaf.exists_unique_gluing' TopCat.Sheaf.existsUnique_gluing'

@[ext]
theorem eq_of_locally_eq (s t : F.1.obj (op (supᵢ U)))
    (h : ∀ i, F.1.map (Opens.leSupr U i).op s = F.1.map (Opens.leSupr U i).op t) : s = t :=
  by
  let sf : ∀ i : ι, F.1.obj (op (U i)) := fun i => F.1.map (opens.le_supr U i).op s
  have sf_compatible : is_compatible _ U sf :=
    by
    intro i j
    simp_rw [← comp_apply, ← F.1.map_comp]
    rfl
  obtain ⟨gl, -, gl_uniq⟩ := F.exists_unique_gluing U sf sf_compatible
  trans gl
  · apply gl_uniq
    intro i
    rfl
  · symm
    apply gl_uniq
    intro i
    rw [← h]
#align Top.sheaf.eq_of_locally_eq TopCat.Sheaf.eq_of_locally_eq

/-- In this version of the lemma, the inclusion homs `iUV` can be specified directly by the user,
which can be more convenient in practice.
-/
theorem eq_of_locally_eq' (V : Opens X) (iUV : ∀ i : ι, U i ⟶ V) (hcover : V ≤ supᵢ U)
    (s t : F.1.obj (op V)) (h : ∀ i, F.1.map (iUV i).op s = F.1.map (iUV i).op t) : s = t :=
  by
  have V_eq_supr_U : V = supᵢ U := le_antisymm hcover (supᵢ_le fun i => (iUV i).le)
  suffices F.1.map (eq_to_hom V_eq_supr_U.symm).op s = F.1.map (eq_to_hom V_eq_supr_U.symm).op t by
    convert congr_arg (F.1.map (eq_to_hom V_eq_supr_U).op) this <;>
      rw [← comp_apply, ← F.1.map_comp, eq_to_hom_op, eq_to_hom_op, eq_to_hom_trans, eq_to_hom_refl,
        F.1.map_id, id_apply]
  apply eq_of_locally_eq
  intro i
  rw [← comp_apply, ← comp_apply, ← F.1.map_comp]
  convert h i
#align Top.sheaf.eq_of_locally_eq' TopCat.Sheaf.eq_of_locally_eq'

theorem eq_of_locally_eq₂ {U₁ U₂ V : Opens X} (i₁ : U₁ ⟶ V) (i₂ : U₂ ⟶ V) (hcover : V ≤ U₁ ⊔ U₂)
    (s t : F.1.obj (op V)) (h₁ : F.1.map i₁.op s = F.1.map i₁.op t)
    (h₂ : F.1.map i₂.op s = F.1.map i₂.op t) : s = t := by
  classical
    fapply F.eq_of_locally_eq' fun t : ULift Bool => if t.1 then U₁ else U₂
    · exact fun i => if h : i.1 then eq_to_hom (if_pos h) ≫ i₁ else eq_to_hom (if_neg h) ≫ i₂
    · refine' le_trans hcover _
      rw [sup_le_iff]
      constructor
      · convert le_supᵢ (fun t : ULift Bool => if t.1 then U₁ else U₂) (ULift.up True)
      · convert le_supᵢ (fun t : ULift Bool => if t.1 then U₁ else U₂) (ULift.up False)
    · rintro ⟨_ | _⟩ <;> simp [h₁, h₂]
#align Top.sheaf.eq_of_locally_eq₂ TopCat.Sheaf.eq_of_locally_eq₂

end

end Sheaf

end TopCat


open classical
variables (α : Type) (p q : α -> Prop)
variable a : α
variable r : Prop
example : (∃ x, r -> p x) ↔  (r -> ∃ x, p x) :=
iff.intro
(assume h1 :  ∃ x, r -> p x,
exists.elim h1 $
assume y(h2 : r -> p y),
assume r,
have h3 : p y,from h2 r,
show (∃ x, p x), from exists.intro y h3)
(assume h : (r → ∃ x, p x),
        show (∃ x, r → p x), from
        by_cases
            (assume hr : r,
                have h2 : ∃ x, p x, from h hr,
                match h2 with ⟨w, (hw)⟩ :=
                    ⟨w, (λ f, hw)⟩
                end)
            (assume hr' : ¬r,
                ⟨a, (λ hr, absurd hr hr')⟩))


lemma lt_aux_one (a b : mynat) : a ≤ b ∧ ¬ (b ≤ a) → succ a ≤ b :=
begin
intro h,
cases h with h1 h2,
cases h1 with d hd,
cases d,
exfalso,
apply h2,
rw hd,
rw add_zero,
exact le_refl a,
use d,
rw hd,
rw add_succ,
rw succ_add,
refl,
end


import definitions rotations del_root forall_keys tactic.linarith tactic.induction
set_option pp.generalized_field_notation false

universe u

namespace deletion_lemmas
open btree rotation_lemmas del_root_lemmas forall_keys_lemmas

variables {α : Type u}

/- Auxiliary lemma for deletion: a previously existing key's relation with a tree is the same after deletion -/
lemma forall_keys_delete (t : btree α) (k x : nat) (p : nat → nat → Prop) (h : p k x) :
  forall_keys p k t → forall_keys p k (delete x t) :=
begin
  intro h₁,
  induction t,
  case empty {
    simp [delete],
    exact h₁,
  },
  case node : tl tk ta tr ihl ihr {
    simp [delete],
    by_cases c₁ : (x = tk),
    { simp only [if_pos c₁],
      apply forall_del_root,
      exact h₁,
    },
    { simp only [if_neg c₁],
      by_cases c₂ : (x < tk),
      { simp only [if_pos c₂],
        by_cases c₃ : (height (delete x tl) + 1 < height tr),
        { simp only [if_pos c₃],
          apply forall_rotate_left,
          rw ← forall_keys_char,
          unfold forall_keys at *,
          repeat { split },
          { apply ihl,
            intros k' h₂,
            apply h₁,
            simp [bound],
            tauto,
          },
          { apply h₁,
            simp [bound],
          },
          { intros k' h₂,
            apply h₁,
            simp [bound],
            tauto,
          },
        },
        { simp only [if_neg c₃],
          rw ← forall_keys_char,
          unfold forall_keys at *,
          repeat { split },
          { apply ihl,
            intros k' h₂,
            apply h₁,
            simp [bound],
            tauto,
          },
          { apply h₁,
            simp [bound],
          },
          { intros k' h₂,
            apply h₁,
            simp [bound],
            tauto,
          },
        },
      },
      { simp only [if_neg c₂],
        by_cases c₃ : (height (delete x tr) + 1 < height tl),
        { simp only [if_pos c₃],
          apply forall_rotate_right,
          rw ← forall_keys_char,
          unfold forall_keys at *,
          repeat { split },
          { intros k' h₂,
            apply h₁,
            simp [bound],
            tauto,
          },
          { apply h₁,
            simp [bound],
          },
          { apply ihr,
            intros k' h₂,
            apply h₁,
            simp [bound],
            tauto,
          },
        },
        { simp only [if_neg c₃],
          rw ← forall_keys_char,
          unfold forall_keys at *,
          repeat { split },
          { intros k' h₂,
            apply h₁,
            simp [bound],
            tauto,
          },
          { apply h₁,
            simp [bound],
          },
          { apply ihr,
            intros k' h₂,
            apply h₁,
            simp [bound],
            tauto,
          },
        },
      },
    },
  },
end

/- Deletion preserves tree order -/
lemma delete_ordered (t : btree α) (k : nat) :
  ordered t → ordered (delete k t) :=
begin
  intro h₁,
  induction t,
  case empty {
    simp [delete, ordered],
  },
  case node : tl tk ta tr ihl ihr {
    simp only [delete],
    by_cases c₁ : (k = tk),
    { simp only [if_pos c₁],
      apply del_root_ordered,
      exact h₁,
    },
    { simp only [if_neg c₁],
      rw ordered at h₁,
      cases_matching* (_ ∧ _),
      by_cases c₂ : (k < tk),
      { simp only [if_pos c₂],
        by_cases c₃ : (height (delete k tl) + 1 < height tr),
        { simp only [if_pos c₃],
          apply rotate_left_ordered,
          repeat { split }; try { assumption },
          { apply ihl, assumption, },
          { apply forall_keys_delete; assumption, },
        },
        { simp only [if_neg c₃],
          repeat { split }; try { assumption },
          { apply ihl, assumption, },
          { apply forall_keys_delete; assumption, },
        },
      },
      { simp only [if_neg c₂],
        by_cases c₃ : (height tl > height (delete k tr) + 1),
        { simp only [if_pos c₃],
          apply rotate_right_ordered,
          repeat { split }; try { assumption },
          { apply ihr, assumption, },
          { apply forall_keys_delete,
            { omega, },
            { assumption, },
          },
        },
        { simp only [if_neg c₃],
          repeat { split }; try { assumption },
          { apply ihr, assumption, },
          { apply forall_keys_delete,
            { omega, },
            { assumption, },
          },
        },
      },
    },
  },
end

end deletion_lemmas


/-
Copyright (c) 2018 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro

! This file was ported from Lean 3 source module data.list.lex
! leanprover-community/mathlib commit d6aae1bcbd04b8de2022b9b83a5b5b10e10c777d
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Order.RelClasses
import Mathlib.Tactic.Classical

/-!
# Lexicographic ordering of lists.

The lexicographic order on `List α` is defined by `L < M` iff
* `[] < (a :: L)` for any `a` and `L`,
* `(a :: L) < (b :: M)` where `a < b`, or
* `(a :: L) < (a :: M)` where `L < M`.

## See also

Related files are:
* `Mathlib.Data.Finset.Colex`: Colexicographic order on finite sets.
* `Mathlib.Data.PSigma.Order`: Lexicographic order on `Σ' i, α i`.
* `Mathlib.Data.Pi.Lex`: Lexicographic order on `Πₗ i, α i`.
* `Mathlib.Data.Sigma.Order`: Lexicographic order on `Σ i, α i`.
* `Mathlib.Data.Prod.Lex`: Lexicographic order on `α × β`.
-/

namespace List

open Nat

universe u

variable {α : Type u}

/-! ### lexicographic ordering -/

/-- Given a strict order `<` on `α`, the lexicographic strict order on `List α`, for which
`[a0, ..., an] < [b0, ..., b_k]` if `a0 < b0` or `a0 = b0` and `[a1, ..., an] < [b1, ..., bk]`.
The definition is given for any relation `r`, not only strict orders. -/
inductive Lex (r : α → α → Prop) : List α → List α → Prop
  | nil {a l} : Lex r [] (a :: l)
  | cons {a l₁ l₂} (h : Lex r l₁ l₂) : Lex r (a :: l₁) (a :: l₂)
  | rel {a₁ l₁ a₂ l₂} (h : r a₁ a₂) : Lex r (a₁ :: l₁) (a₂ :: l₂)
#align list.lex List.Lex
#align list.lex.nil List.Lex.nil
#align list.lex.cons List.Lex.cons
#align list.lex.rel List.Lex.rel

namespace Lex

theorem cons_iff {r : α → α → Prop} [IsIrrefl α r] {a l₁ l₂} :
    Lex r (a :: l₁) (a :: l₂) ↔ Lex r l₁ l₂ :=
  ⟨fun h => by cases' h with _ _ _ _ _ h _ _ _ _ h; exacts [h, (irrefl_of r a h).elim], Lex.cons⟩
#align list.lex.cons_iff List.Lex.cons_iff

@[simp]
theorem not_nil_right (r : α → α → Prop) (l : List α) : ¬Lex r l [] :=
  fun.
#align list.lex.not_nil_right List.Lex.not_nil_right

instance isOrderConnected (r : α → α → Prop) [IsOrderConnected α r] [IsTrichotomous α r] :
    IsOrderConnected (List α) (Lex r) where
  conn := aux where
    aux
    | _, [], c :: l₃, nil => Or.inr nil
    | _, [], c :: l₃, rel _ => Or.inr nil
    | _, [], c :: l₃, cons _ => Or.inr nil
    | _, b :: l₂, c :: l₃, nil => Or.inl nil
    | a :: l₁, b :: l₂, c :: l₃, rel h => (IsOrderConnected.conn _ b _ h).imp rel rel
    | a :: l₁, b :: l₂, _ :: l₃, cons h => by
      rcases trichotomous_of r a b with (ab | rfl | ab)
      · exact Or.inl (rel ab)
      · exact (aux _ l₂ _ h).imp cons cons
      · exact Or.inr (rel ab)
#align list.lex.is_order_connected List.Lex.isOrderConnected

-- This can be removed after https://github.com/leanprover/lean4/pull/1866
attribute [nolint defLemma] isOrderConnected.aux

instance isTrichotomous (r : α → α → Prop) [IsTrichotomous α r] :
    IsTrichotomous (List α) (Lex r) where
  trichotomous := aux where
    aux
    | [], [] => Or.inr (Or.inl rfl)
    | [], b :: l₂ => Or.inl nil
    | a :: l₁, [] => Or.inr (Or.inr nil)
    | a :: l₁, b :: l₂ => by
      rcases trichotomous_of r a b with (ab | rfl | ab)
      · exact Or.inl (rel ab)
      · exact (aux l₁ l₂).imp cons (Or.imp (congr_arg _) cons)
      · exact Or.inr (Or.inr (rel ab))
#align list.lex.is_trichotomous List.Lex.isTrichotomous

-- This can be removed after https://github.com/leanprover/lean4/pull/1866
attribute [nolint defLemma] isTrichotomous.aux

instance isAsymm (r : α → α → Prop) [IsAsymm α r] : IsAsymm (List α) (Lex r) where
  asymm := aux where
    aux
    | _, _, Lex.rel h₁, Lex.rel h₂ => asymm h₁ h₂
    | _, _, Lex.rel h₁, Lex.cons _ => asymm h₁ h₁
    | _, _, Lex.cons _, Lex.rel h₂ => asymm h₂ h₂
    | _, _, Lex.cons h₁, Lex.cons h₂ => aux _ _ h₁ h₂
#align list.lex.is_asymm List.Lex.isAsymm

-- This can be removed after https://github.com/leanprover/lean4/pull/1866
attribute [nolint defLemma] isAsymm.aux

instance isStrictTotalOrder (r : α → α → Prop) [IsStrictTotalOrder α r] :
    IsStrictTotalOrder (List α) (Lex r) :=
  { isStrictWeakOrder_of_isOrderConnected with }
#align list.lex.is_strict_total_order List.Lex.isStrictTotalOrder

instance decidableRel [DecidableEq α] (r : α → α → Prop) [DecidableRel r] : DecidableRel (Lex r)
  | l₁, [] => isFalse fun h => by cases h
  | [], b :: l₂ => isTrue Lex.nil
  | a :: l₁, b :: l₂ => by
    haveI := decidableRel r l₁ l₂
    refine' decidable_of_iff (r a b ∨ a = b ∧ Lex r l₁ l₂) ⟨fun h => _, fun h => _⟩
    · rcases h with (h | ⟨rfl, h⟩)
      · exact Lex.rel h
      · exact Lex.cons h
    · rcases h with (_ | h | h)
      · exact Or.inr ⟨rfl, h⟩
      · exact Or.inl h
#align list.lex.decidable_rel List.Lex.decidableRel

theorem append_left (R : α → α → Prop) {t₁ t₂} (h : Lex R t₁ t₂) : ∀ s, Lex R (s ++ t₁) (s ++ t₂)
  | [] => h
  | _ :: l => cons (append_left R h l)
#align list.lex.append_left List.Lex.append_left

theorem imp {r s : α → α → Prop} (H : ∀ a b, r a b → s a b) : ∀ l₁ l₂, Lex r l₁ l₂ → Lex s l₁ l₂
  | _, _, nil => nil
  | _, _, cons h => cons (imp H _ _ h)
  | _, _, rel r => rel (H _ _ r)
#align list.lex.imp List.Lex.imp

theorem to_ne : ∀ {l₁ l₂ : List α}, Lex (· ≠ ·) l₁ l₂ → l₁ ≠ l₂
  | _, _, cons h, e => to_ne h (List.cons.inj e).2
  | _, _, rel r, e => r (List.cons.inj e).1
#align list.lex.to_ne List.Lex.to_ne

theorem _root_.Decidable.List.Lex.ne_iff [DecidableEq α] {l₁ l₂ : List α}
    (H : length l₁ ≤ length l₂) : Lex (· ≠ ·) l₁ l₂ ↔ l₁ ≠ l₂ :=
  ⟨to_ne, fun h => by
    induction' l₁ with a l₁ IH generalizing l₂ <;> cases' l₂ with b l₂
    · contradiction
    · apply nil
    · exact (not_lt_of_ge H).elim (succ_pos _)
    · by_cases ab : a = b
      · subst b
        apply cons
        exact IH (le_of_succ_le_succ H) (mt (congr_arg _) h)
      · exact rel ab ⟩
#align decidable.list.lex.ne_iff Decidable.List.Lex.ne_iff

theorem ne_iff {l₁ l₂ : List α} (H : length l₁ ≤ length l₂) : Lex (· ≠ ·) l₁ l₂ ↔ l₁ ≠ l₂ := by
  classical
  exact Decidable.List.Lex.ne_iff H
#align list.lex.ne_iff List.Lex.ne_iff

end Lex

--Note: this overrides an instance in core lean
instance LT' [LT α] : LT (List α) :=
  ⟨Lex (· < ·)⟩
#align list.has_lt' List.LT'

theorem nil_lt_cons [LT α] (a : α) (l : List α) : [] < a :: l :=
  Lex.nil
#align list.nil_lt_cons List.nil_lt_cons

instance [LinearOrder α] : LinearOrder (List α) :=
  linearOrderOfSTO (Lex (· < ·))

--Note: this overrides an instance in core lean
instance LE' [LinearOrder α] : LE (List α) :=
  Preorder.toLE
#align list.has_le' List.LE'

end List


import data.zmod.basic tactic.ring data.polynomial group_theory.perm.sign

open finset polynomial

lemma add_even_of_add_square_even {m x y : ℤ} (h : 2 * m = x^2 + y^2) : (x + y) % 2 = 0 :=
have hzmod : ∀ x y : zmod 2, x ^ 2 + y ^ 2 = 0 → x + y = 0, from dec_trivial,
have (x : zmod 2)^2 + (y : zmod 2)^2 = 0,
  by simpa [show (2 : zmod 2) = 0, from rfl, eq_comm] using congr_arg (coe : ℤ → zmod 2) h,
show x + y ≡ 0 [ZMOD 2], from (zmod.eq_iff_modeq_int' (show 2 > 0, from dec_trivial)).1 $
by simpa using hzmod _ _ this

lemma sub_even_of_add_square_even {m x y : ℤ} (h : 2 * m = x^2 + y^2) : (x - y) % 2 = 0 :=
add_even_of_add_square_even (show 2 * m = x^2 + (-y)^2, by simpa)

private lemma sum_two_squares_of_two_mul_sum_two_squares {m x y : ℤ} (h : 2 * m = x^2 + y^2) :
  m = ((x - y) / 2) ^ 2 + ((x + y) / 2) ^ 2 :=
(domain.mul_left_inj (show (2*2 : ℤ) ≠ 0, from dec_trivial)).1 $
calc 2 * 2 * m = (x - y)^2 + (x + y)^2 : by rw [mul_assoc, h]; ring
... = (2 * ((x - y) / 2))^2 + (2 * ((x + y) / 2))^2 :
  by rw [int.mul_div_cancel' ((int.dvd_iff_mod_eq_zero _ _).2 (sub_even_of_add_square_even h)),
    int.mul_div_cancel' ((int.dvd_iff_mod_eq_zero _ _).2 (add_even_of_add_square_even h))]
... = 2 * 2 * (((x - y) / 2) ^ 2 + ((x + y) / 2) ^ 2) :
  by simp [mul_add, pow_succ, mul_comm, mul_assoc, mul_left_comm]

private lemma sum_four_squares_of_two_mul_sum_four_squares {m a b c d : ℤ}
  (h : a^2 + b^2 + c^2 + d^2 = 2 * m) :
  ∃ w x y z, w^2 + x^2 + y^2 + z^2 = m :=
let dec : decidable (∀ f : fin 4 → zmod 2, (f 0)^2 + (f 1)^2 + (f 2)^2 + (f 3)^2 = 0 →
    ∃ σ : equiv.perm (fin 4), f (σ 0) ^ 2 + f (σ 1) ^ 2 = 0 ∧ f (σ 2) ^ 2 + f (σ 3) ^ 2 = 0) :=
  @fintype.decidable_forall_fintype (fin 4 → zmod 2) _ _
    (λ f : fin 4 → zmod 2, @forall_prop_decidable ((f 0)^2 + (f 1)^2 + (f 2)^2 + (f 3)^2 = 0)
      _ (zmod.decidable_eq 2 _ 0)
      (λ h, @fintype.decidable_exists_fintype (equiv.perm (fin 4)) _
        (λ σ, f (σ 0) ^ 2 + f (σ 1) ^ 2 = 0 ∧ f (σ 2) ^ 2 + f (σ 3) ^ 2 = 0)
        _)) in
have ∀ f : fin 4 → zmod 2, (f 0)^2 + (f 1)^2 + (f 2)^2 + (f 3)^2 = 0 →
    ∃ σ : equiv.perm (fin 4), f (σ 0) ^ 2 + f (σ 1) ^ 2 = 0 ∧ f (σ 2) ^ 2 + f (σ 3) ^ 2 = 0,
  from @of_as_true _ dec trivial,
let f : fin 4 → ℤ := vector.nth ⟨[a,b,c,d], rfl⟩ in
let ⟨σ, hσ⟩ := this (coe ∘ f) (by rw [← @zero_mul (zmod 2) _ m, ← show ((2 : ℤ) : zmod 2) = 0, from rfl,
  ← int.cast_mul, ← h]; simp only [int.cast_add, int.cast_pow]; refl) in
have h01 : 2 ∣ f (σ 0) ^ 2 + f (σ 1) ^ 2,
  from (@zmod.eq_zero_iff_dvd_int 2 _).1 $ by simpa using hσ.1,
have h23 : 2 ∣ f (σ 2) ^ 2 + f (σ 3) ^ 2,
  from (@zmod.eq_zero_iff_dvd_int 2 _).1 $ by simpa using hσ.2,
let ⟨x, hx⟩ := h01 in let ⟨y, hy⟩ := h23 in
⟨(f (σ 0) - f (σ 1)) / 2, (f (σ 0) + f (σ 1)) / 2, (f (σ 2) - f (σ 3)) / 2, (f (σ 2) + f (σ 3)) / 2,
  begin
    rw [← sum_two_squares_of_two_mul_sum_two_squares hx.symm, add_assoc,
      ← sum_two_squares_of_two_mul_sum_two_squares hy.symm,
      ← domain.mul_left_inj (show (2 : ℤ) ≠ 0, from dec_trivial), ← h, mul_add, ← hx, ← hy],
    suffices : f (σ 0)^2 + (f (σ 1)^2 + (f (σ 2)^2 + (f (σ 3)^2 + 0))) =
      f 0^2 + (f 1^2 + (f 2^2 + (f 3^2 + 0))),
    { by simpa [f] },
    have : univ.sum (λ x, f (σ x)^2) = univ.sum (λ x, f x^2),
    { conv_rhs { rw finset.sum_univ_perm σ } },
    exact this,
  end⟩

lemma card_image_polynomial_eval {α : Type*} [integral_domain α] [fintype α] [decidable_eq α]
  {p : polynomial α} (hp : 0 < p.degree) :
  fintype.card α ≤ nat_degree p * (univ.image (λ x, eval x p)).card :=
have hdp : ∀ {a : α}, degree p = degree (p - C a),
  from λ a, eq.symm $ by rw [sub_eq_add_neg, add_comm]; exact
    degree_add_eq_of_degree_lt
      (show degree (-C a) < degree p, by rw degree_neg;
        exact lt_of_le_of_lt (degree_C_le) hp),
have hp0 : ∀ {a : α}, p - C a ≠ 0, from λ a h, by rw [@hdp a, h] at hp; simp * at *,
have hroots : ∀ {x a : α}, x ∈ (p - C a).roots ↔ p.eval x = a,
  from λ _ _, by rw [mem_roots hp0, is_root, eval_sub, eval_C, sub_eq_zero],
calc fintype.card α = fintype.card (Σ a : set.range (λ x, eval x p), {x // p.eval x = a}) :
  fintype.card_congr (equiv.sigma_subtype_preimage_equiv _
    (set.range (λ x, eval x p)) (set.mem_range_self : _)).symm
... = univ.sum (λ a : set.range (λ x, eval x p), fintype.card {x // p.eval x = a}) :
  fintype.card_sigma _
... = (univ.image (λ x, eval x p)).sum (λ a, (p - C a).roots.card) :
  finset.sum_bij (λ a _, a)
    (λ ⟨a, x, hx⟩ _, mem_image.2 ⟨x, mem_univ _, hx⟩)
    (λ ⟨a, ha⟩ _, finset.card_congr (λ a _, a.val) (λ ⟨x, hx⟩ _, by rwa hroots)
      (λ _ _ _ _, subtype.ext.2)
      (λ x hx, ⟨⟨x, by rwa ← hroots⟩, mem_univ _, rfl⟩))
    (λ _ _ _ _, subtype.ext.2)
    (λ x, by rw [mem_image]; exact λ ⟨a, _, ha⟩, ⟨⟨x, ⟨a, ha⟩⟩, mem_univ _, rfl⟩)
... ≤ (univ.image (λ x, eval x p)).sum (λ _, p.nat_degree) :
  sum_le_sum (λ a _, by rw [nat_degree_eq_of_degree_eq (@hdp a)]; exact card_roots' (@hp0 a))
... = _ : by rw [sum_const, add_monoid.smul_eq_mul', nat.cast_id]

lemma exists_root_sum_quadratic {α : Type*} [fintype α] [integral_domain α]
  (f g : polynomial α) (hf2 : degree f = 2) (hg2 : degree g = 2) (hα : fintype.card α % 2 = 1) :
  ∃ a b, f.eval a + g.eval b = 0 :=
by letI := classical.dec_eq α; exact
have ∀ f : polynomial α, degree f = 2 →
    fintype.card α ≤ 2 * (univ.image (λ x : α, eval x f)).card,
  from λ f hf, have hf0 : f ≠ 0, from λ h, by simp * at *; contradiction,
    calc fintype.card α ≤ nat_degree f * (univ.image (λ x, eval x f)).card :
      card_image_polynomial_eval (hf.symm ▸ dec_trivial)
    ... = _ : by rw [degree_eq_nat_degree hf0, show (2 : with_bot ℕ) = (2 : ℕ), from rfl,
      with_bot.coe_eq_coe] at hf; rw hf,
have ∀ f : polynomial α, degree f = 2 →
    fintype.card α < 2 * (univ.image (λ x : α, eval x f)).card,
  from λ f hf, lt_of_le_of_ne (this _ hf) (mt (congr_arg (% 2)) (by simp *)),
have h : fintype.card α < (univ.image (λ x : α, eval x f)).card +
    (univ.image (λ x : α, eval x (-g))).card,
  from (mul_lt_mul_left (show 2 > 0, by norm_num)).1 $
    by rw [two_mul, mul_add]; exact add_lt_add (this _ hf2) (this _ (by simpa)),
have hd : ¬ disjoint (univ.image (λ x : α, eval x f)) (univ.image (λ x : α, eval x (-g))),
  from λ hd, by rw [← card_disjoint_union hd, ← not_le] at h;
    exact h (card_le_of_subset $ subset_univ _),
begin
  simp only [disjoint_left, mem_image] at hd,
  push_neg at hd,
  rcases hd with ⟨x, ⟨a, _, ha⟩, ⟨b, _, hb⟩⟩,
  use [a, b],
  rw [ha, ← hb, eval_neg, neg_add_self]
end

lemma neg_one_sum_two_squares_mod_p {p : ℕ} (hp : p.prime) : ∃ a b : zmodp p hp, a^2 + b^2 + 1 = 0 :=
hp.eq_two_or_odd.elim (λ hp2, by subst hp2; exact dec_trivial) $ λ hp2,
let ⟨a, b, hab⟩ := exists_root_sum_quadratic (-X^2 : polynomial (zmodp p hp)) (X^2 - C (-1)) (by simp)
  (degree_X_pow_sub_C dec_trivial _) (by simp *) in
⟨a, b, by simpa using hab⟩

lemma exists_sum_two_squares_add_one_eq_k {p : ℕ} (hp : p.prime) (hp1 : p % 2 = 1) :
  ∃ (a b : ℤ) (k : ℕ), a^2 + b^2 + 1 = k * p ∧ k < p :=
let ⟨a, b, hab⟩ := neg_one_sum_two_squares_mod_p hp in
have hab' : (p : ℤ) ∣ a.val_min_abs ^ 2 + b.val_min_abs ^ 2 + 1,
  from (zmodp.eq_zero_iff_dvd_int hp _).1 $ by simpa using hab,
let ⟨k, hk⟩ := hab' in
have hk0 : 0 ≤ k, from nonneg_of_mul_nonneg_left
  (by rw ← hk; exact (add_nonneg (add_nonneg (pow_two_nonneg _) (pow_two_nonneg _)) zero_le_one))
  (int.coe_nat_pos.2 hp.pos),
⟨a.val_min_abs, b.val_min_abs, k.nat_abs,
    by rw [hk, int.nat_abs_of_nonneg hk0, mul_comm],
  lt_of_mul_lt_mul_left
    (calc p * k.nat_abs = a.val_min_abs.nat_abs ^ 2 + b.val_min_abs.nat_abs ^ 2 + 1 :
        by rw [← int.coe_nat_inj', int.coe_nat_add, int.coe_nat_add, nat.pow_two, nat.pow_two,
          int.nat_abs_mul_self, int.nat_abs_mul_self,← pow_two, ← pow_two,
          int.coe_nat_one, hk, int.coe_nat_mul, int.nat_abs_of_nonneg hk0]
      ... ≤ (p / 2) ^ 2 + (p / 2)^2 + 1 :
        add_le_add
          (add_le_add
            (nat.pow_le_pow_of_le_left (zmodp.nat_abs_val_min_abs_le _) _)
            (nat.pow_le_pow_of_le_left (zmodp.nat_abs_val_min_abs_le _) _))
          (le_refl _)
      ... < (p / 2) ^ 2 + (p / 2)^ 2 + (p % 2)^2 + ((2 * (p / 2)^2 + (4 * (p / 2) * (p % 2)))) :
        by rw [hp1, nat.one_pow, mul_one];
          exact (lt_add_iff_pos_right _).2
            (add_pos_of_nonneg_of_pos (nat.zero_le _) (mul_pos dec_trivial
              (nat.div_pos hp.two_le dec_trivial)))
      ... = p * p : begin
        conv_rhs { rw [← nat.mod_add_div p 2] },
        simp only [nat.pow_two],
        rw [← int.coe_nat_inj'],
        simp only [nat.pow_two, int.coe_nat_add, int.coe_nat_mul, int.coe_nat_bit0, int.coe_nat_one,
          two_mul, mul_add, add_mul],
        ring,
      end)
    (show 0 ≤ p, from nat.zero_le _)⟩

open_locale classical

lemma odd_prime_sum_four_squares {p : ℕ} (hp : p.prime) (hp2 : p%2 = 1) :
  ∃ a b c d : ℤ, a^2 + b^2 + c^2 + d^2 = p :=
have hm : ∃ m < p, 0 < m ∧ ∃ a b c d : ℤ, a^2 + b^2 + c^2 + d^2 = m * p,
  from let ⟨a, b, k, hk⟩ := exists_sum_two_squares_add_one_eq_k hp hp2 in
  ⟨k, hk.2, nat.pos_of_ne_zero $
    (λ hk0, by rw [hk0, int.coe_nat_zero, zero_mul] at hk;
      exact ne_of_gt (show a^2 + b^2 + 1 > 0, from add_pos_of_nonneg_of_pos
        (add_nonneg (pow_two_nonneg _) (pow_two_nonneg _)) zero_lt_one) hk.1),
    a, b, 1, 0, by simpa [pow_two] using hk.1⟩,
let m := nat.find hm in
let ⟨a, b, c, d, (habcd : a^2 + b^2 + c^2 + d^2 = m * p)⟩ := (nat.find_spec hm).snd.2 in
have hm0 : 0 < m, from (nat.find_spec hm).snd.1,
have hmp : m < p, from (nat.find_spec hm).fst,
m.mod_two_eq_zero_or_one.elim
  (λ hm2 : m % 2 = 0,
    let ⟨k, hk⟩ := (nat.dvd_iff_mod_eq_zero _ _).2 hm2 in
    have hk0 : 0 < k, from nat.pos_of_ne_zero $ λ _, by simp [*, lt_irrefl] at *,
    have hkm : k < m, by rw [hk, two_mul]; exact (lt_add_iff_pos_left _).2 hk0,
    false.elim $ nat.find_min hm hkm ⟨lt_trans hkm hmp, hk0,
      sum_four_squares_of_two_mul_sum_four_squares
        (show a^2 + b^2 + c^2 + d^2 = 2 * (k * p),
          by rw [habcd, hk, int.coe_nat_mul, mul_assoc]; simp)⟩)
  (λ hm2 : m % 2 = 1,
    if hm1 : m = 1 then ⟨a, b, c, d, by simp only [hm1, habcd, int.coe_nat_one, one_mul]⟩
    else --have hm1 : 1 < m, from lt_of_le_of_ne hm0 (ne.symm hm1),
      let mp : ℕ+ := ⟨m, hm0⟩ in
      let w := (a : zmod mp).val_min_abs, x := (b : zmod mp).val_min_abs,
          y := (c : zmod mp).val_min_abs, z := (d : zmod mp).val_min_abs in
      have hnat_abs : w^2 + x^2 + y^2 + z^2 =
          (w.nat_abs^2 + x.nat_abs^2 + y.nat_abs ^2 + z.nat_abs ^ 2 : ℕ),
        by simp [pow_two],
      have hwxyzlt : w^2 + x^2 + y^2 + z^2 < m^2,
        from calc w^2 + x^2 + y^2 + z^2
            = (w.nat_abs^2 + x.nat_abs^2 + y.nat_abs ^2 + z.nat_abs ^ 2 : ℕ) : hnat_abs
        ... ≤ ((m / 2) ^ 2 + (m / 2) ^ 2 + (m / 2) ^ 2 + (m / 2) ^ 2 : ℕ) :
          int.coe_nat_le.2 $ add_le_add (add_le_add (add_le_add
            (nat.pow_le_pow_of_le_left (zmod.nat_abs_val_min_abs_le _) _)
            (nat.pow_le_pow_of_le_left (zmod.nat_abs_val_min_abs_le _) _))
            (nat.pow_le_pow_of_le_left (zmod.nat_abs_val_min_abs_le _) _))
            (nat.pow_le_pow_of_le_left (zmod.nat_abs_val_min_abs_le _) _)
        ... = 4 * (m / 2 : ℕ) ^ 2 : by simp [pow_two, bit0, bit1, mul_add, add_mul]
        ... < 4 * (m / 2 : ℕ) ^ 2 + ((4 * (m / 2) : ℕ) * (m % 2 : ℕ) + (m % 2 : ℕ)^2) :
          (lt_add_iff_pos_right _).2 (by rw [hm2, int.coe_nat_one, one_pow, mul_one];
            exact add_pos_of_nonneg_of_pos (int.coe_nat_nonneg _) zero_lt_one)
        ... = m ^ 2 : by conv_rhs {rw [← nat.mod_add_div m 2]};
          simp [-nat.mod_add_div, mul_add, add_mul, bit0, bit1, mul_comm, mul_assoc, mul_left_comm,
            pow_add],
      have hwxyzabcd : ((w^2 + x^2 + y^2 + z^2 : ℤ) : zmod mp) =
          ((a^2 + b^2 + c^2 + d^2 : ℤ) : zmod mp),
        by simp [w, x, y, z, pow_two],
      have hwxyz0 : ((w^2 + x^2 + y^2 + z^2 : ℤ) : zmod mp) = 0,
        by rw [hwxyzabcd, habcd, int.cast_mul, show ((m : ℤ) : zmod mp) = (mp : zmod mp), from rfl,
          int.cast_coe_nat, coe_coe, zmod.cast_self_eq_zero]; simp,
      let ⟨n, hn⟩ := (zmod.eq_zero_iff_dvd_int.1 hwxyz0) in
      have hn0 : 0 < n.nat_abs, from int.nat_abs_pos_of_ne_zero (λ hn0,
        have hwxyz0 : (w.nat_abs^2 + x.nat_abs^2 + y.nat_abs^2 + z.nat_abs^2 : ℕ) = 0,
          by rw [← int.coe_nat_eq_zero, ← hnat_abs]; rwa [hn0, mul_zero] at hn,
        have habcd0 : (m : ℤ) ∣ a ∧ (m : ℤ) ∣ b ∧ (m : ℤ) ∣ c ∧ (m : ℤ) ∣ d,
          by simpa [add_eq_zero_iff_eq_zero_of_nonneg (pow_two_nonneg _) (pow_two_nonneg _),
            nat.pow_two, w, x, y, z, zmod.eq_zero_iff_dvd_int] using hwxyz0,
        let ⟨ma, hma⟩ := habcd0.1,     ⟨mb, hmb⟩ := habcd0.2.1,
            ⟨mc, hmc⟩ := habcd0.2.2.1, ⟨md, hmd⟩ := habcd0.2.2.2 in
        have hmdvdp : m ∣ p,
          from int.coe_nat_dvd.1 ⟨ma^2 + mb^2 + mc^2 + md^2,
            (domain.mul_left_inj (show (m : ℤ) ≠ 0, from int.coe_nat_ne_zero_iff_pos.2 hm0)).1 $
              by rw [← habcd, hma, hmb, hmc, hmd]; ring⟩,
        (hp.2 _ hmdvdp).elim hm1 (λ hmeqp, by simpa [lt_irrefl, hmeqp] using hmp)),
      have hawbxcydz : ((mp : ℕ) : ℤ) ∣ a * w + b * x + c * y + d * z,
        from zmod.eq_zero_iff_dvd_int.1 $ by rw [← hwxyz0]; simp; ring,
      have haxbwczdy : ((mp : ℕ) : ℤ) ∣ a * x - b * w - c * z + d * y,
        from zmod.eq_zero_iff_dvd_int.1 $ by simp; ring,
      have haybzcwdx : ((mp : ℕ) : ℤ) ∣ a * y + b * z - c * w - d * x,
        from zmod.eq_zero_iff_dvd_int.1 $ by simp; ring,
      have hazbycxdw : ((mp : ℕ) : ℤ) ∣ a * z - b * y + c * x - d * w,
        from zmod.eq_zero_iff_dvd_int.1 $ by simp; ring,
      let ⟨s, hs⟩ := hawbxcydz, ⟨t, ht⟩ := haxbwczdy, ⟨u, hu⟩ := haybzcwdx, ⟨v, hv⟩ := hazbycxdw in
      have hn_nonneg : 0 ≤ n,
        from nonneg_of_mul_nonneg_left
          (by erw [← hn]; repeat {try {refine add_nonneg _ _}, try {exact pow_two_nonneg _}})
          (int.coe_nat_pos.2 hm0),
      have hnm : n.nat_abs < mp,
        from int.coe_nat_lt.1 (lt_of_mul_lt_mul_left
          (by rw [int.nat_abs_of_nonneg hn_nonneg, ← hn, ← pow_two]; exact hwxyzlt)
          (int.coe_nat_nonneg mp)),
      have hstuv : s^2 + t^2 + u^2 + v^2 = n.nat_abs * p,
        from (domain.mul_left_inj (show (m^2 : ℤ) ≠ 0, from pow_ne_zero 2
            (int.coe_nat_ne_zero_iff_pos.2 hm0))).1 $
          calc (m : ℤ)^2 * (s^2 + t^2 + u^2 + v^2) = ((mp : ℕ) * s)^2 + ((mp : ℕ) * t)^2 +
              ((mp : ℕ) * u)^2 + ((mp : ℕ) * v)^2 :
            by simp [mp]; ring
          ... = (w^2 + x^2 + y^2 + z^2) * (a^2 + b^2 + c^2 + d^2) :
            by simp only [hs.symm, ht.symm, hu.symm, hv.symm]; ring
          ... = _ : by rw [hn, habcd, int.nat_abs_of_nonneg hn_nonneg]; dsimp [mp]; ring,
      false.elim $ nat.find_min hm hnm ⟨lt_trans hnm hmp, hn0, s, t, u, v, hstuv⟩)

open nat

lemma sum_four_squares : ∀ n : ℕ, ∃ a b c d : ℕ, a^2 + b^2 + c^2 + d^2 = n
| 0 := ⟨0, 0, 0, 0, rfl⟩
| 1 := ⟨1, 0, 0, 0, rfl⟩
| n@(k+2) :=
have hm : (min_fac n).prime := min_fac_prime dec_trivial,
have n / min_fac n < n := factors_lemma,
let ⟨a, b, c, d, h₁⟩ := show ∃ a b c d : ℤ, a^2 + b^2 + c^2 + d^2 = min_fac n,
  from or.cases_on hm.eq_two_or_odd
    (λ h2, h2.symm ▸ ⟨1, 1, 0, 0, rfl⟩)
    (odd_prime_sum_four_squares hm) in
let ⟨w, x, y, z, h₂⟩ := sum_four_squares (n / min_fac n) in
⟨(a * x - w * b + (d * y - z * c)).nat_abs,
 (a * y - w * c + (b * z - x * d)).nat_abs,
 (a * z - w * d + (c * x - y * b)).nat_abs,
 (a * w + b * x +  c * y + d * z).nat_abs,
  begin
    rw [← int.coe_nat_inj', ← nat.mul_div_cancel' (min_fac_dvd (k+2)), int.coe_nat_mul, ← h₁, ← h₂],
    simp [nat.pow_two, int.coe_nat_add, int.nat_abs_mul_self'],
    ring,
  end⟩

#print sum_four_squares


/-
Copyright (c) 2021 OpenAI. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kunhao Zheng, Stanislas Polu, David Renshaw, OpenAI GPT-f
-/
import mathzoo.imports.miniF2F

open_locale nat rat real big_operators topological_space

theorem amc12a_2021_p7
  (x : ℝ)
  (y : ℝ) :
  1 ≤ ((x * y) - 1)^2 + (x + y)^2 :=
begin
  ring_nf,
  nlinarith,
end


opaque A : Nat → Type
opaque f (x : Nat) (a : A x) : Nat

example (x : Nat) (a : A (x + 0)) : f (x + 0) a = x := by
  simp
  trace_state -- ⊢ f x a = x
  sorry

example (x : Nat) (a : A (x + 0)) : f (x + 0) a = x := by
  simp (config := { dsimp := false })
  trace_state -- ⊢ f (x + 0) a = x
  sorry


import GMLInit.Prelude

namespace Prod
variable {α β : Type _}

protected theorem eq : {p q : α × β} → (fst : p.fst = q.fst) → (snd : p.snd = q.snd) → p = q
| (_, _), (_, _), rfl, rfl => rfl

abbrev swap {α β} : α × β → β × α
| (a, b) => (b, a)

end Prod

namespace Sigma
variable {α : Type _} {β : α → Type _}

protected theorem eq : {x₁ x₂ : Sigma β} → x₁.fst = x₂.fst → x₁.snd ≅ x₂.snd → x₁ = x₂
| ⟨_, _⟩, ⟨_, _⟩, rfl, HEq.rfl => rfl

protected theorem eta (p : Sigma β) : p = ⟨p.fst, p.snd⟩ := Sigma.eq rfl HEq.rfl

end Sigma

namespace Sum

@[inline] def swap {α β} : Sum α β → Sum β α
| inl a => inr a
| inr b => inl b

end Sum

namespace Ordering

def opp : Ordering → Ordering
| lt => gt
| eq => eq
| gt => lt

theorem opp_opp (x) : opp (opp x) = x := by cases x <;> rfl

theorem opp_inj {x y} : opp x = opp y → x = y := by
  intro h
  rw [←opp_opp x, ←opp_opp y, h]

theorem eq_opp_iff_opp_eq (x y) : opp x = y ↔ x = opp y := by
  constructor
  · intro h; rw [←h, opp_opp]
  · intro h; rw [h, opp_opp]

end Ordering

inductive Index.{u} {α : Type u} : List α → Type u where
| head {a : α} {as : List α} : Index (a :: as)
| tail {a : α} {as : List α} : Index as → Index (a :: as)
deriving Repr

instance Index.instDecidableEq {α} : {xs : List α} → DecidableEq (Index xs)
| _::_, head, head => isTrue rfl
| _::_, head, tail _ => isFalse Index.noConfusion
| _::_, tail _, head => isFalse Index.noConfusion
| _::_, tail i, tail j =>
  match instDecidableEq i j with
  | isTrue rfl => isTrue rfl
  | isFalse h => isFalse fun | rfl => h rfl

@[reducible] def Index.val {α} : {as : List α} → Index as → α
| a::_, head => a
| _::_, tail i => val i

structure Cached {α} (a : α) where
  value : α
  value_eq : value = a

instance {α} (a : α) : Inhabited (Cached a) := ⟨⟨a, rfl⟩⟩

instance {α} (a : α) : Subsingleton (Cached a) := ⟨fun | ⟨_,rfl⟩, ⟨_,rfl⟩ => rfl⟩

instance {α} (a : α) : DecidableEq (Cached a) | ⟨_,rfl⟩, ⟨_,rfl⟩ => isTrue rfl


/-
Copyright (c) 2019 Chris Hughes. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Chris Hughes
-/
import data.list.basic

universes u
variables {α : Type u}

open nat

namespace list

lemma rotate_mod (l : list α) (n : ℕ) : l.rotate (n % l.length) = l.rotate n :=
by simp [rotate]

@[simp] lemma rotate_nil (n : ℕ) : ([] : list α).rotate n = [] := by cases n; simp [rotate]

@[simp] lemma rotate_zero (l : list α) : l.rotate 0 = l := by simp [rotate]

@[simp] lemma rotate'_nil (n : ℕ) : ([] : list α).rotate' n = [] := by cases n; refl

@[simp] lemma rotate'_zero (l : list α) : l.rotate' 0 = l := by cases l; refl

lemma rotate'_cons_succ (l : list α) (a : α) (n : ℕ) :
  (a :: l : list α).rotate' n.succ = (l ++ [a]).rotate' n := by simp [rotate']

@[simp] lemma length_rotate' : ∀ (l : list α) (n : ℕ), (l.rotate' n).length = l.length
| []     n     := rfl
| (a::l) 0     := rfl
| (a::l) (n+1) := by rw [list.rotate', length_rotate' (l ++ [a]) n]; simp

lemma rotate'_eq_take_append_drop : ∀ {l : list α} {n : ℕ}, n ≤ l.length →
  l.rotate' n = l.drop n ++ l.take n
| []     n     h := by simp [drop_append_of_le_length h]
| l      0     h := by simp [take_append_of_le_length h]
| (a::l) (n+1) h :=
have hnl : n ≤ l.length, from le_of_succ_le_succ h,
have hnl' : n ≤ (l ++ [a]).length,
  by rw [length_append, length_cons, list.length, zero_add];
    exact (le_of_succ_le h),
by rw [rotate'_cons_succ, rotate'_eq_take_append_drop hnl', drop, take,
     drop_append_of_le_length hnl, take_append_of_le_length hnl];
   simp

lemma rotate'_rotate' : ∀ (l : list α) (n m : ℕ), (l.rotate' n).rotate' m = l.rotate' (n + m)
| (a::l) 0     m := by simp
| []     n     m := by simp
| (a::l) (n+1) m := by rw [rotate'_cons_succ, rotate'_rotate', add_right_comm, rotate'_cons_succ]

@[simp] lemma rotate'_length (l : list α) : rotate' l l.length = l :=
by rw rotate'_eq_take_append_drop (le_refl _); simp

@[simp] lemma rotate'_length_mul (l : list α) : ∀ n : ℕ, l.rotate' (l.length * n) = l
| 0     := by simp
| (n+1) :=
calc l.rotate' (l.length * (n + 1)) =
  (l.rotate' (l.length * n)).rotate' (l.rotate' (l.length * n)).length :
    by simp [-rotate'_length, nat.mul_succ, rotate'_rotate']
... = l : by rw [rotate'_length, rotate'_length_mul]

lemma rotate'_mod (l : list α) (n : ℕ) : l.rotate' (n % l.length) = l.rotate' n :=
calc l.rotate' (n % l.length) = (l.rotate' (n % l.length)).rotate'
    ((l.rotate' (n % l.length)).length * (n / l.length)) : by rw rotate'_length_mul
... = l.rotate' n : by rw [rotate'_rotate', length_rotate', nat.mod_add_div]

lemma rotate_eq_rotate' (l : list α) (n : ℕ) : l.rotate n = l.rotate' n :=
if h : l.length = 0 then by simp [length_eq_zero, *] at *
else by
  rw [← rotate'_mod, rotate'_eq_take_append_drop (le_of_lt (nat.mod_lt _ (nat.pos_of_ne_zero h)))];
  simp [rotate]

lemma rotate_cons_succ (l : list α) (a : α) (n : ℕ) :
  (a :: l : list α).rotate n.succ = (l ++ [a]).rotate n :=
by rw [rotate_eq_rotate', rotate_eq_rotate', rotate'_cons_succ]

@[simp] lemma mem_rotate : ∀ {l : list α} {a : α} {n : ℕ}, a ∈ l.rotate n ↔ a ∈ l
| []     _ n     := by simp
| (a::l) _ 0     := by simp
| (a::l) _ (n+1) := by simp [rotate_cons_succ, mem_rotate, or.comm]

@[simp] lemma length_rotate (l : list α) (n : ℕ) : (l.rotate n).length = l.length :=
by rw [rotate_eq_rotate', length_rotate']

lemma rotate_eq_take_append_drop {l : list α} {n : ℕ} : n ≤ l.length →
  l.rotate n = l.drop n ++ l.take n :=
by rw rotate_eq_rotate'; exact rotate'_eq_take_append_drop

lemma rotate_rotate (l : list α) (n m : ℕ) : (l.rotate n).rotate m = l.rotate (n + m) :=
by rw [rotate_eq_rotate', rotate_eq_rotate', rotate_eq_rotate', rotate'_rotate']

@[simp] lemma rotate_length (l : list α) : rotate l l.length = l :=
by rw [rotate_eq_rotate', rotate'_length]

@[simp] lemma rotate_length_mul (l : list α) (n : ℕ) : l.rotate (l.length * n) = l :=
by rw [rotate_eq_rotate', rotate'_length_mul]

lemma prod_rotate_eq_one_of_prod_eq_one [group α] : ∀ {l : list α} (hl : l.prod = 1) (n : ℕ),
  (l.rotate n).prod = 1
| []     _  _ := by simp
| (a::l) hl n :=
have n % list.length (a :: l) ≤ list.length (a :: l), from le_of_lt (nat.mod_lt _ dec_trivial),
by rw ← list.take_append_drop (n % list.length (a :: l)) (a :: l) at hl;
  rw [← rotate_mod, rotate_eq_take_append_drop this, list.prod_append, mul_eq_one_iff_inv_eq,
    ← one_mul (list.prod _)⁻¹, ← hl, list.prod_append, mul_assoc, mul_inv_self, mul_one]

end list


/-
Copyright (c) 2020 Thomas Browning and Patrick Lutz. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Thomas Browning, Patrick Lutz

! This file was ported from Lean 3 source module field_theory.abel_ruffini
! leanprover-community/mathlib commit f694c7dead66f5d4c80f446c796a5aad14707f0e
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.GroupTheory.Solvable
import Mathbin.FieldTheory.PolynomialGaloisGroup
import Mathbin.RingTheory.RootsOfUnity

/-!
# The Abel-Ruffini Theorem

This file proves one direction of the Abel-Ruffini theorem, namely that if an element is solvable
by radicals, then its minimal polynomial has solvable Galois group.

## Main definitions

* `solvable_by_rad F E` : the intermediate field of solvable-by-radicals elements

## Main results

* the Abel-Ruffini Theorem `solvable_by_rad.is_solvable'` : An irreducible polynomial with a root
that is solvable by radicals has a solvable Galois group.
-/

noncomputable section

open Classical Polynomial

open Polynomial IntermediateField

section AbelRuffini

variable {F : Type _} [Field F] {E : Type _} [Field E] [Algebra F E]

theorem gal_zero_isSolvable : IsSolvable (0 : F[X]).Gal := by infer_instance
#align gal_zero_is_solvable gal_zero_isSolvable

theorem gal_one_isSolvable : IsSolvable (1 : F[X]).Gal := by infer_instance
#align gal_one_is_solvable gal_one_isSolvable

theorem gal_c_isSolvable (x : F) : IsSolvable (C x).Gal := by infer_instance
#align gal_C_is_solvable gal_c_isSolvable

theorem gal_x_isSolvable : IsSolvable (X : F[X]).Gal := by infer_instance
#align gal_X_is_solvable gal_x_isSolvable

theorem gal_x_sub_c_isSolvable (x : F) : IsSolvable (X - C x).Gal := by infer_instance
#align gal_X_sub_C_is_solvable gal_x_sub_c_isSolvable

theorem gal_x_pow_isSolvable (n : ℕ) : IsSolvable (X ^ n : F[X]).Gal := by infer_instance
#align gal_X_pow_is_solvable gal_x_pow_isSolvable

theorem gal_mul_isSolvable {p q : F[X]} (hp : IsSolvable p.Gal) (hq : IsSolvable q.Gal) :
    IsSolvable (p * q).Gal :=
  solvable_of_solvable_injective (Gal.restrictProd_injective p q)
#align gal_mul_is_solvable gal_mul_isSolvable

theorem gal_prod_isSolvable {s : Multiset F[X]} (hs : ∀ p ∈ s, IsSolvable (Gal p)) :
    IsSolvable s.Prod.Gal := by
  apply Multiset.induction_on' s
  · exact gal_one_isSolvable
  · intro p t hps hts ht
    rw [Multiset.insert_eq_cons, Multiset.prod_cons]
    exact gal_mul_isSolvable (hs p hps) ht
#align gal_prod_is_solvable gal_prod_isSolvable

theorem gal_isSolvable_of_splits {p q : F[X]}
    (hpq : Fact (p.Splits (algebraMap F q.SplittingField))) (hq : IsSolvable q.Gal) :
    IsSolvable p.Gal :=
  haveI : IsSolvable (q.splitting_field ≃ₐ[F] q.splitting_field) := hq
  solvable_of_surjective (AlgEquiv.restrictNormalHom_surjective q.splitting_field)
#align gal_is_solvable_of_splits gal_isSolvable_of_splits

theorem gal_isSolvable_tower (p q : F[X]) (hpq : p.Splits (algebraMap F q.SplittingField))
    (hp : IsSolvable p.Gal) (hq : IsSolvable (q.map (algebraMap F p.SplittingField)).Gal) :
    IsSolvable q.Gal := by
  let K := p.splitting_field
  let L := q.splitting_field
  haveI : Fact (p.splits (algebraMap F L)) := ⟨hpq⟩
  let ϕ : (L ≃ₐ[K] L) ≃* (q.map (algebraMap F K)).Gal :=
    (is_splitting_field.alg_equiv L (q.map (algebraMap F K))).autCongr
  have ϕ_inj : Function.Injective ϕ.to_monoid_hom := ϕ.injective
  haveI : IsSolvable (K ≃ₐ[F] K) := hp
  haveI : IsSolvable (L ≃ₐ[K] L) := solvable_of_solvable_injective ϕ_inj
  exact isSolvable_of_isScalarTower F p.splitting_field q.splitting_field
#align gal_is_solvable_tower gal_isSolvable_tower

section GalXPowSubC

theorem gal_x_pow_sub_one_isSolvable (n : ℕ) : IsSolvable (X ^ n - 1 : F[X]).Gal :=
  by
  by_cases hn : n = 0
  · rw [hn, pow_zero, sub_self]
    exact gal_zero_isSolvable
  have hn' : 0 < n := pos_iff_ne_zero.mpr hn
  have hn'' : (X ^ n - 1 : F[X]) ≠ 0 := X_pow_sub_C_ne_zero hn' 1
  apply isSolvable_of_comm
  intro σ τ
  ext (a ha)
  simp only [mem_root_set_of_ne hn'', map_sub, aeval_X_pow, aeval_one, sub_eq_zero] at ha
  have key : ∀ σ : (X ^ n - 1 : F[X]).Gal, ∃ m : ℕ, σ a = a ^ m :=
    by
    intro σ
    lift n to ℕ+ using hn'
    exact map_root_of_unity_eq_pow_self σ.to_alg_hom (rootsOfUnity.mkOfPowEq a ha)
  obtain ⟨c, hc⟩ := key σ
  obtain ⟨d, hd⟩ := key τ
  rw [σ.mul_apply, τ.mul_apply, hc, τ.map_pow, hd, σ.map_pow, hc, ← pow_mul, pow_mul']
#align gal_X_pow_sub_one_is_solvable gal_x_pow_sub_one_isSolvable

theorem gal_x_pow_sub_c_isSolvable_aux (n : ℕ) (a : F)
    (h : (X ^ n - 1 : F[X]).Splits (RingHom.id F)) : IsSolvable (X ^ n - C a).Gal :=
  by
  by_cases ha : a = 0
  · rw [ha, C_0, sub_zero]
    exact gal_x_pow_isSolvable n
  have ha' : algebraMap F (X ^ n - C a).SplittingField a ≠ 0 :=
    mt ((injective_iff_map_eq_zero _).mp (RingHom.injective _) a) ha
  by_cases hn : n = 0
  · rw [hn, pow_zero, ← C_1, ← C_sub]
    exact gal_c_isSolvable (1 - a)
  have hn' : 0 < n := pos_iff_ne_zero.mpr hn
  have hn'' : X ^ n - C a ≠ 0 := X_pow_sub_C_ne_zero hn' a
  have hn''' : (X ^ n - 1 : F[X]) ≠ 0 := X_pow_sub_C_ne_zero hn' 1
  have mem_range : ∀ {c}, c ^ n = 1 → ∃ d, algebraMap F (X ^ n - C a).SplittingField d = c :=
    fun c hc =>
    ring_hom.mem_range.mp
      (minpoly.mem_range_of_degree_eq_one F c
        (h.def.resolve_left hn'''
          (minpoly.irreducible ((splitting_field.normal (X ^ n - C a)).IsIntegral c))
          (minpoly.dvd F c (by rwa [map_id, AlgHom.map_sub, sub_eq_zero, aeval_X_pow, aeval_one]))))
  apply isSolvable_of_comm
  intro σ τ
  ext (b hb)
  simp only [mem_root_set_of_ne hn'', map_sub, aeval_X_pow, aeval_C, sub_eq_zero] at hb
  have hb' : b ≠ 0 := by
    intro hb'
    rw [hb', zero_pow hn'] at hb
    exact ha' hb.symm
  have key : ∀ σ : (X ^ n - C a).Gal, ∃ c, σ b = b * algebraMap F _ c :=
    by
    intro σ
    have key : (σ b / b) ^ n = 1 := by rw [div_pow, ← σ.map_pow, hb, σ.commutes, div_self ha']
    obtain ⟨c, hc⟩ := mem_range key
    use c
    rw [hc, mul_div_cancel' (σ b) hb']
  obtain ⟨c, hc⟩ := key σ
  obtain ⟨d, hd⟩ := key τ
  rw [σ.mul_apply, τ.mul_apply, hc, τ.map_mul, τ.commutes, hd, σ.map_mul, σ.commutes, hc]
  rw [mul_assoc, mul_assoc, mul_right_inj' hb', mul_comm]
#align gal_X_pow_sub_C_is_solvable_aux gal_x_pow_sub_c_isSolvable_aux

theorem splits_x_pow_sub_one_of_x_pow_sub_c {F : Type _} [Field F] {E : Type _} [Field E]
    (i : F →+* E) (n : ℕ) {a : F} (ha : a ≠ 0) (h : (X ^ n - C a).Splits i) :
    (X ^ n - 1).Splits i :=
  by
  have ha' : i a ≠ 0 := mt ((injective_iff_map_eq_zero i).mp i.injective a) ha
  by_cases hn : n = 0
  · rw [hn, pow_zero, sub_self]
    exact splits_zero i
  have hn' : 0 < n := pos_iff_ne_zero.mpr hn
  have hn'' : (X ^ n - C a).degree ≠ 0 :=
    ne_of_eq_of_ne (degree_X_pow_sub_C hn' a) (mt with_bot.coe_eq_coe.mp hn)
  obtain ⟨b, hb⟩ := exists_root_of_splits i h hn''
  rw [eval₂_sub, eval₂_X_pow, eval₂_C, sub_eq_zero] at hb
  have hb' : b ≠ 0 := by
    intro hb'
    rw [hb', zero_pow hn'] at hb
    exact ha' hb.symm
  let s := ((X ^ n - C a).map i).roots
  have hs : _ = _ * (s.map _).Prod := eq_prod_roots_of_splits h
  rw [leading_coeff_X_pow_sub_C hn', RingHom.map_one, C_1, one_mul] at hs
  have hs' : s.card = n := (nat_degree_eq_card_roots h).symm.trans nat_degree_X_pow_sub_C
  apply @splits_of_exists_multiset F E _ _ i (X ^ n - 1) (s.map fun c : E => c / b)
  rw [leading_coeff_X_pow_sub_one hn', RingHom.map_one, C_1, one_mul, Multiset.map_map]
  have C_mul_C : C (i a⁻¹) * C (i a) = 1 := by
    rw [← C_mul, ← i.map_mul, inv_mul_cancel ha, i.map_one, C_1]
  have key1 : (X ^ n - 1).map i = C (i a⁻¹) * ((X ^ n - C a).map i).comp (C b * X) := by
    rw [Polynomial.map_sub, Polynomial.map_sub, Polynomial.map_pow, map_X, map_C,
      Polynomial.map_one, sub_comp, pow_comp, X_comp, C_comp, mul_pow, ← C_pow, hb, mul_sub, ←
      mul_assoc, C_mul_C, one_mul]
  have key2 :
    ((fun q : E[X] => q.comp (C b * X)) ∘ fun c : E => X - C c) = fun c : E =>
      C b * (X - C (c / b)) :=
    by
    ext1 c
    change (X - C c).comp (C b * X) = C b * (X - C (c / b))
    rw [sub_comp, X_comp, C_comp, mul_sub, ← C_mul, mul_div_cancel' c hb']
  rw [key1, hs, multiset_prod_comp, Multiset.map_map, key2, Multiset.prod_map_mul,
    Multiset.map_const, Multiset.prod_replicate, hs', ← C_pow, hb, ← mul_assoc, C_mul_C, one_mul]
  all_goals exact field.to_nontrivial F
#align splits_X_pow_sub_one_of_X_pow_sub_C splits_x_pow_sub_one_of_x_pow_sub_c

theorem gal_x_pow_sub_c_isSolvable (n : ℕ) (x : F) : IsSolvable (X ^ n - C x).Gal :=
  by
  by_cases hx : x = 0
  · rw [hx, C_0, sub_zero]
    exact gal_x_pow_isSolvable n
  apply gal_isSolvable_tower (X ^ n - 1) (X ^ n - C x)
  · exact splits_x_pow_sub_one_of_x_pow_sub_c _ n hx (splitting_field.splits _)
  · exact gal_x_pow_sub_one_isSolvable n
  · rw [Polynomial.map_sub, Polynomial.map_pow, map_X, map_C]
    apply gal_x_pow_sub_c_isSolvable_aux
    have key := splitting_field.splits (X ^ n - 1 : F[X])
    rwa [← splits_id_iff_splits, Polynomial.map_sub, Polynomial.map_pow, map_X,
      Polynomial.map_one] at key
#align gal_X_pow_sub_C_is_solvable gal_x_pow_sub_c_isSolvable

end GalXPowSubC

variable (F)

/-- Inductive definition of solvable by radicals -/
inductive IsSolvableByRad : E → Prop
  | base (a : F) : IsSolvableByRad (algebraMap F E a)
  | add (a b : E) : IsSolvableByRad a → IsSolvableByRad b → IsSolvableByRad (a + b)
  | neg (α : E) : IsSolvableByRad α → IsSolvableByRad (-α)
  | mul (α β : E) : IsSolvableByRad α → IsSolvableByRad β → IsSolvableByRad (α * β)
  | inv (α : E) : IsSolvableByRad α → IsSolvableByRad α⁻¹
  | rad (α : E) (n : ℕ) (hn : n ≠ 0) : IsSolvableByRad (α ^ n) → IsSolvableByRad α
#align is_solvable_by_rad IsSolvableByRad

variable (E)

/-- The intermediate field of solvable-by-radicals elements -/
def solvableByRad : IntermediateField F E
    where
  carrier := IsSolvableByRad F
  zero_mem' := by
    convert IsSolvableByRad.base (0 : F)
    rw [RingHom.map_zero]
  add_mem' := IsSolvableByRad.add
  neg_mem' := IsSolvableByRad.neg
  one_mem' := by
    convert IsSolvableByRad.base (1 : F)
    rw [RingHom.map_one]
  mul_mem' := IsSolvableByRad.mul
  inv_mem' := IsSolvableByRad.inv
  algebraMap_mem' := IsSolvableByRad.base
#align solvable_by_rad solvableByRad

namespace solvableByRad

variable {F} {E} {α : E}

theorem induction (P : solvableByRad F E → Prop)
    (base : ∀ α : F, P (algebraMap F (solvableByRad F E) α))
    (add : ∀ α β : solvableByRad F E, P α → P β → P (α + β))
    (neg : ∀ α : solvableByRad F E, P α → P (-α))
    (mul : ∀ α β : solvableByRad F E, P α → P β → P (α * β))
    (inv : ∀ α : solvableByRad F E, P α → P α⁻¹)
    (rad : ∀ α : solvableByRad F E, ∀ n : ℕ, n ≠ 0 → P (α ^ n) → P α) (α : solvableByRad F E) :
    P α := by
  revert α
  suffices ∀ α : E, IsSolvableByRad F α → ∃ β : solvableByRad F E, ↑β = α ∧ P β
    by
    intro α
    obtain ⟨α₀, hα₀, Pα⟩ := this α (Subtype.mem α)
    convert Pα
    exact Subtype.ext hα₀.symm
  apply IsSolvableByRad.ndrec
  · exact fun α => ⟨algebraMap F (solvableByRad F E) α, rfl, base α⟩
  · intro α β hα hβ Pα Pβ
    obtain ⟨⟨α₀, hα₀, Pα⟩, β₀, hβ₀, Pβ⟩ := Pα, Pβ
    exact
      ⟨α₀ + β₀, by
        rw [← hα₀, ← hβ₀]
        rfl, add α₀ β₀ Pα Pβ⟩
  · intro α hα Pα
    obtain ⟨α₀, hα₀, Pα⟩ := Pα
    exact
      ⟨-α₀, by
        rw [← hα₀]
        rfl, neg α₀ Pα⟩
  · intro α β hα hβ Pα Pβ
    obtain ⟨⟨α₀, hα₀, Pα⟩, β₀, hβ₀, Pβ⟩ := Pα, Pβ
    exact
      ⟨α₀ * β₀, by
        rw [← hα₀, ← hβ₀]
        rfl, mul α₀ β₀ Pα Pβ⟩
  · intro α hα Pα
    obtain ⟨α₀, hα₀, Pα⟩ := Pα
    exact
      ⟨α₀⁻¹, by
        rw [← hα₀]
        rfl, inv α₀ Pα⟩
  · intro α n hn hα Pα
    obtain ⟨α₀, hα₀, Pα⟩ := Pα
    refine' ⟨⟨α, IsSolvableByRad.rad α n hn hα⟩, rfl, rad _ n hn _⟩
    convert Pα
    exact Subtype.ext (Eq.trans ((solvableByRad F E).val_pow_eq_pow_val _ n) hα₀.symm)
#align solvable_by_rad.induction solvableByRad.induction

theorem isIntegral (α : solvableByRad F E) : IsIntegral F α :=
  by
  revert α
  apply solvableByRad.induction
  · exact fun _ => isIntegral_algebraMap
  · exact fun _ _ => isIntegral_add
  · exact fun _ => isIntegral_neg
  · exact fun _ _ => isIntegral_mul
  ·
    exact fun α hα =>
      Subalgebra.inv_mem_of_algebraic (integralClosure F (solvableByRad F E))
        (show IsAlgebraic F ↑(⟨α, hα⟩ : integralClosure F (solvableByRad F E)) from
          is_algebraic_iff_is_integral.mpr hα)
  · intro α n hn hα
    obtain ⟨p, h1, h2⟩ := is_algebraic_iff_is_integral.mpr hα
    refine'
      is_algebraic_iff_is_integral.mp
        ⟨p.comp (X ^ n),
          ⟨fun h => h1 (leading_coeff_eq_zero.mp _), by rw [aeval_comp, aeval_X_pow, h2]⟩⟩
    rwa [← leading_coeff_eq_zero, leading_coeff_comp, leading_coeff_X_pow, one_pow, mul_one] at h
    rwa [nat_degree_X_pow]
#align solvable_by_rad.is_integral solvableByRad.isIntegral

/-- The statement to be proved inductively -/
def P (α : solvableByRad F E) : Prop :=
  IsSolvable (minpoly F α).Gal
#align solvable_by_rad.P solvableByRad.P

/-- An auxiliary induction lemma, which is generalized by `solvable_by_rad.is_solvable`. -/
theorem induction3 {α : solvableByRad F E} {n : ℕ} (hn : n ≠ 0) (hα : P (α ^ n)) : P α :=
  by
  let p := minpoly F (α ^ n)
  have hp : p.comp (X ^ n) ≠ 0 := by
    intro h
    cases' comp_eq_zero_iff.mp h with h' h'
    · exact minpoly.ne_zero (IsIntegral (α ^ n)) h'
    · exact hn (by rw [← nat_degree_C _, ← h'.2, nat_degree_X_pow])
  apply gal_isSolvable_of_splits
  ·
    exact
      ⟨splits_of_splits_of_dvd _ hp (splitting_field.splits (p.comp (X ^ n)))
          (minpoly.dvd F α (by rw [aeval_comp, aeval_X_pow, minpoly.aeval]))⟩
  · refine' gal_isSolvable_tower p (p.comp (X ^ n)) _ hα _
    · exact gal.splits_in_splitting_field_of_comp _ _ (by rwa [nat_degree_X_pow])
    · obtain ⟨s, hs⟩ := (splits_iff_exists_multiset _).1 (splitting_field.splits p)
      rw [map_comp, Polynomial.map_pow, map_X, hs, mul_comp, C_comp]
      apply gal_mul_isSolvable (gal_c_isSolvable _)
      rw [multiset_prod_comp]
      apply gal_prod_isSolvable
      intro q hq
      rw [Multiset.mem_map] at hq
      obtain ⟨q, hq, rfl⟩ := hq
      rw [Multiset.mem_map] at hq
      obtain ⟨q, hq, rfl⟩ := hq
      rw [sub_comp, X_comp, C_comp]
      exact gal_x_pow_sub_c_isSolvable n q
#align solvable_by_rad.induction3 solvableByRad.induction3

/- ./././Mathport/Syntax/Translate/Expr.lean:192:11: unsupported (impossible) -/
/- ./././Mathport/Syntax/Translate/Expr.lean:192:11: unsupported (impossible) -/
/- ./././Mathport/Syntax/Translate/Expr.lean:192:11: unsupported (impossible) -/
/- ./././Mathport/Syntax/Translate/Expr.lean:192:11: unsupported (impossible) -/
/-- An auxiliary induction lemma, which is generalized by `solvable_by_rad.is_solvable`. -/
theorem induction2 {α β γ : solvableByRad F E} (hγ : γ ∈ F⟮⟯) (hα : P α) (hβ : P β) : P γ :=
  by
  let p := minpoly F α
  let q := minpoly F β
  have hpq :=
    Polynomial.splits_of_splits_mul _
      (mul_ne_zero (minpoly.ne_zero (IsIntegral α)) (minpoly.ne_zero (IsIntegral β)))
      (splitting_field.splits (p * q))
  let f : F⟮⟯ →ₐ[F] (p * q).SplittingField :=
    Classical.choice
      (alg_hom_mk_adjoin_splits
        (by
          intro x hx
          cases hx
          rw [hx]
          exact ⟨IsIntegral α, hpq.1⟩
          cases hx
          exact ⟨IsIntegral β, hpq.2⟩))
  have key : minpoly F γ = minpoly F (f ⟨γ, hγ⟩) :=
    minpoly.eq_of_irreducible_of_monic (minpoly.irreducible (IsIntegral γ))
      (by
        suffices aeval (⟨γ, hγ⟩ : F⟮⟯) (minpoly F γ) = 0 by
          rw [aeval_alg_hom_apply, this, AlgHom.map_zero]
        apply (algebraMap F⟮⟯ (solvableByRad F E)).Injective
        rw [RingHom.map_zero, ← aeval_algebra_map_apply]
        exact minpoly.aeval F γ)
      (minpoly.monic (IsIntegral γ))
  rw [P, key]
  exact
    gal_isSolvable_of_splits ⟨Normal.splits (splitting_field.normal _) _⟩ (gal_mul_isSolvable hα hβ)
#align solvable_by_rad.induction2 solvableByRad.induction2

/- ./././Mathport/Syntax/Translate/Expr.lean:192:11: unsupported (impossible) -/
/-- An auxiliary induction lemma, which is generalized by `solvable_by_rad.is_solvable`. -/
theorem induction1 {α β : solvableByRad F E} (hβ : β ∈ F⟮⟯) (hα : P α) : P β :=
  induction2 (adjoin.mono F _ _ (ge_of_eq (Set.pair_eq_singleton α)) hβ) hα hα
#align solvable_by_rad.induction1 solvableByRad.induction1

theorem isSolvable (α : solvableByRad F E) : IsSolvable (minpoly F α).Gal :=
  by
  revert α
  apply solvableByRad.induction
  ·
    exact fun α => by
      rw [minpoly.eq_x_sub_c]
      exact gal_x_sub_c_isSolvable α
  ·
    exact fun α β =>
      induction2
        (add_mem (subset_adjoin F _ (Set.mem_insert α _))
          (subset_adjoin F _ (Set.mem_insert_of_mem α (Set.mem_singleton β))))
  · exact fun α => induction1 (neg_mem (mem_adjoin_simple_self F α))
  ·
    exact fun α β =>
      induction2
        (mul_mem (subset_adjoin F _ (Set.mem_insert α _))
          (subset_adjoin F _ (Set.mem_insert_of_mem α (Set.mem_singleton β))))
  · exact fun α => induction1 (inv_mem (mem_adjoin_simple_self F α))
  · exact fun α n => induction3
#align solvable_by_rad.is_solvable solvableByRad.isSolvable

/-- **Abel-Ruffini Theorem** (one direction): An irreducible polynomial with an
`is_solvable_by_rad` root has solvable Galois group -/
theorem is_solvable' {α : E} {q : F[X]} (q_irred : Irreducible q) (q_aeval : aeval α q = 0)
    (hα : IsSolvableByRad F α) : IsSolvable q.Gal :=
  by
  have : _root_.is_solvable (q * C q.leading_coeff⁻¹).Gal :=
    by
    rw [minpoly.eq_of_irreducible q_irred q_aeval, ←
      show minpoly F (⟨α, hα⟩ : solvableByRad F E) = minpoly F α from
        minpoly.eq_of_algebraMap_eq (RingHom.injective _) (IsIntegral ⟨α, hα⟩) rfl]
    exact IsSolvable ⟨α, hα⟩
  refine' solvable_of_surjective (gal.restrict_dvd_surjective ⟨C q.leading_coeff⁻¹, rfl⟩ _)
  rw [mul_ne_zero_iff, Ne, Ne, C_eq_zero, inv_eq_zero]
  exact ⟨q_irred.ne_zero, leading_coeff_ne_zero.mpr q_irred.ne_zero⟩
#align solvable_by_rad.is_solvable' solvableByRad.is_solvable'

end solvableByRad

end AbelRuffini


/-
Copyright (c) 2014 Jeremy Avigad. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Jeremy Avigad, Mario Carneiro, Yaël Dillies
-/
import order.compare
import order.max
import order.rel_classes

/-!
# Monotonicity

This file defines (strictly) monotone/antitone functions. Contrary to standard mathematical usage,
"monotone"/"mono" here means "increasing", not "increasing or decreasing". We use "antitone"/"anti"
to mean "decreasing".

## Definitions

* `monotone f`: A function `f` between two preorders is monotone if `a ≤ b` implies `f a ≤ f b`.
* `antitone f`: A function `f` between two preorders is antitone if `a ≤ b` implies `f b ≤ f a`.
* `monotone_on f s`: Same as `monotone f`, but for all `a, b ∈ s`.
* `antitone_on f s`: Same as `antitone f`, but for all `a, b ∈ s`.
* `strict_mono f` : A function `f` between two preorders is strictly monotone if `a < b` implies
  `f a < f b`.
* `strict_anti f` : A function `f` between two preorders is strictly antitone if `a < b` implies
  `f b < f a`.
* `strict_mono_on f s`: Same as `strict_mono f`, but for all `a, b ∈ s`.
* `strict_anti_on f s`: Same as `strict_anti f`, but for all `a, b ∈ s`.

## Main theorems

* `monotone_nat_of_le_succ`, `monotone_int_of_le_succ`: If `f : ℕ → α` or `f : ℤ → α` and
  `f n ≤ f (n + 1)` for all `n`, then `f` is monotone.
* `antitone_nat_of_succ_le`, `antitone_int_of_succ_le`: If `f : ℕ → α` or `f : ℤ → α` and
  `f (n + 1) ≤ f n` for all `n`, then `f` is antitone.
* `strict_mono_nat_of_lt_succ`, `strict_mono_int_of_lt_succ`: If `f : ℕ → α` or `f : ℤ → α` and
  `f n < f (n + 1)` for all `n`, then `f` is strictly monotone.
* `strict_anti_nat_of_succ_lt`, `strict_anti_int_of_succ_lt`: If `f : ℕ → α` or `f : ℤ → α` and
  `f (n + 1) < f n` for all `n`, then `f` is strictly antitone.

## Implementation notes

Some of these definitions used to only require `has_le α` or `has_lt α`. The advantage of this is
unclear and it led to slight elaboration issues. Now, everything requires `preorder α` and seems to
work fine. Related Zulip discussion:
https://leanprover.zulipchat.com/#narrow/stream/113488-general/topic/Order.20diamond/near/254353352.

## TODO

The above theorems are also true in `ℕ+`, `fin n`... To make that work, we need `succ_order α`
and `succ_archimedean α`.

## Tags

monotone, strictly monotone, antitone, strictly antitone, increasing, strictly increasing,
decreasing, strictly decreasing
-/

open function order_dual

universes u v w
variables {α : Type u} {β : Type v} {γ : Type w} {δ : Type*} {r : α → α → Prop}

section monotone_def
variables [preorder α] [preorder β]

/-- A function `f` is monotone if `a ≤ b` implies `f a ≤ f b`. -/
def monotone (f : α → β) : Prop := ∀ ⦃a b⦄, a ≤ b → f a ≤ f b

/-- A function `f` is antitone if `a ≤ b` implies `f b ≤ f a`. -/
def antitone (f : α → β) : Prop := ∀ ⦃a b⦄, a ≤ b → f b ≤ f a

/-- A function `f` is monotone on `s` if, for all `a, b ∈ s`, `a ≤ b` implies `f a ≤ f b`. -/
def monotone_on (f : α → β) (s : set α) : Prop :=
∀ ⦃a⦄ (ha : a ∈ s) ⦃b⦄ (hb : b ∈ s), a ≤ b → f a ≤ f b

/-- A function `f` is antitone on `s` if, for all `a, b ∈ s`, `a ≤ b` implies `f b ≤ f a`. -/
def antitone_on (f : α → β) (s : set α) : Prop :=
∀ ⦃a⦄ (ha : a ∈ s) ⦃b⦄ (hb : b ∈ s), a ≤ b → f b ≤ f a

/-- A function `f` is strictly monotone if `a < b` implies `f a < f b`. -/
def strict_mono (f : α → β) : Prop :=
∀ ⦃a b⦄, a < b → f a < f b

/-- A function `f` is strictly antitone if `a < b` implies `f b < f a`. -/
def strict_anti (f : α → β) : Prop :=
∀ ⦃a b⦄, a < b → f b < f a

/-- A function `f` is strictly monotone on `s` if, for all `a, b ∈ s`, `a < b` implies
`f a < f b`. -/
def strict_mono_on (f : α → β) (s : set α) : Prop :=
∀ ⦃a⦄ (ha : a ∈ s) ⦃b⦄ (hb : b ∈ s), a < b → f a < f b

/-- A function `f` is strictly antitone on `s` if, for all `a, b ∈ s`, `a < b` implies
`f b < f a`. -/
def strict_anti_on (f : α → β) (s : set α) : Prop :=
∀ ⦃a⦄ (ha : a ∈ s) ⦃b⦄ (hb : b ∈ s), a < b → f b < f a

end monotone_def

/-! ### Monotonicity on the dual order

Strictly, many of the `*_on.dual` lemmas in this section should use `of_dual ⁻¹' s` instead of `s`,
but right now this is not possible as `set.preimage` is not defined yet, and importing it creates
an import cycle.

Often, you should not need the rewriting lemmas. Instead, you probably want to add `.dual`,
`.dual_left` or `.dual_right` to your `monotone`/`antitone` hypothesis.
-/

section order_dual

variables [preorder α] [preorder β] {f : α → β} {s : set α}

@[simp] lemma monotone_comp_of_dual_iff : monotone (f ∘ of_dual) ↔ antitone f := forall_swap
@[simp] lemma antitone_comp_of_dual_iff : antitone (f ∘ of_dual) ↔ monotone f := forall_swap
@[simp] lemma monotone_to_dual_comp_iff : monotone (to_dual ∘ f) ↔ antitone f := iff.rfl
@[simp] lemma antitone_to_dual_comp_iff : antitone (to_dual ∘ f) ↔ monotone f := iff.rfl

@[simp] lemma monotone_on_comp_of_dual_iff : monotone_on (f ∘ of_dual) s ↔ antitone_on f s :=
forall₂_swap
@[simp] lemma antitone_on_comp_of_dual_iff : antitone_on (f ∘ of_dual) s ↔ monotone_on f s :=
forall₂_swap
@[simp] lemma monotone_on_to_dual_comp_iff : monotone_on (to_dual ∘ f) s ↔ antitone_on f s :=
iff.rfl
@[simp] lemma antitone_on_to_dual_comp_iff : antitone_on (to_dual ∘ f) s ↔ monotone_on f s :=
iff.rfl

@[simp] lemma strict_mono_comp_of_dual_iff : strict_mono (f ∘ of_dual) ↔ strict_anti f :=
forall_swap
@[simp] lemma strict_anti_comp_of_dual_iff : strict_anti (f ∘ of_dual) ↔ strict_mono f :=
forall_swap
@[simp] lemma strict_mono_to_dual_comp_iff : strict_mono (to_dual ∘ f) ↔ strict_anti f := iff.rfl
@[simp] lemma strict_anti_to_dual_comp_iff : strict_anti (to_dual ∘ f) ↔ strict_mono f := iff.rfl

@[simp] lemma strict_mono_on_comp_of_dual_iff :
  strict_mono_on (f ∘ of_dual) s ↔ strict_anti_on f s := forall₂_swap
@[simp] lemma strict_anti_on_comp_of_dual_iff :
  strict_anti_on (f ∘ of_dual) s ↔ strict_mono_on f s := forall₂_swap
@[simp] lemma strict_mono_on_to_dual_comp_iff :
  strict_mono_on (to_dual ∘ f) s ↔ strict_anti_on f s := iff.rfl
@[simp] lemma strict_anti_on_to_dual_comp_iff :
  strict_anti_on (to_dual ∘ f) s ↔ strict_mono_on f s := iff.rfl

protected lemma monotone.dual (hf : monotone f) : monotone (to_dual ∘ f ∘ of_dual) := swap hf
protected lemma antitone.dual (hf : antitone f) : antitone (to_dual ∘ f ∘ of_dual) := swap hf
protected lemma monotone_on.dual (hf : monotone_on f s) : monotone_on (to_dual ∘ f ∘ of_dual) s :=
swap₂ hf
protected lemma antitone_on.dual (hf : antitone_on f s) : antitone_on (to_dual ∘ f ∘ of_dual) s :=
swap₂ hf
protected lemma strict_mono.dual (hf : strict_mono f) : strict_mono (to_dual ∘ f ∘ of_dual) :=
swap hf
protected lemma strict_anti.dual (hf : strict_anti f) : strict_anti (to_dual ∘ f ∘ of_dual) :=
swap hf
protected lemma strict_mono_on.dual (hf : strict_mono_on f s) :
  strict_mono_on (to_dual ∘ f ∘ of_dual) s := swap₂ hf
protected lemma strict_anti_on.dual (hf : strict_anti_on f s) :
  strict_anti_on (to_dual ∘ f ∘ of_dual) s := swap₂ hf

alias antitone_comp_of_dual_iff ↔ _ monotone.dual_left
alias monotone_comp_of_dual_iff ↔ _ antitone.dual_left
alias antitone_to_dual_comp_iff ↔ _ monotone.dual_right
alias monotone_to_dual_comp_iff ↔ _ antitone.dual_right
alias antitone_on_comp_of_dual_iff ↔ _ monotone_on.dual_left
alias monotone_on_comp_of_dual_iff ↔ _ antitone_on.dual_left
alias antitone_on_to_dual_comp_iff ↔ _ monotone_on.dual_right
alias monotone_on_to_dual_comp_iff ↔ _ antitone_on.dual_right
alias strict_anti_comp_of_dual_iff ↔ _ strict_mono.dual_left
alias strict_mono_comp_of_dual_iff ↔ _ strict_anti.dual_left
alias strict_anti_to_dual_comp_iff ↔ _ strict_mono.dual_right
alias strict_mono_to_dual_comp_iff ↔ _ strict_anti.dual_right
alias strict_anti_on_comp_of_dual_iff ↔ _ strict_mono_on.dual_left
alias strict_mono_on_comp_of_dual_iff ↔ _ strict_anti_on.dual_left
alias strict_anti_on_to_dual_comp_iff ↔ _ strict_mono_on.dual_right
alias strict_mono_on_to_dual_comp_iff ↔ _ strict_anti_on.dual_right

end order_dual

/-! ### Monotonicity in function spaces -/

section preorder
variables [preorder α]

theorem monotone.comp_le_comp_left [preorder β]
  {f : β → α} {g h : γ → β} (hf : monotone f) (le_gh : g ≤ h) :
  has_le.le.{max w u} (f ∘ g) (f ∘ h) :=
λ x, hf (le_gh x)

variables [preorder γ]

theorem monotone_lam {f : α → β → γ} (hf : ∀ b, monotone (λ a, f a b)) : monotone f :=
λ a a' h b, hf b h

theorem monotone_app (f : β → α → γ) (b : β) (hf : monotone (λ a b, f b a)) : monotone (f b) :=
λ a a' h, hf h b

theorem antitone_lam {f : α → β → γ} (hf : ∀ b, antitone (λ a, f a b)) : antitone f :=
λ a a' h b, hf b h

theorem antitone_app (f : β → α → γ) (b : β) (hf : antitone (λ a b, f b a)) : antitone (f b) :=
λ a a' h, hf h b

end preorder

lemma function.monotone_eval {ι : Type u} {α : ι → Type v} [∀ i, preorder (α i)] (i : ι) :
  monotone (function.eval i : (Π i, α i) → α i) :=
λ f g H, H i

/-! ### Monotonicity hierarchy -/

section preorder
variables [preorder α]

section preorder
variables [preorder β] {f : α → β} {a b : α}

/-!
These four lemmas are there to strip off the semi-implicit arguments `⦃a b : α⦄`. This is useful
when you do not want to apply a `monotone` assumption (i.e. your goal is `a ≤ b → f a ≤ f b`).
However if you find yourself writing `hf.imp h`, then you should have written `hf h` instead.
-/

lemma monotone.imp (hf : monotone f) (h : a ≤ b) : f a ≤ f b := hf h
lemma antitone.imp (hf : antitone f) (h : a ≤ b) : f b ≤ f a := hf h
lemma strict_mono.imp (hf : strict_mono f) (h : a < b) : f a < f b := hf h
lemma strict_anti.imp (hf : strict_anti f) (h : a < b) : f b < f a := hf h

protected lemma monotone.monotone_on (hf : monotone f) (s : set α) : monotone_on f s :=
λ a _ b _, hf.imp

protected lemma antitone.antitone_on (hf : antitone f) (s : set α) : antitone_on f s :=
λ a _ b _, hf.imp

lemma monotone_on_univ : monotone_on f set.univ ↔ monotone f :=
⟨λ h a b, h trivial trivial, λ h, h.monotone_on _⟩

lemma antitone_on_univ : antitone_on f set.univ ↔ antitone f :=
⟨λ h a b, h trivial trivial, λ h, h.antitone_on _⟩

protected lemma strict_mono.strict_mono_on (hf : strict_mono f) (s : set α) : strict_mono_on f s :=
λ a _ b _, hf.imp

protected lemma strict_anti.strict_anti_on (hf : strict_anti f) (s : set α) : strict_anti_on f s :=
λ a _ b _, hf.imp

lemma strict_mono_on_univ : strict_mono_on f set.univ ↔ strict_mono f :=
⟨λ h a b, h trivial trivial, λ h, h.strict_mono_on _⟩

lemma strict_anti_on_univ : strict_anti_on f set.univ ↔ strict_anti f :=
⟨λ h a b, h trivial trivial, λ h, h.strict_anti_on _⟩

end preorder

section partial_order
variables [partial_order β] {f : α → β}

lemma monotone.strict_mono_of_injective (h₁ : monotone f) (h₂ : injective f) : strict_mono f :=
λ a b h, (h₁ h.le).lt_of_ne (λ H, h.ne $ h₂ H)

lemma antitone.strict_anti_of_injective (h₁ : antitone f) (h₂ : injective f) : strict_anti f :=
λ a b h, (h₁ h.le).lt_of_ne (λ H, h.ne $ h₂ H.symm)

end partial_order
end preorder

section partial_order
variables [partial_order α] [preorder β] {f : α → β} {s : set α}

lemma monotone_iff_forall_lt : monotone f ↔ ∀ ⦃a b⦄, a < b → f a ≤ f b :=
forall₂_congr $ λ a b, ⟨λ hf h, hf h.le, λ hf h, h.eq_or_lt.elim (λ H, (congr_arg _ H).le) hf⟩

lemma antitone_iff_forall_lt : antitone f ↔ ∀ ⦃a b⦄, a < b → f b ≤ f a :=
forall₂_congr $ λ a b, ⟨λ hf h, hf h.le, λ hf h, h.eq_or_lt.elim (λ H, (congr_arg _ H).ge) hf⟩

lemma monotone_on_iff_forall_lt :
  monotone_on f s ↔ ∀ ⦃a⦄ (ha : a ∈ s) ⦃b⦄ (hb : b ∈ s), a < b → f a ≤ f b :=
⟨λ hf a ha b hb h, hf ha hb h.le,
  λ hf a ha b hb h, h.eq_or_lt.elim (λ H, (congr_arg _ H).le) (hf ha hb)⟩

lemma antitone_on_iff_forall_lt :
  antitone_on f s ↔ ∀ ⦃a⦄ (ha : a ∈ s) ⦃b⦄ (hb : b ∈ s), a < b → f b ≤ f a :=
⟨λ hf a ha b hb h, hf ha hb h.le,
  λ hf a ha b hb h, h.eq_or_lt.elim (λ H, (congr_arg _ H).ge) (hf ha hb)⟩

-- `preorder α` isn't strong enough: if the preorder on `α` is an equivalence relation,
-- then `strict_mono f` is vacuously true.
protected lemma strict_mono_on.monotone_on (hf : strict_mono_on f s) : monotone_on f s :=
monotone_on_iff_forall_lt.2 $ λ a ha b hb h, (hf ha hb h).le

protected lemma strict_anti_on.antitone_on (hf : strict_anti_on f s) : antitone_on f s :=
antitone_on_iff_forall_lt.2 $ λ a ha b hb h, (hf ha hb h).le

protected lemma strict_mono.monotone (hf : strict_mono f) : monotone f :=
monotone_iff_forall_lt.2 $ λ a b h, (hf h).le

protected lemma strict_anti.antitone (hf : strict_anti f) : antitone f :=
antitone_iff_forall_lt.2 $ λ a b h, (hf h).le

end partial_order

/-! ### Monotonicity from and to subsingletons -/

namespace subsingleton
variables [preorder α] [preorder β]

protected lemma monotone [subsingleton α] (f : α → β) : monotone f :=
λ a b _, (congr_arg _ $ subsingleton.elim _ _).le

protected lemma antitone [subsingleton α] (f : α → β) : antitone f :=
λ a b _, (congr_arg _ $ subsingleton.elim _ _).le

lemma monotone' [subsingleton β] (f : α → β) : monotone f := λ a b _, (subsingleton.elim _ _).le
lemma antitone' [subsingleton β] (f : α → β) : antitone f := λ a b _, (subsingleton.elim _ _).le

protected lemma strict_mono [subsingleton α] (f : α → β) : strict_mono f :=
λ a b h, (h.ne $ subsingleton.elim _ _).elim

protected lemma strict_anti [subsingleton α] (f : α → β) : strict_anti f :=
λ a b h, (h.ne $ subsingleton.elim _ _).elim

end subsingleton

/-! ### Miscellaneous monotonicity results -/

lemma monotone_id [preorder α] : monotone (id : α → α) := λ a b, id

lemma strict_mono_id [preorder α] : strict_mono (id : α → α) := λ a b, id

theorem monotone_const [preorder α] [preorder β] {c : β} : monotone (λ (a : α), c) :=
λ a b _, le_refl c

theorem antitone_const [preorder α] [preorder β] {c : β} : antitone (λ (a : α), c) :=
λ a b _, le_refl c

lemma strict_mono_of_le_iff_le [preorder α] [preorder β] {f : α → β}
  (h : ∀ x y, x ≤ y ↔ f x ≤ f y) : strict_mono f :=
λ a b, (lt_iff_lt_of_le_iff_le' (h _ _) (h _ _)).1

lemma injective_of_lt_imp_ne [linear_order α] {f : α → β} (h : ∀ x y, x < y → f x ≠ f y) :
  injective f :=
begin
  intros x y hxy,
  contrapose hxy,
  cases ne.lt_or_lt hxy with hxy hxy,
  exacts [h _ _ hxy, (h _ _ hxy).symm]
end

lemma injective_of_le_imp_le [partial_order α] [preorder β] (f : α → β)
  (h : ∀ {x y}, f x ≤ f y → x ≤ y) : injective f :=
λ x y hxy, (h hxy.le).antisymm (h hxy.ge)

section preorder
variables [preorder α] [preorder β] {f g : α → β} {a : α}

lemma strict_mono.is_max_of_apply (hf : strict_mono f) (ha : is_max (f a)) : is_max a :=
of_not_not $ λ h, let ⟨b, hb⟩ := not_is_max_iff.1 h in (hf hb).not_is_max ha

lemma strict_mono.is_min_of_apply (hf : strict_mono f) (ha : is_min (f a)) : is_min a :=
of_not_not $ λ h, let ⟨b, hb⟩ := not_is_min_iff.1 h in (hf hb).not_is_min ha

lemma strict_anti.is_max_of_apply (hf : strict_anti f) (ha : is_min (f a)) : is_max a :=
of_not_not $ λ h, let ⟨b, hb⟩ := not_is_max_iff.1 h in (hf hb).not_is_min ha

lemma strict_anti.is_min_of_apply (hf : strict_anti f) (ha : is_max (f a)) : is_min a :=
of_not_not $ λ h, let ⟨b, hb⟩ := not_is_min_iff.1 h in (hf hb).not_is_max ha

protected lemma strict_mono.ite' (hf : strict_mono f) (hg : strict_mono g) {p : α → Prop}
  [decidable_pred p] (hp : ∀ ⦃x y⦄, x < y → p y → p x)
  (hfg : ∀ ⦃x y⦄, p x → ¬p y → x < y → f x < g y) :
  strict_mono (λ x, if p x then f x else g x) :=
begin
  intros x y h,
  by_cases hy : p y,
  { have hx : p x := hp h hy,
    simpa [hx, hy] using hf h },
  by_cases hx : p x,
  { simpa [hx, hy] using hfg hx hy h },
  { simpa [hx, hy] using hg h}
end

protected lemma strict_mono.ite (hf : strict_mono f) (hg : strict_mono g) {p : α → Prop}
  [decidable_pred p] (hp : ∀ ⦃x y⦄, x < y → p y → p x) (hfg : ∀ x, f x ≤ g x) :
  strict_mono (λ x, if p x then f x else g x) :=
hf.ite' hg hp $ λ x y hx hy h, (hf h).trans_le (hfg y)

protected lemma strict_anti.ite' (hf : strict_anti f) (hg : strict_anti g) {p : α → Prop}
  [decidable_pred p] (hp : ∀ ⦃x y⦄, x < y → p y → p x)
  (hfg : ∀ ⦃x y⦄, p x → ¬p y → x < y → g y < f x) :
  strict_anti (λ x, if p x then f x else g x) :=
(strict_mono.ite' hf.dual_right hg.dual_right hp hfg).dual_right

protected lemma strict_anti.ite (hf : strict_anti f) (hg : strict_anti g) {p : α → Prop}
  [decidable_pred p] (hp : ∀ ⦃x y⦄, x < y → p y → p x) (hfg : ∀ x, g x ≤ f x) :
  strict_anti (λ x, if p x then f x else g x) :=
hf.ite' hg hp $ λ x y hx hy h, (hfg y).trans_lt (hf h)

end preorder

/-! ### Monotonicity under composition -/

section composition
variables [preorder α] [preorder β] [preorder γ] {g : β → γ} {f : α → β} {s : set α}

protected lemma monotone.comp (hg : monotone g) (hf : monotone f) :
  monotone (g ∘ f) :=
λ a b h, hg (hf h)

lemma monotone.comp_antitone (hg : monotone g) (hf : antitone f) :
  antitone (g ∘ f) :=
λ a b h, hg (hf h)

protected lemma antitone.comp (hg : antitone g) (hf : antitone f) :
  monotone (g ∘ f) :=
λ a b h, hg (hf h)

lemma antitone.comp_monotone (hg : antitone g) (hf : monotone f) :
  antitone (g ∘ f) :=
λ a b h, hg (hf h)

protected lemma monotone.iterate {f : α → α} (hf : monotone f) (n : ℕ) : monotone (f^[n]) :=
nat.rec_on n monotone_id (λ n h, h.comp hf)

protected lemma monotone.comp_monotone_on (hg : monotone g) (hf : monotone_on f s) :
  monotone_on (g ∘ f) s :=
λ a ha b hb h, hg (hf ha hb h)

lemma monotone.comp_antitone_on (hg : monotone g) (hf : antitone_on f s) :
  antitone_on (g ∘ f) s :=
λ a ha b hb h, hg (hf ha hb h)

protected lemma antitone.comp_antitone_on (hg : antitone g) (hf : antitone_on f s) :
  monotone_on (g ∘ f) s :=
λ a ha b hb h, hg (hf ha hb h)

lemma antitone.comp_monotone_on (hg : antitone g) (hf : monotone_on f s) :
  antitone_on (g ∘ f) s :=
λ a ha b hb h, hg (hf ha hb h)

protected lemma strict_mono.comp (hg : strict_mono g) (hf : strict_mono f) :
  strict_mono (g ∘ f) :=
λ a b h, hg (hf h)

lemma strict_mono.comp_strict_anti (hg : strict_mono g) (hf : strict_anti f) :
  strict_anti (g ∘ f) :=
λ a b h, hg (hf h)

protected lemma strict_anti.comp (hg : strict_anti g) (hf : strict_anti f) :
  strict_mono (g ∘ f) :=
λ a b h, hg (hf h)

lemma strict_anti.comp_strict_mono (hg : strict_anti g) (hf : strict_mono f) :
  strict_anti (g ∘ f) :=
λ a b h, hg (hf h)

protected lemma strict_mono.iterate {f : α → α} (hf : strict_mono f) (n : ℕ) :
  strict_mono (f^[n]) :=
nat.rec_on n strict_mono_id (λ n h, h.comp hf)

protected lemma strict_mono.comp_strict_mono_on (hg : strict_mono g) (hf : strict_mono_on f s) :
  strict_mono_on (g ∘ f) s :=
λ a ha b hb h, hg (hf ha hb h)

lemma strict_mono.comp_strict_anti_on (hg : strict_mono g) (hf : strict_anti_on f s) :
  strict_anti_on (g ∘ f) s :=
λ a ha b hb h, hg (hf ha hb h)

protected lemma strict_anti.comp_strict_anti_on (hg : strict_anti g) (hf : strict_anti_on f s) :
  strict_mono_on (g ∘ f) s :=
λ a ha b hb h, hg (hf ha hb h)

lemma strict_anti.comp_strict_mono_on (hg : strict_anti g) (hf : strict_mono_on f s) :
  strict_anti_on (g ∘ f) s :=
λ a ha b hb h, hg (hf ha hb h)

end composition

namespace list

section fold

theorem foldl_monotone [preorder α] {f : α → β → α} (H : ∀ b, monotone (λ a, f a b)) (l : list β) :
  monotone (λ a, l.foldl f a) :=
list.rec_on l (λ _ _, id) (λ i l hl _ _ h, hl (H _ h))

theorem foldr_monotone [preorder β] {f : α → β → β} (H : ∀ a, monotone (f a)) (l : list α) :
  monotone (λ b, l.foldr f b) :=
λ _ _ h, list.rec_on l h (λ i l hl, H i hl)

theorem foldl_strict_mono [preorder α] {f : α → β → α} (H : ∀ b, strict_mono (λ a, f a b))
  (l : list β) : strict_mono (λ a, l.foldl f a) :=
list.rec_on l (λ _ _, id) (λ i l hl _ _ h, hl (H _ h))

theorem foldr_strict_mono [preorder β] {f : α → β → β} (H : ∀ a, strict_mono (f a)) (l : list α) :
  strict_mono (λ b, l.foldr f b) :=
λ _ _ h, list.rec_on l h (λ i l hl, H i hl)

end fold

end list

/-! ### Monotonicity in linear orders  -/

section linear_order
variables [linear_order α]

section preorder
variables [preorder β] {f : α → β} {s : set α}

open ordering

lemma monotone.reflect_lt (hf : monotone f) {a b : α} (h : f a < f b) : a < b :=
lt_of_not_ge (λ h', h.not_le (hf h'))

lemma antitone.reflect_lt (hf : antitone f) {a b : α} (h : f a < f b) : b < a :=
lt_of_not_ge (λ h', h.not_le (hf h'))

lemma monotone_on.reflect_lt (hf : monotone_on f s) {a b : α} (ha : a ∈ s) (hb : b ∈ s)
  (h : f a < f b) :
  a < b :=
lt_of_not_ge $ λ h', h.not_le $ hf hb ha h'

lemma antitone_on.reflect_lt (hf : antitone_on f s) {a b : α}  (ha : a ∈ s) (hb : b ∈ s)
  (h : f a < f b) :
  b < a :=
lt_of_not_ge $ λ h', h.not_le $ hf ha hb h'

lemma strict_mono_on.le_iff_le (hf : strict_mono_on f s) {a b : α} (ha : a ∈ s) (hb : b ∈ s) :
  f a ≤ f b ↔ a ≤ b :=
⟨λ h, le_of_not_gt $ λ h', (hf hb ha h').not_le h,
 λ h, h.lt_or_eq_dec.elim (λ h', (hf ha hb h').le) (λ h', h' ▸ le_rfl)⟩

lemma strict_anti_on.le_iff_le (hf : strict_anti_on f s) {a b : α} (ha : a ∈ s) (hb : b ∈ s) :
  f a ≤ f b ↔ b ≤ a :=
hf.dual_right.le_iff_le hb ha

lemma strict_mono_on.lt_iff_lt (hf : strict_mono_on f s) {a b : α} (ha : a ∈ s) (hb : b ∈ s) :
  f a < f b ↔ a < b :=
by rw [lt_iff_le_not_le, lt_iff_le_not_le, hf.le_iff_le ha hb, hf.le_iff_le hb ha]

lemma strict_anti_on.lt_iff_lt (hf : strict_anti_on f s) {a b : α} (ha : a ∈ s) (hb : b ∈ s) :
  f a < f b ↔ b < a :=
hf.dual_right.lt_iff_lt hb ha

lemma strict_mono.le_iff_le (hf : strict_mono f) {a b : α} :
  f a ≤ f b ↔ a ≤ b :=
(hf.strict_mono_on set.univ).le_iff_le trivial trivial

lemma strict_anti.le_iff_le (hf : strict_anti f) {a b : α} :
  f a ≤ f b ↔ b ≤ a :=
(hf.strict_anti_on set.univ).le_iff_le trivial trivial

lemma strict_mono.lt_iff_lt (hf : strict_mono f) {a b : α} :
  f a < f b ↔ a < b :=
(hf.strict_mono_on set.univ).lt_iff_lt trivial trivial

lemma strict_anti.lt_iff_lt (hf : strict_anti f) {a b : α} :
  f a < f b ↔ b < a :=
(hf.strict_anti_on set.univ).lt_iff_lt trivial trivial

protected theorem strict_mono_on.compares (hf : strict_mono_on f s) {a b : α} (ha : a ∈ s)
  (hb : b ∈ s) :
  ∀ {o : ordering}, o.compares (f a) (f b) ↔ o.compares a b
| ordering.lt := hf.lt_iff_lt ha hb
| ordering.eq := ⟨λ h, ((hf.le_iff_le ha hb).1 h.le).antisymm ((hf.le_iff_le hb ha).1 h.symm.le),
                   congr_arg _⟩
| ordering.gt := hf.lt_iff_lt hb ha

protected theorem strict_anti_on.compares (hf : strict_anti_on f s) {a b : α} (ha : a ∈ s)
  (hb : b ∈ s) {o : ordering} :
  o.compares (f a) (f b) ↔ o.compares b a :=
to_dual_compares_to_dual.trans $ hf.dual_right.compares hb ha

protected theorem strict_mono.compares (hf : strict_mono f) {a b : α} {o : ordering} :
  o.compares (f a) (f b) ↔ o.compares a b :=
(hf.strict_mono_on set.univ).compares trivial trivial

protected theorem strict_anti.compares (hf : strict_anti f) {a b : α} {o : ordering} :
  o.compares (f a) (f b) ↔ o.compares b a :=
(hf.strict_anti_on set.univ).compares trivial trivial

lemma strict_mono.injective (hf : strict_mono f) : injective f :=
λ x y h, show compares eq x y, from hf.compares.1 h

lemma strict_anti.injective (hf : strict_anti f) : injective f :=
λ x y h, show compares eq x y, from hf.compares.1 h.symm

lemma strict_mono.maximal_of_maximal_image (hf : strict_mono f) {a} (hmax : ∀ p, p ≤ f a) (x : α) :
  x ≤ a :=
hf.le_iff_le.mp (hmax (f x))

lemma strict_mono.minimal_of_minimal_image (hf : strict_mono f) {a} (hmin : ∀ p, f a ≤ p) (x : α) :
  a ≤ x :=
hf.le_iff_le.mp (hmin (f x))

lemma strict_anti.minimal_of_maximal_image (hf : strict_anti f) {a} (hmax : ∀ p, p ≤ f a) (x : α) :
  a ≤ x :=
hf.le_iff_le.mp (hmax (f x))

lemma strict_anti.maximal_of_minimal_image (hf : strict_anti f) {a} (hmin : ∀ p, f a ≤ p) (x : α) :
  x ≤ a :=
hf.le_iff_le.mp (hmin (f x))

end preorder

section partial_order
variables [partial_order β] {f : α → β}

lemma monotone.strict_mono_iff_injective (hf : monotone f) :
  strict_mono f ↔ injective f :=
⟨λ h, h.injective, hf.strict_mono_of_injective⟩

lemma antitone.strict_anti_iff_injective (hf : antitone f) :
  strict_anti f ↔ injective f :=
⟨λ h, h.injective, hf.strict_anti_of_injective⟩

end partial_order

/-!
### Strictly monotone functions and `cmp`
-/

variables [linear_order β] {f : α → β} {s : set α} {x y : α}

lemma strict_mono_on.cmp_map_eq (hf : strict_mono_on f s) (hx : x ∈ s) (hy : y ∈ s) :
  cmp (f x) (f y) = cmp x y :=
((hf.compares hx hy).2 (cmp_compares x y)).cmp_eq

lemma strict_mono.cmp_map_eq (hf : strict_mono f) (x y : α) : cmp (f x) (f y) = cmp x y :=
(hf.strict_mono_on set.univ).cmp_map_eq trivial trivial

lemma strict_anti_on.cmp_map_eq (hf : strict_anti_on f s) (hx : x ∈ s) (hy : y ∈ s) :
  cmp (f x) (f y) = cmp y x :=
hf.dual_right.cmp_map_eq hy hx

lemma strict_anti.cmp_map_eq (hf : strict_anti f) (x y : α) : cmp (f x) (f y) = cmp y x :=
(hf.strict_anti_on set.univ).cmp_map_eq trivial trivial

end linear_order

/-! ### Monotonicity in `ℕ` and `ℤ` -/

section preorder
variables [preorder α]

lemma nat.rel_of_forall_rel_succ_of_le_of_lt (r : β → β → Prop) [is_trans β r]
  {f : ℕ → β} {a : ℕ} (h : ∀ n, a ≤ n → r (f n) (f (n + 1))) ⦃b c : ℕ⦄
  (hab : a ≤ b) (hbc : b < c) :
  r (f b) (f c) :=
begin
  induction hbc with k b_lt_k r_b_k,
  exacts [h _ hab, trans r_b_k (h _ (hab.trans_lt b_lt_k).le)]
end

lemma nat.rel_of_forall_rel_succ_of_le_of_le (r : β → β → Prop) [is_refl β r] [is_trans β r]
  {f : ℕ → β} {a : ℕ} (h : ∀ n, a ≤ n → r (f n) (f (n + 1))) ⦃b c : ℕ⦄
  (hab : a ≤ b) (hbc : b ≤ c) :
  r (f b) (f c) :=
hbc.eq_or_lt.elim (λ h, h ▸ refl _) (nat.rel_of_forall_rel_succ_of_le_of_lt r h hab)

lemma nat.rel_of_forall_rel_succ_of_lt (r : β → β → Prop) [is_trans β r]
  {f : ℕ → β} (h : ∀ n, r (f n) (f (n + 1))) ⦃a b : ℕ⦄ (hab : a < b) : r (f a) (f b) :=
nat.rel_of_forall_rel_succ_of_le_of_lt r (λ n _, h n) le_rfl hab

lemma nat.rel_of_forall_rel_succ_of_le (r : β → β → Prop) [is_refl β r] [is_trans β r]
  {f : ℕ → β} (h : ∀ n, r (f n) (f (n + 1))) ⦃a b : ℕ⦄ (hab : a ≤ b) : r (f a) (f b) :=
nat.rel_of_forall_rel_succ_of_le_of_le r (λ n _, h n) le_rfl hab

lemma monotone_nat_of_le_succ {f : ℕ → α} (hf : ∀ n, f n ≤ f (n + 1)) :
  monotone f :=
nat.rel_of_forall_rel_succ_of_le (≤) hf

lemma antitone_nat_of_succ_le {f : ℕ → α} (hf : ∀ n, f (n + 1) ≤ f n) : antitone f :=
@monotone_nat_of_le_succ αᵒᵈ _ _ hf

lemma strict_mono_nat_of_lt_succ {f : ℕ → α} (hf : ∀ n, f n < f (n + 1)) : strict_mono f :=
nat.rel_of_forall_rel_succ_of_lt (<) hf

lemma strict_anti_nat_of_succ_lt {f : ℕ → α} (hf : ∀ n, f (n + 1) < f n) : strict_anti f :=
@strict_mono_nat_of_lt_succ αᵒᵈ _ f hf

namespace nat

/-- If `α` is a preorder with no maximal elements, then there exists a strictly monotone function
`ℕ → α` with any prescribed value of `f 0`. -/
lemma exists_strict_mono' [no_max_order α] (a : α) : ∃ f : ℕ → α, strict_mono f ∧ f 0 = a :=
begin
  have := (λ x : α, exists_gt x),
  choose g hg,
  exact ⟨λ n, nat.rec_on n a (λ _, g), strict_mono_nat_of_lt_succ $ λ n, hg _, rfl⟩
end

/-- If `α` is a preorder with no maximal elements, then there exists a strictly antitone function
`ℕ → α` with any prescribed value of `f 0`. -/
lemma exists_strict_anti' [no_min_order α] (a : α) : ∃ f : ℕ → α, strict_anti f ∧ f 0 = a :=
exists_strict_mono' (order_dual.to_dual a)

variable (α)

/-- If `α` is a nonempty preorder with no maximal elements, then there exists a strictly monotone
function `ℕ → α`. -/
lemma exists_strict_mono [nonempty α] [no_max_order α] : ∃ f : ℕ → α, strict_mono f :=
let ⟨a⟩ := ‹nonempty α›, ⟨f, hf, hfa⟩ := exists_strict_mono' a in ⟨f, hf⟩

/-- If `α` is a nonempty preorder with no minimal elements, then there exists a strictly antitone
function `ℕ → α`. -/
lemma exists_strict_anti [nonempty α] [no_min_order α] : ∃ f : ℕ → α, strict_anti f :=
exists_strict_mono αᵒᵈ

end nat

lemma int.rel_of_forall_rel_succ_of_lt (r : β → β → Prop) [is_trans β r]
  {f : ℤ → β} (h : ∀ n, r (f n) (f (n + 1))) ⦃a b : ℤ⦄ (hab : a < b) : r (f a) (f b) :=
begin
  rcases hab.dest with ⟨n, rfl⟩, clear hab,
  induction n with n ihn,
  { rw int.coe_nat_one, apply h },
  { rw [int.coe_nat_succ, ← int.add_assoc],
    exact trans ihn (h _) }
end

lemma int.rel_of_forall_rel_succ_of_le (r : β → β → Prop) [is_refl β r] [is_trans β r]
  {f : ℤ → β} (h : ∀ n, r (f n) (f (n + 1))) ⦃a b : ℤ⦄ (hab : a ≤ b) : r (f a) (f b) :=
hab.eq_or_lt.elim (λ h, h ▸ refl _) (λ h', int.rel_of_forall_rel_succ_of_lt r h h')

lemma monotone_int_of_le_succ {f : ℤ → α} (hf : ∀ n, f n ≤ f (n + 1)) : monotone f :=
int.rel_of_forall_rel_succ_of_le (≤) hf

lemma antitone_int_of_succ_le {f : ℤ → α} (hf : ∀ n, f (n + 1) ≤ f n) : antitone f :=
int.rel_of_forall_rel_succ_of_le (≥) hf

lemma strict_mono_int_of_lt_succ {f : ℤ → α} (hf : ∀ n, f n < f (n + 1)) : strict_mono f :=
int.rel_of_forall_rel_succ_of_lt (<) hf

lemma strict_anti_int_of_succ_lt {f : ℤ → α} (hf : ∀ n, f (n + 1) < f n) : strict_anti f :=
int.rel_of_forall_rel_succ_of_lt (>) hf

namespace int

variables (α) [nonempty α] [no_min_order α] [no_max_order α]

/-- If `α` is a nonempty preorder with no minimal or maximal elements, then there exists a strictly
monotone function `f : ℤ → α`. -/
lemma exists_strict_mono : ∃ f : ℤ → α, strict_mono f :=
begin
  inhabit α,
  rcases nat.exists_strict_mono' (default : α) with ⟨f, hf, hf₀⟩,
  rcases nat.exists_strict_anti' (default : α) with ⟨g, hg, hg₀⟩,
  refine ⟨λ n, int.cases_on n f (λ n, g (n + 1)), strict_mono_int_of_lt_succ _⟩,
  rintro (n|_|n),
  { exact hf n.lt_succ_self },
  { show g 1 < f 0,
    rw [hf₀, ← hg₀],
    exact hg nat.zero_lt_one },
  { exact hg (nat.lt_succ_self _) }
end

/-- If `α` is a nonempty preorder with no minimal or maximal elements, then there exists a strictly
antitone function `f : ℤ → α`. -/
lemma exists_strict_anti : ∃ f : ℤ → α, strict_anti f := exists_strict_mono αᵒᵈ

end int

-- TODO@Yael: Generalize the following four to succ orders
/-- If `f` is a monotone function from `ℕ` to a preorder such that `x` lies between `f n` and
  `f (n + 1)`, then `x` doesn't lie in the range of `f`. -/
lemma monotone.ne_of_lt_of_lt_nat {f : ℕ → α} (hf : monotone f) (n : ℕ) {x : α}
  (h1 : f n < x) (h2 : x < f (n + 1)) (a : ℕ) :
  f a ≠ x :=
by { rintro rfl, exact (hf.reflect_lt h1).not_le (nat.le_of_lt_succ $ hf.reflect_lt h2) }

/-- If `f` is an antitone function from `ℕ` to a preorder such that `x` lies between `f (n + 1)` and
`f n`, then `x` doesn't lie in the range of `f`. -/
lemma antitone.ne_of_lt_of_lt_nat {f : ℕ → α} (hf : antitone f)
  (n : ℕ) {x : α} (h1 : f (n + 1) < x) (h2 : x < f n) (a : ℕ) : f a ≠ x :=
by { rintro rfl, exact (hf.reflect_lt h2).not_le (nat.le_of_lt_succ $ hf.reflect_lt h1) }

/-- If `f` is a monotone function from `ℤ` to a preorder and `x` lies between `f n` and
  `f (n + 1)`, then `x` doesn't lie in the range of `f`. -/
lemma monotone.ne_of_lt_of_lt_int {f : ℤ → α} (hf : monotone f) (n : ℤ) {x : α}
  (h1 : f n < x) (h2 : x < f (n + 1)) (a : ℤ) :
  f a ≠ x :=
by { rintro rfl, exact (hf.reflect_lt h1).not_le (int.le_of_lt_add_one $ hf.reflect_lt h2) }

/-- If `f` is an antitone function from `ℤ` to a preorder and `x` lies between `f (n + 1)` and
`f n`, then `x` doesn't lie in the range of `f`. -/
lemma antitone.ne_of_lt_of_lt_int {f : ℤ → α} (hf : antitone f)
  (n : ℤ) {x : α} (h1 : f (n + 1) < x) (h2 : x < f n) (a : ℤ) : f a ≠ x :=
by { rintro rfl, exact (hf.reflect_lt h2).not_le (int.le_of_lt_add_one $ hf.reflect_lt h1) }

lemma strict_mono.id_le {φ : ℕ → ℕ} (h : strict_mono φ) : ∀ n, n ≤ φ n :=
λ n, nat.rec_on n (nat.zero_le _)
  (λ n hn, nat.succ_le_of_lt (hn.trans_lt $ h $ nat.lt_succ_self n))

end preorder

lemma subtype.mono_coe [preorder α] (t : set α) : monotone (coe : (subtype t) → α) :=
λ x y, id

lemma subtype.strict_mono_coe [preorder α] (t : set α) : strict_mono (coe : (subtype t) → α) :=
λ x y, id

section preorder
variables [preorder α] [preorder β] [preorder γ] [preorder δ] {f : α → γ} {g : β → δ} {a b : α}

lemma monotone_fst : monotone (@prod.fst α β) := λ a b, and.left
lemma monotone_snd : monotone (@prod.snd α β) := λ a b, and.right

lemma monotone.prod_map (hf : monotone f) (hg : monotone g) : monotone (prod.map f g) :=
λ a b h, ⟨hf h.1, hg h.2⟩

lemma antitone.prod_map (hf : antitone f) (hg : antitone g) : antitone (prod.map f g) :=
λ a b h, ⟨hf h.1, hg h.2⟩

end preorder

section partial_order
variables [partial_order α] [partial_order β] [preorder γ] [preorder δ]
  {f : α → γ} {g : β → δ}

lemma strict_mono.prod_map (hf : strict_mono f) (hg : strict_mono g) : strict_mono (prod.map f g) :=
λ a b, by { simp_rw prod.lt_iff,
  exact or.imp (and.imp hf.imp hg.monotone.imp) (and.imp hf.monotone.imp hg.imp) }

lemma strict_anti.prod_map (hf : strict_anti f) (hg : strict_anti g) : strict_anti (prod.map f g) :=
λ a b, by { simp_rw prod.lt_iff,
  exact or.imp (and.imp hf.imp hg.antitone.imp) (and.imp hf.antitone.imp hg.imp) }

end partial_order