/-
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.cast
! leanprover-community/mathlib commit acebd8d49928f6ed8920e502a6c90674e75bd441
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Data.Rat.Order
import Mathlib.Data.Rat.Lemmas
import Mathlib.Data.Int.CharZero
import Mathlib.Algebra.GroupWithZero.Power
import Mathlib.Algebra.Field.Opposite
import Mathlib.Algebra.Order.Field.Basic

/-!
# Casts for Rational Numbers

## Summary

We define the canonical injection from ℚ into an arbitrary division ring and prove various
casting lemmas showing the well-behavedness of this injection.

## Notations

- `/.` is infix notation for `rat.mk`.

## Tags

rat, rationals, field, ℚ, numerator, denominator, num, denom, cast, coercion, casting
-/

variable {F ι α β : Type _}

namespace Rat

open Rat

section WithDivRing

variable [DivisionRing α]

@[simp, norm_cast]
theorem cast_coe_int (n : ℤ) : ((n : ℚ) : α) = n :=
  (cast_def _).trans <| show (n / (1 : ℕ) : α) = n by rw [Nat.cast_one, div_one]
#align rat.cast_coe_int Rat.cast_coe_int

@[simp, norm_cast]

@[simp, norm_cast]
theorem cast_zero : ((0 : ℚ) : α) = 0 :=
  (cast_coe_int _).trans Int.cast_zero
#align rat.cast_zero Rat.cast_zero

@[simp, norm_cast]
theorem cast_one : ((1 : ℚ) : α) = 1 :=
  (cast_coe_int _).trans Int.cast_one
#align rat.cast_one Rat.cast_one

theorem cast_commute (r : ℚ) (a : α) : Commute (↑r) a := by
  simpa only [cast_def] using (r.1.cast_commute a).div_left (r.2.cast_commute a)
#align rat.cast_commute Rat.cast_commute

theorem cast_comm (r : ℚ) (a : α) : (r : α) * a = a * r :=
  (cast_commute r a).eq
#align rat.cast_comm Rat.cast_comm

theorem commute_cast (a : α) (r : ℚ) : Commute a r :=
  (r.cast_commute a).symm
#align rat.commute_cast Rat.commute_cast

