/-
Copyright (c) 2019 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl, Mario Carneiro

! This file was ported from Lean 3 source module data.rat.defs
! leanprover-community/mathlib commit 18a5306c091183ac90884daa9373fa3b178e8607
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Data.Rat.Init
import Mathlib.Data.Int.Cast.Defs
import Mathlib.Data.Int.Dvd.Basic
import Mathlib.Algebra.Ring.Regular
import Mathlib.Data.Nat.GCD.Basic
import Mathlib.Data.PNat.Defs

/-!
# Basics for the Rational Numbers

## Summary

We define the integral domain structure on `ℚ` and prove basic lemmas about it.
The definition of the field structure on `ℚ` will be done in `Mathlib.Data.Rat.Basic` once the
`Field` class has been defined.

## Main Definitions

- `Rat.divInt n d` constructs a rational number `q = n / d` from `n d : ℤ`.

## Notations

- `/.` is infix notation for `Rat.divInt`.

-/

namespace Rat

-- Porting note: the definition of `ℚ` has changed; in mathlib3 this was a field.
theorem pos (a : ℚ) : 0 < a.den := Nat.pos_of_ne_zero a.den_nz
#align rat.pos Rat.pos

#align rat.of_int Rat.ofInt

@[simp]
theorem ofInt_eq_cast (n : ℤ) : ofInt n = Int.cast n :=
  rfl
#align rat.of_int_eq_cast Rat.ofInt_eq_cast

@[simp, norm_cast]
theorem coe_int_num (n : ℤ) : (n : ℚ).num = n :=
  rfl
#align rat.coe_int_num Rat.coe_int_num

@[simp, norm_cast]
theorem coe_int_den (n : ℤ) : (n : ℚ).den = 1 :=
  rfl
#align rat.coe_int_denom Rat.coe_int_den

#noalign rat.mk_pnat

-- Porting note: TODO Should this be namespaced?
#align rat.mk_nat mkRat

#noalign rat.mk_pnat_eq

theorem mkRat_eq (n d) : mkRat n d = n /. d :=
  rfl
#align rat.mk_nat_eq Rat.mkRat_eq

#align rat.mk_zero Rat.divInt_zero

@[simp]
theorem zero_mk (d) (h : d ≠ 0) (w) : mk' 0 d h w = 0 := by congr

#noalign rat.zero_mk_pnat

#align rat.zero_mk_nat Rat.zero_mkRat
#align rat.zero_mk Rat.zero_divInt

private theorem gcd_abs_dvd_left {a b} : (Nat.gcd (Int.natAbs a) b : ℤ) ∣ a :=
  Int.dvd_natAbs.1 <| Int.coe_nat_dvd.2 <| Nat.gcd_dvd_left (Int.natAbs a) b
-- Porting note: no #align here as the declaration is private.

@[simp]
theorem divInt_eq_zero {a b : ℤ} (b0 : b ≠ 0) : a /. b = 0 ↔ a = 0 := by
  rw [←zero_divInt b, divInt_eq_iff b0 b0, zero_mul, mul_eq_zero, or_iff_left b0]

#align rat.mk_eq_zero Rat.divInt_eq_zero

theorem divInt_ne_zero {a b : ℤ} (b0 : b ≠ 0) : a /. b ≠ 0 ↔ a ≠ 0 :=
  (divInt_eq_zero b0).not
#align rat.mk_ne_zero Rat.divInt_ne_zero

#align rat.mk_eq Rat.divInt_eq_iff
#align rat.div_mk_div_cancel_left Rat.divInt_mul_right

-- Porting note: this can move to Std4
theorem normalize_eq_mk' (n : Int) (d : Nat) (h : d ≠ 0) (c : Nat.gcd (Int.natAbs n) d = 1) :
    normalize n d h = mk' n d h c := (mk_eq_normalize ..).symm

-- Porting note: removing as a `@[simp]` lemma as
-- theorem Rat.divInt_ofNat : ∀ (num : ℤ) (den : ℕ), num /. ↑den = mkRat num den
-- applies to the LHS.
-- @[simp]
theorem num_den : ∀ {a : ℚ}, a.num /. a.den = a := divInt_self _
#align rat.num_denom Rat.num_den

theorem num_den' {n d h c} : (⟨n, d, h, c⟩ : ℚ) = n /. d := num_den.symm
#align rat.num_denom' Rat.num_den'

theorem coe_int_eq_divInt (z : ℤ) : (z : ℚ) = z /. 1 := num_den'
#align rat.coe_int_eq_mk Rat.coe_int_eq_divInt

/-- Define a (dependent) function or prove `∀ r : ℚ, p r` by dealing with rational
numbers of the form `n /. d` with `0 < d` and coprime `n`, `d`. -/
@[elab_as_elim]
def numDenCasesOn.{u} {C : ℚ → Sort u} :
    ∀ (a : ℚ) (_ : ∀ n d, 0 < d → (Int.natAbs n).coprime d → C (n /. d)), C a
  | ⟨n, d, h, c⟩, H => by rw [num_den'] ; exact H n d (Nat.pos_of_ne_zero h) c
#align rat.num_denom_cases_on Rat.numDenCasesOn

/-- Define a (dependent) function or prove `∀ r : ℚ, p r` by dealing with rational
numbers of the form `n /. d` with `d ≠ 0`. -/
@[elab_as_elim]
def numDenCasesOn'.{u} {C : ℚ → Sort u} (a : ℚ) (H : ∀ (n : ℤ) (d : ℕ), d ≠ 0 → C (n /. d)) :
    C a :=
  numDenCasesOn a fun n d h _ => H n d h.ne'
#align rat.num_denom_cases_on' Rat.numDenCasesOn'

#align rat.add Rat.add

-- Porting note: there's already an instance for `Add ℚ` is in Std.

theorem lift_binop_eq (f : ℚ → ℚ → ℚ) (f₁ : ℤ → ℤ → ℤ → ℤ → ℤ) (f₂ : ℤ → ℤ → ℤ → ℤ → ℤ)
    (fv :
      ∀ {n₁ d₁ h₁ c₁ n₂ d₂ h₂ c₂},
        f ⟨n₁, d₁, h₁, c₁⟩ ⟨n₂, d₂, h₂, c₂⟩ = f₁ n₁ d₁ n₂ d₂ /. f₂ n₁ d₁ n₂ d₂)
    (f0 : ∀ {n₁ d₁ n₂ d₂}, d₁ ≠ 0 → d₂ ≠ 0 → f₂ n₁ d₁ n₂ d₂ ≠ 0) (a b c d : ℤ)
    (b0 : b ≠ 0) (d0 : d ≠ 0)
    (H :
      ∀ {n₁ d₁ n₂ d₂}, a * d₁ = n₁ * b → c * d₂ = n₂ * d →
        f₁ n₁ d₁ n₂ d₂ * f₂ a b c d = f₁ a b c d * f₂ n₁ d₁ n₂ d₂) :
    f (a /. b) (c /. d) = f₁ a b c d /. f₂ a b c d := by
  generalize ha : a /. b = x; cases' x with n₁ d₁ h₁ c₁; rw [num_den'] at ha
  generalize hc : c /. d = x; cases' x with n₂ d₂ h₂ c₂; rw [num_den'] at hc
  rw [fv]
  have d₁0 := ne_of_gt (Int.ofNat_lt.2 $ Nat.pos_of_ne_zero h₁)
  have d₂0 := ne_of_gt (Int.ofNat_lt.2 $ Nat.pos_of_ne_zero h₂)
  exact (divInt_eq_iff (f0 d₁0 d₂0) (f0 b0 d0)).2
    (H ((divInt_eq_iff b0 d₁0).1 ha) ((divInt_eq_iff d0 d₂0).1 hc))
#align rat.lift_binop_eq Rat.lift_binop_eq

@[simp]
theorem add_def'' {a b c d : ℤ} (b0 : b ≠ 0) (d0 : d ≠ 0) :
    a /. b + c /. d = (a * d + c * b) /. (b * d) := divInt_add_divInt _ _ b0 d0

#align rat.add_def Rat.add_def''

#align rat.neg Rat.neg

-- Porting note: there's already an instance for `Neg ℚ` is in Std.

-- Porting note: Std has explicit arguments here
@[simp]
theorem neg_def {a b : ℤ} : -(a /. b) = -a /. b := neg_divInt a b
#align rat.neg_def Rat.neg_def

@[simp]
theorem divInt_neg_den (n d : ℤ) : n /. -d = -n /. d := divInt_neg' ..
#align rat.mk_neg_denom Rat.divInt_neg_den

@[simp]
theorem sub_def'' {a b c d : ℤ} (b0 : b ≠ 0) (d0 : d ≠ 0) :
    a /. b - c /. d = (a * d - c * b) /. (b * d) := divInt_sub_divInt _ _ b0 d0
#align rat.sub_def Rat.sub_def''

#align rat.mul Rat.mul

-- Porting note: there's already an instance for `Mul ℚ` in Std.
@[simp]
theorem mul_def' {a b c d : ℤ} (b0 : b ≠ 0) (d0 : d ≠ 0) : a /. b * (c /. d) = a * c /. (b * d) :=
  divInt_mul_divInt _ _ b0 d0
#align rat.mul_def Rat.mul_def'

#align rat.inv Rat.inv

instance : Inv ℚ :=
  ⟨Rat.inv⟩

-- Porting note: there's already an instance for `Div ℚ` is in Std.

@[simp]

variable (a b c : ℚ)

-- Porting note: TODO this is a workaround.
attribute [-simp] divInt_ofNat

protected theorem add_zero : a + 0 = a :=
  numDenCasesOn' a fun n d h => by
    rw [← zero_divInt d, add_def'', zero_mul, add_zero, divInt_mul_right] <;> simp [h]
#align rat.add_zero Rat.add_zero

protected theorem zero_add : 0 + a = a :=
  numDenCasesOn' a fun n d h => by
    rw [← zero_divInt d, add_def'', zero_mul, zero_add, divInt_mul_right] <;> simp [h]
#align rat.zero_add Rat.zero_add

protected theorem add_comm : a + b = b + a :=
  numDenCasesOn' a fun n₁ d₁ h₁ => numDenCasesOn' b fun n₂ d₂ h₂ => by
    simp [h₁, h₂, add_comm, mul_comm]
#align rat.add_comm Rat.add_comm

protected theorem add_assoc : a + b + c = a + (b + c) :=
  numDenCasesOn' a fun n₁ d₁ h₁ =>
    numDenCasesOn' b fun n₂ d₂ h₂ =>
      numDenCasesOn' c fun n₃ d₃ h₃ => by
        simp [h₁, h₂, h₃]
        rw [mul_assoc, add_mul, add_mul, mul_assoc, add_assoc]
        congr 2
        ac_rfl
#align rat.add_assoc Rat.add_assoc

protected theorem add_left_neg : -a + a = 0 :=
  numDenCasesOn' a fun n d h => by simp [h, mkRat_add_mkRat]
#align rat.add_left_neg Rat.add_left_neg

theorem divInt_zero_one : 0 /. 1 = 0 :=
  show divInt _ _ = _ by
    rw [divInt]
    simp
#align rat.mk_zero_one Rat.divInt_zero_one

@[simp]
theorem divInt_one_one : 1 /. 1 = 1 :=
  show divInt _ _ = _ by
    rw [divInt]
    simp
    rfl
#align rat.mk_one_one Rat.divInt_one_one

@[simp]
theorem divInt_neg_one_one : -1 /. 1 = -1 :=
  show divInt _ _ = _ by
    rw [divInt]
    simp
    rfl
#align rat.mk_neg_one_one Rat.divInt_neg_one_one

#align rat.mul_one Rat.mul_one
#align rat.one_mul Rat.one_mul
#align rat.mul_comm Rat.mul_comm

protected theorem mul_assoc : a * b * c = a * (b * c) :=
  numDenCasesOn' a fun n₁ d₁ h₁ =>
    numDenCasesOn' b fun n₂ d₂ h₂ =>
      numDenCasesOn' c fun n₃ d₃ h₃ => by
        simp [h₁, h₂, h₃, mul_ne_zero, mul_comm, mul_assoc, mul_left_comm]
#align rat.mul_assoc Rat.mul_assoc

protected theorem add_mul : (a + b) * c = a * c + b * c :=
  numDenCasesOn' a fun n₁ d₁ h₁ =>
    numDenCasesOn' b fun n₂ d₂ h₂ =>
      numDenCasesOn' c fun n₃ d₃ h₃ => by
        simp [h₁, h₂, h₃, mul_ne_zero]
        rw [←  divInt_mul_right (Int.coe_nat_ne_zero.2 h₃), add_mul, add_mul]
        ac_rfl
#align rat.add_mul Rat.add_mul

protected theorem mul_add : a * (b + c) = a * b + a * c := by
  rw [Rat.mul_comm, Rat.add_mul, Rat.mul_comm, Rat.mul_comm c a]
#align rat.mul_add Rat.mul_add

protected theorem zero_ne_one : 0 ≠ (1 : ℚ) := by
  rw [ne_comm, ← divInt_one_one, divInt_ne_zero one_ne_zero]
  exact one_ne_zero
#align rat.zero_ne_one Rat.zero_ne_one

protected theorem mul_inv_cancel : a ≠ 0 → a * a⁻¹ = 1 :=
  numDenCasesOn' a fun n d h a0 => by
    have n0 : n ≠ 0 := mt (by rintro rfl; simp) a0
    simpa [h, n0, mul_comm] using @divInt_mul_right 1 1 (n * d) (by simp [h, n0])
#align rat.mul_inv_cancel Rat.mul_inv_cancel

protected theorem inv_mul_cancel (h : a ≠ 0) : a⁻¹ * a = 1 :=
  Eq.trans (Rat.mul_comm _ _) (Rat.mul_inv_cancel _ h)
#align rat.inv_mul_cancel Rat.inv_mul_cancel

-- Porting note: we already have a `DecidableEq ℚ`.

/-! At this point in the import hierarchy we have not defined the `Field` typeclass.
Instead we'll instantiate `CommRing` and `CommGroupWithZero` at this point.
The `Rat.field` instance and any field-specific lemmas can be found in `Mathlib.Data.Rat.Basic`.
-/

