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

import linear_algebra.tensor_product
import algebra.algebra.basic

/-!
# The tensor product of R-algebras

We construct the R-algebra structure on `A ⊗[R] B`, when `A` and `B` are both `R`-algebras,
and provide the structure isomorphisms

* `R ⊗[R] A ≃ₐ[R] A`
* `A ⊗[R] R ≃ₐ[R] A`
* `A ⊗[R] B ≃ₐ[R] B ⊗[R] A`

The code for
* `((A ⊗[R] B) ⊗[R] C) ≃ₐ[R] (A ⊗[R] (B ⊗[R] C))`
is written and compiles, but takes longer than the `-T100000` time limit,
so is currently commented out.
-/

universes u v₁ v₂ v₃ v₄

namespace algebra

open_locale tensor_product
open tensor_product

namespace tensor_product

section semiring

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

end semiring

section ring

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

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

end ring

section comm_ring

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

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

end comm_ring

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

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

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

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

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

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

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

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

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

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

end

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

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

@[simp]

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

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

section
variables (R A B)

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

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

end

section
variables {R A B C}

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

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

-- variables (R A B C)

-- -- local attribute [elab_simple] alg_equiv_of_linear_equiv_triple_tensor_product

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

-- variables {R A B C}

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

end

variables {R A B C D}

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

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

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

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

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

end

end monoidal

end tensor_product

end algebra


import linear_algebra.eigenspace
import rnd_var

import to_mathlib_maybe.pTrace
import to_mathlib_maybe.Hilbert_space

import to_qShannon_theory_maybe.state
import to_qShannon_theory_maybe.channel
import to_qShannon_theory_maybe.entropy

#check rnd_var
#check quantum_state
#check quantum_channel
#check entropy

-- import Lemma3
-- import Lemma4

open_locale tensor_product big_operators

variables
{ι : Type} [fintype ι] [decidable_eq ι]
{ℋ : Type} [complex_hilbert_space ℋ]
{ρ : module.End ℂ ℋ} [quantum_state ρ]
{ρ' : module.End ℂ ℋ} [quantum_state ρ']
{σ : module.End ℂ ℋ} [quantum_state σ]
{U : module.End ℂ ℋ} [unitary U]
-- {q : ι → ℝ} [rnd_var q]