@[norm_cast]
theorem cast_mk_of_ne_zero (a b : ℤ) (b0 : (b : α) ≠ 0) : (a /. b : α) = a / b := by
  have b0' : b ≠ 0 := by
    refine' mt _ b0
    simp (config := { contextual := true })
  cases' e : a /. b with n d h c
  have d0 : (d : α) ≠ 0 := by
    intro d0
    have dd := den_dvd a b
    cases' show (d : ℤ) ∣ b by rwa [e] at dd with k ke
    have : (b : α) = (d : α) * (k : α) := by rw [ke, Int.cast_mul, Int.cast_ofNat]
    rw [d0, zero_mul] at this
    contradiction
  rw [num_den'] at e
  have := congr_arg ((↑) : ℤ → α)
    ((divInt_eq_iff b0' <| ne_of_gt <| Int.coe_nat_pos.2 h.bot_lt).1 e)
  rw [Int.cast_mul, Int.cast_mul, Int.cast_ofNat] at this
  -- Porting note: was `symm`
  apply Eq.symm
  rw [cast_def, div_eq_mul_inv, eq_div_iff_mul_eq d0, mul_assoc, (d.commute_cast _).eq, ← mul_assoc,
    this, mul_assoc, mul_inv_cancel b0, mul_one]
#align rat.cast_mk_of_ne_zero Rat.cast_mk_of_ne_zero

@[norm_cast]
theorem cast_add_of_ne_zero :
    ∀ {m n : ℚ}, (m.den : α) ≠ 0 → (n.den : α) ≠ 0 → ((m + n : ℚ) : α) = m + n
  | ⟨n₁, d₁, h₁, c₁⟩, ⟨n₂, d₂, h₂, c₂⟩ => fun (d₁0 : (d₁ : α) ≠ 0) (d₂0 : (d₂ : α) ≠ 0) =>
    by
    have d₁0' : (d₁ : ℤ) ≠ 0 :=
      Int.coe_nat_ne_zero.2 fun e => by rw [e] at d₁0 ; exact d₁0 Nat.cast_zero
    have d₂0' : (d₂ : ℤ) ≠ 0 :=
      Int.coe_nat_ne_zero.2 fun e => by rw [e] at d₂0 ; exact d₂0 Nat.cast_zero
    rw [num_den', num_den', add_def'' d₁0' d₂0']
    suffices (n₁ * (d₂ * ((d₂ : α)⁻¹ * (d₁ : α)⁻¹)) + n₂ * (d₁ * (d₂ : α)⁻¹) * (d₁ : α)⁻¹ : α)
        = n₁ * (d₁ : α)⁻¹ + n₂ * (d₂ : α)⁻¹
      by
      rw [cast_mk_of_ne_zero, cast_mk_of_ne_zero, cast_mk_of_ne_zero]
      · simpa [division_def, left_distrib, right_distrib, mul_inv_rev, d₁0, d₂0, mul_assoc]
      all_goals simp [d₁0, d₂0]
    rw [← mul_assoc (d₂ : α), mul_inv_cancel d₂0, one_mul, (Nat.cast_commute _ _).eq]
    simp [d₁0, mul_assoc]
#align rat.cast_add_of_ne_zero Rat.cast_add_of_ne_zero

@[simp, norm_cast]
theorem cast_neg : ∀ n, ((-n : ℚ) : α) = -n
  | ⟨n, d, h, c⟩ => by
    simpa only [cast_def] using
      show (↑(-n) / d : α) = -(n / d) by
        rw [div_eq_mul_inv, div_eq_mul_inv, Int.cast_neg, neg_mul_eq_neg_mul]
#align rat.cast_neg Rat.cast_neg

@[norm_cast]
theorem cast_sub_of_ne_zero {m n : ℚ} (m0 : (m.den : α) ≠ 0) (n0 : (n.den : α) ≠ 0) :
    ((m - n : ℚ) : α) = m - n := by
  have : ((-n).den : α) ≠ 0 := by cases n ; exact n0
  simp [sub_eq_add_neg, cast_add_of_ne_zero m0 this]
#align rat.cast_sub_of_ne_zero Rat.cast_sub_of_ne_zero

@[norm_cast]
theorem cast_mul_of_ne_zero :
    ∀ {m n : ℚ}, (m.den : α) ≠ 0 → (n.den : α) ≠ 0 → ((m * n : ℚ) : α) = m * n
  | ⟨n₁, d₁, h₁, c₁⟩, ⟨n₂, d₂, h₂, c₂⟩ => fun (d₁0 : (d₁ : α) ≠ 0) (d₂0 : (d₂ : α) ≠ 0) =>
    by
    have d₁0' : (d₁ : ℤ) ≠ 0 :=
      Int.coe_nat_ne_zero.2 fun e => by rw [e] at d₁0 ; exact d₁0 Nat.cast_zero
    have d₂0' : (d₂ : ℤ) ≠ 0 :=
      Int.coe_nat_ne_zero.2 fun e => by rw [e] at d₂0 ; exact d₂0 Nat.cast_zero
    rw [num_den', num_den', mul_def' d₁0' d₂0']
    suffices (n₁ * (n₂ * (d₂ : α)⁻¹ * (d₁ : α)⁻¹) : α) = n₁ * ((d₁ : α)⁻¹ * (n₂ * (d₂ : α)⁻¹))
      by
      rw [cast_mk_of_ne_zero, cast_mk_of_ne_zero, cast_mk_of_ne_zero]
      · simpa [division_def, mul_inv_rev, d₁0, d₂0, mul_assoc]
      all_goals simp [d₁0, d₂0]
    rw [(d₁.commute_cast (_ : α)).inv_right₀.eq]
#align rat.cast_mul_of_ne_zero Rat.cast_mul_of_ne_zero

-- Porting note: rewrote proof
@[simp]
theorem cast_inv_nat (n : ℕ) : ((n⁻¹ : ℚ) : α) = (n : α)⁻¹ := by
  cases' n with n
  · simp
  rw [cast_def, inv_coe_nat_num, inv_coe_nat_den, if_neg n.succ_ne_zero,
    Int.sign_eq_one_of_pos (Nat.cast_pos.mpr n.succ_pos), Int.cast_one, one_div]
#align rat.cast_inv_nat Rat.cast_inv_nat

-- Porting note: proof got a lot easier - is this still the intended statement?
@[simp]
theorem cast_inv_int (n : ℤ) : ((n⁻¹ : ℚ) : α) = (n : α)⁻¹ := by
  cases' n with n n
  · simp [ofInt_eq_cast, cast_inv_nat]
  · simp only [ofInt_eq_cast, Int.cast_negSucc, ← Nat.cast_succ, cast_neg, inv_neg, cast_inv_nat]
#align rat.cast_inv_int Rat.cast_inv_int

@[norm_cast]
theorem cast_inv_of_ne_zero :
  ∀ {n : ℚ}, (n.num : α) ≠ 0 → (n.den : α) ≠ 0 → ((n⁻¹ : ℚ) : α) = (n : α)⁻¹
  | ⟨n, d, h, c⟩ => fun (n0 : (n : α) ≠ 0) (d0 : (d : α) ≠ 0) =>
    by
    have _ : (n : ℤ) ≠ 0 := fun e => by rw [e] at n0 ; exact n0 Int.cast_zero
    have _ : (d : ℤ) ≠ 0 :=
      Int.coe_nat_ne_zero.2 fun e => by rw [e] at d0 ; exact d0 Nat.cast_zero
    rw [num_den', inv_def']
    rw [cast_mk_of_ne_zero, cast_mk_of_ne_zero, inv_div] <;> simp [n0, d0]
#align rat.cast_inv_of_ne_zero Rat.cast_inv_of_ne_zero

@[norm_cast]
theorem cast_div_of_ne_zero {m n : ℚ} (md : (m.den : α) ≠ 0) (nn : (n.num : α) ≠ 0)
    (nd : (n.den : α) ≠ 0) : ((m / n : ℚ) : α) = m / n := by
  have : (n⁻¹.den : ℤ) ∣ n.num := by
    conv in n⁻¹.den => rw [← @num_den n, inv_def']
    apply den_dvd
  have : (n⁻¹.den : α) = 0 → (n.num : α) = 0 := fun h =>
    by
    let ⟨k, e⟩ := this
    have := congr_arg ((↑) : ℤ → α) e ; rwa [Int.cast_mul, Int.cast_ofNat, h, zero_mul] at this
  rw [division_def, cast_mul_of_ne_zero md (mt this nn), cast_inv_of_ne_zero nn nd, division_def]
#align rat.cast_div_of_ne_zero Rat.cast_div_of_ne_zero

@[simp, norm_cast]
theorem cast_inj [CharZero α] : ∀ {m n : ℚ}, (m : α) = n ↔ m = n
  | ⟨n₁, d₁, d₁0, c₁⟩, ⟨n₂, d₂, d₂0, c₂⟩ =>
    by
    refine' ⟨fun h => _, congr_arg _⟩
    have d₁a : (d₁ : α) ≠ 0 := Nat.cast_ne_zero.2 d₁0
    have d₂a : (d₂ : α) ≠ 0 := Nat.cast_ne_zero.2 d₂0
    rw [num_den', num_den'] at h⊢
    rw [cast_mk_of_ne_zero, cast_mk_of_ne_zero] at h <;> simp [d₁0, d₂0] at h⊢
    rwa [eq_div_iff_mul_eq d₂a, division_def, mul_assoc, (d₁.cast_commute (d₂ : α)).inv_left₀.eq, ←
      mul_assoc, ← division_def, eq_comm, eq_div_iff_mul_eq d₁a, eq_comm, ← Int.cast_ofNat d₁, ←
      Int.cast_mul, ← Int.cast_ofNat d₂, ← Int.cast_mul, Int.cast_inj, ← mkRat_eq_iff d₁0 d₂0] at h
#align rat.cast_inj Rat.cast_inj

theorem cast_injective [CharZero α] : Function.Injective ((↑) : ℚ → α)
  | _, _ => cast_inj.1
#align rat.cast_injective Rat.cast_injective

@[simp]
theorem cast_eq_zero [CharZero α] {n : ℚ} : (n : α) = 0 ↔ n = 0 := by rw [← cast_zero, cast_inj]
#align rat.cast_eq_zero Rat.cast_eq_zero

theorem cast_ne_zero [CharZero α] {n : ℚ} : (n : α) ≠ 0 ↔ n ≠ 0 :=
  not_congr cast_eq_zero
#align rat.cast_ne_zero Rat.cast_ne_zero

@[simp, norm_cast]
theorem cast_add [CharZero α] (m n) : ((m + n : ℚ) : α) = m + n :=
  cast_add_of_ne_zero (Nat.cast_ne_zero.2 <| ne_of_gt m.pos) (Nat.cast_ne_zero.2 <| ne_of_gt n.pos)
#align rat.cast_add Rat.cast_add

@[simp, norm_cast]
theorem cast_sub [CharZero α] (m n) : ((m - n : ℚ) : α) = m - n :=
  cast_sub_of_ne_zero (Nat.cast_ne_zero.2 <| ne_of_gt m.pos) (Nat.cast_ne_zero.2 <| ne_of_gt n.pos)
#align rat.cast_sub Rat.cast_sub

@[simp, norm_cast]
theorem cast_mul [CharZero α] (m n) : ((m * n : ℚ) : α) = m * n :=
  cast_mul_of_ne_zero (Nat.cast_ne_zero.2 <| ne_of_gt m.pos) (Nat.cast_ne_zero.2 <| ne_of_gt n.pos)
#align rat.cast_mul Rat.cast_mul

section

set_option linter.deprecated false

@[simp, norm_cast]
theorem cast_bit0 [CharZero α] (n : ℚ) : ((bit0 n : ℚ) : α) = (bit0 n : α) :=
  cast_add _ _
#align rat.cast_bit0 Rat.cast_bit0

@[simp, norm_cast]
theorem cast_bit1 [CharZero α] (n : ℚ) : ((bit1 n : ℚ) : α) = (bit1 n : α) := by
  rw [bit1, cast_add, cast_one, cast_bit0] ; rfl
#align rat.cast_bit1 Rat.cast_bit1

end

variable (α)
variable [CharZero α]

/-- Coercion `ℚ → α` as a `RingHom`. -/
def castHom : ℚ →+* α where
  toFun := (↑)
  map_one' := cast_one
  map_mul' := cast_mul
  map_zero' := cast_zero
  map_add' := cast_add
#align rat.cast_hom Rat.castHom

variable {α}

@[simp]
theorem coe_cast_hom : ⇑(castHom α) = ((↑) : ℚ → α) :=
  rfl
#align rat.coe_cast_hom Rat.coe_cast_hom

@[simp, norm_cast]
theorem cast_inv (n) : ((n⁻¹ : ℚ) : α) = (n : α)⁻¹ :=
  map_inv₀ (castHom α) _
#align rat.cast_inv Rat.cast_inv

@[simp, norm_cast]
theorem cast_div (m n) : ((m / n : ℚ) : α) = m / n :=
  map_div₀ (castHom α) _ _
#align rat.cast_div Rat.cast_div

@[simp, norm_cast]
theorem cast_zpow (q : ℚ) (n : ℤ) : ((q ^ n : ℚ) : α) = (q : α) ^ n :=
  map_zpow₀ (castHom α) q n
#align rat.cast_zpow Rat.cast_zpow

@[norm_cast]
theorem cast_mk (a b : ℤ) : (a /. b : α) = a / b := by
  simp only [divInt_eq_div, cast_div, cast_coe_int]
#align rat.cast_mk Rat.cast_mk

@[simp, norm_cast]
theorem cast_pow (q) (k : ℕ) : ((q : ℚ) ^ k : α) = (q : α) ^ k :=
  (castHom α).map_pow q k
#align rat.cast_pow Rat.cast_pow

end WithDivRing

section LinearOrderedField

variable {K : Type _} [LinearOrderedField K]

theorem cast_pos_of_pos {r : ℚ} (hr : 0 < r) : (0 : K) < r := by
  rw [Rat.cast_def]
  exact div_pos (Int.cast_pos.2 <| num_pos_iff_pos.2 hr) (Nat.cast_pos.2 r.pos)
#align rat.cast_pos_of_pos Rat.cast_pos_of_pos

@[mono]
theorem cast_strictMono : StrictMono ((↑) : ℚ → K) := fun m n => by
  simpa only [sub_pos, cast_sub] using @cast_pos_of_pos K _ (n - m)
#align rat.cast_strict_mono Rat.cast_strictMono

@[mono]
theorem cast_mono : Monotone ((↑) : ℚ → K) :=
  cast_strictMono.monotone
#align rat.cast_mono Rat.cast_mono

/-- Coercion from `ℚ` as an order embedding. -/
@[simps!]
def castOrderEmbedding : ℚ ↪o K :=
  OrderEmbedding.ofStrictMono (↑) cast_strictMono
#align rat.cast_order_embedding Rat.castOrderEmbedding
#align rat.cast_order_embedding_apply Rat.castOrderEmbedding_apply

@[simp, norm_cast]
theorem cast_le {m n : ℚ} : (m : K) ≤ n ↔ m ≤ n :=
  castOrderEmbedding.le_iff_le
#align rat.cast_le Rat.cast_le

@[simp, norm_cast]
theorem cast_lt {m n : ℚ} : (m : K) < n ↔ m < n :=
  cast_strictMono.lt_iff_lt
#align rat.cast_lt Rat.cast_lt

@[simp]
theorem cast_nonneg {n : ℚ} : 0 ≤ (n : K) ↔ 0 ≤ n := by
      norm_cast

#align rat.cast_nonneg Rat.cast_nonneg

@[simp]
theorem cast_nonpos {n : ℚ} : (n : K) ≤ 0 ↔ n ≤ 0 := by
      norm_cast
#align rat.cast_nonpos Rat.cast_nonpos

@[simp]
theorem cast_pos {n : ℚ} : (0 : K) < n ↔ 0 < n := by
      norm_cast
#align rat.cast_pos Rat.cast_pos

@[simp]
theorem cast_lt_zero {n : ℚ} : (n : K) < 0 ↔ n < 0 := by
      norm_cast
#align rat.cast_lt_zero Rat.cast_lt_zero

@[simp, norm_cast]
theorem cast_min {a b : ℚ} : (↑(min a b) : K) = min (a : K) (b : K) :=
  (@cast_mono K _).map_min
#align rat.cast_min Rat.cast_min

@[simp, norm_cast]
theorem cast_max {a b : ℚ} : (↑(max a b) : K) = max (a : K) (b : K) :=
  (@cast_mono K _).map_max
#align rat.cast_max Rat.cast_max

@[simp, norm_cast]
theorem cast_abs {q : ℚ} : ((|q| : ℚ) : K) = |(q : K)| := by simp [abs_eq_max_neg]
#align rat.cast_abs Rat.cast_abs

open Set

@[simp]
theorem preimage_cast_Icc (a b : ℚ) : (↑) ⁻¹' Icc (a : K) b = Icc a b := by
  ext x
  simp
#align rat.preimage_cast_Icc Rat.preimage_cast_Icc

@[simp]
theorem preimage_cast_Ico (a b : ℚ) : (↑) ⁻¹' Ico (a : K) b = Ico a b := by
  ext x
  simp
#align rat.preimage_cast_Ico Rat.preimage_cast_Ico

@[simp]
theorem preimage_cast_Ioc (a b : ℚ) : (↑) ⁻¹' Ioc (a : K) b = Ioc a b := by
  ext x
  simp
#align rat.preimage_cast_Ioc Rat.preimage_cast_Ioc

@[simp]
theorem preimage_cast_Ioo (a b : ℚ) : (↑) ⁻¹' Ioo (a : K) b = Ioo a b := by
  ext x
  simp
#align rat.preimage_cast_Ioo Rat.preimage_cast_Ioo

@[simp]
theorem preimage_cast_Ici (a : ℚ) : (↑) ⁻¹' Ici (a : K) = Ici a := by
  ext x
  simp
#align rat.preimage_cast_Ici Rat.preimage_cast_Ici

@[simp]
theorem preimage_cast_Iic (a : ℚ) : (↑) ⁻¹' Iic (a : K) = Iic a := by
  ext x
  simp
#align rat.preimage_cast_Iic Rat.preimage_cast_Iic

@[simp]
theorem preimage_cast_Ioi (a : ℚ) : (↑) ⁻¹' Ioi (a : K) = Ioi a := by
  ext x
  simp
#align rat.preimage_cast_Ioi Rat.preimage_cast_Ioi

@[simp]
theorem preimage_cast_Iio (a : ℚ) : (↑) ⁻¹' Iio (a : K) = Iio a := by
  ext x
  simp
#align rat.preimage_cast_Iio Rat.preimage_cast_Iio

end LinearOrderedField

-- Porting note: statement made more explicit
@[norm_cast]
theorem cast_id (n : ℚ) : Rat.cast n = n := rfl
#align rat.cast_id Rat.cast_id

@[simp]
theorem cast_eq_id : ((↑) : ℚ → ℚ) = id :=
  funext fun _ => rfl
#align rat.cast_eq_id Rat.cast_eq_id

@[simp]
theorem cast_hom_rat : castHom ℚ = RingHom.id ℚ :=
  RingHom.ext cast_id
#align rat.cast_hom_rat Rat.cast_hom_rat

end Rat

open Rat

@[simp]
theorem map_ratCast [DivisionRing α] [DivisionRing β] [RingHomClass F α β] (f : F) (q : ℚ) :
    f q = q := by rw [cast_def, map_div₀, map_intCast, map_natCast, cast_def]
#align map_rat_cast map_ratCast

@[simp]
theorem eq_ratCast {k} [DivisionRing k] [RingHomClass F ℚ k] (f : F) (r : ℚ) : f r = r := by
  rw [← map_ratCast f, Rat.cast_id]
#align eq_rat_cast eq_ratCast

namespace MonoidWithZeroHom

variable {M₀ : Type _} [MonoidWithZero M₀] [MonoidWithZeroHomClass F ℚ M₀] {f g : F}

/-- If `f` and `g` agree on the integers then they are equal `φ`. -/
theorem ext_rat' (h : ∀ m : ℤ, f m = g m) : f = g :=
  (FunLike.ext f g) fun r => by
    rw [← r.num_div_den, div_eq_mul_inv, map_mul, map_mul, h, ← Int.cast_ofNat,
      eq_on_inv₀ f g]
    apply h
#align monoid_with_zero_hom.ext_rat' MonoidWithZeroHom.ext_rat'

/-- If `f` and `g` agree on the integers then they are equal `φ`.

See note [partially-applied ext lemmas] for why `comp` is used here. -/
@[ext]
theorem ext_rat {f g : ℚ →*₀ M₀}
    (h : f.comp (Int.castRingHom ℚ : ℤ →*₀ ℚ) = g.comp (Int.castRingHom ℚ)) : f = g :=
  ext_rat' <| FunLike.congr_fun h
#align monoid_with_zero_hom.ext_rat MonoidWithZeroHom.ext_rat

/-- Positive integer values of a morphism `φ` and its value on `-1` completely determine `φ`. -/
theorem ext_rat_on_pnat (same_on_neg_one : f (-1) = g (-1))
    (same_on_pnat : ∀ n : ℕ, 0 < n → f n = g n) : f = g :=
  ext_rat' <|
    FunLike.congr_fun <|
      show
        (f : ℚ →*₀ M₀).comp (Int.castRingHom ℚ : ℤ →*₀ ℚ) =
          (g : ℚ →*₀ M₀).comp (Int.castRingHom ℚ : ℤ →*₀ ℚ)
        from ext_int' (by simpa) (by simpa)
#align monoid_with_zero_hom.ext_rat_on_pnat MonoidWithZeroHom.ext_rat_on_pnat

end MonoidWithZeroHom

/-- Any two ring homomorphisms from `ℚ` to a semiring are equal. If the codomain is a division ring,
then this lemma follows from `eq_ratCast`. -/
theorem RingHom.ext_rat {R : Type _} [Semiring R] [RingHomClass F ℚ R] (f g : F) : f = g :=
  MonoidWithZeroHom.ext_rat' <|
    RingHom.congr_fun <|
      ((f : ℚ →+* R).comp (Int.castRingHom ℚ)).ext_int ((g : ℚ →+* R).comp (Int.castRingHom ℚ))
#align ring_hom.ext_rat RingHom.ext_rat

instance Rat.subsingleton_ringHom {R : Type _} [Semiring R] : Subsingleton (ℚ →+* R) :=
  ⟨RingHom.ext_rat⟩
#align rat.subsingleton_ring_hom Rat.subsingleton_ringHom

section SMul

namespace Rat

variable {K : Type _} [DivisionRing K]

instance (priority := 100) distribSMul : DistribSMul ℚ K where
  smul := (· • ·)
  smul_zero a := by rw [smul_def, mul_zero]
  smul_add a x y := by rw [smul_def, smul_def, smul_def, mul_add]
#align rat.distrib_smul Rat.distribSMul

instance isScalarTower_right : IsScalarTower ℚ K K :=
  ⟨fun a x y => by simp only [smul_def, smul_eq_mul, mul_assoc]⟩
#align rat.is_scalar_tower_right Rat.isScalarTower_right

end Rat

end SMul


import recover

-- We are given two fields, `K` and `F`
variables {K F : Type*} [field K] [field F]

open module finite_dimensional
open_locale tensor_product

/-
NOTE: This introduces notation `[a]ₘ` for `a : Kˣ`, where `[a]ₘ` is the element of
the base-change `F ⊗[ℤ] (additive Kˣ)` corresponding to `a`.
-/
notation `[`:max a`]ₘ`:max := 1 ⊗ₜ (additive.of_mul a)

lemma one_tmul_mul (a b : Kˣ) : ([a * b]ₘ : F ⊗[ℤ] additive Kˣ) =
  [a]ₘ + [b]ₘ :=
tensor_product.tmul_add _ _ _

lemma one_tmul_inv (a : Kˣ) : ([a⁻¹]ₘ : F ⊗[ℤ] additive Kˣ) = - [a]ₘ :=
tensor_product.tmul_neg _ _

/-
We consider the weak topology on `dual F (F ⊗[ℤ] additive Kˣ)`.
This is just the pointwise convergence topology, i.e. the topology
induced by the product topology on the type of functions `F ⊗[ℤ] additive Kˣ → F`
where `F` is given the discrete topology.
-/
def module.dual.weak_topology :
  topological_space (dual F (F ⊗[ℤ] additive Kˣ)) :=
topological_space.induced (λ e a, e a) $
(@Pi.topological_space (F ⊗[ℤ] additive Kˣ) (λ _, F) $ λ a, ⊥)

/-
We only activate this topological space instance for this file.
-/
local attribute [instance]
  module.dual.weak_topology

-- We now assume that `F` is a prime field.
-- The is defined as saying that every element `a : F` can be expressed as
-- `m/n` for some `m : ℤ` and some `n : ℕ` such that `(n : F) ≠ 0`.
variable [is_prime_field F]

example : is_prime_field ℚ := infer_instance
example (p : ℕ) [fact (nat.prime p)] : is_prime_field (zmod p) := infer_instance

/- The main theorem of alternating pairs (prime field case). -/
theorem main_alternating_theorem_of_prime_field
  -- Given a submodule `D` of `dual F (F ⊗[ℤ] additive Kˣ)`,
  (D : submodule F (dual F (F ⊗[ℤ] additive Kˣ)))
  -- which is: (1) closed with respect to the topology introduced above;
  (h1 : is_closed (D : set (dual F (F ⊗[ℤ] additive Kˣ))))
  -- (2) every element of `D` maps `[(-1 : Kˣ)]ₘ` to zero;
  (h2 : ∀ (f : dual F (F ⊗[ℤ] additive Kˣ)) (hf : f ∈ D), f [-1]ₘ = 0)
  -- (3) satisfies the alternating condition, i.e. whenever `u v : Kˣ` satisfy
  -- `(u : K) + v = 1`, then `f [u]ₘ * g [v]ₘ = f [v]ₘ * g [u]ₘ`.
  (h3 : ∀ (u v : Kˣ) (huv : (u : K) + v = 1)
    (f g : dual F (F ⊗[ℤ] additive Kˣ))
    (hf : f ∈ D) (hg : g ∈ D),
    f [u]ₘ * g [v]ₘ = f [v]ₘ * g [u]ₘ) :
  -- Then there exists a valuation subring `R` of `K`,
  ∃ (R : valuation_subring K)
  -- and another submodule `I` of `dual F (F ⊗[ℤ] additive Kˣ)`
    (I : submodule F (dual F (F ⊗[ℤ] additive Kˣ)))
    -- which is closed, and such that the following hold:
    (Iclosed : is_closed (I : set (dual F (F ⊗[ℤ] additive Kˣ))))
    -- (1) `I` is contained in `D`;
    (le : I ≤ D)
    -- (2) the elements `f` of `I` satisfy `f [u]ₘ = 0` for `R`-units;
    (units : ∀ (u : Kˣ) (hu : u ∈ R.unit_group)
      (f : dual F (F ⊗[ℤ] additive Kˣ))
      (hf : f ∈ I), f [u]ₘ = 0)
    -- (3) the elements `f` of `D` satisfy `f [u]ₘ = 0` for `R`-principal-units;
    (punits : ∀ (u : Kˣ) (hu : u ∈ R.principal_unit_group)
      (f : dual F (F ⊗[ℤ] additive Kˣ))
      (hf : f ∈ D), f [u]ₘ = 0)
    -- (4) the quotient `D / I` is finite dimensional;
    (fd : finite_dimensional F (↥D ⧸ I.comap D.subtype)),
    -- and `I` has codimension at most one in `D`.
    finrank F (↥D ⧸ I.comap D.subtype) ≤ 1 :=
begin
  rw submodule.is_closed_iff at h1,
  let T := D.dual_annihilator_comap,
  have hTD : T.dual_annihilator = D,
  { dsimp only [T],
    exact h1.dual_comap_dual },
  have hacl : D.acl,
  { refine ⟨h1, h3, h2⟩ },
  have hacl' : T.dual_annihilator.acl,
  { convert hacl },
  obtain ⟨R,H,le,units,principal_units,fd,codim⟩ := main_theorem_mul T hacl',
  let I := H.dual_annihilator,
  obtain ⟨e⟩ : nonempty ((↥D ⧸ submodule.comap D.subtype I) ≃ₗ[F]
    (dual F (↥H ⧸ T.comap H.subtype))),
  { dsimp [I],
    rw ← hTD,
    use submodule.dual_mod_comap_iso T H le,},
  refine ⟨R, I, _, _, _, _, _, _⟩,
  { rw submodule.is_closed_iff, apply submodule.is_closed_dual_annihilator },
  { intros f hf, rw [← hTD, submodule.mem_dual_annihilator],
    intros w hw,
    dsimp [I] at hf,
    erw submodule.mem_dual_annihilator at hf,
    apply hf, apply le, assumption },
  { intros u hu,
    rw ← submodule.mem_dual_annihilator_comap_iff,
    dsimp [I], rw submodule.dual_annihilator_dual_annihilator_comap,
    apply units, assumption },
  { intros u hu,
    rw ← submodule.mem_dual_annihilator_comap_iff,
    apply principal_units, assumption },
  { resetI, apply e.symm.finite_dimensional },
  { resetI, rwa [e.finrank_eq, subspace.dual_finrank_eq] },
end


/-
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, Floris van Doorn
-/
import category_theory.eq_to_hom
import data.ulift

/-!
# Discrete categories

We define `discrete α` as a structure containing a term `a : α` for any type `α`,
and use this type alias to provide a `small_category` instance
whose only morphisms are the identities.

There is an annoying technical difficulty that it has turned out to be inconvenient
to allow categories with morphisms living in `Prop`,
so instead of defining `X ⟶ Y` in `discrete α` as `X = Y`,
one might define it as `plift (X = Y)`.
In fact, to allow `discrete α` to be a `small_category`
(i.e. with morphisms in the same universe as the objects),
we actually define the hom type `X ⟶ Y` as `ulift (plift (X = Y))`.

`discrete.functor` promotes a function `f : I → C` (for any category `C`) to a functor
`discrete.functor f : discrete I ⥤ C`.

Similarly, `discrete.nat_trans` and `discrete.nat_iso` promote `I`-indexed families of morphisms,
or `I`-indexed families of isomorphisms to natural transformations or natural isomorphism.

We show equivalences of types are the same as (categorical) equivalences of the corresponding
discrete categories.
-/

namespace category_theory

-- morphism levels before object levels. See note [category_theory universes].
universes v₁ v₂ v₃ u₁ u₂ u₃

/--
A wrapper for promoting any type to a category,
with the only morphisms being equalities.
-/
-- This is intentionally a structure rather than a type synonym
-- to enforce using `discrete_equiv` (or `discrete.mk` and `discrete.as`) to move between
-- `discrete α` and `α`. Otherwise there is too much API leakage.
@[ext] structure discrete (α : Type u₁) :=
(as : α)

@[simp] lemma discrete.mk_as {α : Type u₁} (X : discrete α) : discrete.mk X.as = X :=
by { ext, refl, }

/-- `discrete α` is equivalent to the original type `α`.-/
@[simps] def discrete_equiv {α : Type u₁} : discrete α ≃ α :=
{ to_fun := discrete.as,
  inv_fun := discrete.mk,
  left_inv := by tidy,
  right_inv := by tidy, }

instance {α : Type u₁} [decidable_eq α] : decidable_eq (discrete α) :=
discrete_equiv.decidable_eq

/--
The "discrete" category on a type, whose morphisms are equalities.

Because we do not allow morphisms in `Prop` (only in `Type`),
somewhat annoyingly we have to define `X ⟶ Y` as `ulift (plift (X = Y))`.

See <https://stacks.math.columbia.edu/tag/001A>
-/
instance discrete_category (α : Type u₁) : small_category (discrete α) :=
{ hom  := λ X Y, ulift (plift (X.as = Y.as)),
  id   := λ X, ulift.up (plift.up rfl),
  comp := λ X Y Z g f, by { cases X, cases Y, cases Z, rcases f with ⟨⟨⟨⟩⟩⟩, exact g } }

namespace discrete

variables {α : Type u₁}

instance [inhabited α] : inhabited (discrete α) :=
⟨⟨default⟩⟩

instance [subsingleton α] : subsingleton (discrete α) :=
⟨by { intros, ext, apply subsingleton.elim, }⟩

/-- A simple tactic to run `cases` on any `discrete α` hypotheses. -/
meta def _root_.tactic.discrete_cases : tactic unit :=
`[cases_matching* [discrete _, (_ : discrete _) ⟶ (_ : discrete _), plift _]]

run_cmd add_interactive [``tactic.discrete_cases]

local attribute [tidy] tactic.discrete_cases

instance [unique α] : unique (discrete α) :=
unique.mk' (discrete α)

/-- Extract the equation from a morphism in a discrete category. -/

/-- Promote an equation between the wrapped terms in `X Y : discrete α` to a morphism `X ⟶ Y`
in the discrete category. -/
abbreviation eq_to_hom {X Y : discrete α} (h : X.as = Y.as) : X ⟶ Y :=
eq_to_hom (by { ext, exact h, })

/-- Promote an equation between the wrapped terms in `X Y : discrete α` to an isomorphism `X ≅ Y`
in the discrete category. -/
abbreviation eq_to_iso {X Y : discrete α} (h : X.as = Y.as) : X ≅ Y :=
eq_to_iso (by { ext, exact h, })

/-- A variant of `eq_to_hom` that lifts terms to the discrete category. -/
abbreviation eq_to_hom' {a b : α} (h : a = b) : discrete.mk a ⟶ discrete.mk b :=
eq_to_hom h

/-- A variant of `eq_to_iso` that lifts terms to the discrete category. -/
abbreviation eq_to_iso' {a b : α} (h : a = b) : discrete.mk a ≅ discrete.mk b :=
eq_to_iso h

@[simp] lemma id_def (X : discrete α) : ulift.up (plift.up (eq.refl X.as)) = 𝟙 X := rfl

variables {C : Type u₂} [category.{v₂} C]

instance {I : Type u₁} {i j : discrete I} (f : i ⟶ j) : is_iso f :=
⟨⟨eq_to_hom (eq_of_hom f).symm, by tidy⟩⟩

/--
Any function `I → C` gives a functor `discrete I ⥤ C`.
-/
def functor {I : Type u₁} (F : I → C) : discrete I ⥤ C :=
{ obj := F ∘ discrete.as,
  map := λ X Y f, by { discrete_cases, cases f, exact 𝟙 (F X), } }

@[simp] lemma functor_obj  {I : Type u₁} (F : I → C) (i : I) :
  (discrete.functor F).obj (discrete.mk i) = F i := rfl

lemma functor_map  {I : Type u₁} (F : I → C) {i : discrete I} (f : i ⟶ i) :
  (discrete.functor F).map f = 𝟙 (F i.as) :=
by tidy

/--
For functors out of a discrete category,
a natural transformation is just a collection of maps,
as the naturality squares are trivial.
-/
@[simps]
def nat_trans {I : Type u₁} {F G : discrete I ⥤ C}
  (f : Π i : discrete I, F.obj i ⟶ G.obj i) : F ⟶ G :=
{ app := f,
  naturality' := λ X Y g, by { discrete_cases, cases g, simp, } }

/--
For functors out of a discrete category,
a natural isomorphism is just a collection of isomorphisms,
as the naturality squares are trivial.
-/
@[simps]
def nat_iso {I : Type u₁} {F G : discrete I ⥤ C}
  (f : Π i : discrete I, F.obj i ≅ G.obj i) : F ≅ G :=
nat_iso.of_components f (λ X Y g, by { discrete_cases, cases g, simp, })

@[simp]
lemma nat_iso_app {I : Type u₁} {F G : discrete I ⥤ C}
  (f : Π i : discrete I, F.obj i ≅ G.obj i) (i : discrete I) :
  (discrete.nat_iso f).app i = f i :=
by tidy

/-- Every functor `F` from a discrete category is naturally isomorphic (actually, equal) to
  `discrete.functor (F.obj)`. -/
@[simp]
def nat_iso_functor {I : Type u₁} {F : discrete I ⥤ C} :
  F ≅ discrete.functor (F.obj ∘ discrete.mk) :=
nat_iso $ λ i, by { discrete_cases, refl, }

/-- Composing `discrete.functor F` with another functor `G` amounts to composing `F` with `G.obj` -/
@[simp]
def comp_nat_iso_discrete {I : Type u₁} {D : Type u₃} [category.{v₃} D]
 (F : I → C) (G : C ⥤ D) : discrete.functor F ⋙ G ≅ discrete.functor (G.obj ∘ F) :=
nat_iso $ λ i, iso.refl _

/--
We can promote a type-level `equiv` to
an equivalence between the corresponding `discrete` categories.
-/
@[simps]
def equivalence {I : Type u₁} {J : Type u₂} (e : I ≃ J) : discrete I ≌ discrete J :=
{ functor := discrete.functor (discrete.mk ∘ (e : I → J)),
  inverse := discrete.functor (discrete.mk ∘ (e.symm : J → I)),
  unit_iso := discrete.nat_iso (λ i, eq_to_iso (by { discrete_cases, simp })),
  counit_iso := discrete.nat_iso (λ j, eq_to_iso (by { discrete_cases, simp })), }

/-- We can convert an equivalence of `discrete` categories to a type-level `equiv`. -/
@[simps]
def equiv_of_equivalence {α : Type u₁} {β : Type u₂} (h : discrete α ≌ discrete β) : α ≃ β :=
{ to_fun := discrete.as ∘ h.functor.obj ∘ discrete.mk,
  inv_fun := discrete.as ∘ h.inverse.obj ∘ discrete.mk,
  left_inv := λ a, by simpa using eq_of_hom (h.unit_iso.app (discrete.mk a)).2,
  right_inv := λ a, by simpa using eq_of_hom (h.counit_iso.app (discrete.mk a)).1, }

end discrete

namespace discrete
variables {J : Type v₁}

open opposite

/-- A discrete category is equivalent to its opposite category. -/
@[simps functor_obj_as inverse_obj]
protected def opposite (α : Type u₁) : (discrete α)ᵒᵖ ≌ discrete α :=
let F : discrete α ⥤ (discrete α)ᵒᵖ := discrete.functor (λ x, op (discrete.mk x)) in
begin
  refine equivalence.mk (functor.left_op F) F _
    (discrete.nat_iso $ λ X, by { discrete_cases, simp [F] }),
  refine nat_iso.of_components (λ X, by { tactic.op_induction', discrete_cases, simp [F], }) _,
  tidy
end

variables {C : Type u₂} [category.{v₂} C]

@[simp] lemma functor_map_id
  (F : discrete J ⥤ C) {j : discrete J} (f : j ⟶ j) : F.map f = 𝟙 (F.obj j) :=
begin
  have h : f = 𝟙 j, { cases f, cases f, ext, },
  rw h,
  simp,
end

end discrete

end category_theory


/-
Copyright (c) 2020 Heather Macbeth. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Heather Macbeth, Frédéric Dupuis
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.analysis.normed_space.hahn_banach
import Mathlib.analysis.normed_space.inner_product
import Mathlib.PostPort

universes u_1 u_2 u v

namespace Mathlib

/-!
# The topological dual of a normed space

In this file we define the topological dual of a normed space, and the bounded linear map from
a normed space into its double dual.

We also prove that, for base field `𝕜` with `[is_R_or_C 𝕜]`, this map is an isometry.

We then consider inner product spaces, with base field over `ℝ` (the corresponding results for `ℂ`
will require the definition of conjugate-linear maps). We define `to_dual_map`, a continuous linear
map from `E` to its dual, which maps an element `x` of the space to `λ y, ⟪x, y⟫`. We check
(`to_dual_map_isometry`) that this map is an isometry onto its image, and particular is injective.
We also define `to_dual'` as the function taking taking a vector to its dual for a base field `𝕜`
with `[is_R_or_C 𝕜]`; this is a function and not a linear map.

Finally, under the hypothesis of completeness (i.e., for Hilbert spaces), we prove the Fréchet-Riesz
representation (`to_dual_map_eq_top`), which states the surjectivity: every element of the dual
of a Hilbert space `E` has the form `λ u, ⟪x, u⟫` for some `x : E`.  This permits the map
`to_dual_map` to be upgraded to an (isometric) continuous linear equivalence, `to_dual`, between a
Hilbert space and its dual.

## References

* [M. Einsiedler and T. Ward, *Functional Analysis, Spectral Theory, and Applications*]
  [EinsiedlerWard2017]

## Tags

dual, Fréchet-Riesz
-/

namespace normed_space

/-- The topological dual of a normed space `E`. -/
def dual (𝕜 : Type u_1) [nondiscrete_normed_field 𝕜] (E : Type u_2) [normed_group E] [normed_space 𝕜 E] :=
  continuous_linear_map 𝕜 E 𝕜

protected instance dual.inhabited (𝕜 : Type u_1) [nondiscrete_normed_field 𝕜] (E : Type u_2) [normed_group E] [normed_space 𝕜 E] : Inhabited (dual 𝕜 E) :=
  { default := 0 }

/-- The inclusion of a normed space in its double (topological) dual. -/
def inclusion_in_double_dual' (𝕜 : Type u_1) [nondiscrete_normed_field 𝕜] (E : Type u_2) [normed_group E] [normed_space 𝕜 E] (x : E) : dual 𝕜 (dual 𝕜 E) :=
  linear_map.mk_continuous (linear_map.mk (fun (f : dual 𝕜 E) => coe_fn f x) sorry sorry) (norm x) sorry

@[simp] theorem dual_def (𝕜 : Type u_1) [nondiscrete_normed_field 𝕜] (E : Type u_2) [normed_group E] [normed_space 𝕜 E] (x : E) (f : dual 𝕜 E) : coe_fn (inclusion_in_double_dual' 𝕜 E x) f = coe_fn f x :=
  rfl

theorem double_dual_bound (𝕜 : Type u_1) [nondiscrete_normed_field 𝕜] (E : Type u_2) [normed_group E] [normed_space 𝕜 E] (x : E) : norm (inclusion_in_double_dual' 𝕜 E x) ≤ norm x := sorry

/-- The inclusion of a normed space in its double (topological) dual, considered
   as a bounded linear map. -/
def inclusion_in_double_dual (𝕜 : Type u_1) [nondiscrete_normed_field 𝕜] (E : Type u_2) [normed_group E] [normed_space 𝕜 E] : continuous_linear_map 𝕜 E (dual 𝕜 (dual 𝕜 E)) :=
  linear_map.mk_continuous (linear_map.mk (fun (x : E) => inclusion_in_double_dual' 𝕜 E x) sorry sorry) 1 sorry

/-- If one controls the norm of every `f x`, then one controls the norm of `x`.
    Compare `continuous_linear_map.op_norm_le_bound`. -/
theorem norm_le_dual_bound {𝕜 : Type v} [is_R_or_C 𝕜] {E : Type u} [normed_group E] [normed_space 𝕜 E] (x : E) {M : ℝ} (hMp : 0 ≤ M) (hM : ∀ (f : dual 𝕜 E), norm (coe_fn f x) ≤ M * norm f) : norm x ≤ M := sorry

/-- The inclusion of a normed space in its double dual is an isometry onto its image.-/
theorem inclusion_in_double_dual_isometry {𝕜 : Type v} [is_R_or_C 𝕜] {E : Type u} [normed_group E] [normed_space 𝕜 E] (x : E) : norm (coe_fn (inclusion_in_double_dual 𝕜 E) x) = norm x := sorry

end normed_space

namespace inner_product_space

/--
Given some `x` in an inner product space, we can define its dual as the continuous linear map
`λ y, ⟪x, y⟫`. Consider using `to_dual` or `to_dual_map` instead in the real case.
-/
def to_dual' (𝕜 : Type u_1) {E : Type u_2} [is_R_or_C 𝕜] [inner_product_space 𝕜 E] : E →+ normed_space.dual 𝕜 E :=
  add_monoid_hom.mk
    (fun (x : E) => linear_map.mk_continuous (linear_map.mk (fun (y : E) => inner x y) sorry sorry) (norm x) sorry) sorry
    sorry

@[simp] theorem to_dual'_apply (𝕜 : Type u_1) {E : Type u_2} [is_R_or_C 𝕜] [inner_product_space 𝕜 E] {x : E} {y : E} : coe_fn (coe_fn (to_dual' 𝕜) x) y = inner x y :=
  rfl

/-- In an inner product space, the norm of the dual of a vector `x` is `∥x∥` -/
@[simp] theorem norm_to_dual'_apply (𝕜 : Type u_1) {E : Type u_2} [is_R_or_C 𝕜] [inner_product_space 𝕜 E] (x : E) : norm (coe_fn (to_dual' 𝕜) x) = norm x := sorry

theorem to_dual'_isometry (𝕜 : Type u_1) (E : Type u_2) [is_R_or_C 𝕜] [inner_product_space 𝕜 E] : isometry ⇑(to_dual' 𝕜) :=
  add_monoid_hom.isometry_of_norm (to_dual' 𝕜) (norm_to_dual'_apply 𝕜)

/--
Fréchet-Riesz representation: any `ℓ` in the dual of a Hilbert space `E` is of the form
`λ u, ⟪y, u⟫` for some `y : E`, i.e. `to_dual'` is surjective.
-/
theorem to_dual'_surjective (𝕜 : Type u_1) (E : Type u_2) [is_R_or_C 𝕜] [inner_product_space 𝕜 E] [complete_space E] : function.surjective ⇑(to_dual' 𝕜) := sorry

/-- In a real inner product space `F`, the function that takes a vector `x` in `F` to its dual
`λ y, ⟪x, y⟫` is a continuous linear map. If the space is complete (i.e. is a Hilbert space),
consider using `to_dual` instead. -/
-- TODO extend to `is_R_or_C` (requires a definition of conjugate linear maps)

def to_dual_map {F : Type u_1} [inner_product_space ℝ F] : continuous_linear_map ℝ F (normed_space.dual ℝ F) :=
  linear_map.mk_continuous (linear_map.mk ⇑(to_dual' ℝ) sorry sorry) 1 sorry

@[simp] theorem to_dual_map_apply {F : Type u_1} [inner_product_space ℝ F] {x : F} {y : F} : coe_fn (coe_fn to_dual_map x) y = inner x y :=
  rfl

/-- In an inner product space, the norm of the dual of a vector `x` is `∥x∥` -/
@[simp] theorem norm_to_dual_map_apply {F : Type u_1} [inner_product_space ℝ F] (x : F) : norm (coe_fn to_dual_map x) = norm x :=
  norm_to_dual'_apply ℝ x

theorem to_dual_map_isometry {F : Type u_1} [inner_product_space ℝ F] : isometry ⇑to_dual_map :=
  add_monoid_hom.isometry_of_norm (to_dual' ℝ) norm_to_dual_map_apply

theorem to_dual_map_injective {F : Type u_1} [inner_product_space ℝ F] : function.injective ⇑to_dual_map :=
  isometry.injective to_dual_map_isometry

@[simp] theorem ker_to_dual_map {F : Type u_1} [inner_product_space ℝ F] : continuous_linear_map.ker to_dual_map = ⊥ :=
  iff.mpr linear_map.ker_eq_bot to_dual_map_injective

@[simp] theorem to_dual_map_eq_iff_eq {F : Type u_1} [inner_product_space ℝ F] {x : F} {y : F} : coe_fn to_dual_map x = coe_fn to_dual_map y ↔ x = y :=
  function.injective.eq_iff (iff.mp linear_map.ker_eq_bot ker_to_dual_map)

/--
Fréchet-Riesz representation: any `ℓ` in the dual of a real Hilbert space `F` is of the form
`λ u, ⟪y, u⟫` for some `y` in `F`.  See `inner_product_space.to_dual` for the continuous linear
equivalence thus induced.
-/
-- TODO extend to `is_R_or_C` (requires a definition of conjugate linear maps)

theorem range_to_dual_map {F : Type u_1} [inner_product_space ℝ F] [complete_space F] : continuous_linear_map.range to_dual_map = ⊤ :=
  iff.mpr linear_map.range_eq_top (to_dual'_surjective ℝ F)

/--
Fréchet-Riesz representation: If `F` is a Hilbert space, the function that takes a vector in `F` to
its dual is a continuous linear equivalence.  -/
def to_dual {F : Type u_1} [inner_product_space ℝ F] [complete_space F] : continuous_linear_equiv ℝ F (normed_space.dual ℝ F) :=
  continuous_linear_equiv.of_isometry (continuous_linear_map.to_linear_map to_dual_map) to_dual_map_isometry
    range_to_dual_map

/--
Fréchet-Riesz representation: If `F` is a Hilbert space, the function that takes a vector in `F` to
its dual is an isometry.  -/
def isometric.to_dual {F : Type u_1} [inner_product_space ℝ F] [complete_space F] : F ≃ᵢ normed_space.dual ℝ F :=
  isometric.mk (linear_equiv.to_equiv (continuous_linear_equiv.to_linear_equiv to_dual)) (to_dual'_isometry ℝ F)

@[simp] theorem to_dual_apply {F : Type u_1} [inner_product_space ℝ F] [complete_space F] {x : F} {y : F} : coe_fn (coe_fn to_dual x) y = inner x y :=
  rfl

@[simp] theorem to_dual_eq_iff_eq {F : Type u_1} [inner_product_space ℝ F] [complete_space F] {x : F} {y : F} : coe_fn to_dual x = coe_fn to_dual y ↔ x = y :=
  function.injective.eq_iff (continuous_linear_equiv.injective to_dual)

theorem to_dual_eq_iff_eq' {F : Type u_1} [inner_product_space ℝ F] [complete_space F] {x : F} {x' : F} : (∀ (y : F), inner x y = inner x' y) ↔ x = x' := sorry

@[simp] theorem norm_to_dual_apply {F : Type u_1} [inner_product_space ℝ F] [complete_space F] (x : F) : norm (coe_fn to_dual x) = norm x :=
  norm_to_dual_map_apply x

/-- In a Hilbert space, the norm of a vector in the dual space is the norm of its corresponding
primal vector. -/
theorem norm_to_dual_symm_apply {F : Type u_1} [inner_product_space ℝ F] [complete_space F] (ℓ : normed_space.dual ℝ F) : norm (coe_fn (continuous_linear_equiv.symm to_dual) ℓ) = norm ℓ := sorry


import Mathlib.Data.Nat.Basic
import Lean4.Range

open Std Std.Range Std.Range.forIn

def ff (n : ℕ) : ℕ := Id.run do
  let mut r := 0
  for _ in [: n] do
    r ← r + 1
  return r

def incStep : ℕ → ℕ → Id (ForInStep ℕ) := λ _ r => ForInStep.yield (r + 1)

variable {m : Type u → Type v} [Monad m]

-- loop f start stop 1 init (Nat.zero_lt_one) = init
theorem singleIncStep {k : ℕ} : Std.Range.forIn (mkRange' k k.succ) init incStep = init + 1 := by
  simp [mkRange']
  rw [Range.forIn]
  simp
  rw [loop]
  simp [incStep, eq_false (Nat.not_succ_le_self k)]
  exact emptyStep' Nat.le.refl

-- For a function that's independent of the loop variable
-- The result only depends on the number of iterations
-- Notes: In `f i r`, `i` is the loop variable and `r` is the "program state"
-- Notes: `Std.Range.forIn range init f`
-- TODO: Generalise `f` to `ℕ → β → Id (ForInStep β)` (I do not know how to do this)
theorem succInvariantLt {k : ℕ} {init : β} {f : ℕ → β → Id (ForInStep β)} (start stop skip : ℕ)
  (hf : ∀ i j : ℕ, f i = f j) (hs : start ≤ stop) : Range.forIn (mkRange' start stop) init f
    = Range.forIn (mkRange' (start + skip) (stop + skip)) init f := by
  -- Proof idea: define new function g that's independent of index, then prove they're equivalent
  -- Then just prove it's the g applied stop - start times by induction
  let g := f 0
  have hf' : f = λ _ r => g r := by
    funext
    rw [hf _ 0]
  cases' Nat.exists_eq_add_of_le hs with k hk
  rw [hk]
  induction' k with t ht
  simp [emptyStep]
  sorry

theorem succInvariant {k : ℕ} {init : β} {f : ℕ → β → Id (ForInStep β)} (start stop skip : ℕ)
  (hf : ∀ i j : ℕ, f i = f j) : Range.forIn (mkRange' start stop) init f
    = Range.forIn (mkRange' (start + skip) (stop + skip)) init f := by
  by_cases h : start < stop
  exact @succInvariantLt _ k init f start stop skip hf (Nat.le_of_lt h)
  simp [Range.forIn, mkRange', emptyStep' (Nat.ge_of_not_lt h),
        emptyStep' (Nat.add_le_add_right (Nat.ge_of_not_lt h) skip)]

theorem incStepAlwaysYield : ∀ (i r : ℕ), ForInStep.isYield (incStep i r) := by
  simp [incStep, ForInStep.isYield]

-- This is kind of an ad-hoc theorem for the simple program
-- Also, I have a question: `s` is a Nat here and the loop (RHS) is a `Id Nat`
-- How do they compare?
theorem stateInvariant {n : ℕ} (init : ℕ) :
  Id.run (Range.forIn (mkRange' 0 n) init incStep) + 1
  = Range.forIn (mkRange' 0 n.succ) init incStep := by
  induction' n with k hk
  -- n = 0
  simp [Id.run, Range.forIn, incStep, mkRange']
  rw [loop, loop]
  simp [Id.run, Range.forIn, incStep, Nat.one_eq_succ_zero]
  rw [emptyStep' Nat.le.refl]
  -- n = k → n = k + 1
  simp [Id.run] at *
  rw [rangeDecompose _ k.succ k.succ.succ _ incStepAlwaysYield, Id.run, ← hk, singleIncStep]
  simp [Nat.le_succ]

theorem ff' : ff n = n := by
  induction' n with k hk
  simp
  let h := (@stateInvariant k 0)
  simp [ff, Id.run, Range.forIn, loop, ← succInvariant] at *
  simp [Id.run, incStep, mkRange', Range.forIn] at h
  conv_rhs => rw [← hk, Nat.succ_eq_add_one]
  sorry

namespace Examples

example : ff 5 = 5 := ff'

end Examples

/-
**Test Functions**

Here are some test functions.
-/

def f1 (n : ℕ) : ℕ := Id.run do
  let mut r := 0
  for i in [: 2 * n] do
    if i % 2 = 0 then
      continue
    if i = 2 * n then
      break
    r ← r + i
  return r

/-
forIn RANGE r fun i r =>
  let r := r;
  let __do_jp := fun r y =>
    let __do_jp := fun r y => do
      let r ← r + i
      let r : ℕ := r
      pure PUnit.unit
      pure (ForInStep.yield r);
    if i = 2 * n then pure (ForInStep.done r) -- `break`
    else do
      let y ← pure PUnit.unit
      __do_jp r y;
  if i % 2 = 0 then pure (ForInStep.yield r)  -- `continue`
  else do
    let y ← pure PUnit.unit
    __do_jp r y
-/

#print f1
#eval f1 50


/-
Copyright (c) 2021 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import category_theory.subobject.limits

/-!
# Image-to-kernel comparison maps

Whenever `f : A ⟶ B` and `g : B ⟶ C` satisfy `w : f ≫ g = 0`,
we have `image_le_kernel f g w : image_subobject f ≤ kernel_subobject g`
(assuming the appropriate images and kernels exist).

`image_to_kernel f g w` is the corresponding morphism between objects in `C`.

We define `homology f g w` of such a pair as the cokernel of `image_to_kernel f g w`.
-/

universes v u

open category_theory category_theory.limits

variables {ι : Type*}
variables {V : Type u} [category.{v} V] [has_zero_morphisms V]

open_locale classical
noncomputable theory

section
variables {A B C : V} (f : A ⟶ B) [has_image f] (g : B ⟶ C) [has_kernel g]

lemma image_le_kernel (w : f ≫ g = 0) :
  image_subobject f ≤ kernel_subobject g :=
image_subobject_le_mk _ _ (kernel.lift _ _ w) (by simp)

/--
The canonical morphism `image_subobject f ⟶ kernel_subobject g` when `f ≫ g = 0`.
-/
@[derive mono]
def image_to_kernel (w : f ≫ g = 0) :
  (image_subobject f : V) ⟶ (kernel_subobject g : V) :=
(subobject.of_le _ _ (image_le_kernel _ _ w))

/-- Prefer `image_to_kernel`. -/
@[simp] lemma subobject_of_le_as_image_to_kernel (w : f ≫ g = 0) (h) :
  subobject.of_le (image_subobject f) (kernel_subobject g) h = image_to_kernel f g w :=
rfl

@[simp, reassoc]
lemma image_to_kernel_arrow (w : f ≫ g = 0) :
  image_to_kernel f g w ≫ (kernel_subobject g).arrow = (image_subobject f).arrow :=
by simp [image_to_kernel]

-- This is less useful as a `simp` lemma than it initially appears,
-- as it "loses" the information the morphism factors through the image.
lemma factor_thru_image_subobject_comp_image_to_kernel (w : f ≫ g = 0) :
  factor_thru_image_subobject f ≫ image_to_kernel f g w = factor_thru_kernel_subobject g f w :=
by { ext, simp, }

end

section
variables {A B C : V} (f : A ⟶ B) (g : B ⟶ C)

@[simp]
lemma image_to_kernel_zero_left [has_kernels V] [has_zero_object V] {w} :
  image_to_kernel (0 : A ⟶ B) g w = 0 :=
by { ext, simp, }

lemma image_to_kernel_zero_right [has_images V] {w} :
  image_to_kernel f (0 : B ⟶ C) w =
    (image_subobject f).arrow ≫ inv (kernel_subobject (0 : B ⟶ C)).arrow :=
by { ext, simp }

section
variables [has_kernels V] [has_images V]

lemma image_to_kernel_comp_right {D : V} (h : C ⟶ D) (w : f ≫ g = 0) :
  image_to_kernel f (g ≫ h) (by simp [reassoc_of w]) =
    image_to_kernel f g w ≫ subobject.of_le _ _ (kernel_subobject_comp_le g h) :=
by { ext, simp }

lemma image_to_kernel_comp_left {Z : V} (h : Z ⟶ A) (w : f ≫ g = 0) :
  image_to_kernel (h ≫ f) g (by simp [w]) =
    subobject.of_le _ _ (image_subobject_comp_le h f) ≫ image_to_kernel f g w :=
by { ext, simp }

@[simp]
lemma image_to_kernel_comp_mono {D : V} (h : C ⟶ D) [mono h] (w) :
  image_to_kernel f (g ≫ h) w =
  image_to_kernel f g ((cancel_mono h).mp (by simpa using w : (f ≫ g) ≫ h = 0 ≫ h)) ≫
    (subobject.iso_of_eq _ _ (kernel_subobject_comp_mono g h)).inv :=
by { ext, simp, }

@[simp]
lemma image_to_kernel_epi_comp {Z : V} (h : Z ⟶ A) [epi h] (w) :
  image_to_kernel (h ≫ f) g w =
  subobject.of_le _ _ (image_subobject_comp_le h f) ≫
    image_to_kernel f g ((cancel_epi h).mp (by simpa using w : h ≫ f ≫ g = h ≫ 0)) :=
by { ext, simp, }

end

@[simp]
lemma image_to_kernel_comp_hom_inv_comp [has_equalizers V] [has_images V] {Z : V} {i : B ≅ Z} (w) :
  image_to_kernel (f ≫ i.hom) (i.inv ≫ g) w =
  (image_subobject_comp_iso _ _).hom ≫ image_to_kernel f g (by simpa using w) ≫
    (kernel_subobject_iso_comp i.inv g).inv :=
by { ext, simp, }

open_locale zero_object

/--
`image_to_kernel` for `A --0--> B --g--> C`, where `g` is a mono is itself an epi
(i.e. the sequence is exact at `B`).
-/
instance image_to_kernel_epi_of_zero_of_mono [has_kernels V] [has_zero_object V] [mono g] :
  epi (image_to_kernel (0 : A ⟶ B) g (by simp)) :=
epi_of_target_iso_zero _ (kernel_subobject_iso g ≪≫ kernel.of_mono g)

/--
`image_to_kernel` for `A --f--> B --0--> C`, where `g` is an epi is itself an epi
(i.e. the sequence is exact at `B`).
-/
instance image_to_kernel_epi_of_epi_of_zero [has_images V] [epi f] :
  epi (image_to_kernel f (0 : B ⟶ C) (by simp)) :=
begin
  simp only [image_to_kernel_zero_right],
  haveI := epi_image_of_epi f,
  rw ←image_subobject_arrow,
  refine @epi_comp _ _ _ _ _ _ (epi_comp _ _) _ _,
end

end

section
variables {A B C : V} (f : A ⟶ B) [has_image f] (g : B ⟶ C) [has_kernel g]

/--
The homology of a pair of morphisms `f : A ⟶ B` and `g : B ⟶ C` satisfying `f ≫ g = 0`
is the cokernel of the `image_to_kernel` morphism for `f` and `g`.
-/
def homology {A B C : V} (f : A ⟶ B) [has_image f] (g : B ⟶ C) [has_kernel g]
  (w : f ≫ g = 0) [has_cokernel (image_to_kernel f g w)] : V :=
cokernel (image_to_kernel f g w)

section
variables (w : f ≫ g = 0) [has_cokernel (image_to_kernel f g w)]

/-- The morphism from cycles to homology. -/
def homology.π : (kernel_subobject g : V) ⟶ homology f g w :=
cokernel.π _

@[simp] lemma homology.condition : image_to_kernel f g w ≫ homology.π f g w = 0 :=
cokernel.condition _

/--
To construct a map out of homology, it suffices to construct a map out of the cycles
which vanishes on boundaries.
-/
def homology.desc {D : V} (k : (kernel_subobject g : V) ⟶ D) (p : image_to_kernel f g w ≫ k = 0) :
  homology f g w ⟶ D :=
cokernel.desc _ k p

@[simp, reassoc]
lemma homology.π_desc
  {D : V} (k : (kernel_subobject g : V) ⟶ D) (p : image_to_kernel f g w ≫ k = 0) :
  homology.π f g w ≫ homology.desc f g w k p = k :=
by { simp [homology.π, homology.desc], }

/-- To check two morphisms out of `homology f g w` are equal, it suffices to check on cycles. -/
@[ext]
lemma homology.ext {D : V} {k k' : homology f g w ⟶ D}
  (p : homology.π f g w ≫ k = homology.π f g w ≫ k') : k = k' :=
by { ext, exact p, }

/-- `homology 0 0 _` is just the middle object. -/
@[simps]
def homology_zero_zero [has_zero_object V]
  [has_image (0 : A ⟶ B)] [has_cokernel (image_to_kernel (0 : A ⟶ B) (0 : B ⟶ C) (by simp))] :
  homology (0 : A ⟶ B) (0 : B ⟶ C) (by simp) ≅ B :=
{ hom := homology.desc (0 : A ⟶ B) (0 : B ⟶ C) (by simp) (kernel_subobject 0).arrow (by simp),
  inv := inv (kernel_subobject 0).arrow ≫ homology.π _ _ _, }

end

section
variables {f g} (w : f ≫ g = 0)
  {A' B' C' : V} {f' : A' ⟶ B'} [has_image f'] {g' : B' ⟶ C'} [has_kernel g'] (w' : f' ≫ g' = 0)
  (α : arrow.mk f ⟶ arrow.mk f') [has_image_map α] (β : arrow.mk g ⟶ arrow.mk g')
  {A₁ B₁ C₁ : V} {f₁ : A₁ ⟶ B₁} [has_image f₁] {g₁ : B₁ ⟶ C₁} [has_kernel g₁] (w₁ : f₁ ≫ g₁ = 0)
  {A₂ B₂ C₂ : V} {f₂ : A₂ ⟶ B₂} [has_image f₂] {g₂ : B₂ ⟶ C₂} [has_kernel g₂] (w₂ : f₂ ≫ g₂ = 0)
  {A₃ B₃ C₃ : V} {f₃ : A₃ ⟶ B₃} [has_image f₃] {g₃ : B₃ ⟶ C₃} [has_kernel g₃] (w₃ : f₃ ≫ g₃ = 0)
  (α₁ : arrow.mk f₁ ⟶ arrow.mk f₂) [has_image_map α₁] (β₁ : arrow.mk g₁ ⟶ arrow.mk g₂)
  (α₂ : arrow.mk f₂ ⟶ arrow.mk f₃) [has_image_map α₂] (β₂ : arrow.mk g₂ ⟶ arrow.mk g₃)

/--
Given compatible commutative squares between
a pair `f g` and a pair `f' g'` satisfying `f ≫ g = 0` and `f' ≫ g' = 0`,
the `image_to_kernel` morphisms intertwine the induced map on kernels and the induced map on images.
-/
@[reassoc]
lemma image_subobject_map_comp_image_to_kernel (p : α.right = β.left) :
  image_to_kernel f g w ≫ kernel_subobject_map β =
    image_subobject_map α ≫ image_to_kernel f' g' w' :=
by { ext, simp [p], }

variables [has_cokernel (image_to_kernel f g w)] [has_cokernel (image_to_kernel f' g' w')]
variables [has_cokernel (image_to_kernel f₁ g₁ w₁)]
variables [has_cokernel (image_to_kernel f₂ g₂ w₂)]
variables [has_cokernel (image_to_kernel f₃ g₃ w₃)]

/--
Given compatible commutative squares between
a pair `f g` and a pair `f' g'` satisfying `f ≫ g = 0` and `f' ≫ g' = 0`,
we get a morphism on homology.
-/
def homology.map (p : α.right = β.left) :
  homology f g w ⟶ homology f' g' w' :=
cokernel.desc _ (kernel_subobject_map β ≫ cokernel.π _)
  begin
    rw [image_subobject_map_comp_image_to_kernel_assoc w w' α β p],
    simp only [cokernel.condition, comp_zero],
  end

@[simp, reassoc]
lemma homology.π_map (p : α.right = β.left) :
  homology.π f g w ≫ homology.map w w' α β p = kernel_subobject_map β ≫ homology.π f' g' w' :=
by simp only [homology.π, homology.map, cokernel.π_desc]

@[simp, reassoc]
lemma homology.map_desc (p : α.right = β.left)
  {D : V} (k : (kernel_subobject g' : V) ⟶ D) (z : image_to_kernel f' g' w' ≫ k = 0) :
  homology.map w w' α β p ≫ homology.desc f' g' w' k z =
    homology.desc f g w (kernel_subobject_map β ≫ k)
      (by simp only [image_subobject_map_comp_image_to_kernel_assoc w w' α β p, z, comp_zero]) :=
by ext; simp only [homology.π_desc, homology.π_map_assoc]

@[simp]
lemma homology.map_id : homology.map w w (𝟙 _) (𝟙 _) rfl = 𝟙 _ :=
by ext; simp only [homology.π_map, kernel_subobject_map_id, category.id_comp, category.comp_id]

/-- Auxiliary lemma for homology computations. -/
lemma homology.comp_right_eq_comp_left
  {V : Type*} [category V] {A₁ B₁ C₁ A₂ B₂ C₂ A₃ B₃ C₃ : V}
  {f₁ : A₁ ⟶ B₁} {g₁ : B₁ ⟶ C₁} {f₂ : A₂ ⟶ B₂} {g₂ : B₂ ⟶ C₂} {f₃ : A₃ ⟶ B₃} {g₃ : B₃ ⟶ C₃}
  {α₁ : arrow.mk f₁ ⟶ arrow.mk f₂} {β₁ : arrow.mk g₁ ⟶ arrow.mk g₂}
  {α₂ : arrow.mk f₂ ⟶ arrow.mk f₃} {β₂ : arrow.mk g₂ ⟶ arrow.mk g₃}
  (p₁ : α₁.right = β₁.left) (p₂ : α₂.right = β₂.left) :
  (α₁ ≫ α₂).right = (β₁ ≫ β₂).left :=
by simp only [comma.comp_left, comma.comp_right, p₁, p₂]

@[reassoc]
lemma homology.map_comp (p₁ : α₁.right = β₁.left) (p₂ : α₂.right = β₂.left) :
  homology.map w₁ w₂ α₁ β₁ p₁ ≫ homology.map w₂ w₃ α₂ β₂ p₂ =
    homology.map w₁ w₃ (α₁ ≫ α₂) (β₁ ≫ β₂) (homology.comp_right_eq_comp_left p₁ p₂) :=
by ext; simp only [kernel_subobject_map_comp, homology.π_map_assoc, homology.π_map, category.assoc]

/-- An isomorphism between two three-term complexes induces an isomorphism on homology. -/
def homology.map_iso (α : arrow.mk f₁ ≅ arrow.mk f₂) (β : arrow.mk g₁ ≅ arrow.mk g₂)
  (p : α.hom.right = β.hom.left) :
  homology f₁ g₁ w₁ ≅ homology f₂ g₂ w₂ :=
{ hom := homology.map w₁ w₂ α.hom β.hom p,
  inv := homology.map w₂ w₁ α.inv β.inv
  (by { rw [← cancel_mono (α.hom.right), ← comma.comp_right, α.inv_hom_id, comma.id_right, p,
      ← comma.comp_left, β.inv_hom_id, comma.id_left], refl }),
  hom_inv_id' := by { rw [homology.map_comp], convert homology.map_id _; rw [iso.hom_inv_id] },
  inv_hom_id' := by { rw [homology.map_comp], convert homology.map_id _; rw [iso.inv_hom_id] } }

end

end

section
variables {A B C : V} {f : A ⟶ B} {g : B ⟶ C} (w : f ≫ g = 0)
  {f' : A ⟶ B} {g' : B ⟶ C} (w' : f' ≫ g' = 0)
  [has_kernels V] [has_cokernels V] [has_images V] [has_image_maps V]

/-- Custom tactic to golf and speedup boring proofs in `homology.congr`. -/
private meta def aux_tac : tactic unit :=
`[ dsimp only [auto_param_eq], erw [category.id_comp, category.comp_id], cases pf, cases pg, refl ]

/--
`homology f g w ≅ homology f' g' w'` if `f = f'` and `g = g'`.
(Note the objects are not changing here.)
-/
@[simps]
def homology.congr (pf : f = f') (pg : g = g') : homology f g w ≅ homology f' g' w' :=
{ hom := homology.map w w' ⟨𝟙 _, 𝟙 _, by aux_tac⟩ ⟨𝟙 _, 𝟙 _, by aux_tac⟩ rfl,
  inv := homology.map w' w ⟨𝟙 _, 𝟙 _, by aux_tac⟩ ⟨𝟙 _, 𝟙 _, by aux_tac⟩ rfl,
  hom_inv_id' := begin
    cases pf, cases pg, rw [homology.map_comp, ← homology.map_id],
    congr' 1; exact category.comp_id _,
  end,
  inv_hom_id' := begin
    cases pf, cases pg, rw [homology.map_comp, ← homology.map_id],
    congr' 1; exact category.comp_id _,
  end, }

end

/-!
We provide a variant `image_to_kernel' : image f ⟶ kernel g`,
and use this to give alternative formulas for `homology f g w`.
-/
section image_to_kernel'
variables {A B C : V} (f : A ⟶ B) (g : B ⟶ C) (w : f ≫ g = 0)
  [has_kernels V] [has_images V]

/--
While `image_to_kernel f g w` provides a morphism
`image_subobject f ⟶ kernel_subobject g`
in terms of the subobject API,
this variant provides a morphism
`image f ⟶ kernel g`,
which is sometimes more convenient.
-/
def image_to_kernel' (w : f ≫ g = 0) : image f ⟶ kernel g :=
kernel.lift g (image.ι f) (by { ext, simpa using w, })

@[simp] lemma image_subobject_iso_image_to_kernel' (w : f ≫ g = 0) :
  (image_subobject_iso f).hom ≫ image_to_kernel' f g w =
    image_to_kernel f g w ≫ (kernel_subobject_iso g).hom :=
by { ext, simp [image_to_kernel'], }

@[simp] lemma image_to_kernel'_kernel_subobject_iso (w : f ≫ g = 0) :
  image_to_kernel' f g w ≫ (kernel_subobject_iso g).inv =
    (image_subobject_iso f).inv ≫ image_to_kernel f g w :=
by { ext, simp [image_to_kernel'], }

variables [has_cokernels V]

/--
`homology f g w` can be computed as the cokernel of `image_to_kernel' f g w`.
-/
def homology_iso_cokernel_image_to_kernel' (w : f ≫ g = 0) :
  homology f g w ≅ cokernel (image_to_kernel' f g w) :=
{ hom := cokernel.map _ _ (image_subobject_iso f).hom (kernel_subobject_iso g).hom
    (by simp only [image_subobject_iso_image_to_kernel']),
  inv := cokernel.map _ _ (image_subobject_iso f).inv (kernel_subobject_iso g).inv
    (by simp only [image_to_kernel'_kernel_subobject_iso]),
  hom_inv_id' := begin
    apply coequalizer.hom_ext,
    simp only [iso.hom_inv_id_assoc, cokernel.π_desc, cokernel.π_desc_assoc, category.assoc,
      coequalizer_as_cokernel],
    exact (category.comp_id _).symm,
  end,
  inv_hom_id' := by { ext1, simp only [iso.inv_hom_id_assoc, cokernel.π_desc, category.comp_id,
    cokernel.π_desc_assoc, category.assoc], } }

variables [has_equalizers V]

/--
`homology f g w` can be computed as the cokernel of `kernel.lift g f w`.
-/
def homology_iso_cokernel_lift (w : f ≫ g = 0) :
  homology f g w ≅ cokernel (kernel.lift g f w) :=
begin
  refine homology_iso_cokernel_image_to_kernel' f g w ≪≫ _,
  have p : factor_thru_image f ≫ image_to_kernel' f g w = kernel.lift g f w,
  { ext, simp [image_to_kernel'], },
  exact (cokernel_epi_comp _ _).symm ≪≫ cokernel_iso_of_eq p,
end

end image_to_kernel'


/-
Copyright (c) 2017 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Sebastian Ullrich
-/
prelude
import init.control.monad init.meta.interactive
import init.control.state init.control.except init.control.reader init.control.option
universes u v

open function
open tactic

meta def control_laws_tac := whnf_target >> intros >> to_expr ``(rfl) >>= exact

class is_lawful_functor (f : Type u → Type v) [functor f] : Prop :=
(map_const_eq : ∀ {α β : Type u}, ((<$) : α → f β → f α) = (<$>) ∘ const β . control_laws_tac)
-- `functor` is indeed a categorical functor
(id_map       : Π {α : Type u} (x : f α), id <$> x = x)
(comp_map     : Π {α β γ : Type u} (g : α → β) (h : β → γ) (x : f α), (h ∘ g) <$> x = h <$> g <$> x)

export is_lawful_functor (map_const_eq id_map comp_map)
attribute [simp] id_map
-- `comp_map` does not make a good simp lemma

class is_lawful_applicative (f : Type u → Type v) [applicative f] extends is_lawful_functor f : Prop :=
(seq_left_eq  : ∀ {α β : Type u} (a : f α) (b : f β), a <* b = const β <$> a <*> b . control_laws_tac)
(seq_right_eq : ∀ {α β : Type u} (a : f α) (b : f β), a *> b = const α id <$> a <*> b . control_laws_tac)
-- applicative laws
(pure_seq_eq_map : ∀ {α β : Type u} (g : α → β) (x : f α), pure g <*> x = g <$> x)
(map_pure        : ∀ {α β : Type u} (g : α → β) (x : α), g <$> (pure x : f α) = pure (g x))
(seq_pure        : ∀ {α β : Type u} (g : f (α → β)) (x : α), g <*> pure x = (λ g : α → β, g x) <$> g)
(seq_assoc       : ∀ {α β γ : Type u} (x : f α) (g : f (α → β)) (h : f (β → γ)), h <*> (g <*> x) = (@comp α β γ <$> h) <*> g <*> x)
-- default functor law
(comp_map := begin intros; simp [(pure_seq_eq_map _ _).symm, seq_assoc, map_pure, seq_pure] end)

export is_lawful_applicative (seq_left_eq seq_right_eq pure_seq_eq_map map_pure seq_pure seq_assoc)
attribute [simp] map_pure seq_pure

-- applicative "law" derivable from other laws
@[simp] theorem pure_id_seq {α : Type u} {f : Type u → Type v} [applicative f] [is_lawful_applicative f] (x : f α) : pure id <*> x = x :=
by simp [pure_seq_eq_map]

class is_lawful_monad (m : Type u → Type v) [monad m] extends is_lawful_applicative m : Prop :=
(bind_pure_comp_eq_map : ∀ {α β : Type u} (f : α → β) (x : m α), x >>= pure ∘ f = f <$> x  . control_laws_tac)
(bind_map_eq_seq : ∀ {α β : Type u} (f : m (α → β)) (x : m α), f >>= (<$> x) = f <*> x  . control_laws_tac)
-- monad laws
(pure_bind : ∀ {α β : Type u} (x : α) (f : α → m β), pure x >>= f = f x)
(bind_assoc : ∀ {α β γ : Type u} (x : m α) (f : α → m β) (g : β → m γ),
  x >>= f >>= g = x >>= λ x, f x >>= g)
(pure_seq_eq_map := by intros; rw ←bind_map_eq_seq; simp [pure_bind])
(map_pure := by intros; rw ←bind_pure_comp_eq_map; simp [pure_bind])
(seq_pure := by intros; rw ←bind_map_eq_seq; simp [map_pure, bind_pure_comp_eq_map])
(seq_assoc := by intros; simp [(bind_pure_comp_eq_map _ _).symm,
                               (bind_map_eq_seq _ _).symm,
                               bind_assoc, pure_bind])

export is_lawful_monad (bind_pure_comp_eq_map bind_map_eq_seq pure_bind bind_assoc)
attribute [simp] pure_bind

-- monad "law" derivable from other laws
@[simp] theorem bind_pure {α : Type u} {m : Type u → Type v} [monad m] [is_lawful_monad m] (x : m α) : x >>= pure = x :=
show x >>= pure ∘ id = x, by rw bind_pure_comp_eq_map; simp [id_map]

lemma bind_ext_congr {α β} {m : Type u → Type v} [has_bind m] {x : m α} {f g : α → m β} :
  (∀ a, f a = g a) →
  x >>= f = x >>= g :=
λ h, by simp [show f = g, from funext h]

lemma map_ext_congr {α β} {m : Type u → Type v} [functor m] {x : m α} {f g : α → β} :
  (∀ a, f a = g a) →
  (f <$> x : m β) = g <$> x :=
λ h, by simp [show f = g, from funext h]

-- instances of previously defined monads

namespace id
variables {α β : Type}
@[simp] lemma map_eq (x : id α) (f : α → β) : f <$> x = f x := rfl
@[simp] lemma bind_eq (x : id α) (f : α → id β) : x >>= f = f x := rfl
@[simp] lemma pure_eq (a : α) : (pure a : id α) = a := rfl
end id

instance : is_lawful_monad id :=
by refine { .. }; intros; refl

namespace state_t
section
  variable  {σ : Type u}
  variable  {m : Type u → Type v}
  variables {α β : Type u}
  variables (x : state_t σ m α) (st : σ)

  lemma ext {x x' : state_t σ m α} (h : ∀ st, x.run st = x'.run st) : x = x' :=
  by cases x; cases x'; simp [show x = x', from funext h]

  variable  [monad m]

  @[simp] lemma run_pure (a) : (pure a : state_t σ m α).run st = pure (a, st) := rfl
  @[simp] lemma run_bind (f : α → state_t σ m β) :
    (x >>= f).run st = x.run st >>= λ p, (f p.1).run p.2 :=
  by apply bind_ext_congr; intro a; cases a; simp [state_t.bind, state_t.run]
  @[simp] lemma run_map (f : α → β) [is_lawful_monad m] :
    (f <$> x).run st = (λ p : α × σ, (f (prod.fst p), prod.snd p)) <$> x.run st :=
  begin
    rw ← bind_pure_comp_eq_map _ (x.run st),
    change (x >>= pure ∘ f).run st = _,
    simp
  end
  @[simp]

instance (m : Type u → Type v) [monad m] [is_lawful_monad m] (σ : Type u) : is_lawful_monad (state_t σ m) :=
{ id_map := by intros; apply state_t.ext; intro; simp; erw id_map,
  pure_bind := by { intros, apply state_t.ext, simp },
  bind_assoc := by { intros, apply state_t.ext, simp [bind_assoc] } }

namespace except_t
  variables {α β ε : Type u} {m : Type u → Type v} (x : except_t ε m α)

  lemma ext {x x' : except_t ε m α} (h : x.run = x'.run) : x = x' :=
  by cases x; cases x'; simp * at *

  variable [monad m]

  @[simp] lemma run_pure (a) : (pure a : except_t ε m α).run = pure (@except.ok ε α a) := rfl
  @[simp] lemma run_bind (f : α → except_t ε m β) : (x >>= f).run = x.run >>= except_t.bind_cont f :=
  rfl
  @[simp] lemma run_map (f : α → β) [is_lawful_monad m] : (f <$> x).run = except.map f <$> x.run :=
  begin
    rw ← bind_pure_comp_eq_map _ x.run,
    change x.run >>= except_t.bind_cont (pure ∘ f) = _,
    apply bind_ext_congr,
    intro a; cases a; simp [except_t.bind_cont, except.map]
  end
  @[simp] lemma run_monad_lift {n} [has_monad_lift_t n m] (x : n α) :
    (monad_lift x : except_t ε m α).run = except.ok <$> (monad_lift x : m α) := rfl
  @[simp] lemma run_monad_map {m' n n'} [monad m'] [monad_functor_t n n' m m'] (f : ∀ {α}, n α → n' α) :
    (monad_map @f x : except_t ε m' α).run = monad_map @f x.run := rfl
end except_t

instance (m : Type u → Type v) [monad m] [is_lawful_monad m] (ε : Type u) : is_lawful_monad (except_t ε m) :=
{ id_map := begin
    intros, apply except_t.ext, simp only [except_t.run_map],
    rw [map_ext_congr, id_map],
    intro a, cases a; refl
  end,
  bind_pure_comp_eq_map := begin
    intros, apply except_t.ext, simp only [except_t.run_map, except_t.run_bind],
    rw [bind_ext_congr, bind_pure_comp_eq_map],
    intro a, cases a; refl
  end,
  bind_assoc := begin
    intros, apply except_t.ext, simp only [except_t.run_bind, bind_assoc],
    rw [bind_ext_congr],
    intro a, cases a; simp [except_t.bind_cont]
  end,
  pure_bind := by intros; apply except_t.ext; simp [except_t.bind_cont] }

namespace reader_t
section
  variable  {ρ : Type u}
  variable  {m : Type u → Type v}
  variables {α β : Type u}
  variables (x : reader_t ρ m α) (r : ρ)

  lemma ext {x x' : reader_t ρ m α} (h : ∀ r, x.run r = x'.run r) : x = x' :=
  by cases x; cases x'; simp [show x = x', from funext h]

  variable  [monad m]

  @[simp] lemma run_pure (a) : (pure a : reader_t ρ m α).run r = pure a := rfl
  @[simp] lemma run_bind (f : α → reader_t ρ m β) :
    (x >>= f).run r = x.run r >>= λ a, (f a).run r := rfl
  @[simp] lemma run_map (f : α → β) [is_lawful_monad m] : (f <$> x).run r = f <$> x.run r :=
  by rw ← bind_pure_comp_eq_map _ (x.run r); refl
  @[simp] lemma run_monad_lift {n} [has_monad_lift_t n m] (x : n α) :
    (monad_lift x : reader_t ρ m α).run r = (monad_lift x : m α) := rfl
  @[simp] lemma run_monad_map {m' n n'} [monad m'] [monad_functor_t n n' m m'] (f : ∀ {α}, n α → n' α) :
    (monad_map @f x : reader_t ρ m' α).run r = monad_map @f (x.run r) := rfl
  @[simp] lemma run_read : (reader_t.read : reader_t ρ m ρ).run r = pure r := rfl
end
end reader_t

instance (ρ : Type u) (m : Type u → Type v) [monad m] [is_lawful_monad m] : is_lawful_monad (reader_t ρ m) :=
{ id_map := by intros; apply reader_t.ext; intro; simp,
  pure_bind := by intros; apply reader_t.ext; intro; simp,
  bind_assoc := by intros; apply reader_t.ext; intro; simp [bind_assoc] }

namespace option_t
  variables {α β : Type u} {m : Type u → Type v} (x : option_t m α)

  lemma ext {x x' : option_t m α} (h : x.run = x'.run) : x = x' :=
  by cases x; cases x'; simp * at *

  variable [monad m]

  @[simp] lemma run_pure (a) : (pure a : option_t m α).run = pure (some a) := rfl
  @[simp] lemma run_bind (f : α → option_t m β) : (x >>= f).run = x.run >>= option_t.bind_cont f :=
  rfl
  @[simp] lemma run_map (f : α → β) [is_lawful_monad m] : (f <$> x).run = option.map f <$> x.run :=
  begin
    rw ← bind_pure_comp_eq_map _ x.run,
    change x.run >>= option_t.bind_cont (pure ∘ f) = _,
    apply bind_ext_congr,
    intro a; cases a; simp [option_t.bind_cont, option.map, option.bind]
  end
  @[simp] lemma run_monad_lift {n} [has_monad_lift_t n m] (x : n α) :
    (monad_lift x : option_t m α).run = some <$> (monad_lift x : m α) := rfl
  @[simp] lemma run_monad_map {m' n n'} [monad m'] [monad_functor_t n n' m m'] (f : ∀ {α}, n α → n' α) :
    (monad_map @f x : option_t m' α).run = monad_map @f x.run := rfl
end option_t

instance (m : Type u → Type v) [monad m] [is_lawful_monad m] : is_lawful_monad (option_t m) :=
{ id_map := begin
    intros, apply option_t.ext, simp only [option_t.run_map],
    rw [map_ext_congr, id_map],
    intro a, cases a; refl
  end,
  bind_assoc := begin
    intros, apply option_t.ext, simp only [option_t.run_bind, bind_assoc],
    rw [bind_ext_congr],
    intro a, cases a; simp [option_t.bind_cont]
  end,
  pure_bind := by intros; apply option_t.ext; simp [option_t.bind_cont] }


import tactic.times_table
import number_theory.quad_ring.basic

open polynomial

open_locale big_operators

-- TODO: could generalize to infinite ι
noncomputable def has_mul_of_table {ι R S : Type*} [fintype ι] [semiring R]
  [hS : add_comm_monoid S] [module R S] (b : basis ι R S) (table : ι → ι → ι → R) :
    has_mul S :=
{ mul := λ x y, b.equiv_fun.symm (λ k, ∑ i j, b.repr x i * b.repr y j * table i j k) }

lemma mul_def' {ι R S : Type*} [fintype ι] [semiring R]
  [hS : add_comm_monoid S] [module R S] (b : basis ι R S) (table : ι → ι → ι → R)
  (x y : S) (k : ι) :
  b.repr (by { letI := has_mul_of_table b table; exact x * y }) k = ∑ i j, b.repr x i * b.repr y j * table i j k :=
show b.repr (b.equiv_fun.symm (λ k, ∑ i j, b.repr x i * b.repr y j * table i j k)) k =
  ∑ i j, b.repr x i * b.repr y j * table i j k,
by simp only [← b.equiv_fun_apply, b.equiv_fun.apply_symm_apply]

lemma mul_def {ι R S : Type*} [fintype ι] [semiring R]
  [hS : add_comm_monoid S] [module R S] (b : basis ι R S) (table : ι → ι → ι → R)
  (i j k : ι) :
  b.repr (by { letI := has_mul_of_table b table; exact b i * b j }) k = table i j k :=
begin
  letI := classical.dec_eq ι,
  rw [mul_def', fintype.sum_eq_single i, fintype.sum_eq_single j],
  { simp },
  { intros k hk, simp [finsupp.single_eq_of_ne hk.symm] },
  { intros k hk, simp [finsupp.single_eq_of_ne hk.symm] },
end

-- TODO: could generalize to infinite ι
-- See note [reducible non-instances]
@[reducible]
noncomputable def non_unital_non_assoc_semiring_of_table {ι R S : Type*} [fintype ι] [semiring R]
  [hS : add_comm_monoid S] [module R S] (b : basis ι R S) (table : ι → ι → ι → R) :
    non_unital_non_assoc_semiring S :=
{ zero := 0,
  add := (+),
  mul := λ x y, b.equiv_fun.symm (λ k, ∑ i j, b.repr x i * b.repr y j * table i j k),
  zero_mul := λ x, b.ext_elem (λ k, by { rw mul_def', simp only [_root_.map_zero, finsupp.zero_apply, zero_mul, finset.sum_const_zero] }),
  mul_zero := λ x, b.ext_elem (λ k, by { rw mul_def', simp only [_root_.map_zero, finsupp.zero_apply, mul_zero, zero_mul, finset.sum_const_zero] }),
  left_distrib := λ x y z, b.ext_elem (λ k, by { rw mul_def', simp only [_root_.map_add, finsupp.add_apply, mul_add, add_mul, finset.sum_add_distrib, ← b.equiv_fun_apply, b.equiv_fun.apply_symm_apply] }),
  right_distrib := λ x y z, b.ext_elem (λ k, by { rw mul_def', simp only [_root_.map_add, finsupp.add_apply, mul_add, add_mul, finset.sum_add_distrib, ← b.equiv_fun_apply, b.equiv_fun.apply_symm_apply] }),
  .. hS }

namespace sqrt_d

variables (d : ℚ)

def table : fin 2 → fin 2 → fin 2 → ℚ :=
![![![1, 0], ![0, 1]],
  ![![0, 1], ![d, 0]]]

/-- Alternative definition of `quad_ring ℚ 0 d` -/
def sqrt_d (d : ℚ) := fin 2 → ℚ

section

local attribute [semireducible] sqrt_d

variables {d}

def mk (a b : ℚ) : sqrt_d d := ![a, b]

variables (d)

def sqrt : sqrt_d d := ![0, 1]

instance : add_comm_group (sqrt_d d) := pi.add_comm_group

noncomputable instance : non_unital_non_assoc_semiring (sqrt_d d) :=
non_unital_non_assoc_semiring_of_table (pi.basis_fun ℚ (fin 2)) (table d)

instance : module ℚ (sqrt_d d) := pi.module _ _ _

noncomputable abbreviation basis : basis (fin 2) ℚ (sqrt_d d) := pi.basis_fun ℚ (fin 2)

instance : smul_comm_class ℚ (sqrt_d d) (sqrt_d d) :=
⟨λ m n a, (basis d).ext_elem (λ k, by {
  rw [smul_eq_mul, smul_eq_mul, linear_equiv.map_smul, finsupp.smul_apply, mul_def', mul_def'],
  simp,
  ring })⟩

instance : is_scalar_tower ℚ (sqrt_d d) (sqrt_d d) :=
⟨λ m n a, (basis d).ext_elem (λ k, by {
  rw [smul_eq_mul, smul_eq_mul, linear_equiv.map_smul, finsupp.smul_apply, mul_def', mul_def'],
  simp,
  ring })⟩

noncomputable def times_table : times_table (fin 2) ℚ (sqrt_d d) :=
{ basis := by convert pi.basis_fun ℚ (fin 2),
  table := table d,
  unfold_mul' := sorry }

end

@[times_table_simps] lemma table_apply (i j k : fin 2) :
  (sqrt_d.times_table d).table i j k =
  ![![![1, 0], ![0, 1]],
    ![![0, 1], ![d, 0]]] i j k := rfl

@[times_table_simps] lemma coord_mk (a b : ℚ) (i : fin 2) :
  (sqrt_d.times_table d).coord (mk a b) i = ![a, b] i :=
rfl

variables {d}

@[elab_as_eliminator]
lemma cases (x : sqrt_d d) {p : sqrt_d d → Prop} (h : p (mk (x 0) (x 1))) :
  p x :=
sorry

set_option profiler true

-- 600ms
lemma mul_comm' (x y : quad_ring ℚ 0 d) : x * y = y * x :=
by quad_ring.calc_tac

-- 1s
lemma mul_comm (x y : sqrt_d d) : x * y = y * x :=
begin
  refine cases x _, refine cases y _,
  apply (sqrt_d.times_table d).ext (λ k, _),
  fin_cases k; times_table,
end

-- 1.3s
lemma mul_assoc' (x y z : quad_ring ℚ 0 d) : x * y * z = x * (y * z) :=
by quad_ring.calc_tac

-- 2.5s
lemma mul_assoc (x y z : sqrt_d d) : x * y * z = x * (y * z) :=
begin
  refine cases x _, refine cases y _, refine cases z _,
  apply (sqrt_d.times_table d).ext (λ k, _),
  fin_cases k; times_table,
end

instance : has_one (sqrt_d d) := ⟨![1, 0]⟩

@[times_table_simps] lemma coord_one : (sqrt_d.times_table d).coord 1 = ![1, 0] := rfl

noncomputable instance : comm_semiring (sqrt_d d) :=
{ one := 1,
  mul_assoc := mul_assoc,
  mul_comm := mul_comm,
  one_mul := λ x, cases x ((sqrt_d.times_table d).ext (λ k, by fin_cases k; times_table)),
  mul_one := λ x, cases x ((sqrt_d.times_table d).ext (λ k, by fin_cases k; times_table)),
  .. sqrt_d.non_unital_non_assoc_semiring d }

noncomputable instance : comm_ring (sqrt_d d) :=
{ .. sqrt_d.add_comm_group d, .. sqrt_d.comm_semiring }

section
set_option profiler true

-- calc_tac with a bit of help: 18s
lemma quad_ring.pow_three_sub_pow_three (x y : quad_ring ℚ 0 d) :
  x^3 - y^3 = (x - y) * (x^2 + x * y + y^2) :=
by { refine quad_ring.ext _ _ _ _; simp [pow_succ]; ring_nf }

-- times_table: 28s
lemma times_table.pow_three_sub_pow_three (x y : sqrt_d d) :
  x^3 - y^3 = (x - y) * (x^2 + x * y + y^2) :=
begin
  refine cases x _, refine cases y _,
  apply (sqrt_d.times_table d).ext (λ k, _),
  fin_cases k; times_table
end

-- calc_tac with a bit of help: 62.9s
lemma quad_ring.pow_four_sub_pow_four (x y : quad_ring ℚ 0 d) :
  x^4 - y^4 = (x - y) * (x^3 + x^2 * y + x * y^2 + y^3) :=
by { refine quad_ring.ext _ _ _ _; simp [pow_succ]; ring_nf }

-- times_table: 108s
lemma times_table.pow_four_sub_pow_four (x y : sqrt_d d) :
  x^4 - y^4 = (x - y) * (x^3 + x^2 * y + x * y^2 + y^3) :=
begin
  refine cases x _, refine cases y _,
  apply (sqrt_d.times_table d).ext (λ k, _),
  fin_cases k; times_table
end

end

end sqrt_d

#exit

-- Define a new structure
-- Might just as well have been a synonym for `adjoin_root (X^2 - 3 : (adjoin_root (X^2 - 2))[X]),
-- but this shows off the general design.
@[ext]
structure sqrt_2_sqrt_3 :=
(a b c d : ℚ)

namespace sqrt_2_sqrt_3

instance : add_comm_group sqrt_2_sqrt_3 :=
{ zero := ⟨0, 0, 0, 0⟩,
  add := λ x y, ⟨x.a + y.a, x.b + y.b, x.c + y.c, x.d + y.d⟩,
  add_comm := λ x y, by { ext : 1; apply add_comm },
  add_zero := λ x, by { ext : 1; apply add_zero },
  zero_add := λ x, by { ext : 1; apply zero_add },
  add_assoc := λ x y z, by { ext : 1; apply add_assoc },
  neg := λ x, ⟨-x.a, -x.b, -x.c, -x.d⟩,
  add_left_neg := λ x, by { ext : 1; apply add_left_neg },
  sub := λ x y, ⟨x.a - y.a, x.b - y.b, x.c - y.c, x.d - y.d⟩ }

.

instance : module ℚ sqrt_2_sqrt_3 :=
{ smul := λ c x, ⟨c * x.a, c * x.b, c * x.c, c * x.d⟩,
  add_smul := λ c d x, by { ext : 1; apply add_mul },
  smul_add := λ c x y, by { ext : 1; apply mul_add },
  mul_smul := λ c d x, by { ext : 1; apply mul_assoc },
  one_smul := λ x, by { ext : 1; apply one_mul },
  smul_zero := λ c, by { ext : 1; apply mul_zero },
  zero_smul := λ x, by { ext : 1; apply zero_mul } }

noncomputable def basis : basis (fin 4) ℚ sqrt_2_sqrt_3 :=
basis.of_equiv_fun $
{ to_fun := λ x, ![x.a, x.b, x.c, x.d],
  inv_fun := λ x, ⟨x 0, x 1, x 2, x 3⟩,
  left_inv := λ ⟨a, b, c, d⟩, rfl,
  right_inv := λ x, by { ext i : 1, fin_cases i; simp },
  map_add' := λ ⟨a, b, c, d⟩ ⟨a', b', c', d'⟩, by { ext i : 1, fin_cases i; refl },
  map_smul' := λ r ⟨a, b, c, d⟩, by { ext i : 1, fin_cases i; refl } }

def table : fin 4 → fin 4 → fin 4 → ℚ :=
![![![1, 0, 0, 0], ![0, 1, 0, 0], ![0, 0, 1, 0], ![0, 0, 0, 1]],
  ![![0, 1, 0, 0], ![2, 0, 0, 0], ![0, 0, 0, 1], ![0, 0, 2, 0]],
  ![![0, 0, 1, 0], ![0, 0, 0, 1], ![3, 0, 0, 0], ![0, 3, 0, 0]],
  ![![0, 0, 0, 1], ![0, 0, 2, 0], ![0, 3, 0, 0], ![6, 0, 0, 0]]]

noncomputable def mul : sqrt_2_sqrt_3 →ₗ[ℚ] sqrt_2_sqrt_3 →ₗ[ℚ] sqrt_2_sqrt_3 :=
sqrt_2_sqrt_3.basis.constr ℚ $ λ i,
sqrt_2_sqrt_3.basis.constr ℚ $ λ j,
sqrt_2_sqrt_3.basis.equiv_fun.symm (table i j)

noncomputable instance : has_mul sqrt_2_sqrt_3 :=
{ mul := λ x y, mul x y }

instance : has_one sqrt_2_sqrt_3 :=
⟨⟨1, 0, 0, 0⟩⟩

@[simp] lemma sqrt_2_sqrt_3.basis_repr (x : sqrt_2_sqrt_3) :
  ⇑(sqrt_2_sqrt_3.basis.repr x) = ![x.a, x.b, x.c, x.d] :=
rfl

noncomputable def sqrt_2_sqrt_3.times_table : times_table (fin 4) ℚ sqrt_2_sqrt_3 :=
{ basis := sqrt_2_sqrt_3.basis,
  table := sqrt_2_sqrt_3.table,
  unfold_mul' := sorry }

@[simp, times_table_simps] -- TODO: get rid of `@[simp]`
lemma sqrt_2_sqrt_3.times_table_apply (i j k : fin 4) :
  sqrt_2_sqrt_3.times_table.table i j k =
  ![![![1, 0, 0, 0], ![0, 1, 0, 0], ![0, 0, 1, 0], ![0, 0, 0, 1]],
    ![![0, 1, 0, 0], ![2, 0, 0, 0], ![0, 0, 0, 1], ![0, 0, 2, 0]],
    ![![0, 0, 1, 0], ![0, 0, 0, 1], ![3, 0, 0, 0], ![0, 3, 0, 0]],
    ![![0, 0, 0, 1], ![0, 0, 2, 0], ![0, 3, 0, 0], ![6, 0, 0, 0]]] i j k :=
rfl

@[times_table_simps] lemma coord_one (i : fin 4) :
  sqrt_2_sqrt_3.times_table.coord 1 i = ![1, 0, 0, 0] i := rfl

@[simp, times_table_simps] lemma coord_mk (a b c d : ℚ) (i : fin 4) :
  sqrt_2_sqrt_3.times_table.coord ⟨a, b, c, d⟩ i = ![a, b, c, d] i := rfl

def sqrt_2 : sqrt_2_sqrt_3 := ⟨0, 1, 0, 0⟩
@[times_table_simps] lemma coord_sqrt_2 (i : fin 4) :
  sqrt_2_sqrt_3.times_table.coord sqrt_2 i = ![0, 1, 0, 0] i := rfl

def sqrt_3 : sqrt_2_sqrt_3 := ⟨0, 0, 1, 0⟩
@[times_table_simps] lemma coord_sqrt_3 (i : fin 4) :
  sqrt_2_sqrt_3.times_table.coord sqrt_3 i = ![0, 0, 1, 0] i := rfl

@[simp]
lemma finsupp.bit0_apply {α M : Type*} [add_monoid M] (f : α →₀ M) (i : α) : (bit0 f) i = bit0 (f i) := rfl

end sqrt_2_sqrt_3
namespace sqrt_2_sqrt_3

-- set_option trace.type_context.is_def_eq_detail true
-- set_option trace.class_instances true

protected lemma mul_comm (x y : sqrt_2_sqrt_3) : x * y = y * x :=
begin
  cases x, cases y,
  apply sqrt_2_sqrt_3.times_table.ext (λ k, _),
  fin_cases k; times_table
end

protected lemma mul_assoc (x y z : sqrt_2_sqrt_3) : x * y * z = x * (y * z) :=
begin
  cases x, cases y, cases z,
  apply sqrt_2_sqrt_3.times_table.ext (λ k, _),
  fin_cases k; times_table
end

protected lemma left_distrib (x y z : sqrt_2_sqrt_3) : x * (y + z) = x * y + x * z :=
begin
  cases x, cases y, cases z,
  apply sqrt_2_sqrt_3.times_table.ext (λ k, _),
  fin_cases k; times_table
end

protected lemma right_distrib (x y z : sqrt_2_sqrt_3) : (x + y) * z = x * z + y * z :=
begin
  cases x, cases y, cases z,
  apply sqrt_2_sqrt_3.times_table.ext (λ k, _),
  fin_cases k; times_table
end

noncomputable instance : comm_ring sqrt_2_sqrt_3 :=
{ add := (+),
  zero := 0,
  mul := (*),
  one := 1,
  neg := has_neg.neg,
  one_mul := λ x, by { cases x, apply sqrt_2_sqrt_3.times_table.ext (λ k, _), fin_cases k; times_table },
  mul_one := λ x, by { cases x, apply sqrt_2_sqrt_3.times_table.ext (λ k, _), fin_cases k; times_table },
  left_distrib := sqrt_2_sqrt_3.left_distrib,
  right_distrib := sqrt_2_sqrt_3.right_distrib,
  mul_comm := sqrt_2_sqrt_3.mul_comm,
  mul_assoc := sqrt_2_sqrt_3.mul_assoc,
  .. sqrt_2_sqrt_3.add_comm_group }

-- Here's a concrete example of an equation that `times_table_tac` can solve
lemma eq₁ : (sqrt_2 + sqrt_3)^3 - 9 * (sqrt_2 + sqrt_3) = 2 * sqrt_2 :=
begin
  apply sqrt_2_sqrt_3.times_table.ext (λ k, _),
  fin_cases k; times_table,
end

lemma eq₂ (x y : sqrt_2_sqrt_3) : (x - y) * (x^2 + x * y + y^2) = x^3 - y^3 :=
begin
  cases x, cases y,
  apply sqrt_2_sqrt_3.times_table.ext (λ k, _),
  fin_cases k; times_table
end

@[times_table_simps] lemma coord_coe_int {a : ℤ} (k : fin 4) :
  sqrt_2_sqrt_3.times_table.coord ↑a k = ![a, 0, 0, 0] k :=
sorry

example (a b : sqrt_2_sqrt_3) : a + -b = a - b :=
begin
  cases a, cases b,
  apply sqrt_2_sqrt_3.times_table.ext (λ k, _),
  fin_cases k; times_table,
end

-- More equations to solve
example (a b : ℤ) : (a + b * sqrt_2 : sqrt_2_sqrt_3) * (a - b * sqrt_2) = a^2 - 2 * b^2 :=
begin
  apply sqrt_2_sqrt_3.times_table.ext (λ k, _),
  fin_cases k; times_table,
end

-- More equations to solve
example (a b c d : ℤ) :
  (a + b * sqrt_2 + c * sqrt_3 + d * sqrt_2 * sqrt_3 : sqrt_2_sqrt_3) *
  (a - b * sqrt_2 + c * sqrt_3 - d * sqrt_2 * sqrt_3 : sqrt_2_sqrt_3) *
  (a + b * sqrt_2 - c * sqrt_3 - d * sqrt_2 * sqrt_3 : sqrt_2_sqrt_3) *
  (a - b * sqrt_2 - c * sqrt_3 + d * sqrt_2 * sqrt_3 : sqrt_2_sqrt_3) =
  a^4 - 4*a^2*b^2 + 4*b^4 - 6*a^2*c^2 - 12*b^2*c^2 + 9*c^4 + 48 * a * b * c  *d - 12*a^2*d^2 -
    24*b^2*d^2 - 36*c^2*d^2 + 36*d^4 :=
begin
  apply sqrt_2_sqrt_3.times_table.ext (λ k, _),
  fin_cases k; times_table,
end

end sqrt_2_sqrt_3


import Smt

theorem prop_ext (p q : Prop) : (p ↔ q) → p = q := by
  smt
  simp_all


universe u

example (α : Type u) (a b : α) (p : α → Prop) (h1 : a = b) (h2 : p a) : p b :=
  eq.subst h1 h2

example (α : Type u) (a b : α) (p : α → Prop) (h1 : a = b) (h2 : p a) : p b :=
  h1 ▸ h2


/-
Copyright (c) 2020 Anatole Dedecker. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Anatole Dedecker
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.analysis.calculus.mean_value
import Mathlib.PostPort

namespace Mathlib

/-!
# L'Hôpital's rule for 0/0 indeterminate forms

In this file, we prove several forms of "L'Hopital's rule" for computing 0/0
indeterminate forms. The proof of `has_deriv_at.lhopital_zero_right_on_Ioo`
is based on the one given in the corresponding
[Wikibooks](https://en.wikibooks.org/wiki/Calculus/L%27H%C3%B4pital%27s_Rule)
chapter, and all other statements are derived from this one by composing by
carefully chosen functions.

Note that the filter `f'/g'` tends to isn't required to be one of `𝓝 a`,
`at_top` or `at_bot`. In fact, we give a slightly stronger statement by
allowing it to be any filter on `ℝ`.

Each statement is available in a `has_deriv_at` form and a `deriv` form, which
is denoted by each statement being in either the `has_deriv_at` or the `deriv`
namespace.
-/

/-!
## Interval-based versions

We start by proving statements where all conditions (derivability, `g' ≠ 0`) have
to be satisfied on an explicitely-provided interval.
-/

namespace has_deriv_at

theorem lhopital_zero_right_on_Ioo {a : ℝ} {b : ℝ} (hab : a < b) {l : filter ℝ} {f : ℝ → ℝ} {f' : ℝ → ℝ} {g : ℝ → ℝ} {g' : ℝ → ℝ} (hff' : ∀ (x : ℝ), x ∈ set.Ioo a b → has_deriv_at f (f' x) x) (hgg' : ∀ (x : ℝ), x ∈ set.Ioo a b → has_deriv_at g (g' x) x) (hg' : ∀ (x : ℝ), x ∈ set.Ioo a b → g' x ≠ 0) (hfa : filter.tendsto f (nhds_within a (set.Ioi a)) (nhds 0)) (hga : filter.tendsto g (nhds_within a (set.Ioi a)) (nhds 0)) (hdiv : filter.tendsto (fun (x : ℝ) => f' x / g' x) (nhds_within a (set.Ioi a)) l) : filter.tendsto (fun (x : ℝ) => f x / g x) (nhds_within a (set.Ioi a)) l := sorry

theorem lhopital_zero_right_on_Ico {a : ℝ} {b : ℝ} (hab : a < b) {l : filter ℝ} {f : ℝ → ℝ} {f' : ℝ → ℝ} {g : ℝ → ℝ} {g' : ℝ → ℝ} (hff' : ∀ (x : ℝ), x ∈ set.Ioo a b → has_deriv_at f (f' x) x) (hgg' : ∀ (x : ℝ), x ∈ set.Ioo a b → has_deriv_at g (g' x) x) (hcf : continuous_on f (set.Ico a b)) (hcg : continuous_on g (set.Ico a b)) (hg' : ∀ (x : ℝ), x ∈ set.Ioo a b → g' x ≠ 0) (hfa : f a = 0) (hga : g a = 0) (hdiv : filter.tendsto (fun (x : ℝ) => f' x / g' x) (nhds_within a (set.Ioi a)) l) : filter.tendsto (fun (x : ℝ) => f x / g x) (nhds_within a (set.Ioi a)) l := sorry

theorem lhopital_zero_left_on_Ioo {a : ℝ} {b : ℝ} (hab : a < b) {l : filter ℝ} {f : ℝ → ℝ} {f' : ℝ → ℝ} {g : ℝ → ℝ} {g' : ℝ → ℝ} (hff' : ∀ (x : ℝ), x ∈ set.Ioo a b → has_deriv_at f (f' x) x) (hgg' : ∀ (x : ℝ), x ∈ set.Ioo a b → has_deriv_at g (g' x) x) (hg' : ∀ (x : ℝ), x ∈ set.Ioo a b → g' x ≠ 0) (hfb : filter.tendsto f (nhds_within b (set.Iio b)) (nhds 0)) (hgb : filter.tendsto g (nhds_within b (set.Iio b)) (nhds 0)) (hdiv : filter.tendsto (fun (x : ℝ) => f' x / g' x) (nhds_within b (set.Iio b)) l) : filter.tendsto (fun (x : ℝ) => f x / g x) (nhds_within b (set.Iio b)) l := sorry

theorem lhopital_zero_left_on_Ioc {a : ℝ} {b : ℝ} (hab : a < b) {l : filter ℝ} {f : ℝ → ℝ} {f' : ℝ → ℝ} {g : ℝ → ℝ} {g' : ℝ → ℝ} (hff' : ∀ (x : ℝ), x ∈ set.Ioo a b → has_deriv_at f (f' x) x) (hgg' : ∀ (x : ℝ), x ∈ set.Ioo a b → has_deriv_at g (g' x) x) (hcf : continuous_on f (set.Ioc a b)) (hcg : continuous_on g (set.Ioc a b)) (hg' : ∀ (x : ℝ), x ∈ set.Ioo a b → g' x ≠ 0) (hfb : f b = 0) (hgb : g b = 0) (hdiv : filter.tendsto (fun (x : ℝ) => f' x / g' x) (nhds_within b (set.Iio b)) l) : filter.tendsto (fun (x : ℝ) => f x / g x) (nhds_within b (set.Iio b)) l := sorry

theorem lhopital_zero_at_top_on_Ioi {a : ℝ} {l : filter ℝ} {f : ℝ → ℝ} {f' : ℝ → ℝ} {g : ℝ → ℝ} {g' : ℝ → ℝ} (hff' : ∀ (x : ℝ), x ∈ set.Ioi a → has_deriv_at f (f' x) x) (hgg' : ∀ (x : ℝ), x ∈ set.Ioi a → has_deriv_at g (g' x) x) (hg' : ∀ (x : ℝ), x ∈ set.Ioi a → g' x ≠ 0) (hftop : filter.tendsto f filter.at_top (nhds 0)) (hgtop : filter.tendsto g filter.at_top (nhds 0)) (hdiv : filter.tendsto (fun (x : ℝ) => f' x / g' x) filter.at_top l) : filter.tendsto (fun (x : ℝ) => f x / g x) filter.at_top l := sorry

theorem lhopital_zero_at_bot_on_Iio {a : ℝ} {l : filter ℝ} {f : ℝ → ℝ} {f' : ℝ → ℝ} {g : ℝ → ℝ} {g' : ℝ → ℝ} (hff' : ∀ (x : ℝ), x ∈ set.Iio a → has_deriv_at f (f' x) x) (hgg' : ∀ (x : ℝ), x ∈ set.Iio a → has_deriv_at g (g' x) x) (hg' : ∀ (x : ℝ), x ∈ set.Iio a → g' x ≠ 0) (hfbot : filter.tendsto f filter.at_bot (nhds 0)) (hgbot : filter.tendsto g filter.at_bot (nhds 0)) (hdiv : filter.tendsto (fun (x : ℝ) => f' x / g' x) filter.at_bot l) : filter.tendsto (fun (x : ℝ) => f x / g x) filter.at_bot l := sorry

end has_deriv_at

namespace deriv

theorem lhopital_zero_right_on_Ioo {a : ℝ} {b : ℝ} (hab : a < b) {l : filter ℝ} {f : ℝ → ℝ} {g : ℝ → ℝ} (hdf : differentiable_on ℝ f (set.Ioo a b)) (hg' : ∀ (x : ℝ), x ∈ set.Ioo a b → deriv g x ≠ 0) (hfa : filter.tendsto f (nhds_within a (set.Ioi a)) (nhds 0)) (hga : filter.tendsto g (nhds_within a (set.Ioi a)) (nhds 0)) (hdiv : filter.tendsto (fun (x : ℝ) => deriv f x / deriv g x) (nhds_within a (set.Ioi a)) l) : filter.tendsto (fun (x : ℝ) => f x / g x) (nhds_within a (set.Ioi a)) l := sorry

theorem lhopital_zero_right_on_Ico {a : ℝ} {b : ℝ} (hab : a < b) {l : filter ℝ} {f : ℝ → ℝ} {g : ℝ → ℝ} (hdf : differentiable_on ℝ f (set.Ioo a b)) (hcf : continuous_on f (set.Ico a b)) (hcg : continuous_on g (set.Ico a b)) (hg' : ∀ (x : ℝ), x ∈ set.Ioo a b → deriv g x ≠ 0) (hfa : f a = 0) (hga : g a = 0) (hdiv : filter.tendsto (fun (x : ℝ) => deriv f x / deriv g x) (nhds_within a (set.Ioi a)) l) : filter.tendsto (fun (x : ℝ) => f x / g x) (nhds_within a (set.Ioi a)) l := sorry

theorem lhopital_zero_left_on_Ioo {a : ℝ} {b : ℝ} (hab : a < b) {l : filter ℝ} {f : ℝ → ℝ} {g : ℝ → ℝ} (hdf : differentiable_on ℝ f (set.Ioo a b)) (hg' : ∀ (x : ℝ), x ∈ set.Ioo a b → deriv g x ≠ 0) (hfb : filter.tendsto f (nhds_within b (set.Iio b)) (nhds 0)) (hgb : filter.tendsto g (nhds_within b (set.Iio b)) (nhds 0)) (hdiv : filter.tendsto (fun (x : ℝ) => deriv f x / deriv g x) (nhds_within b (set.Iio b)) l) : filter.tendsto (fun (x : ℝ) => f x / g x) (nhds_within b (set.Iio b)) l := sorry

theorem lhopital_zero_at_top_on_Ioi {a : ℝ} {l : filter ℝ} {f : ℝ → ℝ} {g : ℝ → ℝ} (hdf : differentiable_on ℝ f (set.Ioi a)) (hg' : ∀ (x : ℝ), x ∈ set.Ioi a → deriv g x ≠ 0) (hftop : filter.tendsto f filter.at_top (nhds 0)) (hgtop : filter.tendsto g filter.at_top (nhds 0)) (hdiv : filter.tendsto (fun (x : ℝ) => deriv f x / deriv g x) filter.at_top l) : filter.tendsto (fun (x : ℝ) => f x / g x) filter.at_top l := sorry

theorem lhopital_zero_at_bot_on_Iio {a : ℝ} {l : filter ℝ} {f : ℝ → ℝ} {g : ℝ → ℝ} (hdf : differentiable_on ℝ f (set.Iio a)) (hg' : ∀ (x : ℝ), x ∈ set.Iio a → deriv g x ≠ 0) (hfbot : filter.tendsto f filter.at_bot (nhds 0)) (hgbot : filter.tendsto g filter.at_bot (nhds 0)) (hdiv : filter.tendsto (fun (x : ℝ) => deriv f x / deriv g x) filter.at_bot l) : filter.tendsto (fun (x : ℝ) => f x / g x) filter.at_bot l := sorry

end deriv

/-!
## Generic versions

The following statements no longer any explicit interval, as they only require
conditions holding eventually.
-/

namespace has_deriv_at

/-- L'Hôpital's rule for approaching a real from the right, `has_deriv_at` version -/
theorem lhopital_zero_nhds_right {a : ℝ} {l : filter ℝ} {f : ℝ → ℝ} {f' : ℝ → ℝ} {g : ℝ → ℝ} {g' : ℝ → ℝ} (hff' : filter.eventually (fun (x : ℝ) => has_deriv_at f (f' x) x) (nhds_within a (set.Ioi a))) (hgg' : filter.eventually (fun (x : ℝ) => has_deriv_at g (g' x) x) (nhds_within a (set.Ioi a))) (hg' : filter.eventually (fun (x : ℝ) => g' x ≠ 0) (nhds_within a (set.Ioi a))) (hfa : filter.tendsto f (nhds_within a (set.Ioi a)) (nhds 0)) (hga : filter.tendsto g (nhds_within a (set.Ioi a)) (nhds 0)) (hdiv : filter.tendsto (fun (x : ℝ) => f' x / g' x) (nhds_within a (set.Ioi a)) l) : filter.tendsto (fun (x : ℝ) => f x / g x) (nhds_within a (set.Ioi a)) l := sorry

/-- L'Hôpital's rule for approaching a real from the left, `has_deriv_at` version -/
theorem lhopital_zero_nhds_left {a : ℝ} {l : filter ℝ} {f : ℝ → ℝ} {f' : ℝ → ℝ} {g : ℝ → ℝ} {g' : ℝ → ℝ} (hff' : filter.eventually (fun (x : ℝ) => has_deriv_at f (f' x) x) (nhds_within a (set.Iio a))) (hgg' : filter.eventually (fun (x : ℝ) => has_deriv_at g (g' x) x) (nhds_within a (set.Iio a))) (hg' : filter.eventually (fun (x : ℝ) => g' x ≠ 0) (nhds_within a (set.Iio a))) (hfa : filter.tendsto f (nhds_within a (set.Iio a)) (nhds 0)) (hga : filter.tendsto g (nhds_within a (set.Iio a)) (nhds 0)) (hdiv : filter.tendsto (fun (x : ℝ) => f' x / g' x) (nhds_within a (set.Iio a)) l) : filter.tendsto (fun (x : ℝ) => f x / g x) (nhds_within a (set.Iio a)) l := sorry

/-- L'Hôpital's rule for approaching a real, `has_deriv_at` version. This
  does not require anything about the situation at `a` -/
theorem lhopital_zero_nhds' {a : ℝ} {l : filter ℝ} {f : ℝ → ℝ} {f' : ℝ → ℝ} {g : ℝ → ℝ} {g' : ℝ → ℝ} (hff' : filter.eventually (fun (x : ℝ) => has_deriv_at f (f' x) x) (nhds_within a (set.univ \ singleton a))) (hgg' : filter.eventually (fun (x : ℝ) => has_deriv_at g (g' x) x) (nhds_within a (set.univ \ singleton a))) (hg' : filter.eventually (fun (x : ℝ) => g' x ≠ 0) (nhds_within a (set.univ \ singleton a))) (hfa : filter.tendsto f (nhds_within a (set.univ \ singleton a)) (nhds 0)) (hga : filter.tendsto g (nhds_within a (set.univ \ singleton a)) (nhds 0)) (hdiv : filter.tendsto (fun (x : ℝ) => f' x / g' x) (nhds_within a (set.univ \ singleton a)) l) : filter.tendsto (fun (x : ℝ) => f x / g x) (nhds_within a (set.univ \ singleton a)) l := sorry

/-- L'Hôpital's rule for approaching a real, `has_deriv_at` version -/
theorem lhopital_zero_nhds {a : ℝ} {l : filter ℝ} {f : ℝ → ℝ} {f' : ℝ → ℝ} {g : ℝ → ℝ} {g' : ℝ → ℝ} (hff' : filter.eventually (fun (x : ℝ) => has_deriv_at f (f' x) x) (nhds a)) (hgg' : filter.eventually (fun (x : ℝ) => has_deriv_at g (g' x) x) (nhds a)) (hg' : filter.eventually (fun (x : ℝ) => g' x ≠ 0) (nhds a)) (hfa : filter.tendsto f (nhds a) (nhds 0)) (hga : filter.tendsto g (nhds a) (nhds 0)) (hdiv : filter.tendsto (fun (x : ℝ) => f' x / g' x) (nhds a) l) : filter.tendsto (fun (x : ℝ) => f x / g x) (nhds_within a (set.univ \ singleton a)) l :=
  lhopital_zero_nhds' (eventually_nhds_within_of_eventually_nhds hff') (eventually_nhds_within_of_eventually_nhds hgg')
    (eventually_nhds_within_of_eventually_nhds hg') (tendsto_nhds_within_of_tendsto_nhds hfa)
    (tendsto_nhds_within_of_tendsto_nhds hga) (tendsto_nhds_within_of_tendsto_nhds hdiv)

/-- L'Hôpital's rule for approaching +∞, `has_deriv_at` version -/
theorem lhopital_zero_at_top {l : filter ℝ} {f : ℝ → ℝ} {f' : ℝ → ℝ} {g : ℝ → ℝ} {g' : ℝ → ℝ} (hff' : filter.eventually (fun (x : ℝ) => has_deriv_at f (f' x) x) filter.at_top) (hgg' : filter.eventually (fun (x : ℝ) => has_deriv_at g (g' x) x) filter.at_top) (hg' : filter.eventually (fun (x : ℝ) => g' x ≠ 0) filter.at_top) (hftop : filter.tendsto f filter.at_top (nhds 0)) (hgtop : filter.tendsto g filter.at_top (nhds 0)) (hdiv : filter.tendsto (fun (x : ℝ) => f' x / g' x) filter.at_top l) : filter.tendsto (fun (x : ℝ) => f x / g x) filter.at_top l := sorry

/-- L'Hôpital's rule for approaching -∞, `has_deriv_at` version -/
theorem lhopital_zero_at_bot {l : filter ℝ} {f : ℝ → ℝ} {f' : ℝ → ℝ} {g : ℝ → ℝ} {g' : ℝ → ℝ} (hff' : filter.eventually (fun (x : ℝ) => has_deriv_at f (f' x) x) filter.at_bot) (hgg' : filter.eventually (fun (x : ℝ) => has_deriv_at g (g' x) x) filter.at_bot) (hg' : filter.eventually (fun (x : ℝ) => g' x ≠ 0) filter.at_bot) (hfbot : filter.tendsto f filter.at_bot (nhds 0)) (hgbot : filter.tendsto g filter.at_bot (nhds 0)) (hdiv : filter.tendsto (fun (x : ℝ) => f' x / g' x) filter.at_bot l) : filter.tendsto (fun (x : ℝ) => f x / g x) filter.at_bot l := sorry

end has_deriv_at

namespace deriv

/-- L'Hôpital's rule for approaching a real from the right, `deriv` version -/
theorem lhopital_zero_nhds_right {a : ℝ} {l : filter ℝ} {f : ℝ → ℝ} {g : ℝ → ℝ} (hdf : filter.eventually (fun (x : ℝ) => differentiable_at ℝ f x) (nhds_within a (set.Ioi a))) (hg' : filter.eventually (fun (x : ℝ) => deriv g x ≠ 0) (nhds_within a (set.Ioi a))) (hfa : filter.tendsto f (nhds_within a (set.Ioi a)) (nhds 0)) (hga : filter.tendsto g (nhds_within a (set.Ioi a)) (nhds 0)) (hdiv : filter.tendsto (fun (x : ℝ) => deriv f x / deriv g x) (nhds_within a (set.Ioi a)) l) : filter.tendsto (fun (x : ℝ) => f x / g x) (nhds_within a (set.Ioi a)) l := sorry

/-- L'Hôpital's rule for approaching a real from the left, `deriv` version -/
theorem lhopital_zero_nhds_left {a : ℝ} {l : filter ℝ} {f : ℝ → ℝ} {g : ℝ → ℝ} (hdf : filter.eventually (fun (x : ℝ) => differentiable_at ℝ f x) (nhds_within a (set.Iio a))) (hg' : filter.eventually (fun (x : ℝ) => deriv g x ≠ 0) (nhds_within a (set.Iio a))) (hfa : filter.tendsto f (nhds_within a (set.Iio a)) (nhds 0)) (hga : filter.tendsto g (nhds_within a (set.Iio a)) (nhds 0)) (hdiv : filter.tendsto (fun (x : ℝ) => deriv f x / deriv g x) (nhds_within a (set.Iio a)) l) : filter.tendsto (fun (x : ℝ) => f x / g x) (nhds_within a (set.Iio a)) l := sorry

/-- L'Hôpital's rule for approaching a real, `deriv` version. This
  does not require anything about the situation at `a` -/
theorem lhopital_zero_nhds' {a : ℝ} {l : filter ℝ} {f : ℝ → ℝ} {g : ℝ → ℝ} (hdf : filter.eventually (fun (x : ℝ) => differentiable_at ℝ f x) (nhds_within a (set.univ \ singleton a))) (hg' : filter.eventually (fun (x : ℝ) => deriv g x ≠ 0) (nhds_within a (set.univ \ singleton a))) (hfa : filter.tendsto f (nhds_within a (set.univ \ singleton a)) (nhds 0)) (hga : filter.tendsto g (nhds_within a (set.univ \ singleton a)) (nhds 0)) (hdiv : filter.tendsto (fun (x : ℝ) => deriv f x / deriv g x) (nhds_within a (set.univ \ singleton a)) l) : filter.tendsto (fun (x : ℝ) => f x / g x) (nhds_within a (set.univ \ singleton a)) l := sorry

/-- L'Hôpital's rule for approaching a real, `deriv` version -/
theorem lhopital_zero_nhds {a : ℝ} {l : filter ℝ} {f : ℝ → ℝ} {g : ℝ → ℝ} (hdf : filter.eventually (fun (x : ℝ) => differentiable_at ℝ f x) (nhds a)) (hg' : filter.eventually (fun (x : ℝ) => deriv g x ≠ 0) (nhds a)) (hfa : filter.tendsto f (nhds a) (nhds 0)) (hga : filter.tendsto g (nhds a) (nhds 0)) (hdiv : filter.tendsto (fun (x : ℝ) => deriv f x / deriv g x) (nhds a) l) : filter.tendsto (fun (x : ℝ) => f x / g x) (nhds_within a (set.univ \ singleton a)) l :=
  lhopital_zero_nhds' (eventually_nhds_within_of_eventually_nhds hdf) (eventually_nhds_within_of_eventually_nhds hg')
    (tendsto_nhds_within_of_tendsto_nhds hfa) (tendsto_nhds_within_of_tendsto_nhds hga)
    (tendsto_nhds_within_of_tendsto_nhds hdiv)

/-- L'Hôpital's rule for approaching +∞, `deriv` version -/
theorem lhopital_zero_at_top {l : filter ℝ} {f : ℝ → ℝ} {g : ℝ → ℝ} (hdf : filter.eventually (fun (x : ℝ) => differentiable_at ℝ f x) filter.at_top) (hg' : filter.eventually (fun (x : ℝ) => deriv g x ≠ 0) filter.at_top) (hftop : filter.tendsto f filter.at_top (nhds 0)) (hgtop : filter.tendsto g filter.at_top (nhds 0)) (hdiv : filter.tendsto (fun (x : ℝ) => deriv f x / deriv g x) filter.at_top l) : filter.tendsto (fun (x : ℝ) => f x / g x) filter.at_top l := sorry

/-- L'Hôpital's rule for approaching -∞, `deriv` version -/
theorem lhopital_zero_at_bot {l : filter ℝ} {f : ℝ → ℝ} {g : ℝ → ℝ} (hdf : filter.eventually (fun (x : ℝ) => differentiable_at ℝ f x) filter.at_bot) (hg' : filter.eventually (fun (x : ℝ) => deriv g x ≠ 0) filter.at_bot) (hfbot : filter.tendsto f filter.at_bot (nhds 0)) (hgbot : filter.tendsto g filter.at_bot (nhds 0)) (hdiv : filter.tendsto (fun (x : ℝ) => deriv f x / deriv g x) filter.at_bot l) : filter.tendsto (fun (x : ℝ) => f x / g x) filter.at_bot l := sorry


/-
Copyright (c) 2020 Kenny Lau. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kenny Lau
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.algebra.big_operators.pi
import Mathlib.data.finsupp.default
import Mathlib.PostPort

universes u_1 u_2 u_4 u_3 u_5 u_6

namespace Mathlib

/-!
# Big operators for finsupps

This file contains theorems relevant to big operators in finitely supported functions.
-/

theorem finset.sum_apply' {α : Type u_1} {ι : Type u_2} {A : Type u_4} [add_comm_monoid A] {s : finset α} {f : α → ι →₀ A} (i : ι) : coe_fn (finset.sum s fun (k : α) => f k) i = finset.sum s fun (k : α) => coe_fn (f k) i :=
  Eq.symm (finset.sum_hom s ⇑(finsupp.apply_add_hom i))

theorem finsupp.sum_apply' {ι : Type u_2} {γ : Type u_3} {A : Type u_4} {B : Type u_5} [add_comm_monoid A] [add_comm_monoid B] (g : ι →₀ A) (k : ι → A → γ → B) (x : γ) : finsupp.sum g k x = finsupp.sum g fun (i : ι) (b : A) => k i b x :=
  finset.sum_apply x (finsupp.support g) fun (a : ι) => k a (coe_fn g a)

theorem finsupp.sum_sum_index' {α : Type u_1} {ι : Type u_2} {A : Type u_4} {C : Type u_6} [add_comm_monoid A] [add_comm_monoid C] {t : ι → A → C} (h0 : ∀ (i : ι), t i 0 = 0) (h1 : ∀ (i : ι) (x y : A), t i (x + y) = t i x + t i y) {s : finset α} {f : α → ι →₀ A} : finsupp.sum (finset.sum s fun (x : α) => f x) t = finset.sum s fun (x : α) => finsupp.sum (f x) t := sorry