instance commRing : CommRing ℚ where
  zero := 0
  add := (· + ·)
  neg := Neg.neg
  one := 1
  mul := (· * ·)
  zero_add := Rat.zero_add
  add_zero := Rat.add_zero
  add_comm := Rat.add_comm
  add_assoc := Rat.add_assoc
  add_left_neg := Rat.add_left_neg
  mul_one := Rat.mul_one
  one_mul := Rat.one_mul
  mul_comm := Rat.mul_comm
  mul_assoc := Rat.mul_assoc
  zero_mul := Rat.zero_mul
  mul_zero := Rat.mul_zero
  left_distrib := Rat.mul_add
  right_distrib := Rat.add_mul
  sub_eq_add_neg := Rat.sub_eq_add_neg
  intCast := fun n => n
  natCast n := Int.cast n
  natCast_zero := rfl
  natCast_succ n := by
    simp only [coe_int_eq_divInt, add_def'' one_ne_zero one_ne_zero,
      ← divInt_one_one, Nat.cast_add, Nat.cast_one, mul_one]

instance commGroupWithZero : CommGroupWithZero ℚ :=
  { Rat.commRing with
    zero := 0
    one := 1
    mul := (· * ·)
    inv := Inv.inv
    div := (· / ·)
    exists_pair_ne := ⟨0, 1, Rat.zero_ne_one⟩
    inv_zero := by
      change Rat.inv 0 = 0
      rw [Rat.inv_def]
      rfl
    mul_inv_cancel := Rat.mul_inv_cancel
    mul_zero := mul_zero
    zero_mul := zero_mul }

instance isDomain : IsDomain ℚ :=
  NoZeroDivisors.to_isDomain _

-- Extra instances to short-circuit type class resolution
-- TODO(Mario): this instance slows down Mathlib.Data.Real.Basic
instance nontrivial : Nontrivial ℚ := by infer_instance

instance commSemiring : CommSemiring ℚ := by infer_instance

instance semiring : Semiring ℚ := by infer_instance

instance addCommGroup : AddCommGroup ℚ := by infer_instance

instance addGroup : AddGroup ℚ := by infer_instance

instance addCommMonoid : AddCommMonoid ℚ := by infer_instance

instance addMonoid : AddMonoid ℚ := by infer_instance

instance addLeftCancelSemigroup : AddLeftCancelSemigroup ℚ := by infer_instance

instance addRightCancelSemigroup : AddRightCancelSemigroup ℚ := by infer_instance

instance addCommSemigroup : AddCommSemigroup ℚ := by infer_instance

instance addSemigroup : AddSemigroup ℚ := by infer_instance

instance commMonoid : CommMonoid ℚ := by infer_instance

instance monoid : Monoid ℚ := by infer_instance

instance commSemigroup : CommSemigroup ℚ := by infer_instance

instance semigroup : Semigroup ℚ := by infer_instance

#align rat.denom_ne_zero Rat.den_nz

theorem eq_iff_mul_eq_mul {p q : ℚ} : p = q ↔ p.num * q.den = q.num * p.den := by
  conv =>
    lhs
    rw [← @num_den p, ← @num_den q]
  apply Rat.divInt_eq_iff <;>
    · rw [← Nat.cast_zero, Ne, Int.ofNat_inj]
      apply den_nz
#align rat.eq_iff_mul_eq_mul Rat.eq_iff_mul_eq_mul

@[simp]
theorem den_neg_eq_den (q : ℚ) : (-q).den = q.den :=
  rfl
#align rat.denom_neg_eq_denom Rat.den_neg_eq_den

@[simp]
theorem num_neg_eq_neg_num (q : ℚ) : (-q).num = -q.num :=
  rfl
#align rat.num_neg_eq_neg_num Rat.num_neg_eq_neg_num

@[simp]
theorem num_zero : Rat.num 0 = 0 :=
  rfl
#align rat.num_zero Rat.num_zero

@[simp]
theorem den_zero : Rat.den 0 = 1 :=
  rfl
#align rat.denom_zero Rat.den_zero

theorem zero_of_num_zero {q : ℚ} (hq : q.num = 0) : q = 0 := by
  have : q = q.num /. q.den := num_den.symm
  simpa [hq] using this
#align rat.zero_of_num_zero Rat.zero_of_num_zero

theorem zero_iff_num_zero {q : ℚ} : q = 0 ↔ q.num = 0 :=
  ⟨fun _ => by simp [*], zero_of_num_zero⟩
#align rat.zero_iff_num_zero Rat.zero_iff_num_zero

theorem num_ne_zero_of_ne_zero {q : ℚ} (h : q ≠ 0) : q.num ≠ 0 := fun hq0 : q.num = 0 =>
  h <| zero_of_num_zero hq0
#align rat.num_ne_zero_of_ne_zero Rat.num_ne_zero_of_ne_zero

@[simp]
theorem num_one : (1 : ℚ).num = 1 :=
  rfl
#align rat.num_one Rat.num_one

@[simp]
theorem den_one : (1 : ℚ).den = 1 :=
  rfl
#align rat.denom_one Rat.den_one

theorem mk_num_ne_zero_of_ne_zero {q : ℚ} {n d : ℤ} (hq : q ≠ 0) (hqnd : q = n /. d) : n ≠ 0 :=
  fun this => hq <| by simpa [this] using hqnd
#align rat.mk_num_ne_zero_of_ne_zero Rat.mk_num_ne_zero_of_ne_zero

theorem mk_denom_ne_zero_of_ne_zero {q : ℚ} {n d : ℤ} (hq : q ≠ 0) (hqnd : q = n /. d) : d ≠ 0 :=
  fun this => hq <| by simpa [this] using hqnd
#align rat.mk_denom_ne_zero_of_ne_zero Rat.mk_denom_ne_zero_of_ne_zero

theorem divInt_ne_zero_of_ne_zero {n d : ℤ} (h : n ≠ 0) (hd : d ≠ 0) : n /. d ≠ 0 :=
  (divInt_ne_zero hd).mpr h
#align rat.mk_ne_zero_of_ne_zero Rat.divInt_ne_zero_of_ne_zero