def reachable_by_catalysis (ε : ℝ) (ρ : module.End ℂ ℋ) (ρ' : module.End ℂ ℋ) :=
∃ σ : module.End ℂ ℋ, ∃ U : module.End ℂ ℋ,
Tr₁(U ∘ (ρ ⊗ σ) ∘ U†) = σ
∧
D(Tr₂(U ∘ (ρ ⊗ σ) ∘ U†), ρ') ≤ ε

-- notation ρ `→ε` ρ' := reachable_by_catalysis ε ρ ρ'
notation `H` := entropy

-- Choose catalytic state σ₁⊗σ₂ according to two-step construction
--  1. Define σ₁ using (16). This requires choosing `n` and `U` (in order to define `χ`). `n` can be estimated using (17). `U` is chosen such that the final state on `S` is as close to `ρ'` as possible - but there is no explicit formula. I still don't know how to deal with this.
-- TODO define trace for arbitrary number of subsystems; in particular, this definition requires a function of type
--  `Tr : list ℕ → quantum_state → quantum_state`
-- where the list of integers indicates the subsystems to be traced out
-- TODO define trace making the system partition explicit, otherwise LEAN will not know what we mean by `Tr k` unless the argument is a product state
def σ₁ (ρ) (n) (U) := (1/n) • ∑ k in finset.range n, ρ^⊗(n-k) ⊗ (Tr(list n-k n) (U ∘ ρ ∘ U†)) ⊗ |k⟩⟨k|

--  2. Ancilla system R for the dephasing channel. This is just the ancilla in the Naimark/Stinespring dilation of the channel.
def σ₂ := naimark_ancilla (dephasing_channel ρ')

-- Pick unitaries: we want to compose steps 1, 2, & 3 (see fig. 3) with a dephasing channel
def V := naimark_unitary (dephasing_channel ρ') ∘ cycle_ancilla ∘ cycle_s ∘ (U ⊗ |n⟩⟨n| + (Id d*(n-1)) ⊗ ∑ k in finset.range (n-1), |k⟩⟨k|)

/--
This is the main theorem
-/
theorem reachable_iff_higher_entropy : (∀ ε>0, reachable_by_catalysis ε ρ ρ') ↔ H(ρ') ≥ H(ρ) :=
begin
  split,
  { -- "The direction i) ⇒ ii) follows directly from sub-additivity,
    -- unitary invariance and continuity of von Neumann entropy:"
    intro h,
    intro ε,
    let ρσ' := U ∘ (ρ ⊗ σ) ∘ U†,
    let ρ'ε := Tr₂ ρσ',
    calc H(ρ'ε) + H(σ) ≥ H(ρσ')              : by apply entropy_subadditive,
                  ... = H(U ∘ (ρ ⊗ σ) ∘ U†)     : by sorry -- def of ρ'ε and invariance of σ under transformation
                  ... = H(ρ ⊗ σ)              : by apply entropy_unitary_evolution_eq_entropy_self,
                  ... = H(ρ) + H(σ)              : by apply entropy_tmul_eq_add_entropy,
    -- then rw to cancel H(σ) ("by continuity") and done
    sorry
  },
  {
    /-
    "The proof [of the ii) ⇒ i) direction] proceeds in two parts:
    -/

    let χ := U ∘ ρ^⊗n ∘ U†,

    /-
    First we construct a catalyst σ₁ for the exact transition from ρ
    to the equal mixture χ_bar := 1/n * ∑ k, (χ k) of states (χ k) = pTr_k_bar χ."
    -/

    /-
    "Then we use a second catalyst R in state σ₂ to implement the
    dephasing map and obtain 𝒟_ρ'[χ] , which is ε-close to the target ρ'
    The part R of the catalyst thus effectively acts as a source of randomness."
    -/

    let ρ'ε := 𝒟_ρ'[χ],

    /-
    "By Lemma 5 and the fact that the dephasing map is a mixed unitary channel,
    this second part can be done in such a way that the two parts of the catalyst
    remain uncorrelated."
    -/

    /-
    "From the results of [35] it follows that σ₂ only needs to have a dimension of
    the order of √d. Furthermore, note that by perturbing ρ' arbitrarily slightly,
    we can always ensure that H(ρ) < H(ρ') since we allow for arbitrarily small
    errors and von Neumann entropy is continuous. We thus only need to prove that
    we can do the transition ρ →ε=0 χ_bar in the case H(ρ') > H(ρ)."
    -/

    /-
    "To show this we make use of a trick that was used in recent work by Shiraishi
    and Sagawa [33]."
    -/

    -- use σ₁ ⊗ σ₂,
    -- use V,

    -- have hyp_close : D(ρ', Tr (-S) evolve(V σ₂ ⊗ ρ ⊗ σ₁)) ≤ ε, by sorry -- lemma 4
    -- have hyp_catalysis : Tr S evolve(V σ₂ ⊗ ρ ⊗ σ₁) = σ₂ ⊗ σ₁, by sorry -- lemmas 4 & 5
  },
end


/-
Copyright (c) 2020 Yury Kudryashov. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yury Kudryashov, Heather Macbeth, Sébastien Gouëzel
-/
import analysis.calculus.cont_diff
import tactic.ring_exp
import analysis.normed_space.banach
import topology.local_homeomorph

/-!
# Inverse function theorem

In this file we prove the inverse function theorem. It says that if a map `f : E → F`
has an invertible strict derivative `f'` at `a`, then it is locally invertible,
and the inverse function has derivative `f' ⁻¹`.

We define `has_strict_deriv_at.to_local_homeomorph` that repacks a function `f`
with a `hf : has_strict_fderiv_at f f' a`, `f' : E ≃L[𝕜] F`, into a `local_homeomorph`.
The `to_fun` of this `local_homeomorph` is `defeq` to `f`, so one can apply theorems
about `local_homeomorph` to `hf.to_local_homeomorph f`, and get statements about `f`.

Then we define `has_strict_fderiv_at.local_inverse` to be the `inv_fun` of this `local_homeomorph`,
and prove two versions of the inverse function theorem:

* `has_strict_fderiv_at.to_local_inverse`: if `f` has an invertible derivative `f'` at `a` in the
  strict sense (`hf`), then `hf.local_inverse f f' a` has derivative `f'.symm` at `f a` in the
  strict sense;

* `has_strict_fderiv_at.to_local_left_inverse`: if `f` has an invertible derivative `f'` at `a` in
  the strict sense and `g` is locally left inverse to `f` near `a`, then `g` has derivative
  `f'.symm` at `f a` in the strict sense.

In the one-dimensional case we reformulate these theorems in terms of `has_strict_deriv_at` and
`f'⁻¹`.

We also reformulate the theorems in terms of `cont_diff`, to give that `C^k` (respectively,
smooth) inputs give `C^k` (smooth) inverses.  These versions require that continuous
differentiability implies strict differentiability; this is false over a general field, true over
`ℝ` or `ℂ` and implemented here assuming `is_R_or_C 𝕂`.

Some related theorems, providing the derivative and higher regularity assuming that we already know
the inverse function, are formulated in `fderiv.lean`, `deriv.lean`, and `cont_diff.lean`.

## Notations

In the section about `approximates_linear_on` we introduce some `local notation` to make formulas
shorter:

* by `N` we denote `‖f'⁻¹‖`;
* by `g` we denote the auxiliary contracting map `x ↦ x + f'.symm (y - f x)` used to prove that
  `{x | f x = y}` is nonempty.

## Tags

derivative, strictly differentiable, continuously differentiable, smooth, inverse function
-/

open function set filter metric
open_locale topology classical nnreal

noncomputable theory

variables {𝕜 : Type*} [nontrivially_normed_field 𝕜]
variables {E : Type*} [normed_add_comm_group E] [normed_space 𝕜 E]
variables {F : Type*} [normed_add_comm_group F] [normed_space 𝕜 F]
variables {G : Type*} [normed_add_comm_group G] [normed_space 𝕜 G]
variables {G' : Type*} [normed_add_comm_group G'] [normed_space 𝕜 G']
variables {ε : ℝ}

open asymptotics filter metric set
open continuous_linear_map (id)

/-!
### Non-linear maps close to affine maps

In this section we study a map `f` such that `‖f x - f y - f' (x - y)‖ ≤ c * ‖x - y‖` on an open set
`s`, where `f' : E →L[𝕜] F` is a continuous linear map and `c` is suitably small. Maps of this type
behave like `f a + f' (x - a)` near each `a ∈ s`.

When `f'` is onto, we show that `f` is locally onto.

When `f'` is a continuous linear equiv, we show that `f` is a homeomorphism
between `s` and `f '' s`. More precisely, we define `approximates_linear_on.to_local_homeomorph` to
be a `local_homeomorph` with `to_fun = f`, `source = s`, and `target = f '' s`.

Maps of this type naturally appear in the proof of the inverse function theorem (see next section),
and `approximates_linear_on.to_local_homeomorph` will imply that the locally inverse function
exists.

We define this auxiliary notion to split the proof of the inverse function theorem into small
lemmas. This approach makes it possible

- to prove a lower estimate on the size of the domain of the inverse function;

- to reuse parts of the proofs in the case if a function is not strictly differentiable. E.g., for a
  function `f : E × F → G` with estimates on `f x y₁ - f x y₂` but not on `f x₁ y - f x₂ y`.
-/

/-- We say that `f` approximates a continuous linear map `f'` on `s` with constant `c`,
if `‖f x - f y - f' (x - y)‖ ≤ c * ‖x - y‖` whenever `x, y ∈ s`.

This predicate is defined to facilitate the splitting of the inverse function theorem into small
lemmas. Some of these lemmas can be useful, e.g., to prove that the inverse function is defined
on a specific set. -/
def approximates_linear_on (f : E → F) (f' : E →L[𝕜] F) (s : set E) (c : ℝ≥0) : Prop :=
∀ (x ∈ s) (y ∈ s), ‖f x - f y - f' (x - y)‖ ≤ c * ‖x - y‖

@[simp] lemma approximates_linear_on_empty (f : E → F) (f' : E →L[𝕜] F) (c : ℝ≥0) :
  approximates_linear_on f f' ∅ c :=
by simp [approximates_linear_on]

namespace approximates_linear_on

variables [cs : complete_space E] {f : E → F}

/-! First we prove some properties of a function that `approximates_linear_on` a (not necessarily
invertible) continuous linear map. -/

section

variables {f' : E →L[𝕜] F} {s t : set E} {c c' : ℝ≥0}

theorem mono_num (hc : c ≤ c') (hf : approximates_linear_on f f' s c) :
  approximates_linear_on f f' s c' :=
λ x hx y hy, le_trans (hf x hx y hy) (mul_le_mul_of_nonneg_right hc $ norm_nonneg _)

theorem mono_set (hst : s ⊆ t) (hf : approximates_linear_on f f' t c) :
  approximates_linear_on f f' s c :=
λ x hx y hy, hf x (hst hx) y (hst hy)

lemma approximates_linear_on_iff_lipschitz_on_with
  {f : E → F} {f' : E →L[𝕜] F} {s : set E} {c : ℝ≥0} :
  approximates_linear_on f f' s c ↔ lipschitz_on_with c (f - f') s :=
begin
  have : ∀ x y, f x - f y - f' (x - y) = (f - f') x - (f - f') y,
  { assume x y, simp only [map_sub, pi.sub_apply], abel },
  simp only [this, lipschitz_on_with_iff_norm_sub_le, approximates_linear_on],
end

alias approximates_linear_on_iff_lipschitz_on_with ↔
  lipschitz_on_with _root_.lipschitz_on_with.approximates_linear_on

lemma lipschitz_sub (hf : approximates_linear_on f f' s c) :
  lipschitz_with c (λ x : s, f x - f' x) :=
begin
  refine lipschitz_with.of_dist_le_mul (λ x y, _),
  rw [dist_eq_norm, subtype.dist_eq, dist_eq_norm],
  convert hf x x.2 y y.2 using 2,
  rw [f'.map_sub], abel
end

protected lemma lipschitz (hf : approximates_linear_on f f' s c) :
  lipschitz_with (‖f'‖₊ + c) (s.restrict f) :=
by simpa only [restrict_apply, add_sub_cancel'_right]
  using (f'.lipschitz.restrict s).add hf.lipschitz_sub

protected lemma continuous (hf : approximates_linear_on f f' s c) :
  continuous (s.restrict f) :=
hf.lipschitz.continuous

protected lemma continuous_on (hf : approximates_linear_on f f' s c) :
  continuous_on f s :=
continuous_on_iff_continuous_restrict.2 hf.continuous

end

section locally_onto
/-!
We prove that a function which is linearly approximated by a continuous linear map with a nonlinear
right inverse is locally onto. This will apply to the case where the approximating map is a linear
equivalence, for the local inverse theorem, but also whenever the approximating map is onto,
by Banach's open mapping theorem. -/

include cs

variables {s : set E} {c : ℝ≥0} {f' : E →L[𝕜] F}

/-- If a function is linearly approximated by a continuous linear map with a (possibly nonlinear)
right inverse, then it is locally onto: a ball of an explicit radius is included in the image
of the map. -/
theorem surj_on_closed_ball_of_nonlinear_right_inverse
  (hf : approximates_linear_on f f' s c)  (f'symm : f'.nonlinear_right_inverse)
  {ε : ℝ} {b : E} (ε0 : 0 ≤ ε) (hε : closed_ball b ε ⊆ s) :
  surj_on f (closed_ball b ε) (closed_ball (f b) (((f'symm.nnnorm : ℝ)⁻¹ - c) * ε)) :=
begin
  assume y hy,
  cases le_or_lt (f'symm.nnnorm : ℝ) ⁻¹ c with hc hc,
  { refine ⟨b, by simp [ε0], _⟩,
    have : dist y (f b) ≤ 0 :=
      (mem_closed_ball.1 hy).trans (mul_nonpos_of_nonpos_of_nonneg (by linarith) ε0),
    simp only [dist_le_zero] at this,
    rw this },
  have If' : (0 : ℝ) < f'symm.nnnorm,
    by { rw [← inv_pos], exact (nnreal.coe_nonneg _).trans_lt hc },
  have Icf' : (c : ℝ) * f'symm.nnnorm < 1, by rwa [inv_eq_one_div, lt_div_iff If'] at hc,
  have Jf' : (f'symm.nnnorm : ℝ) ≠ 0 := ne_of_gt If',
  have Jcf' : (1 : ℝ) - c * f'symm.nnnorm ≠ 0, by { apply ne_of_gt, linarith },
  /- We have to show that `y` can be written as `f x` for some `x ∈ closed_ball b ε`.
  The idea of the proof is to apply the Banach contraction principle to the map
  `g : x ↦ x + f'symm (y - f x)`, as a fixed point of this map satisfies `f x = y`.
  When `f'symm` is a genuine linear inverse, `g` is a contracting map. In our case, since `f'symm`
  is nonlinear, this map is not contracting (it is not even continuous), but still the proof of
  the contraction theorem holds: `uₙ = gⁿ b` is a Cauchy sequence, converging exponentially fast
  to the desired point `x`. Instead of appealing to general results, we check this by hand.

  The main point is that `f (u n)` becomes exponentially close to `y`, and therefore
  `dist (u (n+1)) (u n)` becomes exponentally small, making it possible to get an inductive
  bound on `dist (u n) b`, from which one checks that `u n` stays in the ball on which one has a
  control. Therefore, the bound can be checked at the next step, and so on inductively.
  -/
  set g := λ x, x + f'symm (y - f x) with hg,
  set u := λ (n : ℕ), g ^[n] b with hu,
  have usucc : ∀ n, u (n + 1) = g (u n), by simp [hu, ← iterate_succ_apply' g _ b],
  -- First bound: if `f z` is close to `y`, then `g z` is close to `z` (i.e., almost a fixed point).
  have A : ∀ z, dist (g z) z ≤ f'symm.nnnorm * dist (f z) y,
  { assume z,
    rw [dist_eq_norm, hg, add_sub_cancel', dist_eq_norm'],
    exact f'symm.bound _ },
  -- Second bound: if `z` and `g z` are in the set with good control, then `f (g z)` becomes closer
  -- to `y` than `f z` was (this uses the linear approximation property, and is the reason for the
  -- choice of the formula for `g`).
  have B : ∀ z ∈ closed_ball b ε, g z ∈ closed_ball b ε →
    dist (f (g z)) y ≤ c * f'symm.nnnorm * dist (f z) y,
  { assume z hz hgz,
    set v := f'symm (y - f z) with hv,
    calc dist (f (g z)) y = ‖f (z + v) - y‖ : by rw [dist_eq_norm]
    ... = ‖f (z + v) - f  z - f' v + f' v - (y - f z)‖ : by { congr' 1, abel }
    ... = ‖f (z + v) - f z - f' ((z + v) - z)‖ :
      by simp only [continuous_linear_map.nonlinear_right_inverse.right_inv,
                    add_sub_cancel', sub_add_cancel]
    ... ≤ c * ‖(z + v) - z‖ : hf _ (hε hgz) _ (hε hz)
    ... ≤ c * (f'symm.nnnorm * dist (f z) y) : begin
      apply mul_le_mul_of_nonneg_left _ (nnreal.coe_nonneg c),
      simpa [hv, dist_eq_norm'] using f'symm.bound (y - f z),
    end
    ... = c * f'symm.nnnorm * dist (f z) y : by ring },
  -- Third bound: a complicated bound on `dist w b` (that will show up in the induction) is enough
  -- to check that `w` is in the ball on which one has controls. Will be used to check that `u n`
  -- belongs to this ball for all `n`.
  have C : ∀ (n : ℕ) (w : E),
    dist w b ≤ f'symm.nnnorm * (1 - (c * f'symm.nnnorm)^n) / (1 - c * f'symm.nnnorm) * dist (f b) y
    → w ∈ closed_ball b ε,
  { assume n w hw,
    apply hw.trans,
    rw [div_mul_eq_mul_div, div_le_iff], swap, { linarith },
    calc (f'symm.nnnorm : ℝ) * (1 - (c * f'symm.nnnorm) ^ n) * dist (f b) y
      = f'symm.nnnorm * dist (f b) y * (1 - (c * f'symm.nnnorm) ^ n) : by ring
      ... ≤ f'symm.nnnorm * dist (f b) y * 1 :
      begin
        apply mul_le_mul_of_nonneg_left _ (mul_nonneg (nnreal.coe_nonneg _) dist_nonneg),
        rw [sub_le_self_iff],
        exact pow_nonneg (mul_nonneg (nnreal.coe_nonneg _) (nnreal.coe_nonneg _)) _,
      end
    ... ≤ f'symm.nnnorm * (((f'symm.nnnorm : ℝ)⁻¹ - c) * ε) :
      by { rw [mul_one],
           exact mul_le_mul_of_nonneg_left (mem_closed_ball'.1 hy) (nnreal.coe_nonneg _) }
    ... = ε * (1 - c * f'symm.nnnorm) : by { field_simp, ring } },
  /- Main inductive control: `f (u n)` becomes exponentially close to `y`, and therefore
  `dist (u (n+1)) (u n)` becomes exponentally small, making it possible to get an inductive
  bound on `dist (u n) b`, from which one checks that `u n` remains in the ball on which we
  have estimates. -/
  have D : ∀ (n : ℕ), dist (f (u n)) y ≤ (c * f'symm.nnnorm)^n * dist (f b) y
    ∧ dist (u n) b ≤ f'symm.nnnorm * (1 - (c * f'symm.nnnorm)^n) / (1 - c * f'symm.nnnorm)
      * dist (f b) y,
  { assume n,
    induction n with n IH, { simp [hu, le_refl] },
    rw usucc,
    have Ign : dist (g (u n)) b ≤
      f'symm.nnnorm * (1 - (c * f'symm.nnnorm)^n.succ) / (1 - c * f'symm.nnnorm) * dist (f b) y :=
    calc
      dist (g (u n)) b ≤ dist (g (u n)) (u n) + dist (u n) b : dist_triangle _ _ _
      ... ≤ f'symm.nnnorm * dist (f (u n)) y + dist (u n) b : add_le_add (A _) le_rfl
      ... ≤ f'symm.nnnorm * ((c * f'symm.nnnorm)^n * dist (f b) y) +
        f'symm.nnnorm * (1 - (c * f'symm.nnnorm)^n) / (1 - c * f'symm.nnnorm) * dist (f b) y :
          add_le_add (mul_le_mul_of_nonneg_left IH.1 (nnreal.coe_nonneg _)) IH.2
      ... = f'symm.nnnorm * (1 - (c * f'symm.nnnorm)^n.succ) / (1 - c * f'symm.nnnorm)
        * dist (f b) y : by { field_simp [Jcf'], ring_exp },
    refine ⟨_, Ign⟩,
    calc dist (f (g (u n))) y ≤ c * f'symm.nnnorm * dist (f (u n)) y :
      B _ (C n _ IH.2) (C n.succ _ Ign)
    ... ≤ (c * f'symm.nnnorm) * ((c * f'symm.nnnorm)^n * dist (f b) y) :
      mul_le_mul_of_nonneg_left IH.1 (mul_nonneg (nnreal.coe_nonneg _) (nnreal.coe_nonneg _))
    ... = (c * f'symm.nnnorm) ^ n.succ * dist (f b) y : by ring_exp },
  -- Deduce from the inductive bound that `uₙ` is a Cauchy sequence, therefore converging.
  have : cauchy_seq u,
  { have : ∀ (n : ℕ), dist (u n) (u (n+1)) ≤ f'symm.nnnorm * dist (f b) y * (c * f'symm.nnnorm)^n,
    { assume n,
      calc dist (u n) (u (n+1)) = dist (g (u n)) (u n) :  by rw [usucc, dist_comm]
      ... ≤ f'symm.nnnorm * dist (f (u n)) y : A _
      ... ≤ f'symm.nnnorm * ((c * f'symm.nnnorm)^n * dist (f b) y) :
        mul_le_mul_of_nonneg_left (D n).1 (nnreal.coe_nonneg _)
      ... = f'symm.nnnorm * dist (f b) y * (c * f'symm.nnnorm)^n : by ring },
    exact cauchy_seq_of_le_geometric _ _ Icf' this },
  obtain ⟨x, hx⟩ : ∃ x, tendsto u at_top (𝓝 x) := cauchy_seq_tendsto_of_complete this,
  -- As all the `uₙ` belong to the ball `closed_ball b ε`, so does their limit `x`.
  have xmem : x ∈ closed_ball b ε :=
    is_closed_ball.mem_of_tendsto hx (eventually_of_forall (λ n, C n _ (D n).2)),
  refine ⟨x, xmem, _⟩,
  -- It remains to check that `f x = y`. This follows from continuity of `f` on `closed_ball b ε`
  -- and from the fact that `f uₙ` is converging to `y` by construction.
  have hx' : tendsto u at_top (𝓝[closed_ball b ε] x),
  { simp only [nhds_within, tendsto_inf, hx, true_and, ge_iff_le, tendsto_principal],
    exact eventually_of_forall (λ n, C n _ (D n).2) },
  have T1 : tendsto (λ n, f (u n)) at_top (𝓝 (f x)) :=
    (hf.continuous_on.mono hε x xmem).tendsto.comp hx',
  have T2 : tendsto (λ n, f (u n)) at_top (𝓝 y),
  { rw tendsto_iff_dist_tendsto_zero,
    refine squeeze_zero (λ n, dist_nonneg) (λ n, (D n).1) _,
    simpa using (tendsto_pow_at_top_nhds_0_of_lt_1
      (mul_nonneg (nnreal.coe_nonneg _) (nnreal.coe_nonneg _)) Icf').mul tendsto_const_nhds },
  exact tendsto_nhds_unique T1 T2,
end

lemma open_image (hf : approximates_linear_on f f' s c) (f'symm : f'.nonlinear_right_inverse)
  (hs : is_open s) (hc : subsingleton F ∨ c < f'symm.nnnorm⁻¹) : is_open (f '' s) :=
begin
  cases hc with hE hc, { resetI, apply is_open_discrete },
  simp only [is_open_iff_mem_nhds, nhds_basis_closed_ball.mem_iff, ball_image_iff] at hs ⊢,
  intros x hx,
  rcases hs x hx with ⟨ε, ε0, hε⟩,
  refine ⟨(f'symm.nnnorm⁻¹ - c) * ε, mul_pos (sub_pos.2 hc) ε0, _⟩,
  exact (hf.surj_on_closed_ball_of_nonlinear_right_inverse f'symm (le_of_lt ε0) hε).mono
    hε (subset.refl _)
end

lemma image_mem_nhds (hf : approximates_linear_on f f' s c) (f'symm : f'.nonlinear_right_inverse)
  {x : E} (hs : s ∈ 𝓝 x) (hc : subsingleton F ∨ c < f'symm.nnnorm⁻¹) :
  f '' s ∈ 𝓝 (f x) :=
begin
  obtain ⟨t, hts, ht, xt⟩ : ∃ t ⊆ s, is_open t ∧ x ∈ t := _root_.mem_nhds_iff.1 hs,
  have := is_open.mem_nhds ((hf.mono_set hts).open_image f'symm ht hc) (mem_image_of_mem _ xt),
  exact mem_of_superset this (image_subset _ hts),
end

lemma map_nhds_eq (hf : approximates_linear_on f f' s c) (f'symm : f'.nonlinear_right_inverse)
  {x : E} (hs : s ∈ 𝓝 x) (hc : subsingleton F ∨ c < f'symm.nnnorm⁻¹) :
  map f (𝓝 x) = 𝓝 (f x) :=
begin
  refine le_antisymm ((hf.continuous_on x (mem_of_mem_nhds hs)).continuous_at hs)
    (le_map (λ t ht, _)),
  have : f '' (s ∩ t) ∈ 𝓝 (f x) := (hf.mono_set (inter_subset_left s t)).image_mem_nhds
    f'symm (inter_mem hs ht) hc,
  exact mem_of_superset this (image_subset _ (inter_subset_right _ _)),
end

end locally_onto

/-!
From now on we assume that `f` approximates an invertible continuous linear map `f : E ≃L[𝕜] F`.

We also assume that either `E = {0}`, or `c < ‖f'⁻¹‖⁻¹`. We use `N` as an abbreviation for `‖f'⁻¹‖`.
-/

variables {f' : E ≃L[𝕜] F} {s : set E} {c : ℝ≥0}

local notation `N` := ‖(f'.symm : F →L[𝕜] E)‖₊

protected lemma antilipschitz (hf : approximates_linear_on f (f' : E →L[𝕜] F) s c)
  (hc : subsingleton E ∨ c < N⁻¹) :
  antilipschitz_with (N⁻¹ - c)⁻¹ (s.restrict f) :=
begin
  cases hc with hE hc,
  { haveI : subsingleton s := ⟨λ x y, subtype.eq $ @subsingleton.elim _ hE _ _⟩,
    exact antilipschitz_with.of_subsingleton },
  convert (f'.antilipschitz.restrict s).add_lipschitz_with hf.lipschitz_sub hc,
  simp [restrict]
end

protected lemma injective (hf : approximates_linear_on f (f' : E →L[𝕜] F) s c)
  (hc : subsingleton E ∨ c < N⁻¹) :
  injective (s.restrict f) :=
(hf.antilipschitz hc).injective

protected lemma inj_on (hf : approximates_linear_on f (f' : E →L[𝕜] F) s c)
  (hc : subsingleton E ∨ c < N⁻¹) :
  inj_on f s :=
inj_on_iff_injective.2 $ hf.injective hc

protected lemma surjective [complete_space E]
  (hf : approximates_linear_on f (f' : E →L[𝕜] F) univ c) (hc : subsingleton E ∨ c < N⁻¹) :
  surjective f :=
begin
  cases hc with hE hc,
  { haveI : subsingleton F := (equiv.subsingleton_congr f'.to_linear_equiv.to_equiv).1 hE,
    exact surjective_to_subsingleton _ },
  { apply forall_of_forall_mem_closed_ball (λ (y : F), ∃ a, f a = y) (f 0) _,
    have hc' : (0 : ℝ) < N⁻¹ - c, by { rw sub_pos, exact hc },
    let p : ℝ → Prop := λ R, closed_ball (f 0) R ⊆ set.range f,
    have hp : ∀ᶠ (r:ℝ) in at_top, p ((N⁻¹ - c) * r),
    { have hr : ∀ᶠ (r:ℝ) in at_top, 0 ≤ r := eventually_ge_at_top 0,
      refine hr.mono (λ r hr, subset.trans _ (image_subset_range f (closed_ball 0 r))),
      refine hf.surj_on_closed_ball_of_nonlinear_right_inverse f'.to_nonlinear_right_inverse hr _,
      exact subset_univ _ },
    refine ((tendsto_id.const_mul_at_top hc').frequently hp.frequently).mono _,
    exact λ R h y hy, h hy },
end

/-- A map approximating a linear equivalence on a set defines a local equivalence on this set.
Should not be used outside of this file, because it is superseded by `to_local_homeomorph` below.

This is a first step towards the inverse function. -/
def to_local_equiv (hf : approximates_linear_on f (f' : E →L[𝕜] F) s c)
  (hc : subsingleton E ∨ c < N⁻¹) : local_equiv E F :=
(hf.inj_on hc).to_local_equiv _ _

/-- The inverse function is continuous on `f '' s`. Use properties of `local_homeomorph` instead. -/
lemma inverse_continuous_on (hf : approximates_linear_on f (f' : E →L[𝕜] F) s c)
  (hc : subsingleton E ∨ c < N⁻¹) :
  continuous_on (hf.to_local_equiv hc).symm (f '' s) :=
begin
  apply continuous_on_iff_continuous_restrict.2,
  refine ((hf.antilipschitz hc).to_right_inv_on' _ (hf.to_local_equiv hc).right_inv').continuous,
  exact (λ x hx, (hf.to_local_equiv hc).map_target hx)
end

/-- The inverse function is approximated linearly on `f '' s` by `f'.symm`. -/
lemma to_inv (hf : approximates_linear_on f (f' : E →L[𝕜] F) s c)
  (hc : subsingleton E ∨ c < N⁻¹) :
  approximates_linear_on (hf.to_local_equiv hc).symm (f'.symm : F →L[𝕜] E) (f '' s)
    (N * (N⁻¹ - c)⁻¹ * c) :=
begin
  assume x hx y hy,
  set A := hf.to_local_equiv hc with hA,
  have Af : ∀ z, A z = f z := λ z, rfl,
  rcases (mem_image _ _ _).1 hx with ⟨x', x's, rfl⟩,
  rcases (mem_image _ _ _).1 hy with ⟨y', y's, rfl⟩,
  rw [← Af x', ← Af y', A.left_inv x's, A.left_inv y's],
  calc ‖x' - y' - (f'.symm) (A x' - A y')‖
      ≤ N * ‖f' (x' - y' - (f'.symm) (A x' - A y'))‖ :
    (f' : E →L[𝕜] F).bound_of_antilipschitz f'.antilipschitz _
  ... = N * ‖A y' - A x' - f' (y' - x')‖ :
    begin
      congr' 2,
      simp only [continuous_linear_equiv.apply_symm_apply, continuous_linear_equiv.map_sub],
      abel,
    end
  ... ≤ N * (c * ‖y' - x'‖) :
    mul_le_mul_of_nonneg_left (hf _ y's _ x's) (nnreal.coe_nonneg _)
  ... ≤ N * (c * (((N⁻¹ - c)⁻¹ : ℝ≥0) * ‖A y' - A x'‖)) :
    begin
      apply_rules [mul_le_mul_of_nonneg_left, nnreal.coe_nonneg],
      rw [← dist_eq_norm, ← dist_eq_norm],
      exact (hf.antilipschitz hc).le_mul_dist ⟨y', y's⟩ ⟨x', x's⟩,
    end
  ... = (N * (N⁻¹ - c)⁻¹ * c : ℝ≥0) * ‖A x' - A y'‖ :
    by { simp only [norm_sub_rev, nonneg.coe_mul], ring }
end

include cs

section
variables (f s)

/-- Given a function `f` that approximates a linear equivalence on an open set `s`,
returns a local homeomorph with `to_fun = f` and `source = s`. -/
def to_local_homeomorph (hf : approximates_linear_on f (f' : E →L[𝕜] F) s c)
  (hc : subsingleton E ∨ c < N⁻¹) (hs : is_open s) : local_homeomorph E F :=
{ to_local_equiv := hf.to_local_equiv hc,
  open_source := hs,
  open_target := hf.open_image f'.to_nonlinear_right_inverse hs
    (by rwa f'.to_linear_equiv.to_equiv.subsingleton_congr at hc),
  continuous_to_fun := hf.continuous_on,
  continuous_inv_fun := hf.inverse_continuous_on hc }

/-- A function `f` that approximates a linear equivalence on the whole space is a homeomorphism. -/
def to_homeomorph (hf : approximates_linear_on f (f' : E →L[𝕜] F) univ c)
  (hc : subsingleton E ∨ c < N⁻¹) :
  E ≃ₜ F :=
begin
  refine (hf.to_local_homeomorph _ _ hc is_open_univ).to_homeomorph_of_source_eq_univ_target_eq_univ
    rfl _,
  change f '' univ = univ,
  rw [image_univ, range_iff_surjective],
  exact hf.surjective hc,
end

omit cs

/-- In a real vector space, a function `f` that approximates a linear equivalence on a subset `s`
can be extended to a homeomorphism of the whole space. -/
lemma exists_homeomorph_extension {E : Type*} [normed_add_comm_group E] [normed_space ℝ E]
  {F : Type*} [normed_add_comm_group F] [normed_space ℝ F] [finite_dimensional ℝ F]
  {s : set E} {f : E → F} {f' : E ≃L[ℝ] F} {c : ℝ≥0}
  (hf : approximates_linear_on f (f' : E →L[ℝ] F) s c)
  (hc : subsingleton E ∨ lipschitz_extension_constant F * c < (‖(f'.symm : F →L[ℝ] E)‖₊)⁻¹) :
  ∃ g : E ≃ₜ F, eq_on f g s :=
begin
  -- the difference `f - f'` is Lipschitz on `s`. It can be extended to a Lipschitz function `u`
  -- on the whole space, with a slightly worse Lipschitz constant. Then `f' + u` will be the
  -- desired homeomorphism.
  obtain ⟨u, hu, uf⟩ : ∃ (u : E → F), lipschitz_with (lipschitz_extension_constant F * c) u
    ∧ eq_on (f - f') u s := hf.lipschitz_on_with.extend_finite_dimension,
  let g : E → F := λ x, f' x + u x,
  have fg : eq_on f g s := λ x hx, by simp_rw [g, ← uf hx, pi.sub_apply, add_sub_cancel'_right],
  have hg : approximates_linear_on g (f' : E →L[ℝ] F) univ (lipschitz_extension_constant F * c),
  { apply lipschitz_on_with.approximates_linear_on,
    rw lipschitz_on_univ,
    convert hu,
    ext x,
    simp only [add_sub_cancel', continuous_linear_equiv.coe_coe, pi.sub_apply] },
  haveI : finite_dimensional ℝ E := f'.symm.to_linear_equiv.finite_dimensional,
  exact ⟨hg.to_homeomorph g hc, fg⟩,
end

end

@[simp] lemma to_local_homeomorph_coe (hf : approximates_linear_on f (f' : E →L[𝕜] F) s c)
  (hc : subsingleton E ∨ c < N⁻¹) (hs : is_open s) :
  (hf.to_local_homeomorph f s hc hs : E → F) = f := rfl

@[simp] lemma to_local_homeomorph_source (hf : approximates_linear_on f (f' : E →L[𝕜] F) s c)
  (hc : subsingleton E ∨ c < N⁻¹) (hs : is_open s) :
  (hf.to_local_homeomorph f s hc hs).source = s := rfl

@[simp] lemma to_local_homeomorph_target (hf : approximates_linear_on f (f' : E →L[𝕜] F) s c)
  (hc : subsingleton E ∨ c < N⁻¹) (hs : is_open s) :
  (hf.to_local_homeomorph f s hc hs).target = f '' s := rfl

lemma closed_ball_subset_target (hf : approximates_linear_on f (f' : E →L[𝕜] F) s c)
  (hc : subsingleton E ∨ c < N⁻¹) (hs : is_open s) {b : E} (ε0 : 0 ≤ ε) (hε : closed_ball b ε ⊆ s) :
  closed_ball (f b) ((N⁻¹ - c) * ε) ⊆ (hf.to_local_homeomorph f s hc hs).target :=
(hf.surj_on_closed_ball_of_nonlinear_right_inverse f'.to_nonlinear_right_inverse
  ε0 hε).mono hε (subset.refl _)

end approximates_linear_on

/-!
### Inverse function theorem

Now we prove the inverse function theorem. Let `f : E → F` be a map defined on a complete vector
space `E`. Assume that `f` has an invertible derivative `f' : E ≃L[𝕜] F` at `a : E` in the strict
sense. Then `f` approximates `f'` in the sense of `approximates_linear_on` on an open neighborhood
of `a`, and we can apply `approximates_linear_on.to_local_homeomorph` to construct the inverse
function. -/

namespace has_strict_fderiv_at

/-- If `f` has derivative `f'` at `a` in the strict sense and `c > 0`, then `f` approximates `f'`
with constant `c` on some neighborhood of `a`. -/
lemma approximates_deriv_on_nhds {f : E → F} {f' : E →L[𝕜] F} {a : E}
  (hf : has_strict_fderiv_at f f' a) {c : ℝ≥0} (hc : subsingleton E ∨ 0 < c) :
  ∃ s ∈ 𝓝 a, approximates_linear_on f f' s c :=
begin
  cases hc with hE hc,
  { refine ⟨univ, is_open.mem_nhds is_open_univ trivial, λ x hx y hy, _⟩,
    simp [@subsingleton.elim E hE x y] },
  have := hf.def hc,
  rw [nhds_prod_eq, filter.eventually, mem_prod_same_iff] at this,
  rcases this with ⟨s, has, hs⟩,
  exact ⟨s, has, λ x hx y hy, hs (mk_mem_prod hx hy)⟩
end

lemma map_nhds_eq_of_surj [complete_space E] [complete_space F]
  {f : E → F} {f' : E →L[𝕜] F} {a : E}
  (hf : has_strict_fderiv_at f (f' : E →L[𝕜] F) a) (h : linear_map.range f' = ⊤) :
  map f (𝓝 a) = 𝓝 (f a) :=
begin
  let f'symm := f'.nonlinear_right_inverse_of_surjective h,
  set c : ℝ≥0 := f'symm.nnnorm⁻¹ / 2 with hc,
  have f'symm_pos : 0 < f'symm.nnnorm := f'.nonlinear_right_inverse_of_surjective_nnnorm_pos h,
  have cpos : 0 < c, by simp [hc, half_pos, inv_pos, f'symm_pos],
  obtain ⟨s, s_nhds, hs⟩ : ∃ s ∈ 𝓝 a, approximates_linear_on f f' s c :=
    hf.approximates_deriv_on_nhds (or.inr cpos),
  apply hs.map_nhds_eq f'symm s_nhds (or.inr (nnreal.half_lt_self _)),
  simp [ne_of_gt f'symm_pos],
end

variables [cs : complete_space E] {f : E → F} {f' : E ≃L[𝕜] F} {a : E}

lemma approximates_deriv_on_open_nhds (hf : has_strict_fderiv_at f (f' : E →L[𝕜] F) a) :
  ∃ (s : set E) (hs : a ∈ s ∧ is_open s),
    approximates_linear_on f (f' : E →L[𝕜] F) s (‖(f'.symm : F →L[𝕜] E)‖₊⁻¹ / 2) :=
begin
  refine ((nhds_basis_opens a).exists_iff _).1 _,
  exact (λ s t, approximates_linear_on.mono_set),
  exact (hf.approximates_deriv_on_nhds $ f'.subsingleton_or_nnnorm_symm_pos.imp id $
    λ hf', half_pos $ inv_pos.2 hf')
end

include cs

variable (f)

/-- Given a function with an invertible strict derivative at `a`, returns a `local_homeomorph`
with `to_fun = f` and `a ∈ source`. This is a part of the inverse function theorem.
The other part `has_strict_fderiv_at.to_local_inverse` states that the inverse function
of this `local_homeomorph` has derivative `f'.symm`. -/
def to_local_homeomorph (hf : has_strict_fderiv_at f (f' : E →L[𝕜] F) a) : local_homeomorph E F :=
approximates_linear_on.to_local_homeomorph f
  (classical.some hf.approximates_deriv_on_open_nhds)
  (classical.some_spec hf.approximates_deriv_on_open_nhds).snd
  (f'.subsingleton_or_nnnorm_symm_pos.imp id $ λ hf', nnreal.half_lt_self $ ne_of_gt $
    inv_pos.2 hf')
  (classical.some_spec hf.approximates_deriv_on_open_nhds).fst.2

variable {f}

@[simp] lemma to_local_homeomorph_coe (hf : has_strict_fderiv_at f (f' : E →L[𝕜] F) a) :
  (hf.to_local_homeomorph f : E → F) = f := rfl

lemma mem_to_local_homeomorph_source (hf : has_strict_fderiv_at f (f' : E →L[𝕜] F) a) :
  a ∈ (hf.to_local_homeomorph f).source :=
(classical.some_spec hf.approximates_deriv_on_open_nhds).fst.1

lemma image_mem_to_local_homeomorph_target (hf : has_strict_fderiv_at f (f' : E →L[𝕜] F) a) :
  f a ∈ (hf.to_local_homeomorph f).target :=
(hf.to_local_homeomorph f).map_source hf.mem_to_local_homeomorph_source

lemma map_nhds_eq_of_equiv (hf : has_strict_fderiv_at f (f' : E →L[𝕜] F) a) :
  map f (𝓝 a) = 𝓝 (f a) :=
(hf.to_local_homeomorph f).map_nhds_eq hf.mem_to_local_homeomorph_source

variables (f f' a)

/-- Given a function `f` with an invertible derivative, returns a function that is locally inverse
to `f`. -/
def local_inverse (hf : has_strict_fderiv_at f (f' : E →L[𝕜] F) a) : F → E :=
(hf.to_local_homeomorph f).symm

variables {f f' a}

lemma local_inverse_def (hf : has_strict_fderiv_at f (f' : E →L[𝕜] F) a) :
  hf.local_inverse f _ _ = (hf.to_local_homeomorph f).symm :=
rfl

lemma eventually_left_inverse (hf : has_strict_fderiv_at f (f' : E →L[𝕜] F) a) :
  ∀ᶠ x in 𝓝 a, hf.local_inverse f f' a (f x) = x :=
(hf.to_local_homeomorph f).eventually_left_inverse hf.mem_to_local_homeomorph_source

@[simp]

lemma eventually_right_inverse (hf : has_strict_fderiv_at f (f' : E →L[𝕜] F) a) :
  ∀ᶠ y in 𝓝 (f a), f (hf.local_inverse f f' a y) = y :=
(hf.to_local_homeomorph f).eventually_right_inverse' hf.mem_to_local_homeomorph_source

lemma local_inverse_continuous_at (hf : has_strict_fderiv_at f (f' : E →L[𝕜] F) a) :
  continuous_at (hf.local_inverse f f' a) (f a) :=
(hf.to_local_homeomorph f).continuous_at_symm hf.image_mem_to_local_homeomorph_target

lemma local_inverse_tendsto (hf : has_strict_fderiv_at f (f' : E →L[𝕜] F) a) :
  tendsto (hf.local_inverse f f' a) (𝓝 $ f a) (𝓝 a) :=
(hf.to_local_homeomorph f).tendsto_symm hf.mem_to_local_homeomorph_source

lemma local_inverse_unique (hf : has_strict_fderiv_at f (f' : E →L[𝕜] F) a) {g : F → E}
  (hg : ∀ᶠ x in 𝓝 a, g (f x) = x) :
  ∀ᶠ y in 𝓝 (f a), g y = local_inverse f f' a hf y :=
eventually_eq_of_left_inv_of_right_inv hg hf.eventually_right_inverse $
  (hf.to_local_homeomorph f).tendsto_symm hf.mem_to_local_homeomorph_source

/-- If `f` has an invertible derivative `f'` at `a` in the sense of strict differentiability `(hf)`,
then the inverse function `hf.local_inverse f` has derivative `f'.symm` at `f a`. -/
theorem to_local_inverse (hf : has_strict_fderiv_at f (f' : E →L[𝕜] F) a) :
  has_strict_fderiv_at (hf.local_inverse f f' a) (f'.symm : F →L[𝕜] E) (f a) :=
(hf.to_local_homeomorph f).has_strict_fderiv_at_symm hf.image_mem_to_local_homeomorph_target $
  by simpa [← local_inverse_def] using hf

/-- If `f : E → F` has an invertible derivative `f'` at `a` in the sense of strict differentiability
and `g (f x) = x` in a neighborhood of `a`, then `g` has derivative `f'.symm` at `f a`.

For a version assuming `f (g y) = y` and continuity of `g` at `f a` but not `[complete_space E]`
see `of_local_left_inverse`.  -/
theorem to_local_left_inverse (hf : has_strict_fderiv_at f (f' : E →L[𝕜] F) a) {g : F → E}
  (hg : ∀ᶠ x in 𝓝 a, g (f x) = x) :
  has_strict_fderiv_at g (f'.symm : F →L[𝕜] E) (f a) :=
hf.to_local_inverse.congr_of_eventually_eq $ (hf.local_inverse_unique hg).mono $ λ _, eq.symm

end has_strict_fderiv_at

/-- If a function has an invertible strict derivative at all points, then it is an open map. -/
lemma open_map_of_strict_fderiv_equiv [complete_space E] {f : E → F} {f' : E → E ≃L[𝕜] F}
  (hf : ∀ x, has_strict_fderiv_at f (f' x : E →L[𝕜] F) x) :
  is_open_map f :=
is_open_map_iff_nhds_le.2 $ λ x, (hf x).map_nhds_eq_of_equiv.ge

/-!
### Inverse function theorem, 1D case

In this case we prove a version of the inverse function theorem for maps `f : 𝕜 → 𝕜`.
We use `continuous_linear_equiv.units_equiv_aut` to translate `has_strict_deriv_at f f' a` and
`f' ≠ 0` into `has_strict_fderiv_at f (_ : 𝕜 ≃L[𝕜] 𝕜) a`.
-/

namespace has_strict_deriv_at

variables [cs : complete_space 𝕜] {f : 𝕜 → 𝕜} {f' a : 𝕜} (hf : has_strict_deriv_at f f' a)
  (hf' : f' ≠ 0)

include cs

variables (f f' a)

/-- A function that is inverse to `f` near `a`. -/
@[reducible] def local_inverse : 𝕜 → 𝕜 :=
(hf.has_strict_fderiv_at_equiv hf').local_inverse _ _ _

variables {f f' a}

lemma map_nhds_eq : map f (𝓝 a) = 𝓝 (f a) :=
(hf.has_strict_fderiv_at_equiv hf').map_nhds_eq_of_equiv

theorem to_local_inverse : has_strict_deriv_at (hf.local_inverse f f' a hf') f'⁻¹ (f a) :=
(hf.has_strict_fderiv_at_equiv hf').to_local_inverse

theorem to_local_left_inverse {g : 𝕜 → 𝕜} (hg : ∀ᶠ x in 𝓝 a, g (f x) = x) :
  has_strict_deriv_at g f'⁻¹ (f a) :=
(hf.has_strict_fderiv_at_equiv hf').to_local_left_inverse hg

end has_strict_deriv_at

/-- If a function has a non-zero strict derivative at all points, then it is an open map. -/
lemma open_map_of_strict_deriv [complete_space 𝕜] {f f' : 𝕜 → 𝕜}
  (hf : ∀ x, has_strict_deriv_at f (f' x) x) (h0 : ∀ x, f' x ≠ 0) :
  is_open_map f :=
is_open_map_iff_nhds_le.2 $ λ x, ((hf x).map_nhds_eq (h0 x)).ge

/-!
### Inverse function theorem, smooth case

-/

namespace cont_diff_at
variables {𝕂 : Type*} [is_R_or_C 𝕂]
variables {E' : Type*} [normed_add_comm_group E'] [normed_space 𝕂 E']
variables {F' : Type*} [normed_add_comm_group F'] [normed_space 𝕂 F']
variables [complete_space E'] (f : E' → F') {f' : E' ≃L[𝕂] F'} {a : E'}

/-- Given a `cont_diff` function over `𝕂` (which is `ℝ` or `ℂ`) with an invertible
derivative at `a`, returns a `local_homeomorph` with `to_fun = f` and `a ∈ source`. -/
def to_local_homeomorph
  {n : ℕ∞} (hf : cont_diff_at 𝕂 n f a) (hf' : has_fderiv_at f (f' : E' →L[𝕂] F') a)
  (hn : 1 ≤ n) :
  local_homeomorph E' F' :=
(hf.has_strict_fderiv_at' hf' hn).to_local_homeomorph f

variable {f}

@[simp] lemma to_local_homeomorph_coe
  {n : ℕ∞} (hf : cont_diff_at 𝕂 n f a) (hf' : has_fderiv_at f (f' : E' →L[𝕂] F') a)
  (hn : 1 ≤ n) :
  (hf.to_local_homeomorph f hf' hn : E' → F') = f := rfl

lemma mem_to_local_homeomorph_source
  {n : ℕ∞} (hf : cont_diff_at 𝕂 n f a) (hf' : has_fderiv_at f (f' : E' →L[𝕂] F') a)
  (hn : 1 ≤ n) :
  a ∈ (hf.to_local_homeomorph f hf' hn).source :=
(hf.has_strict_fderiv_at' hf' hn).mem_to_local_homeomorph_source

lemma image_mem_to_local_homeomorph_target
  {n : ℕ∞} (hf : cont_diff_at 𝕂 n f a) (hf' : has_fderiv_at f (f' : E' →L[𝕂] F') a)
  (hn : 1 ≤ n) :
  f a ∈ (hf.to_local_homeomorph f hf' hn).target :=
(hf.has_strict_fderiv_at' hf' hn).image_mem_to_local_homeomorph_target

/-- Given a `cont_diff` function over `𝕂` (which is `ℝ` or `ℂ`) with an invertible derivative
at `a`, returns a function that is locally inverse to `f`. -/
def local_inverse
  {n : ℕ∞} (hf : cont_diff_at 𝕂 n f a) (hf' : has_fderiv_at f (f' : E' →L[𝕂] F') a)
  (hn : 1 ≤ n) :
  F' → E' :=
(hf.has_strict_fderiv_at' hf' hn).local_inverse f f' a

lemma local_inverse_apply_image
  {n : ℕ∞} (hf : cont_diff_at 𝕂 n f a) (hf' : has_fderiv_at f (f' : E' →L[𝕂] F') a)
  (hn : 1 ≤ n) :
  hf.local_inverse hf' hn (f a) = a :=
(hf.has_strict_fderiv_at' hf' hn).local_inverse_apply_image

/-- Given a `cont_diff` function over `𝕂` (which is `ℝ` or `ℂ`) with an invertible derivative
at `a`, the inverse function (produced by `cont_diff.to_local_homeomorph`) is
also `cont_diff`. -/
lemma to_local_inverse
  {n : ℕ∞} (hf : cont_diff_at 𝕂 n f a) (hf' : has_fderiv_at f (f' : E' →L[𝕂] F') a)
  (hn : 1 ≤ n) :
  cont_diff_at 𝕂 n (hf.local_inverse hf' hn) (f a) :=
begin
  have := hf.local_inverse_apply_image hf' hn,
  apply (hf.to_local_homeomorph f hf' hn).cont_diff_at_symm
    (image_mem_to_local_homeomorph_target hf hf' hn),
  { convert hf' },
  { convert hf }
end

end cont_diff_at


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

! This file was ported from Lean 3 source module algebra.lie.semisimple
! leanprover-community/mathlib commit 356447fe00e75e54777321045cdff7c9ea212e60
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Algebra.Lie.Solvable

/-!
# Semisimple Lie algebras

The famous Cartan-Dynkin-Killing classification of semisimple Lie algebras renders them one of the
most important classes of Lie algebras. In this file we define simple and semisimple Lie algebras
and prove some basic related results.

## Main definitions

  * `lie_module.is_irreducible`
  * `lie_algebra.is_simple`
  * `lie_algebra.is_semisimple`
  * `lie_algebra.is_semisimple_iff_no_solvable_ideals`
  * `lie_algebra.is_semisimple_iff_no_abelian_ideals`
  * `lie_algebra.abelian_radical_iff_solvable_is_abelian`

## Tags

lie algebra, radical, simple, semisimple
-/

universe u v w w₁ w₂

/-- A Lie module is irreducible if it is zero or its only non-trivial Lie submodule is itself. -/
class LieModule.IsIrreducible (R : Type u) (L : Type v) (M : Type w) [CommRing R] [LieRing L]
  [LieAlgebra R L] [AddCommGroup M] [Module R M] [LieRingModule L M] [LieModule R L M] : Prop where
  Irreducible : ∀ N : LieSubmodule R L M, N ≠ ⊥ → N = ⊤
#align lie_module.is_irreducible LieModule.IsIrreducible

namespace LieAlgebra

variable (R : Type u) (L : Type v)

variable [CommRing R] [LieRing L] [LieAlgebra R L]

/-- A Lie algebra is simple if it is irreducible as a Lie module over itself via the adjoint
action, and it is non-Abelian. -/
class IsSimple extends LieModule.IsIrreducible R L L : Prop where
  non_abelian : ¬IsLieAbelian L
#align lie_algebra.is_simple LieAlgebra.IsSimple

/-- A semisimple Lie algebra is one with trivial radical.

Note that the label 'semisimple' is apparently not universally agreed
[upon](https://mathoverflow.net/questions/149391/on-radicals-of-a-lie-algebra#comment383669_149391)
for general coefficients. We are following [Seligman, page 15](seligman1967) and using the label
for the weakest of the various properties which are all equivalent over a field of characteristic
zero. -/
class IsSemisimple : Prop where
  semisimple : radical R L = ⊥
#align lie_algebra.is_semisimple LieAlgebra.IsSemisimple

theorem isSemisimple_iff_no_solvable_ideals :
    IsSemisimple R L ↔ ∀ I : LieIdeal R L, IsSolvable R I → I = ⊥ :=
  ⟨fun h => supₛ_eq_bot.mp h.semisimple, fun h => ⟨supₛ_eq_bot.mpr h⟩⟩
#align lie_algebra.is_semisimple_iff_no_solvable_ideals LieAlgebra.isSemisimple_iff_no_solvable_ideals

theorem isSemisimple_iff_no_abelian_ideals :
    IsSemisimple R L ↔ ∀ I : LieIdeal R L, IsLieAbelian I → I = ⊥ :=
  by
  rw [is_semisimple_iff_no_solvable_ideals]
  constructor <;> intro h₁ I h₂
  · haveI : IsLieAbelian I := h₂
    apply h₁
    exact LieAlgebra.ofAbelianIsSolvable R I
  · haveI : IsSolvable R I := h₂
    rw [← abelian_of_solvable_ideal_eq_bot_iff]
    apply h₁
    exact abelian_derived_abelian_of_ideal I
#align lie_algebra.is_semisimple_iff_no_abelian_ideals LieAlgebra.isSemisimple_iff_no_abelian_ideals

@[simp]
theorem center_eq_bot_of_semisimple [h : IsSemisimple R L] : center R L = ⊥ :=
  by
  rw [is_semisimple_iff_no_abelian_ideals] at h
  apply h
  infer_instance
#align lie_algebra.center_eq_bot_of_semisimple LieAlgebra.center_eq_bot_of_semisimple

/-- A simple Lie algebra is semisimple. -/
instance (priority := 100) isSemisimpleOfIsSimple [h : IsSimple R L] : IsSemisimple R L :=
  by
  rw [is_semisimple_iff_no_abelian_ideals]
  intro I hI
  obtain @⟨⟨h₁⟩, h₂⟩ := id h
  by_contra contra
  rw [h₁ I contra, lie_abelian_iff_equiv_lie_abelian LieIdeal.topEquiv] at hI
  exact h₂ hI
#align lie_algebra.is_semisimple_of_is_simple LieAlgebra.isSemisimpleOfIsSimple

/-- A semisimple Abelian Lie algebra is trivial. -/
theorem subsingleton_of_semisimple_lie_abelian [IsSemisimple R L] [h : IsLieAbelian L] :
    Subsingleton L :=
  by
  rw [is_lie_abelian_iff_center_eq_top R L, center_eq_bot_of_semisimple] at h
  exact (LieSubmodule.subsingleton_iff R L L).mp (subsingleton_of_bot_eq_top h)
#align lie_algebra.subsingleton_of_semisimple_lie_abelian LieAlgebra.subsingleton_of_semisimple_lie_abelian

theorem abelian_radical_of_semisimple [IsSemisimple R L] : IsLieAbelian (radical R L) :=
  by
  rw [is_semisimple.semisimple]
  exact is_lie_abelian_bot R L
#align lie_algebra.abelian_radical_of_semisimple LieAlgebra.abelian_radical_of_semisimple

/-- The two properties shown to be equivalent here are possible definitions for a Lie algebra
to be reductive.

Note that there is absolutely [no agreement](https://mathoverflow.net/questions/284713/) on what
the label 'reductive' should mean when the coefficients are not a field of characteristic zero. -/
theorem abelian_radical_iff_solvable_is_abelian [IsNoetherian R L] :
    IsLieAbelian (radical R L) ↔ ∀ I : LieIdeal R L, IsSolvable R I → IsLieAbelian I :=
  by
  constructor
  · rintro h₁ I h₂
    rw [lie_ideal.solvable_iff_le_radical] at h₂
    exact (LieIdeal.homOfLe_injective h₂).IsLieAbelian h₁
  · intro h
    apply h
    infer_instance
#align lie_algebra.abelian_radical_iff_solvable_is_abelian LieAlgebra.abelian_radical_iff_solvable_is_abelian

theorem ad_ker_eq_bot_of_semisimple [IsSemisimple R L] : (ad R L).ker = ⊥ := by simp
#align lie_algebra.ad_ker_eq_bot_of_semisimple LieAlgebra.ad_ker_eq_bot_of_semisimple

end LieAlgebra


/-
Copyright (c) 2022 Markus Himmel. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Markus Himmel
-/
import category_theory.limits.shapes.biproducts
import category_theory.limits.preserves.shapes.zero

/-!
# Preservation of biproducts

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

We define the image of a (binary) bicone under a functor that preserves zero morphisms and define
classes `preserves_biproduct` and `preserves_binary_biproduct`. We then

* show that a functor that preserves biproducts of a two-element type preserves binary biproducts,
* construct the comparison morphisms between the image of a biproduct and the biproduct of the
  images and show that the biproduct is preserved if one of them is an isomorphism,
* give the canonical isomorphism between the image of a biproduct and the biproduct of the images
  in case that the biproduct is preserved.

-/

universes w₁ w₂ v₁ v₂ u₁ u₂

noncomputable theory

open category_theory
open category_theory.limits

namespace category_theory

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

section has_zero_morphisms
variables [has_zero_morphisms C] [has_zero_morphisms D]

namespace functor

section map
variables (F : C ⥤ D) [preserves_zero_morphisms F]

section bicone
variables {J : Type w₁}

/-- The image of a bicone under a functor. -/
@[simps]
def map_bicone {f : J → C} (b : bicone f) : bicone (F.obj ∘ f) :=
{ X := F.obj b.X,
  π := λ j, F.map (b.π j),
  ι := λ j, F.map (b.ι j),
  ι_π := λ j j',
  begin
    rw ← F.map_comp,
    split_ifs,
    { subst h,
      simp only [bicone_ι_π_self, category_theory.functor.map_id, eq_to_hom_refl] },
    { rw [bicone_ι_π_ne _ h, F.map_zero] }
  end }

lemma map_bicone_whisker {K : Type w₂} {g : K ≃ J} {f : J → C} (c : bicone f) :
  F.map_bicone (c.whisker g) = (F.map_bicone c).whisker g := rfl

end bicone

/-- The image of a binary bicone under a functor. -/
@[simps]
def map_binary_bicone {X Y : C} (b : binary_bicone X Y) : binary_bicone (F.obj X) (F.obj Y) :=
{ X := F.obj b.X,
  fst := F.map b.fst,
  snd := F.map b.snd,
  inl := F.map b.inl,
  inr := F.map b.inr,
  inl_fst' := by rw [← F.map_comp, b.inl_fst, F.map_id],
  inl_snd' := by rw [← F.map_comp, b.inl_snd, F.map_zero],
  inr_fst' := by rw [← F.map_comp, b.inr_fst, F.map_zero],
  inr_snd' := by rw [← F.map_comp, b.inr_snd, F.map_id] }

end map

end functor

open category_theory.functor

namespace limits

section bicone
variables {J : Type w₁} {K : Type w₂}

/-- A functor `F` preserves biproducts of `f` if `F` maps every bilimit bicone over `f` to a
    bilimit bicone over `F.obj ∘ f`. -/
class preserves_biproduct (f : J → C) (F : C ⥤ D) [preserves_zero_morphisms F] :=
(preserves : Π {b : bicone f}, b.is_bilimit → (F.map_bicone b).is_bilimit)

/-- A functor `F` preserves biproducts of `f` if `F` maps every bilimit bicone over `f` to a
    bilimit bicone over `F.obj ∘ f`. -/
def is_bilimit_of_preserves {f : J → C} (F : C ⥤ D) [preserves_zero_morphisms F]
  [preserves_biproduct f F] {b : bicone f} (hb : b.is_bilimit) : (F.map_bicone b).is_bilimit :=
preserves_biproduct.preserves hb

variables (J)

/-- A functor `F` preserves biproducts of shape `J` if it preserves biproducts of `f` for every
    `f : J → C`. -/
class preserves_biproducts_of_shape (F : C ⥤ D) [preserves_zero_morphisms F] :=
(preserves : Π {f : J → C}, preserves_biproduct f F)

attribute [instance, priority 100] preserves_biproducts_of_shape.preserves

end bicone

/-- A functor `F` preserves finite biproducts if it preserves biproducts of shape `J` whenever
    `J` is a fintype. -/
class preserves_finite_biproducts (F : C ⥤ D) [preserves_zero_morphisms F] :=
(preserves : Π {J : Type} [fintype J], preserves_biproducts_of_shape J F)

attribute [instance, priority 100] preserves_finite_biproducts.preserves

/-- A functor `F` preserves biproducts if it preserves biproducts of any shape `J` of size `w`.
    The usual notion of preservation of biproducts is recovered by choosing `w` to be the universe
    of the morphisms of `C`. -/
class preserves_biproducts (F : C ⥤ D) [preserves_zero_morphisms F] :=
(preserves : Π {J : Type w₁}, preserves_biproducts_of_shape J F)

attribute [instance, priority 100] preserves_biproducts.preserves

/-- Preserving biproducts at a bigger universe level implies preserving biproducts at a
smaller universe level. -/
def preserves_biproducts_shrink (F : C ⥤ D) [preserves_zero_morphisms F]
  [hp : preserves_biproducts.{max w₁ w₂} F] : preserves_biproducts.{w₁} F :=
⟨λ J, ⟨λ f, ⟨λ b ib, ((F.map_bicone b).whisker_is_bilimit_iff _).to_fun
  (is_bilimit_of_preserves F ((b.whisker_is_bilimit_iff equiv.ulift.{w₂}).inv_fun ib))⟩⟩⟩

@[priority 100]
instance preserves_finite_biproducts_of_preserves_biproducts (F : C ⥤ D)
  [preserves_zero_morphisms F] [preserves_biproducts.{w₁} F] : preserves_finite_biproducts F :=
{ preserves := λ J _, by letI := preserves_biproducts_shrink.{0} F; apply_instance }

/-- A functor `F` preserves binary biproducts of `X` and `Y` if `F` maps every bilimit bicone over
    `X` and `Y` to a bilimit bicone over `F.obj X` and `F.obj Y`. -/
class preserves_binary_biproduct (X Y : C) (F : C ⥤ D) [preserves_zero_morphisms F] :=
(preserves : Π {b : binary_bicone X Y}, b.is_bilimit → (F.map_binary_bicone b).is_bilimit)

/-- A functor `F` preserves binary biproducts of `X` and `Y` if `F` maps every bilimit bicone over
    `X` and `Y` to a bilimit bicone over `F.obj X` and `F.obj Y`. -/
def is_binary_bilimit_of_preserves {X Y : C} (F : C ⥤ D) [preserves_zero_morphisms F]
  [preserves_binary_biproduct X Y F] {b : binary_bicone X Y} (hb : b.is_bilimit) :
  (F.map_binary_bicone b).is_bilimit :=
preserves_binary_biproduct.preserves hb

/-- A functor `F` preserves binary biproducts if it preserves the binary biproduct of `X` and `Y`
    for all `X` and `Y`. -/
class preserves_binary_biproducts (F : C ⥤ D) [preserves_zero_morphisms F] :=
(preserves : Π {X Y : C}, preserves_binary_biproduct X Y F . tactic.apply_instance)

/-- A functor that preserves biproducts of a pair preserves binary biproducts. -/
def preserves_binary_biproduct_of_preserves_biproduct (F : C ⥤ D) [preserves_zero_morphisms F]
  (X Y : C) [preserves_biproduct (pair_function X Y) F] : preserves_binary_biproduct X Y F :=
{ preserves := λ b hb,
  { is_limit := is_limit.of_iso_limit
      ((is_limit.postcompose_hom_equiv (by exact diagram_iso_pair _) _).symm
        ((is_bilimit_of_preserves F (b.to_bicone_is_bilimit.symm hb)).is_limit)) $
      cones.ext (iso.refl _) (λ j, by { rcases j with ⟨⟨⟩⟩, tidy, }),
    is_colimit := is_colimit.of_iso_colimit
      ((is_colimit.precompose_inv_equiv (by exact diagram_iso_pair _ ) _).symm
        ((is_bilimit_of_preserves F (b.to_bicone_is_bilimit.symm hb)).is_colimit)) $
      cocones.ext (iso.refl _) (λ j, by { rcases j with ⟨⟨⟩⟩, tidy, }) } }

/-- A functor that preserves biproducts of a pair preserves binary biproducts. -/
def preserves_binary_biproducts_of_preserves_biproducts (F : C ⥤ D)
  [preserves_zero_morphisms F] [preserves_biproducts_of_shape walking_pair F] :
  preserves_binary_biproducts F :=
{ preserves := λ X Y, preserves_binary_biproduct_of_preserves_biproduct F X Y }

attribute [instance, priority 100] preserves_binary_biproducts.preserves

end limits

open category_theory.limits

namespace functor

section bicone
variables {J : Type w₁} (F : C ⥤ D) (f : J → C)
  [has_biproduct f]

section
variables [has_biproduct (F.obj ∘ f)]

/-- As for products, any functor between categories with biproducts gives rise to a morphism
    `F.obj (⨁ f) ⟶ ⨁ (F.obj ∘ f)`. -/
def biproduct_comparison : F.obj (⨁ f) ⟶ ⨁ (F.obj ∘ f) :=
biproduct.lift (λ j, F.map (biproduct.π f j))

@[simp, reassoc] lemma biproduct_comparison_π (j : J) :
  biproduct_comparison F f ≫ biproduct.π _ j = F.map (biproduct.π f j) :=
biproduct.lift_π _ _

/-- As for coproducts, any functor between categories with biproducts gives rise to a morphism
    `⨁ (F.obj ∘ f) ⟶ F.obj (⨁ f)` -/
def biproduct_comparison' : ⨁ (F.obj ∘ f) ⟶ F.obj (⨁ f) :=
biproduct.desc (λ j, F.map (biproduct.ι f j))

@[simp, reassoc] lemma ι_biproduct_comparison' (j : J) :
  biproduct.ι _ j ≫ biproduct_comparison' F f = F.map (biproduct.ι f j) :=
biproduct.ι_desc _ _

variables [preserves_zero_morphisms F]

/-- The composition in the opposite direction is equal to the identity if and only if `F` preserves
    the biproduct, see `preserves_biproduct_of_mono_biproduct_comparison`.  -/
@[simp, reassoc] lemma biproduct_comparison'_comp_biproduct_comparison :
  biproduct_comparison' F f ≫ biproduct_comparison F f = 𝟙 (⨁ (F.obj ∘ f)) :=
by { classical, ext, simp [biproduct.ι_π, ← functor.map_comp, eq_to_hom_map] }

/-- `biproduct_comparison F f` is a split epimorphism. -/
@[simps]
def split_epi_biproduct_comparison : split_epi (biproduct_comparison F f) :=
⟨biproduct_comparison' F f⟩

instance : is_split_epi (biproduct_comparison F f) :=
is_split_epi.mk' (split_epi_biproduct_comparison F f)

/-- `biproduct_comparison' F f` is a split monomorphism. -/
@[simps]
def split_mono_biproduct_comparison' : split_mono (biproduct_comparison' F f) :=
⟨biproduct_comparison F f⟩

instance : is_split_mono (biproduct_comparison' F f) :=
is_split_mono.mk' (split_mono_biproduct_comparison' F f)

end

variables [preserves_zero_morphisms F] [preserves_biproduct f F]

instance has_biproduct_of_preserves : has_biproduct (F.obj ∘ f) :=
has_biproduct.mk
{ bicone := F.map_bicone (biproduct.bicone f),
  is_bilimit := preserves_biproduct.preserves (biproduct.is_bilimit _) }

/-- If `F` preserves a biproduct, we get a definitionally nice isomorphism
    `F.obj (⨁ f) ≅ ⨁ (F.obj ∘ f)`. -/
@[simp]
def map_biproduct : F.obj (⨁ f) ≅ ⨁ (F.obj ∘ f) :=
biproduct.unique_up_to_iso _ (preserves_biproduct.preserves (biproduct.is_bilimit _))

lemma map_biproduct_hom : (map_biproduct F f).hom = biproduct.lift (λ j, F.map (biproduct.π f j)) :=
rfl

lemma map_biproduct_inv : (map_biproduct F f).inv = biproduct.desc (λ j, F.map (biproduct.ι f j)) :=
rfl

end bicone

variables (F : C ⥤ D) (X Y : C) [has_binary_biproduct X Y]

section
variables [has_binary_biproduct (F.obj X) (F.obj Y)]

/-- As for products, any functor between categories with binary biproducts gives rise to a
    morphism `F.obj (X ⊞ Y) ⟶ F.obj X ⊞ F.obj Y`. -/
def biprod_comparison : F.obj (X ⊞ Y) ⟶ F.obj X ⊞ F.obj Y :=
biprod.lift (F.map biprod.fst) (F.map biprod.snd)

@[simp, reassoc] lemma biprod_comparison_fst :
  biprod_comparison F X Y ≫ biprod.fst = F.map biprod.fst :=
biprod.lift_fst _ _

@[simp, reassoc] lemma biprod_comparison_snd :
  biprod_comparison F X Y ≫ biprod.snd = F.map biprod.snd :=
biprod.lift_snd _ _

/-- As for coproducts, any functor between categories with binary biproducts gives rise to a
    morphism `F.obj X ⊞ F.obj Y ⟶ F.obj (X ⊞ Y)`. -/
def biprod_comparison' : F.obj X ⊞ F.obj Y ⟶ F.obj (X ⊞ Y) :=
biprod.desc (F.map biprod.inl) (F.map biprod.inr)

@[simp, reassoc] lemma inl_biprod_comparison' :
  biprod.inl ≫ biprod_comparison' F X Y = F.map biprod.inl :=
biprod.inl_desc _ _

@[simp, reassoc] lemma inr_biprod_comparison' :
  biprod.inr ≫ biprod_comparison' F X Y = F.map biprod.inr :=
biprod.inr_desc _ _

variables [preserves_zero_morphisms F]

/-- The composition in the opposite direction is equal to the identity if and only if `F` preserves
    the biproduct, see `preserves_binary_biproduct_of_mono_biprod_comparison`. -/
@[simp, reassoc]

/-- `biprod_comparison F X Y` is a split epi. -/
@[simps]
def split_epi_biprod_comparison : split_epi (biprod_comparison F X Y) :=
⟨biprod_comparison' F X Y⟩

instance : is_split_epi (biprod_comparison F X Y) :=
is_split_epi.mk' (split_epi_biprod_comparison F X Y)

/-- `biprod_comparison' F X Y` is a split mono. -/
@[simps]
def split_mono_biprod_comparison' : split_mono (biprod_comparison' F X Y) :=
⟨biprod_comparison F X Y⟩

instance : is_split_mono (biprod_comparison' F X Y) :=
is_split_mono.mk' (split_mono_biprod_comparison' F X Y)

end

variables [preserves_zero_morphisms F] [preserves_binary_biproduct X Y F]

instance has_binary_biproduct_of_preserves : has_binary_biproduct (F.obj X) (F.obj Y) :=
has_binary_biproduct.mk
{ bicone := F.map_binary_bicone (binary_biproduct.bicone X Y),
  is_bilimit := preserves_binary_biproduct.preserves (binary_biproduct.is_bilimit _ _) }

/-- If `F` preserves a binary biproduct, we get a definitionally nice isomorphism
    `F.obj (X ⊞ Y) ≅ F.obj X ⊞ F.obj Y`. -/
@[simp]
def map_biprod : F.obj (X ⊞ Y) ≅ F.obj X ⊞ F.obj Y :=
biprod.unique_up_to_iso _ _
  (preserves_binary_biproduct.preserves (binary_biproduct.is_bilimit _ _))

lemma map_biprod_hom : (map_biprod F X Y).hom = biprod.lift (F.map biprod.fst) (F.map biprod.snd) :=
rfl

lemma map_biprod_inv : (map_biprod F X Y).inv = biprod.desc (F.map biprod.inl) (F.map biprod.inr) :=
rfl

end functor

namespace limits
variables (F : C ⥤ D) [preserves_zero_morphisms F]

section bicone
variables {J : Type w₁} (f : J → C) [has_biproduct f] [preserves_biproduct f F]
  {W : C}

lemma biproduct.map_lift_map_biprod (g : Π j, W ⟶ f j) :
  F.map (biproduct.lift g) ≫ (F.map_biproduct f).hom = biproduct.lift (λ j, F.map (g j)) :=
by { ext, simp [← F.map_comp] }

lemma biproduct.map_biproduct_inv_map_desc (g : Π j, f j ⟶ W) :
  (F.map_biproduct f).inv ≫ F.map (biproduct.desc g) = biproduct.desc (λ j, F.map (g j)) :=
by { ext, simp [← F.map_comp] }

lemma biproduct.map_biproduct_hom_desc (g : Π j, f j ⟶ W) :
  (F.map_biproduct f).hom ≫ biproduct.desc (λ j, F.map (g j)) = F.map (biproduct.desc g) :=
by rw [← biproduct.map_biproduct_inv_map_desc, iso.hom_inv_id_assoc]

end bicone

section binary_bicone
variables (X Y : C) [has_binary_biproduct X Y] [preserves_binary_biproduct X Y F] {W : C}

lemma biprod.map_lift_map_biprod (f : W ⟶ X) (g : W ⟶ Y) :
  F.map (biprod.lift f g) ≫ (F.map_biprod X Y).hom = biprod.lift (F.map f) (F.map g) :=
by ext; simp [← F.map_comp]

lemma biprod.lift_map_biprod (f : W ⟶ X) (g : W ⟶ Y) :
  biprod.lift (F.map f) (F.map g) ≫ (F.map_biprod X Y).inv = F.map (biprod.lift f g) :=
by rw [← biprod.map_lift_map_biprod, category.assoc, iso.hom_inv_id, category.comp_id]

lemma biprod.map_biprod_inv_map_desc (f : X ⟶ W) (g : Y ⟶ W) :
  (F.map_biprod X Y).inv ≫ F.map (biprod.desc f g) = biprod.desc (F.map f) (F.map g) :=
by ext; simp [← F.map_comp]

lemma biprod.map_biprod_hom_desc (f : X ⟶ W) (g : Y ⟶ W) :
 (F.map_biprod X Y).hom ≫ biprod.desc (F.map f) (F.map g) = F.map (biprod.desc f g) :=
by rw [← biprod.map_biprod_inv_map_desc, iso.hom_inv_id_assoc]

end binary_bicone

end limits

end has_zero_morphisms

end category_theory


import data.sym.sym2

open function

variables {α β : Type*} {e : sym2 α} {f : α → β}

namespace sym2

protected lemma is_diag.map : e.is_diag → (e.map f).is_diag := sym2.ind (λ x y, congr_arg f) e

lemma is_diag_map (hf : injective f) : (e.map f).is_diag ↔ e.is_diag :=
sym2.ind (λ x y, hf.eq_iff) e

end sym2


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

set_option aesop.check.all false
-- With this option, the test becomes unbearably slow.

abbrev State := String → Int

inductive Com where
| Skip : Com
| Seq : Com → Com → Com

declare_syntax_cat com

syntax "SKIP" : com
syntax com ";" com : com
syntax "(" com ")" : com
syntax term : com

syntax "[Com|" com "]" : term

macro_rules
| `([Com| SKIP]) => `(Com.Skip)
| `([Com| $x ; $y]) => `(Com.Seq [Com| $x] [Com| $y])
| `([Com| ( $x:com )]) => `([Com| $x])
| `([Com| $x:term ]) => `($x)

@[aesop safe [constructors, -100 (cases (index := [hyp BigStep Com.Skip _ _, hyp BigStep [Com| _;_] _ _]))]]
inductive BigStep : Com → State → State → Prop where
| Skip : BigStep Com.Skip s s
| Seq (h1 : BigStep c₁ s t) (h2 : BigStep c₂ t u) : BigStep [Com| c₁;c₂] s u

theorem seq_assoc :
    BigStep [Com| (c1;c2);c3] s s' ↔ BigStep [Com| c1;c2;c3] s s' := by
  aesop


/- LoVe Library -/

import tactic.explode
import tactic.find
import tactic.linarith
import tactic.rewrite
import tactic.tidy
import tactic.where
import logic.basic
import algebra
import order
import data.real.basic

namespace LoVe

/- Options -/

set_option pp.beta true

/- Logical connectives -/

attribute [pattern] or.intro_left or.intro_right

meta def tactic.dec_trivial := `[exact dec_trivial]

@[simp] lemma not_not_iff (a : Prop) [decidable a] : ¬¬ a ↔ a :=
by by_cases a; simp [h]

@[simp] lemma and_imp_distrib (a b c : Prop) : (a ∧ b → c) ↔ (a → b → c) :=
iff.intro
  (assume h ha hb, h ⟨ha, hb⟩)
  (assume h ⟨ha, hb⟩, h ha hb)

@[simp] lemma or_imp_distrib {a b c : Prop} : a ∨ b → c ↔ (a → c) ∧ (b → c) :=
iff.intro
  (assume h,
   ⟨assume ha, h (or.intro_left _ ha), assume hb, h (or.intro_right _ hb)⟩)
  (assume ⟨ha, hb⟩ h, match h with or.inl h := ha h | or.inr h := hb h end)

@[simp] lemma exists_imp_distrib {α : Sort*} {p : α → Prop} {a : Prop} :
  ((∃x, p x) → a) ↔ (∀x, p x → a) :=
iff.intro
  (assume h hp ha, h ⟨hp, ha⟩)
  (assume h ⟨hp, ha⟩, h hp ha)

lemma and_exists {α : Sort*} {p : α → Prop} {a : Prop} :
  (a ∧ (∃x, p x)) ↔ (∃x, a ∧ p x) :=
iff.intro
  (assume ⟨ha, x, hp⟩, ⟨x, ha, hp⟩)
  (assume ⟨x, ha, hp⟩, ⟨ha, x, hp⟩)

@[simp] lemma exists_false {α : Sort*} : (∃x : α, false) ↔ false :=
iff.intro (assume ⟨a, f⟩, f) (assume h, h.elim)

/- Reflexive transitive closure of a relation -/

inductive refl_trans {α : Sort*} (r : α → α → Prop) (a : α) : α → Prop
| refl {} : refl_trans a
| tail {b c} : refl_trans b → r b c → refl_trans c

attribute [refl] refl_trans.refl

namespace refl_trans

variables {α : Sort*} {r : α → α → Prop} {a b c d : α}

@[trans] lemma trans (hab : refl_trans r a b) (hbc : refl_trans r b c) :
  refl_trans r a c :=
begin
  induction hbc,
  case refl_trans.refl { assumption },
  case refl_trans.tail : c d hbc hcd hac { exact hac.tail hcd }
end

lemma single (hab : r a b) : refl_trans r a b :=
refl.tail hab

lemma head (hab : r a b) (hbc : refl_trans r b c) : refl_trans r a c :=
begin
  induction hbc,
  case refl_trans.refl { exact refl.tail hab },
  case refl_trans.tail : c d hbc hcd hac { exact hac.tail hcd }
end

lemma head_induction_on {α : Sort*} {r : α → α → Prop} {b : α}
  {P : ∀a : α, refl_trans r a b → Prop} {a : α} (h : refl_trans r a b)
  (refl : P b refl)
  (head : ∀{a c} (h' : r a c) (h : refl_trans r c b), P c h → P a (h.head h')) :
  P a h :=
begin
  induction h generalizing P,
  case refl_trans.refl { exact refl },
  case refl_trans.tail : b c hab hbc ih {
    apply ih,
    show P b _, from head hbc _ refl,
    show ∀a a', r a a' → refl_trans r a' b → P a' _ → P a _,
      from assume a a' hab hbc, head hab _ }
end

lemma trans_induction_on {α : Sort*} {r : α → α → Prop}
  {P : ∀{a b : α}, refl_trans r a b → Prop}
  {a b : α} (h : refl_trans r a b)
  (ih₁ : ∀a, @P a a refl)
  (ih₂ : ∀{a b} (h : r a b), P (single h))
  (ih₃ : ∀{a b c} (h₁ : refl_trans r a b) (h₂ : refl_trans r b c), P h₁ → P h₂ →
    P (h₁.trans h₂)) :
  P h :=
begin
  induction h,
  case refl_trans.refl { exact ih₁ a },
  case refl_trans.tail : b c hab hbc ih {
    exact ih₃ hab (single hbc) ih (ih₂ hbc) }
end

lemma lift {β : Sort*} {p : β → β → Prop} (f : α → β)
  (h : ∀a b, r a b → p (f a) (f b)) (hab : refl_trans r a b) :
  refl_trans p (f a) (f b) :=
hab.trans_induction_on
  (assume a, refl)
  (assume a b, single ∘ h _ _)
  (assume a b c _ _, trans)

lemma mono {p : α → α → Prop} :
  (∀a b, r a b → p a b) → refl_trans r a b → refl_trans p a b :=
lift id

lemma refl_trans_refl_trans_eq : refl_trans (refl_trans r) = refl_trans r :=
funext $ assume a, funext $ assume b, propext $
iff.intro
  (assume h, begin induction h, { refl }, { transitivity; assumption } end)
  (refl_trans.mono (assume a b, single))

end refl_trans

/- States -/

def state := string → ℕ

def state.update (name : string) (val : ℕ) (s : state) :
  state :=
λname', if name' = name then val else s name'

notation s `{` name ` ↦ ` val `}` := state.update name val s

instance : has_emptyc state := ⟨λ_, 0⟩

@[simp] lemma update_apply (name : string) (val : ℕ)
  (s : state) : s{name ↦ val} name = val :=
if_pos rfl

@[simp] lemma update_apply_ne (name name' : string) (val : ℕ)
    (s : state) (h : name' ≠ name . tactic.dec_trivial) :
  s{name ↦ val} name' = s name' :=
if_neg h

@[simp] lemma update_override (name : string) (val₁ val₂ : ℕ)
  (s : state) : s{name ↦ val₂}{name ↦ val₁} = s{name ↦ val₁} :=
begin
  apply funext,
  intro name',
  by_cases name' = name;
    simp [h]
end

@[simp] lemma update_swap (name₁ name₂ : string) (val₁ val₂ : ℕ)
  (s : state) (h : name₁ ≠ name₂ . tactic.dec_trivial) :
  s{name₂ ↦ val₂}{name₁ ↦ val₁} =
  s{name₁ ↦ val₁}{name₂ ↦ val₂} :=
begin
  apply funext,
  intro name',
  by_cases name' = name₁;
    by_cases name' = name₂;
    simp * at *
end

@[simp] lemma update_id (name : string) (s : state) :
  s{name ↦ s name} = s :=
begin
  apply funext,
  intro name',
  by_cases name' = name;
    simp * at *
end

example (s : state) :
  s{"a" ↦ 0}{"a" ↦ 2} = s{"a" ↦ 2} :=
by simp

example (s : state) :
  s{"a" ↦ 0}{"b" ↦ 2} = s{"b" ↦ 2}{"a" ↦ 0} :=
by simp

example (s : state) :
  s{"a" ↦ s "a"}{"b" ↦ 0} = s{"b" ↦ 0} :=
by simp

end LoVe


import NBG.SetTheory.Defs
import NBG.SetTheory.Axioms.Foundation

open Classical

-- 15. AxiomGlobalChoice
axiom AxiomGlobalChoice:
  ∃F: Class,∃_: Function F,∀x: Class, ∀_: Set x,
    (¬ x＝ø → (∃y: Class,∃hy: y∈x,
      (@Pair_mk x y _ (Set.mk₁ hy)) ∈ F))

-- ex. AxiomChoice
theorem AxiomChoice:
  ∀x: Class, ∀_: Set x,
    ∃f: Class, ∃_: Function f, ∀y: Class, ∃hy: y∈x,
      (¬ y＝ø → (∃z: Class,∃hz: z∈y,
        ((@Pair_mk y z (Set.mk₁ hy) (Set.mk₁ hz)) ∈ f))) := sorry