/-
Copyright (c) 2022 Michael Stoll. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Michael Stoll

! This file was ported from Lean 3 source module number_theory.legendre_symbol.quadratic_char
! leanprover-community/mathlib commit d11893b411025250c8e61ff2f12ccbd7ee35ab15
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Data.Fintype.Parity
import Mathbin.NumberTheory.LegendreSymbol.ZmodChar
import Mathbin.FieldTheory.Finite.Basic
import Mathbin.NumberTheory.LegendreSymbol.GaussSum

/-!
# Quadratic characters of finite fields

This file defines the quadratic character on a finite field `F` and proves
some basic statements about it.

## Tags

quadratic character
-/

/-!
### Definition of the quadratic character

We define the quadratic character of a finite field `F` with values in ℤ.
-/

section Define

/-- Define the quadratic character with values in ℤ on a monoid with zero `α`.
It takes the value zero at zero; for non-zero argument `a : α`, it is `1`
if `a` is a square, otherwise it is `-1`.

This only deserves the name "character" when it is multiplicative,
e.g., when `α` is a finite field. See `quadratic_char_fun_mul`.

We will later define `quadratic_char` to be a multiplicative character
of type `mul_char F ℤ`, when the domain is a finite field `F`.
-/
def quadraticCharFun (α : Type _) [MonoidWithZero α] [DecidableEq α]
    [DecidablePred (IsSquare : α → Prop)] (a : α) : ℤ :=
  if a = 0 then 0 else if IsSquare a then 1 else -1
#align quadratic_char_fun quadraticCharFun

end Define

/-!
### Basic properties of the quadratic character

We prove some properties of the quadratic character.
We work with a finite field `F` here.
The interesting case is when the characteristic of `F` is odd.
-/

section quadraticChar

open MulChar

variable {F : Type _} [Field F] [Fintype F] [DecidableEq F]

/-- Some basic API lemmas -/
theorem quadraticCharFun_eq_zero_iff {a : F} : quadraticCharFun F a = 0 ↔ a = 0 :=
  by
  simp only [quadraticCharFun]
  by_cases ha : a = 0
  · simp only [ha, eq_self_iff_true, if_true]
  · simp only [ha, if_false, iff_false_iff]
    split_ifs <;> simp only [neg_eq_zero, one_ne_zero, not_false_iff]
#align quadratic_char_fun_eq_zero_iff quadraticCharFun_eq_zero_iff

@[simp]
theorem quadraticCharFun_zero : quadraticCharFun F 0 = 0 := by
  simp only [quadraticCharFun, eq_self_iff_true, if_true, id.def]
#align quadratic_char_fun_zero quadraticCharFun_zero

@[simp]
theorem quadraticCharFun_one : quadraticCharFun F 1 = 1 := by
  simp only [quadraticCharFun, one_ne_zero, isSquare_one, if_true, if_false, id.def]
#align quadratic_char_fun_one quadraticCharFun_one

/-- If `ring_char F = 2`, then `quadratic_char_fun F` takes the value `1` on nonzero elements. -/
theorem quadraticCharFun_eq_one_of_char_two (hF : ringChar F = 2) {a : F} (ha : a ≠ 0) :
    quadraticCharFun F a = 1 :=
  by
  simp only [quadraticCharFun, ha, if_false, ite_eq_left_iff]
  exact fun h => False.ndrec _ (h (FiniteField.isSquare_of_char_two hF a))
#align quadratic_char_fun_eq_one_of_char_two quadraticCharFun_eq_one_of_char_two

/-- If `ring_char F` is odd, then `quadratic_char_fun F a` can be computed in
terms of `a ^ (fintype.card F / 2)`. -/
theorem quadraticCharFun_eq_pow_of_char_ne_two (hF : ringChar F ≠ 2) {a : F} (ha : a ≠ 0) :
    quadraticCharFun F a = if a ^ (Fintype.card F / 2) = 1 then 1 else -1 :=
  by
  simp only [quadraticCharFun, ha, if_false]
  simp_rw [FiniteField.isSquare_iff hF ha]
#align quadratic_char_fun_eq_pow_of_char_ne_two quadraticCharFun_eq_pow_of_char_ne_two

