import data.rat.basic
import data.nat.prime
import ring_theory.localization
import tactic
import set_theory.surreal

namespace surreal

def dyadic_map : localization (@submonoid.powers ℤ _ 2) →+ surreal := sorry

end surreal

namespace rat
open rat

def is_dyadic (q : ℚ) : Prop := ∃ (n : ℕ), q.denom = 2^n

-- TODO: move this data.rat.basic
theorem denom_dvd' (n : ℤ) (d : ℕ) : ((mk_nat n d).denom) ∣ d := by exact_mod_cast denom_dvd n d

-- TODO: move this data.rat.basic
theorem num_denom'' {a : ℚ} : mk_nat a.num a.denom = a := num_denom

-- TODO: move this data.rat.basic
lemma denom_pow_prime_mul_denom_pow_prime (m₁ m₂ : ℤ) (n₁ n₂ : ℕ) {p : ℕ} (hp : p.prime) :
  ∃ k : ℕ, (mk_nat m₁ (p ^ n₁) * mk_nat m₂ (p ^ n₂)).denom = p ^ k :=
begin
  let x := mk m₁ (p ^ n₁ : ℕ),
  let y := mk m₂ (p ^ n₂ : ℕ),
  have : (x * y).denom ∣ p ^ (n₁ + n₂), by
  { calc (x * y).denom ∣ x.denom * y.denom : mul_denom_dvd _ _
                   ... ∣ p ^ n₁ * p ^ n₂   : mul_dvd_mul (denom_dvd' _ _) (denom_dvd' _ _)
                   ... = p ^ (n₁ + n₂)     : (pow_add p n₁ n₂).symm },
  obtain ⟨k, -, hk⟩ := (nat.dvd_prime_pow hp).1 this,
  exact ⟨k, hk⟩,
end

-- TODO: move this data.rat.basic
lemma denom_pow_prime_add_denom_pow_prime (m₁ m₂ : ℤ) (n₁ n₂ : ℕ) {p : ℕ} (hp : p.prime) :
  ∃ k : ℕ, (mk_nat m₁ (p ^ n₁) + mk_nat m₂ (p ^ n₂)).denom = p ^ k :=
begin
  let x := mk m₁ (p ^ n₁ : ℕ),
  let y := mk m₂ (p ^ n₂ : ℕ),
  have : (x + y).denom ∣ p ^ (n₁ + n₂), by
  { calc (x + y).denom ∣ x.denom * y.denom : add_denom_dvd _ _
                   ... ∣ p ^ n₁ * p ^ n₂   : mul_dvd_mul (denom_dvd' _ _) (denom_dvd' _ _)
                   ... = p ^ (n₁ + n₂)     : (pow_add p n₁ n₂).symm },
  obtain ⟨k, -, hk⟩ := (nat.dvd_prime_pow hp).1 this,
  exact ⟨k, hk⟩,
end

theorem is_dyadic.mul (x y : ℚ) : x.is_dyadic → y.is_dyadic → (x * y).is_dyadic :=
begin
  rintros ⟨nx, hnx⟩ ⟨ny, hny⟩,
  obtain ⟨k, hk⟩ := denom_pow_prime_mul_denom_pow_prime x.num y.num nx ny nat.prime_two,
  use k,
  rwa [← hnx, ← hny, num_denom'', num_denom''] at hk,
end

theorem is_dyadic.add (x y : ℚ) : x.is_dyadic → y.is_dyadic → (x + y).is_dyadic :=
begin
  rintros ⟨nx, hnx⟩ ⟨ny, hny⟩,
  obtain ⟨k, hk⟩ := denom_pow_prime_add_denom_pow_prime x.num y.num nx ny nat.prime_two,
  use k,
  rwa [← hnx, ← hny, num_denom'', num_denom''] at hk,
end

theorem is_dyadic.neg (x : ℚ): x.is_dyadic → (-x).is_dyadic :=
λ ⟨n, hn⟩, ⟨n, by simp[hn]⟩