theorem mul_num_den (q r : ℚ) : q * r = q.num * r.num /. ↑(q.den * r.den) := by
  have hq' : (↑q.den : ℤ) ≠ 0 := by have := den_nz q; simpa
  have hr' : (↑r.den : ℤ) ≠ 0 := by have := den_nz r; simpa
  suffices q.num /. ↑q.den * (r.num /. ↑r.den) = q.num * r.num /. ↑(q.den * r.den) by
    simpa [num_den] using this
  simp [mul_def' hq' hr']
#align rat.mul_num_denom Rat.mul_num_den

theorem div_num_den (q r : ℚ) : q / r = q.num * r.den /. (q.den * r.num) :=
  if hr : r.num = 0 then by
    have hr' : r = 0 := zero_of_num_zero hr
    simp [*]
  else
    calc
      q / r = q * r⁻¹ := div_eq_mul_inv q r
      _ = q.num /. q.den * (r.num /. r.den)⁻¹ := by simp [num_den]
      _ = q.num /. q.den * (r.den /. r.num) := by rw [inv_def']
      _ = q.num * r.den /. (q.den * r.num) := mul_def' (by simpa using den_nz q) hr

#align rat.div_num_denom Rat.div_num_den

section Casts

protected theorem add_divInt (a b c : ℤ) : (a + b) /. c = a /. c + b /. c :=
  if h : c = 0 then by simp [h]
  else by
    rw [add_def'' h h, divInt_eq_iff h (mul_ne_zero h h)]
    simp [add_mul, mul_assoc]
#align rat.add_mk Rat.add_divInt

theorem divInt_eq_div (n d : ℤ) : n /. d = (n : ℚ) / d := by
  by_cases d0 : d = 0
  · simp [d0, div_zero]
  simp [division_def, coe_int_eq_divInt, mul_def' one_ne_zero d0]
#align rat.mk_eq_div Rat.divInt_eq_div

theorem divInt_mul_divInt_cancel {x : ℤ} (hx : x ≠ 0) (n d : ℤ) : n /. x * (x /. d) = n /. d := by
  by_cases hd : d = 0
  · rw [hd]
    simp
  rw [mul_def' hx hd, mul_comm x, divInt_mul_right hx]
#align rat.mk_mul_mk_cancel Rat.divInt_mul_divInt_cancel

theorem divInt_div_divInt_cancel_left {x : ℤ} (hx : x ≠ 0) (n d : ℤ) :
    n /. x / (d /. x) = n /. d := by
  rw [div_eq_mul_inv, inv_def', divInt_mul_divInt_cancel hx]
#align rat.mk_div_mk_cancel_left Rat.divInt_div_divInt_cancel_left

theorem divInt_div_divInt_cancel_right {x : ℤ} (hx : x ≠ 0) (n d : ℤ) :
    x /. n / (x /. d) = d /. n := by
  rw [div_eq_mul_inv, inv_def', mul_comm, divInt_mul_divInt_cancel hx]
#align rat.mk_div_mk_cancel_right Rat.divInt_div_divInt_cancel_right

theorem coe_int_div_eq_divInt {n d : ℤ} : (n : ℚ) / (d) = n /. d := by
  repeat' rw [coe_int_eq_divInt]
  exact divInt_div_divInt_cancel_left one_ne_zero n d
#align rat.coe_int_div_eq_mk Rat.coe_int_div_eq_divInt

-- Porting note: see porting note above about `Int.cast`@[simp]
theorem num_div_den (r : ℚ) : (r.num : ℚ) / (r.den : ℚ) = r := by
  rw [← Int.cast_ofNat]
  erw [← divInt_eq_div, num_den]
#align rat.num_div_denom Rat.num_div_den

theorem coe_int_num_of_den_eq_one {q : ℚ} (hq : q.den = 1) : (q.num : ℚ) = q := by
  conv_rhs => rw [← @num_den q, hq]
  rw [coe_int_eq_divInt]
  rfl
#align rat.coe_int_num_of_denom_eq_one Rat.coe_int_num_of_den_eq_one

theorem den_eq_one_iff (r : ℚ) : r.den = 1 ↔ ↑r.num = r :=
  ⟨Rat.coe_int_num_of_den_eq_one, fun h => h ▸ Rat.coe_int_den r.num⟩
#align rat.denom_eq_one_iff Rat.den_eq_one_iff

instance canLift : CanLift ℚ ℤ (↑) fun q => q.den = 1 :=
  ⟨fun q hq => ⟨q.num, coe_int_num_of_den_eq_one hq⟩⟩
#align rat.can_lift Rat.canLift

theorem coe_nat_eq_divInt (n : ℕ) : ↑n = n /. 1 := by
  rw [← Int.cast_ofNat, coe_int_eq_divInt]
#align rat.coe_nat_eq_mk Rat.coe_nat_eq_divInt

@[simp, norm_cast]
theorem coe_nat_num (n : ℕ) : (n : ℚ).num = n := by
  rw [← Int.cast_ofNat, coe_int_num]
#align rat.coe_nat_num Rat.coe_nat_num

@[simp, norm_cast]
theorem coe_nat_den (n : ℕ) : (n : ℚ).den = 1 := by
  rw [← Int.cast_ofNat, coe_int_den]
#align rat.coe_nat_denom Rat.coe_nat_den

-- Will be subsumed by `Int.coe_inj` after we have defined
-- `LinearOrderedField ℚ` (which implies characteristic zero).
theorem coe_int_inj (m n : ℤ) : (m : ℚ) = n ↔ m = n :=
  ⟨congr_arg num, congr_arg _⟩
#align rat.coe_int_inj Rat.coe_int_inj

end Casts

end Rat

-- Porting note: `assert_not_exists` is not implemented yet.
-- Guard against import creep.
-- assert_not_exists field


/-
Copyright (c) 2020 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison, Johan Commelin
-/

import linear_algebra.tensor_product
import algebra.algebra.tower

/-!
# The tensor product of R-algebras

Let `R` be a (semi)ring and `A` an `R`-algebra.
In this file we:

- Define the `A`-module structure on `A ⊗ M`, for an `R`-module `M`.
- Define the `R`-algebra structure on `A ⊗ B`, for another `R`-algebra `B`.
  and provide the structure isomorphisms
  * `R ⊗[R] A ≃ₐ[R] A`
  * `A ⊗[R] R ≃ₐ[R] A`
  * `A ⊗[R] B ≃ₐ[R] B ⊗[R] A`
  * `((A ⊗[R] B) ⊗[R] C) ≃ₐ[R] (A ⊗[R] (B ⊗[R] C))`

## Main declaration

- `linear_map.base_change A f` is the `A`-linear map `A ⊗ f`, for an `R`-linear map `f`.

## Implementation notes

The heterobasic definitions below such as:
 * `tensor_product.algebra_tensor_module.curry`
 * `tensor_product.algebra_tensor_module.uncurry`
 * `tensor_product.algebra_tensor_module.lcurry`
 * `tensor_product.algebra_tensor_module.lift`
 * `tensor_product.algebra_tensor_module.lift.equiv`
 * `tensor_product.algebra_tensor_module.mk`
 * `tensor_product.algebra_tensor_module.assoc`

are just more general versions of the definitions already in `linear_algebra/tensor_product`. We
could thus consider replacing the less general definitions with these ones. If we do this, we
probably should still implement the less general ones as abbreviations to the more general ones with
fewer type arguments.
-/

universes u v₁ v₂ v₃ v₄

open_locale tensor_product
open tensor_product

namespace tensor_product

variables {R A M N P : Type*}

/-!
### The `A`-module structure on `A ⊗[R] M`
-/

open linear_map
open algebra (lsmul)

namespace algebra_tensor_module

section semiring
variables [comm_semiring R] [semiring A] [algebra R A]
variables [add_comm_monoid M] [module R M] [module A M] [is_scalar_tower R A M]
variables [add_comm_monoid N] [module R N]
variables [add_comm_monoid P] [module R P] [module A P] [is_scalar_tower R A P]

lemma smul_eq_lsmul_rtensor (a : A) (x : M ⊗[R] N) : a • x = (lsmul R M a).rtensor N x := rfl

/-- Heterobasic version of `tensor_product.curry`:

Given a linear map `M ⊗[R] N →[A] P`, compose it with the canonical
bilinear map `M →[A] N →[R] M ⊗[R] N` to form a bilinear map `M →[A] N →[R] P`. -/
@[simps] def curry (f : (M ⊗[R] N) →ₗ[A] P) : M →ₗ[A] (N →ₗ[R] P) :=
{ map_smul' := λ c x, linear_map.ext $ λ y, f.map_smul c (x ⊗ₜ y),
  .. curry (f.restrict_scalars R) }

lemma restrict_scalars_curry (f : (M ⊗[R] N) →ₗ[A] P) :
  restrict_scalars R (curry f) = curry (f.restrict_scalars R) :=
rfl

/-- Just as `tensor_product.ext` is marked `ext` instead of `tensor_product.ext'`, this is
a better `ext` lemma than `tensor_product.algebra_tensor_module.ext` below.

See note [partially-applied ext lemmas]. -/
@[ext] lemma curry_injective :
  function.injective (curry : (M ⊗ N →ₗ[A] P) → (M →ₗ[A] N →ₗ[R] P)) :=
λ x y h, linear_map.restrict_scalars_injective R $ curry_injective $
  (congr_arg (linear_map.restrict_scalars R) h : _)

theorem ext {g h : (M ⊗[R] N) →ₗ[A] P}
  (H : ∀ x y, g (x ⊗ₜ y) = h (x ⊗ₜ y)) : g = h :=
curry_injective $ linear_map.ext₂ H

end semiring

section comm_semiring
variables [comm_semiring R] [comm_semiring A] [algebra R A]
variables [add_comm_monoid M] [module R M] [module A M] [is_scalar_tower R A M]
variables [add_comm_monoid N] [module R N]
variables [add_comm_monoid P] [module R P] [module A P] [is_scalar_tower R A P]

/-- Heterobasic version of `tensor_product.lift`:

Constructing a linear map `M ⊗[R] N →[A] P` given a bilinear map `M →[A] N →[R] P` with the
property that its composition with the canonical bilinear map `M →[A] N →[R] M ⊗[R] N` is
the given bilinear map `M →[A] N →[R] P`. -/
@[simps] def lift (f : M →ₗ[A] (N →ₗ[R] P)) : (M ⊗[R] N) →ₗ[A] P :=
{ map_smul' := λ c, show ∀ x : M ⊗[R] N, (lift (f.restrict_scalars R)).comp (lsmul R _ c) x =
      (lsmul R _ c).comp (lift (f.restrict_scalars R)) x,
    from ext_iff.1 $ tensor_product.ext' $ λ x y,
    by simp only [comp_apply, algebra.lsmul_coe, smul_tmul', lift.tmul, coe_restrict_scalars_eq_coe,
        f.map_smul, smul_apply],
  .. lift (f.restrict_scalars R) }

@[simp] lemma lift_tmul (f : M →ₗ[A] (N →ₗ[R] P)) (x : M) (y : N) :
  lift f (x ⊗ₜ y) = f x y :=
lift.tmul' x y

variables (R A M N P)
/-- Heterobasic version of `tensor_product.uncurry`:

Linearly constructing a linear map `M ⊗[R] N →[A] P` given a bilinear map `M →[A] N →[R] P`
with the property that its composition with the canonical bilinear map `M →[A] N →[R] M ⊗[R] N` is
the given bilinear map `M →[A] N →[R] P`. -/
@[simps] def uncurry : (M →ₗ[A] (N →ₗ[R] P)) →ₗ[A] ((M ⊗[R] N) →ₗ[A] P) :=
{ to_fun := lift,
  map_add' := λ f g, ext $ λ x y, by simp only [lift_tmul, add_apply],
  map_smul' := λ c f, ext $ λ x y, by simp only [lift_tmul, smul_apply, ring_hom.id_apply] }

/-- Heterobasic version of `tensor_product.lcurry`:

Given a linear map `M ⊗[R] N →[A] P`, compose it with the canonical
bilinear map `M →[A] N →[R] M ⊗[R] N` to form a bilinear map `M →[A] N →[R] P`. -/
@[simps] def lcurry : ((M ⊗[R] N) →ₗ[A] P) →ₗ[A] (M →ₗ[A] (N →ₗ[R] P)) :=
{ to_fun := curry,
  map_add' := λ f g, rfl,
  map_smul' := λ c f, rfl }

/-- Heterobasic version of `tensor_product.lift.equiv`:

A linear equivalence constructing a linear map `M ⊗[R] N →[A] P` given a
bilinear map `M →[A] N →[R] P` with the property that its composition with the
canonical bilinear map `M →[A] N →[R] M ⊗[R] N` is the given bilinear map `M →[A] N →[R] P`. -/
def lift.equiv : (M →ₗ[A] (N →ₗ[R] P)) ≃ₗ[A] ((M ⊗[R] N) →ₗ[A] P) :=
linear_equiv.of_linear (uncurry R A M N P) (lcurry R A M N P)
  (linear_map.ext $ λ f, ext $ λ x y, lift_tmul _ x y)
  (linear_map.ext $ λ f, linear_map.ext $ λ x, linear_map.ext $ λ y, lift_tmul f x y)

variables (R A M N P)
/-- Heterobasic version of `tensor_product.mk`:

The canonical bilinear map `M →[A] N →[R] M ⊗[R] N`. -/
@[simps] def mk : M →ₗ[A] N →ₗ[R] M ⊗[R] N :=
{ map_smul' := λ c x, rfl,
  .. mk R M N }

local attribute [ext] tensor_product.ext

/-- Heterobasic version of `tensor_product.assoc`:

Linear equivalence between `(M ⊗[A] N) ⊗[R] P` and `M ⊗[A] (N ⊗[R] P)`. -/
def assoc : ((M ⊗[A] P) ⊗[R] N) ≃ₗ[A] (M ⊗[A] (P ⊗[R] N)) :=
linear_equiv.of_linear
  (lift $ tensor_product.uncurry A _ _ _ $ comp (lcurry R A _ _ _) $
    tensor_product.mk A M (P ⊗[R] N))
  (tensor_product.uncurry A _ _ _ $ comp (uncurry R A _ _ _) $
    by apply tensor_product.curry; exact (mk R A _ _))
  (by { ext, refl, })
  (by { ext, refl, })

end comm_semiring

end algebra_tensor_module

end tensor_product

namespace linear_map
open tensor_product

/-!
### The base-change of a linear map of `R`-modules to a linear map of `A`-modules
-/

section semiring

variables {R A B M N : Type*} [comm_semiring R]
variables [semiring A] [algebra R A] [semiring B] [algebra R B]
variables [add_comm_monoid M] [module R M] [add_comm_monoid N] [module R N]
variables (r : R) (f g : M →ₗ[R] N)

variables (A)

/-- `base_change A f` for `f : M →ₗ[R] N` is the `A`-linear map `A ⊗[R] M →ₗ[A] A ⊗[R] N`. -/
def base_change (f : M →ₗ[R] N) : A ⊗[R] M →ₗ[A] A ⊗[R] N :=
{ to_fun := f.ltensor A,
  map_add' := (f.ltensor A).map_add,
  map_smul' := λ a x,
    show (f.ltensor A) (rtensor M (algebra.lmul R A a) x) =
      (rtensor N ((algebra.lmul R A) a)) ((ltensor A f) x),
    by { rw [← comp_apply, ← comp_apply],
      simp only [ltensor_comp_rtensor, rtensor_comp_ltensor] } }

variables {A}

@[simp] lemma base_change_tmul (a : A) (x : M) :
  f.base_change A (a ⊗ₜ x) = a ⊗ₜ (f x) := rfl

lemma base_change_eq_ltensor :
  (f.base_change A : A ⊗ M → A ⊗ N) = f.ltensor A := rfl

@[simp] lemma base_change_add :
  (f + g).base_change A = f.base_change A + g.base_change A :=
by { ext, simp [base_change_eq_ltensor], }

@[simp] lemma base_change_zero : base_change A (0 : M →ₗ[R] N) = 0 :=
by { ext, simp [base_change_eq_ltensor], }

@[simp] lemma base_change_smul : (r • f).base_change A = r • (f.base_change A) :=
by { ext, simp [base_change_tmul], }

variables (R A M N)
/-- `base_change` as a linear map. -/
@[simps] def base_change_hom : (M →ₗ[R] N) →ₗ[R] A ⊗[R] M →ₗ[A] A ⊗[R] N :=
{ to_fun := base_change A,
  map_add' := base_change_add,
  map_smul' := base_change_smul }

end semiring

section ring

variables {R A B M N : Type*} [comm_ring R]
variables [ring A] [algebra R A] [ring B] [algebra R B]
variables [add_comm_group M] [module R M] [add_comm_group N] [module R N]
variables (f g : M →ₗ[R] N)

@[simp] lemma base_change_sub :
  (f - g).base_change A = f.base_change A - g.base_change A :=
by { ext, simp [base_change_eq_ltensor], }

@[simp] lemma base_change_neg : (-f).base_change A = -(f.base_change A) :=
by { ext, simp [base_change_eq_ltensor], }

end ring

end linear_map

namespace algebra
namespace tensor_product

section semiring

variables {R : Type u} [comm_semiring R]
variables {A : Type v₁} [semiring A] [algebra R A]
variables {B : Type v₂} [semiring B] [algebra R B]

/-!
### The `R`-algebra structure on `A ⊗[R] B`
-/

/--
(Implementation detail)
The multiplication map on `A ⊗[R] B`,
for a fixed pure tensor in the first argument,
as an `R`-linear map.
-/
def mul_aux (a₁ : A) (b₁ : B) : (A ⊗[R] B) →ₗ[R] (A ⊗[R] B) :=
tensor_product.map (lmul_left R a₁) (lmul_left R b₁)

@[simp]
lemma mul_aux_apply (a₁ a₂ : A) (b₁ b₂ : B) :
  (mul_aux a₁ b₁) (a₂ ⊗ₜ[R] b₂) = (a₁ * a₂) ⊗ₜ[R] (b₁ * b₂) :=
rfl

/--
(Implementation detail)
The multiplication map on `A ⊗[R] B`,
as an `R`-bilinear map.
-/
def mul : (A ⊗[R] B) →ₗ[R] (A ⊗[R] B) →ₗ[R] (A ⊗[R] B) :=
tensor_product.lift $ linear_map.mk₂ R mul_aux
  (λ x₁ x₂ y, tensor_product.ext' $ λ x' y',
    by simp only [mul_aux_apply, linear_map.add_apply, add_mul, add_tmul])
  (λ c x y, tensor_product.ext' $ λ x' y',
    by simp only [mul_aux_apply, linear_map.smul_apply, smul_tmul', smul_mul_assoc])
  (λ x y₁ y₂, tensor_product.ext' $ λ x' y',
    by simp only [mul_aux_apply, linear_map.add_apply, add_mul, tmul_add])
  (λ c x y, tensor_product.ext' $ λ x' y',
    by simp only [mul_aux_apply, linear_map.smul_apply, smul_tmul, smul_tmul', smul_mul_assoc])

@[simp]
lemma mul_apply (a₁ a₂ : A) (b₁ b₂ : B) :
  mul (a₁ ⊗ₜ[R] b₁) (a₂ ⊗ₜ[R] b₂) = (a₁ * a₂) ⊗ₜ[R] (b₁ * b₂) :=
rfl

lemma mul_assoc' (mul : (A ⊗[R] B) →ₗ[R] (A ⊗[R] B) →ₗ[R] (A ⊗[R] B))
  (h : ∀ (a₁ a₂ a₃ : A) (b₁ b₂ b₃ : B),
    mul (mul (a₁ ⊗ₜ[R] b₁) (a₂ ⊗ₜ[R] b₂)) (a₃ ⊗ₜ[R] b₃) =
      mul (a₁ ⊗ₜ[R] b₁) (mul (a₂ ⊗ₜ[R] b₂) (a₃ ⊗ₜ[R] b₃))) :
  ∀ (x y z : A ⊗[R] B), mul (mul x y) z = mul x (mul y z) :=
begin
  intros,
  apply tensor_product.induction_on x,
  { simp only [linear_map.map_zero, linear_map.zero_apply], },
  apply tensor_product.induction_on y,
  { simp only [linear_map.map_zero, forall_const, linear_map.zero_apply], },
  apply tensor_product.induction_on z,
  { simp only [linear_map.map_zero, forall_const], },
  { intros, simp only [h], },
  { intros, simp only [linear_map.map_add, *], },
  { intros, simp only [linear_map.map_add, *, linear_map.add_apply], },
  { intros, simp only [linear_map.map_add, *, linear_map.add_apply], },
end

lemma mul_assoc (x y z : A ⊗[R] B) : mul (mul x y) z = mul x (mul y z) :=
mul_assoc' mul (by { intros, simp only [mul_apply, mul_assoc], }) x y z

lemma one_mul (x : A ⊗[R] B) : mul (1 ⊗ₜ 1) x = x :=
begin
  apply tensor_product.induction_on x;
  simp {contextual := tt},
end

lemma mul_one (x : A ⊗[R] B) : mul x (1 ⊗ₜ 1) = x :=
begin
  apply tensor_product.induction_on x;
  simp {contextual := tt},
end

instance : semiring (A ⊗[R] B) :=
{ zero := 0,
  add := (+),
  one := 1 ⊗ₜ 1,
  mul := λ a b, mul a b,
  one_mul := one_mul,
  mul_one := mul_one,
  mul_assoc := mul_assoc,
  zero_mul := by simp,
  mul_zero := by simp,
  left_distrib := by simp,
  right_distrib := by simp,
  .. (by apply_instance : add_comm_monoid (A ⊗[R] B)) }.

lemma one_def : (1 : A ⊗[R] B) = (1 : A) ⊗ₜ (1 : B) := rfl

@[simp]
lemma tmul_mul_tmul (a₁ a₂ : A) (b₁ b₂ : B) :
  (a₁ ⊗ₜ[R] b₁) * (a₂ ⊗ₜ[R] b₂) = (a₁ * a₂) ⊗ₜ[R] (b₁ * b₂) :=
rfl

@[simp]
lemma tmul_pow (a : A) (b : B) (k : ℕ) :
  (a ⊗ₜ[R] b)^k = (a^k) ⊗ₜ[R] (b^k) :=
begin
  induction k with k ih,
  { simp [one_def], },
  { simp [pow_succ, ih], }
end

/--
The algebra map `R →+* (A ⊗[R] B)` giving `A ⊗[R] B` the structure of an `R`-algebra.
-/
def tensor_algebra_map : R →+* (A ⊗[R] B) :=
{ to_fun := λ r, algebra_map R A r ⊗ₜ[R] 1,
  map_one' := by { simp, refl },
  map_mul' := by simp,
  map_zero' := by simp [zero_tmul],
  map_add' := by simp [add_tmul], }

instance : algebra R (A ⊗[R] B) :=
{ commutes' := λ r x,
  begin
    apply tensor_product.induction_on x,
    { simp, },
    { intros a b, simp [tensor_algebra_map, algebra.commutes], },
    { intros y y' h h', simp at h h', simp [mul_add, add_mul, h, h'], },
  end,
  smul_def' := λ r x,
  begin
    apply tensor_product.induction_on x,
    { simp [smul_zero], },
    { intros a b,
      rw [tensor_algebra_map, ←tmul_smul, ←smul_tmul, algebra.smul_def r a],
      simp, },
    { intros, dsimp, simp [smul_add, mul_add, *], },
  end,
  .. tensor_algebra_map,
  .. (by apply_instance : module R (A ⊗[R] B)) }.

@[simp]
lemma algebra_map_apply (r : R) :
  (algebra_map R (A ⊗[R] B)) r = ((algebra_map R A) r) ⊗ₜ[R] 1 := rfl

variables {C : Type v₃} [semiring C] [algebra R C]

@[ext]
theorem ext {g h : (A ⊗[R] B) →ₐ[R] C}
  (H : ∀ a b, g (a ⊗ₜ b) = h (a ⊗ₜ b)) : g = h :=
begin
  apply @alg_hom.to_linear_map_injective R (A ⊗[R] B) C _ _ _ _ _ _ _ _,
  ext,
  simp [H],
end

/-- The algebra morphism `A →ₐ[R] A ⊗[R] B` sending `a` to `a ⊗ₜ 1`. -/
def include_left : A →ₐ[R] A ⊗[R] B :=
{ to_fun := λ a, a ⊗ₜ 1,
  map_zero' := by simp,
  map_add' := by simp [add_tmul],
  map_one' := rfl,
  map_mul' := by simp,
  commutes' := by simp, }

@[simp]
lemma include_left_apply (a : A) : (include_left : A →ₐ[R] A ⊗[R] B) a = a ⊗ₜ 1 := rfl

/-- The algebra morphism `B →ₐ[R] A ⊗[R] B` sending `b` to `1 ⊗ₜ b`. -/
def include_right : B →ₐ[R] A ⊗[R] B :=
{ to_fun := λ b, 1 ⊗ₜ b,
  map_zero' := by simp,
  map_add' := by simp [tmul_add],
  map_one' := rfl,
  map_mul' := by simp,
  commutes' := λ r,
  begin
    simp only [algebra_map_apply],
    transitivity r • ((1 : A) ⊗ₜ[R] (1 : B)),
    { rw [←tmul_smul, algebra.smul_def], simp, },
    { simp [algebra.smul_def], },
  end, }

@[simp]
lemma include_right_apply (b : B) : (include_right : B →ₐ[R] A ⊗[R] B) b = 1 ⊗ₜ b := rfl

end semiring

section ring

variables {R : Type u} [comm_ring R]
variables {A : Type v₁} [ring A] [algebra R A]
variables {B : Type v₂} [ring B] [algebra R B]

instance : ring (A ⊗[R] B) :=
{ .. (by apply_instance : add_comm_group (A ⊗[R] B)),
  .. (by apply_instance : semiring (A ⊗[R] B)) }.

end ring

section comm_ring

variables {R : Type u} [comm_ring R]
variables {A : Type v₁} [comm_ring A] [algebra R A]
variables {B : Type v₂} [comm_ring B] [algebra R B]

instance : comm_ring (A ⊗[R] B) :=
{ mul_comm := λ x y,
  begin
    apply tensor_product.induction_on x,
    { simp, },
    { intros a₁ b₁,
      apply tensor_product.induction_on y,
      { simp, },
      { intros a₂ b₂,
        simp [mul_comm], },
      { intros a₂ b₂ ha hb,
        simp [mul_add, add_mul, ha, hb], }, },
    { intros x₁ x₂ h₁ h₂,
      simp [mul_add, add_mul, h₁, h₂], },
  end
  .. (by apply_instance : ring (A ⊗[R] B)) }.

end comm_ring

/--
Verify that typeclass search finds the ring structure on `A ⊗[ℤ] B`
when `A` and `B` are merely rings, by treating both as `ℤ`-algebras.
-/
example {A : Type v₁} [ring A] {B : Type v₂} [ring B] : ring (A ⊗[ℤ] B) :=
by apply_instance

/--
Verify that typeclass search finds the comm_ring structure on `A ⊗[ℤ] B`
when `A` and `B` are merely comm_rings, by treating both as `ℤ`-algebras.
-/
example {A : Type v₁} [comm_ring A] {B : Type v₂} [comm_ring B] : comm_ring (A ⊗[ℤ] B) :=
by apply_instance

/-!
We now build the structure maps for the symmetric monoidal category of `R`-algebras.
-/
section monoidal

section
variables {R : Type u} [comm_semiring R]
variables {A : Type v₁} [semiring A] [algebra R A]
variables {B : Type v₂} [semiring B] [algebra R B]
variables {C : Type v₃} [semiring C] [algebra R C]
variables {D : Type v₄} [semiring D] [algebra R D]

/--
Build an algebra morphism from a linear map out of a tensor product,
and evidence of multiplicativity on pure tensors.
-/
def alg_hom_of_linear_map_tensor_product
  (f : A ⊗[R] B →ₗ[R] C)
  (w₁ : ∀ (a₁ a₂ : A) (b₁ b₂ : B), f ((a₁ * a₂) ⊗ₜ (b₁ * b₂)) = f (a₁ ⊗ₜ b₁) * f (a₂ ⊗ₜ b₂))
  (w₂ : ∀ r, f ((algebra_map R A) r ⊗ₜ[R] 1) = (algebra_map R C) r):
  A ⊗[R] B →ₐ[R] C :=
{ map_one' := by simpa using w₂ 1,
  map_zero' := by simp,
  map_mul' := λ x y,
  begin
    apply tensor_product.induction_on x,
    { simp, },
    { intros a₁ b₁,
      apply tensor_product.induction_on y,
      { simp, },
      { intros a₂ b₂,
        simp [w₁], },
      { intros x₁ x₂ h₁ h₂,
        simp at h₁, simp at h₂,
        simp [mul_add, add_mul, h₁, h₂], }, },
    { intros x₁ x₂ h₁ h₂,
      simp at h₁, simp at h₂,
      simp [mul_add, add_mul, h₁, h₂], }
  end,
  commutes' := λ r, by simp [w₂],
  .. f }

@[simp]
lemma alg_hom_of_linear_map_tensor_product_apply (f w₁ w₂ x) :
  (alg_hom_of_linear_map_tensor_product f w₁ w₂ : A ⊗[R] B →ₐ[R] C) x = f x := rfl

/--
Build an algebra equivalence from a linear equivalence out of a tensor product,
and evidence of multiplicativity on pure tensors.
-/
def alg_equiv_of_linear_equiv_tensor_product
  (f : A ⊗[R] B ≃ₗ[R] C)
  (w₁ : ∀ (a₁ a₂ : A) (b₁ b₂ : B), f ((a₁ * a₂) ⊗ₜ (b₁ * b₂)) = f (a₁ ⊗ₜ b₁) * f (a₂ ⊗ₜ b₂))
  (w₂ : ∀ r, f ((algebra_map R A) r ⊗ₜ[R] 1) = (algebra_map R C) r):
  A ⊗[R] B ≃ₐ[R] C :=
{ .. alg_hom_of_linear_map_tensor_product (f : A ⊗[R] B →ₗ[R] C) w₁ w₂,
  .. f }

@[simp]
lemma alg_equiv_of_linear_equiv_tensor_product_apply (f w₁ w₂ x) :
  (alg_equiv_of_linear_equiv_tensor_product f w₁ w₂ : A ⊗[R] B ≃ₐ[R] C) x = f x := rfl

/--
Build an algebra equivalence from a linear equivalence out of a triple tensor product,
and evidence of multiplicativity on pure tensors.
-/
def alg_equiv_of_linear_equiv_triple_tensor_product
  (f : ((A ⊗[R] B) ⊗[R] C) ≃ₗ[R] D)
  (w₁ : ∀ (a₁ a₂ : A) (b₁ b₂ : B) (c₁ c₂ : C),
    f ((a₁ * a₂) ⊗ₜ (b₁ * b₂) ⊗ₜ (c₁ * c₂)) = f (a₁ ⊗ₜ b₁ ⊗ₜ c₁) * f (a₂ ⊗ₜ b₂ ⊗ₜ c₂))
  (w₂ : ∀ r, f (((algebra_map R A) r ⊗ₜ[R] (1 : B)) ⊗ₜ[R] (1 : C)) = (algebra_map R D) r) :
  (A ⊗[R] B) ⊗[R] C ≃ₐ[R] D :=
{ to_fun := f,
  map_mul' := λ x y,
  begin
    apply tensor_product.induction_on x,
    { simp, },
    { intros ab₁ c₁,
      apply tensor_product.induction_on y,
      { simp, },
      { intros ab₂ c₂,
        apply tensor_product.induction_on ab₁,
        { simp, },
        { intros a₁ b₁,
          apply tensor_product.induction_on ab₂,
          { simp, },
          { simp [w₁], },
          { intros x₁ x₂ h₁ h₂,
            simp at h₁ h₂,
            simp [mul_add, add_tmul, h₁, h₂], }, },
        { intros x₁ x₂ h₁ h₂,
          simp at h₁ h₂,
          simp [add_mul, add_tmul, h₁, h₂], }, },
      { intros x₁ x₂ h₁ h₂,
        simp [mul_add, add_mul, h₁, h₂], }, },
    { intros x₁ x₂ h₁ h₂,
      simp [mul_add, add_mul, h₁, h₂], }
  end,
  commutes' := λ r, by simp [w₂],
  .. f }

@[simp]
lemma alg_equiv_of_linear_equiv_triple_tensor_product_apply (f w₁ w₂ x) :
  (alg_equiv_of_linear_equiv_triple_tensor_product f w₁ w₂ : (A ⊗[R] B) ⊗[R] C ≃ₐ[R] D) x = f x :=
rfl

end

variables {R : Type u} [comm_semiring R]
variables {A : Type v₁} [semiring A] [algebra R A]
variables {B : Type v₂} [semiring B] [algebra R B]
variables {C : Type v₃} [semiring C] [algebra R C]
variables {D : Type v₄} [semiring D] [algebra R D]

section
variables (R A)
/--
The base ring is a left identity for the tensor product of algebra, up to algebra isomorphism.
-/
protected def lid : R ⊗[R] A ≃ₐ[R] A :=
alg_equiv_of_linear_equiv_tensor_product (tensor_product.lid R A)
(by simp [mul_smul]) (by simp [algebra.smul_def])

@[simp]

/--
The base ring is a right identity for the tensor product of algebra, up to algebra isomorphism.
-/
protected def rid : A ⊗[R] R ≃ₐ[R] A :=
alg_equiv_of_linear_equiv_tensor_product (tensor_product.rid R A)
(by simp [mul_smul]) (by simp [algebra.smul_def])

@[simp] theorem rid_tmul (r : R) (a : A) :
  (tensor_product.rid R A : (A ⊗ R → A)) (a ⊗ₜ r) = r • a :=
by simp [tensor_product.rid]

section
variables (R A B)

/--
The tensor product of R-algebras is commutative, up to algebra isomorphism.
-/
protected def comm : A ⊗[R] B ≃ₐ[R] B ⊗[R] A :=
alg_equiv_of_linear_equiv_tensor_product (tensor_product.comm R A B)
(by simp)
(λ r, begin
  transitivity r • ((1 : B) ⊗ₜ[R] (1 : A)),
  { rw [←tmul_smul, algebra.smul_def], simp, },
  { simp [algebra.smul_def], },
end)

@[simp]
theorem comm_tmul (a : A) (b : B) :
  (tensor_product.comm R A B : (A ⊗[R] B → B ⊗[R] A)) (a ⊗ₜ b) = (b ⊗ₜ a) :=
by simp [tensor_product.comm]

end

section
variables {R A B C}

lemma assoc_aux_1 (a₁ a₂ : A) (b₁ b₂ : B) (c₁ c₂ : C) :
  (tensor_product.assoc R A B C) (((a₁ * a₂) ⊗ₜ[R] (b₁ * b₂)) ⊗ₜ[R] (c₁ * c₂)) =
    (tensor_product.assoc R A B C) ((a₁ ⊗ₜ[R] b₁) ⊗ₜ[R] c₁) *
      (tensor_product.assoc R A B C) ((a₂ ⊗ₜ[R] b₂) ⊗ₜ[R] c₂) :=
rfl

lemma assoc_aux_2 (r : R) :
  (tensor_product.assoc R A B C) (((algebra_map R A) r ⊗ₜ[R] 1) ⊗ₜ[R] 1) =
    (algebra_map R (A ⊗ (B ⊗ C))) r := rfl

-- variables (R A B C)

-- -- local attribute [elab_simple] alg_equiv_of_linear_equiv_triple_tensor_product

-- /-- The associator for tensor product of R-algebras, as an algebra isomorphism. -/
-- -- FIXME This is _really_ slow to compile. :-(
-- protected def assoc : ((A ⊗[R] B) ⊗[R] C) ≃ₐ[R] (A ⊗[R] (B ⊗[R] C)) :=
-- alg_equiv_of_linear_equiv_triple_tensor_product
--   (tensor_product.assoc R A B C)
--   assoc_aux_1 assoc_aux_2

-- variables {R A B C}

-- @[simp] theorem assoc_tmul (a : A) (b : B) (c : C) :
--   ((tensor_product.assoc R A B C) :
--   (A ⊗[R] B) ⊗[R] C → A ⊗[R] (B ⊗[R] C)) ((a ⊗ₜ b) ⊗ₜ c) = a ⊗ₜ (b ⊗ₜ c) :=
-- rfl

end

variables {R A B C D}

/-- The tensor product of a pair of algebra morphisms. -/
def map (f : A →ₐ[R] B) (g : C →ₐ[R] D) : A ⊗[R] C →ₐ[R] B ⊗[R] D :=
alg_hom_of_linear_map_tensor_product
  (tensor_product.map f.to_linear_map g.to_linear_map)
  (by simp)
  (by simp [alg_hom.commutes])

@[simp] theorem map_tmul (f : A →ₐ[R] B) (g : C →ₐ[R] D) (a : A) (c : C) :
  map f g (a ⊗ₜ c) = f a ⊗ₜ g c :=
rfl

@[simp] lemma map_comp_include_left (f : A →ₐ[R] B) (g : C →ₐ[R] D) :
  (map f g).comp include_left = include_left.comp f := alg_hom.ext $ by simp

@[simp] lemma map_comp_include_right (f : A →ₐ[R] B) (g : C →ₐ[R] D) :
  (map f g).comp include_right = include_right.comp g := alg_hom.ext $ by simp

/--
Construct an isomorphism between tensor products of R-algebras
from isomorphisms between the tensor factors.
-/
def congr (f : A ≃ₐ[R] B) (g : C ≃ₐ[R] D) : A ⊗[R] C ≃ₐ[R] B ⊗[R] D :=
alg_equiv.of_alg_hom (map f g) (map f.symm g.symm)
  (ext $ λ b d, by simp)
  (ext $ λ a c, by simp)

@[simp]
lemma congr_apply (f : A ≃ₐ[R] B) (g : C ≃ₐ[R] D) (x) :
  congr f g x = (map (f : A →ₐ[R] B) (g : C →ₐ[R] D)) x := rfl

@[simp]
lemma congr_symm_apply (f : A ≃ₐ[R] B) (g : C ≃ₐ[R] D) (x) :
  (congr f g).symm x = (map (f.symm : B →ₐ[R] A) (g.symm : D →ₐ[R] C)) x := rfl

end

end monoidal

section

variables {R A B S : Type*} [comm_semiring R] [semiring A] [semiring B] [comm_semiring S]
variables [algebra R A] [algebra R B] [algebra R S]
variables (f : A →ₐ[R] S) (g : B →ₐ[R] S)

variables (R)

/-- `algebra.lmul'` is an alg_hom on commutative rings. -/
def lmul' : S ⊗[R] S →ₐ[R] S :=
alg_hom_of_linear_map_tensor_product (algebra.lmul' R)
  (λ a₁ a₂ b₁ b₂, by simp only [algebra.lmul'_apply, mul_mul_mul_comm])
  (λ r, by simp only [algebra.lmul'_apply, _root_.mul_one])

variables {R}

lemma lmul'_to_linear_map : (lmul' R : _ →ₐ[R] S).to_linear_map = algebra.lmul' R := rfl

@[simp] lemma lmul'_apply_tmul (a b : S) : lmul' R (a ⊗ₜ[R] b) = a * b := lmul'_apply

@[simp]
lemma lmul'_comp_include_left : (lmul' R : _ →ₐ[R] S).comp include_left = alg_hom.id R S :=
alg_hom.ext $ λ _, (lmul'_apply_tmul _ _).trans (_root_.mul_one _)

@[simp]
lemma lmul'_comp_include_right : (lmul' R : _ →ₐ[R] S).comp include_right = alg_hom.id R S :=
alg_hom.ext $ λ _, (lmul'_apply_tmul _ _).trans (_root_.one_mul _)

/--
If `S` is commutative, for a pair of morphisms `f : A →ₐ[R] S`, `g : B →ₐ[R] S`,
We obtain a map `A ⊗[R] B →ₐ[R] S` that commutes with `f`, `g` via `a ⊗ b ↦ f(a) * g(b)`.
-/
def product_map : A ⊗[R] B →ₐ[R] S := (lmul' R).comp (tensor_product.map f g)

@[simp] lemma product_map_apply_tmul (a : A) (b : B) : product_map f g (a ⊗ₜ b) = f a * g b :=
by { unfold product_map lmul', simp }

lemma product_map_left_apply (a : A) : product_map f g (include_left a) = f a := by simp

@[simp] lemma product_map_left : (product_map f g).comp include_left = f := alg_hom.ext $ by simp

lemma product_map_right_apply (b : B) : product_map f g (include_right b) = g b := by simp

@[simp] lemma product_map_right : (product_map f g).comp include_right = g := alg_hom.ext $ by simp

end
end tensor_product
end algebra


-- vim: ts=2 sw=0 sts=-1 et ai tw=70

import .basic
import .le
import .lt

namespace hidden

namespace mynat

variables {m n k p a b c: mynat}

theorem lt_to_mul:
1 < k → n ≠ 0 → n < n * k :=
(λ h1k hnn0, lt_mul hnn0 h1k)

theorem lt_rhs_nonzero:
m < n → n ≠ 0 :=
begin
  assume hmn hn0,
  rw hn0 at hmn,
  from lt_nzero hmn,
end

theorem pow_gt_1:
1 < a → 1 < a ^ succ n :=
begin
  assume h1a,
  induction n, {
    from h1a,
  }, {
    rw pow_succ,
    from lt_comb_mul h1a n_ih,
  },
end

-- maybe should be done better than this
theorem pow_gt_1_converse:
1 < a ^ succ n → 1 < a :=
begin
  cases a, {
    simp,
    assume h, from h,
  }, {
    cases a, {
      simp,
      assume h, from h,
    }, {
      assume _,
      apply @lt_add _ _ 1,
      from zero_lt_succ,
    },
  },
end

theorem exp_nonzero:
a ≠ 0 → a ^ n ≠ 0 :=
begin
  assume han0 hexp0,
  induction n with n_n n_ih, {
    cases hexp0,
  }, {
    rw pow_succ at hexp0,
    from n_ih (mul_integral han0 hexp0),
  },
end

theorem exp_monotone:
1 < a → n < m → a ^ n < a ^ m :=
begin
  assume h1a hnm,
  cases (lt_iff_succ_le.mp hnm) with d hd,
  rw [hd, succ_add, ←add_succ, pow_add],
  have han0: a ≠ 0, {
    assume ha0,
    rw ha0 at h1a,
    from lt_nzero h1a,
  },
  from lt_to_mul (pow_gt_1 h1a) (exp_nonzero han0),
end

theorem lt_impl_neq:
m < n → m ≠ n :=
begin
  assume hmltn hmeqn,
  rw hmeqn at hmltn,
  from lt_nrefl hmltn,
end

theorem pow_cancel_left:  -- aka, "taking base-a logs"
1 < a → a ^ n = a ^ m → n = m :=
begin
  wlog_le m n, {
    assume h1a hanam,
    symmetry,
    from hsymm h1a hanam.symm,
  }, {
    assume h1a haman,
    cases (le_iff_lt_or_eq.mp hle) with hlt heq, {
      exfalso,
      from lt_impl_neq (exp_monotone h1a hlt) haman,
    }, {
      assumption,
    },
  },
end

theorem pow_monotone:
1 < a → n ≠ 0 → a < b → a ^ n < b ^ n :=
begin
  assume h1a hnn0 hab,
  cases n, {
    contradiction,
  }, {
    clear hnn0,
    induction n with n hn, {
      assumption,
    }, {
      conv {
        congr,
        rw pow_succ,
        skip,
        rw pow_succ,
      },
      from lt_comb_mul hab hn,
    },
  },
end

theorem pow_monotone_nonstrict:
a ≤ b → a ^ n ≤ b ^ n :=
begin
  assume hab,
  induction n with n hn, {
    from le_refl,
  }, {
    apply le_mul_comb, {
      assumption,
    }, {
      assumption,
    },
  },
end

theorem pow_cancel_right: -- aka, "taking n-th roots"
1 < a → n ≠ 0 → a ^ n = b ^ n → a = b :=
begin
  assume h1a hnn0 hanbn,
  have h1b: 1 < b, {
    cases n, {
      contradiction,
    }, {
      have h1asn := pow_gt_1 h1a,
      rw hanbn at h1asn,
      from pow_gt_1_converse h1asn,
    },
  },
  wlog_le a b, {
    assume h1a hanbn h1b,
    symmetry,
    from hsymm h1b hanbn.symm h1a,
  }, {
    assume h1b hbnan h1a,
    cases (le_iff_lt_or_eq.mp hle) with hlt heq, {
      have := pow_monotone h1a hnn0 hlt,
      exfalso,
      from (lt_impl_neq this) hbnan.symm,
    }, {
      symmetry,
      assumption,
    },
  },
end

-- this is probably bad, I'm rusty
theorem root_monotone:
1 < a → n ≠ 0 → a ^ n ≤ b ^ n → a ≤ b :=
begin
  assume h1a hnn0 hanbn,
  by_contradiction,
  cases n, {
    contradiction,
  }, {
    cases b, {
      simp at hanbn,
      rw ←pow_succ at hanbn,
      have := @pow_gt_1 n a h1a,
      have := lt_le_chain _ this hanbn,
      from lt_nzero this,
    }, {
      cases b, {
        simp at hanbn,
        rw ←pow_succ at hanbn,
        have := @pow_gt_1 n a h1a,
        have := lt_le_chain _ this hanbn,
        from lt_nrefl this,
      }, {
        have h1b: 1 < b.succ.succ, {
          rw ←add_one_succ,
          rw add_comm,
          from @lt_to_add_succ 1 b,
        },
        have := pow_monotone h1b hnn0 a_1,
        contradiction,
      },
    },
  },
end

end mynat

end hidden


import measure_theory.probability_mass_function.basic
import topology.algebra.infinite_sum
import data.polynomial.eval
import .negligible

noncomputable theory
open_locale classical big_operators nnreal ennreal

-- open polynomial

-- We define ℕ-indexed distribution ensembles where the distributions are discrete, i.e. given by pmfs.

def ensemble (α : Type) : Type := ℕ → pmf α

-- lemma tsum_zero {α β : Type} [add_comm_monoid α] [topological_space α] : tsum (0 : β → α) = 0

variables {α : Type}

-- TODO send to mathlib. see https://leanprover.zulipchat.com/#narrow/stream/217875-Is-there-code-for-X.3F/topic/Total.20variation.20distance.20on.20pmf/near/281214430
instance total_variation : metric_space (pmf α) := sorry
-- { dist := λ u v, tsum (abs ((↑(u : α → ℝ≥0) : α → ℝ) - ↑(v : α → ℝ≥0))),
--   dist_self := by {intros x, cases x, simp only [sub_self], rw abs_zero, }, -- diamond
--   dist_comm := by {sorry,},
--   dist_triangle := _,
--   edist := _,
--   edist_dist := _,
--   to_uniform_space := _,
--   uniformity_dist := _,
--   eq_of_dist_eq_zero := _ }

def statistically_indistinguishable (a b : ensemble α) : Prop :=
negligible (λ n, dist (a n) (b n))

notation x ` ≈ₛ ` y := statistically_indistinguishable x y

def reflexive_statistically_indistinguishable : reflexive (@statistically_indistinguishable α) :=
begin
  intros x p,
  simp only [dist_self, one_div, inv_nonneg, nat.cast_nonneg, implies_true_iff, exists_const],
end

def symmetric_statistically_indistinguishable : symmetric (@statistically_indistinguishable α) :=
begin
  intros x y hxy,
  unfold statistically_indistinguishable at *,
  simp_rw dist_comm,
  exact hxy,
end

def transitive_statistically_indistinguishable : transitive (@statistically_indistinguishable α) :=
begin
  intros x y z hxy hyz,
  unfold statistically_indistinguishable at *,
  apply negligible_of_le_negligible _ (negligible_add hxy hyz),
  intro n,
  simp only [pi.add_apply],
  exact dist_triangle (x n) (y n) (z n),
end


lemma le_succ_self (a : mynat) : a ≤ succ a :=
begin
exact le_succ a a (le_refl a),
end


-- vim: ts=2 sw=0 sts=-1 et ai tw=70

import ..mynat.basic
import ..mynat.lt
import ..mynat.induction

namespace hidden

universe u

-- list of elements of type T
inductive mylist (T: Sort u)
-- allow empty to infer its type. It doesn't seem to work very often
| empty {}: mylist
| cons (head: T) (tail: mylist): mylist

open mylist
open mynat

namespace mylist

variable {T: Sort u}
-- Haskell-like convention, use x::xs to pattern match head/tail
variables {x y z: T}
variables {xs ys zs lst lst1 lst2 lst3: mylist T}
variables {m n: mynat}

-- I'm really just sort of making this up as I go along
-- It would be nice to have notation like [1, 2, 3]
notation h :: t := cons h t
def singleton (x: T) := x :: (empty: mylist T)

theorem cons_injective_1: x :: xs = y :: ys → x = y :=
λ h, (cons.inj h).left

theorem cons_injective_2: x :: xs = y :: ys → xs = ys :=
λ h, (cons.inj h).right

-- we don't define append explicitly, since lists are define by
-- recursion on the tail. Also note that concat is defined by
-- recursion on the first argument, so you should generally induct on
-- the first argument.
def concat: mylist T → mylist T → mylist T
| empty        lst := lst
| (x :: xs) lst := x :: (concat xs lst)

notation lst1 ++ lst2 := concat lst1 lst2

@[simp] theorem empty_concat: (empty: mylist T) ++ lst = lst := rfl
@[simp]
theorem cons_concat: (x :: xs) ++ lst = x :: (xs ++ lst) := rfl

@[simp]
theorem concat_empty: lst ++ (empty: mylist T) = lst :=
begin
  induction lst with lst_head lst_tail lst_ih, {
    simp,
  }, {
    simp [lst_ih],
  },
end

@[simp]
theorem singleton_concat_cons: singleton x ++ lst = x :: lst := rfl

@[simp]
theorem cons_not_empty: x :: xs ≠ empty :=
begin
  assume h,
  cases h,
end

@[simp]
theorem concat_assoc: (lst1 ++ lst2) ++ lst3 = lst1 ++ (lst2 ++ lst3) :=
begin
  induction lst1 with lst1_head lst1_tail lst1_ih, {
    simp,
  }, {
   simp [lst1_ih],
  },
end

instance concat_is_assoc (T: Type u): is_associative (mylist T) concat :=
⟨λ a b c, concat_assoc⟩

def len: mylist T → mynat
| empty        := 0
| (_ :: xs) := succ (len xs)

@[simp]
theorem empty_len: len (empty: mylist T) = 0 := rfl

@[simp]
theorem len_cons_succ: len (x :: xs) = succ (len xs) := rfl

@[simp]
theorem len_singleton: len (singleton x) = 1 := len_cons_succ

theorem len_of_refl: lst1 = lst2 → len lst1 = len lst2 :=
begin
  assume h,
  rw h,
end

@[simp]
theorem len_concat_add: len (lst1 ++ lst2) = len lst1 + len lst2 :=
begin
  induction lst1 with lst1_head lst1_tail lst1_ih, {
    simp,
  }, {
    simp [lst1_ih],
  },
end

def rev: mylist T → mylist T
| empty        := empty
| (x :: xs) := (rev xs) ++ singleton x

@[simp] theorem rev_empty: rev (empty: mylist T) = empty := rfl
@[simp] theorem rev_cons: rev (x :: xs) = (rev xs) ++ singleton x := rfl
@[simp] theorem rev_singleton: rev (singleton x) = singleton x := rfl

@[simp]
theorem rev_append: rev (lst ++ singleton x) = x :: rev lst :=
begin
  induction lst with lst_head lst_tail lst_ih, {
    refl,
  }, {
    rw [cons_concat, rev_cons, lst_ih],
    refl,
  },
end

theorem rev_concat: rev (lst1 ++ lst2) = rev lst2 ++ rev lst1 :=
begin
  induction lst1 with lst1_head lst1_tail lst1_ih, {
    rw rev_empty,
    rw concat_empty,
    refl,
  }, {
    rw [cons_concat, rev_cons, lst1_ih, rev_cons, concat_assoc],
  },
end

@[simp]
theorem rev_rev: rev (rev lst) = lst :=
begin
  induction lst with lst_head lst_tail lst_ih, {
    simp,
  }, {
    simp [lst_ih, rev_concat],
  },
end

@[simp]
theorem rev_len: len (rev lst) = len lst :=
begin
  induction lst with lst_head lst_tail lst_ih, {
    simp,
  }, {
    simp [lst_ih],
  },
end

theorem empty_iff_len_zero: lst = empty ↔ len lst = 0 :=
begin
  split, {
    assume h,
    rw h,
    refl,
  }, {
    assume h,
    cases lst, {
      refl,
    }, {
      exfalso,
      from succ_ne_zero h,
    },
  },
end

theorem nonempty_iff_len_nonzero: lst ≠ empty ↔ len lst ≠ 0 :=
iff_to_contrapositive empty_iff_len_zero

theorem rev_not_empty: lst ≠ empty → rev lst ≠ empty :=
begin
  repeat {rw nonempty_iff_len_nonzero},
  rw rev_len,
  assume h, from h,
end

-- These are some "maybe" operations, which are undefined on empty lists
-- (or sometimes lists of a certain length), so they take as argument
-- a proof that the input list is of the correct form,
-- which is a dependent type thing. Maybe they're supposed to be Πs

-- first element
def head: Π lst: mylist T, lst ≠ empty → T
| empty       h := absurd rfl h
| (x :: _) _ := x

@[simp] theorem first_cons (h: x :: xs ≠ empty): head (x :: xs) h = x := rfl

-- everything except first element
def tail: Π lst: mylist T, lst ≠ empty → mylist T
| empty        h := absurd rfl h
| (_ :: xs) _ := xs

@[simp] theorem tail_cons (h: x :: xs ≠ empty): tail (x :: xs) h = xs := rfl

-- everything except last element
def init: Π lst: mylist T, lst ≠ empty → mylist T
| empty             h := absurd rfl h
| (x :: empty)      _ := empty
| (x :: y :: xs) _ := x :: init (y :: xs) cons_not_empty

@[simp]
theorem init_singleton (h: singleton x ≠ empty):
init (singleton x) h = empty := rfl

@[simp]
theorem init_ccons (h: x :: y :: xs ≠ empty):
init (x :: y :: xs) h = x :: init (y :: xs) cons_not_empty := rfl

-- last element
def last: Π lst: mylist T, lst ≠ empty → T
| empty             h := absurd rfl h
| (x :: empty)      _ := x
| (x :: y :: xs) h := last (y :: xs) cons_not_empty

@[simp]
theorem last_singleton (h: singleton x ≠ empty):
last (singleton x) h = x := rfl

@[simp]
theorem last_ccons (h: x :: y :: xs ≠ empty):
last (x :: y :: xs) h = last (y :: xs) cons_not_empty := rfl

private theorem len_cons_succ_cancel1 (h: succ n ≤ len (x :: xs)): n ≤ len xs :=
begin
  simp at h,
  from le_succ_cancel h,
end

private theorem absurd_succ_le_zero: ¬succ n ≤ 0 :=
begin
  assume h,
  simp [le_iff_lt_succ] at h,
  exfalso, from lt_nzero (lt_succ_cancel h),
end

-- the first n elements
def take: Π n: mynat, Π lst: mylist T, n ≤ len lst → mylist T
| 0        _         _ := empty
| (succ n) empty        h := absurd h absurd_succ_le_zero
| (succ n) (x :: xs) h := x :: take n xs (len_cons_succ_cancel1 h)

@[simp] theorem take_zero (h: 0 ≤ len lst): take 0 lst h = empty := rfl

@[simp]
theorem take_succ_cons
(h: succ n ≤ len (x :: xs)):
take (succ n) (x :: xs) h
  = x :: take n xs (len_cons_succ_cancel1 h) := rfl

-- everything except the first n elements
def drop: Π n: mynat, Π lst: mylist T, n ≤ len lst → mylist T
| 0        lst       _ := lst
| (succ n) empty        h := absurd h absurd_succ_le_zero
| (succ n) (_ :: xs) h := drop n xs (len_cons_succ_cancel1 h)

@[simp] theorem drop_zero (h: 0 ≤ len lst): drop 0 lst h = lst := rfl
@[simp]
theorem drop_succ_cons
(h: succ n ≤ len (x :: xs)):
drop (succ n) (x :: xs) h = drop n xs (len_cons_succ_cancel1 h) := rfl

private theorem len_cons_succ_cancel2 (h: succ n < len (x :: xs)):
n < len xs :=
begin
  simp at h,
  from lt_succ_cancel h,
end

-- the nth element
def get: Π n: mynat, Π lst: mylist T, n < len lst → T
| n        empty        h := absurd h lt_nzero
| 0        (x :: _)  _ := x
| (succ n) (x :: xs) h := get n xs (len_cons_succ_cancel2 h)

@[simp]
theorem get_zero_cons
(h: 0 < len (x :: xs)):
get 0 (x :: xs) h = x := rfl

@[simp]
theorem get_succ_cons
(h: succ n < len (x :: xs)):
get (succ n) (x :: xs) h = get n xs (len_cons_succ_cancel2 h) := rfl

-- TODO: state this without tactic mode
@[simp] theorem get_zero_head (h: 0 < len lst):
get 0 lst h = head lst
              begin
                assume h',
                simp [h', lt_nrefl] at h,
                assumption,
              end :=
begin
  cases lst, {
    refl,
  }, {
    simp,
  },
end

theorem cons_head_tail (h: lst ≠ empty): head lst h :: tail lst h = lst :=
begin
  cases lst, {
    contradiction,
  }, {
    simp,
  },
end

theorem len_tail (h: lst ≠ empty): len lst = succ (len (tail lst h)) :=
begin
  cases lst, {
    contradiction,
  }, {
    simp,
  },
end

-- I didn't really think this one through
theorem len_init (h: lst ≠ empty): len lst = succ (len (init lst h)) :=
begin
  induction lst, {
    contradiction,
  }, {
    cases lst_tail, {
      refl,
    }, {
      have := lst_ih cons_not_empty,
      dsimp [len] at this,
      dsimp [len],
      rw this,
    },
  },
end

theorem append_init_last (h: lst ≠ empty):
init lst h ++ (singleton (last lst h)) = lst :=
begin
  induction lst, {
    from absurd rfl h,
  }, {
    cases lst_tail, {
      refl,
    }, {
      rw init_ccons h,
      rw last_ccons h,
      simp,
      apply lst_ih,
    },
  },
end

private theorem succ_le_impl_le (h: succ n ≤ len lst): n ≤ len lst :=
(le_cancel_strong 1 h)

theorem len_take_succ
(hsnl: succ n ≤ len lst):
len (take (succ n) lst hsnl)
  = succ (len (take n lst (succ_le_impl_le hsnl))) :=
begin
  induction n with n_n n_ih generalizing lst, {
    simp,
    cases lst, {
      exfalso,
      simp at hsnl, -- clearly absurd. Is there a quicker way?
      cases hsnl with d hd,
      from mynat.no_confusion (add_integral hd.symm),
    }, {
      -- why on Earth is this SO DIFFICULT
      -- I don't understand why I can't go straight to the rw
      have h: (1: mynat) = succ 0 := rfl,
      conv {
        to_lhs,
        congr,
        congr,
        rw h,
      },
      rw take_succ_cons,
      simp,
    },
  }, {
    cases lst, {
      exfalso,
      cases hsnl with d hd,
      from mynat.no_confusion (add_integral hd.symm),
    }, {
      simp,
      rw len_cons_succ at hsnl,
      from n_ih (le_succ_cancel hsnl),
    },
  },
end

@[simp]
theorem len_take (hnl: n ≤ len lst):
len (take n lst hnl) = n :=
begin
  induction n, {
    refl,
  }, {
    -- really all the hard work happens in len_take_succ
    simp [len_take_succ],
    apply n_ih,
  },
end

theorem take_concat_drop (hnl: n ≤ len lst):
take n lst hnl ++ drop n lst hnl = lst :=
begin
  induction n generalizing lst, {
    refl,
  }, {
    cases lst, {
      simp at hnl,
      cases hnl with d hd,
      rw succ_add at hd,
      cases hd,
    }, {
      simp,
      apply n_ih,
    },
  },
end

theorem len_drop (hnl: n ≤ len lst):
len (drop n lst hnl) + n = len lst :=
begin
  conv {
    to_lhs, congr, skip,
    rw ←len_take hnl,
  },
  rw [add_comm, ←len_concat_add, take_concat_drop],
end

theorem get_head_drop
(hnl: n < len lst):
get n lst hnl = head (drop n lst (lt_impl_le hnl)) (
  begin
    rw nonempty_iff_len_nonzero,
    have := len_drop (lt_impl_le hnl),
    rw ←this at hnl,
    conv at hnl {
      to_lhs,
      rw ←add_zero n,
      rw add_comm,
    },
    have this2 := lt_cancel n hnl,
    assume h,
    rw h at this2,
    from lt_nrefl this2,
  end
) :=
begin
  induction n generalizing lst, {
    simp,
  }, {
    cases lst, {
      exfalso, from lt_nzero hnl,
    }, {
      simp,
      apply n_ih,
    },
  },
end

theorem concat_cancel_left: lst1 ++ lst2 = lst1 ++ lst3 → lst2 = lst3 :=
begin
  assume hl1l2l1l3,
  induction lst1, {
    simp at hl1l2l1l3,
    assumption,
  }, {
    simp at hl1l2l1l3,
    apply lst1_ih,
    assumption,
  },
end

theorem rev_injective: rev lst1 = rev lst2 → lst1 = lst2 :=
begin
  -- this is a bit silly. Is there a better way to apply
  -- something to both sides in Lean?
  assume hrl1rl2,
  suffices hrr: rev (rev lst1) = rev (rev lst2), {
    repeat {rw rev_rev at hrr},
    assumption,
  }, {
    rw hrl1rl2,
  },
end

theorem concat_cancel_right: lst2 ++ lst1 = lst3 ++ lst1 → lst2 = lst3 :=
begin
  assume hl1l2l1l3,
  apply rev_injective,
  apply @concat_cancel_left _ (rev lst1),
  rw [←rev_concat, hl1l2l1l3, rev_concat],
end

@[simp]
theorem take_all (h: len lst ≤ len lst): take (len lst) lst h = lst :=
begin
  induction lst with lst_head lst_tail lst_ih, {
    refl,
  }, {
    simp,
    from lst_ih _,
  },
end

@[simp]
theorem drop_all (h: len lst ≤ len lst): drop (len lst) lst h = empty :=
begin
  induction lst with lst_head lst_tail lst_ih, {
    refl,
  }, {
    simp,
    from lst_ih _,
  },
end

theorem take_idem
(hml: m ≤ len lst):
take m (take m lst hml) (
  begin
    rw len_take,
  end
) = take m lst hml :=
begin
  induction m with m hm generalizing lst, {
    refl,
  }, {
    cases lst, {
      exfalso,
      from lt_nzero (lt_iff_succ_le.mpr hml),
    }, {
      simp,
      apply hm,
    },
  },
end

theorem take_take
(hml: m ≤ len lst)
(hnl: n ≤ len (take m lst hml)):
take n (take m lst hml) hnl = take n lst (
  begin
    rw len_take at hnl,
    from le_trans hnl hml,
  end
) :=
begin
  induction n with n hn generalizing m lst, {
    refl,
  }, {
    cases lst, {
      exfalso,
      rw len_take at hnl,
      from lt_nzero (lt_iff_succ_le.mpr (le_trans hnl hml)),
    }, {
      cases m, {
        exfalso,
        simp at hnl,
        from lt_nzero (lt_iff_succ_le.mpr hnl),
      }, {
        simp,
        apply hn,
      },
    },
  },
end

theorem drop_drop
(hml: m ≤ len lst)
(hnl: n ≤ len (drop m lst hml)):
drop n (drop m lst hml) hnl = drop (m + n) lst (
  begin
    rw ←len_drop hml,
    rw add_comm m n,
    from le_comb hnl le_refl,
  end
) :=
begin
  induction m with m hm generalizing n lst, {
    simp,
  }, {
    cases lst, {
      exfalso,
      from succ_ne_zero (le_zero hml),
    }, {
      simp,
      apply hm,
    },
  },
end

theorem drop_one_tail
(h1l: 1 ≤ len lst):
drop 1 lst h1l = tail lst (
  begin
    rw nonempty_iff_len_nonzero,
    assume h,
    rw h at h1l,
    from succ_nle_zero h1l,
  end
) :=
begin
  cases lst, {
    refl,
  }, {
    refl,
  },
end

theorem take_init
(hnl: len xs ≤ len (xs ++ singleton x)):
take (len xs) (xs ++ singleton x) hnl = xs :=
begin
  induction xs, {
    refl,
  }, {
    simp,
    apply xs_ih,
  },
end

theorem take_ignore
(hnl: n ≤ len xs):
take n (xs ++ singleton x) (
  begin
    rw len_concat_add,
    from le_add_rhs hnl,
  end
  ) = take n xs hnl :=
begin
  suffices h:
      take n (take (len xs) (xs ++ singleton x) _) _ = take n xs hnl, {
    rw @take_take _ (xs ++ singleton x) (len xs) n _ _ at h,
    from h,
  }, {
    conv {
      to_lhs,
      congr, skip,
      rw take_init,
    },
  }, {
    simp,
    from @le_to_add _ 1,
  }, {
    simp,
    assumption,
  },
end

theorem rev_drop_take
(hmn: m + n = len lst):
drop m lst (
  begin
    rw ←hmn,
    from le_to_add,
  end
) = rev (take n (rev lst) (
  begin
    rw rev_len,
    rw ←hmn,
    rw add_comm,
    from le_to_add,
  end
)) :=
begin
  induction m with m hm generalizing lst, {
    simp at hmn,
    conv in n {rw hmn},
    conv in (len lst) {rw ←rev_len},
    rw take_all,
    conv in zero {rw zz},
    rw drop_zero,
    rw rev_rev,
  }, {
    cases lst, {
      exfalso,
      rw succ_add at hmn,
      from succ_ne_zero hmn,
    }, {
      rw drop_succ_cons,
      have hmlt: m + n = len lst_tail, {
        simp at hmn,
        assumption,
      },
      have := hm hmlt, {
        rw this,
        conv in (rev (lst_head :: lst_tail)) {rw rev_cons},
        rw take_ignore,
      },
    },
  },
end

-- for some reason this has to be a Type ???
-- otherwise has_mem complains
variable {T': Type u}
variables {x' y' z': T'}
variables {xs' ys' zs': mylist T'}

-- the well-founded relation "is one strictly shorter than the other"
def shorter (lst1 lst2: mylist T) := len lst1 < len lst2

private theorem shorter_lt:
shorter lst1 lst2 ↔ lt (len lst1) (len lst2) := iff.rfl

-- it should be easier than this, right? how on earth do I just say
-- "because < is well-founded".
theorem shorter_well_founded: well_founded (@shorter T) :=
begin
  split,
  -- can't figure out how to use "generalizing"
  suffices h:
    ∀ a: mylist T,
      ∀ n,
        n = len a → acc shorter a, {
    intro a,
    from h a (len a) rfl,
  }, {
    intros a n, revert n a,
    assume hnla,
    apply strict_strong_induction
        (λ n, ∀ a : mylist T, n = len a → acc shorter a), {
      intro n,
      assume h_ih,
      intro a,
      assume hnla,
      split,
      intro y,
      assume hysa,
      rw [shorter_lt, ←hnla] at hysa,
      from h_ih (len y) hysa y rfl,
    },
  },
end

-- this made the red lines go away
namespace lwf

instance: has_well_founded (mylist T) :=
  ⟨shorter, shorter_well_founded⟩

end lwf

-- attempts at defining things that recurse on the init

-- private def lst_is_odd: mylist T → Prop
-- | empty := false
-- | (x :: xs) := have shorter (init (x :: xs) (cons_not_empty)) (x :: xs),
--                from begin
--                       rw shorter_lt,
--                       have: ∀ x y, lt x y ↔ x < y := (λ x y, iff.rfl),
--                       rw this,
--                       rw lt_iff_succ_le,
--                       rw ←len_init,
--                       from le_refl,
--                     end,
--                ¬lst_is_odd (init (x :: xs) (cons_not_empty))

-- TODO: make this work
-- def palindrome: mylist T → Prop
-- | empty             := true
-- | (x :: empty)      := true
-- | (x :: y :: xs) := x = last (y :: xs) (cons_not_empty _ _)
--                   ∧ palindrome (init (y :: xs) (cons_not_empty _ _))

end mylist
end hidden


/-
Copyright (c) 2021 Yourong Zang. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yourong Zang, Yury Kudryashov
-/
import data.fintype.option
import topology.separation
import topology.sets.opens

/-!
# The Alexandroff Compactification

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

We construct the Alexandroff compactification (the one-point compactification) of an arbitrary
topological space `X` and prove some properties inherited from `X`.

## Main definitions

* `alexandroff`: the Alexandroff compactification, we use coercion for the canonical embedding
  `X → alexandroff X`; when `X` is already compact, the compactification adds an isolated point
  to the space.
* `alexandroff.infty`: the extra point

## Main results

* The topological structure of `alexandroff X`
* The connectedness of `alexandroff X` for a noncompact, preconnected `X`
* `alexandroff X` is `T₀` for a T₀ space `X`
* `alexandroff X` is `T₁` for a T₁ space `X`
* `alexandroff X` is normal if `X` is a locally compact Hausdorff space

## Tags

one-point compactification, compactness
-/

open set filter
open_locale classical topology filter

/-!
### Definition and basic properties

In this section we define `alexandroff X` to be the disjoint union of `X` and `∞`, implemented as
`option X`. Then we restate some lemmas about `option X` for `alexandroff X`.
-/

variables {X : Type*}

/-- The Alexandroff extension of an arbitrary topological space `X` -/
def alexandroff (X : Type*) := option X

/-- The repr uses the notation from the `alexandroff` locale. -/
instance [has_repr X] : has_repr (alexandroff X) :=
⟨λ o, match o with | none := "∞" | (some a) := "↑" ++ repr a end⟩

namespace alexandroff

/-- The point at infinity -/
def infty : alexandroff X := none
localized "notation (name := alexandroff.infty) `∞` := alexandroff.infty" in alexandroff

instance : has_coe_t X (alexandroff X) := ⟨option.some⟩

instance : inhabited (alexandroff X) := ⟨∞⟩

instance [fintype X] : fintype (alexandroff X) := option.fintype

instance infinite [infinite X] : infinite (alexandroff X) := option.infinite

lemma coe_injective : function.injective (coe : X → alexandroff X) :=
option.some_injective X

@[norm_cast] lemma coe_eq_coe {x y : X} : (x : alexandroff X) = y ↔ x = y :=
coe_injective.eq_iff

@[simp] lemma coe_ne_infty (x : X) : (x : alexandroff X) ≠ ∞  .
@[simp] lemma infty_ne_coe (x : X) : ∞ ≠ (x : alexandroff X) .

/-- Recursor for `alexandroff` using the preferred forms `∞` and `↑x`. -/
@[elab_as_eliminator]
protected def rec (C : alexandroff X → Sort*) (h₁ : C ∞) (h₂ : Π x : X, C x) :
  Π (z : alexandroff X), C z :=
option.rec h₁ h₂

@[simp] lemma range_coe_union_infty : (range (coe : X → alexandroff X) ∪ {∞}) = univ :=
range_some_union_none X

@[simp] lemma range_coe_inter_infty : (range (coe : X → alexandroff X) ∩ {∞}) = ∅ :=
range_some_inter_none X

@[simp] lemma compl_range_coe : (range (coe : X → alexandroff X))ᶜ = {∞} :=
compl_range_some X

lemma compl_infty : ({∞}ᶜ : set (alexandroff X)) = range (coe : X → alexandroff X) :=
(@is_compl_range_coe_infty X).symm.compl_eq

lemma compl_image_coe (s : set X) : (coe '' s : set (alexandroff X))ᶜ = coe '' sᶜ ∪ {∞} :=
by rw [coe_injective.compl_image_eq, compl_range_coe]

lemma ne_infty_iff_exists {x : alexandroff X} :
  x ≠ ∞ ↔ ∃ (y : X), (y : alexandroff X) = x :=
by induction x using alexandroff.rec; simp

instance can_lift : can_lift (alexandroff X) X coe (λ x, x ≠ ∞) :=
with_top.can_lift

lemma not_mem_range_coe_iff {x : alexandroff X} :
  x ∉ range (coe : X → alexandroff X) ↔ x = ∞ :=
by rw [← mem_compl_iff, compl_range_coe, mem_singleton_iff]

lemma infty_not_mem_range_coe : ∞ ∉ range (coe : X → alexandroff X) :=
not_mem_range_coe_iff.2 rfl

lemma infty_not_mem_image_coe {s : set X} : ∞ ∉ (coe : X → alexandroff X) '' s :=
not_mem_subset (image_subset_range _ _) infty_not_mem_range_coe

@[simp] lemma coe_preimage_infty : (coe : X → alexandroff X) ⁻¹' {∞} = ∅ :=
by { ext, simp }

/-!
### Topological space structure on `alexandroff X`

We define a topological space structure on `alexandroff X` so that `s` is open if and only if

* `coe ⁻¹' s` is open in `X`;
* if `∞ ∈ s`, then `(coe ⁻¹' s)ᶜ` is compact.

Then we reformulate this definition in a few different ways, and prove that
`coe : X → alexandroff X` is an open embedding. If `X` is not a compact space, then we also prove
that `coe` has dense range, so it is a dense embedding.
-/

variables [topological_space X]

instance : topological_space (alexandroff X) :=
{ is_open := λ s, (∞ ∈ s → is_compact ((coe : X → alexandroff X) ⁻¹' s)ᶜ) ∧
    is_open ((coe : X → alexandroff X) ⁻¹' s),
  is_open_univ := by simp,
  is_open_inter := λ s t,
  begin
    rintros ⟨hms, hs⟩ ⟨hmt, ht⟩,
    refine ⟨_, hs.inter ht⟩,
    rintros ⟨hms', hmt'⟩,
    simpa [compl_inter] using (hms hms').union (hmt hmt')
  end,
  is_open_sUnion := λ S ho,
  begin
    suffices : is_open (coe ⁻¹' ⋃₀ S : set X),
    { refine ⟨_, this⟩,
      rintro ⟨s, hsS : s ∈ S, hs : ∞ ∈ s⟩,
      refine is_compact_of_is_closed_subset ((ho s hsS).1 hs) this.is_closed_compl _,
      exact compl_subset_compl.mpr (preimage_mono $ subset_sUnion_of_mem hsS) },
    rw [preimage_sUnion],
    exact is_open_bUnion (λ s hs, (ho s hs).2)
  end }

variables {s : set (alexandroff X)} {t : set X}

lemma is_open_def :
  is_open s ↔ (∞ ∈ s → is_compact (coe ⁻¹' s : set X)ᶜ) ∧ is_open (coe ⁻¹' s : set X) :=
iff.rfl

lemma is_open_iff_of_mem' (h : ∞ ∈ s) :
  is_open s ↔ is_compact (coe ⁻¹' s : set X)ᶜ ∧ is_open (coe ⁻¹' s : set X) :=
by simp [is_open_def, h]

lemma is_open_iff_of_mem (h : ∞ ∈ s) :
  is_open s ↔ is_closed (coe ⁻¹' s : set X)ᶜ ∧ is_compact (coe ⁻¹' s : set X)ᶜ :=
by simp only [is_open_iff_of_mem' h, is_closed_compl_iff, and.comm]

lemma is_open_iff_of_not_mem (h : ∞ ∉ s) :
  is_open s ↔ is_open (coe ⁻¹' s : set X) :=
by simp [is_open_def, h]

lemma is_closed_iff_of_mem (h : ∞ ∈ s) :
  is_closed s ↔ is_closed (coe ⁻¹' s : set X) :=
have ∞ ∉ sᶜ, from λ H, H h,
by rw [← is_open_compl_iff, is_open_iff_of_not_mem this, ← is_open_compl_iff, preimage_compl]

lemma is_closed_iff_of_not_mem (h : ∞ ∉ s) :
  is_closed s ↔ is_closed (coe ⁻¹' s : set X) ∧ is_compact (coe ⁻¹' s : set X) :=
by rw [← is_open_compl_iff, is_open_iff_of_mem (mem_compl h), ← preimage_compl, compl_compl]

@[simp] lemma is_open_image_coe {s : set X} :
  is_open (coe '' s : set (alexandroff X)) ↔ is_open s :=
by rw [is_open_iff_of_not_mem infty_not_mem_image_coe, preimage_image_eq _ coe_injective]

lemma is_open_compl_image_coe {s : set X} :
  is_open (coe '' s : set (alexandroff X))ᶜ ↔ is_closed s ∧ is_compact s :=
begin
  rw [is_open_iff_of_mem, ← preimage_compl, compl_compl, preimage_image_eq _ coe_injective],
  exact infty_not_mem_image_coe
end

@[simp] lemma is_closed_image_coe {s : set X} :
  is_closed (coe '' s : set (alexandroff X)) ↔ is_closed s ∧ is_compact s :=
by rw [← is_open_compl_iff, is_open_compl_image_coe]

/-- An open set in `alexandroff X` constructed from a closed compact set in `X` -/
def opens_of_compl (s : set X) (h₁ : is_closed s) (h₂ : is_compact s) :
  topological_space.opens (alexandroff X) :=
⟨(coe '' s)ᶜ, is_open_compl_image_coe.2 ⟨h₁, h₂⟩⟩

lemma infty_mem_opens_of_compl {s : set X} (h₁ : is_closed s) (h₂ : is_compact s) :
  ∞ ∈ opens_of_compl s h₁ h₂ :=
mem_compl infty_not_mem_image_coe

@[continuity] lemma continuous_coe : continuous (coe : X → alexandroff X) :=
continuous_def.mpr (λ s hs, hs.right)

lemma is_open_map_coe  : is_open_map (coe : X → alexandroff X) :=
λ s, is_open_image_coe.2

lemma open_embedding_coe : open_embedding (coe : X → alexandroff X) :=
open_embedding_of_continuous_injective_open continuous_coe coe_injective is_open_map_coe

lemma is_open_range_coe : is_open (range (coe : X → alexandroff X)) :=
open_embedding_coe.open_range

lemma is_closed_infty : is_closed ({∞} : set (alexandroff X)) :=
by { rw [← compl_range_coe, is_closed_compl_iff], exact is_open_range_coe }

lemma nhds_coe_eq (x : X) : 𝓝 ↑x = map (coe : X → alexandroff X) (𝓝 x) :=
(open_embedding_coe.map_nhds_eq x).symm

lemma nhds_within_coe_image (s : set X) (x : X) :
  𝓝[coe '' s] (x : alexandroff X) = map coe (𝓝[s] x) :=
(open_embedding_coe.to_embedding.map_nhds_within_eq _ _).symm

lemma nhds_within_coe (s : set (alexandroff X)) (x : X) :
  𝓝[s] ↑x = map coe (𝓝[coe ⁻¹' s] x) :=
(open_embedding_coe.map_nhds_within_preimage_eq _ _).symm

lemma comap_coe_nhds (x : X) : comap (coe : X → alexandroff X) (𝓝 x) = 𝓝 x :=
(open_embedding_coe.to_inducing.nhds_eq_comap x).symm

/-- If `x` is not an isolated point of `X`, then `x : alexandroff X` is not an isolated point
of `alexandroff X`. -/
instance nhds_within_compl_coe_ne_bot (x : X) [h : ne_bot (𝓝[≠] x)] :
  ne_bot (𝓝[≠] (x : alexandroff X)) :=
by simpa [nhds_within_coe, preimage, coe_eq_coe] using h.map coe

lemma nhds_within_compl_infty_eq : 𝓝[≠] (∞ : alexandroff X) = map coe (coclosed_compact X) :=
begin
  refine (nhds_within_basis_open ∞ _).ext (has_basis_coclosed_compact.map _) _ _,
  { rintro s ⟨hs, hso⟩,
    refine ⟨_, (is_open_iff_of_mem hs).mp hso, _⟩,
    simp },
  { rintro s ⟨h₁, h₂⟩,
    refine ⟨_, ⟨mem_compl infty_not_mem_image_coe, is_open_compl_image_coe.2 ⟨h₁, h₂⟩⟩, _⟩,
    simp [compl_image_coe, ← diff_eq, subset_preimage_image] }
end

/-- If `X` is a non-compact space, then `∞` is not an isolated point of `alexandroff X`. -/
instance nhds_within_compl_infty_ne_bot [noncompact_space X] :
  ne_bot (𝓝[≠] (∞ : alexandroff X)) :=
by { rw nhds_within_compl_infty_eq, apply_instance }

@[priority 900]
instance nhds_within_compl_ne_bot [∀ x : X, ne_bot (𝓝[≠] x)] [noncompact_space X]
  (x : alexandroff X) : ne_bot (𝓝[≠] x) :=
alexandroff.rec _ alexandroff.nhds_within_compl_infty_ne_bot
  (λ y, alexandroff.nhds_within_compl_coe_ne_bot y) x

lemma nhds_infty_eq : 𝓝 (∞ : alexandroff X) = map coe (coclosed_compact X) ⊔ pure ∞ :=
by rw [← nhds_within_compl_infty_eq, nhds_within_compl_singleton_sup_pure]

lemma has_basis_nhds_infty :
  (𝓝 (∞ : alexandroff X)).has_basis (λ s : set X, is_closed s ∧ is_compact s)
    (λ s, coe '' sᶜ ∪ {∞}) :=
begin
  rw nhds_infty_eq,
  exact (has_basis_coclosed_compact.map _).sup_pure _
end

@[simp] lemma comap_coe_nhds_infty : comap (coe : X → alexandroff X) (𝓝 ∞) = coclosed_compact X :=
by simp [nhds_infty_eq, comap_sup, comap_map coe_injective]

lemma le_nhds_infty {f : filter (alexandroff X)} :
  f ≤ 𝓝 ∞ ↔ ∀ s : set X, is_closed s → is_compact s → coe '' sᶜ ∪ {∞} ∈ f :=
by simp only [has_basis_nhds_infty.ge_iff, and_imp]

lemma ultrafilter_le_nhds_infty {f : ultrafilter (alexandroff X)} :
  (f : filter (alexandroff X)) ≤ 𝓝 ∞ ↔ ∀ s : set X, is_closed s → is_compact s → coe '' s ∉ f :=
by simp only [le_nhds_infty, ← compl_image_coe, ultrafilter.mem_coe,
  ultrafilter.compl_mem_iff_not_mem]

lemma tendsto_nhds_infty' {α : Type*} {f : alexandroff X → α} {l : filter α} :
  tendsto f (𝓝 ∞) l ↔ tendsto f (pure ∞) l ∧ tendsto (f ∘ coe) (coclosed_compact X) l :=
by simp [nhds_infty_eq, and_comm]

lemma tendsto_nhds_infty {α : Type*} {f : alexandroff X → α} {l : filter α} :
  tendsto f (𝓝 ∞) l ↔
    ∀ s ∈ l, f ∞ ∈ s ∧ ∃ t : set X, is_closed t ∧ is_compact t ∧ maps_to (f ∘ coe) tᶜ s :=
tendsto_nhds_infty'.trans $ by simp only [tendsto_pure_left,
  has_basis_coclosed_compact.tendsto_left_iff, forall_and_distrib, and_assoc, exists_prop]

lemma continuous_at_infty' {Y : Type*} [topological_space Y] {f : alexandroff X → Y} :
  continuous_at f ∞ ↔ tendsto (f ∘ coe) (coclosed_compact X) (𝓝 (f ∞)) :=
tendsto_nhds_infty'.trans $ and_iff_right (tendsto_pure_nhds _ _)

lemma continuous_at_infty {Y : Type*} [topological_space Y] {f : alexandroff X → Y} :
  continuous_at f ∞ ↔
    ∀ s ∈ 𝓝 (f ∞), ∃ t : set X, is_closed t ∧ is_compact t ∧ maps_to (f ∘ coe) tᶜ s :=
continuous_at_infty'.trans $
  by simp only [has_basis_coclosed_compact.tendsto_left_iff, exists_prop, and_assoc]

lemma continuous_at_coe {Y : Type*} [topological_space Y] {f : alexandroff X → Y} {x : X} :
  continuous_at f x ↔ continuous_at (f ∘ coe) x :=
by rw [continuous_at, nhds_coe_eq, tendsto_map'_iff, continuous_at]

/-- If `X` is not a compact space, then the natural embedding `X → alexandroff X` has dense range.
-/
lemma dense_range_coe [noncompact_space X] :
  dense_range (coe : X → alexandroff X) :=
begin
  rw [dense_range, ← compl_infty],
  exact dense_compl_singleton _
end

lemma dense_embedding_coe [noncompact_space X] :
  dense_embedding (coe : X → alexandroff X) :=
{ dense := dense_range_coe, .. open_embedding_coe }

@[simp] lemma specializes_coe {x y : X} : (x : alexandroff X) ⤳ y ↔ x ⤳ y :=
open_embedding_coe.to_inducing.specializes_iff

@[simp] lemma inseparable_coe {x y : X} : inseparable (x : alexandroff X) y ↔ inseparable x y :=
open_embedding_coe.to_inducing.inseparable_iff

lemma not_specializes_infty_coe {x : X} : ¬specializes ∞ (x : alexandroff X) :=
is_closed_infty.not_specializes rfl (coe_ne_infty x)

lemma not_inseparable_infty_coe {x : X} : ¬inseparable ∞ (x : alexandroff X) :=
λ h, not_specializes_infty_coe h.specializes

lemma not_inseparable_coe_infty {x : X} : ¬inseparable (x : alexandroff X) ∞ :=
λ h, not_specializes_infty_coe h.specializes'

lemma inseparable_iff {x y : alexandroff X} :
  inseparable x y ↔ x = ∞ ∧ y = ∞ ∨ ∃ x' : X, x = x' ∧ ∃ y' : X, y = y' ∧ inseparable x' y' :=
by induction x using alexandroff.rec; induction y using alexandroff.rec;
  simp [not_inseparable_infty_coe, not_inseparable_coe_infty, coe_eq_coe]

/-!
### Compactness and separation properties

In this section we prove that `alexandroff X` is a compact space; it is a T₀ (resp., T₁) space if
the original space satisfies the same separation axiom. If the original space is a locally compact
Hausdorff space, then `alexandroff X` is a normal (hence, T₃ and Hausdorff) space.

Finally, if the original space `X` is *not* compact and is a preconnected space, then
`alexandroff X` is a connected space.
-/

/-- For any topological space `X`, its one point compactification is a compact space. -/
instance : compact_space (alexandroff X) :=
{ is_compact_univ :=
  begin
    have : tendsto (coe : X → alexandroff X) (cocompact X) (𝓝 ∞),
    { rw [nhds_infty_eq],
      exact (tendsto_map.mono_left cocompact_le_coclosed_compact).mono_right le_sup_left },
    convert ← this.is_compact_insert_range_of_cocompact continuous_coe,
    exact insert_none_range_some X
  end }

/-- The one point compactification of a `t0_space` space is a `t0_space`. -/
instance [t0_space X] : t0_space (alexandroff X) :=
begin
  refine ⟨λ x y hxy, _⟩,
  rcases inseparable_iff.1 hxy with ⟨rfl, rfl⟩|⟨x, rfl, y, rfl, h⟩,
  exacts [rfl, congr_arg coe h.eq]
end

/-- The one point compactification of a `t1_space` space is a `t1_space`. -/
instance [t1_space X] : t1_space (alexandroff X) :=
{ t1 := λ z,
  begin
    induction z using alexandroff.rec,
    { exact is_closed_infty },
    { rw [← image_singleton, is_closed_image_coe],
      exact ⟨is_closed_singleton, is_compact_singleton⟩ }
  end }

/-- The one point compactification of a locally compact Hausdorff space is a normal (hence,
Hausdorff and regular) topological space. -/
instance [locally_compact_space X] [t2_space X] : normal_space (alexandroff X) :=
begin
  have key : ∀ z : X,
    ∃ u v : set (alexandroff X), is_open u ∧ is_open v ∧ ↑z ∈ u ∧ ∞ ∈ v ∧ disjoint u v,
  { intro z,
    rcases exists_open_with_compact_closure z with ⟨u, hu, huy', Hu⟩,
    exact ⟨coe '' u, (coe '' closure u)ᶜ, is_open_image_coe.2 hu,
      is_open_compl_image_coe.2 ⟨is_closed_closure, Hu⟩, mem_image_of_mem _ huy',
      mem_compl infty_not_mem_image_coe, (image_subset _ subset_closure).disjoint_compl_right⟩ },
  refine @normal_of_compact_t2 _ _ _ ⟨λ x y hxy, _⟩,
  induction x using alexandroff.rec; induction y using alexandroff.rec,
  { exact (hxy rfl).elim },
  { rcases key y with ⟨u, v, hu, hv, hxu, hyv, huv⟩,
    exact ⟨v, u, hv, hu, hyv, hxu, huv.symm⟩ },
  { exact key x },
  { exact separated_by_open_embedding open_embedding_coe (mt coe_eq_coe.mpr hxy) }
end

/-- If `X` is not a compact space, then `alexandroff X` is a connected space. -/
instance [preconnected_space X] [noncompact_space X] : connected_space (alexandroff X) :=
{ to_preconnected_space := dense_embedding_coe.to_dense_inducing.preconnected_space,
  to_nonempty := infer_instance }

/-- If `X` is an infinite type with discrete topology (e.g., `ℕ`), then the identity map from
`cofinite_topology (alexandroff X)` to `alexandroff X` is not continuous. -/
lemma not_continuous_cofinite_topology_of_symm [infinite X] [discrete_topology X] :
  ¬(continuous (@cofinite_topology.of (alexandroff X)).symm) :=
begin
  inhabit X,
  simp only [continuous_iff_continuous_at, continuous_at, not_forall],
  use [cofinite_topology.of ↑(default : X)],
  simpa [nhds_coe_eq, nhds_discrete, cofinite_topology.nhds_eq]
    using (finite_singleton ((default : X) : alexandroff X)).infinite_compl
end

end alexandroff

/--
A concrete counterexample shows that  `continuous.homeo_of_equiv_compact_to_t2`
cannot be generalized from `t2_space` to `t1_space`.

Let `α = alexandroff ℕ` be the one-point compactification of `ℕ`, and let `β` be the same space
`alexandroff ℕ` with the cofinite topology.  Then `α` is compact, `β` is T1, and the identity map
`id : α → β` is a continuous equivalence that is not a homeomorphism.
-/
lemma continuous.homeo_of_equiv_compact_to_t2.t1_counterexample :
  ∃ (α β : Type) (Iα : topological_space α) (Iβ : topological_space β), by exactI
  compact_space α ∧ t1_space β ∧ ∃ f : α ≃ β, continuous f ∧ ¬ continuous f.symm :=
⟨alexandroff ℕ, cofinite_topology (alexandroff ℕ), infer_instance, infer_instance,
  infer_instance, infer_instance, cofinite_topology.of, cofinite_topology.continuous_of,
  alexandroff.not_continuous_cofinite_topology_of_symm⟩


/- -----------------------------------------------------------------------
Misc facts about Lean.
----------------------------------------------------------------------- -/

namespace qp
namespace stdaux

/-! #brief funext, but for heterogeneous equality.
-/
theorem {ℓ₁ ℓ₂} hfunext
    : ∀ {A₁ A₂ : Type ℓ₁}
        {B : Type ℓ₂}
        {f₁ : A₁ → B} {f₂ : A₂ → B}
        (ωA : A₁ = A₂)
        (ω : ∀ (a : A₁), f₁ a = f₂ (cast ωA a))
      , f₁ == f₂
| A .(A) B f₁ f₂ (eq.refl .(A)) ω
:= begin
     apply heq_of_eq,
     apply funext,
     intro a,
     exact ω a
   end

/-! #brief The punit type is uniquely inhabited.
-/
theorem {ℓ} punit.uniq
    : ∀ (u₁ u₂ : punit.{ℓ})
      , u₁ = u₂
| punit.star punit.star := rfl

/-! #brief Equality helper for products.
-/
theorem {ℓ₁ ℓ₂} prod.eq {A : Type ℓ₁} {B : Type ℓ₂}
    : ∀ {ab₁ ab₂ : prod A B}
      , ab₁^.fst = ab₂^.fst
      → ab₁^.snd = ab₂^.snd
      → ab₁ = ab₂
| (prod.mk a b) (prod.mk .(a) .(b)) (eq.refl .(a)) (eq.refl .(b)) := rfl

/-! #brief The diagonal map.
-/
definition {ℓ} prod.diag {X : Type ℓ} (x : X)
    : prod X X
:= (x, x)

/-! #brief Max of two natural numbers.
-/
definition nat.max (a b : ℕ) : ℕ
:= if a ≤ b then b else a

theorem nat.le_max_left (a b : ℕ)
    : a ≤ nat.max a b
:= if ω : a ≤ b
    then begin
           unfold nat.max,
           rw if_pos ω,
           exact ω
         end
    else begin
           unfold nat.max,
           rw if_neg ω
         end

theorem nat.le_max_right (a b : ℕ)
    : b ≤ nat.max a b
:= if ω : a ≤ b
    then begin
           unfold nat.max,
           rw if_pos ω
         end
    else begin
           unfold nat.max,
           rw if_neg ω,
           exact le_of_not_le ω
         end

/-! #brief Handy absurd lemma.
-/
theorem nat.not_lt_add_left
    {P : Prop} (n : ℕ)
    : ∀ (m : ℕ) (ω : n + m < n)
      , P
| 0 ω := absurd ω (nat.lt_irrefl n)
| (nat.succ m) ω := nat.not_lt_add_left m
                     (by calc n + m < n + nat.succ m : nat.self_lt_succ _
                              ...   < n              : ω)

/-! #brief Handy absurd lemma.
-/
theorem nat.not_lt_add_right
    {P : Prop} (n : ℕ)
    : ∀ (m : ℕ) (ω : n + m < m)
      , P
| 0 ω := by cases ω
| (nat.succ m) ω := nat.not_lt_add_right m (nat.lt_of_succ_lt_succ ω)

/-! #brief The axiom of choice, for unique existence.
-/
noncomputable definition {ℓ} unique_choice {A : Type ℓ} {P : A → Prop}
    : (∃! (a : A), P a) → A
:= λ pr, classical.some (exists_of_exists_unique pr)

/-! #brief The axiom of unique choice satisfies the indicated property.
-/
theorem {ℓ} unique_choice.has_prop {A : Type ℓ} {P : A → Prop}
    (pr : ∃! (a : A), P a)
    : P (unique_choice pr)
:= classical.some_spec (exists_of_exists_unique pr)

/-! #brief The axiom of unique choice does what you'd think.
-/
theorem {ℓ} unique_choice.simp {A : Type ℓ} {P : A → Prop}
    {a : A} {ωa : P a} {ωP : ∀ (b : A), P b → b = a}
    : unique_choice (exists_unique.intro a ωa ωP) = a
:= begin
     apply ωP,
     apply unique_choice.has_prop
   end

/-! #brief Mere existence.
-/
definition {ℓ} MerelyExists (A : Type ℓ) : Prop
:= ∃ (a : A), true

/-! #brief Introducing something which merely exists.
-/
definition {ℓ} MerelyExists.intro {A : Type ℓ}
    (a : A)
    : MerelyExists A
:= exists.intro a true.intro

/-! #brief Elimintation of mere existence.
-/
definition {ℓ} MerelyExists.elim {A : Type ℓ}
    : ∀ (ex : MerelyExists A)
        (P : Prop)
        (ω : A → P)
      , P
| (exists.intro a ωa) P ω := ω a

/-! #brief The axiom of choice allows us to unbox something which merely exists.
-/
noncomputable definition {ℓ} MerelyExists.choice {A : Type ℓ}
    (ex : MerelyExists A)
    : A
:= classical.some ex

end stdaux
end qp