/-- The quadratic character is multiplicative. -/
theorem quadraticCharFun_mul (a b : F) :
    quadraticCharFun F (a * b) = quadraticCharFun F a * quadraticCharFun F b :=
  by
  by_cases ha : a = 0
  · rw [ha, MulZeroClass.zero_mul, quadraticCharFun_zero, MulZeroClass.zero_mul]
  -- now `a ≠ 0`
  by_cases hb : b = 0
  · rw [hb, MulZeroClass.mul_zero, quadraticCharFun_zero, MulZeroClass.mul_zero]
  -- now `a ≠ 0` and `b ≠ 0`
  have hab := mul_ne_zero ha hb
  by_cases hF : ringChar F = 2
  ·-- case `ring_char F = 2`
    rw [quadraticCharFun_eq_one_of_char_two hF ha, quadraticCharFun_eq_one_of_char_two hF hb,
      quadraticCharFun_eq_one_of_char_two hF hab, mul_one]
  · -- case of odd characteristic
    rw [quadraticCharFun_eq_pow_of_char_ne_two hF ha, quadraticCharFun_eq_pow_of_char_ne_two hF hb,
      quadraticCharFun_eq_pow_of_char_ne_two hF hab, mul_pow]
    cases' FiniteField.pow_dichotomy hF hb with hb' hb'
    · simp only [hb', mul_one, eq_self_iff_true, if_true]
    · have h := Ring.neg_one_ne_one_of_char_ne_two hF
      -- `-1 ≠ 1`
      simp only [hb', h, mul_neg, mul_one, if_false, ite_mul, neg_mul]
      cases' FiniteField.pow_dichotomy hF ha with ha' ha' <;>
        simp only [ha', h, neg_neg, eq_self_iff_true, if_true, if_false]
#align quadratic_char_fun_mul quadraticCharFun_mul

variable (F)

/-- The quadratic character as a multiplicative character. -/
@[simps]
def quadraticChar : MulChar F ℤ where
  toFun := quadraticCharFun F
  map_one' := quadraticCharFun_one
  map_mul' := quadraticCharFun_mul
  map_nonunit' a ha := by
    rw [of_not_not (mt Ne.isUnit ha)]
    exact quadraticCharFun_zero
#align quadratic_char quadraticChar

variable {F}

/-- The value of the quadratic character on `a` is zero iff `a = 0`. -/
theorem quadraticChar_eq_zero_iff {a : F} : quadraticChar F a = 0 ↔ a = 0 :=
  quadraticCharFun_eq_zero_iff
#align quadratic_char_eq_zero_iff quadraticChar_eq_zero_iff

@[simp]
theorem quadraticChar_zero : quadraticChar F 0 = 0 := by
  simp only [quadraticChar_apply, quadraticCharFun_zero]
#align quadratic_char_zero quadraticChar_zero

/-- For nonzero `a : F`, `quadratic_char F a = 1 ↔ is_square a`. -/
theorem quadraticChar_one_iff_isSquare {a : F} (ha : a ≠ 0) : quadraticChar F a = 1 ↔ IsSquare a :=
  by
  simp only [quadraticChar_apply, quadraticCharFun, ha, (by decide : (-1 : ℤ) ≠ 1), if_false,
    ite_eq_left_iff, imp_false, Classical.not_not]
#align quadratic_char_one_iff_is_square quadraticChar_one_iff_isSquare

/-- The quadratic character takes the value `1` on nonzero squares. -/
theorem quadraticChar_sq_one' {a : F} (ha : a ≠ 0) : quadraticChar F (a ^ 2) = 1 := by
  simp only [quadraticCharFun, ha, pow_eq_zero_iff, Nat.succ_pos', IsSquare_sq, if_true, if_false,
    quadraticChar_apply]
#align quadratic_char_sq_one' quadraticChar_sq_one'

/-- The square of the quadratic character on nonzero arguments is `1`. -/
theorem quadraticChar_sq_one {a : F} (ha : a ≠ 0) : quadraticChar F a ^ 2 = 1 := by
  rwa [pow_two, ← map_mul, ← pow_two, quadraticChar_sq_one']
#align quadratic_char_sq_one quadraticChar_sq_one

/-- The quadratic character is `1` or `-1` on nonzero arguments. -/
theorem quadraticChar_dichotomy {a : F} (ha : a ≠ 0) :
    quadraticChar F a = 1 ∨ quadraticChar F a = -1 :=
  sq_eq_one_iff.1 <| quadraticChar_sq_one ha
#align quadratic_char_dichotomy quadraticChar_dichotomy

/-- The quadratic character is `1` or `-1` on nonzero arguments. -/
theorem quadraticChar_eq_neg_one_iff_not_one {a : F} (ha : a ≠ 0) :
    quadraticChar F a = -1 ↔ ¬quadraticChar F a = 1 :=
  by
  refine' ⟨fun h => _, fun h₂ => (or_iff_right h₂).mp (quadraticChar_dichotomy ha)⟩
  rw [h]
  norm_num
#align quadratic_char_eq_neg_one_iff_not_one quadraticChar_eq_neg_one_iff_not_one

/-- For `a : F`, `quadratic_char F a = -1 ↔ ¬ is_square a`. -/
theorem quadraticChar_neg_one_iff_not_isSquare {a : F} : quadraticChar F a = -1 ↔ ¬IsSquare a :=
  by
  by_cases ha : a = 0
  · simp only [ha, isSquare_zero, MulChar.map_zero, zero_eq_neg, one_ne_zero, not_true]
  · rw [quadraticChar_eq_neg_one_iff_not_one ha, quadraticChar_one_iff_isSquare ha]
#align quadratic_char_neg_one_iff_not_is_square quadraticChar_neg_one_iff_not_isSquare

/-- If `F` has odd characteristic, then `quadratic_char F` takes the value `-1`. -/
theorem quadraticChar_exists_neg_one (hF : ringChar F ≠ 2) : ∃ a, quadraticChar F a = -1 :=
  (FiniteField.exists_nonsquare hF).imp fun b h₁ => quadraticChar_neg_one_iff_not_isSquare.mpr h₁
#align quadratic_char_exists_neg_one quadraticChar_exists_neg_one

/-- If `ring_char F = 2`, then `quadratic_char F` takes the value `1` on nonzero elements. -/
theorem quadraticChar_eq_one_of_char_two (hF : ringChar F = 2) {a : F} (ha : a ≠ 0) :
    quadraticChar F a = 1 :=
  quadraticCharFun_eq_one_of_char_two hF ha
#align quadratic_char_eq_one_of_char_two quadraticChar_eq_one_of_char_two

/-- If `ring_char F` is odd, then `quadratic_char F a` can be computed in
terms of `a ^ (fintype.card F / 2)`. -/
theorem quadraticChar_eq_pow_of_char_ne_two (hF : ringChar F ≠ 2) {a : F} (ha : a ≠ 0) :
    quadraticChar F a = if a ^ (Fintype.card F / 2) = 1 then 1 else -1 :=
  quadraticCharFun_eq_pow_of_char_ne_two hF ha
#align quadratic_char_eq_pow_of_char_ne_two quadraticChar_eq_pow_of_char_ne_two

theorem quadraticChar_eq_pow_of_char_ne_two' (hF : ringChar F ≠ 2) (a : F) :
    (quadraticChar F a : F) = a ^ (Fintype.card F / 2) :=
  by
  by_cases ha : a = 0
  · have : 0 < Fintype.card F / 2 := Nat.div_pos Fintype.one_lt_card two_pos
    simp only [ha, zero_pow this, quadraticChar_apply, quadraticChar_zero, Int.cast_zero]
  · rw [quadraticChar_eq_pow_of_char_ne_two hF ha]
    by_cases ha' : a ^ (Fintype.card F / 2) = 1
    · simp only [ha', eq_self_iff_true, if_true, Int.cast_one]
    · have ha'' := Or.resolve_left (FiniteField.pow_dichotomy hF ha) ha'
      simp only [ha'', Int.cast_ite, Int.cast_one, Int.cast_neg, ite_eq_right_iff]
      exact Eq.symm
#align quadratic_char_eq_pow_of_char_ne_two' quadraticChar_eq_pow_of_char_ne_two'

variable (F)

/-- The quadratic character is quadratic as a multiplicative character. -/
theorem quadraticChar_isQuadratic : (quadraticChar F).IsQuadratic :=
  by
  intro a
  by_cases ha : a = 0
  · left
    rw [ha]
    exact quadraticChar_zero
  · right
    exact quadraticChar_dichotomy ha
#align quadratic_char_is_quadratic quadraticChar_isQuadratic

variable {F}

/-- The quadratic character is nontrivial as a multiplicative character
when the domain has odd characteristic. -/
theorem quadraticChar_isNontrivial (hF : ringChar F ≠ 2) : (quadraticChar F).IsNontrivial :=
  by
  rcases quadraticChar_exists_neg_one hF with ⟨a, ha⟩
  have hu : IsUnit a := by
    by_contra hf
    rw [map_nonunit _ hf] at ha
    norm_num at ha
  refine' ⟨hu.unit, (_ : quadraticChar F a ≠ 1)⟩
  rw [ha]
  norm_num
#align quadratic_char_is_nontrivial quadraticChar_isNontrivial

/-- The number of solutions to `x^2 = a` is determined by the quadratic character. -/
theorem quadraticChar_card_sqrts (hF : ringChar F ≠ 2) (a : F) :
    ↑{ x : F | x ^ 2 = a }.toFinset.card = quadraticChar F a + 1 :=
  by
  -- we consider the cases `a = 0`, `a` is a nonzero square and `a` is a nonsquare in turn
  by_cases h₀ : a = 0
  ·
    simp only [h₀, pow_eq_zero_iff, Nat.succ_pos', Int.ofNat_succ, Int.ofNat_zero, MulChar.map_zero,
      Set.setOf_eq_eq_singleton, Set.toFinset_card, Set.card_singleton]
  · set s := { x : F | x ^ 2 = a }.toFinset with hs
    by_cases h : IsSquare a
    · rw [(quadraticChar_one_iff_isSquare h₀).mpr h]
      rcases h with ⟨b, h⟩
      rw [h, mul_self_eq_zero] at h₀
      have h₁ : s = [b, -b].toFinset := by
        ext x
        simp only [Finset.mem_filter, Finset.mem_univ, true_and_iff, List.toFinset_cons,
          List.toFinset_nil, insert_emptyc_eq, Finset.mem_insert, Finset.mem_singleton]
        rw [← pow_two] at h
        simp only [hs, Set.mem_toFinset, Set.mem_setOf_eq, h]
        constructor
        · exact eq_or_eq_neg_of_sq_eq_sq _ _
        · rintro (h₂ | h₂) <;> rw [h₂]
          simp only [neg_sq]
      norm_cast
      rw [h₁, List.toFinset_cons, List.toFinset_cons, List.toFinset_nil]
      exact Finset.card_doubleton (Ne.symm (mt (Ring.eq_self_iff_eq_zero_of_char_ne_two hF).mp h₀))
    · rw [quadratic_char_neg_one_iff_not_is_square.mpr h]
      simp only [Int.coe_nat_eq_zero, Finset.card_eq_zero, Set.toFinset_card, Fintype.card_ofFinset,
        Set.mem_setOf_eq, add_left_neg]
      ext x
      simp only [iff_false_iff, Finset.mem_filter, Finset.mem_univ, true_and_iff,
        Finset.not_mem_empty]
      rw [isSquare_iff_exists_sq] at h
      exact fun h' => h ⟨_, h'.symm⟩
#align quadratic_char_card_sqrts quadraticChar_card_sqrts

open BigOperators

/-- The sum over the values of the quadratic character is zero when the characteristic is odd. -/
theorem quadraticChar_sum_zero (hF : ringChar F ≠ 2) : (∑ a : F, quadraticChar F a) = 0 :=
  IsNontrivial.sum_eq_zero (quadraticChar_isNontrivial hF)
#align quadratic_char_sum_zero quadraticChar_sum_zero

end quadraticChar

/-!
### Special values of the quadratic character

We express `quadratic_char F (-1)` in terms of `χ₄`.
-/

section SpecialValues

open ZMod MulChar

variable {F : Type _} [Field F] [Fintype F]

/-- The value of the quadratic character at `-1` -/
theorem quadraticChar_neg_one [DecidableEq F] (hF : ringChar F ≠ 2) :
    quadraticChar F (-1) = χ₄ (Fintype.card F) :=
  by
  have h := quadraticChar_eq_pow_of_char_ne_two hF (neg_ne_zero.mpr one_ne_zero)
  rw [h, χ₄_eq_neg_one_pow (FiniteField.odd_card_of_char_ne_two hF)]
  set n := Fintype.card F / 2
  cases' Nat.even_or_odd n with h₂ h₂
  · simp only [Even.neg_one_pow h₂, eq_self_iff_true, if_true]
  · simp only [Odd.neg_one_pow h₂, ite_eq_right_iff]
    exact fun hf => False.ndrec (1 = -1) (Ring.neg_one_ne_one_of_char_ne_two hF hf)
#align quadratic_char_neg_one quadraticChar_neg_one

/-- `-1` is a square in `F` iff `#F` is not congruent to `3` mod `4`. -/
theorem FiniteField.isSquare_neg_one_iff : IsSquare (-1 : F) ↔ Fintype.card F % 4 ≠ 3 := by
  classical
    -- suggested by the linter (instead of `[decidable_eq F]`)
    by_cases hF : ringChar F = 2
    · simp only [FiniteField.isSquare_of_char_two hF, Ne.def, true_iff_iff]
      exact fun hf =>
        one_ne_zero <|
          (Nat.odd_of_mod_four_eq_three hf).symm.trans <| FiniteField.even_card_of_char_two hF
    · have h₁ := FiniteField.odd_card_of_char_ne_two hF
      rw [← quadraticChar_one_iff_isSquare (neg_ne_zero.mpr (one_ne_zero' F)),
        quadraticChar_neg_one hF, χ₄_nat_eq_if_mod_four, h₁]
      simp only [Nat.one_ne_zero, if_false, ite_eq_left_iff, Ne.def, (by decide : (-1 : ℤ) ≠ 1),
        imp_false, Classical.not_not]
      exact
        ⟨fun h => ne_of_eq_of_ne h (by decide : 1 ≠ 3),
          Or.resolve_right (nat.odd_mod_four_iff.mp h₁)⟩
#align finite_field.is_square_neg_one_iff FiniteField.isSquare_neg_one_iff

/-- The value of the quadratic character at `2` -/
theorem quadraticChar_two [DecidableEq F] (hF : ringChar F ≠ 2) :
    quadraticChar F 2 = χ₈ (Fintype.card F) :=
  IsQuadratic.eq_of_eq_coe (quadraticChar_isQuadratic F) isQuadratic_χ₈ hF
    ((quadraticChar_eq_pow_of_char_ne_two' hF 2).trans (FiniteField.two_pow_card hF))
#align quadratic_char_two quadraticChar_two

/-- `2` is a square in `F` iff `#F` is not congruent to `3` or `5` mod `8`. -/
theorem FiniteField.isSquare_two_iff :
    IsSquare (2 : F) ↔ Fintype.card F % 8 ≠ 3 ∧ Fintype.card F % 8 ≠ 5 := by
  classical
    by_cases hF : ringChar F = 2
    focus
      have h := FiniteField.even_card_of_char_two hF
      simp only [FiniteField.isSquare_of_char_two hF, true_iff_iff]
    rotate_left
    focus
      have h := FiniteField.odd_card_of_char_ne_two hF
      rw [← quadraticChar_one_iff_isSquare (Ring.two_ne_zero hF), quadraticChar_two hF,
        χ₈_nat_eq_if_mod_eight]
      simp only [h, Nat.one_ne_zero, if_false, ite_eq_left_iff, Ne.def, (by decide : (-1 : ℤ) ≠ 1),
        imp_false, Classical.not_not]
    all_goals
      rw [← Nat.mod_mod_of_dvd _ (by norm_num : 2 ∣ 8)] at h
      have h₁ := Nat.mod_lt (Fintype.card F) (by decide : 0 < 8)
      revert h₁ h
      generalize Fintype.card F % 8 = n
      decide!
#align finite_field.is_square_two_iff FiniteField.isSquare_two_iff

/-- The value of the quadratic character at `-2` -/
theorem quadraticChar_neg_two [DecidableEq F] (hF : ringChar F ≠ 2) :
    quadraticChar F (-2) = χ₈' (Fintype.card F) := by
  rw [(by norm_num : (-2 : F) = -1 * 2), map_mul, χ₈'_eq_χ₄_mul_χ₈, quadraticChar_neg_one hF,
    quadraticChar_two hF, @cast_nat_cast _ (ZMod 4) _ _ _ (by norm_num : 4 ∣ 8)]
#align quadratic_char_neg_two quadraticChar_neg_two

/-- `-2` is a square in `F` iff `#F` is not congruent to `5` or `7` mod `8`. -/
theorem FiniteField.isSquare_neg_two_iff :
    IsSquare (-2 : F) ↔ Fintype.card F % 8 ≠ 5 ∧ Fintype.card F % 8 ≠ 7 := by
  classical
    by_cases hF : ringChar F = 2
    focus
      have h := FiniteField.even_card_of_char_two hF
      simp only [FiniteField.isSquare_of_char_two hF, true_iff_iff]
    rotate_left
    focus
      have h := FiniteField.odd_card_of_char_ne_two hF
      rw [← quadraticChar_one_iff_isSquare (neg_ne_zero.mpr (Ring.two_ne_zero hF)),
        quadraticChar_neg_two hF, χ₈'_nat_eq_if_mod_eight]
      simp only [h, Nat.one_ne_zero, if_false, ite_eq_left_iff, Ne.def, (by decide : (-1 : ℤ) ≠ 1),
        imp_false, Classical.not_not]
    all_goals
      rw [← Nat.mod_mod_of_dvd _ (by norm_num : 2 ∣ 8)] at h
      have h₁ := Nat.mod_lt (Fintype.card F) (by decide : 0 < 8)
      revert h₁ h
      generalize Fintype.card F % 8 = n
      decide!
#align finite_field.is_square_neg_two_iff FiniteField.isSquare_neg_two_iff

/-- The relation between the values of the quadratic character of one field `F` at the
cardinality of another field `F'` and of the quadratic character of `F'` at the cardinality
of `F`. -/
theorem quadraticChar_card_card [DecidableEq F] (hF : ringChar F ≠ 2) {F' : Type _} [Field F']
    [Fintype F'] [DecidableEq F'] (hF' : ringChar F' ≠ 2) (h : ringChar F' ≠ ringChar F) :
    quadraticChar F (Fintype.card F') = quadraticChar F' (quadraticChar F (-1) * Fintype.card F) :=
  by
  let χ := (quadraticChar F).ringHomComp (algebraMap ℤ F')
  have hχ₁ : χ.is_nontrivial :=
    by
    obtain ⟨a, ha⟩ := quadraticChar_exists_neg_one hF
    have hu : IsUnit a := by
      contrapose ha
      exact ne_of_eq_of_ne (map_nonunit (quadraticChar F) ha) (mt zero_eq_neg.mp one_ne_zero)
    use hu.unit
    simp only [IsUnit.unit_spec, ring_hom_comp_apply, eq_intCast, Ne.def, ha]
    rw [Int.cast_neg, Int.cast_one]
    exact Ring.neg_one_ne_one_of_char_ne_two hF'
  have hχ₂ : χ.is_quadratic := is_quadratic.comp (quadraticChar_isQuadratic F) _
  have h := Char.card_pow_card hχ₁ hχ₂ h hF'
  rw [← quadraticChar_eq_pow_of_char_ne_two' hF'] at h
  exact
    (is_quadratic.eq_of_eq_coe (quadraticChar_isQuadratic F') (quadraticChar_isQuadratic F) hF'
        h).symm
#align quadratic_char_card_card quadraticChar_card_card

/-- The value of the quadratic character at an odd prime `p` different from `ring_char F`. -/
theorem quadraticChar_odd_prime [DecidableEq F] (hF : ringChar F ≠ 2) {p : ℕ} [Fact p.Prime]
    (hp₁ : p ≠ 2) (hp₂ : ringChar F ≠ p) :
    quadraticChar F p = quadraticChar (ZMod p) (χ₄ (Fintype.card F) * Fintype.card F) :=
  by
  rw [← quadraticChar_neg_one hF]
  have h :=
    quadraticChar_card_card hF (ne_of_eq_of_ne (ring_char_zmod_n p) hp₁)
      (ne_of_eq_of_ne (ring_char_zmod_n p) hp₂.symm)
  rwa [card p] at h
#align quadratic_char_odd_prime quadraticChar_odd_prime

/-- An odd prime `p` is a square in `F` iff the quadratic character of `zmod p` does not
take the value `-1` on `χ₄(#F) * #F`. -/
theorem FiniteField.isSquare_odd_prime_iff (hF : ringChar F ≠ 2) {p : ℕ} [Fact p.Prime]
    (hp : p ≠ 2) :
    IsSquare (p : F) ↔ quadraticChar (ZMod p) (χ₄ (Fintype.card F) * Fintype.card F) ≠ -1 := by
  classical
    by_cases hFp : ringChar F = p
    · rw [show (p : F) = 0 by
          rw [← hFp]
          exact ringChar.Nat.cast_ringChar]
      simp only [isSquare_zero, Ne.def, true_iff_iff, map_mul]
      obtain ⟨n, _, hc⟩ := FiniteField.card F (ringChar F)
      have hchar : ringChar F = ringChar (ZMod p) :=
        by
        rw [hFp]
        exact (ring_char_zmod_n p).symm
      conv =>
        congr
        lhs
        congr
        skip
        rw [hc, Nat.cast_pow, map_pow, hchar, map_ring_char]
      simp only [zero_pow n.pos, MulZeroClass.mul_zero, zero_eq_neg, one_ne_zero, not_false_iff]
    · rw [← Iff.not_left (@quadraticChar_neg_one_iff_not_isSquare F _ _ _ _),
        quadraticChar_odd_prime hF hp]
      exact hFp
#align finite_field.is_square_odd_prime_iff FiniteField.isSquare_odd_prime_iff

end SpecialValues


/-
Copyright (c) 2021 Yaël Dillies. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yaël Dillies
-/
import data.sigma.lex
import order.bounded_order

/-!
# Orders on a sigma type

> THIS FILE IS SYNCHRONIZED WITH MATHLIB4.
> Any changes to this file require a corresponding PR to mathlib4.

This file defines two orders on a sigma type:
* The disjoint sum of orders. `a` is less `b` iff `a` and `b` are in the same summand and `a` is
  less than `b` there.
* The lexicographical order. `a` is less than `b` if its summand is strictly less than the summand
  of `b` or they are in the same summand and `a` is less than `b` there.

We make the disjoint sum of orders the default set of instances. The lexicographic order goes on a
type synonym.

## Notation

* `Σₗ i, α i`: Sigma type equipped with the lexicographic order. Type synonym of `Σ i, α i`.

## See also

Related files are:
* `data.finset.colex`: Colexicographic order on finite sets.
* `data.list.lex`: Lexicographic order on lists.
* `data.pi.lex`: Lexicographic order on `Πₗ i, α i`.
* `data.psigma.order`: Lexicographic order on `Σₗ' i, α i`. Basically a twin of this file.
* `data.prod.lex`: Lexicographic order on `α × β`.

## TODO

Upgrade `equiv.sigma_congr_left`, `equiv.sigma_congr`, `equiv.sigma_assoc`,
`equiv.sigma_prod_of_equiv`, `equiv.sigma_equiv_prod`, ... to order isomorphisms.
-/

namespace sigma
variables {ι : Type*} {α : ι → Type*}

/-! ### Disjoint sum of orders on `sigma` -/

/-- Disjoint sum of orders. `⟨i, a⟩ ≤ ⟨j, b⟩` iff `i = j` and `a ≤ b`. -/
inductive le [Π i, has_le (α i)] : Π a b : Σ i, α i, Prop
| fiber (i : ι) (a b : α i) : a ≤ b → le ⟨i, a⟩ ⟨i, b⟩

/-- Disjoint sum of orders. `⟨i, a⟩ < ⟨j, b⟩` iff `i = j` and `a < b`. -/
inductive lt [Π i, has_lt (α i)] : Π a b : Σ i, α i, Prop
| fiber (i : ι) (a b : α i) : a < b → lt ⟨i, a⟩ ⟨i, b⟩

instance [Π i, has_le (α i)] : has_le (Σ i, α i) := ⟨le⟩
instance [Π i, has_lt (α i)] : has_lt (Σ i, α i) := ⟨lt⟩

@[simp] lemma mk_le_mk_iff [Π i, has_le (α i)] {i : ι} {a b : α i} :
  (⟨i, a⟩ : sigma α) ≤ ⟨i, b⟩ ↔ a ≤ b :=
⟨λ ⟨_, _, _, h⟩, h, le.fiber _ _ _⟩

@[simp] lemma mk_lt_mk_iff [Π i, has_lt (α i)] {i : ι} {a b : α i} :
  (⟨i, a⟩ : sigma α) < ⟨i, b⟩ ↔ a < b :=
⟨λ ⟨_, _, _, h⟩, h, lt.fiber _ _ _⟩

lemma lt_def [Π i, has_lt (α i)] {a b : Σ i, α i} : a < b ↔ ∃ h : a.1 = b.1, h.rec a.2 < b.2 :=
begin
  split,
  { rintro ⟨i, a, b, h⟩,
    exact ⟨rfl, h⟩ },
  { obtain ⟨i, a⟩ := a,
    obtain ⟨j, b⟩ := b,
    rintro ⟨(rfl : i = j), h⟩,
    exact lt.fiber _ _ _ h }
end

instance [Π i, preorder (α i)] : preorder (Σ i, α i) :=
{ le_refl := λ ⟨i, a⟩, le.fiber i a a le_rfl,
  le_trans := begin
    rintro _ _ _ ⟨i, a, b, hab⟩ ⟨_, _, c, hbc⟩,
    exact le.fiber i a c (hab.trans hbc),
  end,
  lt_iff_le_not_le := λ _ _, begin
    split,
    { rintro ⟨i, a, b, hab⟩,
      rwa [mk_le_mk_iff, mk_le_mk_iff, ←lt_iff_le_not_le] },
    { rintro ⟨⟨i, a, b, hab⟩, h⟩,
      rw mk_le_mk_iff at h,
      exact mk_lt_mk_iff.2 (hab.lt_of_not_le h) }
  end,
  .. sigma.has_le,
  .. sigma.has_lt }

instance [Π i, partial_order (α i)] : partial_order (Σ i, α i) :=
{ le_antisymm := begin
    rintro _ _ ⟨i, a, b, hab⟩ ⟨_, _, _, hba⟩,
    exact ext rfl (heq_of_eq $ hab.antisymm hba),
  end,
  .. sigma.preorder }

instance [Π i, preorder (α i)] [Π i, densely_ordered (α i)] : densely_ordered (Σ i, α i) :=
⟨begin
  rintro ⟨i, a⟩ ⟨_, _⟩ ⟨_, _, b, h⟩,
  obtain ⟨c, ha, hb⟩ := exists_between h,
  exact ⟨⟨i, c⟩, lt.fiber i a c ha, lt.fiber i c b hb⟩,
end⟩

/-! ### Lexicographical order on `sigma` -/

namespace lex

notation `Σₗ` binders `, ` r:(scoped p, _root_.lex (sigma p)) := r

/-- The lexicographical `≤` on a sigma type. -/
instance has_le [has_lt ι] [Π i, has_le (α i)] : has_le (Σₗ i, α i) := ⟨lex (<) (λ i, (≤))⟩

/-- The lexicographical `<` on a sigma type. -/
instance has_lt [has_lt ι] [Π i, has_lt (α i)] : has_lt (Σₗ i, α i) := ⟨lex (<) (λ i, (<))⟩

lemma le_def [has_lt ι] [Π i, has_le (α i)] {a b : Σₗ i, α i} :
  a ≤ b ↔ a.1 < b.1 ∨ ∃ (h : a.1 = b.1), h.rec a.2 ≤ b.2 := sigma.lex_iff

lemma lt_def [has_lt ι] [Π i, has_lt (α i)] {a b : Σₗ i, α i} :
  a < b ↔ a.1 < b.1 ∨ ∃ (h : a.1 = b.1), h.rec a.2 < b.2 := sigma.lex_iff

/-- The lexicographical preorder on a sigma type. -/
instance preorder [preorder ι] [Π i, preorder (α i)] : preorder (Σₗ i, α i) :=
{ le_refl := λ ⟨i, a⟩, lex.right a a le_rfl,
  le_trans := λ _ _ _, trans_of (lex (<) $ λ _, (≤)),
  lt_iff_le_not_le := begin
    refine λ a b, ⟨λ hab, ⟨hab.mono_right (λ i a b, le_of_lt), _⟩, _⟩,
    { rintro (⟨b, a, hji⟩ | ⟨b, a, hba⟩);
        obtain (⟨_, _, hij⟩ | ⟨_, _, hab⟩) := hab,
      { exact hij.not_lt hji },
      { exact lt_irrefl _ hji },
      { exact lt_irrefl _ hij },
      { exact hab.not_le hba } },
    { rintro ⟨⟨a, b, hij⟩ | ⟨a, b, hab⟩, hba⟩,
      { exact lex.left _ _ hij },
      { exact lex.right _ _ (hab.lt_of_not_le $ λ h, hba $ lex.right _ _ h) } }
  end,
  .. lex.has_le,
  .. lex.has_lt }

/-- The lexicographical partial order on a sigma type. -/
instance partial_order [preorder ι] [Π i, partial_order (α i)] :
  partial_order (Σₗ i, α i) :=
{ le_antisymm := λ _ _, antisymm_of (lex (<) $ λ _, (≤)),
  .. lex.preorder }

/-- The lexicographical linear order on a sigma type. -/
instance linear_order [linear_order ι] [Π i, linear_order (α i)] :
  linear_order (Σₗ i, α i) :=
{ le_total := total_of (lex (<) $ λ _, (≤)),
  decidable_eq := sigma.decidable_eq,
  decidable_le := lex.decidable _ _,
  .. lex.partial_order }

/-- The lexicographical linear order on a sigma type. -/
instance order_bot [partial_order ι] [order_bot ι] [Π i, preorder (α i)] [order_bot (α ⊥)] :
  order_bot (Σₗ i, α i) :=
{ bot := ⟨⊥, ⊥⟩,
  bot_le := λ ⟨a, b⟩, begin
    obtain rfl | ha := eq_bot_or_bot_lt a,
    { exact lex.right _ _ bot_le },
    { exact lex.left _ _ ha }
  end }

/-- The lexicographical linear order on a sigma type. -/
instance order_top [partial_order ι] [order_top ι] [Π i, preorder (α i)] [order_top (α ⊤)] :
  order_top (Σₗ i, α i) :=
{ top := ⟨⊤, ⊤⟩,
  le_top := λ ⟨a, b⟩, begin
    obtain rfl | ha := eq_top_or_lt_top a,
    { exact lex.right _ _ le_top },
    { exact lex.left _ _ ha }
  end }

/-- The lexicographical linear order on a sigma type. -/
instance bounded_order [partial_order ι] [bounded_order ι] [Π i, preorder (α i)]
  [order_bot (α ⊥)] [order_top (α ⊤)] :
  bounded_order (Σₗ i, α i) :=
{ .. lex.order_bot, .. lex.order_top }

instance densely_ordered [preorder ι] [densely_ordered ι] [Π i, nonempty (α i)]
  [Π i, preorder (α i)] [Π i, densely_ordered (α i)] :
  densely_ordered (Σₗ i, α i) :=
⟨begin
  rintro ⟨i, a⟩ ⟨j, b⟩ (⟨_, _, h⟩ | ⟨_, b, h⟩),
  { obtain ⟨k, hi, hj⟩ := exists_between h,
    obtain ⟨c⟩ : nonempty (α k) := infer_instance,
    exact ⟨⟨k, c⟩, left _ _ hi, left _ _ hj⟩ },
  { obtain ⟨c, ha, hb⟩ := exists_between h,
    exact ⟨⟨i, c⟩, right _ _ ha, right _ _ hb⟩ }
end⟩

instance densely_ordered_of_no_max_order [preorder ι] [Π i, preorder (α i)]
  [Π i, densely_ordered (α i)] [Π i, no_max_order (α i)] :
  densely_ordered (Σₗ i, α i) :=
⟨begin
  rintro ⟨i, a⟩ ⟨j, b⟩ (⟨_, _, h⟩ | ⟨_, b, h⟩),
  { obtain ⟨c, ha⟩ := exists_gt a,
    exact ⟨⟨i, c⟩, right _ _ ha, left _ _ h⟩ },
  { obtain ⟨c, ha, hb⟩ := exists_between h,
    exact ⟨⟨i, c⟩, right _ _ ha, right _ _ hb⟩ }
end⟩

instance densely_ordered_of_no_min_order [preorder ι] [Π i, preorder (α i)]
  [Π i, densely_ordered (α i)] [Π i, no_min_order (α i)] :
  densely_ordered (Σₗ i, α i) :=
⟨begin
  rintro ⟨i, a⟩ ⟨j, b⟩ (⟨_, _, h⟩ | ⟨_, b, h⟩),
  { obtain ⟨c, hb⟩ := exists_lt b,
    exact ⟨⟨j, c⟩, left _ _ h, right _ _ hb⟩ },
  { obtain ⟨c, ha, hb⟩ := exists_between h,
    exact ⟨⟨i, c⟩, right _ _ ha, right _ _ hb⟩ }
end⟩

instance no_max_order_of_nonempty [preorder ι] [Π i, preorder (α i)] [no_max_order ι]
  [Π i, nonempty (α i)] :
  no_max_order (Σₗ i, α i) :=
⟨begin
  rintro ⟨i, a⟩,
  obtain ⟨j, h⟩ := exists_gt i,
  obtain ⟨b⟩ : nonempty (α j) := infer_instance,
  exact ⟨⟨j, b⟩, left _ _ h⟩
end⟩

instance no_min_order_of_nonempty [preorder ι] [Π i, preorder (α i)] [no_max_order ι]
  [Π i, nonempty (α i)] :
  no_max_order (Σₗ i, α i) :=
⟨begin
  rintro ⟨i, a⟩,
  obtain ⟨j, h⟩ := exists_gt i,
  obtain ⟨b⟩ : nonempty (α j) := infer_instance,
  exact ⟨⟨j, b⟩, left _ _ h⟩
end⟩

instance no_max_order [preorder ι] [Π i, preorder (α i)] [Π i, no_max_order (α i)] :
  no_max_order (Σₗ i, α i) :=
⟨by { rintro ⟨i, a⟩, obtain ⟨b, h⟩ := exists_gt a, exact ⟨⟨i, b⟩, right _ _ h⟩ }⟩

instance no_min_order [preorder ι] [Π i, preorder (α i)] [Π i, no_min_order (α i)] :
  no_min_order (Σₗ i, α i) :=
⟨by { rintro ⟨i, a⟩, obtain ⟨b, h⟩ := exists_lt a, exact ⟨⟨i, b⟩, right _ _ h⟩ }⟩

end lex
end sigma


/-
Copyright (c) 2019 Rohan Mitta. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Rohan Mitta, Kevin Buzzard, Alistair Tucker, Johannes Hölzl, Yury Kudryashov
-/
import analysis.specific_limits.basic
import data.setoid.basic
import dynamics.fixed_points.topology

/-!
# Contracting maps

A Lipschitz continuous self-map with Lipschitz constant `K < 1` is called a *contracting map*.
In this file we prove the Banach fixed point theorem, some explicit estimates on the rate
of convergence, and some properties of the map sending a contracting map to its fixed point.

## Main definitions

* `contracting_with K f` : a Lipschitz continuous self-map with `K < 1`;
* `efixed_point` : given a contracting map `f` on a complete emetric space and a point `x`
  such that `edist x (f x) ≠ ∞`, `efixed_point f hf x hx` is the unique fixed point of `f`
  in `emetric.ball x ∞`;
* `fixed_point` : the unique fixed point of a contracting map on a complete nonempty metric space.

## Tags

contracting map, fixed point, Banach fixed point theorem
-/

open_locale nnreal topological_space classical ennreal
open filter function

variables {α : Type*}

/-- A map is said to be `contracting_with K`, if `K < 1` and `f` is `lipschitz_with K`. -/
def contracting_with [emetric_space α] (K : ℝ≥0) (f : α → α) :=
(K < 1) ∧ lipschitz_with K f

namespace contracting_with

variables [emetric_space α] [cs : complete_space α] {K : ℝ≥0} {f : α → α}

open emetric set

lemma to_lipschitz_with (hf : contracting_with K f) : lipschitz_with K f := hf.2

lemma one_sub_K_pos' (hf : contracting_with K f) : (0:ℝ≥0∞) < 1 - K := by simp [hf.1]

lemma one_sub_K_ne_zero (hf : contracting_with K f) : (1:ℝ≥0∞) - K ≠ 0 :=
ne_of_gt hf.one_sub_K_pos'

lemma one_sub_K_ne_top : (1:ℝ≥0∞) - K ≠ ∞ :=
by { norm_cast, exact ennreal.coe_ne_top }

lemma edist_inequality (hf : contracting_with K f) {x y} (h : edist x y ≠ ∞) :
  edist x y ≤ (edist x (f x) + edist y (f y)) / (1 - K) :=
suffices edist x y ≤ edist x (f x) + edist y (f y) + K * edist x y,
  by rwa [ennreal.le_div_iff_mul_le (or.inl hf.one_sub_K_ne_zero) (or.inl one_sub_K_ne_top),
    mul_comm, ennreal.sub_mul (λ _ _, h), one_mul, tsub_le_iff_right],
calc edist x y ≤ edist x (f x) + edist (f x) (f y) + edist (f y) y : edist_triangle4 _ _ _ _
  ... = edist x (f x) + edist y (f y) + edist (f x) (f y) : by rw [edist_comm y, add_right_comm]
  ... ≤ edist x (f x) + edist y (f y) + K * edist x y : add_le_add le_rfl (hf.2 _ _)

lemma edist_le_of_fixed_point (hf : contracting_with K f) {x y}
  (h : edist x y ≠ ∞) (hy : is_fixed_pt f y) :
  edist x y ≤ (edist x (f x)) / (1 - K) :=
by simpa only [hy.eq, edist_self, add_zero] using hf.edist_inequality h

lemma eq_or_edist_eq_top_of_fixed_points (hf : contracting_with K f) {x y}
  (hx : is_fixed_pt f x) (hy : is_fixed_pt f y) :
  x = y ∨ edist x y = ∞ :=
begin
  refine or_iff_not_imp_right.2 (λ h, edist_le_zero.1 _),
  simpa only [hx.eq, edist_self, add_zero, ennreal.zero_div]
    using hf.edist_le_of_fixed_point h hy
end

/-- If a map `f` is `contracting_with K`, and `s` is a forward-invariant set, then
restriction of `f` to `s` is `contracting_with K` as well. -/
lemma restrict (hf : contracting_with K f) {s : set α} (hs : maps_to f s s) :
  contracting_with K (hs.restrict f s s) :=
⟨hf.1, λ x y, hf.2 x y⟩

include cs

/-- Banach fixed-point theorem, contraction mapping theorem, `emetric_space` version.
A contracting map on a complete metric space has a fixed point.
We include more conclusions in this theorem to avoid proving them again later.

The main API for this theorem are the functions `efixed_point` and `fixed_point`,
and lemmas about these functions. -/
theorem exists_fixed_point (hf : contracting_with K f) (x : α) (hx : edist x (f x) ≠ ∞) :
  ∃ y, is_fixed_pt f y ∧ tendsto (λ n, f^[n] x) at_top (𝓝 y) ∧
    ∀ n:ℕ, edist (f^[n] x) y ≤ (edist x (f x)) * K^n / (1 - K) :=
have cauchy_seq (λ n, f^[n] x),
from cauchy_seq_of_edist_le_geometric K (edist x (f x)) (ennreal.coe_lt_one_iff.2 hf.1)
  hx (hf.to_lipschitz_with.edist_iterate_succ_le_geometric x),
let ⟨y, hy⟩ := cauchy_seq_tendsto_of_complete this in
⟨y, is_fixed_pt_of_tendsto_iterate hy hf.2.continuous.continuous_at, hy,
  edist_le_of_edist_le_geometric_of_tendsto K (edist x (f x))
    (hf.to_lipschitz_with.edist_iterate_succ_le_geometric x) hy⟩

variable (f) -- avoid `efixed_point _` in pretty printer

/-- Let `x` be a point of a complete emetric space. Suppose that `f` is a contracting map,
and `edist x (f x) ≠ ∞`. Then `efixed_point` is the unique fixed point of `f`
in `emetric.ball x ∞`. -/
noncomputable def efixed_point (hf : contracting_with K f) (x : α) (hx : edist x (f x) ≠ ∞) :
  α :=
classical.some $ hf.exists_fixed_point x hx

variables {f}

lemma efixed_point_is_fixed_pt (hf : contracting_with K f) {x : α} (hx : edist x (f x) ≠ ∞) :
  is_fixed_pt f (efixed_point f hf x hx) :=
(classical.some_spec $ hf.exists_fixed_point x hx).1

lemma tendsto_iterate_efixed_point (hf : contracting_with K f) {x : α} (hx : edist x (f x) ≠ ∞) :
  tendsto (λn, f^[n] x) at_top (𝓝 $ efixed_point f hf x hx) :=
(classical.some_spec $ hf.exists_fixed_point x hx).2.1

lemma apriori_edist_iterate_efixed_point_le (hf : contracting_with K f)
  {x : α} (hx : edist x (f x) ≠ ∞) (n : ℕ) :
  edist (f^[n] x) (efixed_point f hf x hx) ≤ (edist x (f x)) * K^n / (1 - K) :=
(classical.some_spec $ hf.exists_fixed_point x hx).2.2 n

lemma edist_efixed_point_le (hf : contracting_with K f) {x : α} (hx : edist x (f x) ≠ ∞) :
  edist x (efixed_point f hf x hx) ≤ (edist x (f x)) / (1 - K) :=
by { convert hf.apriori_edist_iterate_efixed_point_le hx 0, simp only [pow_zero, mul_one] }

lemma edist_efixed_point_lt_top (hf : contracting_with K f) {x : α} (hx : edist x (f x) ≠ ∞) :
  edist x (efixed_point f hf x hx) < ∞ :=
(hf.edist_efixed_point_le hx).trans_lt (ennreal.mul_lt_top hx $
  ennreal.inv_ne_top.2 hf.one_sub_K_ne_zero)

lemma efixed_point_eq_of_edist_lt_top (hf : contracting_with K f) {x : α} (hx : edist x (f x) ≠ ∞)
  {y : α} (hy : edist y (f y) ≠ ∞) (h : edist x y ≠ ∞) :
  efixed_point f hf x hx = efixed_point f hf y hy :=
begin
  refine (hf.eq_or_edist_eq_top_of_fixed_points _ _).elim id (λ h', false.elim (ne_of_lt _ h'));
    try { apply efixed_point_is_fixed_pt },
  change edist_lt_top_setoid.rel _ _,
  transitivity x, by { symmetry, exact hf.edist_efixed_point_lt_top hx },
  transitivity y,
  exacts [lt_top_iff_ne_top.2 h, hf.edist_efixed_point_lt_top hy]
end

omit cs

/-- Banach fixed-point theorem for maps contracting on a complete subset. -/
theorem exists_fixed_point' {s : set α} (hsc : is_complete s) (hsf : maps_to f s s)
  (hf : contracting_with K $ hsf.restrict f s s) {x : α} (hxs : x ∈ s) (hx : edist x (f x) ≠ ∞) :
  ∃ y ∈ s, is_fixed_pt f y ∧ tendsto (λ n, f^[n] x) at_top (𝓝 y) ∧
    ∀ n:ℕ, edist (f^[n] x) y ≤ (edist x (f x)) * K^n / (1 - K) :=
begin
  haveI := hsc.complete_space_coe,
  rcases hf.exists_fixed_point ⟨x, hxs⟩ hx with ⟨y, hfy, h_tendsto, hle⟩,
  refine ⟨y, y.2, subtype.ext_iff_val.1 hfy, _, λ n, _⟩,
  { convert (continuous_subtype_coe.tendsto _).comp h_tendsto, ext n,
    simp only [(∘), maps_to.iterate_restrict, maps_to.coe_restrict_apply, subtype.coe_mk] },
  { convert hle n,
    rw [maps_to.iterate_restrict, eq_comm, maps_to.coe_restrict_apply, subtype.coe_mk] }
end

variable (f) -- avoid `efixed_point _` in pretty printer

/-- Let `s` be a complete forward-invariant set of a self-map `f`. If `f` contracts on `s`
and `x ∈ s` satisfies `edist x (f x) ≠ ∞`, then `efixed_point'` is the unique fixed point
of the restriction of `f` to `s ∩ emetric.ball x ∞`. -/
noncomputable def efixed_point' {s : set α} (hsc : is_complete s) (hsf : maps_to f s s)
  (hf : contracting_with K $ hsf.restrict f s s) (x : α) (hxs : x ∈ s) (hx : edist x (f x) ≠ ∞) :
  α :=
classical.some $ hf.exists_fixed_point' hsc hsf hxs hx

variables {f}

lemma efixed_point_mem' {s : set α} (hsc : is_complete s) (hsf : maps_to f s s)
  (hf : contracting_with K $ hsf.restrict f s s) {x : α} (hxs : x ∈ s) (hx : edist x (f x) ≠ ∞) :
  efixed_point' f hsc hsf hf x hxs hx ∈ s :=
(classical.some_spec $ hf.exists_fixed_point' hsc hsf hxs hx).fst

lemma efixed_point_is_fixed_pt' {s : set α} (hsc : is_complete s) (hsf : maps_to f s s)
  (hf : contracting_with K $ hsf.restrict f s s) {x : α} (hxs : x ∈ s) (hx : edist x (f x) ≠ ∞) :
  is_fixed_pt f (efixed_point' f hsc hsf hf x hxs hx) :=
(classical.some_spec $ hf.exists_fixed_point' hsc hsf hxs hx).snd.1

lemma tendsto_iterate_efixed_point' {s : set α} (hsc : is_complete s) (hsf : maps_to f s s)
  (hf : contracting_with K $ hsf.restrict f s s) {x : α} (hxs : x ∈ s) (hx : edist x (f x) ≠ ∞) :
  tendsto (λn, f^[n] x) at_top (𝓝 $ efixed_point' f hsc hsf hf x hxs hx) :=
(classical.some_spec $ hf.exists_fixed_point' hsc hsf hxs hx).snd.2.1

lemma apriori_edist_iterate_efixed_point_le' {s : set α} (hsc : is_complete s)
  (hsf : maps_to f s s) (hf : contracting_with K $ hsf.restrict f s s) {x : α} (hxs : x ∈ s)
  (hx : edist x (f x) ≠ ∞) (n : ℕ) :
  edist (f^[n] x) (efixed_point' f hsc hsf hf x hxs hx) ≤ (edist x (f x)) * K^n / (1 - K) :=
(classical.some_spec $ hf.exists_fixed_point' hsc hsf hxs hx).snd.2.2 n

lemma edist_efixed_point_le' {s : set α} (hsc : is_complete s) (hsf : maps_to f s s)
  (hf : contracting_with K $ hsf.restrict f s s) {x : α} (hxs : x ∈ s) (hx : edist x (f x) ≠ ∞) :
  edist x (efixed_point' f hsc hsf hf x hxs hx) ≤ (edist x (f x)) / (1 - K) :=
by { convert hf.apriori_edist_iterate_efixed_point_le' hsc hsf hxs hx 0,
  rw [pow_zero, mul_one] }

lemma edist_efixed_point_lt_top' {s : set α} (hsc : is_complete s) (hsf : maps_to f s s)
  (hf : contracting_with K $ hsf.restrict f s s) {x : α} (hxs : x ∈ s) (hx : edist x (f x) ≠ ∞) :
  edist x (efixed_point' f hsc hsf hf x hxs hx) < ∞ :=
(hf.edist_efixed_point_le' hsc hsf hxs hx).trans_lt (ennreal.mul_lt_top hx $
  ennreal.inv_ne_top.2 hf.one_sub_K_ne_zero)

/-- If a globally contracting map `f` has two complete forward-invariant sets `s`, `t`,
and `x ∈ s` is at a finite distance from `y ∈ t`, then the `efixed_point'` constructed by `x`
is the same as the `efixed_point'` constructed by `y`.

This lemma takes additional arguments stating that `f` contracts on `s` and `t` because this way
it can be used to prove the desired equality with non-trivial proofs of these facts. -/
lemma efixed_point_eq_of_edist_lt_top' (hf : contracting_with K f)
  {s : set α} (hsc : is_complete s) (hsf : maps_to f s s)
  (hfs : contracting_with K $ hsf.restrict f s s) {x : α} (hxs : x ∈ s) (hx : edist x (f x) ≠ ∞)
  {t : set α} (htc : is_complete t) (htf : maps_to f t t)
  (hft : contracting_with K $ htf.restrict f t t) {y : α} (hyt : y ∈ t) (hy : edist y (f y) ≠ ∞)
  (hxy : edist x y ≠ ∞) :
  efixed_point' f hsc hsf hfs x hxs hx = efixed_point' f htc htf hft y hyt hy :=
begin
  refine (hf.eq_or_edist_eq_top_of_fixed_points _ _).elim id (λ h', false.elim (ne_of_lt _ h'));
    try { apply efixed_point_is_fixed_pt' },
  change edist_lt_top_setoid.rel _ _,
  transitivity x, by { symmetry, apply edist_efixed_point_lt_top' },
  transitivity y,
  exact lt_top_iff_ne_top.2 hxy,
  apply edist_efixed_point_lt_top'
end

end contracting_with

namespace contracting_with

variables [metric_space α] {K : ℝ≥0} {f : α → α} (hf : contracting_with K f)
include hf

lemma one_sub_K_pos (hf : contracting_with K f) : (0:ℝ) < 1 - K := sub_pos.2 hf.1

lemma dist_le_mul (x y : α) : dist (f x) (f y) ≤ K * dist x y :=
hf.to_lipschitz_with.dist_le_mul x y

lemma dist_inequality (x y) : dist x y ≤ (dist x (f x) + dist y (f y)) / (1 - K) :=
suffices dist x y ≤ dist x (f x) + dist y (f y) + K * dist x y,
  by rwa [le_div_iff hf.one_sub_K_pos, mul_comm, sub_mul, one_mul, sub_le_iff_le_add],
calc dist x y ≤ dist x (f x) + dist y (f y) + dist (f x) (f y) : dist_triangle4_right _ _ _ _
          ... ≤ dist x (f x) + dist y (f y) + K * dist x y :
  add_le_add_left (hf.dist_le_mul _ _) _

lemma dist_le_of_fixed_point (x) {y} (hy : is_fixed_pt f y) :
  dist x y ≤ (dist x (f x)) / (1 - K) :=
by simpa only [hy.eq, dist_self, add_zero] using hf.dist_inequality x y

theorem fixed_point_unique' {x y} (hx : is_fixed_pt f x) (hy : is_fixed_pt f y) : x = y :=
(hf.eq_or_edist_eq_top_of_fixed_points hx hy).resolve_right (edist_ne_top _ _)

/-- Let `f` be a contracting map with constant `K`; let `g` be another map uniformly
`C`-close to `f`. If `x` and `y` are their fixed points, then `dist x y ≤ C / (1 - K)`. -/

noncomputable theory

variables [nonempty α] [complete_space α]

variable (f)
/-- The unique fixed point of a contracting map in a nonempty complete metric space. -/
def fixed_point : α :=
efixed_point f hf _ (edist_ne_top (classical.choice ‹nonempty α›) _)
variable {f}

/-- The point provided by `contracting_with.fixed_point` is actually a fixed point. -/
lemma fixed_point_is_fixed_pt : is_fixed_pt f (fixed_point f hf) :=
hf.efixed_point_is_fixed_pt _

lemma fixed_point_unique {x} (hx : is_fixed_pt f x) : x = fixed_point f hf :=
hf.fixed_point_unique' hx hf.fixed_point_is_fixed_pt

lemma dist_fixed_point_le (x) : dist x (fixed_point f hf) ≤ (dist x (f x)) / (1 - K) :=
hf.dist_le_of_fixed_point x hf.fixed_point_is_fixed_pt

/-- Aposteriori estimates on the convergence of iterates to the fixed point. -/
lemma aposteriori_dist_iterate_fixed_point_le (x n) :
  dist (f^[n] x) (fixed_point f hf) ≤ (dist (f^[n] x) (f^[n+1] x)) / (1 - K) :=
by { rw [iterate_succ'], apply hf.dist_fixed_point_le }

lemma apriori_dist_iterate_fixed_point_le (x n) :
  dist (f^[n] x) (fixed_point f hf) ≤ (dist x (f x)) * K^n / (1 - K) :=
le_trans (hf.aposteriori_dist_iterate_fixed_point_le x n) $
  (div_le_div_right hf.one_sub_K_pos).2 $
    hf.to_lipschitz_with.dist_iterate_succ_le_geometric x n

lemma tendsto_iterate_fixed_point (x) :
  tendsto (λn, f^[n] x) at_top (𝓝 $ fixed_point f hf) :=
begin
  convert tendsto_iterate_efixed_point hf (edist_ne_top x _),
  refine (fixed_point_unique _ _).symm,
  apply efixed_point_is_fixed_pt
end

lemma fixed_point_lipschitz_in_map {g : α → α} (hg : contracting_with K g)
  {C} (hfg : ∀ z, dist (f z) (g z) ≤ C) :
  dist (fixed_point f hf) (fixed_point g hg) ≤ C / (1 - K) :=
hf.dist_fixed_point_fixed_point_of_dist_le' g hf.fixed_point_is_fixed_pt
  hg.fixed_point_is_fixed_pt hfg

omit hf

/-- If a map `f` has a contracting iterate `f^[n]`, then the fixed point of `f^[n]` is also a fixed
point of `f`. -/
lemma is_fixed_pt_fixed_point_iterate {n : ℕ} (hf : contracting_with K (f^[n])) :
  is_fixed_pt f (hf.fixed_point (f^[n])) :=
begin
  set x := hf.fixed_point (f^[n]),
  have hx : (f^[n] x) = x := hf.fixed_point_is_fixed_pt,
  have := hf.to_lipschitz_with.dist_le_mul x (f x),
  rw [← iterate_succ_apply, iterate_succ_apply', hx] at this,
  contrapose! this,
  have := dist_pos.2 (ne.symm this),
  simpa only [nnreal.coe_one, one_mul, nnreal.val_eq_coe] using (mul_lt_mul_right this).mpr hf.left
end

end contracting_with


/-
Copyright (c) 2019 Rohan Mitta. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Rohan Mitta, Kevin Buzzard, Alistair Tucker, Johannes Hölzl, Yury Kudryashov
-/
import analysis.specific_limits
import data.setoid.basic
import dynamics.fixed_points.topology

/-!
# Contracting maps

A Lipschitz continuous self-map with Lipschitz constant `K < 1` is called a *contracting map*.
In this file we prove the Banach fixed point theorem, some explicit estimates on the rate
of convergence, and some properties of the map sending a contracting map to its fixed point.

## Main definitions

* `contracting_with K f` : a Lipschitz continuous self-map with `K < 1`;
* `efixed_point` : given a contracting map `f` on a complete emetric space and a point `x`
  such that `edist x (f x) ≠ ∞`, `efixed_point f hf x hx` is the unique fixed point of `f`
  in `emetric.ball x ∞`;
* `fixed_point` : the unique fixed point of a contracting map on a complete nonempty metric space.

## Tags

contracting map, fixed point, Banach fixed point theorem
-/

open_locale nnreal topological_space classical ennreal
open filter function

variables {α : Type*}

/-- A map is said to be `contracting_with K`, if `K < 1` and `f` is `lipschitz_with K`. -/
def contracting_with [emetric_space α] (K : ℝ≥0) (f : α → α) :=
(K < 1) ∧ lipschitz_with K f

namespace contracting_with

variables [emetric_space α] [cs : complete_space α] {K : ℝ≥0} {f : α → α}

open emetric set

lemma to_lipschitz_with (hf : contracting_with K f) : lipschitz_with K f := hf.2

lemma one_sub_K_pos' (hf : contracting_with K f) : (0:ℝ≥0∞) < 1 - K := by simp [hf.1]

lemma one_sub_K_ne_zero (hf : contracting_with K f) : (1:ℝ≥0∞) - K ≠ 0 :=
ne_of_gt hf.one_sub_K_pos'

lemma one_sub_K_ne_top : (1:ℝ≥0∞) - K ≠ ∞ :=
by { norm_cast, exact ennreal.coe_ne_top }

lemma edist_inequality (hf : contracting_with K f) {x y} (h : edist x y ≠ ∞) :
  edist x y ≤ (edist x (f x) + edist y (f y)) / (1 - K) :=
suffices edist x y ≤ edist x (f x) + edist y (f y) + K * edist x y,
  by rwa [ennreal.le_div_iff_mul_le (or.inl hf.one_sub_K_ne_zero) (or.inl one_sub_K_ne_top),
    mul_comm, ennreal.sub_mul (λ _ _, h), one_mul, tsub_le_iff_right],
calc edist x y ≤ edist x (f x) + edist (f x) (f y) + edist (f y) y : edist_triangle4 _ _ _ _
  ... = edist x (f x) + edist y (f y) + edist (f x) (f y) : by rw [edist_comm y, add_right_comm]
  ... ≤ edist x (f x) + edist y (f y) + K * edist x y : add_le_add (le_refl _) (hf.2 _ _)

lemma edist_le_of_fixed_point (hf : contracting_with K f) {x y}
  (h : edist x y ≠ ∞) (hy : is_fixed_pt f y) :
  edist x y ≤ (edist x (f x)) / (1 - K) :=
by simpa only [hy.eq, edist_self, add_zero] using hf.edist_inequality h

lemma eq_or_edist_eq_top_of_fixed_points (hf : contracting_with K f) {x y}
  (hx : is_fixed_pt f x) (hy : is_fixed_pt f y) :
  x = y ∨ edist x y = ∞ :=
begin
  refine or_iff_not_imp_right.2 (λ h, edist_le_zero.1 _),
  simpa only [hx.eq, edist_self, add_zero, ennreal.zero_div]
    using hf.edist_le_of_fixed_point h hy
end

/-- If a map `f` is `contracting_with K`, and `s` is a forward-invariant set, then
restriction of `f` to `s` is `contracting_with K` as well. -/
lemma restrict (hf : contracting_with K f) {s : set α} (hs : maps_to f s s) :
  contracting_with K (hs.restrict f s s) :=
⟨hf.1, λ x y, hf.2 x y⟩

include cs

/-- Banach fixed-point theorem, contraction mapping theorem, `emetric_space` version.
A contracting map on a complete metric space has a fixed point.
We include more conclusions in this theorem to avoid proving them again later.

The main API for this theorem are the functions `efixed_point` and `fixed_point`,
and lemmas about these functions. -/
theorem exists_fixed_point (hf : contracting_with K f) (x : α) (hx : edist x (f x) ≠ ∞) :
  ∃ y, is_fixed_pt f y ∧ tendsto (λ n, f^[n] x) at_top (𝓝 y) ∧
    ∀ n:ℕ, edist (f^[n] x) y ≤ (edist x (f x)) * K^n / (1 - K) :=
have cauchy_seq (λ n, f^[n] x),
from cauchy_seq_of_edist_le_geometric K (edist x (f x)) (ennreal.coe_lt_one_iff.2 hf.1)
  hx (hf.to_lipschitz_with.edist_iterate_succ_le_geometric x),
let ⟨y, hy⟩ := cauchy_seq_tendsto_of_complete this in
⟨y, is_fixed_pt_of_tendsto_iterate hy hf.2.continuous.continuous_at, hy,
  edist_le_of_edist_le_geometric_of_tendsto K (edist x (f x))
    (hf.to_lipschitz_with.edist_iterate_succ_le_geometric x) hy⟩

variable (f) -- avoid `efixed_point _` in pretty printer

/-- Let `x` be a point of a complete emetric space. Suppose that `f` is a contracting map,
and `edist x (f x) ≠ ∞`. Then `efixed_point` is the unique fixed point of `f`
in `emetric.ball x ∞`. -/
noncomputable def efixed_point (hf : contracting_with K f) (x : α) (hx : edist x (f x) ≠ ∞) :
  α :=
classical.some $ hf.exists_fixed_point x hx

variables {f}

lemma efixed_point_is_fixed_pt (hf : contracting_with K f) {x : α} (hx : edist x (f x) ≠ ∞) :
  is_fixed_pt f (efixed_point f hf x hx) :=
(classical.some_spec $ hf.exists_fixed_point x hx).1

lemma tendsto_iterate_efixed_point (hf : contracting_with K f) {x : α} (hx : edist x (f x) ≠ ∞) :
  tendsto (λn, f^[n] x) at_top (𝓝 $ efixed_point f hf x hx) :=
(classical.some_spec $ hf.exists_fixed_point x hx).2.1

lemma apriori_edist_iterate_efixed_point_le (hf : contracting_with K f)
  {x : α} (hx : edist x (f x) ≠ ∞) (n : ℕ) :
  edist (f^[n] x) (efixed_point f hf x hx) ≤ (edist x (f x)) * K^n / (1 - K) :=
(classical.some_spec $ hf.exists_fixed_point x hx).2.2 n

lemma edist_efixed_point_le (hf : contracting_with K f) {x : α} (hx : edist x (f x) ≠ ∞) :
  edist x (efixed_point f hf x hx) ≤ (edist x (f x)) / (1 - K) :=
by { convert hf.apriori_edist_iterate_efixed_point_le hx 0, simp only [pow_zero, mul_one] }

lemma edist_efixed_point_lt_top (hf : contracting_with K f) {x : α} (hx : edist x (f x) ≠ ∞) :
  edist x (efixed_point f hf x hx) < ∞ :=
(hf.edist_efixed_point_le hx).trans_lt (ennreal.mul_lt_top hx $
  ennreal.inv_ne_top.2 hf.one_sub_K_ne_zero)

lemma efixed_point_eq_of_edist_lt_top (hf : contracting_with K f) {x : α} (hx : edist x (f x) ≠ ∞)
  {y : α} (hy : edist y (f y) ≠ ∞) (h : edist x y ≠ ∞) :
  efixed_point f hf x hx = efixed_point f hf y hy :=
begin
  refine (hf.eq_or_edist_eq_top_of_fixed_points _ _).elim id (λ h', false.elim (ne_of_lt _ h'));
    try { apply efixed_point_is_fixed_pt },
  change edist_lt_top_setoid.rel _ _,
  transitivity x, by { symmetry, exact hf.edist_efixed_point_lt_top hx },
  transitivity y,
  exacts [lt_top_iff_ne_top.2 h, hf.edist_efixed_point_lt_top hy]
end

omit cs

/-- Banach fixed-point theorem for maps contracting on a complete subset. -/
theorem exists_fixed_point' {s : set α} (hsc : is_complete s) (hsf : maps_to f s s)
  (hf : contracting_with K $ hsf.restrict f s s) {x : α} (hxs : x ∈ s) (hx : edist x (f x) ≠ ∞) :
  ∃ y ∈ s, is_fixed_pt f y ∧ tendsto (λ n, f^[n] x) at_top (𝓝 y) ∧
    ∀ n:ℕ, edist (f^[n] x) y ≤ (edist x (f x)) * K^n / (1 - K) :=
begin
  haveI := hsc.complete_space_coe,
  rcases hf.exists_fixed_point ⟨x, hxs⟩ hx with ⟨y, hfy, h_tendsto, hle⟩,
  refine ⟨y, y.2, subtype.ext_iff_val.1 hfy, _, λ n, _⟩,
  { convert (continuous_subtype_coe.tendsto _).comp h_tendsto, ext n,
    simp only [(∘), maps_to.iterate_restrict, maps_to.coe_restrict_apply, subtype.coe_mk] },
  { convert hle n,
    rw [maps_to.iterate_restrict, eq_comm, maps_to.coe_restrict_apply, subtype.coe_mk] }
end

variable (f) -- avoid `efixed_point _` in pretty printer

/-- Let `s` be a complete forward-invariant set of a self-map `f`. If `f` contracts on `s`
and `x ∈ s` satisfies `edist x (f x) ≠ ∞`, then `efixed_point'` is the unique fixed point
of the restriction of `f` to `s ∩ emetric.ball x ∞`. -/
noncomputable def efixed_point' {s : set α} (hsc : is_complete s) (hsf : maps_to f s s)
  (hf : contracting_with K $ hsf.restrict f s s) (x : α) (hxs : x ∈ s) (hx : edist x (f x) ≠ ∞) :
  α :=
classical.some $ hf.exists_fixed_point' hsc hsf hxs hx

variables {f}

lemma efixed_point_mem' {s : set α} (hsc : is_complete s) (hsf : maps_to f s s)
  (hf : contracting_with K $ hsf.restrict f s s) {x : α} (hxs : x ∈ s) (hx : edist x (f x) ≠ ∞) :
  efixed_point' f hsc hsf hf x hxs hx ∈ s :=
(classical.some_spec $ hf.exists_fixed_point' hsc hsf hxs hx).fst

lemma efixed_point_is_fixed_pt' {s : set α} (hsc : is_complete s) (hsf : maps_to f s s)
  (hf : contracting_with K $ hsf.restrict f s s) {x : α} (hxs : x ∈ s) (hx : edist x (f x) ≠ ∞) :
  is_fixed_pt f (efixed_point' f hsc hsf hf x hxs hx) :=
(classical.some_spec $ hf.exists_fixed_point' hsc hsf hxs hx).snd.1

lemma tendsto_iterate_efixed_point' {s : set α} (hsc : is_complete s) (hsf : maps_to f s s)
  (hf : contracting_with K $ hsf.restrict f s s) {x : α} (hxs : x ∈ s) (hx : edist x (f x) ≠ ∞) :
  tendsto (λn, f^[n] x) at_top (𝓝 $ efixed_point' f hsc hsf hf x hxs hx) :=
(classical.some_spec $ hf.exists_fixed_point' hsc hsf hxs hx).snd.2.1

lemma apriori_edist_iterate_efixed_point_le' {s : set α} (hsc : is_complete s)
  (hsf : maps_to f s s) (hf : contracting_with K $ hsf.restrict f s s) {x : α} (hxs : x ∈ s)
  (hx : edist x (f x) ≠ ∞) (n : ℕ) :
  edist (f^[n] x) (efixed_point' f hsc hsf hf x hxs hx) ≤ (edist x (f x)) * K^n / (1 - K) :=
(classical.some_spec $ hf.exists_fixed_point' hsc hsf hxs hx).snd.2.2 n

lemma edist_efixed_point_le' {s : set α} (hsc : is_complete s) (hsf : maps_to f s s)
  (hf : contracting_with K $ hsf.restrict f s s) {x : α} (hxs : x ∈ s) (hx : edist x (f x) ≠ ∞) :
  edist x (efixed_point' f hsc hsf hf x hxs hx) ≤ (edist x (f x)) / (1 - K) :=
by { convert hf.apriori_edist_iterate_efixed_point_le' hsc hsf hxs hx 0,
  rw [pow_zero, mul_one] }

lemma edist_efixed_point_lt_top' {s : set α} (hsc : is_complete s) (hsf : maps_to f s s)
  (hf : contracting_with K $ hsf.restrict f s s) {x : α} (hxs : x ∈ s) (hx : edist x (f x) ≠ ∞) :
  edist x (efixed_point' f hsc hsf hf x hxs hx) < ∞ :=
(hf.edist_efixed_point_le' hsc hsf hxs hx).trans_lt (ennreal.mul_lt_top hx $
  ennreal.inv_ne_top.2 hf.one_sub_K_ne_zero)

/-- If a globally contracting map `f` has two complete forward-invariant sets `s`, `t`,
and `x ∈ s` is at a finite distance from `y ∈ t`, then the `efixed_point'` constructed by `x`
is the same as the `efixed_point'` constructed by `y`.

This lemma takes additional arguments stating that `f` contracts on `s` and `t` because this way
it can be used to prove the desired equality with non-trivial proofs of these facts. -/
lemma efixed_point_eq_of_edist_lt_top' (hf : contracting_with K f)
  {s : set α} (hsc : is_complete s) (hsf : maps_to f s s)
  (hfs : contracting_with K $ hsf.restrict f s s) {x : α} (hxs : x ∈ s) (hx : edist x (f x) ≠ ∞)
  {t : set α} (htc : is_complete t) (htf : maps_to f t t)
  (hft : contracting_with K $ htf.restrict f t t) {y : α} (hyt : y ∈ t) (hy : edist y (f y) ≠ ∞)
  (hxy : edist x y ≠ ∞) :
  efixed_point' f hsc hsf hfs x hxs hx = efixed_point' f htc htf hft y hyt hy :=
begin
  refine (hf.eq_or_edist_eq_top_of_fixed_points _ _).elim id (λ h', false.elim (ne_of_lt _ h'));
    try { apply efixed_point_is_fixed_pt' },
  change edist_lt_top_setoid.rel _ _,
  transitivity x, by { symmetry, apply edist_efixed_point_lt_top' },
  transitivity y,
  exact lt_top_iff_ne_top.2 hxy,
  apply edist_efixed_point_lt_top'
end

end contracting_with

namespace contracting_with

variables [metric_space α] {K : ℝ≥0} {f : α → α} (hf : contracting_with K f)
include hf

lemma one_sub_K_pos (hf : contracting_with K f) : (0:ℝ) < 1 - K := sub_pos.2 hf.1

lemma dist_le_mul (x y : α) : dist (f x) (f y) ≤ K * dist x y :=
hf.to_lipschitz_with.dist_le_mul x y

lemma dist_inequality (x y) : dist x y ≤ (dist x (f x) + dist y (f y)) / (1 - K) :=
suffices dist x y ≤ dist x (f x) + dist y (f y) + K * dist x y,
  by rwa [le_div_iff hf.one_sub_K_pos, mul_comm, sub_mul, one_mul, sub_le_iff_le_add],
calc dist x y ≤ dist x (f x) + dist y (f y) + dist (f x) (f y) : dist_triangle4_right _ _ _ _
          ... ≤ dist x (f x) + dist y (f y) + K * dist x y :
  add_le_add_left (hf.dist_le_mul _ _) _

lemma dist_le_of_fixed_point (x) {y} (hy : is_fixed_pt f y) :
  dist x y ≤ (dist x (f x)) / (1 - K) :=
by simpa only [hy.eq, dist_self, add_zero] using hf.dist_inequality x y

theorem fixed_point_unique' {x y} (hx : is_fixed_pt f x) (hy : is_fixed_pt f y) : x = y :=
(hf.eq_or_edist_eq_top_of_fixed_points hx hy).resolve_right (edist_ne_top _ _)

/-- Let `f` be a contracting map with constant `K`; let `g` be another map uniformly
`C`-close to `f`. If `x` and `y` are their fixed points, then `dist x y ≤ C / (1 - K)`. -/

noncomputable theory

variables [nonempty α] [complete_space α]

variable (f)
/-- The unique fixed point of a contracting map in a nonempty complete metric space. -/
def fixed_point : α :=
efixed_point f hf _ (edist_ne_top (classical.choice ‹nonempty α›) _)
variable {f}

/-- The point provided by `contracting_with.fixed_point` is actually a fixed point. -/
lemma fixed_point_is_fixed_pt : is_fixed_pt f (fixed_point f hf) :=
hf.efixed_point_is_fixed_pt _

lemma fixed_point_unique {x} (hx : is_fixed_pt f x) : x = fixed_point f hf :=
hf.fixed_point_unique' hx hf.fixed_point_is_fixed_pt

lemma dist_fixed_point_le (x) : dist x (fixed_point f hf) ≤ (dist x (f x)) / (1 - K) :=
hf.dist_le_of_fixed_point x hf.fixed_point_is_fixed_pt

/-- Aposteriori estimates on the convergence of iterates to the fixed point. -/
lemma aposteriori_dist_iterate_fixed_point_le (x n) :
  dist (f^[n] x) (fixed_point f hf) ≤ (dist (f^[n] x) (f^[n+1] x)) / (1 - K) :=
by { rw [iterate_succ'], apply hf.dist_fixed_point_le }

lemma apriori_dist_iterate_fixed_point_le (x n) :
  dist (f^[n] x) (fixed_point f hf) ≤ (dist x (f x)) * K^n / (1 - K) :=
le_trans (hf.aposteriori_dist_iterate_fixed_point_le x n) $
  (div_le_div_right hf.one_sub_K_pos).2 $
    hf.to_lipschitz_with.dist_iterate_succ_le_geometric x n

lemma tendsto_iterate_fixed_point (x) :
  tendsto (λn, f^[n] x) at_top (𝓝 $ fixed_point f hf) :=
begin
  convert tendsto_iterate_efixed_point hf (edist_ne_top x _),
  refine (fixed_point_unique _ _).symm,
  apply efixed_point_is_fixed_pt
end

lemma fixed_point_lipschitz_in_map {g : α → α} (hg : contracting_with K g)
  {C} (hfg : ∀ z, dist (f z) (g z) ≤ C) :
  dist (fixed_point f hf) (fixed_point g hg) ≤ C / (1 - K) :=
hf.dist_fixed_point_fixed_point_of_dist_le' g hf.fixed_point_is_fixed_pt
  hg.fixed_point_is_fixed_pt hfg

omit hf

/-- If a map `f` has a contracting iterate `f^[n]`, then the fixed point of `f^[n]` is also a fixed
point of `f`. -/
lemma is_fixed_pt_fixed_point_iterate {n : ℕ} (hf : contracting_with K (f^[n])) :
  is_fixed_pt f (hf.fixed_point (f^[n])) :=
begin
  set x := hf.fixed_point (f^[n]),
  have hx : (f^[n] x) = x := hf.fixed_point_is_fixed_pt,
  have := hf.to_lipschitz_with.dist_le_mul x (f x),
  rw [← iterate_succ_apply, iterate_succ_apply', hx] at this,
  contrapose! this,
  have := dist_pos.2 (ne.symm this),
  simpa only [nnreal.coe_one, one_mul, nnreal.val_eq_coe] using (mul_lt_mul_right this).mpr hf.left
end

end contracting_with


/-
Copyright (c) 2021 Sébastien Gouëzel. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Sébastien Gouëzel
-/
import topology.instances.real
import order.filter.archimedean

/-!
# Convergence of subadditive sequences

> THIS FILE IS SYNCHRONIZED WITH MATHLIB4.
> Any changes to this file require a corresponding PR to mathlib4.

A subadditive sequence `u : ℕ → ℝ` is a sequence satisfying `u (m + n) ≤ u m + u n` for all `m, n`.
We define this notion as `subadditive u`, and prove in `subadditive.tendsto_lim` that, if `u n / n`
is bounded below, then it converges to a limit (that we denote by `subadditive.lim` for
convenience). This result is known as Fekete's lemma in the literature.
-/

noncomputable theory
open set filter
open_locale topology

/-- A real-valued sequence is subadditive if it satisfies the inequality `u (m + n) ≤ u m + u n`
for all `m, n`. -/
def subadditive (u : ℕ → ℝ) : Prop :=
∀ m n, u (m + n) ≤ u m + u n

namespace subadditive

variables {u : ℕ → ℝ} (h : subadditive u)
include h

/-- The limit of a bounded-below subadditive sequence. The fact that the sequence indeed tends to
this limit is given in `subadditive.tendsto_lim` -/
@[irreducible, nolint unused_arguments]
protected def lim := Inf ((λ (n : ℕ), u n / n) '' (Ici 1))

lemma lim_le_div (hbdd : bdd_below (range (λ n, u n / n))) {n : ℕ} (hn : n ≠ 0) :
  h.lim ≤ u n / n :=
begin
  rw subadditive.lim,
  apply cInf_le _ _,
  { rcases hbdd with ⟨c, hc⟩,
    exact ⟨c, λ x hx, hc (image_subset_range _ _ hx)⟩ },
  { apply mem_image_of_mem,
    exact zero_lt_iff.2 hn }
end

lemma apply_mul_add_le (k n r) : u (k * n + r) ≤ k * u n + u r :=
begin
  induction k with k IH, { simp only [nat.cast_zero, zero_mul, zero_add] },
  calc
  u ((k+1) * n + r)
      = u (n + (k * n + r)) : by { congr' 1, ring }
  ... ≤ u n + u (k * n + r) : h _ _
  ... ≤ u n + (k * u n + u r) : add_le_add_left IH _
  ... = (k+1 : ℕ) * u n + u r : by simp; ring
end

lemma eventually_div_lt_of_div_lt {L : ℝ} {n : ℕ} (hn : n ≠ 0) (hL : u n / n < L) :
  ∀ᶠ p in at_top, u p / p < L :=
begin
  have I : ∀ (i : ℕ), 0 < i → (i : ℝ) ≠ 0,
  { assume i hi, simp only [hi.ne', ne.def, nat.cast_eq_zero, not_false_iff] },
  obtain ⟨w, nw, wL⟩ : ∃ w, u n / n < w ∧ w < L := exists_between hL,
  obtain ⟨x, hx⟩ : ∃ x, ∀ i < n, u i - i * w ≤ x,
  { obtain ⟨x, hx⟩ : bdd_above (↑(finset.image (λ i, u i - i * w) (finset.range n))) :=
      finset.bdd_above _,
    refine ⟨x, λ i hi, _⟩,
    simp only [upper_bounds, mem_image, and_imp, forall_exists_index, mem_set_of_eq,
      forall_apply_eq_imp_iff₂, finset.mem_range, finset.mem_coe, finset.coe_image] at hx,
    exact hx _ hi },
  have A : ∀ (p : ℕ), u p ≤ p * w + x,
  { assume p,
    let s := p / n,
    let r := p % n,
    have hp : p = s * n + r, by rw [mul_comm, nat.div_add_mod],
    calc u p = u (s * n + r) : by rw hp
    ... ≤ s * u n + u r : h.apply_mul_add_le _ _ _
    ... = s * n * (u n / n) + u r : by { field_simp [I _ hn.bot_lt], ring }
    ... ≤ s * n * w + u r : add_le_add_right
      (mul_le_mul_of_nonneg_left nw.le (mul_nonneg (nat.cast_nonneg _) (nat.cast_nonneg _))) _
    ... = (s * n + r) * w + (u r - r * w) : by ring
    ... = p * w + (u r - r * w) : by { rw hp, simp only [nat.cast_add, nat.cast_mul] }
    ... ≤ p * w + x : add_le_add_left (hx _ (nat.mod_lt _ hn.bot_lt)) _ },
  have B : ∀ᶠ p in at_top, u p / p ≤ w + x / p,
  { refine eventually_at_top.2 ⟨1, λ p hp, _⟩,
    simp only [I p hp, ne.def, not_false_iff] with field_simps,
    refine div_le_div_of_le_of_nonneg _ (nat.cast_nonneg _),
    rw mul_comm,
    exact A _ },
  have C : ∀ᶠ (p : ℕ) in at_top, w + x / p < L,
  { have : tendsto (λ (p : ℕ), w + x / p) at_top (𝓝 (w + 0)) :=
      tendsto_const_nhds.add (tendsto_const_nhds.div_at_top tendsto_coe_nat_at_top_at_top),
    rw add_zero at this,
    exact (tendsto_order.1 this).2 _ wL },
  filter_upwards [B, C] with _ hp h'p using hp.trans_lt h'p,
end

/-- Fekete's lemma: a subadditive sequence which is bounded below converges. -/
theorem tendsto_lim (hbdd : bdd_below (range (λ n, u n / n))) :
  tendsto (λ n, u n / n) at_top (𝓝 h.lim) :=
begin
  refine tendsto_order.2 ⟨λ l hl, _, λ L hL, _⟩,
  { refine eventually_at_top.2
      ⟨1, λ n hn, hl.trans_le (h.lim_le_div hbdd ((zero_lt_one.trans_le hn).ne'))⟩ },
  { obtain ⟨n, npos, hn⟩ : ∃ (n : ℕ), 0 < n ∧ u n / n < L,
    { rw subadditive.lim at hL,
      rcases exists_lt_of_cInf_lt (by simp) hL with ⟨x, hx, xL⟩,
      rcases (mem_image _ _ _).1 hx with ⟨n, hn, rfl⟩,
      exact ⟨n, zero_lt_one.trans_le hn, xL⟩ },
    exact h.eventually_div_lt_of_div_lt npos.ne' hn }
end

end subadditive


/-
Copyright (c) 2020 Yury Kudryashov. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yury Kudryashov, Sébastien Gouëzel
-/
import analysis.calculus.mean_value
import analysis.special_functions.pow_deriv

/-!
# Collection of convex functions

In this file we prove that the following functions are convex:

* `strict_convex_on_exp` : The exponential function is strictly convex.
* `even.convex_on_pow`, `even.strict_convex_on_pow` : For an even `n : ℕ`, `λ x, x ^ n` is convex
  and strictly convex when `2 ≤ n`.
* `convex_on_pow`, `strict_convex_on_pow` : For `n : ℕ`, `λ x, x ^ n` is convex on $[0, +∞)$ and
  strictly convex when `2 ≤ n`.
* `convex_on_zpow`, `strict_convex_on_zpow` : For `m : ℤ`, `λ x, x ^ m` is convex on $[0, +∞)$ and
  strictly convex when `m ≠ 0, 1`.
* `convex_on_rpow`, `strict_convex_on_rpow` : For `p : ℝ`, `λ x, x ^ p` is convex on $[0, +∞)$ when
  `1 ≤ p` and strictly convex when `1 < p`.
* `strict_concave_on_log_Ioi`, `strict_concave_on_log_Iio`: `real.log` is strictly concave on
  $(0, +∞)$ and $(-∞, 0)$ respectively.

## TODO

For `p : ℝ`, prove that `λ x, x ^ p` is concave when `0 ≤ p ≤ 1` and strictly concave when
`0 < p < 1`.
-/

open real set
open_locale big_operators

/-- `exp` is strictly convex on the whole real line. -/
lemma strict_convex_on_exp : strict_convex_on ℝ univ exp :=
strict_convex_on_univ_of_deriv2_pos differentiable_exp (λ x, (iter_deriv_exp 2).symm ▸ exp_pos x)

/-- `exp` is convex on the whole real line. -/
lemma convex_on_exp : convex_on ℝ univ exp := strict_convex_on_exp.convex_on

/-- `x^n`, `n : ℕ` is convex on the whole real line whenever `n` is even -/
lemma even.convex_on_pow {n : ℕ} (hn : even n) : convex_on ℝ set.univ (λ x : ℝ, x^n) :=
begin
  apply convex_on_univ_of_deriv2_nonneg differentiable_pow,
  { simp only [deriv_pow', differentiable.mul, differentiable_const, differentiable_pow] },
  { intro x,
    obtain ⟨k, hk⟩ := (hn.tsub $ even_bit0 _).exists_two_nsmul _,
    rw [iter_deriv_pow, finset.prod_range_cast_nat_sub, hk, nsmul_eq_mul, pow_mul'],
    exact mul_nonneg (nat.cast_nonneg _) (pow_two_nonneg _) }
end

/-- `x^n`, `n : ℕ` is strictly convex on the whole real line whenever `n ≠ 0` is even. -/
lemma even.strict_convex_on_pow {n : ℕ} (hn : even n) (h : n ≠ 0) :
  strict_convex_on ℝ set.univ (λ x : ℝ, x^n) :=
begin
  apply strict_mono.strict_convex_on_univ_of_deriv differentiable_pow,
  rw deriv_pow',
  replace h := nat.pos_of_ne_zero h,
  exact strict_mono.const_mul (odd.strict_mono_pow $ nat.even.sub_odd h hn $ nat.odd_iff.2 rfl)
    (nat.cast_pos.2 h),
end

/-- `x^n`, `n : ℕ` is convex on `[0, +∞)` for all `n` -/
lemma convex_on_pow (n : ℕ) : convex_on ℝ (Ici 0) (λ x : ℝ, x^n) :=
begin
  apply convex_on_of_deriv2_nonneg (convex_Ici _) (continuous_pow n).continuous_on
    differentiable_on_pow,
  { simp only [deriv_pow'], exact (@differentiable_on_pow ℝ _ _ _).const_mul (n : ℝ) },
  { intros x hx,
    rw [iter_deriv_pow, finset.prod_range_cast_nat_sub],
    exact mul_nonneg (nat.cast_nonneg _) (pow_nonneg (interior_subset hx) _) }
end

/-- `x^n`, `n : ℕ` is strictly convex on `[0, +∞)` for all `n` greater than `2`. -/
lemma strict_convex_on_pow {n : ℕ} (hn : 2 ≤ n) : strict_convex_on ℝ (Ici 0) (λ x : ℝ, x^n) :=
begin
  apply strict_mono_on.strict_convex_on_of_deriv (convex_Ici _) (continuous_on_pow _)
    differentiable_on_pow,
  rw [deriv_pow', interior_Ici],
  exact λ x (hx : 0 < x) y hy hxy, mul_lt_mul_of_pos_left (pow_lt_pow_of_lt_left hxy hx.le $
    nat.sub_pos_of_lt hn) (nat.cast_pos.2 $ zero_lt_two.trans_le hn),
end

lemma finset.prod_nonneg_of_card_nonpos_even
  {α β : Type*} [linear_ordered_comm_ring β]
  {f : α → β} [decidable_pred (λ x, f x ≤ 0)]
  {s : finset α} (h0 : even (s.filter (λ x, f x ≤ 0)).card) :
  0 ≤ ∏ x in s, f x :=
calc 0 ≤ (∏ x in s, ((if f x ≤ 0 then (-1:β) else 1) * f x)) :
  finset.prod_nonneg (λ x _, by
    { split_ifs with hx hx, by simp [hx], simp at hx ⊢, exact le_of_lt hx })
... = _ : by rw [finset.prod_mul_distrib, finset.prod_ite, finset.prod_const_one,
  mul_one, finset.prod_const, neg_one_pow_eq_pow_mod_two, nat.even_iff.1 h0, pow_zero, one_mul]

lemma int_prod_range_nonneg (m : ℤ) (n : ℕ) (hn : even n) :
  0 ≤ ∏ k in finset.range n, (m - k) :=
begin
  rcases hn with ⟨n, rfl⟩,
  induction n with n ihn, { simp },
  rw ← two_mul at ihn,
  rw [← two_mul, nat.succ_eq_add_one, mul_add, mul_one, bit0, ← add_assoc, finset.prod_range_succ,
    finset.prod_range_succ, mul_assoc],
  refine mul_nonneg ihn _, generalize : (1 + 1) * n = k,
  cases le_or_lt m k with hmk hmk,
  { have : m ≤ k + 1, from hmk.trans (lt_add_one ↑k).le,
    exact mul_nonneg_of_nonpos_of_nonpos (sub_nonpos_of_le hmk) (sub_nonpos_of_le this) },
  { exact mul_nonneg (sub_nonneg_of_le hmk.le) (sub_nonneg_of_le hmk) }
end

lemma int_prod_range_pos {m : ℤ} {n : ℕ} (hn : even n) (hm : m ∉ Ico (0 : ℤ) n) :
  0 < ∏ k in finset.range n, (m - k) :=
begin
  refine (int_prod_range_nonneg m n hn).lt_of_ne (λ h, hm _),
  rw [eq_comm, finset.prod_eq_zero_iff] at h,
  obtain ⟨a, ha, h⟩ := h,
  rw sub_eq_zero.1 h,
  exact ⟨int.coe_zero_le _, int.coe_nat_lt.2 $ finset.mem_range.1 ha⟩,
end

/-- `x^m`, `m : ℤ` is convex on `(0, +∞)` for all `m` -/
lemma convex_on_zpow (m : ℤ) : convex_on ℝ (Ioi 0) (λ x : ℝ, x^m) :=
begin
  have : ∀ n : ℤ, differentiable_on ℝ (λ x, x ^ n) (Ioi (0 : ℝ)),
    from λ n, differentiable_on_zpow _ _ (or.inl $ lt_irrefl _),
  apply convex_on_of_deriv2_nonneg (convex_Ioi 0);
    try { simp only [interior_Ioi, deriv_zpow'] },
  { exact (this _).continuous_on },
  { exact this _ },
  { exact (this _).const_mul _ },
  { intros x hx,
    rw iter_deriv_zpow,
    refine mul_nonneg _ (zpow_nonneg (le_of_lt hx) _),
    exact_mod_cast int_prod_range_nonneg _ _ (even_bit0 1) }
end

/-- `x^m`, `m : ℤ` is convex on `(0, +∞)` for all `m` except `0` and `1`. -/
lemma strict_convex_on_zpow {m : ℤ} (hm₀ : m ≠ 0) (hm₁ : m ≠ 1) :
  strict_convex_on ℝ (Ioi 0) (λ x : ℝ, x^m) :=
begin
  have : ∀ n : ℤ, differentiable_on ℝ (λ x, x ^ n) (Ioi (0 : ℝ)),
    from λ n, differentiable_on_zpow _ _ (or.inl $ lt_irrefl _),
  apply strict_convex_on_of_deriv2_pos (convex_Ioi 0),
  { exact (this _).continuous_on },
   all_goals { rw interior_Ioi },
  { exact this _ },
  intros x hx,
  rw iter_deriv_zpow,
  refine mul_pos _ (zpow_pos_of_pos hx _),
  exact_mod_cast int_prod_range_pos (even_bit0 1) (λ hm, _),
  norm_cast at hm,
  rw ← finset.coe_Ico at hm,
  fin_cases hm; cc,
end

lemma convex_on_rpow {p : ℝ} (hp : 1 ≤ p) : convex_on ℝ (Ici 0) (λ x : ℝ, x^p) :=
begin
  have A : deriv (λ (x : ℝ), x ^ p) = λ x, p * x^(p-1), by { ext x, simp [hp] },
  apply convex_on_of_deriv2_nonneg (convex_Ici 0),
  { exact continuous_on_id.rpow_const (λ x _, or.inr (zero_le_one.trans hp)) },
  { exact (differentiable_rpow_const hp).differentiable_on },
  { rw A,
    assume x hx,
    replace hx : x ≠ 0, by { simp at hx, exact ne_of_gt hx },
    simp [differentiable_at.differentiable_within_at, hx] },
  { assume x hx,
    replace hx : 0 < x, by simpa using hx,
    suffices : 0 ≤ p * ((p - 1) * x ^ (p - 1 - 1)), by simpa [ne_of_gt hx, A],
    apply mul_nonneg (le_trans zero_le_one hp),
    exact mul_nonneg (sub_nonneg_of_le hp) (rpow_nonneg_of_nonneg hx.le _) }
end

lemma strict_convex_on_rpow {p : ℝ} (hp : 1 < p) : strict_convex_on ℝ (Ici 0) (λ x : ℝ, x^p) :=
begin
  have A : deriv (λ (x : ℝ), x ^ p) = λ x, p * x^(p-1), by { ext x, simp [hp.le] },
  apply strict_convex_on_of_deriv2_pos (convex_Ici 0),
  { exact continuous_on_id.rpow_const (λ x _, or.inr (zero_le_one.trans hp.le)) },
  { exact (differentiable_rpow_const hp.le).differentiable_on },
  rw interior_Ici,
  rintro x (hx : 0 < x),
  suffices : 0 < p * ((p - 1) * x ^ (p - 1 - 1)), by simpa [ne_of_gt hx, A],
  exact mul_pos (zero_lt_one.trans hp) (mul_pos (sub_pos_of_lt hp) (rpow_pos_of_pos hx _)),
end

lemma strict_concave_on_log_Ioi : strict_concave_on ℝ (Ioi 0) log :=
begin
  have h₁ : Ioi 0 ⊆ ({0} : set ℝ)ᶜ,
  { exact λ x (hx : 0 < x) (hx' : x = 0), hx.ne' hx' },
  refine strict_concave_on_open_of_deriv2_neg (convex_Ioi 0) is_open_Ioi
    (differentiable_on_log.mono h₁) (λ x (hx : 0 < x), _),
  rw [function.iterate_succ, function.iterate_one],
  change (deriv (deriv log)) x < 0,
  rw [deriv_log', deriv_inv],
  exact neg_neg_of_pos (inv_pos.2 $ sq_pos_of_ne_zero _ hx.ne'),
end

lemma strict_concave_on_log_Iio : strict_concave_on ℝ (Iio 0) log :=
begin
  have h₁ : Iio 0 ⊆ ({0} : set ℝ)ᶜ,
  { exact λ x (hx : x < 0) (hx' : x = 0), hx.ne hx' },
  refine strict_concave_on_open_of_deriv2_neg (convex_Iio 0) is_open_Iio
    (differentiable_on_log.mono h₁) (λ x (hx : x < 0), _),
  rw [function.iterate_succ, function.iterate_one],
  change (deriv (deriv log)) x < 0,
  rw [deriv_log', deriv_inv],
  exact neg_neg_of_pos (inv_pos.2 $ sq_pos_of_ne_zero _ hx.ne),
end

section sqrt_mul_log

lemma deriv_sqrt_mul_log (x : ℝ) (hx : 0 < x) :
  deriv (λ x, sqrt x * log x) x = (2 + log x) / (2 * sqrt x) :=
begin
  simp only [sqrt_eq_rpow],
  refine (deriv_mul (has_deriv_at_rpow_const (or.inl hx.ne')).differentiable_at
    (differentiable_at_log hx.ne')).trans _,
  rw [deriv_rpow_const (or.inl hx.ne'), deriv_log, add_comm],
  simp only [div_eq_mul_inv, mul_inv, ←rpow_neg hx.le, ←rpow_neg_one x, ←rpow_add hx],
  rw [add_mul, mul_comm (log x), ←mul_assoc],
  norm_num,
end

lemma deriv2_sqrt_mul_log (x : ℝ) (hx : 0 < x) :
  deriv^[2] (λ x, sqrt x * log x) x = -log x / (4 * sqrt x ^ 3) :=
begin
  let h := (has_deriv_at_rpow_const (or.inl hx.ne')).differentiable_at,
  rw [function.iterate_succ, function.iterate_one, function.comp_app,
      ←deriv_within_of_open is_open_Ioi (set.mem_Ioi.mpr hx)],
  refine (deriv_within_congr (unique_diff_on_Ioi 0 x hx) deriv_sqrt_mul_log
    (deriv_sqrt_mul_log x hx)).trans _,
  simp only [sqrt_eq_rpow],
  rw [deriv_within_of_open is_open_Ioi (set.mem_Ioi.mpr hx),
      deriv_div ((differentiable_at_log hx.ne').const_add 2) (h.const_mul 2)
      (ne_of_gt (mul_pos two_pos (rpow_pos_of_pos hx 0.5))), deriv_const_add, deriv_log,
      deriv_const_mul 2 h, deriv_rpow_const (or.inl hx.ne'), one_div, mul_comm x⁻¹, mul_assoc,
      mul_inv_cancel_left₀ (show (2 : ℝ) ≠ (0 : ℝ), from two_ne_zero), ←div_eq_mul_inv,
      ←rpow_sub_one hx.ne', ←sub_mul, sub_add_cancel', mul_pow, ←div_div_eq_mul_div, ←mul_div],
    simp only [mul_pow, pow_succ, pow_zero, mul_one, ←rpow_add hx, ←rpow_sub hx],
    norm_num,
end

lemma strict_concave_on_sqrt_mul_log_Ioi : strict_concave_on ℝ (set.Ioi 1) (λ x, sqrt x * log x) :=
begin
  refine strict_concave_on_open_of_deriv2_neg (convex_Ioi 1) is_open_Ioi
    (λ x hx, differentiable_within_at_of_deriv_within_ne_zero _) (λ x hx, _),
  { rw [deriv_within_of_open is_open_Ioi hx, deriv_sqrt_mul_log x (zero_lt_one.trans hx)],
    refine div_ne_zero _ (mul_ne_zero two_ne_zero (sqrt_ne_zero'.mpr (zero_lt_one.trans hx))),
    linarith [log_pos hx] },
  { rw deriv2_sqrt_mul_log x (zero_lt_one.trans hx),
    exact div_neg_of_neg_of_pos (neg_neg_of_pos (log_pos hx))
      (mul_pos four_pos (pow_pos (sqrt_pos.mpr (zero_lt_one.trans hx)) 3)) },
end

end sqrt_mul_log

open_locale real

lemma strict_concave_on_sin_Icc : strict_concave_on ℝ (Icc 0 π) sin :=
begin
  apply strict_concave_on_of_deriv2_neg (convex_Icc _ _) continuous_on_sin
    differentiable_sin.differentiable_on (λ x hx, _),
  rw interior_Icc at hx,
  simp [sin_pos_of_mem_Ioo hx],
end

lemma strict_concave_on_cos_Icc : strict_concave_on ℝ (Icc (-(π/2)) (π/2)) cos :=
begin
  apply strict_concave_on_of_deriv2_neg (convex_Icc _ _) continuous_on_cos
    differentiable_cos.differentiable_on (λ x hx, _),
  rw interior_Icc at hx,
  simp [cos_pos_of_mem_Ioo hx],
end


import algebra.order.group
import tactic

private def only_those {T : Type} (cond : T → T → Prop) [∀ n, ∀ m, decidable (cond n m)] : T → list T → list T
| p []        := []
| p (x :: xs) := if (cond x p) then x :: only_those p xs else only_those p xs

private lemma size_cap {T : Type} {cond : T → T → Prop} [∀ n, ∀ m, decidable (cond n m)] {pivot : T} {lizt : list T} :
  (only_those cond pivot lizt).sizeof < (pivot :: lizt).sizeof  :=
begin
  induction lizt with head tail ih,
    unfold only_those,
    unfold list.sizeof,
    linarith,

    unfold list.sizeof,
    by_cases cond head pivot,

      -- here `cond` holds
      have unwrap_yes : only_those cond pivot (head :: tail) = head :: only_those cond pivot tail,
      {
        unfold only_those,
        simp,
        contrapose!,
        intro _,
        exact h,
      },
      calc (only_those cond pivot (head :: tail)).sizeof
           = (head :: only_those cond pivot tail).sizeof             : by rw unwrap_yes
      ...  = 1 + (sizeof head) + (only_those cond pivot tail).sizeof : by unfold list.sizeof
      ...  < 1 + (sizeof head) + (pivot :: tail).sizeof              : by linarith  -- uses `ih` and `add_le_add` afaik
      ...  = 1 + (sizeof head) + (1 + (sizeof pivot) + tail.sizeof)  : by unfold list.sizeof,

      -- here `cond` does not hold
      have unwrap_no : only_those cond pivot (head :: tail) = only_those cond pivot tail,
      {
        unfold only_those,
        simp,
        contrapose,
        intro _,
        exact h,
      },
      calc (only_those cond pivot (head :: tail)).sizeof
           = (only_those cond pivot tail).sizeof                    : by rw unwrap_no
      ...  < (pivot :: tail).sizeof                                 : ih
      ...  =                     (1 + (sizeof pivot) + tail.sizeof) : by unfold list.sizeof
      ...  ≤ 1 + (sizeof head) + (1 + (sizeof pivot) + tail.sizeof) : le_add_self
end

variable {L : Type}
variable [linear_order L]

private def only_le : L → list L → list L :=
  only_those (≤)

private def only_gt : L → list L → list L :=
  only_those (>)

def kviksort : list L → list L
| []        := []
| (x :: xs) := have (only_le x xs).sizeof < (x :: xs).sizeof, from size_cap,
               have (only_gt x xs).sizeof < (x :: xs).sizeof, from size_cap,
               kviksort (only_le x xs) ++ [x] ++ kviksort (only_gt x xs)

#eval kviksort [14, 8, 2, 20, 15, 0, 11, 18, 7, 6, 3, 13, 10, 17, 1, 4, 5, 9, 19, 12, 16, 10]
-- Result should be a sequence of integers 0..20 where 10 is twice.


--import data.set
import tactic

-- dEAduction tactics
import structures2      -- hypo_analysis, targets_analysis
import utils            -- no_meta_vars
import user_notations   -- notations that can be used in deaduction UI for a new object

-- dEAduction definitions
import set_definitions

-- General principles :
-- Type should be defined as parameters, in order to be implicit everywhere
-- other parameters are implicit in definitions, i.e. defined using '{}' (e.g. {A : set X} )
-- but explicit everywhere else, i.e. defined using '()' (e.g. (A : set X) )
-- each definition must be an iff statement (since it will be called with 'rw' or 'symp_rw')

---------------------
-- Course metadata --
---------------------
-- logic names ['and', 'or', 'negate', 'implicate', 'iff', 'forall', 'exists', 'equal', 'map']
-- proofs names ['use_proof_methods', 'new_object']
-- proof methods names ['cbr', 'contrapose', 'absurdum', 'sorry']
-- magic names ['compute', 'assumption']

/- dEAduction
Title
    exercices de mathématiques discretes.
Author
    Alice Laroche
Institution

AvailableMagic
    ALL
Description
    Exercices d'un cours de maths discrètes à Sorbonne Université.
    Les numéros de questions font référence à la feuille de TD.
-/

namespace set

-- def disjoint {X : Type} (A B : set X) : Prop := A ∩ B = ∅

def partition {X :Type} (A : set (set X)) := (∀A₁ ∈ A , A₁ ≠ ∅) ∧ (∀A₁ A₂ ∈ A, (A₁ ∩ A₂ = ∅) ∨ A₁ = A₂) ∧ (∀x, ∃A₁ ∈ A, x ∈ A₁)

end set

namespace relation

def inv {X Y : Type} (R : set (X × Y)) : set (Y × X)
| (x, y) := (y, x) ∈ R

def product {X Y Z : Type} (R : set (X × Y)) (R' : set (Y × Z)) : set (X × Z)
| (x, y) := ∃z, (x, z) ∈ R ∧ (z, y) ∈ R'

def identite {X: Type} : set (X × X)
| (x, y) := x = y

def reflexive {X : Type} (R : set (X × X)) := ∀x, (x, x) ∈ R

def transitive {X : Type} (R: set (X × X)) := ∀x y z, (x, y) ∈ R ∧ (y, z) ∈ R → (x, z) ∈ R

def symetrique {X : Type} (R : set (X × X)) := ∀x y, (x, y) ∈ R → (y, x) ∈ R

def antisymetrique {X : Type} (R : set (X × X)) := ∀x y, (x, y) ∈ R ∧ (y, x) ∈ R → x = y

def relation_equivalence {X : Type} (R : set (X × X)) := reflexive R ∧ transitive R ∧ symetrique R

def relation_ordre {X : Type} (R : set (X × X)) := reflexive R ∧ transitive R ∧ antisymetrique R

def classe_equivalence {X : Type} (R : set (X × X)) (h1 : relation_equivalence R) (e : X) : set X
| e' :=  (e, e')  ∈ R

def deterministe {X Y : Type} (R : set (X × Y)) := ∀x y z, (x, y) ∈ R ∧ (x, z) ∈ R → y = z

def total_gauche {X Y : Type} (R : set (X × Y)) := ∀x, ∃y, (x, y) ∈ R

def application {X Y : Type} (R : set (X × Y)) := deterministe R ∧ total_gauche R

def injective {X Y : Type} (R : set (X × Y)) := ∀x y z, (x, z) ∈ R ∧ (y, z) ∈ R → x = y

def surjective {X Y : Type} (R : set (X × Y)) := ∀y, ∃x, (x, y) ∈ R

def application_injective {X Y : Type} (R : set (X × Y)) := application R ∧ injective R

def application_surjective {X Y : Type} (R : set (X × Y)) := application R ∧ surjective R

def application_bijective {X Y : Type} (R : set (X × Y)) := application R ∧ injective R ∧ surjective R

def image {X Y : Type} (R : set (X × Y)) (x : X) (y : Y) := (x, y) ∈ R

end relation

local attribute [instance] classical.prop_decidable

---------------------------------------------
-- global parameters = implicit variables --
---------------------------------------------
section course
parameters {X Y Z: Type}

open set
open relation

notation [parsing_only] R `.` S := relation.product R S

notation R `⁻¹`  := relation.inv R
notation R `dot` S := relation.product R S

------------------
-- COURSE TITLE --
------------------
namespace math_discretes
/- dEAduction
PrettyName
    Mathématiques discrètes
-/

namespace generalites
/- dEAduction
PrettyName
    Généralités
-/

------------------------
-- COURSE DEFINITIONS --
------------------------
lemma definition.inclusion {A B : set X} : A ⊆ B ↔ ∀ {x:X}, x ∈ A → x ∈ B :=
/- dEAduction
PrettyName
    Inclusion
ImplicitUse
    True
-/
begin
    todo,
end

lemma definition.egalite_deux_ensembles {A A' : set X} :
(A = A') ↔ ( ∀ x, x ∈ A ↔ x ∈ A' ) :=
/- dEAduction
PrettyName
    Egalité de deux ensembles
ImplicitUse
    True
-/
begin
    exact set.ext_iff,
end

-- lemma definition.inegalite_deux_ensembles {A A' : set X} :
-- (A ≠ A') ↔ ( ∃x, (x ∈ A ∧ x ∉ A') ∨ (x ∈ A' ∧ x ∉ A)) :=
-- /- dEAduction
-- PrettyName
--     Inégalité de deux ensembles
-- -/
-- begin
--     todo,
-- end

lemma definition.ensemble_vide
(A: set X) :
(A = ∅) ↔ ∀ x : X, x ∉ A
:=
begin
    exact eq_empty_iff_forall_not_mem,
end

lemma definition.ensemble_extension {X: Type}  {P : X → Prop} {x:X} :
 x ∈ {x | P x} ↔ P x
:=
/- dEAduction
PrettyName
    Ensemble en extension
-/
begin
    refl,
end

lemma definition.singleton : ∀ {X : Type} {x y : X}, x ∈ ({y} : set X) ↔ x = y
:=
/- dEAduction
PrettyName
    Singleton
-/
begin
    intros X x y, exact mem_singleton_iff,
end

lemma definition.double_inclusion (A A' : set X) :
A = A' ↔ (A ⊆ A' ∧ A' ⊆ A) :=
/- dEAduction
PrettyName
    Double inclusion
ImplicitUse
    True
-/
begin
    exact set.subset.antisymm_iff,
end

lemma definition.ensemble_partie (A A' : set X) :
A' ∈ 𝒫(A) ↔  A' ⊆ A
:=
/- dEAduction
PrettyName
    Ensemble des parties
-/
begin
    refl,
end

end generalites

namespace union_intersection
/- dEAduction
PrettyName
    Unions et intersections
-/

------------------------
-- COURSE DEFINITIONS --
------------------------

lemma definition.intersection_deux_ensembles {A B : set X} {x : X} :
x ∈ A ∩ B ↔ ( x ∈ A ∧ x ∈ B) :=
/- dEAduction
PrettyName
    Intersection de deux ensembles
ImplicitUse
    True
-/
begin
    exact iff.rfl,
end

lemma definition.intersection_union (A B C : set X) :
A ∩ (B ∪ C) = (A ∩ B) ∪ (A ∩ C) :=
/- dEAduction
PrettyName
   Intersection avec une union
ImplicitUse
    True
-/
begin
  exact set.inter_distrib_left A B C,
end

lemma definition.partition
 {P : set (set X)} :
 partition P ↔ (∀A₁ ∈ P , A₁ ≠ ∅) ∧ (∀A₁ A₂ ∈ P, (A₁ ∩ A₂ = ∅) ∨ A₁ = A₂) ∧ (∀x, ∃A₁ ∈ P, x ∈ A₁)
:=
/- dEAduction
PrettyName
   Partition
-/
begin
    todo
end
-- lemma definition.intersection_videI (A : set X) :
-- A ∩ ∅ = ∅ :=
-- /- dEAduction
-- PrettyName
--     Intersection avec l'ensemble vide I
-- ImplicitUse
--     False
-- -/
-- begin
--     exact inter_empty A,
-- end

-- lemma definition.intersection_videII (A : set X) :
-- ∅ ∩ A = ∅ :=
-- /- dEAduction
-- PrettyName
--     Intersection avec l'ensemble vide II
-- ImplicitUse
--     False
-- -/
-- begin
--     exact empty_inter A,
-- end

-- lemma definition.union_deux_ensembles  {A : set X} {B : set X} {x : X} :
-- x ∈ A ∪ B ↔ ( x ∈ A ∨ x ∈ B) :=
-- /- dEAduction
-- PrettyName
--     Union de deux ensembles
-- ImplicitUse
--     True
-- -/
-- begin
--     exact iff.rfl,
-- end

-- lemma definition.union_intersection (A B C : set X) :
-- A ∪ (B ∩ C) = (A ∪ B) ∩ (A ∪ C) :=
-- /- dEAduction
-- PrettyName
--    Union avec une intersection
-- ImplicitUse
--     False
-- -/
-- begin
--   exact set.union_distrib_left A B C,
-- end

-- lemma definition.union_videI (A : set X) :
-- A ∪ ∅ = A :=
-- /- dEAduction
-- PrettyName
--     Union avec l'ensemble vide I
-- ImplicitUse
--     False
-- -/
-- begin
--     exact union_empty A,
-- end

-- lemma definition.union_videII (A : set X) :
-- ∅ ∪ A = A :=
-- /- dEAduction
-- PrettyName
--     Union avec l'ensemble vide II
-- ImplicitUse
--     False
-- -/
-- begin
--     exact empty_union A,
-- end

end union_intersection

namespace complementaire
/- dEAduction
PrettyName
    Complémentaire
-/

------------------------
-- COURSE DEFINITIONS --
------------------------

lemma definition.complement {A : set X} {x : X} : x ∈ set.compl A ↔ x ∉ A :=
/- dEAduction
PrettyName
    Complementaire
ImplicitUse
    False
-/
begin
    finish,
end

lemma definition.difference {A A' : set X} {x : X} : x ∈ set.diff A A' ↔ x ∈ A ∧ x ∉ A' :=
/- dEAduction
PrettyName
    Différence
ImplicitUse
    False
-/
begin
    finish,
end
-- lemma definition.complement_complement {A : set X} : (set.compl (set.compl A)) = A :=
-- /- dEAduction
-- PrettyName
--     Complementaire du complementaire
-- ImplicitUse
--     False
-- -/
-- begin
--     exact compl_compl',
-- end

-- lemma definition.complement_intersection {A B : set X} :
-- set.compl (A ∩ B) = (set.compl A) ∪ (set.compl B) :=
-- /- dEAduction
-- PrettyName
--     Complementaire d'une intersection
-- ImplicitUse
--     False
-- -/
-- begin
--     exact compl_inter A B,
-- end

-- lemma definition.intersection_complement {A : set X} :
-- A ∩ set.compl (A) = ∅ :=
-- /- dEAduction
-- PrettyName
--     Intersection avec le complémentaire
-- ImplicitUse
--     False
-- -/
-- begin
--     exact inter_compl_self A,
-- end

-- lemma definition.complement_union {A B : set X} :
-- set.compl (A ∪ B) = (set.compl A) ∩ (set.compl B) :=
-- /- dEAduction
-- PrettyName
--     Complementaire d'une union
-- ImplicitUse
--     False
-- -/
-- begin
--     exact compl_union A B,
-- end

-- lemma definition.union_complement {A : set X} :
-- A ∪ set.compl (A) = univ :=
-- /- dEAduction
-- PrettyName
--     Union avec le complémentaire
-- ImplicitUse
--     False
-- -/
-- begin
--     exact union_compl_self A,
-- end

end complementaire

namespace produits_cartesiens
/- dEAduction
PrettyName
    Produits cartésiens
-/

-- lemma definition.type_produit :
-- ∀ z:X × Y, ∃ x:X, ∃ y:Y, z = (x,y) :=
-- /- dEAduction
-- PrettyName
--     Element d'un produit cartésien de deux ensembles
-- -/
-- begin
--     todo
-- end

lemma definition.produit_de_parties {A : set X} {B : set Y} {x:X} {y:Y} :
(x,y) ∈ set.prod A B ↔ x ∈ A ∧ y ∈ B :=
/- dEAduction
PrettyName
    Produit cartésien de deux parties
-/
begin
    todo
end

end produits_cartesiens

namespace relations
/- dEAduction
PrettyName
    Relations
-/

------------------------
-- COURSE DEFINITIONS --
------------------------

lemma definition.inv {R : set (X × Y)} {x : X} {y : Y} :
(y,x) ∈ (inv R) ↔ (x,y) ∈ R :=
/- dEAduction
PrettyName
    Inverse d'une relation
-/
begin
    refl,
end

lemma definition.prod {R : set (X × Y)} {S : set (Y × Z)} {x : X} {z : Z} :
(x,z) ∈ (product R S) ↔ ∃y, (x,y) ∈ R ∧ (y,z) ∈ S :=
/- dEAduction
PrettyName
    Produit de deux relations
ImplicitUse
    True
-/
begin
    refl,
end

lemma definition.id {x : X} {y : X} :
(x,y) ∈ (identite : set (X × X))  ↔ x = y :=
/- dEAduction
PrettyName
    Relation identité
-/
begin
    refl,
end

lemma theorem.id :
∀ x:X,  (x,x) ∈ (identite : set (X × X)) :=
/- dEAduction
PrettyName
    Relation identité
-/
begin
    intro x, rw definition.id,
end

lemma definition.reflexive {R : set (X × X)} :
reflexive R ↔ ∀x, (x, x) ∈ R :=
/- dEAduction
PrettyName
    Réflexivité
ImplicitUse
    True
-/
begin
    refl,
end

lemma definition.transitive {R : set (X × X)} :
transitive R ↔ ∀x y z, (x, y) ∈ R ∧ (y, z) ∈ R → (x, z) ∈ R :=
/- dEAduction
PrettyName
    Transitivité
ImplicitUse
    True
-/
begin
    refl,
end

lemma definition.symetrique {R : set (X × X)} :
symetrique R ↔ ∀x y, (x, y) ∈ R → (y, x) ∈ R:=
/- dEAduction
PrettyName
    Symétrie
ImplicitUse
    True
-/
begin
    refl,
end

lemma definition.antisymetrique {R : set (X × X)} :
antisymetrique R ↔ ∀x y, (x, y) ∈ R ∧ (y, x) ∈ R → x = y :=
/- dEAduction
PrettyName
    Antisymétrie
-/
begin
    refl,
end

lemma definition.equivalence {R : set (X × X)} :
relation_equivalence R ↔ reflexive R ∧ transitive R ∧ symetrique R :=
/- dEAduction
PrettyName
    Relation d'équivalence
ImplicitUse
    True
-/
begin
    refl,
end

lemma definition.ordre {R : set (X × X)} :
relation_ordre R ↔ reflexive R ∧ transitive R ∧ antisymetrique R :=
/- dEAduction
PrettyName
    Relation d'ordre
-/
begin
    refl,
end

lemma definition.classe_equivalence {x y : X} {R : set (X × X)} {h1 : relation_equivalence R}:
y ∈ classe_equivalence R h1 x ↔ (x, y) ∈ R :=
/- dEAduction
PrettyName
    Classe d'équivalence
-/
begin
    refl,
end
end relations

-- namespace applications

-- lemma definition.deterministe {X Y : Type} (R : set (X × Y))
-- : deterministe R ↔ ∀x y z, (x, y) ∈ R ∧ (x, z) ∈ R → y = z :=
-- /- dEAduction
-- PrettyName
--     Relation déterministe
-- -/
-- begin
--     refl,
-- end

-- lemma definition.total_gauche {X Y : Type} (R : set (X × Y)) :
-- total_gauche R ↔ ∀x, ∃y, (x, y) ∈ R :=
-- /- dEAduction
-- PrettyName
--     Relation totale
-- -/
-- begin
--     refl,
-- end

-- lemma definition.application {X Y : Type} (R : set (X × Y)) :
-- application R ↔ deterministe R ∧ total_gauche R :=
-- /- dEAduction
-- PrettyName
--      Relation et application
-- -/
-- begin
--     refl,
-- end

-- lemma definition.relation_injective {X Y : Type} (R : set (X × Y)) :
-- relation.injective R ↔ ∀x y z, (x, z) ∈ R ∧ (y, z) ∈ R → x = y :=
-- /- dEAduction
-- PrettyName
--     Relation injective
-- -/
-- begin
--     refl,
-- end

-- lemma definition.relation_surjective {X Y : Type} (R : set (X × Y)) :
-- relation.surjective R ↔ ∀y, ∃x, (x, y) ∈ R :=
-- /- dEAduction
-- PrettyName
--     Relation surjective
-- -/
-- begin
--     refl,
-- end

-- lemma definition.application_injective {X Y : Type} (R : set (X × Y)) :
-- application_injective R ↔ application R ∧ relation.injective R :=
-- /- dEAduction
-- PrettyName
--     Application injective
-- -/
-- begin
--     refl,
-- end

-- lemma definition.application_surjective {X Y : Type} (R : set (X × Y)) :
-- application_surjective R ↔ application R ∧ relation.surjective R :=
-- /- dEAduction
-- PrettyName
--     Application surjective
-- -/
-- begin
--     refl,
-- end

-- lemma definition.application_bijective {X Y : Type} (R : set (X × Y)) :
-- application_bijective R ↔ application R ∧ relation.injective R ∧ relation.surjective R :=
-- /- dEAduction
-- PrettyName
--     Application bijective
-- -/
-- begin
--     refl,
-- end

-- lemma definition.image {X Y : Type} (R : set (X × Y)) (x : X) (y : Y) :
-- image R x y ↔ (x, y) ∈ R :=
-- /- dEAduction
-- PrettyName
--     Image d'une relation
-- -/
-- begin
--     refl,
-- end

-- end applications

---------------
-- EXERCICES --
---------------
namespace exercices
/- dEAduction
PrettyName
    Exercices
-/

variables  {A B C : set X}

namespace exercice2
/- dEAduction
PrettyName
    Exercice 2
-/

lemma exercise.question1 :
(A ∩ compl (A ∩ B)) = (A ∩ compl B) :=
/- dEAduction
PrettyName
    Question 1
-/
begin
    todo,
end

lemma exercise.question2 :
A ∩ B = A ∩ C → A ∩ compl B = A ∩ compl C :=
/- dEAduction
PrettyName
    Question 2
-/
begin
    todo,
end

lemma exercise.question3 :
A ∩ B = A ∩ C ↔ A ∩ (compl B) = A ∩ (compl C) :=
/- dEAduction
PrettyName
    Question 3
Description
    Deduire de la question précedente l'équivalence des deux énoncés.
-/
begin
    todo,
end

lemma exercise.question4 :
A ∪ B ⊆ A ∪ C ∧ A ∩ B ⊆ A ∩ C → B ⊆ C :=
/- dEAduction
PrettyName
    Question 4
-/
begin
    todo,
end

lemma exercise.question5 :
set.prod A (B ∪ C) = set.prod A B ∪ set.prod A C :=
/- dEAduction
PrettyName
    Question 5
-/
begin
    todo,
end

-- lemma exercise.question61 :
-- 𝒫(A ∪ B) = 𝒫(A) ∪ 𝒫(B) ∨ ¬𝒫(A ∪ B) = 𝒫(A) ∪ 𝒫(B) :=
-- /- dEAduction
-- PrettyName
--     Question 6.1
-- OpenQuestion
--     True
-- -/
-- begin
--     todo,
-- end

lemma exercise.question62 :
𝒫(A ∩ B) = 𝒫(A) ∩ 𝒫(B) :=
/- dEAduction
PrettyName
    Question 6.2
-/
begin
    todo,
end

--𝒫(E ∪ {x}) = 𝒫(E) ∪ {A' | ∃A ∈ 𝒫(E), A' = A ∪ {x}} :=
lemma exercise.question7 (F : Type) (E : set F) (x : F) (h : x ∉ E) :
𝒫(E ∪ {x}) = 𝒫(E) ∪ {A' | ∃A ⊆ E, A' = A ∪ {x}} :=
/- dEAduction
PrettyName
    Question 7
-/
begin
    todo,
end

end exercice2

namespace exercice5
/- dEAduction
PrettyName
    Exercice 5
-/

lemma exercise.question2_produit_inverse (X Y Z : Type) (R : set (X × Y)) (S : set (Y × Z)) :
 (R dot S) ⁻¹ = ((S ⁻¹) dot (R ⁻¹)) :=
 /- dEAduction
PrettyName
    Question 2
-/
begin
    todo,
end
end exercice5

namespace exercice6
/- dEAduction
PrettyName
    Exercice 6
-/

lemma exercise.question1 (X: Type) (R : set (X × X)) :
reflexive R ↔ identite ⊆ R :=
/- dEAduction
PrettyName
    Question 1
-/
begin
    todo,
end

lemma exercise.question2 (X: Type) (R : set (X × X)) :
symetrique R ↔ R = inv R  :=
/- dEAduction
PrettyName
    Question 2
-/
begin
    todo,
end

lemma exercise.question3 (X: Type) (R : set (X × X)) :
antisymetrique R ↔ (R ∩ (inv R)) ⊆ identite :=
/- dEAduction
PrettyName
    Question 3
-/
begin
    todo,
end

lemma exercise.question4 (X: Type) (R : set (X × X)) :
transitive R ↔ (product R R) ⊆ R :=
/- dEAduction
PrettyName
    Question 4
-/
begin
    todo,
end

lemma exercise.question5 (X: Type) (R : set (X × X)) :
reflexive R → R ⊆ (R dot R) ∧ reflexive (R dot R) :=
/- dEAduction
PrettyName
    Question 5
-/
begin
    todo,
end

lemma exercise.question6 (X: Type) (R : set (X × X)) :
symetrique R → (R ⁻¹ dot R) = (R dot R ⁻¹) :=
/- dEAduction
PrettyName
    Question 6
-/
begin
    todo,
end

lemma exercise.question7 (X: Type) (R : set (X × X)) :
transitive R → transitive (R dot R) :=
/- dEAduction
PrettyName
    Question 7
-/
begin
    todo,
end
end exercice6

namespace exercice8
/- dEAduction
PrettyName
    Exercice 8
-/

lemma exercise.question1 (A : Type) (R : set (A × A)) (h1 : relation_equivalence R) :
∀a, a ∈ classe_equivalence R h1 a :=
/- dEAduction
PrettyName
    Question 1
-/
begin
    todo,
end

lemma exercise.question2 (A : Type) (R : set (A × A)) (h1 : relation_equivalence R) (a b : A) :
classe_equivalence R h1 a = classe_equivalence R h1 b ↔ (a,b) ∈ R :=
/- dEAduction
PrettyName
    Question 2
-/
begin
    todo,
end

lemma exercise.question3 (A : Type) (R : set (A × A)) (h1 : relation_equivalence R) (a b : A) :
classe_equivalence R h1 a ≠ classe_equivalence R h1 b → classe_equivalence R h1 a ∩ classe_equivalence R h1 b = ∅ :=
/- dEAduction
PrettyName
    Question 3
-/
begin
    todo,
end

lemma exercise.question5 (A : Type) (R : set (A × A)) (h1 : relation_equivalence R) :
partition {A₁ | ∃x, A₁ = classe_equivalence R h1 x} :=
/- dEAduction
PrettyName
    Question 5
-/
begin
    todo,
end

end exercice8

-- namespace exercice15
-- /- dEAduction
-- PrettyName
--     Exercice 15
-- -/

-- -- TODO: intégrer les defs pour applications (composition, id, bijective)
-- lemma exercise.question (X : Type) (f : X → X) :
-- ((composition f f) = id : X → X) → bijective f:=
-- /- dEAduction
-- PrettyName
--     Question 1
-- -/
-- begin
--     todo,
-- end
-- end exercice15

namespace exercice22
/- dEAduction
PrettyName
    Exercice 22
-/

lemma exercise.question1 (X Y : Type) (f : X → Y) (R : set (X × X)) (H1 : ∀x x', (x, x') ∈ R ↔ f x = f x') :
relation_equivalence R :=
/- dEAduction
PrettyName
    Question 1
-/
begin
    todo,
end

lemma exercise.question3 (X Y : Type) (f : X → Y) (R : set (X × X)) (H1 : ∀x x', (x, x') ∈ R ↔ f x = f x')
(H2: relation_equivalence R) :
∀x y, x ∈ classe_equivalence R H2 y → classe_equivalence R H2 x = classe_equivalence R H2 y :=
/- dEAduction
PrettyName
    Question 3
-/
begin
    todo,
end

-- lemma exercise.question41 (E F : Type) (f : set (E × F)) (h1 : application f)
-- (Rf : set (E × E)) (h2 : ∀x y, (x,y) ∈ Rf ↔ (∃z, image f x z ∧ image f y z)) (h3 : relation_equivalence Rf)
-- (h4 : ¬relation.injective Rf) (h5 : ¬relation.surjective Rf)
-- (S : set (E × (set E))) (h6 : ∀x y, relation.image S x y ↔ y = classe_equivalence Rf h3 x) :
-- relation.injective S ∨ ¬relation.injective S :=
-- /- dEAduction
-- PrettyName
--     ** Question 4.1
-- -/
-- begin
--     todo,
-- end

-- lemma exercise.question42 (E F : Type) (f : set (E × F)) (h1 : application f)
-- (Rf : set (E × E)) (h2 : ∀x y, (x,y) ∈ Rf ↔ (∃z, image f x z ∧ image f y z)) (h3 : relation_equivalence Rf)
-- (h4 : ¬relation.injective Rf) (h5 : ¬relation.surjective Rf)
-- (S : set (E × (set E))) (h6 : ∀x y, relation.image S x y ↔ y = classe_equivalence Rf h3 x) :
-- relation.surjective S ∨ ¬relation.surjective S :=
-- /- dEAduction
-- PrettyName
--     ** Question 4.2
-- -/
-- begin
--     todo,
-- end

-- lemma exercise.question5 (E F : Type) (f : set (E × F)) (h1 : application f)
-- (Rf : set (E × E)) (h2 : ∀x y, (x,y) ∈ Rf ↔ (∃z, image f x z ∧ image f y z)) (h3 : relation_equivalence Rf)
-- (h4 : ¬relation.injective Rf) (h5 : ¬relation.surjective Rf)
-- (f' : set ((set E) × F)) (h6 : ∀X y, (X, y) ∈ f' ↔ ∃x ∈ X, relation.image f x y) :
-- application f' :=
-- /- dEAduction
-- PrettyName
--     ** Question 5
-- -/
-- begin
--     todo,
-- end

-- lemma exercise.question61 (E F : Type) (f : set (E × F)) (h1 : application f)
-- (Rf : set (E × E)) (h2 : ∀x y, (x,y) ∈ Rf ↔ (∃z, image f x z ∧ image f y z)) (h3 : relation_equivalence Rf)
-- (h4 : ¬relation.injective Rf) (h5 : ¬relation.surjective Rf)
-- (f' : set ((set E) × F)) (h6 : ∀X y, (X, y) ∈ f' ↔ ∃x ∈ X, relation.image f x y) :
-- relation.injective f' ∨ ¬ relation.injective f' :=
-- /- dEAduction
-- PrettyName
--     ** Question 6.1
-- -/
-- begin
--     todo,
-- end

-- lemma exercise.question62 (E F : Type) (f : set (E × F)) (h1 : application f)
-- (Rf : set (E × E)) (h2 : ∀x y, (x,y) ∈ Rf ↔ (∃z, image f x z ∧ image f y z)) (h3 : relation_equivalence Rf)
-- (h4 : ¬relation.injective Rf) (h5 : ¬relation.surjective Rf)
-- (f' : set ((set E) × F)) (h6 : ∀X y, (X, y) ∈ f' ↔ ∃x ∈ X, relation.image f x y) :
-- relation.injective f' ∨ ¬ relation.injective f' :=
-- /- dEAduction
-- PrettyName
--     ** Question 6.2
-- -/
-- begin
--     todo,
-- end

end exercice22

end exercices

end math_discretes
end course