def dyadic : subring ℚ :=
{ carrier   := { x : ℚ | x.is_dyadic },
  one_mem'  := ⟨0, by norm_num⟩,
  mul_mem'  := is_dyadic.mul,
  zero_mem' := ⟨0, by norm_num⟩,
  add_mem'  := is_dyadic.add,
  neg_mem'  :=  is_dyadic.neg }

def int.localization_away_two_dyadic : localization_map.away_map 2 dyadic :=
{ to_fun         := λ m : ℤ, (m : dyadic),
  map_one'       := by norm_num,
  map_mul'       := by norm_num,
  map_zero'      := rfl,
  map_add'       := by norm_num,
  map_units'     := begin
                      rintro ⟨_, a, h⟩,
                      rw is_unit_iff_exists_inv,
                      let b := mk' 1 (2 ^ a) (pow_pos zero_lt_two a) (nat.coprime_one_left (2 ^ a)),
                      use [b, a],
                      simp only [subtype.ext_iff, subring.coe_mul, subring.coe_one,
                                 subring.coe_int_cast, subtype.coe_mk],
                      have : b = ((2 ^ a) : ℚ)⁻¹,
                        by { rw [eq_inv_iff, inv_def'],
                             simp only [nat.cast_bit0, int.cast_one, nat.cast_one,
                                        div_one, nat.cast_pow] },
                      rw [this, ← h],
                      simp only [int.cast_pow, int.cast_bit0, int.cast_one],
                      refine rat.mul_inv_cancel _ _,
                      apply ne_of_gt,
                      simp only [zero_lt_bit0, pow_pos, zero_lt_one],
                    end,
  surj'          := begin
                      rintro ⟨a, b, h⟩,
                      use [a.num, 2 ^ b, b],
                      simp [subtype.ext_iff],
                      norm_cast,
                      rw [← h, mul_denom_eq_num],
                    end,
  eq_iff_exists' := begin
                      intros x y,
                      norm_cast,
                      split,
                      { intro hxy,
                        use 1,
                        simpa only [mul_one, submonoid.coe_one] },
                      { rintro ⟨⟨c, _, hc⟩, hxy⟩,
                        have : (c:ℤ) ≠ 0,
                          by { apply ne_of_gt, rw ← hc, apply pow_pos, dec_trivial },
                        exact mul_right_cancel' this hxy },
                    end }

noncomputable def dyadic_to_surreal : dyadic →+ surreal :=
add_monoid_hom.comp surreal.dyadic_map
  (localization.ring_equiv_of_quotient int.localization_away_two_dyadic).symm

end rat


/-
Copyright (c) 2017 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Stephen Morgan, Scott Morrison, Johannes Hölzl, Reid Barton

! This file was ported from Lean 3 source module category_theory.category.galois_connection
! leanprover-community/mathlib commit d82b87871d9a274884dff5263fa4f5d93bcce1d6
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.CategoryTheory.Category.Preorder
import Mathlib.CategoryTheory.Adjunction.Basic
import Mathlib.Order.GaloisConnection

/-!

# Galois connections between preorders are adjunctions.

* `GaloisConnection.adjunction` is the adjunction associated to a galois connection.

-/

universe u v

section

variable {X : Type u} {Y : Type v} [Preorder X] [Preorder Y]

/-- A galois connection between preorders induces an adjunction between the associated categories.
-/
def GaloisConnection.adjunction {l : X → Y} {u : Y → X} (gc : GaloisConnection l u) :
    gc.monotone_l.functor ⊣ gc.monotone_u.functor :=
  CategoryTheory.Adjunction.mkOfHomEquiv
    { homEquiv := fun X Y =>
        ⟨fun f => CategoryTheory.homOfLE (gc.le_u f.le),
         fun f => CategoryTheory.homOfLE (gc.l_le f.le), _, _⟩ }
#align galois_connection.adjunction GaloisConnection.adjunction

end

namespace CategoryTheory

variable {X : Type u} {Y : Type v} [Preorder X] [Preorder Y]

/-- An adjunction between preorder categories induces a galois connection.
-/
theorem Adjunction.gc {L : X ⥤ Y} {R : Y ⥤ X} (adj : L ⊣ R) : GaloisConnection L.obj R.obj :=
  fun x y =>
  ⟨fun h => ((adj.homEquiv x y).toFun h.hom).le, fun h => ((adj.homEquiv x y).invFun h.hom).le⟩
#align category_theory.adjunction.gc CategoryTheory.Adjunction.gc

end CategoryTheory


import Lean4Axiomatic.AbstractAlgebra
import Lean4Axiomatic.Natural
import Lean4Axiomatic.Natural.Impl.Nat
import Lean4Axiomatic.Operators
import Lean4Axiomatic.Relation.Equivalence

open Lean4Axiomatic
open Natural (step)
open Operators (TildeDash)
open Signed (Positive)

namespace AnalysisI.Ch2

namespace Impl

export Natural.Impl.Generic (sign)
export Natural.Impl.Nat (
  addition axioms constructors core equality exponentiation literals
  multiplication order
)

end Impl

/-= Chapter 2: Starting at the beginning: the natural numbers =-/

/- 2.1 The Peano axioms -/

-- We call `ℕ` the _set of natural numbers_.
abbrev ℕ : Type := Nat

-- Axiom 2.1.
-- `0` is a natural number.
example : ℕ := 0

-- Axiom 2.2.
-- If `n` is a natural number, then `step n` is also a natural number.
example {n : ℕ} : ℕ := step n (self := Impl.constructors)

-- Thus for instance, from Axiom 2.1 and two applications of Axiom 2.2, we see
-- that `step (step 0)` is a natural number.
example : ℕ := step (step 0)

-- [values of `ℕ` obey the axioms of equality]
example : Relation.Equivalence.EqvOp? ℕ :=
  Natural.eqvOp? (self := Impl.equality)

-- [`step` obeys substitution]
example {n₁ n₂ : ℕ} : n₁ ≃ n₂ → step n₁ ≃ step n₂ :=
  AA.subst₁
    (self := Natural.step_substitutive (self := Impl.core))

-- Definition 2.1.3.
-- We define `1` to be the number `step 0`,
example : 1 ≃ step 0 := Rel.refl

-- `2` to be the number `step (step 0)`,
example : 2 ≃ step (step 0) := Rel.refl

-- `3` to be the number `step (step (step 0))`,
example : 3 ≃ step (step (step 0)) := Rel.refl

-- etc.
-- [We can convert any natural number literal (`Nat`) into `ℕ`]
example (n : Nat) : ℕ :=
  @OfNat.ofNat ℕ n (Natural.literal (self := Impl.literals))

-- (In other words, `1 := step 0`, `2 := step 1`, `3 := step 2`, etc.)
example : 1 ≃ step 0 := Rel.refl
example : 2 ≃ step 1 := Rel.refl
example : 3 ≃ step 2 := Rel.refl

-- Proposition 2.1.4.
-- `3` is a natural number.
-- [The proof is given above; `3 ≃ step (step (step 0))`]
example : ℕ := 3

-- Axiom 2.3.
-- `0` is not the successor of any natural number; i.e., we have `step n ≄ 0`
-- for every natural number `n`.
example {n : ℕ} : step n ≄ 0 :=
  Natural.step_neqv_zero (self := Impl.axioms)

-- Proposition 2.1.6.
-- `4` is not equal to `0`.
example : 4 ≄ 0 := Natural.step_neqv_zero (ℕ := ℕ)

-- Axiom 2.4.
-- Different natural numbers must have different successors; i.e., if `n`, `m`
-- are natural numbers and `n ≄ m`, then `step n ≄ step m`. Equivalently, if
-- `step n ≃ step m`, then we must have `n ≃ m`.
example {n m : ℕ} : step n ≃ step m → n ≃ m :=
  AA.inject (self := Natural.step_injective (self := Impl.axioms))

-- Proposition 2.1.8.
-- `6` is not equal to `2`.
example : 6 ≄ 2 := by
  intro (_ : 6 ≃ 2)
  show False
  have : step 5 ≃ step 1 := ‹6 ≃ 2›
  have : 5 ≃ 1           := AA.inject this
  have : step 4 ≃ step 0 := this
  have : 4 ≃ 0           := AA.inject this
  have : step 3 ≃ 0      := this
  exact absurd ‹step 3 ≃ 0› Natural.step_neqv_zero

-- Axiom 2.5 (Principle of mathematical induction).
-- Let `P n` be any property pertaining to a natural number `n`. Suppose that
-- `P 0` is true, and suppose that whenever `P n` is true, `P (step n)` is also
-- true. Then `P n` is true for every natural number `n`.
example (P : ℕ → Prop) : P 0 → (∀ n, P n → P (step n)) → ∀ n, P n :=
  Natural.ind (self := Impl.axioms)

-- Proposition 2.1.16 (Recursive definitions).
-- Suppose for each natural number `n`, we have some function `f n : ℕ → ℕ`
-- from the natural numbers to the natural numbers. Let `c` be a natural
-- number. Then we can assign a unique natural number `a n` to each natural
-- number `n`, such that `a 0 ≃ c` and `a (step n) ≃ f n (a n)` for each
-- natural number `n`.
-- [The book only gives an informal proof here, and I'm not completely sure how
-- to formalize it in the right way. An exercise in Chapter 3 asks for the
-- rigorous proof, once functions have been given an exact definition. So I
-- will postpone the formal proof until then. For now, here's my translation of
-- the statement.]
#check {f : ℕ → ℕ → ℕ} → {c : ℕ} →
  ∃ a : ℕ → ℕ, a 0 ≃ c ∧ ∀ n, a (step n) ≃ f n (a n)

/- 2.2 Addition -/

-- Definition 2.2.1 (Addition of natural numbers).
-- Let `m` be a natural number. To add zero to `m`, we define `0 + m := m`. Now
-- suppose inductively that we have defined how to add `n` to `m`. Then we can
-- add `step n` to `m` by defining `step n + m := step (n + m)`.
example : ℕ → ℕ → ℕ := Add.add (self := Natural.addOp (self := Impl.addition))

example {m : ℕ} : 0 + m ≃ m := Natural.zero_add (self := Impl.addition)

example {n m : ℕ} : step n + m ≃ step (n + m) :=
  Natural.step_add (self := Impl.addition)

-- [Addition obeys left and right substitution]
example : AA.Substitutive₂ (α := ℕ) (· + ·) AA.tc (· ≃ ·) (· ≃ ·) :=
  Natural.add_substitutive

-- Thus `0 + m` is `m`,
example {m : ℕ} : 0 + m ≃ m := Natural.zero_add

-- `1 + m ≃ step 0 + m` is `step m`;
theorem one_plus_m {m : ℕ} : 1 + m ≃ step m := by
  calc
    _ ≃ 1 + m        := Rel.refl
    _ ≃ step 0 + m   := AA.substL Rel.refl
    _ ≃ step (0 + m) := Natural.step_add
    _ ≃ step m       := AA.subst₁ Natural.zero_add

-- `2 + m ≃ step 1 + m ≃ step (step m)`;
example {m : ℕ} : 2 + m ≃ step (step m) := by
  calc
    _ ≃ 2 + m         := Rel.refl
    _ ≃ step 1 + m    := AA.substL Rel.refl
    _ ≃ step (1 + m)  := Natural.step_add
    _ ≃ step (step m) := AA.subst₁ one_plus_m

-- and so forth; for instance we have `2 + 3 ≃ step (step 3) ≃ step 4 ≃ 5`.
example : 2 + 3 ≃ 5 := by
  calc
    _ ≃ 2 + 3               := Rel.refl
    _ ≃ step 1 + 3          := AA.substL (α := ℕ) Rel.refl
    _ ≃ step (1 + 3)        := Natural.step_add
    _ ≃ step (step 0 + 3)   := AA.subst₁ (AA.substL Rel.refl)
    _ ≃ step (step (0 + 3)) := AA.subst₁ Natural.step_add
    _ ≃ step (step 3)       := AA.subst₁ (AA.subst₁ Natural.zero_add)
    _ ≃ step 4              := Rel.refl
    _ ≃ 5                   := Rel.refl

-- Note that this definition is asymmetric: `3 + 5` is incrementing `5` three
-- times, while `5 + 3` is incrementing `3` five times. Of course, they both
-- yield the same value of `8`.
example : 3 + 5 ≃ 8 := by
  let zero_add : {m : ℕ} → 0 + m ≃ m := Natural.zero_add
  let step_add : {n m : ℕ} → step n + m ≃ step (n + m) := Natural.step_add
  calc
    _ ≃ 3 + 5                      := Rel.refl
    _ ≃ step (2 + 5)               := step_add
    _ ≃ step (step (1 + 5))        := AA.subst₁ step_add
    _ ≃ step (step (step (0 + 5))) := AA.subst₁ (AA.subst₁ step_add)
    _ ≃ step (step (step 5))       := AA.subst₁ (AA.subst₁ (AA.subst₁ zero_add))
    _ ≃ 8                          := Rel.refl

example : 5 + 3 ≃ 8 := by
  let ss {n₁ n₂ : ℕ} : n₁ ≃ n₂ → step n₁ ≃ step n₂ := AA.subst₁
  let za : {m : ℕ} → 0 + m ≃ m := Natural.zero_add
  let sa : {n m : ℕ} → step n + m ≃ step (n + m) := Natural.step_add
  calc
    _ ≃ 5 + 3                                    := Rel.refl
    _ ≃ step (4 + 3)                             := sa
    _ ≃ step (step (3 + 3))                      := ss sa
    _ ≃ step (step (step (2 + 3)))               := ss (ss sa)
    _ ≃ step (step (step (step (1 + 3))))        := ss (ss (ss sa))
    _ ≃ step (step (step (step (step (0 + 3))))) := ss (ss (ss (ss sa)))
    _ ≃ step (step (step (step (step 3))))       := ss (ss (ss (ss (ss za))))
    _ ≃ 8                                        := Rel.refl

-- Lemma 2.2.2.
-- For any natural number `n`, `n + 0 ≃ n`.
example {n : ℕ} : n + 0 ≃ n := Natural.add_zero

-- Lemma 2.2.3.
-- For any natural numbers `n` and `m`, `n + step m ≃ step (n + m)`.
example {n m : ℕ} : n + step m ≃ step (n + m) := Natural.add_step

-- As a particular corollary of Lemma 2.2.2 and Lemma 2.2.3 we see that
-- `step n ≃ n + 1`.
example {n : ℕ} : step n ≃ n + 1 := Rel.symm Natural.add_one_step

-- Proposition 2.2.4 (Addition is commutative).
-- For any natural numbers `n` and `m`, `n + m ≃ m + n`.
example {n m : ℕ} : n + m ≃ m + n := AA.comm (self := Natural.add_commutative)

-- Exercise 2.2.1.
-- Proposition 2.2.5 (Addition is associative).
-- For any natural numbers `a`, `b`, `c`, we have `(a + b) + c ≃ a + (b + c)`.
example {a b c : ℕ} : (a + b) + c ≃ a + (b + c) :=
  AA.assoc (self := Natural.add_associative)

-- Proposition 2.2.6 (Cancellation law).
-- Let `a`, `b`, `c` be natural numbers such that `a + b ≃ a + c`. Then we have
-- `b ≃ c`.
example {a b c : ℕ} : a + b ≃ a + c → b ≃ c :=
  AA.cancelL (self := Natural.add_cancellative.cancellativeL)

-- Definition 2.2.7 (Positive natural numbers).
-- A natural number `n` is said to be _positive_ iff it is not equal to `0`.
example : ℕ → Prop := Positive (self := Impl.sign.positivity.toOps)
example {n : ℕ} : Positive n ↔ n ≄ 0 :=
  Signed.positive_defn (self := Impl.sign.positivity)

-- Proposition 2.2.8.
-- If `a` is positive and `b` is a natural number, then `a + b` is positive.
example {a b : ℕ} : Positive a → Positive (a + b) := Natural.positive_add

-- Corollary 2.2.9.
-- If `a` and `b` are natural numbers such that `a + b ≃ 0`,
-- then `a ≃ 0` and `b ≃ 0`.
example {a b : ℕ} : a + b ≃ 0 → a ≃ 0 ∧ b ≃ 0 := Natural.zero_sum_split

-- Exercise 2.2.2.
-- Lemma 2.2.10.
-- Let `a` be a positive number. Then there exists exactly one natural number
-- `b` such that `step b ≃ a`.
example {a : ℕ}
    : Positive a → ∃ b : ℕ, step b ≃ a ∧ ∀ b' : ℕ, step b' ≃ a → b ≃ b' := by
  intro (_ : Positive a)
  show ∃ b, step b ≃ a ∧ ∀ b', step b' ≃ a → b ≃ b'
  have ⟨b, (_ : step b ≃ a)⟩ := Natural.positive_step ‹Positive a›
  exists b
  apply And.intro ‹step b ≃ a›
  intro b' (_ : step b' ≃ a)
  show b ≃ b'
  apply AA.inject (β := ℕ) (f := step) (rβ := (· ≃ ·))
  show step b ≃ step b'
  calc
    _ ≃ step b  := Rel.refl
    _ ≃ a       := ‹step b ≃ a›
    _ ≃ step b' := Rel.symm ‹step b' ≃ a›

-- Definition 2.2.11 (Ordering of the natural numbers).
-- Let `n` and `m` be natural numbers. We say that `n` is
-- _greater than or equal to_ `m`, and write `n ≥ m` or `m ≤ n`, iff we have
-- `n ≃ m + a` for some natural number `a`.
example : ℕ → ℕ → Prop :=
  @GE.ge ℕ (Natural.leOp (self := Impl.order))
example {n m : ℕ} : n ≥ m ↔ ∃ a : ℕ, n ≃ m + a := by
  let le_defn := @Natural.le_defn (ℕ := ℕ) (self := Impl.order)
  apply Iff.intro
  · intro (_ : m ≤ n)
    show ∃ a, n ≃ m + a
    have ⟨a, (_ : m + a ≃ n)⟩ := le_defn.mp ‹m ≤ n›
    exact ⟨a, Rel.symm ‹m + a ≃ n›⟩
  · intro ⟨a, (_ : n ≃ m + a)⟩
    show m ≤ n
    exact le_defn.mpr ⟨a, Rel.symm ‹n ≃ m + a›⟩

-- We say that `n` is _strictly greater than_ `m`, and write `n > m` or
-- `m < n`, iff `n ≥ m` and `n ≄ m`.
example : ℕ → ℕ → Prop :=
  @GT.gt ℕ (Natural.ltOp (self := Impl.order))
example {n m : ℕ} : n > m ↔ n ≥ m ∧ n ≄ m := by
  let lt_defn := @Natural.lt_defn (ℕ := ℕ) (self := Impl.order)
  apply Iff.intro
  · intro (_ : n > m)
    show n ≥ m ∧ n ≄ m
    have ⟨(_ : m ≤ n), (_ : m ≄ n)⟩ := lt_defn.mp ‹m < n›
    exact ⟨‹n ≥ m›, Rel.symm ‹m ≄ n›⟩
  · intro ⟨(_ : n ≥ m), (_ : n ≄ m)⟩
    show n > m
    have : m < n := lt_defn.mpr ⟨‹m ≤ n›, Rel.symm ‹n ≄ m›⟩
    exact ‹n > m›

-- Thus for instance `8 > 5`, because `8 ≃ 5 + 3` and `8 ≄ 5`.
example : 8 > 5 := by
  show 5 < 8
  apply Natural.lt_defn.mpr
  apply And.intro
  · show 5 ≤ 8
    apply Natural.le_defn.mpr
    apply Exists.intro (3 : ℕ)
    apply of_decide_eq_true
    rfl
  · show 5 ≄ 8
    apply of_decide_eq_false
    rfl

-- Also note that `step n > n` for any `n`
example {n : ℕ} : step n > n := Natural.lt_step

-- Exercise 2.2.3.
-- Proposition 2.2.12 (Basic properties of order for natural numbers).
-- Let `a`, `b`, `c` be natural numbers. Then
-- (a) (Order is reflexive) `a ≥ a`.
example {a : ℕ} : a ≥ a := Rel.refl (self := Natural.le_reflexive)

-- (b) (Order is transitive) If `a ≥ b` and `b ≥ c`, then `a ≥ c`.
example {a b c : ℕ} : a ≥ b → b ≥ c → a ≥ c :=
  flip (Rel.trans (self := Natural.le_transitive))

-- (c) (Order is anti-symmetric) If `a ≥ b` and `b ≥ a`, then `a ≃ b`.
example {a b : ℕ} : a ≥ b → b ≥ a → a ≃ b := flip Natural.le_antisymm

-- (d) (Addition preserves order) `a ≥ b` if and only if `a + c ≥ b + c`.
example {a b c : ℕ} : a ≥ b ↔ a + c ≥ b + c := by
  apply Iff.intro
  · intro (_ : b ≤ a)
    show b + c ≤ a + c
    exact AA.substL ‹b ≤ a›
  · intro (_ : b + c ≤ a + c)
    show b ≤ a
    exact AA.cancelR ‹b + c ≤ a + c›

-- (e) `a < b` if and only if `step a ≤ b`.
example {a b : ℕ} : a < b ↔ step a ≤ b := Natural.lt_step_le

-- (f) `a < b` if and only if `b ≃ a + d` for some _positive_ number `d`.
example {a b : ℕ} : a < b ↔ ∃ d, Positive d ∧ b ≃ a + d := Natural.lt_defn_add

-- Exercise 2.2.4.
-- Proposition 2.2.13 (Trichotomy of order for natural numbers).
-- Let `a` and `b` be natural numbers. Then exactly one of the following
-- statements is true: `a < b`, `a ≃ b`, or `a > b`.
example {a b : ℕ} : AA.ExactlyOneOfThree (a < b) (a ≃ b) (a > b) :=
  Natural.trichotomy a b

-- Exercise 2.2.5.
-- Proposition 2.2.14 (Strong principle of induction).
-- Let `m₀` be a natural number, and let `P m` be a property pertaining to an
-- arbitrary natural number `m`. Suppose that for each `m ≥ m₀`, we have the
-- following implication: if `P m'` is true for all natural numbers
-- `m₀ ≤ m' < m`, then `P m` is also true. (In particular, this means that
-- `P m₀` is true, since in this case the hypothesis is vacuous.) Then we can
-- conclude that `P m` is true for all natural numbers `m ≥ m₀`.
example
    {P : ℕ → Prop} {m₀ : ℕ}
    : (∀ m, m ≥ m₀ → (∀ m', m₀ ≤ m' → m' < m → P m') → P m) →
    ∀ m, m ≥ m₀ → P m := by
  intro (h : ∀ m, m₀ ≤ m → (∀ m', m₀ ≤ m' → m' < m → P m') → P m)
  intro m (_ : m₀ ≤ m)
  show P m
  apply h m ‹m₀ ≤ m›
  show ∀ m', m₀ ≤ m' → m' < m → P m'
  let motive := λ m => ∀ m', m₀ ≤ m' → m' < m → P m'
  apply Natural.ind_on (motive := motive) m
  case zero =>
    intro m' (_ : m₀ ≤ m') (_ : m' < 0)
    show P m'
    exact absurd ‹m' < 0› (Natural.lt_zero)
  case step =>
    intro m (ih : ∀ m', m₀ ≤ m' → m' < m → P m')
    intro m' (_ : m₀ ≤ m') (_ : m' < step m)
    show P m'
    match Natural.lt_split ‹m' < step m› with
    | Or.inl (_ : m' < m) =>
      exact ih m' ‹m₀ ≤ m'› ‹m' < m›
    | Or.inr (_ : m' ≃ m) =>
      apply h m' ‹m₀ ≤ m'›
      intro k (_ : m₀ ≤ k) (_ : k < m')
      show P k
      have : k < m := AA.substR (rβ := (· → ·)) ‹m' ≃ m› ‹k < m'›
      exact ih k ‹m₀ ≤ k› ‹k < m›

-- Exercise 2.2.6.
-- Let `n` be a natural number, and let `P m` be a property pertaining to the
-- natural numbers such that whenever `P (step m)` is true, then `P m` is true.
-- Suppose that `P n` is also true. Prove that `P m` is true for all natural
-- numbers `m ≤ n`; this is known as the _principle of backwards induction_.
example {P : ℕ → Prop} [AA.Substitutive₁ P (· ≃ ·) (· → ·)] {n : ℕ}
    : (∀ m, P (step m) → P m) → P n → ∀ m, m ≤ n → P m := by
  intro (_ : ∀ m, P (step m) → P m)
  apply Natural.ind_on (motive := λ n => P n → ∀ m, m ≤ n → P m) n
  case zero =>
    intro (_ : P 0) m (_ : m ≤ 0)
    show P m
    match Natural.le_split ‹m ≤ 0› with
    | Or.inl (_ : m < 0) =>
      exact absurd ‹m < 0› Natural.lt_zero
    | Or.inr (_ : m ≃ 0) =>
      exact AA.subst₁ (rβ := (· → ·)) (Rel.symm ‹m ≃ 0›) ‹P 0›
  case step =>
    intro n (ih : P n → ∀ m, m ≤ n → P m) (_ : P (step n)) m (_ : m ≤ step n)
    show P m
    match Natural.le_split ‹m ≤ step n› with
    | Or.inl (_ : m < step n) =>
      have : step m ≤ step n := Natural.lt_step_le.mp ‹m < step n›
      have : m ≤ n := AA.inject ‹step m ≤ step n›
      have : P n := ‹∀ m, P (step m) → P m› n ‹P (step n)›
      exact ih ‹P n› m ‹m ≤ n›
    | Or.inr (_ : m ≃ step n) =>
      exact AA.subst₁ (rβ := (· → ·)) (Rel.symm ‹m ≃ step n›) ‹P (step n)›

/- 2.3 Multiplication -/

-- Definition 2.3.1 (Multiplication of natural numbers).
-- Let `m` be a natural number. To multiply zero to `m`, we define
-- `0 * m := 0`. Now suppose inductively that we have defined how to multiply
-- `n` to `m`. Then we can multiply `step n` to `m` by defining
-- `step n * m := (n * m) + m`.
example : ℕ → ℕ → ℕ :=
  Mul.mul (self := Natural.mulOp (self := Impl.multiplication))

example {m : ℕ} : 0 * m ≃ 0 := Natural.zero_mul (self := Impl.multiplication)

example {n m : ℕ} : step n * m ≃ (n * m) + m :=
  Natural.step_mul (self := Impl.multiplication)

-- [Multiplication obeys left and right substitution]
example : AA.Substitutive₂ (α := ℕ) (· * ·) AA.tc (· ≃ ·) (· ≃ ·) :=
  Natural.mul_substitutive_eq

-- Thus for instance `0 * m ≃ 0`,
def ex_zero_mul {m : ℕ} : 0 * m ≃ 0 := Natural.zero_mul

-- `1 * m ≃ 0 + m`,
def ex_one_mul {m : ℕ} : 1 * m ≃ 0 + m := calc
  1 * m      ≃ _ := AA.substL (Natural.literal_step (self := Impl.literals))
  step 0 * m ≃ _ := Natural.step_mul
  0 * m + m  ≃ _ := AA.substL ex_zero_mul
  0 + m      ≃ _ := Rel.refl

-- `2 * m ≃ 0 + m + m`, etc.
def ex_two_mul {m : ℕ} : 2 * m ≃ 0 + m + m := calc
  2 * m      ≃ _ := AA.substL Natural.literal_step
  step 1 * m ≃ _ := Natural.step_mul
  1 * m + m  ≃ _ := AA.substL ex_one_mul
  0 + m + m  ≃ _ := Rel.refl

def two_mul_sum {m : ℕ} : 2 * m ≃ m + m := calc
  2 * m     ≃ _ := ex_two_mul
  0 + m + m ≃ _ := AA.substL Natural.zero_add
  m + m     ≃ _ := Rel.refl

-- Exercise 2.3.1.
-- Lemma 2.3.2 (Multiplication is commutative).
-- Let `n`, `m` be natural numbers. Then `n * m ≃ m * n`.
example {n m : ℕ} : n * m ≃ m * n := by
  exact AA.comm (self := Natural.mul_commutative)

-- Exercise 2.3.2.
-- Lemma 2.3.3 (Positive natural numbers have no zero divisors).
-- Let `n`, `m` be natural numbers. Then `n * m ≃ 0` if and only if at least
-- one of `n`, `m` is equal to zero.
example {n m : ℕ} : n * m ≃ 0 ↔ n ≃ 0 ∨ m ≃ 0 := Natural.mul_split_zero

-- In particular, if `n` and `m` are both positive, then `n * m` is also
-- positive.
example {n m : ℕ} : Positive n → Positive m → Positive (n * m) :=
  Natural.mul_positive

-- Proposition 2.3.4 (Distributive law).
-- For any natural numbers `a`, `b`, `c`, we have `a * (b + c) ≃ a * b + a * c`
-- and `(b + c) * a ≃ b * a + c * a`.
example {a b c : ℕ} : a * (b + c) ≃ a * b + a * c :=
  AA.distrib (self := Natural.mul_distributive.distributiveL)

example {a b c : ℕ} : (b + c) * a ≃ b * a + c * a := AA.distribR

-- Exercise 2.3.3.
-- Proposition 2.3.5 (Multiplication is associative).
-- For any natural numbers `a`, `b`, `c`, we have `(a * b) * c ≃ a * (b * c)`.
example {a b c : ℕ} : (a * b) * c ≃ a * (b * c) :=
  AA.assoc (self := Natural.mul_associative)

-- Proposition 2.3.6 (Multiplication preserves order).
-- If `a`, `b` are natural numbers such that `a < b`, and `c` is positive, then
-- `a * c < b * c`.
example {a b c : ℕ} : a < b → Positive c → a * c < b * c := by
  intro (_ : a < b) (_ : Positive c)
  show a * c < b * c
  let mul_substL_lt := (Natural.mul_substitutive_lt (ℕ := ℕ)).substitutiveL
  exact AA.substLC (self := mul_substL_lt) ‹Positive c› ‹a < b›

-- Corollary 2.3.7 (Cancellation law).
-- Let `a`, `b`, `c` be natural numbers such that `a * c ≃ b * c` and `c` is
-- non-zero. Then `a ≃ b`.
example {a b c : ℕ} : a * c ≃ b * c → c ≄ 0 → a ≃ b := by
  intro (_ : a * c ≃ b * c) (_ : c ≄ 0)
  show a ≃ b
  let mul_cancelR := (Natural.mul_cancellative (ℕ := ℕ)).cancellativeR
  exact AA.cancelRC (C := (· ≄ 0)) ‹c ≄ 0› ‹a * c ≃ b * c›

-- Exercise 2.3.5
-- Proposition 2.3.9 (Euclidean algorithm).
-- Let `n` be a natural number, and let `q` be a positive number. Then there
-- exist natural numbers `m`, `r` such that `0 ≤ r < q` and `n ≃ m * q + r`.
inductive Euclid (n q : ℕ) : Prop where
| intro (m r : ℕ) (r_bounded : r < q) (n_divided : n ≃ m * q + r) : Euclid n q

theorem euclidean_algorithm {n q : ℕ} : Positive q → Euclid n q := by
  intro (_ : Positive q)
  show Euclid n q
  have : 0 < q := Natural.lt_zero_pos.mp ‹Positive q›
  apply Natural.ind_on (motive := λ n => Euclid n q) n
  case zero =>
    show Euclid 0 q
    let m := 0
    let r := 0
    have r_bounded : r < q := ‹0 < q›
    have n_divided : 0 ≃ m * q + r := calc
      0         ≃ _ := Rel.symm Natural.zero_mul
      0 * q     ≃ _ := Rel.symm Natural.add_zero
      0 * q + 0 ≃ _ := Rel.refl
      m * q + r ≃ _ := Rel.refl
    exact Euclid.intro m r r_bounded n_divided
  case step =>
    intro n (ih : Euclid n q)
    show Euclid (step n) q
    have ⟨m', r', (_ : r' < q), (_ : n ≃ m' * q + r')⟩ := ih
    have : step r' ≤ q := Natural.lt_step_le.mp ‹r' < q›
    have : step r' < q ∨ step r' ≃ q := Natural.le_split ‹step r' ≤ q›
    apply Or.elim ‹step r' < q ∨ step r' ≃ q›
    · intro (_ : step r' < q)
      show Euclid (step n) q
      let m := m'
      let r := step r'
      have : r < q := ‹step r' < q›
      have : step n ≃ m * q + r := calc
        step n             ≃ _ := AA.subst₁ ‹n ≃ m' * q + r'›
        step (m' * q + r') ≃ _ := Rel.symm Natural.add_step
        m' * q + step r'   ≃ _ := Rel.refl
        m * q + r          ≃ _ := Rel.refl
      exact ⟨m, r, ‹r < q›, ‹step n ≃ m * q + r›⟩
    · intro (_ : step r' ≃ q)
      show Euclid (step n) q
      let m := step m'
      let r := 0
      have : r < q := ‹0 < q›
      have : step n ≃ m * q + r := calc
        step n             ≃ _ := AA.subst₁ ‹n ≃ m' * q + r'›
        step (m' * q + r') ≃ _ := Rel.symm Natural.add_step
        m' * q + step r'   ≃ _ := AA.substR ‹step r' ≃ q›
        m' * q + q         ≃ _ := Rel.symm Natural.step_mul
        step m' * q        ≃ _ := Rel.symm Natural.add_zero
        step m' * q + 0    ≃ _ := Rel.refl
        m * q + r          ≃ _ := Rel.refl
      exact ⟨m, r, ‹r < q›, ‹step n ≃ m * q + r›⟩

-- Definition 2.3.11 (Exponentiation for natural numbers).
example : ℕ → ℕ → ℕ :=
  Pow.pow (self := Natural.powOp (self := Impl.exponentiation))

-- Let `m` be a natural number. To raise `m` to the power `0`, we define
-- `m ^ 0 := 1`;
example {m : ℕ} : m ^ 0 ≃ 1 := Natural.pow_zero (self := Impl.exponentiation)

-- in particular, we define `0 ^ 0 := 1`.
example : 0 ^ (0 : ℕ) ≃ 1 := Natural.pow_zero

-- Now suppose recursively that `m ^ n` has been defined for some natural
-- number `n`, then we define `m ^ step n := m ^ n * m`.
example {m n : ℕ} : m ^ step n ≃ m ^ n * m :=
  Natural.pow_step (self := Impl.exponentiation)

-- Examples 2.3.12.
-- Thus for instance `x ^ 1 ≃ x ^ 0 * x ≃ 1 * x ≃ x`;
def pow_one {x : ℕ} : x ^ 1 ≃ x := calc
  x ^ 1           ≃ _ := Natural.pow_step
  x ^ (0 : ℕ) * x ≃ _ := AA.substL Natural.pow_zero
  1 * x           ≃ _ := ex_one_mul
  0 + x           ≃ _ := Natural.zero_add
  x               ≃ _ := Rel.refl

-- `x ^ 2 ≃ x ^ 1 * x ≃ x * x`;
def pow_two {x : ℕ} : x ^ 2 ≃ x * x := calc
  x ^ 2     ≃ _ := Natural.pow_step
  x ^ 1 * x ≃ _ := AA.substL pow_one
  x * x     ≃ _ := Rel.refl

-- `x ^ 3 ≃ x ^ 2 * x ≃ x * x * x`; and so forth.
example {x : ℕ} : x ^ 3 ≃ x * x * x := calc
  x ^ 3 ≃ _ := Natural.pow_step
  x ^ 2 * x ≃ _ := AA.substL pow_two
  x * x * x ≃ _ := Rel.refl

-- Exercise 2.3.4.
-- Prove the identity `(a + b) ^ 2 ≃ a ^ 2 + 2 * a * b + b ^ 2` for all natural
-- numbers `a, b`.
example {a b : ℕ} : (a + b) ^ 2 ≃ a ^ 2 + 2 * a * b + b ^ 2 := calc
  (a + b) ^ 2
    ≃ _ := pow_two
  (a + b) * (a + b)
    ≃ _ := AA.distribR
  a * (a + b) + b * (a + b)
    ≃ _ := AA.substL AA.distribL
  (a * a + a * b) + b * (a + b)
    ≃ _ := AA.substR AA.distribL
  (a * a + a * b) + (b * a + b * b)
    ≃ _ := AA.substR (AA.substL AA.comm)
  (a * a + a * b) + (a * b + b * b)
    ≃ _ := Rel.symm AA.assoc
  ((a * a + a * b) + a * b) + b * b
    ≃ _ := AA.substL AA.assoc
  a * a + (a * b + a * b) + b * b
    ≃ _ := Rel.symm (AA.substL (AA.substR two_mul_sum))
  a * a + 2 * (a * b) + b * b
    ≃ _ := Rel.symm (AA.substL (AA.substR AA.assoc))
  a * a + 2 * a * b + b * b
    ≃ _ := Rel.symm (AA.substL (AA.substL pow_two))
  a ^ 2 + 2 * a * b + b * b
    ≃ _ := Rel.symm (AA.substR pow_two)
  a ^ 2 + 2 * a * b + b ^ 2
    ≃ _ := Rel.refl

end AnalysisI.Ch2


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

! This file was ported from Lean 3 source module topology.covering
! leanprover-community/mathlib commit 8ef6f08ff8c781c5c07a8b12843710e1a0d8a688
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Topology.IsLocallyHomeomorph
import Mathbin.Topology.FiberBundle.Basic

/-!
# Covering Maps

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

This file defines covering maps.

## Main definitions

* `is_evenly_covered f x I`: A point `x` is evenly coverd by `f : E → X` with fiber `I` if `I` is
  discrete and there is a `trivialization` of `f` at `x` with fiber `I`.
* `is_covering_map f`: A function `f : E → X` is a covering map if every point `x` is evenly
  covered by `f` with fiber `f ⁻¹' {x}`. The fibers `f ⁻¹' {x}` must be discrete, but if `X` is
  not connected, then the fibers `f ⁻¹' {x}` are not necessarily isomorphic. Also, `f` is not
  assumed to be surjective, so the fibers are even allowed to be empty.
-/

open Bundle

variable {E X : Type _} [TopologicalSpace E] [TopologicalSpace X] (f : E → X) (s : Set X)

#print IsEvenlyCovered /-
/-- A point `x : X` is evenly covered by `f : E → X` if `x` has an evenly covered neighborhood. -/
def IsEvenlyCovered (x : X) (I : Type _) [TopologicalSpace I] :=
  DiscreteTopology I ∧ ∃ t : Trivialization I f, x ∈ t.baseSet
#align is_evenly_covered IsEvenlyCovered
-/

namespace IsEvenlyCovered

variable {f}

/- warning: is_evenly_covered.to_trivialization -> IsEvenlyCovered.toTrivialization is a dubious translation:
lean 3 declaration is
  forall {E : Type.{u_1}} {X : Type.{u_2}} [_inst_1 : TopologicalSpace.{u_1} E] [_inst_2 : TopologicalSpace.{u_2} X] {f : E -> X} {x : X} {I : Type.{u_3}} [_inst_3 : TopologicalSpace.{u_3} I], (IsEvenlyCovered.{u_1, u_2, u_3} E X _inst_1 _inst_2 f x I _inst_3) -> (Trivialization.{u_2, u_1, u_1} X (coeSort.{max (succ u_1) 1, succ (succ u_1)} (Set.{u_1} E) Type.{u_1} (Set.hasCoeToSort.{u_1} E) (Set.preimage.{u_1, u_2} E X f (Singleton.singleton.{u_2, u_2} X (Set.{u_2} X) (Set.hasSingleton.{u_2} X) x))) E _inst_2 (Subtype.topologicalSpace.{u_1} E (fun (x_1 : E) => Membership.Mem.{u_1, u_1} E (Set.{u_1} E) (Set.hasMem.{u_1} E) x_1 (Set.preimage.{u_1, u_2} E X f (Singleton.singleton.{u_2, u_2} X (Set.{u_2} X) (Set.hasSingleton.{u_2} X) x))) _inst_1) _inst_1 f)
but is expected to have type
  forall {E : Type.{u_1}} {X : Type.{u_2}} [_inst_1 : TopologicalSpace.{u_1} E] [_inst_2 : TopologicalSpace.{u_2} X] {f : E -> X} {x : X} {I : Type.{u_3}} [_inst_3 : TopologicalSpace.{u_3} I], (IsEvenlyCovered.{u_1, u_2, u_3} E X _inst_1 _inst_2 f x I _inst_3) -> (Trivialization.{u_2, u_1, u_1} X (Set.Elem.{u_1} E (Set.preimage.{u_1, u_2} E X f (Singleton.singleton.{u_2, u_2} X (Set.{u_2} X) (Set.instSingletonSet.{u_2} X) x))) E _inst_2 (instTopologicalSpaceSubtype.{u_1} E (fun (x_1 : E) => Membership.mem.{u_1, u_1} E (Set.{u_1} E) (Set.instMembershipSet.{u_1} E) x_1 (Set.preimage.{u_1, u_2} E X f (Singleton.singleton.{u_2, u_2} X (Set.{u_2} X) (Set.instSingletonSet.{u_2} X) x))) _inst_1) _inst_1 f)
Case conversion may be inaccurate. Consider using '#align is_evenly_covered.to_trivialization IsEvenlyCovered.toTrivializationₓ'. -/
/-- If `x` is evenly covered by `f`, then we can construct a trivialization of `f` at `x`. -/
noncomputable def toTrivialization {x : X} {I : Type _} [TopologicalSpace I]
    (h : IsEvenlyCovered f x I) : Trivialization (f ⁻¹' {x}) f :=
  (Classical.choose h.2).transFiberHomeomorph
    ((Classical.choose h.2).preimageSingletonHomeomorph (Classical.choose_spec h.2)).symm
#align is_evenly_covered.to_trivialization IsEvenlyCovered.toTrivialization

/- warning: is_evenly_covered.mem_to_trivialization_base_set -> IsEvenlyCovered.mem_toTrivialization_baseSet is a dubious translation:
lean 3 declaration is
  forall {E : Type.{u_1}} {X : Type.{u_2}} [_inst_1 : TopologicalSpace.{u_1} E] [_inst_2 : TopologicalSpace.{u_2} X] {f : E -> X} {x : X} {I : Type.{u_3}} [_inst_3 : TopologicalSpace.{u_3} I] (h : IsEvenlyCovered.{u_1, u_2, u_3} E X _inst_1 _inst_2 f x I _inst_3), Membership.Mem.{u_2, u_2} X (Set.{u_2} X) (Set.hasMem.{u_2} X) x (Trivialization.baseSet.{u_2, u_1, u_1} X (coeSort.{max (succ u_1) 1, succ (succ u_1)} (Set.{u_1} E) Type.{u_1} (Set.hasCoeToSort.{u_1} E) (Set.preimage.{u_1, u_2} E X f (Singleton.singleton.{u_2, u_2} X (Set.{u_2} X) (Set.hasSingleton.{u_2} X) x))) E _inst_2 (Subtype.topologicalSpace.{u_1} E (fun (x_1 : E) => Membership.Mem.{u_1, u_1} E (Set.{u_1} E) (Set.hasMem.{u_1} E) x_1 (Set.preimage.{u_1, u_2} E X f (Singleton.singleton.{u_2, u_2} X (Set.{u_2} X) (Set.hasSingleton.{u_2} X) x))) _inst_1) _inst_1 f (IsEvenlyCovered.toTrivialization.{u_1, u_2, u_3, u_4} E X _inst_1 _inst_2 f x I _inst_3 h))
but is expected to have type
  forall {E : Type.{u_2}} {X : Type.{u_3}} [_inst_1 : TopologicalSpace.{u_2} E] [_inst_2 : TopologicalSpace.{u_3} X] {f : E -> X} {x : X} {I : Type.{u_1}} [_inst_3 : TopologicalSpace.{u_1} I] (h : IsEvenlyCovered.{u_2, u_3, u_1} E X _inst_1 _inst_2 f x I _inst_3), Membership.mem.{u_3, u_3} X (Set.{u_3} X) (Set.instMembershipSet.{u_3} X) x (Trivialization.baseSet.{u_3, u_2, u_2} X (Set.Elem.{u_2} E (Set.preimage.{u_2, u_3} E X f (Singleton.singleton.{u_3, u_3} X (Set.{u_3} X) (Set.instSingletonSet.{u_3} X) x))) E _inst_2 (instTopologicalSpaceSubtype.{u_2} E (fun (x_1 : E) => Membership.mem.{u_2, u_2} E (Set.{u_2} E) (Set.instMembershipSet.{u_2} E) x_1 (Set.preimage.{u_2, u_3} E X f (Singleton.singleton.{u_3, u_3} X (Set.{u_3} X) (Set.instSingletonSet.{u_3} X) x))) _inst_1) _inst_1 f (IsEvenlyCovered.toTrivialization.{u_2, u_3, u_1} E X _inst_1 _inst_2 f x I _inst_3 h))
Case conversion may be inaccurate. Consider using '#align is_evenly_covered.mem_to_trivialization_base_set IsEvenlyCovered.mem_toTrivialization_baseSetₓ'. -/
theorem mem_toTrivialization_baseSet {x : X} {I : Type _} [TopologicalSpace I]
    (h : IsEvenlyCovered f x I) : x ∈ h.toTrivialization.baseSet :=
  Classical.choose_spec h.2
#align is_evenly_covered.mem_to_trivialization_base_set IsEvenlyCovered.mem_toTrivialization_baseSet

/- warning: is_evenly_covered.to_trivialization_apply -> IsEvenlyCovered.toTrivialization_apply is a dubious translation:
lean 3 declaration is
  forall {E : Type.{u_1}} {X : Type.{u_2}} [_inst_1 : TopologicalSpace.{u_1} E] [_inst_2 : TopologicalSpace.{u_2} X] {f : E -> X} {x : E} {I : Type.{u_3}} [_inst_3 : TopologicalSpace.{u_3} I] (h : IsEvenlyCovered.{u_1, u_2, u_3} E X _inst_1 _inst_2 f (f x) I _inst_3), Eq.{succ u_1} (coeSort.{max (succ u_1) 1, succ (succ u_1)} (Set.{u_1} E) Type.{u_1} (Set.hasCoeToSort.{u_1} E) (Set.preimage.{u_1, u_2} E X f (Singleton.singleton.{u_2, u_2} X (Set.{u_2} X) (Set.hasSingleton.{u_2} X) (f x)))) (Prod.snd.{u_2, u_1} X (coeSort.{max (succ u_1) 1, succ (succ u_1)} (Set.{u_1} E) Type.{u_1} (Set.hasCoeToSort.{u_1} E) (Set.preimage.{u_1, u_2} E X f (Singleton.singleton.{u_2, u_2} X (Set.{u_2} X) (Set.hasSingleton.{u_2} X) (f x)))) (coeFn.{max (succ u_2) (succ u_1), max (succ u_2) (succ u_1)} (Trivialization.{u_2, u_1, u_1} X (coeSort.{max (succ u_1) 1, succ (succ u_1)} (Set.{u_1} E) Type.{u_1} (Set.hasCoeToSort.{u_1} E) (Set.preimage.{u_1, u_2} E X f (Singleton.singleton.{u_2, u_2} X (Set.{u_2} X) (Set.hasSingleton.{u_2} X) (f x)))) E _inst_2 (Subtype.topologicalSpace.{u_1} E (fun (x_1 : E) => Membership.Mem.{u_1, u_1} E (Set.{u_1} E) (Set.hasMem.{u_1} E) x_1 (Set.preimage.{u_1, u_2} E X f (Singleton.singleton.{u_2, u_2} X (Set.{u_2} X) (Set.hasSingleton.{u_2} X) (f x)))) _inst_1) _inst_1 f) (fun (_x : Trivialization.{u_2, u_1, u_1} X (coeSort.{max (succ u_1) 1, succ (succ u_1)} (Set.{u_1} E) Type.{u_1} (Set.hasCoeToSort.{u_1} E) (Set.preimage.{u_1, u_2} E X f (Singleton.singleton.{u_2, u_2} X (Set.{u_2} X) (Set.hasSingleton.{u_2} X) (f x)))) E _inst_2 (Subtype.topologicalSpace.{u_1} E (fun (x_1 : E) => Membership.Mem.{u_1, u_1} E (Set.{u_1} E) (Set.hasMem.{u_1} E) x_1 (Set.preimage.{u_1, u_2} E X f (Singleton.singleton.{u_2, u_2} X (Set.{u_2} X) (Set.hasSingleton.{u_2} X) (f x)))) _inst_1) _inst_1 f) => E -> (Prod.{u_2, u_1} X (coeSort.{max (succ u_1) 1, succ (succ u_1)} (Set.{u_1} E) Type.{u_1} (Set.hasCoeToSort.{u_1} E) (Set.preimage.{u_1, u_2} E X f (Singleton.singleton.{u_2, u_2} X (Set.{u_2} X) (Set.hasSingleton.{u_2} X) (f x)))))) (Trivialization.hasCoeToFun.{u_2, u_1, u_1} X (coeSort.{max (succ u_1) 1, succ (succ u_1)} (Set.{u_1} E) Type.{u_1} (Set.hasCoeToSort.{u_1} E) (Set.preimage.{u_1, u_2} E X f (Singleton.singleton.{u_2, u_2} X (Set.{u_2} X) (Set.hasSingleton.{u_2} X) (f x)))) E _inst_2 (Subtype.topologicalSpace.{u_1} E (fun (x_1 : E) => Membership.Mem.{u_1, u_1} E (Set.{u_1} E) (Set.hasMem.{u_1} E) x_1 (Set.preimage.{u_1, u_2} E X f (Singleton.singleton.{u_2, u_2} X (Set.{u_2} X) (Set.hasSingleton.{u_2} X) (f x)))) _inst_1) f _inst_1) (IsEvenlyCovered.toTrivialization.{u_1, u_2, u_3, u_4} E X _inst_1 _inst_2 f (f x) I _inst_3 h) x)) (Subtype.mk.{succ u_1} E (fun (x_1 : E) => Membership.Mem.{u_1, u_1} E (Set.{u_1} E) (Set.hasMem.{u_1} E) x_1 (Set.preimage.{u_1, u_2} E X f (Singleton.singleton.{u_2, u_2} X (Set.{u_2} X) (Set.hasSingleton.{u_2} X) (f x)))) x (rfl.{succ u_2} X (f x)))
but is expected to have type
  forall {E : Type.{u_2}} {X : Type.{u_3}} [_inst_1 : TopologicalSpace.{u_2} E] [_inst_2 : TopologicalSpace.{u_3} X] {f : E -> X} {x : E} {I : Type.{u_1}} [_inst_3 : TopologicalSpace.{u_1} I] (h : IsEvenlyCovered.{u_2, u_3, u_1} E X _inst_1 _inst_2 f (f x) I _inst_3), Eq.{succ u_2} (Set.Elem.{u_2} E (Set.preimage.{u_2, u_3} E X f (Singleton.singleton.{u_3, u_3} X (Set.{u_3} X) (Set.instSingletonSet.{u_3} X) (f x)))) (Prod.snd.{u_3, u_2} X (Set.Elem.{u_2} E (Set.preimage.{u_2, u_3} E X f (Singleton.singleton.{u_3, u_3} X (Set.{u_3} X) (Set.instSingletonSet.{u_3} X) (f x)))) (Trivialization.toFun'.{u_3, u_2, u_2} X (Set.Elem.{u_2} E (Set.preimage.{u_2, u_3} E X f (Singleton.singleton.{u_3, u_3} X (Set.{u_3} X) (Set.instSingletonSet.{u_3} X) (f x)))) E _inst_2 (instTopologicalSpaceSubtype.{u_2} E (fun (x_1 : E) => Membership.mem.{u_2, u_2} E (Set.{u_2} E) (Set.instMembershipSet.{u_2} E) x_1 (Set.preimage.{u_2, u_3} E X f (Singleton.singleton.{u_3, u_3} X (Set.{u_3} X) (Set.instSingletonSet.{u_3} X) (f x)))) _inst_1) f _inst_1 (IsEvenlyCovered.toTrivialization.{u_2, u_3, u_1} E X _inst_1 _inst_2 f (f x) I _inst_3 h) x)) (Subtype.mk.{succ u_2} E (fun (x_1 : E) => Membership.mem.{u_2, u_2} E (Set.{u_2} E) (Set.instMembershipSet.{u_2} E) x_1 (Set.preimage.{u_2, u_3} E X f (Singleton.singleton.{u_3, u_3} X (Set.{u_3} X) (Set.instSingletonSet.{u_3} X) (f x)))) x (rfl.{succ u_3} X (f x)))
Case conversion may be inaccurate. Consider using '#align is_evenly_covered.to_trivialization_apply IsEvenlyCovered.toTrivialization_applyₓ'. -/
theorem toTrivialization_apply {x : E} {I : Type _} [TopologicalSpace I]
    (h : IsEvenlyCovered f (f x) I) : (h.toTrivialization x).2 = ⟨x, rfl⟩ :=
  let e := Classical.choose h.2
  let h := Classical.choose_spec h.2
  let he := e.mk_proj_snd' h
  Subtype.ext
    ((e.toLocalEquiv.eq_symm_apply (e.mem_source.mpr h)
            (by rwa [he, e.mem_target, e.coe_fst (e.mem_source.mpr h)])).mpr
        he.symm).symm
#align is_evenly_covered.to_trivialization_apply IsEvenlyCovered.toTrivialization_apply

/- warning: is_evenly_covered.continuous_at -> IsEvenlyCovered.continuousAt is a dubious translation:
lean 3 declaration is
  forall {E : Type.{u1}} {X : Type.{u2}} [_inst_1 : TopologicalSpace.{u1} E] [_inst_2 : TopologicalSpace.{u2} X] {f : E -> X} {x : E} {I : Type.{u3}} [_inst_3 : TopologicalSpace.{u3} I], (IsEvenlyCovered.{u1, u2, u3} E X _inst_1 _inst_2 f (f x) I _inst_3) -> (ContinuousAt.{u1, u2} E X _inst_1 _inst_2 f x)
but is expected to have type
  forall {E : Type.{u2}} {X : Type.{u1}} [_inst_1 : TopologicalSpace.{u2} E] [_inst_2 : TopologicalSpace.{u1} X] {f : E -> X} {x : E} {I : Type.{u3}} [_inst_3 : TopologicalSpace.{u3} I], (IsEvenlyCovered.{u2, u1, u3} E X _inst_1 _inst_2 f (f x) I _inst_3) -> (ContinuousAt.{u2, u1} E X _inst_1 _inst_2 f x)
Case conversion may be inaccurate. Consider using '#align is_evenly_covered.continuous_at IsEvenlyCovered.continuousAtₓ'. -/
protected theorem continuousAt {x : E} {I : Type _} [TopologicalSpace I]
    (h : IsEvenlyCovered f (f x) I) : ContinuousAt f x :=
  let e := h.toTrivialization
  e.continuousAt_proj (e.mem_source.mpr (mem_toTrivialization_baseSet h))
#align is_evenly_covered.continuous_at IsEvenlyCovered.continuousAt

/- warning: is_evenly_covered.to_is_evenly_covered_preimage -> IsEvenlyCovered.to_isEvenlyCovered_preimage is a dubious translation:
lean 3 declaration is
  forall {E : Type.{u1}} {X : Type.{u2}} [_inst_1 : TopologicalSpace.{u1} E] [_inst_2 : TopologicalSpace.{u2} X] {f : E -> X} {x : X} {I : Type.{u3}} [_inst_3 : TopologicalSpace.{u3} I], (IsEvenlyCovered.{u1, u2, u3} E X _inst_1 _inst_2 f x I _inst_3) -> (IsEvenlyCovered.{u1, u2, u1} E X _inst_1 _inst_2 f x (coeSort.{succ u1, succ (succ u1)} (Set.{u1} E) Type.{u1} (Set.hasCoeToSort.{u1} E) (Set.preimage.{u1, u2} E X f (Singleton.singleton.{u2, u2} X (Set.{u2} X) (Set.hasSingleton.{u2} X) x))) (Subtype.topologicalSpace.{u1} E (fun (x_1 : E) => Membership.Mem.{u1, u1} E (Set.{u1} E) (Set.hasMem.{u1} E) x_1 (Set.preimage.{u1, u2} E X f (Singleton.singleton.{u2, u2} X (Set.{u2} X) (Set.hasSingleton.{u2} X) x))) _inst_1))
but is expected to have type
  forall {E : Type.{u2}} {X : Type.{u1}} [_inst_1 : TopologicalSpace.{u2} E] [_inst_2 : TopologicalSpace.{u1} X] {f : E -> X} {x : X} {I : Type.{u3}} [_inst_3 : TopologicalSpace.{u3} I], (IsEvenlyCovered.{u2, u1, u3} E X _inst_1 _inst_2 f x I _inst_3) -> (IsEvenlyCovered.{u2, u1, u2} E X _inst_1 _inst_2 f x (Set.Elem.{u2} E (Set.preimage.{u2, u1} E X f (Singleton.singleton.{u1, u1} X (Set.{u1} X) (Set.instSingletonSet.{u1} X) x))) (instTopologicalSpaceSubtype.{u2} E (fun (x_1 : E) => Membership.mem.{u2, u2} E (Set.{u2} E) (Set.instMembershipSet.{u2} E) x_1 (Set.preimage.{u2, u1} E X f (Singleton.singleton.{u1, u1} X (Set.{u1} X) (Set.instSingletonSet.{u1} X) x))) _inst_1))
Case conversion may be inaccurate. Consider using '#align is_evenly_covered.to_is_evenly_covered_preimage IsEvenlyCovered.to_isEvenlyCovered_preimageₓ'. -/
theorem to_isEvenlyCovered_preimage {x : X} {I : Type _} [TopologicalSpace I]
    (h : IsEvenlyCovered f x I) : IsEvenlyCovered f x (f ⁻¹' {x}) :=
  let ⟨h1, h2⟩ := h
  ⟨((Classical.choose h2).preimageSingletonHomeomorph
          (Classical.choose_spec h2)).Embedding.DiscreteTopology,
    _, h.mem_to_trivialization_base_set⟩
#align is_evenly_covered.to_is_evenly_covered_preimage IsEvenlyCovered.to_isEvenlyCovered_preimage

end IsEvenlyCovered

#print IsCoveringMapOn /-
/-- A covering map is a continuous function `f : E → X` with discrete fibers such that each point
  of `X` has an evenly covered neighborhood. -/
def IsCoveringMapOn :=
  ∀ x ∈ s, IsEvenlyCovered f x (f ⁻¹' {x})
#align is_covering_map_on IsCoveringMapOn
-/

namespace IsCoveringMapOn

#print IsCoveringMapOn.mk /-
theorem mk (F : X → Type _) [∀ x, TopologicalSpace (F x)] [hF : ∀ x, DiscreteTopology (F x)]
    (e : ∀ x ∈ s, Trivialization (F x) f) (h : ∀ (x : X) (hx : x ∈ s), x ∈ (e x hx).baseSet) :
    IsCoveringMapOn f s := fun x hx =>
  IsEvenlyCovered.to_isEvenlyCovered_preimage ⟨hF x, e x hx, h x hx⟩
#align is_covering_map_on.mk IsCoveringMapOn.mk
-/

variable {f} {s}

/- warning: is_covering_map_on.continuous_at -> IsCoveringMapOn.continuousAt is a dubious translation:
lean 3 declaration is
  forall {E : Type.{u1}} {X : Type.{u2}} [_inst_1 : TopologicalSpace.{u1} E] [_inst_2 : TopologicalSpace.{u2} X] {f : E -> X} {s : Set.{u2} X}, (IsCoveringMapOn.{u1, u2} E X _inst_1 _inst_2 f s) -> (forall {x : E}, (Membership.Mem.{u2, u2} X (Set.{u2} X) (Set.hasMem.{u2} X) (f x) s) -> (ContinuousAt.{u1, u2} E X _inst_1 _inst_2 f x))
but is expected to have type
  forall {E : Type.{u2}} {X : Type.{u1}} [_inst_1 : TopologicalSpace.{u2} E] [_inst_2 : TopologicalSpace.{u1} X] {f : E -> X} {s : Set.{u1} X}, (IsCoveringMapOn.{u2, u1} E X _inst_1 _inst_2 f s) -> (forall {x : E}, (Membership.mem.{u1, u1} X (Set.{u1} X) (Set.instMembershipSet.{u1} X) (f x) s) -> (ContinuousAt.{u2, u1} E X _inst_1 _inst_2 f x))
Case conversion may be inaccurate. Consider using '#align is_covering_map_on.continuous_at IsCoveringMapOn.continuousAtₓ'. -/
protected theorem continuousAt (hf : IsCoveringMapOn f s) {x : E} (hx : f x ∈ s) :
    ContinuousAt f x :=
  (hf (f x) hx).ContinuousAt
#align is_covering_map_on.continuous_at IsCoveringMapOn.continuousAt

/- warning: is_covering_map_on.continuous_on -> IsCoveringMapOn.continuousOn is a dubious translation:
lean 3 declaration is
  forall {E : Type.{u1}} {X : Type.{u2}} [_inst_1 : TopologicalSpace.{u1} E] [_inst_2 : TopologicalSpace.{u2} X] {f : E -> X} {s : Set.{u2} X}, (IsCoveringMapOn.{u1, u2} E X _inst_1 _inst_2 f s) -> (ContinuousOn.{u1, u2} E X _inst_1 _inst_2 f (Set.preimage.{u1, u2} E X f s))
but is expected to have type
  forall {E : Type.{u2}} {X : Type.{u1}} [_inst_1 : TopologicalSpace.{u2} E] [_inst_2 : TopologicalSpace.{u1} X] {f : E -> X} {s : Set.{u1} X}, (IsCoveringMapOn.{u2, u1} E X _inst_1 _inst_2 f s) -> (ContinuousOn.{u2, u1} E X _inst_1 _inst_2 f (Set.preimage.{u2, u1} E X f s))
Case conversion may be inaccurate. Consider using '#align is_covering_map_on.continuous_on IsCoveringMapOn.continuousOnₓ'. -/
protected theorem continuousOn (hf : IsCoveringMapOn f s) : ContinuousOn f (f ⁻¹' s) :=
  ContinuousAt.continuousOn fun x => hf.ContinuousAt
#align is_covering_map_on.continuous_on IsCoveringMapOn.continuousOn

/- warning: is_covering_map_on.is_locally_homeomorph_on -> IsCoveringMapOn.isLocallyHomeomorphOn is a dubious translation:
lean 3 declaration is
  forall {E : Type.{u1}} {X : Type.{u2}} [_inst_1 : TopologicalSpace.{u1} E] [_inst_2 : TopologicalSpace.{u2} X] {f : E -> X} {s : Set.{u2} X}, (IsCoveringMapOn.{u1, u2} E X _inst_1 _inst_2 f s) -> (IsLocallyHomeomorphOn.{u1, u2} E X _inst_1 _inst_2 f (Set.preimage.{u1, u2} E X f s))
but is expected to have type
  forall {E : Type.{u2}} {X : Type.{u1}} [_inst_1 : TopologicalSpace.{u2} E] [_inst_2 : TopologicalSpace.{u1} X] {f : E -> X} {s : Set.{u1} X}, (IsCoveringMapOn.{u2, u1} E X _inst_1 _inst_2 f s) -> (IsLocallyHomeomorphOn.{u2, u1} E X _inst_1 _inst_2 f (Set.preimage.{u2, u1} E X f s))
Case conversion may be inaccurate. Consider using '#align is_covering_map_on.is_locally_homeomorph_on IsCoveringMapOn.isLocallyHomeomorphOnₓ'. -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
protected theorem isLocallyHomeomorphOn (hf : IsCoveringMapOn f s) :
    IsLocallyHomeomorphOn f (f ⁻¹' s) :=
  by
  refine' IsLocallyHomeomorphOn.mk f (f ⁻¹' s) fun x hx => _
  let e := (hf (f x) hx).toTrivialization
  have h := (hf (f x) hx).mem_toTrivialization_baseSet
  let he := e.mem_source.2 h
  refine'
    ⟨e.to_local_homeomorph.trans
        { toFun := fun p => p.1
          invFun := fun p => ⟨p, x, rfl⟩
          source := e.base_set ×ˢ ({⟨x, rfl⟩} : Set (f ⁻¹' {f x}))
          target := e.base_set
          open_source :=
            e.open_base_set.prod (singletons_open_iff_discrete.2 (hf (f x) hx).1 ⟨x, rfl⟩)
          open_target := e.open_base_set
          map_source' := fun p => And.left
          map_target' := fun p hp => ⟨hp, rfl⟩
          left_inv' := fun p hp => Prod.ext rfl hp.2.symm
          right_inv' := fun p hp => rfl
          continuous_toFun := continuous_fst.continuous_on
          continuous_invFun := (continuous_id'.prod_mk continuous_const).ContinuousOn },
      ⟨he, by rwa [e.to_local_homeomorph.symm_symm, e.proj_to_fun x he],
        (hf (f x) hx).toTrivialization_apply⟩,
      fun p h => (e.proj_to_fun p h.1).symm⟩
#align is_covering_map_on.is_locally_homeomorph_on IsCoveringMapOn.isLocallyHomeomorphOn

end IsCoveringMapOn

#print IsCoveringMap /-
/-- A covering map is a continuous function `f : E → X` with discrete fibers such that each point
  of `X` has an evenly covered neighborhood. -/
def IsCoveringMap :=
  ∀ x, IsEvenlyCovered f x (f ⁻¹' {x})
#align is_covering_map IsCoveringMap
-/

variable {f}

/- warning: is_covering_map_iff_is_covering_map_on_univ -> isCoveringMap_iff_isCoveringMapOn_univ is a dubious translation:
lean 3 declaration is
  forall {E : Type.{u1}} {X : Type.{u2}} [_inst_1 : TopologicalSpace.{u1} E] [_inst_2 : TopologicalSpace.{u2} X] {f : E -> X}, Iff (IsCoveringMap.{u1, u2} E X _inst_1 _inst_2 f) (IsCoveringMapOn.{u1, u2} E X _inst_1 _inst_2 f (Set.univ.{u2} X))
but is expected to have type
  forall {E : Type.{u2}} {X : Type.{u1}} [_inst_1 : TopologicalSpace.{u2} E] [_inst_2 : TopologicalSpace.{u1} X] {f : E -> X}, Iff (IsCoveringMap.{u2, u1} E X _inst_1 _inst_2 f) (IsCoveringMapOn.{u2, u1} E X _inst_1 _inst_2 f (Set.univ.{u1} X))
Case conversion may be inaccurate. Consider using '#align is_covering_map_iff_is_covering_map_on_univ isCoveringMap_iff_isCoveringMapOn_univₓ'. -/
theorem isCoveringMap_iff_isCoveringMapOn_univ : IsCoveringMap f ↔ IsCoveringMapOn f Set.univ := by
  simp only [IsCoveringMap, IsCoveringMapOn, Set.mem_univ, forall_true_left]
#align is_covering_map_iff_is_covering_map_on_univ isCoveringMap_iff_isCoveringMapOn_univ

/- warning: is_covering_map.is_covering_map_on -> IsCoveringMap.isCoveringMapOn is a dubious translation:
lean 3 declaration is
  forall {E : Type.{u1}} {X : Type.{u2}} [_inst_1 : TopologicalSpace.{u1} E] [_inst_2 : TopologicalSpace.{u2} X] {f : E -> X}, (IsCoveringMap.{u1, u2} E X _inst_1 _inst_2 f) -> (IsCoveringMapOn.{u1, u2} E X _inst_1 _inst_2 f (Set.univ.{u2} X))
but is expected to have type
  forall {E : Type.{u2}} {X : Type.{u1}} [_inst_1 : TopologicalSpace.{u2} E] [_inst_2 : TopologicalSpace.{u1} X] {f : E -> X}, (IsCoveringMap.{u2, u1} E X _inst_1 _inst_2 f) -> (IsCoveringMapOn.{u2, u1} E X _inst_1 _inst_2 f (Set.univ.{u1} X))
Case conversion may be inaccurate. Consider using '#align is_covering_map.is_covering_map_on IsCoveringMap.isCoveringMapOnₓ'. -/
protected theorem IsCoveringMap.isCoveringMapOn (hf : IsCoveringMap f) :
    IsCoveringMapOn f Set.univ :=
  isCoveringMap_iff_isCoveringMapOn_univ.mp hf
#align is_covering_map.is_covering_map_on IsCoveringMap.isCoveringMapOn

variable (f)

namespace IsCoveringMap

#print IsCoveringMap.mk /-
theorem mk (F : X → Type _) [∀ x, TopologicalSpace (F x)] [hF : ∀ x, DiscreteTopology (F x)]
    (e : ∀ x, Trivialization (F x) f) (h : ∀ x, x ∈ (e x).baseSet) : IsCoveringMap f :=
  isCoveringMap_iff_isCoveringMapOn_univ.mpr
    (IsCoveringMapOn.mk f Set.univ F (fun x hx => e x) fun x hx => h x)
#align is_covering_map.mk IsCoveringMap.mk
-/

variable {f}

/- warning: is_covering_map.continuous -> IsCoveringMap.continuous is a dubious translation:
lean 3 declaration is
  forall {E : Type.{u1}} {X : Type.{u2}} [_inst_1 : TopologicalSpace.{u1} E] [_inst_2 : TopologicalSpace.{u2} X] {f : E -> X}, (IsCoveringMap.{u1, u2} E X _inst_1 _inst_2 f) -> (Continuous.{u1, u2} E X _inst_1 _inst_2 f)
but is expected to have type
  forall {E : Type.{u2}} {X : Type.{u1}} [_inst_1 : TopologicalSpace.{u2} E] [_inst_2 : TopologicalSpace.{u1} X] {f : E -> X}, (IsCoveringMap.{u2, u1} E X _inst_1 _inst_2 f) -> (Continuous.{u2, u1} E X _inst_1 _inst_2 f)
Case conversion may be inaccurate. Consider using '#align is_covering_map.continuous IsCoveringMap.continuousₓ'. -/
protected theorem continuous (hf : IsCoveringMap f) : Continuous f :=
  continuous_iff_continuousOn_univ.mpr hf.IsCoveringMapOn.ContinuousOn
#align is_covering_map.continuous IsCoveringMap.continuous

/- warning: is_covering_map.is_locally_homeomorph -> IsCoveringMap.isLocallyHomeomorph is a dubious translation:
lean 3 declaration is
  forall {E : Type.{u1}} {X : Type.{u2}} [_inst_1 : TopologicalSpace.{u1} E] [_inst_2 : TopologicalSpace.{u2} X] {f : E -> X}, (IsCoveringMap.{u1, u2} E X _inst_1 _inst_2 f) -> (IsLocallyHomeomorph.{u1, u2} E X _inst_1 _inst_2 f)
but is expected to have type
  forall {E : Type.{u2}} {X : Type.{u1}} [_inst_1 : TopologicalSpace.{u2} E] [_inst_2 : TopologicalSpace.{u1} X] {f : E -> X}, (IsCoveringMap.{u2, u1} E X _inst_1 _inst_2 f) -> (IsLocallyHomeomorph.{u2, u1} E X _inst_1 _inst_2 f)
Case conversion may be inaccurate. Consider using '#align is_covering_map.is_locally_homeomorph IsCoveringMap.isLocallyHomeomorphₓ'. -/
protected theorem isLocallyHomeomorph (hf : IsCoveringMap f) : IsLocallyHomeomorph f :=
  isLocallyHomeomorph_iff_isLocallyHomeomorphOn_univ.mpr hf.IsCoveringMapOn.IsLocallyHomeomorphOn
#align is_covering_map.is_locally_homeomorph IsCoveringMap.isLocallyHomeomorph

/- warning: is_covering_map.is_open_map -> IsCoveringMap.isOpenMap is a dubious translation:
lean 3 declaration is
  forall {E : Type.{u1}} {X : Type.{u2}} [_inst_1 : TopologicalSpace.{u1} E] [_inst_2 : TopologicalSpace.{u2} X] {f : E -> X}, (IsCoveringMap.{u1, u2} E X _inst_1 _inst_2 f) -> (IsOpenMap.{u1, u2} E X _inst_1 _inst_2 f)
but is expected to have type
  forall {E : Type.{u2}} {X : Type.{u1}} [_inst_1 : TopologicalSpace.{u2} E] [_inst_2 : TopologicalSpace.{u1} X] {f : E -> X}, (IsCoveringMap.{u2, u1} E X _inst_1 _inst_2 f) -> (IsOpenMap.{u2, u1} E X _inst_1 _inst_2 f)
Case conversion may be inaccurate. Consider using '#align is_covering_map.is_open_map IsCoveringMap.isOpenMapₓ'. -/
protected theorem isOpenMap (hf : IsCoveringMap f) : IsOpenMap f :=
  hf.IsLocallyHomeomorph.IsOpenMap
#align is_covering_map.is_open_map IsCoveringMap.isOpenMap

/- warning: is_covering_map.quotient_map -> IsCoveringMap.quotientMap is a dubious translation:
lean 3 declaration is
  forall {E : Type.{u1}} {X : Type.{u2}} [_inst_1 : TopologicalSpace.{u1} E] [_inst_2 : TopologicalSpace.{u2} X] {f : E -> X}, (IsCoveringMap.{u1, u2} E X _inst_1 _inst_2 f) -> (Function.Surjective.{succ u1, succ u2} E X f) -> (QuotientMap.{u1, u2} E X _inst_1 _inst_2 f)
but is expected to have type
  forall {E : Type.{u2}} {X : Type.{u1}} [_inst_1 : TopologicalSpace.{u2} E] [_inst_2 : TopologicalSpace.{u1} X] {f : E -> X}, (IsCoveringMap.{u2, u1} E X _inst_1 _inst_2 f) -> (Function.Surjective.{succ u2, succ u1} E X f) -> (QuotientMap.{u2, u1} E X _inst_1 _inst_2 f)
Case conversion may be inaccurate. Consider using '#align is_covering_map.quotient_map IsCoveringMap.quotientMapₓ'. -/
protected theorem quotientMap (hf : IsCoveringMap f) (hf' : Function.Surjective f) :
    QuotientMap f :=
  hf.IsOpenMap.to_quotientMap hf.Continuous hf'
#align is_covering_map.quotient_map IsCoveringMap.quotientMap

end IsCoveringMap

variable {f}

/- warning: is_fiber_bundle.is_covering_map -> IsFiberBundle.isCoveringMap is a dubious translation:
lean 3 declaration is
  forall {E : Type.{u1}} {X : Type.{u2}} [_inst_1 : TopologicalSpace.{u1} E] [_inst_2 : TopologicalSpace.{u2} X] {f : E -> X} {F : Type.{u3}} [_inst_3 : TopologicalSpace.{u3} F] [_inst_4 : DiscreteTopology.{u3} F _inst_3], (forall (x : X), Exists.{max (succ u2) (succ u3) (succ u1)} (Trivialization.{u2, u3, u1} X F E _inst_2 _inst_3 _inst_1 f) (fun (e : Trivialization.{u2, u3, u1} X F E _inst_2 _inst_3 _inst_1 f) => Membership.Mem.{u2, u2} X (Set.{u2} X) (Set.hasMem.{u2} X) x (Trivialization.baseSet.{u2, u3, u1} X F E _inst_2 _inst_3 _inst_1 f e))) -> (IsCoveringMap.{u1, u2} E X _inst_1 _inst_2 f)
but is expected to have type
  forall {E : Type.{u2}} {X : Type.{u1}} [_inst_1 : TopologicalSpace.{u2} E] [_inst_2 : TopologicalSpace.{u1} X] {f : E -> X} {F : Type.{u3}} [_inst_3 : TopologicalSpace.{u3} F] [_inst_4 : DiscreteTopology.{u3} F _inst_3], (forall (x : X), Exists.{max (max (succ u2) (succ u1)) (succ u3)} (Trivialization.{u1, u3, u2} X F E _inst_2 _inst_3 _inst_1 f) (fun (e : Trivialization.{u1, u3, u2} X F E _inst_2 _inst_3 _inst_1 f) => Membership.mem.{u1, u1} X (Set.{u1} X) (Set.instMembershipSet.{u1} X) x (Trivialization.baseSet.{u1, u3, u2} X F E _inst_2 _inst_3 _inst_1 f e))) -> (IsCoveringMap.{u2, u1} E X _inst_1 _inst_2 f)
Case conversion may be inaccurate. Consider using '#align is_fiber_bundle.is_covering_map IsFiberBundle.isCoveringMapₓ'. -/
protected theorem IsFiberBundle.isCoveringMap {F : Type _} [TopologicalSpace F] [DiscreteTopology F]
    (hf : ∀ x : X, ∃ e : Trivialization F f, x ∈ e.baseSet) : IsCoveringMap f :=
  IsCoveringMap.mk f (fun x => F) (fun x => Classical.choose (hf x)) fun x =>
    Classical.choose_spec (hf x)
#align is_fiber_bundle.is_covering_map IsFiberBundle.isCoveringMap

/- warning: fiber_bundle.is_covering_map -> FiberBundle.isCoveringMap is a dubious translation:
lean 3 declaration is
  forall {X : Type.{u1}} [_inst_2 : TopologicalSpace.{u1} X] {F : Type.{u2}} {E : X -> Type.{u3}} [_inst_3 : TopologicalSpace.{u2} F] [_inst_4 : DiscreteTopology.{u2} F _inst_3] [_inst_5 : TopologicalSpace.{max u1 u3} (Bundle.TotalSpace.{u1, u3} X E)] [_inst_6 : forall (x : X), TopologicalSpace.{u3} (E x)] [hf : FiberBundle.{u1, u2, u3} X F _inst_2 _inst_3 E _inst_5 (fun (b : X) => _inst_6 b)], IsCoveringMap.{max u1 u3, u1} (Bundle.TotalSpace.{u1, u3} X E) X _inst_5 _inst_2 (Bundle.TotalSpace.proj.{u1, u3} X E)
but is expected to have type
  forall {X : Type.{u1}} [_inst_2 : TopologicalSpace.{u1} X] {F : Type.{u3}} {E : X -> Type.{u2}} [_inst_3 : TopologicalSpace.{u3} F] [_inst_4 : DiscreteTopology.{u3} F _inst_3] [_inst_5 : TopologicalSpace.{max u2 u1} (Bundle.TotalSpace.{u1, u2} X E)] [_inst_6 : forall (x : X), TopologicalSpace.{u2} (E x)] [hf : FiberBundle.{u1, u3, u2} X F _inst_2 _inst_3 E _inst_5 (fun (b : X) => _inst_6 b)], IsCoveringMap.{max u1 u2, u1} (Bundle.TotalSpace.{u1, u2} X E) X _inst_5 _inst_2 (Bundle.TotalSpace.proj.{u1, u2} X E)
Case conversion may be inaccurate. Consider using '#align fiber_bundle.is_covering_map FiberBundle.isCoveringMapₓ'. -/
protected theorem FiberBundle.isCoveringMap {F : Type _} {E : X → Type _} [TopologicalSpace F]
    [DiscreteTopology F] [TopologicalSpace (Bundle.TotalSpace E)] [∀ x, TopologicalSpace (E x)]
    [hf : FiberBundle F E] : IsCoveringMap (π E) :=
  IsFiberBundle.isCoveringMap fun x => ⟨trivializationAt F E x, mem_baseSet_trivializationAt F E x⟩
#align fiber_bundle.is_covering_map FiberBundle.isCoveringMap


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

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

/-!
# Normal field extensions

In this file we define normal field extensions and prove that for a finite extension, being normal
is the same as being a splitting field (`normal.of_is_splitting_field` and
`normal.exists_is_splitting_field`).

## Main Definitions

- `normal F K` where `K` is a field extension of `F`.
-/

noncomputable section

open BigOperators

open Classical Polynomial

open Polynomial IsScalarTower

variable (F K : Type _) [Field F] [Field K] [Algebra F K]

/-- Typeclass for normal field extension: `K` is a normal extension of `F` iff the minimal
polynomial of every element `x` in `K` splits in `K`, i.e. every conjugate of `x` is in `K`. -/
class Normal : Prop where
  is_algebraic' : Algebra.IsAlgebraic F K
  splits' (x : K) : Splits (algebraMap F K) (minpoly F x)
#align normal Normal

variable {F K}

theorem Normal.isAlgebraic (h : Normal F K) (x : K) : IsAlgebraic F x :=
  Normal.is_algebraic' x
#align normal.is_algebraic Normal.isAlgebraic

theorem Normal.isIntegral (h : Normal F K) (x : K) : IsIntegral F x :=
  isAlgebraic_iff_isIntegral.mp (h.IsAlgebraic x)
#align normal.is_integral Normal.isIntegral

theorem Normal.splits (h : Normal F K) (x : K) : Splits (algebraMap F K) (minpoly F x) :=
  Normal.splits' x
#align normal.splits Normal.splits

theorem normal_iff : Normal F K ↔ ∀ x : K, IsIntegral F x ∧ Splits (algebraMap F K) (minpoly F x) :=
  ⟨fun h x => ⟨h.IsIntegral x, h.Splits x⟩, fun h =>
    ⟨fun x => (h x).1.IsAlgebraic F, fun x => (h x).2⟩⟩
#align normal_iff normal_iff

theorem Normal.out : Normal F K → ∀ x : K, IsIntegral F x ∧ Splits (algebraMap F K) (minpoly F x) :=
  normal_iff.1
#align normal.out Normal.out

variable (F K)

instance normal_self : Normal F F :=
  ⟨fun x => isIntegral_algebraMap.IsAlgebraic F, fun x =>
    (minpoly.eq_x_sub_C' x).symm ▸ splits_X_sub_C _⟩
#align normal_self normal_self

variable {K}

variable (K)

theorem Normal.exists_isSplittingField [h : Normal F K] [FiniteDimensional F K] :
    ∃ p : F[X], IsSplittingField F K p :=
  by
  let s := Basis.ofVectorSpace F K
  refine'
    ⟨∏ x, minpoly F (s x), splits_prod _ fun x hx => h.splits (s x),
      subalgebra.to_submodule.injective _⟩
  rw [Algebra.top_toSubmodule, eq_top_iff, ← s.span_eq, Submodule.span_le, Set.range_subset_iff]
  refine' fun x =>
    Algebra.subset_adjoin
      (multiset.mem_to_finset.mpr <|
        (mem_roots <|
              mt (Polynomial.map_eq_zero <| algebraMap F K).1 <|
                Finset.prod_ne_zero_iff.2 fun x hx => _).2
          _)
  · exact minpoly.ne_zero (h.is_integral (s x))
  rw [is_root.def, eval_map, ← aeval_def, AlgHom.map_prod]
  exact Finset.prod_eq_zero (Finset.mem_univ _) (minpoly.aeval _ _)
#align normal.exists_is_splitting_field Normal.exists_isSplittingField

section NormalTower

variable (E : Type _) [Field E] [Algebra F E] [Algebra K E] [IsScalarTower F K E]

theorem Normal.tower_top_of_normal [h : Normal F E] : Normal K E :=
  normal_iff.2 fun x => by
    cases' h.out x with hx hhx
    rw [algebra_map_eq F K E] at hhx
    exact
      ⟨isIntegral_of_isScalarTower hx,
        Polynomial.splits_of_splits_of_dvd (algebraMap K E)
          (Polynomial.map_ne_zero (minpoly.ne_zero hx))
          ((Polynomial.splits_map_iff (algebraMap F K) (algebraMap K E)).mpr hhx)
          (minpoly.dvd_map_of_isScalarTower F K x)⟩
#align normal.tower_top_of_normal Normal.tower_top_of_normal

theorem AlgHom.normal_bijective [h : Normal F E] (ϕ : E →ₐ[F] K) : Function.Bijective ϕ :=
  ⟨ϕ.toRingHom.Injective, fun x =>
    by
    letI : Algebra E K := ϕ.to_ring_hom.to_algebra
    obtain ⟨h1, h2⟩ := h.out (algebraMap K E x)
    cases'
      minpoly.mem_range_of_degree_eq_one E x
        (h2.def.resolve_left (minpoly.ne_zero h1)
          (minpoly.irreducible
            (isIntegral_of_isScalarTower
              ((isIntegral_algebraMap_iff (algebraMap K E).Injective).mp h1)))
          (minpoly.dvd E x
            ((algebraMap K E).Injective
              (by
                rw [RingHom.map_zero, aeval_map_algebra_map, ← aeval_algebra_map_apply]
                exact minpoly.aeval F (algebraMap K E x))))) with
      y hy
    exact ⟨y, hy⟩⟩
#align alg_hom.normal_bijective AlgHom.normal_bijective

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

theorem Normal.of_algEquiv [h : Normal F E] (f : E ≃ₐ[F] E') : Normal F E' :=
  normal_iff.2 fun x => by
    cases' h.out (f.symm x) with hx hhx
    have H := map_isIntegral f.to_alg_hom hx
    rw [AlgEquiv.toAlgHom_eq_coe, AlgEquiv.coe_algHom, AlgEquiv.apply_symm_apply] at H
    use H
    apply Polynomial.splits_of_splits_of_dvd (algebraMap F E') (minpoly.ne_zero hx)
    · rw [← AlgHom.comp_algebraMap f.to_alg_hom]
      exact Polynomial.splits_comp_of_splits (algebraMap F E) f.to_alg_hom.to_ring_hom hhx
    · apply minpoly.dvd _ _
      rw [← AddEquiv.map_eq_zero_iff f.symm.to_add_equiv]
      exact
        Eq.trans (Polynomial.aeval_algHom_apply f.symm.to_alg_hom x (minpoly F (f.symm x))).symm
          (minpoly.aeval _ _)
#align normal.of_alg_equiv Normal.of_algEquiv

theorem AlgEquiv.transfer_normal (f : E ≃ₐ[F] E') : Normal F E ↔ Normal F E' :=
  ⟨fun h => Normal.of_algEquiv f, fun h => Normal.of_algEquiv f.symm⟩
#align alg_equiv.transfer_normal AlgEquiv.transfer_normal

theorem Normal.of_isSplittingField (p : F[X]) [hFEp : IsSplittingField F E p] : Normal F E :=
  by
  by_cases hp : p = 0
  · have : is_splitting_field F F p := by
      rw [hp]
      exact ⟨splits_zero _, Subsingleton.elim _ _⟩
    exact
      (AlgEquiv.transfer_normal
            ((is_splitting_field.alg_equiv F p).trans (is_splitting_field.alg_equiv E p).symm)).mp
        (normal_self F)
  refine' normal_iff.2 fun x => _
  haveI hFE : FiniteDimensional F E := is_splitting_field.finite_dimensional E p
  have Hx : IsIntegral F x := isIntegral_of_noetherian (IsNoetherian.iff_fg.2 hFE) x
  refine' ⟨Hx, Or.inr _⟩
  rintro q q_irred ⟨r, hr⟩
  let D := AdjoinRoot q
  haveI := Fact.mk q_irred
  let pbED := AdjoinRoot.powerBasis q_irred.ne_zero
  haveI : FiniteDimensional E D := PowerBasis.finiteDimensional pbED
  have finrankED : FiniteDimensional.finrank E D = q.nat_degree := PowerBasis.finrank pbED
  letI : Algebra F D := RingHom.toAlgebra ((algebraMap E D).comp (algebraMap F E))
  haveI : IsScalarTower F E D := of_algebra_map_eq fun _ => rfl
  haveI : FiniteDimensional F D := FiniteDimensional.trans F E D
  suffices Nonempty (D →ₐ[F] E) by
    cases' this with ϕ
    rw [← WithBot.coe_one, degree_eq_iff_nat_degree_eq q_irred.ne_zero, ← finrankED]
    have nat_lemma : ∀ a b c : ℕ, a * b = c → c ≤ a → 0 < c → b = 1 :=
      by
      intro a b c h1 h2 h3
      nlinarith
    exact
      nat_lemma _ _ _ (FiniteDimensional.finrank_mul_finrank F E D)
        (LinearMap.finrank_le_finrank_of_injective
          (show Function.Injective ϕ.to_linear_map from ϕ.to_ring_hom.injective))
        FiniteDimensional.finrank_pos
  let C := AdjoinRoot (minpoly F x)
  haveI Hx_irred := Fact.mk (minpoly.irreducible Hx)
  letI : Algebra C D :=
    RingHom.toAlgebra
      (AdjoinRoot.lift (algebraMap F D) (AdjoinRoot.root q)
        (by
          rw [algebra_map_eq F E D, ← eval₂_map, hr, AdjoinRoot.algebraMap_eq, eval₂_mul,
            AdjoinRoot.eval₂_root, MulZeroClass.zero_mul]))
  letI : Algebra C E := RingHom.toAlgebra (AdjoinRoot.lift (algebraMap F E) x (minpoly.aeval F x))
  haveI : IsScalarTower F C D := of_algebra_map_eq fun x => (AdjoinRoot.lift_of _).symm
  haveI : IsScalarTower F C E := of_algebra_map_eq fun x => (AdjoinRoot.lift_of _).symm
  suffices Nonempty (D →ₐ[C] E) by exact Nonempty.map (AlgHom.restrictScalars F) this
  let S : Set D := ((p.map (algebraMap F E)).roots.map (algebraMap E D)).toFinset
  suffices ⊤ ≤ IntermediateField.adjoin C S
    by
    refine' IntermediateField.algHom_mk_adjoin_splits' (top_le_iff.mp this) fun y hy => _
    rcases multiset.mem_map.mp (multiset.mem_to_finset.mp hy) with ⟨z, hz1, hz2⟩
    have Hz : IsIntegral F z := isIntegral_of_noetherian (IsNoetherian.iff_fg.2 hFE) z
    use
      show IsIntegral C y from
        isIntegral_of_noetherian (IsNoetherian.iff_fg.2 (FiniteDimensional.right F C D)) y
    apply splits_of_splits_of_dvd (algebraMap C E) (map_ne_zero (minpoly.ne_zero Hz))
    · rw [splits_map_iff, ← algebra_map_eq F C E]
      exact
        splits_of_splits_of_dvd _ hp hFEp.splits
          (minpoly.dvd F z (Eq.trans (eval₂_eq_eval_map _) ((mem_roots (map_ne_zero hp)).mp hz1)))
    · apply minpoly.dvd
      rw [← hz2, aeval_def, eval₂_map, ← algebra_map_eq F C D, algebra_map_eq F E D, ← hom_eval₂, ←
        aeval_def, minpoly.aeval F z, RingHom.map_zero]
  rw [← IntermediateField.toSubalgebra_le_toSubalgebra, IntermediateField.top_toSubalgebra]
  apply ge_trans (IntermediateField.algebra_adjoin_le_adjoin C S)
  suffices
    (Algebra.adjoin C S).restrictScalars F =
      (Algebra.adjoin E {AdjoinRoot.root q}).restrictScalars F
    by
    rw [AdjoinRoot.adjoinRoot_eq_top, Subalgebra.restrictScalars_top, ←
      @Subalgebra.restrictScalars_top F C] at this
    exact top_le_iff.mpr (Subalgebra.restrictScalars_injective F this)
  dsimp only [S]
  rw [← Finset.image_toFinset, Finset.coe_image]
  apply
    Eq.trans
      (Algebra.adjoin_res_eq_adjoin_res F E C D hFEp.adjoin_roots AdjoinRoot.adjoinRoot_eq_top)
  rw [Set.image_singleton, RingHom.algebraMap_toAlgebra, AdjoinRoot.lift_root]
#align normal.of_is_splitting_field Normal.of_isSplittingField

instance (p : F[X]) : Normal F p.SplittingField :=
  Normal.of_isSplittingField p

end NormalTower

namespace IntermediateField

/-- A compositum of normal extensions is normal -/
instance normal_supᵢ {ι : Type _} (t : ι → IntermediateField F K) [h : ∀ i, Normal F (t i)] :
    Normal F (⨆ i, t i : IntermediateField F K) :=
  by
  refine' ⟨is_algebraic_supr fun i => (h i).1, fun x => _⟩
  obtain ⟨s, hx⟩ := exists_finset_of_mem_supr'' (fun i => (h i).1) x.2
  let E : IntermediateField F K := ⨆ i ∈ s, adjoin F ((minpoly F (i.2 : _)).rootSet K)
  have hF : Normal F E :=
    by
    apply Normal.of_isSplittingField (∏ i in s, minpoly F i.2)
    refine' is_splitting_field_supr _ fun i hi => adjoin_root_set_is_splitting_field _
    · exact finset.prod_ne_zero_iff.mpr fun i hi => minpoly.ne_zero ((h i.1).IsIntegral i.2)
    · exact Polynomial.splits_comp_of_splits _ (algebraMap (t i.1) K) ((h i.1).Splits i.2)
  have hE : E ≤ ⨆ i, t i :=
    by
    refine' supᵢ_le fun i => supᵢ_le fun hi => le_supᵢ_of_le i.1 _
    rw [adjoin_le_iff, ← image_root_set ((h i.1).Splits i.2) (t i.1).val]
    exact fun _ ⟨a, _, h⟩ => h ▸ a.2
  have := hF.splits ⟨x, hx⟩
  rw [minpoly_eq, Subtype.coe_mk, ← minpoly_eq] at this
  exact Polynomial.splits_comp_of_splits _ (inclusion hE).toRingHom this
#align intermediate_field.normal_supr IntermediateField.normal_supᵢ

variable {F K} {L : Type _} [Field L] [Algebra F L] [Algebra K L] [IsScalarTower F K L]

@[simp]
theorem restrictScalars_normal {E : IntermediateField K L} :
    Normal F (E.restrictScalars F) ↔ Normal F E :=
  Iff.rfl
#align intermediate_field.restrict_scalars_normal IntermediateField.restrictScalars_normal

end IntermediateField

variable {F} {K} {K₁ K₂ K₃ : Type _} [Field K₁] [Field K₂] [Field K₃] [Algebra F K₁] [Algebra F K₂]
  [Algebra F K₃] (ϕ : K₁ →ₐ[F] K₂) (χ : K₁ ≃ₐ[F] K₂) (ψ : K₂ →ₐ[F] K₃) (ω : K₂ ≃ₐ[F] K₃)

section Restrict

variable (E : Type _) [Field E] [Algebra F E] [Algebra E K₁] [Algebra E K₂] [Algebra E K₃]
  [IsScalarTower F E K₁] [IsScalarTower F E K₂] [IsScalarTower F E K₃]

/-- Restrict algebra homomorphism to image of normal subfield -/
def AlgHom.restrictNormalAux [h : Normal F E] :
    (toAlgHom F E K₁).range →ₐ[F] (toAlgHom F E K₂).range
    where
  toFun x :=
    ⟨ϕ x, by
      suffices (to_alg_hom F E K₁).range.map ϕ ≤ _ by exact this ⟨x, Subtype.mem x, rfl⟩
      rintro x ⟨y, ⟨z, hy⟩, hx⟩
      rw [← hx, ← hy]
      apply minpoly.mem_range_of_degree_eq_one E
      refine'
        Or.resolve_left (h.splits z).def (minpoly.ne_zero (h.is_integral z)) (minpoly.irreducible _)
          (minpoly.dvd E _ (by simp [aeval_alg_hom_apply]))
      simp only [AlgHom.toRingHom_eq_coe, AlgHom.coe_toRingHom]
      suffices IsIntegral F _ by exact isIntegral_of_isScalarTower this
      exact map_isIntegral ϕ (map_isIntegral (to_alg_hom F E K₁) (h.is_integral z))⟩
  map_zero' := Subtype.ext ϕ.map_zero
  map_one' := Subtype.ext ϕ.map_one
  map_add' x y := Subtype.ext (ϕ.map_add x y)
  map_mul' x y := Subtype.ext (ϕ.map_mul x y)
  commutes' x := Subtype.ext (ϕ.commutes x)
#align alg_hom.restrict_normal_aux AlgHom.restrictNormalAux

/-- Restrict algebra homomorphism to normal subfield -/
def AlgHom.restrictNormal [Normal F E] : E →ₐ[F] E :=
  ((AlgEquiv.ofInjectiveField (IsScalarTower.toAlgHom F E K₂)).symm.toAlgHom.comp
        (ϕ.restrictNormalAux E)).comp
    (AlgEquiv.ofInjectiveField (IsScalarTower.toAlgHom F E K₁)).toAlgHom
#align alg_hom.restrict_normal AlgHom.restrictNormal

/-- Restrict algebra homomorphism to normal subfield (`alg_equiv` version) -/
def AlgHom.restrictNormal' [Normal F E] : E ≃ₐ[F] E :=
  AlgEquiv.ofBijective (AlgHom.restrictNormal ϕ E) (AlgHom.normal_bijective F E E _)
#align alg_hom.restrict_normal' AlgHom.restrictNormal'

@[simp]
theorem AlgHom.restrictNormal_commutes [Normal F E] (x : E) :
    algebraMap E K₂ (ϕ.restrictNormal E x) = ϕ (algebraMap E K₁ x) :=
  Subtype.ext_iff.mp
    (AlgEquiv.apply_symm_apply (AlgEquiv.ofInjectiveField (IsScalarTower.toAlgHom F E K₂))
      (ϕ.restrictNormalAux E ⟨IsScalarTower.toAlgHom F E K₁ x, x, rfl⟩))
#align alg_hom.restrict_normal_commutes AlgHom.restrictNormal_commutes

theorem AlgHom.restrictNormal_comp [Normal F E] :
    (ψ.restrictNormal E).comp (ϕ.restrictNormal E) = (ψ.comp ϕ).restrictNormal E :=
  AlgHom.ext fun _ =>
    (algebraMap E K₃).Injective (by simp only [AlgHom.comp_apply, AlgHom.restrictNormal_commutes])
#align alg_hom.restrict_normal_comp AlgHom.restrictNormal_comp

/-- Restrict algebra isomorphism to a normal subfield -/
def AlgEquiv.restrictNormal [h : Normal F E] : E ≃ₐ[F] E :=
  AlgHom.restrictNormal' χ.toAlgHom E
#align alg_equiv.restrict_normal AlgEquiv.restrictNormal

@[simp]
theorem AlgEquiv.restrictNormal_commutes [Normal F E] (x : E) :
    algebraMap E K₂ (χ.restrictNormal E x) = χ (algebraMap E K₁ x) :=
  χ.toAlgHom.restrictNormal_commutes E x
#align alg_equiv.restrict_normal_commutes AlgEquiv.restrictNormal_commutes

theorem AlgEquiv.restrictNormal_trans [Normal F E] :
    (χ.trans ω).restrictNormal E = (χ.restrictNormal E).trans (ω.restrictNormal E) :=
  AlgEquiv.ext fun _ =>
    (algebraMap E K₃).Injective
      (by simp only [AlgEquiv.trans_apply, AlgEquiv.restrictNormal_commutes])
#align alg_equiv.restrict_normal_trans AlgEquiv.restrictNormal_trans

/-- Restriction to an normal subfield as a group homomorphism -/
def AlgEquiv.restrictNormalHom [Normal F E] : (K₁ ≃ₐ[F] K₁) →* E ≃ₐ[F] E :=
  MonoidHom.mk' (fun χ => χ.restrictNormal E) fun ω χ => χ.restrictNormal_trans ω E
#align alg_equiv.restrict_normal_hom AlgEquiv.restrictNormalHom

variable (F K₁ E)

/-- If `K₁/E/F` is a tower of fields with `E/F` normal then `normal.alg_hom_equiv_aut` is an
 equivalence. -/
@[simps]
def Normal.algHomEquivAut [Normal F E] : (E →ₐ[F] K₁) ≃ E ≃ₐ[F] E
    where
  toFun σ := AlgHom.restrictNormal' σ E
  invFun σ := (IsScalarTower.toAlgHom F E K₁).comp σ.toAlgHom
  left_inv σ := by
    ext
    simp [AlgHom.restrictNormal']
  right_inv σ := by
    ext
    simp only [AlgHom.restrictNormal', AlgEquiv.toAlgHom_eq_coe, AlgEquiv.coe_ofBijective]
    apply NoZeroSMulDivisors.algebraMap_injective E K₁
    rw [AlgHom.restrictNormal_commutes]
    simp
#align normal.alg_hom_equiv_aut Normal.algHomEquivAut

end Restrict

section lift

variable {F} {K₁ K₂} (E : Type _) [Field E] [Algebra F E] [Algebra K₁ E] [Algebra K₂ E]
  [IsScalarTower F K₁ E] [IsScalarTower F K₂ E]

/-- If `E/Kᵢ/F` are towers of fields with `E/F` normal then we can lift
  an algebra homomorphism `ϕ : K₁ →ₐ[F] K₂` to `ϕ.lift_normal E : E →ₐ[F] E`. -/
noncomputable def AlgHom.liftNormal [h : Normal F E] : E →ₐ[F] E :=
  @AlgHom.restrictScalars F K₁ E E _ _ _ _ _ _
      ((IsScalarTower.toAlgHom F K₂ E).comp ϕ).toRingHom.toAlgebra _ _ _ _ <|
    Nonempty.some <|
      @IntermediateField.algHom_mk_adjoin_splits' _ _ _ _ _ _ _
        ((IsScalarTower.toAlgHom F K₂ E).comp ϕ).toRingHom.toAlgebra _
        (IntermediateField.adjoin_univ _ _) fun x hx =>
        ⟨isIntegral_of_isScalarTower (h.out x).1,
          splits_of_splits_of_dvd _ (map_ne_zero (minpoly.ne_zero (h.out x).1))
            (by
              rw [splits_map_iff, ← IsScalarTower.algebraMap_eq]
              exact (h.out x).2)
            (minpoly.dvd_map_of_isScalarTower F K₁ x)⟩
#align alg_hom.lift_normal AlgHom.liftNormal

@[simp]
theorem AlgHom.liftNormal_commutes [Normal F E] (x : K₁) :
    ϕ.liftNormal E (algebraMap K₁ E x) = algebraMap K₂ E (ϕ x) := by
  apply @AlgHom.commutes K₁ E E _ _ _ _
#align alg_hom.lift_normal_commutes AlgHom.liftNormal_commutes

@[simp]
theorem AlgHom.restrict_liftNormal (ϕ : K₁ →ₐ[F] K₁) [Normal F K₁] [Normal F E] :
    (ϕ.liftNormal E).restrictNormal K₁ = ϕ :=
  AlgHom.ext fun x =>
    (algebraMap K₁ E).Injective
      (Eq.trans (AlgHom.restrictNormal_commutes _ K₁ x) (ϕ.liftNormal_commutes E x))
#align alg_hom.restrict_lift_normal AlgHom.restrict_liftNormal

/-- If `E/Kᵢ/F` are towers of fields with `E/F` normal then we can lift
  an algebra isomorphism `ϕ : K₁ ≃ₐ[F] K₂` to `ϕ.lift_normal E : E ≃ₐ[F] E`. -/
noncomputable def AlgEquiv.liftNormal [Normal F E] : E ≃ₐ[F] E :=
  AlgEquiv.ofBijective (χ.toAlgHom.liftNormal E) (AlgHom.normal_bijective F E E _)
#align alg_equiv.lift_normal AlgEquiv.liftNormal

@[simp]
theorem AlgEquiv.liftNormal_commutes [Normal F E] (x : K₁) :
    χ.liftNormal E (algebraMap K₁ E x) = algebraMap K₂ E (χ x) :=
  χ.toAlgHom.liftNormal_commutes E x
#align alg_equiv.lift_normal_commutes AlgEquiv.liftNormal_commutes

@[simp]
theorem AlgEquiv.restrict_liftNormal (χ : K₁ ≃ₐ[F] K₁) [Normal F K₁] [Normal F E] :
    (χ.liftNormal E).restrictNormal K₁ = χ :=
  AlgEquiv.ext fun x =>
    (algebraMap K₁ E).Injective
      (Eq.trans (AlgEquiv.restrictNormal_commutes _ K₁ x) (χ.liftNormal_commutes E x))
#align alg_equiv.restrict_lift_normal AlgEquiv.restrict_liftNormal

theorem AlgEquiv.restrictNormalHom_surjective [Normal F K₁] [Normal F E] :
    Function.Surjective (AlgEquiv.restrictNormalHom K₁ : (E ≃ₐ[F] E) → K₁ ≃ₐ[F] K₁) := fun χ =>
  ⟨χ.liftNormal E, χ.restrict_liftNormal E⟩
#align alg_equiv.restrict_normal_hom_surjective AlgEquiv.restrictNormalHom_surjective

variable (F) (K₁) (E)

theorem isSolvable_of_isScalarTower [Normal F K₁] [h1 : IsSolvable (K₁ ≃ₐ[F] K₁)]
    [h2 : IsSolvable (E ≃ₐ[K₁] E)] : IsSolvable (E ≃ₐ[F] E) :=
  by
  let f : (E ≃ₐ[K₁] E) →* E ≃ₐ[F] E :=
    { toFun := fun ϕ =>
        AlgEquiv.ofAlgHom (ϕ.to_alg_hom.restrict_scalars F) (ϕ.symm.to_alg_hom.restrict_scalars F)
          (AlgHom.ext fun x => ϕ.apply_symm_apply x) (AlgHom.ext fun x => ϕ.symm_apply_apply x)
      map_one' := AlgEquiv.ext fun _ => rfl
      map_mul' := fun _ _ => AlgEquiv.ext fun _ => rfl }
  refine'
    solvable_of_ker_le_range f (AlgEquiv.restrictNormalHom K₁) fun ϕ hϕ =>
      ⟨{ ϕ with commutes' := fun x => _ }, AlgEquiv.ext fun _ => rfl⟩
  exact Eq.trans (ϕ.restrict_normal_commutes K₁ x).symm (congr_arg _ (alg_equiv.ext_iff.mp hϕ x))
#align is_solvable_of_is_scalar_tower isSolvable_of_isScalarTower

end lift

section normalClosure

open IntermediateField

variable (F K) (L : Type _) [Field L] [Algebra F L] [Algebra K L] [IsScalarTower F K L]

/-- The normal closure of `K` in `L`. -/
noncomputable def normalClosure : IntermediateField K L :=
  { (⨆ f : K →ₐ[F] L, f.fieldRange).toSubfield with
    algebraMap_mem' := fun r =>
      le_supᵢ (fun f : K →ₐ[F] L => f.fieldRange) (IsScalarTower.toAlgHom F K L) ⟨r, rfl⟩ }
#align normal_closure normalClosure

namespace normalClosure

theorem restrictScalars_eq_supᵢ_adjoin [h : Normal F L] :
    (normalClosure F K L).restrictScalars F = ⨆ x : K, adjoin F ((minpoly F x).rootSet L) :=
  by
  refine' le_antisymm (supᵢ_le _) (supᵢ_le fun x => adjoin_le_iff.mpr fun y hy => _)
  · rintro f _ ⟨x, rfl⟩
    refine'
      le_supᵢ (fun x => adjoin F ((minpoly F x).rootSet L)) x
        (subset_adjoin F ((minpoly F x).rootSet L) _)
    rw [mem_root_set_of_ne, AlgHom.toRingHom_eq_coe, AlgHom.coe_toRingHom,
      Polynomial.aeval_algHom_apply, minpoly.aeval, map_zero]
    exact
      minpoly.ne_zero
        ((isIntegral_algebraMap_iff (algebraMap K L).Injective).mp
          (h.is_integral (algebraMap K L x)))
  · rw [Polynomial.rootSet, Finset.mem_coe, Multiset.mem_toFinset] at hy
    let g :=
      (alg_hom_adjoin_integral_equiv F
            ((isIntegral_algebraMap_iff (algebraMap K L).Injective).mp
              (h.is_integral (algebraMap K L x)))).symm
        ⟨y, hy⟩
    refine'
      le_supᵢ (fun f : K →ₐ[F] L => f.fieldRange)
        ((g.lift_normal L).comp (IsScalarTower.toAlgHom F K L))
        ⟨x, (g.lift_normal_commutes L (adjoin_simple.gen F x)).trans _⟩
    rw [Algebra.id.map_eq_id, RingHom.id_apply]
    apply PowerBasis.lift_gen
#align normal_closure.restrict_scalars_eq_supr_adjoin normalClosure.restrictScalars_eq_supᵢ_adjoin

instance normal [h : Normal F L] : Normal F (normalClosure F K L) :=
  by
  let ϕ := algebraMap K L
  rw [← IntermediateField.restrictScalars_normal, restrict_scalars_eq_supr_adjoin]
  apply IntermediateField.normal_supᵢ F L _
  intro x
  apply Normal.of_isSplittingField (minpoly F x)
  exact
    adjoin_root_set_is_splitting_field
      ((minpoly.eq_of_algebraMap_eq ϕ.injective
            ((isIntegral_algebraMap_iff ϕ.injective).mp (h.is_integral (ϕ x))) rfl).symm ▸
        h.splits _)
#align normal_closure.normal normalClosure.normal

instance is_finiteDimensional [FiniteDimensional F K] : FiniteDimensional F (normalClosure F K L) :=
  by
  haveI : ∀ f : K →ₐ[F] L, FiniteDimensional F f.fieldRange := fun f =>
    f.to_linear_map.finite_dimensional_range
  apply IntermediateField.finiteDimensional_supᵢ_of_finite
#align normal_closure.is_finite_dimensional normalClosure.is_finiteDimensional

end normalClosure

end normalClosure


/-
Copyright (c) 2022 Adam Topaz. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Adam Topaz
-/
import category_theory.abelian.exact
import category_theory.abelian.pseudoelements

/-!

The object `homology f g w`, where `w : f ≫ g = 0`, can be identified with either a
cokernel or a kernel. The isomorphism with a cokernel is `homology_iso_cokernel_lift`, which
was obtained elsewhere. In the case of an abelian category, this file shows the isomorphism
with a kernel as well.

We use these isomorphisms to obtain the analogous api for `homology`:
- `homology.ι` is the map from `homology f g w` into the cokernel of `f`.
- `homology.π'` is the map from `kernel g` to `homology f g w`.
- `homology.desc'` constructs a morphism from `homology f g w`, when it is viewed as a cokernel.
- `homology.lift` constructs a morphism to `homology f g w`, when it is viewed as a kernel.
- Various small lemmas are proved as well, mimicking the API for (co)kernels.
With these definitions and lemmas, the isomorphisms between homology and a (co)kernel need not
be used directly.
-/

open category_theory.limits
open category_theory

noncomputable theory

universes v u
variables {A : Type u} [category.{v} A] [abelian A]

variables {X Y Z : A} (f : X ⟶ Y) (g : Y ⟶ Z) (w : f ≫ g = 0)

namespace category_theory.abelian

/-- The cokernel of `kernel.lift g f w`. This is isomorphic to `homology f g w`.
  See `homology_iso_cokernel_lift`. -/
abbreviation homology_c : A :=
cokernel (kernel.lift g f w)

/-- The kernel of `cokernel.desc f g w`. This is isomorphic to `homology f g w`.
  See `homology_iso_kernel_desc`. -/
abbreviation homology_k : A :=
kernel (cokernel.desc f g w)

/-- The canonical map from `homology_c` to `homology_k`.
  This is an isomorphism, and it is used in obtaining the API for `homology f g w`
  in the bottom of this file. -/
abbreviation homology_c_to_k : homology_c f g w ⟶ homology_k f g w :=
cokernel.desc _ (kernel.lift _ (kernel.ι _ ≫ cokernel.π _) (by simp)) begin
  apply limits.equalizer.hom_ext,
  simp,
end

local attribute [instance] pseudoelement.hom_to_fun pseudoelement.has_zero

instance : mono (homology_c_to_k f g w) :=
begin
  apply pseudoelement.mono_of_zero_of_map_zero,
  intros a ha,
  obtain ⟨a,rfl⟩ := pseudoelement.pseudo_surjective_of_epi (cokernel.π (kernel.lift g f w)) a,
  apply_fun (kernel.ι (cokernel.desc f g w)) at ha,
  simp only [←pseudoelement.comp_apply, cokernel.π_desc,
    kernel.lift_ι, pseudoelement.apply_zero] at ha,
  simp only [pseudoelement.comp_apply] at ha,
  obtain ⟨b,hb⟩ : ∃ b, f b = _ := (pseudoelement.pseudo_exact_of_exact (exact_cokernel f)).2 _ ha,
  suffices : ∃ c, kernel.lift g f w c = a,
  { obtain ⟨c,rfl⟩ := this,
    simp [← pseudoelement.comp_apply] },
  use b,
  apply_fun kernel.ι g,
  swap, { apply pseudoelement.pseudo_injective_of_mono },
  simpa [← pseudoelement.comp_apply]
end

instance : epi (homology_c_to_k f g w) :=
begin
  apply pseudoelement.epi_of_pseudo_surjective,
  intros a,
  let b := kernel.ι (cokernel.desc f g w) a,
  obtain ⟨c,hc⟩ : ∃ c, cokernel.π f c = b,
    apply pseudoelement.pseudo_surjective_of_epi (cokernel.π f),
  have : g c = 0,
  { dsimp [b] at hc,
    rw [(show g = cokernel.π f ≫ cokernel.desc f g w, by simp), pseudoelement.comp_apply, hc],
    simp [← pseudoelement.comp_apply] },
  obtain ⟨d,hd⟩ : ∃ d, kernel.ι g d = c,
  { apply (pseudoelement.pseudo_exact_of_exact exact_kernel_ι).2 _ this },
  use cokernel.π (kernel.lift g f w) d,
  apply_fun kernel.ι (cokernel.desc f g w),
  swap, { apply pseudoelement.pseudo_injective_of_mono },
  simp only [←pseudoelement.comp_apply, cokernel.π_desc, kernel.lift_ι],
  simp only [pseudoelement.comp_apply, hd, hc],
end

instance (w : f ≫ g = 0) : is_iso (homology_c_to_k f g w) := is_iso_of_mono_of_epi _

end category_theory.abelian

/-- The homology associated to `f` and `g` is isomorphic to a kernel. -/
def homology_iso_kernel_desc : homology f g w ≅ kernel (cokernel.desc f g w) :=
homology_iso_cokernel_lift _ _ _ ≪≫ as_iso (category_theory.abelian.homology_c_to_k _ _ _)

namespace homology

-- `homology.π` is taken
/-- The canonical map from the kernel of `g` to the homology of `f` and `g`. -/
def π' : kernel g ⟶ homology f g w :=
cokernel.π _ ≫ (homology_iso_cokernel_lift _ _ _).inv

/-- The canonical map from the homology of `f` and `g` to the cokernel of `f`. -/
def ι : homology f g w ⟶ cokernel f :=
(homology_iso_kernel_desc _ _ _).hom ≫ kernel.ι _

/-- Obtain a morphism from the homology, given a morphism from the kernel. -/
def desc' {W : A} (e : kernel g ⟶ W) (he : kernel.lift g f w ≫ e = 0) :
  homology f g w ⟶ W :=
(homology_iso_cokernel_lift _ _ _).hom ≫ cokernel.desc _ e he

/-- Obtain a moprhism to the homology, given a morphism to the kernel. -/
def lift {W : A} (e : W ⟶ cokernel f) (he : e ≫ cokernel.desc f g w = 0) :
  W ⟶ homology f g w :=
kernel.lift _ e he ≫ (homology_iso_kernel_desc _ _ _).inv

@[simp, reassoc]
lemma π'_desc' {W : A} (e : kernel g ⟶ W) (he : kernel.lift g f w ≫ e = 0) :
  π' f g w ≫ desc' f g w e he = e :=
by { dsimp [π', desc'], simp }

@[simp, reassoc]
lemma lift_ι {W : A} (e : W ⟶ cokernel f) (he : e ≫ cokernel.desc f g w = 0) :
  lift f g w e he ≫ ι _ _ _ = e :=
by { dsimp [ι, lift], simp }

@[simp, reassoc]
lemma condition_π' : kernel.lift g f w ≫ π' f g w = 0 :=
by { dsimp [π'], simp }

@[simp, reassoc]
lemma condition_ι : ι f g w ≫ cokernel.desc f g w = 0 :=
by { dsimp [ι], simp }

@[ext]
lemma hom_from_ext {W : A} (a b : homology f g w ⟶ W)
  (h : π' f g w ≫ a = π' f g w ≫ b) : a = b :=
begin
  dsimp [π'] at h,
  apply_fun (λ e, (homology_iso_cokernel_lift f g w).inv ≫ e),
  swap,
  { intros i j hh,
    apply_fun (λ e, (homology_iso_cokernel_lift f g w).hom ≫ e) at hh,
    simpa using hh },
  simp only [category.assoc] at h,
  exact coequalizer.hom_ext h,
end

@[ext]
lemma hom_to_ext {W : A} (a b : W ⟶ homology f g w)
  (h : a ≫ ι f g w = b ≫ ι f g w) : a = b :=
begin
  dsimp [ι] at h,
  apply_fun (λ e, e ≫ (homology_iso_kernel_desc f g w).hom),
  swap,
  { intros i j hh,
    apply_fun (λ e, e ≫ (homology_iso_kernel_desc f g w).inv) at hh,
    simpa using hh },
  simp only [← category.assoc] at h,
  exact equalizer.hom_ext h,
end

@[simp, reassoc]
lemma π'_ι : π' f g w ≫ ι f g w = kernel.ι _ ≫ cokernel.π _ :=
by { dsimp [π', ι, homology_iso_kernel_desc], simp }

@[simp, reassoc]
lemma π'_eq_π : (kernel_subobject_iso _).hom ≫ π' f g w = π _ _ _ :=
begin
  dsimp [π', homology_iso_cokernel_lift],
  simp only [← category.assoc],
  rw iso.comp_inv_eq,
  dsimp [π, homology_iso_cokernel_image_to_kernel'],
  simp,
end

section

variables {X' Y' Z' : A} (f' : X' ⟶ Y') (g' : Y' ⟶ Z') (w' : f' ≫ g' = 0)

@[simp, reassoc]
lemma π'_map (α β h) :
  π' _ _ _ ≫ map w w' α β h = kernel.map _ _ α.right β.right (by simp [h,β.w.symm]) ≫ π' _ _ _ :=
begin
  apply_fun (λ e, (kernel_subobject_iso _).hom ≫ e),
  swap,
  { intros i j hh,
    apply_fun (λ e, (kernel_subobject_iso _).inv ≫ e) at hh,
    simpa using hh },
  dsimp [map],
  simp only [π'_eq_π_assoc],
  dsimp [π],
  simp only [cokernel.π_desc],
  rw [← iso.inv_comp_eq, ← category.assoc],
  have : (limits.kernel_subobject_iso g).inv ≫ limits.kernel_subobject_map β =
    kernel.map _ _ β.left β.right β.w.symm ≫ (kernel_subobject_iso _).inv,
  { rw [iso.inv_comp_eq, ← category.assoc, iso.eq_comp_inv],
    ext,
    dsimp,
    simp },
  rw this,
  simp only [category.assoc],
  dsimp [π', homology_iso_cokernel_lift],
  simp only [cokernel_iso_of_eq_inv_comp_desc, cokernel.π_desc_assoc],
  congr' 1,
  { congr, exact h.symm },
  { rw [iso.inv_comp_eq, ← category.assoc, iso.eq_comp_inv],
    dsimp [homology_iso_cokernel_image_to_kernel'],
    simp }
end

lemma map_eq_desc'_lift_left (α β h) : map w w' α β h =
  homology.desc' _ _ _ (homology.lift _ _ _ (kernel.ι _ ≫ β.left ≫ cokernel.π _) (by simp))
  (by { ext, simp only [←h, category.assoc, zero_comp, lift_ι, kernel.lift_ι_assoc],
    erw ← reassoc_of α.w, simp } ) :=
begin
  apply homology.hom_from_ext,
  simp only [π'_map, π'_desc'],
  dsimp [π', lift],
  rw iso.eq_comp_inv,
  dsimp [homology_iso_kernel_desc],
  ext,
  simp [h],
end

lemma map_eq_lift_desc'_left (α β h) : map w w' α β h =
  homology.lift _ _ _ (homology.desc' _ _ _ (kernel.ι _ ≫ β.left ≫ cokernel.π _)
  (by { simp only [kernel.lift_ι_assoc, ← h], erw ← reassoc_of α.w, simp }))
  (by { ext, simp }) :=
by { rw map_eq_desc'_lift_left, ext, simp }

lemma map_eq_desc'_lift_right (α β h) : map w w' α β h =
  homology.desc' _ _ _ (homology.lift _ _ _ (kernel.ι _ ≫ α.right ≫ cokernel.π _) (by simp [h]))
  (by { ext, simp only [category.assoc, zero_comp, lift_ι, kernel.lift_ι_assoc],
    erw ← reassoc_of α.w, simp } ) :=
by { rw map_eq_desc'_lift_left, ext, simp [h] }

lemma map_eq_lift_desc'_right (α β h) : map w w' α β h =
  homology.lift _ _ _ (homology.desc' _ _ _ (kernel.ι _ ≫ α.right ≫ cokernel.π _)
  (by { simp only [kernel.lift_ι_assoc], erw ← reassoc_of α.w, simp }))
  (by { ext, simp [h] }) :=
by { rw map_eq_desc'_lift_right, ext, simp }

@[simp, reassoc]
lemma map_ι (α β h) :
  map w w' α β h ≫ ι f' g' w' = ι f g w ≫ cokernel.map f f' α.left β.left (by simp [h, β.w.symm]) :=
begin
  rw [map_eq_lift_desc'_left, lift_ι],
  ext,
  simp only [← category.assoc],
  rw [π'_ι, π'_desc', category.assoc, category.assoc, cokernel.π_desc],
end

end

end homology


/- LoVe Demo 9: Hoare Logic -/

import .love08_operational_semantics_demo

namespace LoVe

/- Hoare Logic: The Semantic Approach -/

variables {b : state → Prop} {a : state → ℕ} {x : string}
variables {S S₀ S₁ S₂ : program} {s s₀ s₁ s₂ t u : state}
variables {P P' P₁ P₂ P₃ Q Q' : state → Prop}

def partial_hoare (P : state → Prop) (S : program)
  (Q : state → Prop) : Prop :=
∀s t, P s → (S, s) ⟹ t → Q t

notation `{* ` P : 1 ` *} ` S : 1 ` {* ` Q : 1 ` *}` :=
partial_hoare P S Q

namespace partial_hoare

lemma skip_intro :
  {* P *} skip {* P *} :=
begin
  intros s t hs hst,
  cases hst,
  assumption
end

lemma assign_intro (P : state → Prop) :
  {* λs, P (s{x ↦ a s}) *} assign x a {* P *} :=
begin
  intros s t P hst,
  cases hst,
  assumption
end

lemma seq_intro (h₁ : {* P₁ *} S₁ {* P₂ *})
    (h₂ : {* P₂ *} S₂ {* P₃ *}) :
  {* P₁ *} S₁ ;; S₂ {* P₃ *} :=
begin
  intros s t P hst,
  cases hst,
  apply h₂ _ _ _ hst_h₂,
  apply h₁ _ _ _ hst_h₁,
  assumption
end

lemma ite_intro (h₁ : {* λs, P s ∧ b s *} S₁ {* Q *})
    (h₂ : {* λs, P s ∧ ¬ b s *} S₂ {* Q *}) :
  {* P *} ite b S₁ S₂ {* Q *} :=
begin
  intros s t hs hst,
  cases hst,
  { apply h₁ _ _ _ hst_hbody,
    exact and.intro hs hst_hcond },
  { apply h₂ _ _ _ hst_hbody,
    exact and.intro hs hst_hcond },
end

lemma while_intro (P : state → Prop)
    (h₁ : {* λs, P s ∧ b s *} S {* P *}) :
  {* P *} while b S {* λs, P s ∧ ¬ b s *} :=
begin
  intros s t hs,
  generalize eq : (while b S, s) = ws,
  intro hst,
  induction hst generalizing s;
    cases eq,
  { apply hst_ih_hrest hst_t _ rfl,
    exact h₁ _ _ (and.intro hs hst_hcond) hst_hbody },
  { exact (and.intro hs hst_hcond) }
end

lemma consequence (h : {* P *} S {* Q *}) (hp : ∀s, P' s → P s)
    (hq : ∀s, Q s → Q' s) :
  {* P' *} S {* Q' *} :=
assume s t hs hst,
show Q' t,
  from hq _ (h s t (hp s hs) hst)

lemma consequence_left (P' : state → Prop)
    (h : {* P *} S {* Q *}) (hp : ∀s, P' s → P s) :
  {* P' *} S {* Q *} :=
consequence h hp (assume s hs, hs)

lemma consequence_right (Q : state → Prop)
    (h : {* P *} S {* Q *}) (hq : ∀s, Q s → Q' s) :
  {* P *} S {* Q' *} :=
consequence h (assume s hs, hs) hq

lemma skip_intro' (h : ∀s, P s → Q s):
  {* P *} skip {* Q *} :=
consequence skip_intro h (assume s hs, hs)

lemma assign_intro' (h : ∀s, P s → Q (s{x ↦ a s})):
  {* P *} assign x a {* Q *} :=
consequence (assign_intro Q) h (assume s hs, hs)

lemma seq_intro' (h₂ : {* P₂ *} S₂ {* P₃ *})
    (h₁ : {* P₁ *} S₁ {* P₂ *}) :
  {* P₁ *} S₁ ;; S₂ {* P₃ *} :=
seq_intro h₁ h₂

lemma while_intro' (I : state → Prop)
    (h₁ : {* λs, I s ∧ b s *} S {* I *}) (hp : ∀s, P s → I s)
    (hq : ∀s, ¬ b s → I s → Q s) :
  {* P *} while b S {* Q *} :=
consequence (while_intro I h₁) hp
  (assume s h, hq s (and.elim_right h) (and.elim_left h))

end partial_hoare

/- Example: Exchanging Two Variables -/

section SWAP

def SWAP : program :=
assign "t" (λs, s "a") ;;
assign "a" (λs, s "b") ;;
assign "b" (λs, s "t")

lemma SWAP_correct (x y : ℕ) :
  {* λs, s "a" = x ∧ s "b" = y *} SWAP
  {* λs, s "a" = y ∧ s "b" = x *} :=
begin
  apply partial_hoare.seq_intro',
  apply partial_hoare.seq_intro',
  apply partial_hoare.assign_intro,
  apply partial_hoare.assign_intro,
  apply partial_hoare.assign_intro',
  simp { contextual := tt }
end

end SWAP

/- Example: Adding Two Numbers -/

section ADD

def ADD : program :=
while (λs, s "n" ≠ 0)
  (assign "n" (λs, s "n" - 1) ;;
   assign "m" (λs, s "m" + 1))

lemma ADD_correct (n₀ m₀ : ℕ) :
  {* λs, s "n" = n₀ ∧ s "m" = m₀ *} ADD
  {* λs, s "n" = 0 ∧ s "m" = n₀ + m₀ *} :=
begin
  refine partial_hoare.while_intro'
    (λs, s "n" + s "m" = n₀ + m₀) _ _ _,
  apply partial_hoare.seq_intro',
  apply partial_hoare.assign_intro,
  apply partial_hoare.assign_intro',
  { simp,
    -- this looks much better: `simp` removed all updates
    intros s hnm hn0,
    rw ←hnm,
    -- subtracting on `ℕ` is annoying
    cases s "n",
    { apply false.elim, apply hn0, refl },
    { simp [nat.succ_eq_add_one] } },
  { simp { contextual := tt } },
  { simp [not_not_iff] { contextual := tt } }
end

end ADD

/- A Verification Condition Generator -/

def program.while_inv (I : state → Prop) (c : state → Prop)
  (p : program) : program :=
while c p

export program (while_inv)

namespace partial_hoare

lemma while_inv_intro {I : state → Prop}
    (h₁ : {* λs, I s ∧ b s *} S {* I *})
    (hq : ∀s, ¬ b s → I s → Q s) :
  {* I *} while_inv I b S {* Q *} :=
while_intro' I h₁ (assume s hs, hs) hq

lemma while_inv_intro' {I : state → Prop}
    (h₁ : {* λs, I s ∧ b s *} S {* I *}) (hp : ∀s, P s → I s)
    (hq : ∀s, ¬ b s → I s → Q s) :
  {* P *} while_inv I b S {* Q *} :=
while_intro' I h₁ hp hq

end partial_hoare

end LoVe

namespace tactic.interactive

open LoVe

meta def is_meta : expr → bool
| (expr.mvar _ _ _) := tt
| _                 := ff

meta def vcg : tactic unit := do
  t ← tactic.target,
  match t with
  | `({* %%P *} %%S {* _ *}) :=
    match S with
    | `(program.skip)            :=
      tactic.applyc
        (if is_meta P then ``partial_hoare.skip_intro
         else ``partial_hoare.skip_intro')
    | `(program.assign _ _)      :=
      tactic.applyc
        (if is_meta P then ``partial_hoare.assign_intro
         else ``partial_hoare.assign_intro')
    | `(program.seq _ _)         :=
      tactic.applyc ``partial_hoare.seq_intro';
        vcg
    | `(program.ite _ _ _)       :=
      tactic.applyc ``partial_hoare.ite_intro;
        vcg
    | `(program.while_inv _ _ _) :=
      tactic.applyc
          (if is_meta P then ``partial_hoare.while_inv_intro
           else ``partial_hoare.while_inv_intro');
        vcg
    | _                          :=
      tactic.fail (to_fmt "cannot analyze " ++ to_fmt S)
    end
  | _                        := pure ()
  end

end tactic.interactive

/- Example: Adding Two Numbers, Revisited -/

namespace LoVe

lemma ADD_correct₂ (n₀ m₀ : ℕ) :
  {* λs, s "n" = n₀ ∧ s "m" = m₀ *} ADD
  {* λs, s "n" = 0 ∧ s "m" = n₀ + m₀ *} :=
show
  {* λs, s "n" = n₀ ∧ s "m" = m₀ *}
  while_inv (λs, s "n" + s "m" = n₀ + m₀) (λs, s "n" ≠ 0)
    (assign "n" (λs, s "n" - 1) ;;
     assign "m" (λs, s "m" + 1))
  {* λs, s "n" = 0 ∧ s "m" = n₀ + m₀ *},
begin
  vcg;
    simp { contextual := tt },
  intros s hnm hn,
  rw ←hnm,
  cases s "n",
  { contradiction },
  { simp [nat.succ_eq_add_one] }
end

end LoVe