/-
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

! This file was ported from Lean 3 source module category_theory.products.basic
! leanprover-community/mathlib commit dc6c365e751e34d100e80fe6e314c3c3e0fd2988
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.CategoryTheory.EqToHom
import Mathlib.CategoryTheory.Functor.Const
import Mathlib.Data.Prod.Basic

/-!
# Cartesian products of categories

We define the category instance on `C × D` when `C` and `D` are categories.

We define:
* `sectl C Z` : the functor `C ⥤ C × D` given by `X ↦ ⟨X, Z⟩`
* `sectr Z D` : the functor `D ⥤ C × D` given by `Y ↦ ⟨Z, Y⟩`
* `fst`       : the functor `⟨X, Y⟩ ↦ X`
* `snd`       : the functor `⟨X, Y⟩ ↦ Y`
* `swap`      : the functor `C × D ⥤ D × C` given by `⟨X, Y⟩ ↦ ⟨Y, X⟩`
    (and the fact this is an equivalence)

We further define `evaluation : C ⥤ (C ⥤ D) ⥤ D` and `evaluationUncurried : C × (C ⥤ D) ⥤ D`,
and products of functors and natural transformations, written `F.prod G` and `α.prod β`.
-/

namespace CategoryTheory

-- declare the `v`'s first; see `CategoryTheory.Category` for an explanation
universe v₁ v₂ v₃ v₄ u₁ u₂ u₃ u₄

section

variable (C : Type u₁) [Category.{v₁} C] (D : Type u₂) [Category.{v₂} D]

-- the generates simp lemmas like `id_fst` and `comp_snd`
/-- `prod C D` gives the cartesian product of two categories.

See <https://stacks.math.columbia.edu/tag/001K>.
-/
@[simps (config := { notRecursive := [] })]
instance prod : Category.{max v₁ v₂} (C × D)
    where
  Hom X Y := (X.1 ⟶ Y.1) × (X.2 ⟶ Y.2)
  id X := ⟨𝟙 X.1, 𝟙 X.2⟩
  comp f g := (f.1 ≫ g.1, f.2 ≫ g.2)
#align category_theory.prod CategoryTheory.prod

/-- Two rfl lemmas that cannot be generated by `@[simps]`. -/
@[simp]
theorem prod_id (X : C) (Y : D) : 𝟙 (X, Y) = (𝟙 X, 𝟙 Y) :=
  rfl
#align category_theory.prod_id CategoryTheory.prod_id

@[simp]
theorem prod_comp {P Q R : C} {S T U : D} (f : (P, S) ⟶ (Q, T)) (g : (Q, T) ⟶ (R, U)) :
    f ≫ g = (f.1 ≫ g.1, f.2 ≫ g.2) :=
  rfl
#align category_theory.prod_comp CategoryTheory.prod_comp

theorem isIso_prod_iff {P Q : C} {S T : D} {f : (P, S) ⟶ (Q, T)} :
    IsIso f ↔ IsIso f.1 ∧ IsIso f.2 := by
  constructor
  · rintro ⟨g, hfg, hgf⟩
    simp at hfg hgf
    rcases hfg with ⟨hfg₁, hfg₂⟩
    rcases hgf with ⟨hgf₁, hgf₂⟩
    exact ⟨⟨⟨g.1, hfg₁, hgf₁⟩⟩, ⟨⟨g.2, hfg₂, hgf₂⟩⟩⟩
  · rintro ⟨⟨g₁, hfg₁, hgf₁⟩, ⟨g₂, hfg₂, hgf₂⟩⟩
    dsimp at hfg₁ hgf₁ hfg₂ hgf₂
    refine' ⟨⟨(g₁, g₂), _, _⟩⟩
    repeat { simp; constructor; assumption; assumption }
#align category_theory.is_iso_prod_iff CategoryTheory.isIso_prod_iff

section

variable {C D}

/-- The isomorphism between `(X.1, X.2)` and `X`. -/
@[simps]
def prod.etaIso (X : C × D) : (X.1, X.2) ≅ X
    where
  hom := (𝟙 _, 𝟙 _)
  inv := (𝟙 _, 𝟙 _)
#align category_theory.prod.eta_iso CategoryTheory.prod.etaIso

/-- Construct an isomorphism in `C × D` out of two isomorphisms in `C` and `D`. -/
@[simps]
def Iso.prod {P Q : C} {S T : D} (f : P ≅ Q) (g : S ≅ T) : (P, S) ≅ (Q, T)
    where
  hom := (f.hom, g.hom)
  inv := (f.inv, g.inv)
#align category_theory.iso.prod CategoryTheory.Iso.prod

end

end

section

variable (C : Type u₁) [Category.{v₁} C] (D : Type u₁) [Category.{v₁} D]

/-- `Category.uniformProd C D` is an additional instance specialised so both factors have the same
universe levels. This helps typeclass resolution.
-/
instance uniformProd : Category (C × D) :=
  CategoryTheory.prod C D
#align category_theory.uniform_prod CategoryTheory.uniformProd

end

-- Next we define the natural functors into and out of product categories. For now this doesn't
-- address the universal properties.
namespace Prod

/-- `sectl C Z` is the functor `C ⥤ C × D` given by `X ↦ (X, Z)`. -/
@[simps]
def sectl (C : Type u₁) [Category.{v₁} C] {D : Type u₂} [Category.{v₂} D] (Z : D) : C ⥤ C × D
    where
  obj X := (X, Z)
  map f := (f, 𝟙 Z)
#align category_theory.prod.sectl CategoryTheory.Prod.sectl

/-- `sectr Z D` is the functor `D ⥤ C × D` given by `Y ↦ (Z, Y)` . -/
@[simps]
def sectr {C : Type u₁} [Category.{v₁} C] (Z : C) (D : Type u₂) [Category.{v₂} D] : D ⥤ C × D
    where
  obj X := (Z, X)
  map f := (𝟙 Z, f)
#align category_theory.prod.sectr CategoryTheory.Prod.sectr

variable (C : Type u₁) [Category.{v₁} C] (D : Type u₂) [Category.{v₂} D]

/-- `fst` is the functor `(X, Y) ↦ X`. -/
@[simps]
def fst : C × D ⥤ C where
  obj X := X.1
  map f := f.1
#align category_theory.prod.fst CategoryTheory.Prod.fst

/-- `snd` is the functor `(X, Y) ↦ Y`. -/
@[simps]
def snd : C × D ⥤ D where
  obj X := X.2
  map f := f.2
#align category_theory.prod.snd CategoryTheory.Prod.snd

/-- The functor swapping the factors of a cartesian product of categories, `C × D ⥤ D × C`. -/
@[simps]
def swap : C × D ⥤ D × C where
  obj X := (X.2, X.1)
  map f := (f.2, f.1)
#align category_theory.prod.swap CategoryTheory.Prod.swap

/-- Swapping the factors of a cartesion product of categories twice is naturally isomorphic
to the identity functor.
-/
@[simps]
def symmetry : swap C D ⋙ swap D C ≅ 𝟭 (C × D)
    where
  hom := { app := fun X => 𝟙 X }
  inv := { app := fun X => 𝟙 X }
#align category_theory.prod.symmetry CategoryTheory.Prod.symmetry

/-- The equivalence, given by swapping factors, between `C × D` and `D × C`.
-/
@[simps!]
def braiding : C × D ≌ D × C :=
  Equivalence.mk (swap C D) (swap D C)
    (NatIso.ofComponents (fun X => eqToIso (by simp)) (by aesop_cat))
    (NatIso.ofComponents (fun X => eqToIso (by simp)) (by aesop_cat))
#align category_theory.prod.braiding CategoryTheory.Prod.braiding

instance swapIsEquivalence : IsEquivalence (swap C D) :=
  (by infer_instance : IsEquivalence (braiding C D).functor)
#align category_theory.prod.swap_is_equivalence CategoryTheory.Prod.swapIsEquivalence

end Prod

section

variable (C : Type u₁) [Category.{v₁} C] (D : Type u₂) [Category.{v₂} D]

/-- The "evaluation at `X`" functor, such that
`(evaluation.obj X).obj F = F.obj X`,
which is functorial in both `X` and `F`.
-/
@[simps]
def evaluation : C ⥤ (C ⥤ D) ⥤ D
    where
  obj X :=
    { obj := fun F => F.obj X
      map := fun α => α.app X }
  map {X} {Y} f :=
    { app := fun F => F.map f
      naturality := fun {F} {G} α => Eq.symm (α.naturality f) }
#align category_theory.evaluation CategoryTheory.evaluation

/-- The "evaluation of `F` at `X`" functor,
as a functor `C × (C ⥤ D) ⥤ D`.
-/
@[simps]
def evaluationUncurried : C × (C ⥤ D) ⥤ D
    where
  obj p := p.2.obj p.1
  map := fun {x} {y} f => x.2.map f.1 ≫ f.2.app y.1
  map_comp := fun {X} {Y} {Z} f g => by
    cases g; cases f; cases Z; cases Y; cases X
    simp only [prod_comp, NatTrans.comp_app, Functor.map_comp, Category.assoc]
    rw [← NatTrans.comp_app, NatTrans.naturality, NatTrans.comp_app, Category.assoc,
      NatTrans.naturality]
#align category_theory.evaluation_uncurried CategoryTheory.evaluationUncurried

variable {C}

/-- The constant functor followed by the evalutation functor is just the identity. -/
@[simps!]
def Functor.constCompEvaluationObj (X : C) : Functor.const C ⋙ (evaluation C D).obj X ≅ 𝟭 D :=
  NatIso.ofComponents (fun Y => Iso.refl _) fun {Y} {Z} f => by simp
#align category_theory.functor.const_comp_evaluation_obj CategoryTheory.Functor.constCompEvaluationObj

end

variable {A : Type u₁} [Category.{v₁} A] {B : Type u₂} [Category.{v₂} B] {C : Type u₃}
  [Category.{v₃} C] {D : Type u₄} [Category.{v₄} D]

namespace Functor

/-- The cartesian product of two functors. -/
@[simps]
def prod (F : A ⥤ B) (G : C ⥤ D) : A × C ⥤ B × D
    where
  obj X := (F.obj X.1, G.obj X.2)
  map f := (F.map f.1, G.map f.2)
#align category_theory.functor.prod CategoryTheory.Functor.prod

/- Because of limitations in Lean 3's handling of notations, we do not setup a notation `F × G`.
   You can use `F.prod G` as a "poor man's infix", or just write `functor.prod F G`. -/
/-- Similar to `prod`, but both functors start from the same category `A` -/
@[simps]
def prod' (F : A ⥤ B) (G : A ⥤ C) : A ⥤ B × C
    where
  obj a := (F.obj a, G.obj a)
  map f := (F.map f, G.map f)
#align category_theory.functor.prod' CategoryTheory.Functor.prod'

/-- The product `F.prod' G` followed by projection on the first component is isomorphic to `F` -/
@[simps!]
def prod'CompFst (F : A ⥤ B) (G : A ⥤ C) : F.prod' G ⋙ CategoryTheory.Prod.fst B C ≅ F :=
  NatIso.ofComponents (fun X => Iso.refl _) fun f => by simp
#align category_theory.functor.prod'_comp_fst CategoryTheory.Functor.prod'CompFst

/-- The product `F.prod' G` followed by projection on the second component is isomorphic to `G` -/
@[simps!]
def prod'CompSnd (F : A ⥤ B) (G : A ⥤ C) : F.prod' G ⋙ CategoryTheory.Prod.snd B C ≅ G :=
  NatIso.ofComponents (fun X => Iso.refl _) fun f => by simp
#align category_theory.functor.prod'_comp_snd CategoryTheory.Functor.prod'CompSnd

section

variable (C)

/-- The diagonal functor. -/
def diag : C ⥤ C × C :=
  (𝟭 C).prod' (𝟭 C)
#align category_theory.functor.diag CategoryTheory.Functor.diag

@[simp]
theorem diag_obj (X : C) : (diag C).obj X = (X, X) :=
  rfl
#align category_theory.functor.diag_obj CategoryTheory.Functor.diag_obj

@[simp]
theorem diag_map {X Y : C} (f : X ⟶ Y) : (diag C).map f = (f, f) :=
  rfl
#align category_theory.functor.diag_map CategoryTheory.Functor.diag_map

end

end Functor

namespace NatTrans

/-- The cartesian product of two natural transformations. -/
@[simps]
def prod {F G : A ⥤ B} {H I : C ⥤ D} (α : F ⟶ G) (β : H ⟶ I) : F.prod H ⟶ G.prod I
    where
  app X := (α.app X.1, β.app X.2)
  naturality {X} {Y} f := by
    cases X; cases Y
    simp only [Functor.prod_map, prod_comp]
    rw [Prod.mk.inj_iff]
    constructor
    repeat {rw [naturality]}
#align category_theory.nat_trans.prod CategoryTheory.NatTrans.prod

/- Again, it is inadvisable in Lean 3 to setup a notation `α × β`;
   use instead `α.prod β` or `NatTrans.prod α β`. -/
end NatTrans

/-- `F.flip` composed with evaluation is the same as evaluating `F`. -/
@[simps!]
def flipCompEvaluation (F : A ⥤ B ⥤ C) (a) : F.flip ⋙ (evaluation _ _).obj a ≅ F.obj a :=
  (NatIso.ofComponents fun b => eqToIso rfl) <| by aesop_cat
#align category_theory.flip_comp_evaluation CategoryTheory.flipCompEvaluation

variable (A B C)

/-- The forward direction for `functorProdFunctorEquiv` -/
@[simps]
def prodFunctorToFunctorProd : (A ⥤ B) × (A ⥤ C) ⥤ A ⥤ B × C
    where
  obj F := F.1.prod' F.2
  map f := { app := fun X => (f.1.app X, f.2.app X) }
#align category_theory.prod_functor_to_functor_prod CategoryTheory.prodFunctorToFunctorProd

/-- The backward direction for `functorProdFunctorEquiv` -/
@[simps]
def functorProdToProdFunctor : (A ⥤ B × C) ⥤ (A ⥤ B) × (A ⥤ C)
    where
  obj F := ⟨F ⋙ CategoryTheory.Prod.fst B C, F ⋙ CategoryTheory.Prod.snd B C⟩
  map α :=
    ⟨{  app := fun X => (α.app X).1
        naturality := fun X Y f => by
          simp only [Functor.comp_map, Prod.fst_map, ← prod_comp_fst, α.naturality] },
      { app := fun X => (α.app X).2
        naturality := fun X Y f => by
          simp only [Functor.comp_map, Prod.snd_map, ← prod_comp_snd, α.naturality] }⟩
#align category_theory.functor_prod_to_prod_functor CategoryTheory.functorProdToProdFunctor

/-- The unit isomorphism for `functorProdFunctorEquiv` -/
@[simps!]
def functorProdFunctorEquivUnitIso :
    𝟭 _ ≅ prodFunctorToFunctorProd A B C ⋙ functorProdToProdFunctor A B C :=
  NatIso.ofComponents
    (fun F =>
      (((Functor.prod'CompFst F.fst F.snd).prod (Functor.prod'CompSnd F.fst F.snd)).trans
        (prod.etaIso F)).symm)
      (fun α => by aesop_cat)
#align category_theory.functor_prod_functor_equiv_unit_iso CategoryTheory.functorProdFunctorEquivUnitIso

/-- The counit isomorphism for `functorProdFunctorEquiv` -/
@[simps!]
def functorProdFunctorEquivCounitIso :
    functorProdToProdFunctor A B C ⋙ prodFunctorToFunctorProd A B C ≅ 𝟭 _ :=
  NatIso.ofComponents (fun F => NatIso.ofComponents (fun X => prod.etaIso (F.obj X)) (by aesop_cat))
    (by aesop_cat)
#align category_theory.functor_prod_functor_equiv_counit_iso CategoryTheory.functorProdFunctorEquivCounitIso

/- Porting note: unlike with Lean 3, we needed to provide `functor_unitIso_comp` because
Lean 4 could not see through `functorProdFunctorEquivUnitIso` (or the co-unit version)
to run the auto tactic `by aesop_cat` -/

/-- The equivalence of categories between `(A ⥤ B) × (A ⥤ C)` and `A ⥤ (B × C)` -/
@[simps]
def functorProdFunctorEquiv : (A ⥤ B) × (A ⥤ C) ≌ A ⥤ B × C :=
  { functor := prodFunctorToFunctorProd A B C,
    inverse := functorProdToProdFunctor A B C,
    unitIso := functorProdFunctorEquivUnitIso A B C,
    counitIso := functorProdFunctorEquivCounitIso A B C,
    functor_unitIso_comp := by
      simp only [functorProdFunctorEquivUnitIso]
      aesop_cat
  }
#align category_theory.functor_prod_functor_equiv CategoryTheory.functorProdFunctorEquiv

end CategoryTheory


/-
Copyright (c) 2018 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison, Reid Barton
-/
import category_theory.limits.shapes.images
import category_theory.filtered
import tactic.equiv_rw

universes u

open category_theory
open category_theory.limits

namespace category_theory.limits.types

variables {J : Type u} [small_category J]

/--
(internal implementation) the limit cone of a functor,
implemented as flat sections of a pi type
-/
def limit_cone (F : J ⥤ Type u) : cone F :=
{ X := F.sections,
  π := { app := λ j u, u.val j } }

local attribute [elab_simple] congr_fun
/-- (internal implementation) the fact that the proposed limit cone is the limit -/
def limit_cone_is_limit (F : J ⥤ Type u) : is_limit (limit_cone F) :=
{ lift := λ s v, ⟨λ j, s.π.app j v, λ j j' f, congr_fun (cone.w s f) _⟩,
  uniq' := by { intros, ext x j, exact congr_fun (w j) x } }

/--
The category of types has all limits.

See https://stacks.math.columbia.edu/tag/002U.
-/
instance : has_limits (Type u) :=
{ has_limits_of_shape := λ J 𝒥, by exactI
  { has_limit := λ F, has_limit.mk
    { cone := limit_cone F, is_limit := limit_cone_is_limit F } } }

/--
The equivalence between a limiting cone of `F` in `Type u` and the "concrete" definition as the
sections of `F`.
-/
def is_limit_equiv_sections {F : J ⥤ Type u} {c : cone F} (t : is_limit c) :
  c.X ≃ F.sections :=
(is_limit.cone_point_unique_up_to_iso t (limit_cone_is_limit F)).to_equiv

@[simp]
lemma is_limit_equiv_sections_apply
  {F : J ⥤ Type u} {c : cone F} (t : is_limit c) (j : J) (x : c.X) :
  (((is_limit_equiv_sections t) x) : Π j, F.obj j) j = c.π.app j x :=
rfl

@[simp]
lemma is_limit_equiv_sections_symm_apply
  {F : J ⥤ Type u} {c : cone F} (t : is_limit c) (x : F.sections) (j : J) :
  c.π.app j ((is_limit_equiv_sections t).symm x) = (x : Π j, F.obj j) j :=
begin
  equiv_rw (is_limit_equiv_sections t).symm at x,
  simp,
end

/--
The equivalence between the abstract limit of `F` in `Type u`
and the "concrete" definition as the sections of `F`.
-/
noncomputable
def limit_equiv_sections (F : J ⥤ Type u) : (limit F : Type u) ≃ F.sections :=
is_limit_equiv_sections (limit.is_limit _)

@[simp]
lemma limit_equiv_sections_apply (F : J ⥤ Type u) (x : limit F) (j : J) :
  (((limit_equiv_sections F) x) : Π j, F.obj j) j = limit.π F j x :=
rfl

@[simp]
lemma limit_equiv_sections_symm_apply (F : J ⥤ Type u) (x : F.sections) (j : J) :
  limit.π F j ((limit_equiv_sections F).symm x) = (x : Π j, F.obj j) j :=
is_limit_equiv_sections_symm_apply _ _ _

/--
Construct a term of `limit F : Type u` from a family of terms `x : Π j, F.obj j`
which are "coherent": `∀ (j j') (f : j ⟶ j'), F.map f (x j) = x j'`.
-/
@[ext]
noncomputable
def limit.mk (F : J ⥤ Type u) (x : Π j, F.obj j) (h : ∀ (j j') (f : j ⟶ j'), F.map f (x j) = x j') :
  (limit F : Type u) :=
(limit_equiv_sections F).symm ⟨x, h⟩

@[simp]
lemma limit.π_mk
  (F : J ⥤ Type u) (x : Π j, F.obj j) (h : ∀ (j j') (f : j ⟶ j'), F.map f (x j) = x j') (j) :
  limit.π F j (limit.mk F x h) = x j :=
by { dsimp [limit.mk], simp, }

-- PROJECT: prove this for concrete categories where the forgetful functor preserves limits
@[ext]
lemma limit_ext (F : J ⥤ Type u) (x y : limit F) (w : ∀ j, limit.π F j x = limit.π F j y) :
  x = y :=
begin
  apply (limit_equiv_sections F).injective,
  ext j,
  simp [w j],
end

lemma limit_ext_iff (F : J ⥤ Type u) (x y : limit F) :
  x = y ↔ (∀ j, limit.π F j x = limit.π F j y) :=
⟨λ t _, t ▸ rfl, limit_ext _ _ _⟩

-- TODO: are there other limits lemmas that should have `_apply` versions?
-- Can we generate these like with `@[reassoc]`?
-- PROJECT: prove these for any concrete category where the forgetful functor preserves limits?

@[simp]
lemma limit.w_apply {F : J ⥤ Type u} {j j' : J} {x : limit F} (f : j ⟶ j') :
  F.map f (limit.π F j x) = limit.π F j' x :=
congr_fun (limit.w F f) x

@[simp]
lemma limit.lift_π_apply (F : J ⥤ Type u) (s : cone F) (j : J) (x : s.X) :
  limit.π F j (limit.lift F s x) = s.π.app j x :=
congr_fun (limit.lift_π s j) x

@[simp]
lemma limit.map_π_apply {F G : J ⥤ Type u} (α : F ⟶ G) (j : J) (x) :
  limit.π G j (lim_map α x) = α.app j (limit.π F j x) :=
congr_fun (lim_map_π α j) x

/--
The relation defining the quotient type which implements the colimit of a functor `F : J ⥤ Type u`.
See `category_theory.limits.types.quot`.
-/
def quot.rel (F : J ⥤ Type u) : (Σ j, F.obj j) → (Σ j, F.obj j) → Prop :=
(λ p p', ∃ f : p.1 ⟶ p'.1, p'.2 = F.map f p.2)

/--
A quotient type implementing the colimit of a functor `F : J ⥤ Type u`,
as pairs `⟨j, x⟩` where `x : F.obj j`, modulo the equivalence relation generated by
`⟨j, x⟩ ~ ⟨j', x'⟩` whenever there is a morphism `f : j ⟶ j'` so `F.map f x = x'`.
-/
@[nolint has_inhabited_instance]
def quot (F : J ⥤ Type u) : Type u :=
@quot (Σ j, F.obj j) (quot.rel F)

/--
(internal implementation) the colimit cocone of a functor,
implemented as a quotient of a sigma type
-/
def colimit_cocone (F : J ⥤ Type u) : cocone F :=
{ X := quot F,
  ι :=
  { app := λ j x, quot.mk _ ⟨j, x⟩,
    naturality' := λ j j' f, funext $ λ x, eq.symm (quot.sound ⟨f, rfl⟩) } }

local attribute [elab_with_expected_type] quot.lift

/-- (internal implementation) the fact that the proposed colimit cocone is the colimit -/
def colimit_cocone_is_colimit (F : J ⥤ Type u) : is_colimit (colimit_cocone F) :=
{ desc := λ s, quot.lift (λ (p : Σ j, F.obj j), s.ι.app p.1 p.2)
    (assume ⟨j, x⟩ ⟨j', x'⟩ ⟨f, hf⟩, by rw hf; exact (congr_fun (cocone.w s f) x).symm) }

/--
The category of types has all colimits.

See https://stacks.math.columbia.edu/tag/002U.
-/
instance : has_colimits (Type u) :=
{ has_colimits_of_shape := λ J 𝒥, by exactI
  { has_colimit := λ F, has_colimit.mk
    { cocone := colimit_cocone F, is_colimit := colimit_cocone_is_colimit F } } }

/--
The equivalence between the abstract colimit of `F` in `Type u`
and the "concrete" definition as a quotient.
-/
noncomputable
def colimit_equiv_quot (F : J ⥤ Type u) : (colimit F : Type u) ≃ quot F :=
(is_colimit.cocone_point_unique_up_to_iso
  (colimit.is_colimit F)
  (colimit_cocone_is_colimit F)).to_equiv

@[simp]
lemma colimit_equiv_quot_symm_apply (F : J ⥤ Type u) (j : J) (x : F.obj j) :
  (colimit_equiv_quot F).symm (quot.mk _ ⟨j, x⟩) = colimit.ι F j x :=
rfl

@[simp]
lemma colimit_equiv_quot_apply (F : J ⥤ Type u) (j : J) (x : F.obj j) :
  (colimit_equiv_quot F) (colimit.ι F j x) = quot.mk _ ⟨j, x⟩ :=
begin
  apply (colimit_equiv_quot F).symm.injective,
  simp,
end

@[simp]
lemma colimit.w_apply {F : J ⥤ Type u} {j j' : J} {x : F.obj j} (f : j ⟶ j') :
  colimit.ι F j' (F.map f x) = colimit.ι F j x :=
congr_fun (colimit.w F f) x

@[simp]
lemma colimit.ι_desc_apply (F : J ⥤ Type u) (s : cocone F) (j : J) (x : F.obj j) :
  colimit.desc F s (colimit.ι F j x) = s.ι.app j x :=
congr_fun (colimit.ι_desc s j) x

@[simp]
lemma colimit.ι_map_apply {F G : J ⥤ Type u} (α : F ⟶ G) (j : J) (x) :
  colim.map α (colimit.ι F j x) = colimit.ι G j (α.app j x) :=
congr_fun (colimit.ι_map α j) x

lemma colimit_sound
  {F : J ⥤ Type u} {j j' : J} {x : F.obj j} {x' : F.obj j'} (f : j ⟶ j') (w : F.map f x = x') :
  colimit.ι F j x = colimit.ι F j' x' :=
begin
  rw [←w],
  simp,
end

lemma colimit_sound'
  {F : J ⥤ Type u} {j j' : J} {x : F.obj j} {x' : F.obj j'} {j'' : J} (f : j ⟶ j'') (f' : j' ⟶ j'')
  (w : F.map f x = F.map f' x') :
  colimit.ι F j x = colimit.ι F j' x' :=
begin
  rw [←colimit.w _ f, ←colimit.w _ f'],
  rw [types_comp_apply, types_comp_apply, w],
end

lemma colimit_eq {F : J ⥤ Type u } {j j' : J} {x : F.obj j} {x' : F.obj j'}
  (w : colimit.ι F j x = colimit.ι F j' x') : eqv_gen (quot.rel F) ⟨j, x⟩ ⟨j', x'⟩ :=
begin
  apply quot.eq.1,
  simpa using congr_arg (colimit_equiv_quot F) w,
end

lemma jointly_surjective (F : J ⥤ Type u) {t : cocone F} (h : is_colimit t)
  (x : t.X) : ∃ j y, t.ι.app j y = x :=
begin
  suffices : (λ (x : t.X), ulift.up (∃ j y, t.ι.app j y = x)) = (λ _, ulift.up true),
  { have := congr_fun this x,
    have H := congr_arg ulift.down this,
    dsimp at H,
    rwa eq_true at H },
  refine h.hom_ext _,
  intro j, ext y,
  erw iff_true,
  exact ⟨j, y, rfl⟩
end

/-- A variant of `jointly_surjective` for `x : colimit F`. -/
lemma jointly_surjective' {F : J ⥤ Type u}
  (x : colimit F) : ∃ j y, colimit.ι F j y = x :=
jointly_surjective F (colimit.is_colimit _) x

namespace filtered_colimit
/- For filtered colimits of types, we can give an explicit description
  of the equivalence relation generated by the relation used to form
  the colimit.  -/

variables (F : J ⥤ Type u)

/--
An alternative relation on `Σ j, F.obj j`,
which generates the same equivalence relation as we use to define the colimit in `Type` above,
but that is more convenient when working with filtered colimits.

Elements in `F.obj j` and `F.obj j'` are equivalent if there is some `k : J` to the right
where their images are equal.
-/
protected def r (x y : Σ j, F.obj j) : Prop :=
∃ k (f : x.1 ⟶ k) (g : y.1 ⟶ k), F.map f x.2 = F.map g y.2

protected lemma r_ge (x y : Σ j, F.obj j) :
  (∃ f : x.1 ⟶ y.1, y.2 = F.map f x.2) → filtered_colimit.r F x y :=
λ ⟨f, hf⟩, ⟨y.1, f, 𝟙 y.1, by simp [hf]⟩

variables (t : cocone F)
local attribute [elab_simple] nat_trans.app

/-- Recognizing filtered colimits of types. -/
noncomputable def is_colimit_of (hsurj : ∀ (x : t.X), ∃ i xi, x = t.ι.app i xi)
  (hinj : ∀ i j xi xj, t.ι.app i xi = t.ι.app j xj →
   ∃ k (f : i ⟶ k) (g : j ⟶ k), F.map f xi = F.map g xj) : is_colimit t :=
-- Strategy: Prove that the map from "the" colimit of F (defined above) to t.X
-- is a bijection.
begin
  apply is_colimit.of_iso_colimit (colimit.is_colimit F),
  refine cocones.ext (equiv.to_iso (equiv.of_bijective _ _)) _,
  { exact colimit.desc F t },
  { split,
    { show function.injective _,
      intros a b h,
      rcases jointly_surjective F (colimit.is_colimit F) a with ⟨i, xi, rfl⟩,
      rcases jointly_surjective F (colimit.is_colimit F) b with ⟨j, xj, rfl⟩,
      change (colimit.ι F i ≫ colimit.desc F t) xi = (colimit.ι F j ≫ colimit.desc F t) xj at h,
      rw [colimit.ι_desc, colimit.ι_desc] at h,
      rcases hinj i j xi xj h with ⟨k, f, g, h'⟩,
      change colimit.ι F i xi = colimit.ι F j xj,
      rw [←colimit.w F f, ←colimit.w F g],
      change colimit.ι F k (F.map f xi) = colimit.ι F k (F.map g xj),
      rw h' },
    { show function.surjective _,
      intro x,
      rcases hsurj x with ⟨i, xi, rfl⟩,
      use colimit.ι F i xi,
      simp } },
  { intro j, apply colimit.ι_desc }
end

variables [is_filtered_or_empty J]

protected lemma r_equiv : equivalence (filtered_colimit.r F) :=
⟨λ x, ⟨x.1, 𝟙 x.1, 𝟙 x.1, rfl⟩,
 λ x y ⟨k, f, g, h⟩, ⟨k, g, f, h.symm⟩,
 λ x y z ⟨k, f, g, h⟩ ⟨k', f', g', h'⟩,
   let ⟨l, fl, gl, _⟩ := is_filtered_or_empty.cocone_objs k k',
       ⟨m, n, hn⟩ := is_filtered_or_empty.cocone_maps (g ≫ fl) (f' ≫ gl) in
   ⟨m, f ≫ fl ≫ n, g' ≫ gl ≫ n, calc
      F.map (f ≫ fl ≫ n) x.2
          = F.map (fl ≫ n) (F.map f x.2)  : by simp
      ... = F.map (fl ≫ n) (F.map g y.2)  : by rw h
      ... = F.map ((g ≫ fl) ≫ n) y.2      : by simp
      ... = F.map ((f' ≫ gl) ≫ n) y.2     : by rw hn
      ... = F.map (gl ≫ n) (F.map f' y.2) : by simp
      ... = F.map (gl ≫ n) (F.map g' z.2) : by rw h'
      ... = F.map (g' ≫ gl ≫ n) z.2       : by simp⟩⟩

protected lemma r_eq :
  filtered_colimit.r F = eqv_gen (λ x y, ∃ f : x.1 ⟶ y.1, y.2 = F.map f x.2) :=
begin
  apply le_antisymm,
  { rintros ⟨i, x⟩ ⟨j, y⟩ ⟨k, f, g, h⟩,
    exact eqv_gen.trans _ ⟨k, F.map f x⟩ _ (eqv_gen.rel _ _ ⟨f, rfl⟩)
      (eqv_gen.symm _ _ (eqv_gen.rel _ _ ⟨g, h⟩)) },
  { intros x y,
    convert relation.eqv_gen_mono (filtered_colimit.r_ge F),
    apply propext,
    symmetry,
    exact relation.eqv_gen_iff_of_equivalence (filtered_colimit.r_equiv F) }
end

lemma colimit_eq_iff_aux {i j : J} {xi : F.obj i} {xj : F.obj j} :
  (colimit_cocone F).ι.app i xi = (colimit_cocone F).ι.app j xj ↔
    ∃ k (f : i ⟶ k) (g : j ⟶ k), F.map f xi = F.map g xj :=
begin
  change quot.mk _ _ = quot.mk _ _ ↔ _,
  rw [quot.eq, quot.rel, ←filtered_colimit.r_eq],
  refl
end

variables {t} (ht : is_colimit t)
lemma is_colimit_eq_iff {i j : J} {xi : F.obj i} {xj : F.obj j} :
  t.ι.app i xi = t.ι.app j xj ↔ ∃ k (f : i ⟶ k) (g : j ⟶ k), F.map f xi = F.map g xj :=
let t' := colimit_cocone F,
    e : t' ≅ t := is_colimit.unique_up_to_iso (colimit_cocone_is_colimit F) ht,
    e' : t'.X ≅ t.X := (cocones.forget _).map_iso e in
begin
  refine iff.trans _ (colimit_eq_iff_aux F),
  convert e'.to_equiv.apply_eq_iff_eq; rw ←e.hom.w; refl
end

lemma colimit_eq_iff {i j : J} {xi : F.obj i} {xj : F.obj j} :
  colimit.ι F i xi = colimit.ι F j xj ↔ ∃ k (f : i ⟶ k) (g : j ⟶ k), F.map f xi = F.map g xj :=
is_colimit_eq_iff _ (colimit.is_colimit F)

end filtered_colimit

variables {α β : Type u} (f : α ⟶ β)

section -- implementation of `has_image`
/-- the image of a morphism in Type is just `set.range f` -/
def image : Type u := set.range f

instance [inhabited α] : inhabited (image f) :=
{ default := ⟨f (default α), ⟨_, rfl⟩⟩ }

/-- the inclusion of `image f` into the target -/
def image.ι : image f ⟶ β := subtype.val

instance : mono (image.ι f) :=
(mono_iff_injective _).2 subtype.val_injective

variables {f}

/-- the universal property for the image factorisation -/
noncomputable def image.lift (F' : mono_factorisation f) : image f ⟶ F'.I :=
(λ x, F'.e (classical.indefinite_description _ x.2).1 : image f → F'.I)

lemma image.lift_fac (F' : mono_factorisation f) : image.lift F' ≫ F'.m = image.ι f :=
begin
  ext x,
  change (F'.e ≫ F'.m) _ = _,
  rw [F'.fac, (classical.indefinite_description _ x.2).2],
  refl,
end
end

/-- the factorisation of any morphism in Type through a mono. -/
def mono_factorisation : mono_factorisation f :=
{ I := image f,
  m := image.ι f,
  e := set.range_factorization f }

/-- the facorisation through a mono has the universal property of the image. -/
noncomputable def is_image : is_image (mono_factorisation f) :=
{ lift := image.lift,
  lift_fac' := image.lift_fac }

instance : has_image f :=
has_image.mk ⟨_, is_image f⟩

instance : has_images (Type u) :=
{ has_image := by apply_instance }

instance : has_image_maps (Type u) :=
{ has_image_map := λ f g st, has_image_map.transport st (mono_factorisation f.hom) (is_image g.hom)
    (λ x, ⟨st.right x.1, ⟨st.left (classical.some x.2),
      begin
        have p := st.w,
        replace p := congr_fun p (classical.some x.2),
        simp only [functor.id_map, types_comp_apply, subtype.val_eq_coe] at p,
        erw [p, classical.some_spec x.2],
      end⟩⟩) rfl }

end category_theory.limits.types


inductive Vec (α : Type u) : Nat → Type u where
  | nil  : Vec α 0
  | cons : α → Vec α n → Vec α (n + 1)

theorem ex1 {a b c d x : Nat} (h : Vec.cons a (Vec.cons b Vec.nil) = Vec.cons x (Vec.cons 0 Vec.nil)) : a = x + b := by
  simp_all

theorem ex2 {a b c d x : Nat} (h : [a, b] = [x, 0]) : a = x + b := by
  simp_all

theorem ex3 {a b c d x : Nat} (h : Array.mk [a, b] = Array.mk [x, 0]) : a = x + b := by
  simp_all

theorem ex4 {a b c d x : Nat} (h : (Array.mk [a, b], c)  = (Array.mk [x, 0], d)) : a + c = x + b + d := by
  simp_all


/-
Copyright (c) 2018 Jeremy Avigad. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Jeremy Avigad, Simon Hudon
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.control.functor.multivariate
import Mathlib.data.pfunctor.univariate.default
import Mathlib.data.sigma.default
import Mathlib.PostPort

universes u l u_1

namespace Mathlib

/-!
# Multivariate polynomial functors.

Multivariate polynomial functors are used for defining M-types and W-types.
They map a type vector `α` to the type `Σ a : A, B a ⟹ α`, with `A : Type` and
`B : A → typevec n`. They interact well with Lean's inductive definitions because
they guarantee that occurrences of `α` are positive.
-/

/--
multivariate polynomial functors
-/
structure mvpfunctor (n : ℕ) where
  A : Type u
  B : A → typevec n

namespace mvpfunctor

/-- Applying `P` to an object of `Type` -/
def obj {n : ℕ} (P : mvpfunctor n) (α : typevec n) := sigma fun (a : A P) => typevec.arrow (B P a) α

/-- Applying `P` to a morphism of `Type` -/
def map {n : ℕ} (P : mvpfunctor n) {α : typevec n} {β : typevec n} (f : typevec.arrow α β) :
    obj P α → obj P β :=
  fun (_x : obj P α) => sorry

protected instance inhabited {n : ℕ} : Inhabited (mvpfunctor n) :=
  { default := mk Inhabited.default fun (_x : Inhabited.default) => Inhabited.default }

protected instance obj.inhabited {n : ℕ} (P : mvpfunctor n) {α : typevec n} [Inhabited (A P)]
    [(i : fin2 n) → Inhabited (α i)] : Inhabited (obj P α) :=
  { default :=
      sigma.mk Inhabited.default
        fun (_x : fin2 n) (_x_1 : B P Inhabited.default _x) => Inhabited.default }

protected instance obj.mvfunctor {n : ℕ} (P : mvpfunctor n) : mvfunctor (obj P) :=
  mvfunctor.mk (map P)

theorem map_eq {n : ℕ} (P : mvpfunctor n) {α : typevec n} {β : typevec n} (g : typevec.arrow α β)
    (a : A P) (f : typevec.arrow (B P a) α) :
    mvfunctor.map g (sigma.mk a f) = sigma.mk a (typevec.comp g f) :=
  rfl

theorem id_map {n : ℕ} (P : mvpfunctor n) {α : typevec n} (x : obj P α) :
    mvfunctor.map typevec.id x = x :=
  sigma.cases_on x
    fun (x_fst : A P) (x_snd : typevec.arrow (B P x_fst) α) =>
      idRhs
        (mvfunctor.map typevec.id (sigma.mk x_fst x_snd) =
          mvfunctor.map typevec.id (sigma.mk x_fst x_snd))
        rfl

theorem comp_map {n : ℕ} (P : mvpfunctor n) {α : typevec n} {β : typevec n} {γ : typevec n}
    (f : typevec.arrow α β) (g : typevec.arrow β γ) (x : obj P α) :
    mvfunctor.map (typevec.comp g f) x = mvfunctor.map g (mvfunctor.map f x) :=
  sorry

protected instance obj.is_lawful_mvfunctor {n : ℕ} (P : mvpfunctor n) :
    is_lawful_mvfunctor (obj P) :=
  is_lawful_mvfunctor.mk (id_map P) (comp_map P)

/-- Constant functor where the input object does not affect the output -/
def const (n : ℕ) (A : Type u) : mvpfunctor n := mk A fun (a : A) (i : fin2 n) => pempty

/-- Constructor for the constant functor -/
def const.mk (n : ℕ) {A : Type u} (x : A) {α : typevec n} : obj (const n A) α :=
  sigma.mk x fun (i : fin2 n) (a : B (const n A) x i) => pempty.elim a

/-- Destructor for the constant functor -/
def const.get {n : ℕ} {A : Type u} {α : typevec n} (x : obj (const n A) α) : A := sigma.fst x

@[simp] theorem const.get_map {n : ℕ} {A : Type u} {α : typevec n} {β : typevec n}
    (f : typevec.arrow α β) (x : obj (const n A) α) : const.get (mvfunctor.map f x) = const.get x :=
  sigma.cases_on x
    fun (x_fst : A (const n A)) (x_snd : typevec.arrow (B (const n A) x_fst) α) =>
      Eq.refl (const.get (mvfunctor.map f (sigma.mk x_fst x_snd)))

@[simp] theorem const.get_mk {n : ℕ} {A : Type u} {α : typevec n} (x : A) :
    const.get (const.mk n x) = x :=
  Eq.refl (const.get (const.mk n x))

@[simp] theorem const.mk_get {n : ℕ} {A : Type u} {α : typevec n} (x : obj (const n A) α) :
    const.mk n (const.get x) = x :=
  sorry

/-- Functor composition on polynomial functors -/
def comp {n : ℕ} {m : ℕ} (P : mvpfunctor n) (Q : fin2 n → mvpfunctor m) : mvpfunctor m :=
  mk (sigma fun (a₂ : A P) => (i : fin2 n) → B P a₂ i → A (Q i))
    fun (a : sigma fun (a₂ : A P) => (i : fin2 n) → B P a₂ i → A (Q i)) (i : fin2 m) =>
      sigma fun (j : fin2 n) => sigma fun (b : B P (sigma.fst a) j) => B (Q j) (sigma.snd a j b) i

/-- Constructor for functor composition -/
def comp.mk {n : ℕ} {m : ℕ} {P : mvpfunctor n} {Q : fin2 n → mvpfunctor m} {α : typevec m}
    (x : obj P fun (i : fin2 n) => obj (Q i) α) : obj (comp P Q) α :=
  sigma.mk
    (sigma.mk (sigma.fst x)
      fun (i : fin2 n) (a : B P (sigma.fst x) i) => sigma.fst (sigma.snd x i a))
    fun (i : fin2 m)
      (a :
      B (comp P Q)
        (sigma.mk (sigma.fst x)
          fun (i : fin2 n) (a : B P (sigma.fst x) i) => sigma.fst (sigma.snd x i a))
        i) =>
      sigma.snd (sigma.snd x (sigma.fst a) (sigma.fst (sigma.snd a))) i (sigma.snd (sigma.snd a))

/-- Destructor for functor composition -/
def comp.get {n : ℕ} {m : ℕ} {P : mvpfunctor n} {Q : fin2 n → mvpfunctor m} {α : typevec m}
    (x : obj (comp P Q) α) : obj P fun (i : fin2 n) => obj (Q i) α :=
  sigma.mk (sigma.fst (sigma.fst x))
    fun (i : fin2 n) (a : B P (sigma.fst (sigma.fst x)) i) =>
      sigma.mk (sigma.snd (sigma.fst x) i a)
        fun (j : fin2 m) (b : B (Q i) (sigma.snd (sigma.fst x) i a) j) =>
          sigma.snd x j (sigma.mk i (sigma.mk a b))

theorem comp.get_map {n : ℕ} {m : ℕ} {P : mvpfunctor n} {Q : fin2 n → mvpfunctor m} {α : typevec m}
    {β : typevec m} (f : typevec.arrow α β) (x : obj (comp P Q) α) :
    comp.get (mvfunctor.map f x) =
        mvfunctor.map (fun (i : fin2 n) (x : obj (Q i) α) => mvfunctor.map f x) (comp.get x) :=
  sigma.cases_on x
    fun (x_fst : A (comp P Q)) (x_snd : typevec.arrow (B (comp P Q) x_fst) α) =>
      Eq.refl (comp.get (mvfunctor.map f (sigma.mk x_fst x_snd)))

@[simp] theorem comp.get_mk {n : ℕ} {m : ℕ} {P : mvpfunctor n} {Q : fin2 n → mvpfunctor m}
    {α : typevec m} (x : obj P fun (i : fin2 n) => obj (Q i) α) : comp.get (comp.mk x) = x :=
  sorry

@[simp] theorem comp.mk_get {n : ℕ} {m : ℕ} {P : mvpfunctor n} {Q : fin2 n → mvpfunctor m}
    {α : typevec m} (x : obj (comp P Q) α) : comp.mk (comp.get x) = x :=
  sorry

/-
lifting predicates and relations
-/

theorem liftp_iff {n : ℕ} {P : mvpfunctor n} {α : typevec n} (p : {i : fin2 n} → α i → Prop)
    (x : obj P α) :
    mvfunctor.liftp p x ↔
        ∃ (a : A P),
          ∃ (f : typevec.arrow (B P a) α),
            x = sigma.mk a f ∧ ∀ (i : fin2 n) (j : B P a i), p (f i j) :=
  sorry

theorem liftp_iff' {n : ℕ} {P : mvpfunctor n} {α : typevec n} (p : {i : fin2 n} → α i → Prop)
    (a : A P) (f : typevec.arrow (B P a) α) :
    mvfunctor.liftp p (sigma.mk a f) ↔ ∀ (i : fin2 n) (x : B P a i), p (f i x) :=
  sorry

theorem liftr_iff {n : ℕ} {P : mvpfunctor n} {α : typevec n} (r : {i : fin2 n} → α i → α i → Prop)
    (x : obj P α) (y : obj P α) :
    mvfunctor.liftr r x y ↔
        ∃ (a : A P),
          ∃ (f₀ : typevec.arrow (B P a) α),
            ∃ (f₁ : typevec.arrow (B P a) α),
              x = sigma.mk a f₀ ∧
                y = sigma.mk a f₁ ∧ ∀ (i : fin2 n) (j : B P a i), r (f₀ i j) (f₁ i j) :=
  sorry

theorem supp_eq {n : ℕ} {P : mvpfunctor n} {α : typevec n} (a : A P) (f : typevec.arrow (B P a) α)
    (i : fin2 n) : mvfunctor.supp (sigma.mk a f) i = f i '' set.univ :=
  sorry

end mvpfunctor

/-
Decomposing an n+1-ary pfunctor.
-/

namespace mvpfunctor

/-- Split polynomial functor, get a n-ary functor
from a `n+1`-ary functor -/
def drop {n : ℕ} (P : mvpfunctor (n + 1)) : mvpfunctor n :=
  mk (A P) fun (a : A P) => typevec.drop (B P a)

/-- Split polynomial functor, get a univariate functor
from a `n+1`-ary functor -/
def last {n : ℕ} (P : mvpfunctor (n + 1)) : pfunctor :=
  pfunctor.mk (A P) fun (a : A P) => typevec.last (B P a)

/-- append arrows of a polynomial functor application -/
def append_contents {n : ℕ} (P : mvpfunctor (n + 1)) {α : typevec n} {β : Type u_1} {a : A P}
    (f' : typevec.arrow (B (drop P) a) α) (f : pfunctor.B (last P) a → β) :
    typevec.arrow (B P a) (α ::: β) :=
  typevec.split_fun f' f

end Mathlib


/-
Copyright (c) 2018 Chris Hughes. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Chris Hughes, Abhimanyu Pallavi Sudhir, Jean Lo, Calle Sönne, Benjamin Davidson

! This file was ported from Lean 3 source module analysis.special_functions.complex.log_deriv
! leanprover-community/mathlib commit f2ce6086713c78a7f880485f7917ea547a215982
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Analysis.SpecialFunctions.Complex.Log
import Mathbin.Analysis.SpecialFunctions.ExpDeriv

/-!
# Differentiability of the complex `log` function

-/

noncomputable section

namespace Complex

open Set Filter

open Real Topology

/-- `complex.exp` as a `local_homeomorph` with `source = {z | -π < im z < π}` and
`target = {z | 0 < re z} ∪ {z | im z ≠ 0}`. This definition is used to prove that `complex.log`
is complex differentiable at all points but the negative real semi-axis. -/
def expLocalHomeomorph : LocalHomeomorph ℂ ℂ :=
  LocalHomeomorph.ofContinuousOpen
    { toFun := exp
      invFun := log
      source := { z : ℂ | z.im ∈ Ioo (-π) π }
      target := { z : ℂ | 0 < z.re } ∪ { z : ℂ | z.im ≠ 0 }
      map_source' := by
        rintro ⟨x, y⟩ ⟨h₁ : -π < y, h₂ : y < π⟩
        refine' (not_or_of_imp fun hz => _).symm
        obtain rfl : y = 0 := by
          rw [exp_im] at hz
          simpa [(Real.exp_pos _).ne', Real.sin_eq_zero_iff_of_lt_of_lt h₁ h₂] using hz
        rw [mem_set_of_eq, ← of_real_def, exp_of_real_re]
        exact Real.exp_pos x
      map_target' := fun z h =>
        suffices 0 ≤ z.re ∨ z.im ≠ 0 by
          simpa [log_im, neg_pi_lt_arg, (arg_le_pi _).lt_iff_ne, arg_eq_pi_iff, not_and_or]
        h.imp (fun h => le_of_lt h) id
      left_inv' := fun x hx => log_exp hx.1 (le_of_lt hx.2)
      right_inv' := fun x hx =>
        exp_log <| by
          rintro rfl
          simpa [lt_irrefl] using hx }
    continuous_exp.ContinuousOn isOpenMap_exp (isOpen_Ioo.Preimage continuous_im)
#align complex.exp_local_homeomorph Complex.expLocalHomeomorph

theorem hasStrictDerivAt_log {x : ℂ} (h : 0 < x.re ∨ x.im ≠ 0) : HasStrictDerivAt log x⁻¹ x :=
  have h0 : x ≠ 0 := by
    rintro rfl
    simpa [lt_irrefl] using h
  expLocalHomeomorph.hasStrictDerivAt_symm h h0 <| by
    simpa [exp_log h0] using has_strict_deriv_at_exp (log x)
#align complex.has_strict_deriv_at_log Complex.hasStrictDerivAt_log

theorem hasStrictFderivAt_log_real {x : ℂ} (h : 0 < x.re ∨ x.im ≠ 0) :
    HasStrictFderivAt log (x⁻¹ • (1 : ℂ →L[ℝ] ℂ)) x :=
  (hasStrictDerivAt_log h).complexToReal_fderiv
#align complex.has_strict_fderiv_at_log_real Complex.hasStrictFderivAt_log_real

theorem contDiffAt_log {x : ℂ} (h : 0 < x.re ∨ x.im ≠ 0) {n : ℕ∞} : ContDiffAt ℂ n log x :=
  expLocalHomeomorph.contDiffAt_symm_deriv (exp_ne_zero <| log x) h (hasDerivAt_exp _)
    contDiff_exp.ContDiffAt
#align complex.cont_diff_at_log Complex.contDiffAt_log

end Complex

section LogDeriv

open Complex Filter

open Topology

variable {α : Type _} [TopologicalSpace α] {E : Type _} [NormedAddCommGroup E] [NormedSpace ℂ E]

theorem HasStrictFderivAt.clog {f : E → ℂ} {f' : E →L[ℂ] ℂ} {x : E} (h₁ : HasStrictFderivAt f f' x)
    (h₂ : 0 < (f x).re ∨ (f x).im ≠ 0) : HasStrictFderivAt (fun t => log (f t)) ((f x)⁻¹ • f') x :=
  (hasStrictDerivAt_log h₂).comp_hasStrictFderivAt x h₁
#align has_strict_fderiv_at.clog HasStrictFderivAt.clog

theorem HasStrictDerivAt.clog {f : ℂ → ℂ} {f' x : ℂ} (h₁ : HasStrictDerivAt f f' x)
    (h₂ : 0 < (f x).re ∨ (f x).im ≠ 0) : HasStrictDerivAt (fun t => log (f t)) (f' / f x) x :=
  by
  rw [div_eq_inv_mul]
  exact (has_strict_deriv_at_log h₂).comp x h₁
#align has_strict_deriv_at.clog HasStrictDerivAt.clog

theorem HasStrictDerivAt.clog_real {f : ℝ → ℂ} {x : ℝ} {f' : ℂ} (h₁ : HasStrictDerivAt f f' x)
    (h₂ : 0 < (f x).re ∨ (f x).im ≠ 0) : HasStrictDerivAt (fun t => log (f t)) (f' / f x) x := by
  simpa only [div_eq_inv_mul] using (has_strict_fderiv_at_log_real h₂).comp_hasStrictDerivAt x h₁
#align has_strict_deriv_at.clog_real HasStrictDerivAt.clog_real

theorem HasFderivAt.clog {f : E → ℂ} {f' : E →L[ℂ] ℂ} {x : E} (h₁ : HasFderivAt f f' x)
    (h₂ : 0 < (f x).re ∨ (f x).im ≠ 0) : HasFderivAt (fun t => log (f t)) ((f x)⁻¹ • f') x :=
  (hasStrictDerivAt_log h₂).HasDerivAt.comp_hasFderivAt x h₁
#align has_fderiv_at.clog HasFderivAt.clog

theorem HasDerivAt.clog {f : ℂ → ℂ} {f' x : ℂ} (h₁ : HasDerivAt f f' x)
    (h₂ : 0 < (f x).re ∨ (f x).im ≠ 0) : HasDerivAt (fun t => log (f t)) (f' / f x) x :=
  by
  rw [div_eq_inv_mul]
  exact (has_strict_deriv_at_log h₂).HasDerivAt.comp x h₁
#align has_deriv_at.clog HasDerivAt.clog

theorem HasDerivAt.clog_real {f : ℝ → ℂ} {x : ℝ} {f' : ℂ} (h₁ : HasDerivAt f f' x)
    (h₂ : 0 < (f x).re ∨ (f x).im ≠ 0) : HasDerivAt (fun t => log (f t)) (f' / f x) x := by
  simpa only [div_eq_inv_mul] using
    (has_strict_fderiv_at_log_real h₂).HasFderivAt.comp_hasDerivAt x h₁
#align has_deriv_at.clog_real HasDerivAt.clog_real

theorem DifferentiableAt.clog {f : E → ℂ} {x : E} (h₁ : DifferentiableAt ℂ f x)
    (h₂ : 0 < (f x).re ∨ (f x).im ≠ 0) : DifferentiableAt ℂ (fun t => log (f t)) x :=
  (h₁.HasFderivAt.clog h₂).DifferentiableAt
#align differentiable_at.clog DifferentiableAt.clog

theorem HasFderivWithinAt.clog {f : E → ℂ} {f' : E →L[ℂ] ℂ} {s : Set E} {x : E}
    (h₁ : HasFderivWithinAt f f' s x) (h₂ : 0 < (f x).re ∨ (f x).im ≠ 0) :
    HasFderivWithinAt (fun t => log (f t)) ((f x)⁻¹ • f') s x :=
  (hasStrictDerivAt_log h₂).HasDerivAt.comp_hasFderivWithinAt x h₁
#align has_fderiv_within_at.clog HasFderivWithinAt.clog

theorem HasDerivWithinAt.clog {f : ℂ → ℂ} {f' x : ℂ} {s : Set ℂ} (h₁ : HasDerivWithinAt f f' s x)
    (h₂ : 0 < (f x).re ∨ (f x).im ≠ 0) : HasDerivWithinAt (fun t => log (f t)) (f' / f x) s x :=
  by
  rw [div_eq_inv_mul]
  exact (has_strict_deriv_at_log h₂).HasDerivAt.comp_hasDerivWithinAt x h₁
#align has_deriv_within_at.clog HasDerivWithinAt.clog

theorem HasDerivWithinAt.clog_real {f : ℝ → ℂ} {s : Set ℝ} {x : ℝ} {f' : ℂ}
    (h₁ : HasDerivWithinAt f f' s x) (h₂ : 0 < (f x).re ∨ (f x).im ≠ 0) :
    HasDerivWithinAt (fun t => log (f t)) (f' / f x) s x := by
  simpa only [div_eq_inv_mul] using
    (has_strict_fderiv_at_log_real h₂).HasFderivAt.comp_hasDerivWithinAt x h₁
#align has_deriv_within_at.clog_real HasDerivWithinAt.clog_real

theorem DifferentiableWithinAt.clog {f : E → ℂ} {s : Set E} {x : E}
    (h₁ : DifferentiableWithinAt ℂ f s x) (h₂ : 0 < (f x).re ∨ (f x).im ≠ 0) :
    DifferentiableWithinAt ℂ (fun t => log (f t)) s x :=
  (h₁.HasFderivWithinAt.clog h₂).DifferentiableWithinAt
#align differentiable_within_at.clog DifferentiableWithinAt.clog

theorem DifferentiableOn.clog {f : E → ℂ} {s : Set E} (h₁ : DifferentiableOn ℂ f s)
    (h₂ : ∀ x ∈ s, 0 < (f x).re ∨ (f x).im ≠ 0) : DifferentiableOn ℂ (fun t => log (f t)) s :=
  fun x hx => (h₁ x hx).clog (h₂ x hx)
#align differentiable_on.clog DifferentiableOn.clog

theorem Differentiable.clog {f : E → ℂ} (h₁ : Differentiable ℂ f)
    (h₂ : ∀ x, 0 < (f x).re ∨ (f x).im ≠ 0) : Differentiable ℂ fun t => log (f t) := fun x =>
  (h₁ x).clog (h₂ x)
#align differentiable.clog Differentiable.clog

end LogDeriv


/-
Copyright (c) 2017 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Patrick Massot, Scott Morrison, Mario Carneiro

! This file was ported from Lean 3 source module topology.category.Top.basic
! leanprover-community/mathlib commit bcfa726826abd57587355b4b5b7e78ad6527b7e4
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.CategoryTheory.ConcreteCategory.BundledHom
import Mathbin.CategoryTheory.Elementwise
import Mathbin.Topology.ContinuousFunction.Basic

/-!
# Category instance for topological spaces

We introduce the bundled category `Top` of topological spaces together with the functors `discrete`
and `trivial` from the category of types to `Top` which equip a type with the corresponding
discrete, resp. trivial, topology. For a proof that these functors are left, resp. right adjoint
to the forgetful functor, see `topology.category.Top.adjunctions`.
-/

open CategoryTheory

open TopologicalSpace

universe u

/-- The category of topological spaces and continuous maps. -/
def TopCat : Type (u + 1) :=
  Bundled TopologicalSpace
#align Top TopCat

namespace TopCat

instance bundledHom : BundledHom @ContinuousMap :=
  ⟨@ContinuousMap.toFun, @ContinuousMap.id, @ContinuousMap.comp, @ContinuousMap.coe_injective⟩
#align Top.bundled_hom TopCat.bundledHom

deriving instance LargeCategory, ConcreteCategory for TopCat

instance : CoeSort TopCat (Type _) :=
  Bundled.hasCoeToSort

instance topologicalSpaceUnbundled (x : TopCat) : TopologicalSpace x :=
  x.str
#align Top.topological_space_unbundled TopCat.topologicalSpaceUnbundled

@[simp]
theorem id_app (X : TopCat.{u}) (x : X) : (𝟙 X : X → X) x = x :=
  rfl
#align Top.id_app TopCat.id_app

@[simp]
theorem comp_app {X Y Z : TopCat.{u}} (f : X ⟶ Y) (g : Y ⟶ Z) (x : X) :
    (f ≫ g : X → Z) x = g (f x) :=
  rfl
#align Top.comp_app TopCat.comp_app

/-- Construct a bundled `Top` from the underlying type and the typeclass. -/
def of (X : Type u) [TopologicalSpace X] : TopCat :=
  ⟨X⟩
#align Top.of TopCat.of

instance (X : TopCat) : TopologicalSpace X :=
  X.str

@[simp]
theorem coe_of (X : Type u) [TopologicalSpace X] : (of X : Type u) = X :=
  rfl
#align Top.coe_of TopCat.coe_of

instance : Inhabited TopCat :=
  ⟨TopCat.of Empty⟩

/-- The discrete topology on any type. -/
def discrete : Type u ⥤ TopCat.{u} where
  obj X := ⟨X, ⊥⟩
  map X Y f :=
    { toFun := f
      continuous_toFun := continuous_bot }
#align Top.discrete TopCat.discrete

instance {X : Type u} : DiscreteTopology (discrete.obj X) :=
  ⟨rfl⟩

/-- The trivial topology on any type. -/
def trivial : Type u ⥤ TopCat.{u} where
  obj X := ⟨X, ⊤⟩
  map X Y f :=
    { toFun := f
      continuous_toFun := continuous_top }
#align Top.trivial TopCat.trivial

/-- Any homeomorphisms induces an isomorphism in `Top`. -/
@[simps]
def isoOfHomeo {X Y : TopCat.{u}} (f : X ≃ₜ Y) : X ≅ Y
    where
  Hom := ⟨f⟩
  inv := ⟨f.symm⟩
#align Top.iso_of_homeo TopCat.isoOfHomeo

/-- Any isomorphism in `Top` induces a homeomorphism. -/
@[simps]
def homeoOfIso {X Y : TopCat.{u}} (f : X ≅ Y) : X ≃ₜ Y
    where
  toFun := f.Hom
  invFun := f.inv
  left_inv x := by simp
  right_inv x := by simp
  continuous_toFun := f.Hom.Continuous
  continuous_invFun := f.inv.Continuous
#align Top.homeo_of_iso TopCat.homeoOfIso

@[simp]
theorem of_isoOfHomeo {X Y : TopCat.{u}} (f : X ≃ₜ Y) : homeoOfIso (isoOfHomeo f) = f :=
  by
  ext
  rfl
#align Top.of_iso_of_homeo TopCat.of_isoOfHomeo

@[simp]
theorem of_homeoOfIso {X Y : TopCat.{u}} (f : X ≅ Y) : isoOfHomeo (homeoOfIso f) = f :=
  by
  ext
  rfl
#align Top.of_homeo_of_iso TopCat.of_homeoOfIso

@[simp]
theorem openEmbedding_iff_comp_isIso {X Y Z : TopCat} (f : X ⟶ Y) (g : Y ⟶ Z) [IsIso g] :
    OpenEmbedding (f ≫ g) ↔ OpenEmbedding f :=
  (TopCat.homeoOfIso (asIso g)).OpenEmbedding.of_comp_iff f
#align Top.open_embedding_iff_comp_is_iso TopCat.openEmbedding_iff_comp_isIso

@[simp]
theorem openEmbedding_iff_isIso_comp {X Y Z : TopCat} (f : X ⟶ Y) (g : Y ⟶ Z) [IsIso f] :
    OpenEmbedding (f ≫ g) ↔ OpenEmbedding g :=
  by
  constructor
  · intro h
    convert h.comp (TopCat.homeoOfIso (as_iso f).symm).OpenEmbedding
    exact congr_arg _ (is_iso.inv_hom_id_assoc f g).symm
  · exact fun h => h.comp (TopCat.homeoOfIso (as_iso f)).OpenEmbedding
#align Top.open_embedding_iff_is_iso_comp TopCat.openEmbedding_iff_isIso_comp

end TopCat


import .rules

open psum nnf node

set_option eqn_compiler.zeta true

def tableau : Π Γ : seqt, node Γ
| Γ :=
match get_contra_seqt Γ with
| inl w := contra_rule_seqt w.2
| inr no_contra :=
  match get_and_seqt Γ with
  | inl p :=
  let Δ := p.1.1 :: p.1.2 :: Γ.main.erase (and p.val.1 p.val.2) in
  let inst := and_instance_seqt.cons p.2 in
  have h : prod.measure_lex seqt_size ⟨_,_,_,_⟩ Γ,
  begin apply split_lt_and_seqt, exact p.2 end,
  let d_delta : node ⟨Δ, Γ.hdld,_,_⟩ := tableau (and_child Γ p.2) in
  and_rule_seqt inst d_delta
  | inr no_and :=
    match get_or_seqt Γ with
    | inl p :=
    let Γ₁ := p.1.1 :: Γ.main.erase (nnf.or p.val.1 p.val.2) in
    let Γ₂ := p.1.2 :: Γ.main.erase (nnf.or p.val.1 p.val.2) in
    let inst := or_instance_seqt.cons p.2 in
    have h₁ : prod.measure_lex seqt_size ⟨Γ₁, Γ.hdld,_,_⟩ Γ,
    begin apply split_lt_or_seqt_left, exact p.2 end,
    have h₂ : prod.measure_lex seqt_size ⟨Γ₂, Γ.hdld,_,_⟩ Γ,
    begin apply split_lt_or_seqt_right, exact p.2 end,
    let d_Γ₁ : node ⟨Γ₁, Γ.hdld,_,_⟩ := tableau (or_child_left Γ p.2) in
    match d_Γ₁ with
    | closed pr := or_rule_seqt inst (closed pr) (tableau (or_child_right Γ p.2))
    | open_ w := open_rule_seqt inst w.2
    end
    | inr no_or :=
      match get_box_seqt Γ with
      | inl p :=
      let Γ₁ := p.1 :: Γ.main.erase (nnf.box p.1) in
      let inst := copy_instance_seqt.cons p.2 in
      have h : prod.measure_lex seqt_size ⟨Γ₁, box p.1 :: Γ.hdld,_,_⟩ Γ,
      begin apply copy_lt_seqt, exact p.2 end,
      let d_delta : node ⟨Γ₁, box p.1 :: Γ.hdld,_,_⟩ := tableau (box_child Γ p.2) in
      copy_rule_seqt inst d_delta
      | inr no_box :=
        match get_dia_seqt Γ with
        | inl p :=
        let ma : modal_applicable Γ :=
            {satu := {no_and := no_and, no_or := no_or},
             no_contra_main := no_contra,
             no_box_main := no_box,
             v := get_var Γ.main,
             hv := λ n, get_var_iff,
             φ := p.1,
             ex := p.2} in
        let l := @dia_rule_seqt (λ Δ, prod.measure_lex seqt_size Δ Γ)
                 (λ x h, tableau x) (unmodal_seqt Γ)
                 (unmodal_seqt_size Γ) in
        match l with
        | inl w :=
          begin left, {exact unsat_of_unsat_unmodal ma w.1 w.2} end
        | inr w :=
          begin right, split, apply sat_of_batch_sat, exact ma, exact w.2 end
        end
        | inr no_dia :=
        let mc : model_constructible Γ :=
          {satu := {no_and := no_and, no_or := no_or},
           no_box_main := no_box,
           no_contra_main := no_contra,
           v := get_var Γ.main,
           hv := λ n, get_var_iff,
           no_dia := no_dia} in
        begin right, split, apply build_model_seqt, exact mc end
        end
      end
    end
  end
end
using_well_founded {rel_tac := λ _ _, `[exact ⟨_, prod.measure_lex_wf seqt_size⟩], dec_tac := `[assumption]}

@[simp] def mk_seqt (Γ : list nnf) : seqt :=
{ main := Γ,
  hdld := [],
  pmain := begin
             intros v l φ h hb hall, exfalso,
             apply list.not_mem_nil, exact hb
           end,
  phdld := box_only_nil }

def is_sat (Γ : list nnf) : bool :=
match tableau (mk_seqt Γ) with
| closed _ := ff
| open_ _  := tt
end

theorem correctness (Γ : list nnf) : is_sat Γ = tt ↔ ∃ (st : Type) (k : KT st) s, sat k s Γ :=
begin
  cases h : is_sat Γ,
  constructor,
  {intro, contradiction},
  {intro hsat, cases eq : tableau (mk_seqt Γ),
   rcases hsat with ⟨w, k, s, hsat⟩,
   apply false.elim, apply a, simp, exact hsat,
   {dsimp [is_sat] at h, dsimp at eq, rw eq at h, contradiction} },
  {split, intro, dsimp [is_sat] at h,
    cases eq : tableau (mk_seqt Γ),
    { dsimp at eq, rw eq at h, contradiction },
  { split, split, split, have := a_1.2, simp at this, exact this},
  { simp } }
end

def test  := [box (var 1), (neg 1)]

#eval is_sat test


inductive fml
| atom (i : ℕ)
| imp (a b : fml)
| not (a : fml)
open fml

infixr ` →' `:50 := imp
local notation ` ¬' ` := fml.not

inductive prf : fml → Type
| axk (p q) : prf (p →' q →' p)
| axs (p q r) : prf $ (p →' q →' r) →' (p →' q) →' (p →' r)
| axn (p q) : prf $ (¬'q →' ¬'p) →' p →' q
| amp (p q) : prf (p →' (p →' q) →' q) -- internal modus ponnens, i couldn't prove it, can you?
| cn (p q r) : prf (q →' r) → prf (p →' q) → prf (p →' r)
| mp (p q) : prf p → prf (p →' q) → prf q

theorem reflex (P : fml) : prf (P →' P) :=
    begin
        have R : fml, exact P,
        let Q : fml := R →' P,
        have HPQ : prf (P →' Q),
            change prf (P →' (R →' P)),
            apply prf.axk,
        have HPQP : prf (P →' (Q →' P)),
            apply prf.axk,
        have HPQPP : prf ((P →' Q) →' (P →' P)),
            apply prf.mp (P →' Q →' P),
            exact HPQP,
            apply prf.axs,
        apply prf.mp (P →' Q),
        exact HPQ,
        exact HPQPP,
    end

lemma deduct (P Q : fml) : prf ((P →' Q) →' P →' Q) :=
    begin
        apply reflex,
    end

lemma deduction (P Q : fml) : prf ((P →' (P →' Q)) →' (P →' Q)) :=
    begin
        apply prf.mp (P →' ((P →' Q) →' Q)),
        apply prf.amp,
        apply prf.axs,
    end

lemma yesyes (Q : fml) : prf (¬'(¬'Q) →' Q) :=
    begin
        have H4213 : prf ((¬'(¬'(¬'(¬'Q))) →' ¬'(¬'Q)) →' (¬'Q →' ¬'(¬'(¬'Q)))),
            apply prf.axn,
        have H1320 : prf ((¬'Q →' ¬'(¬'(¬'Q))) →' (¬'(¬'Q) →' Q)),
            apply prf.axn,
        have H4220 : prf ((¬'(¬'(¬'(¬'Q))) →' ¬'(¬'Q)) →' (¬'(¬'Q) →' Q)),
            apply prf.cn (¬'(¬'(¬'(¬'Q))) →' ¬'(¬'Q)) ((¬'Q →' ¬'(¬'(¬'Q)))) (¬'(¬'Q) →' Q),
            exact H1320, exact H4213,
        have H242 : prf (¬'(¬'Q) →' ((¬'(¬'(¬'(¬'Q)))) →'(¬'(¬'Q)))),
            apply prf.axk,
        have H2020 : prf ((¬' (¬' Q) →' Q) →' (¬' (¬' Q) →' Q)),
            apply reflex,
        have H220 : prf (¬' (¬' Q) →' (¬' (¬' Q) →' Q)),
            apply prf.cn _ ((¬'(¬'(¬'(¬'Q)))) →'(¬'(¬'Q))),
            exact H4220,
            exact H242,
        apply prf.mp (¬' (¬' Q) →' ¬' (¬' Q) →' Q),
        exact H220,
        apply deduction,
    end

theorem notnot (P : fml) : prf (P →' ¬'(¬'P)) :=
    begin
        have H31 : prf (¬'(¬'(¬'P)) →' ¬' P),
            apply yesyes,
        apply prf.mp (¬' (¬' (¬' P)) →' ¬' P),
        exact H31,
        apply prf.axn,
    end


/-
Copyright (c) 2022 Jujian Zhang. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Jujian Zhang
-/
import algebra.category.Module.basic
import ring_theory.tensor_product

/-!
# Change Of Rings

## Main definitions

* `category_theory.Module.restrict_scalars`: given rings `R, S` and a ring homomorphism `R ⟶ S`,
  then `restrict_scalars : Module S ⥤ Module R` is defined by `M ↦ M` where `M : S-module` is seen
  as `R-module` by `r • m := f r • m` and `S`-linear map `l : M ⟶ M'` is `R`-linear as well.

* `category_theory.Module.extend_scalars`: given **commutative** rings `R, S` and ring homomorphism
  `f : R ⟶ S`, then `extend_scalars : Module R ⥤ Module S` is defined by `M ↦ S ⨂ M` where the
  module structure is defined by `s • (s' ⊗ m) := (s * s') ⊗ m` and `R`-linear map `l : M ⟶ M'`
  is sent to `S`-linear map `s ⊗ m ↦ s ⊗ l m : S ⨂ M ⟶ S ⨂ M'`.

## List of notations
Let `R, S` be rings and `f : R →+* S`
* if `M` is an `R`-module, `s : S` and `m : M`, then `s ⊗ₜ[R, f] m` is the pure tensor
  `s ⊗ m : S ⊗[R, f] M`.
-/

namespace category_theory.Module

universes v u₁ u₂

namespace restrict_scalars

variables {R : Type u₁} {S : Type u₂} [ring R] [ring S] (f : R →+* S)
variable (M : Module.{v} S)

/-- Any `S`-module M is also an `R`-module via a ring homomorphism `f : R ⟶ S` by defining
    `r • m := f r • m` (`module.comp_hom`). This is called restriction of scalars. -/
def obj' : Module R :=
{ carrier := M,
  is_module := module.comp_hom M f }

/--
Given an `S`-linear map `g : M → M'` between `S`-modules, `g` is also `R`-linear between `M` and
`M'` by means of restriction of scalars.
-/
def map' {M M' : Module.{v} S} (g : M ⟶ M') :
  obj' f M ⟶ obj' f M' :=
{ map_smul' := λ r, g.map_smul (f r), ..g }

end restrict_scalars

/--
The restriction of scalars operation is functorial. For any `f : R →+* S` a ring homomorphism,
* an `S`-module `M` can be considered as `R`-module by `r • m = f r • m`
* an `S`-linear map is also `R`-linear
-/
def restrict_scalars {R : Type u₁} {S : Type u₂} [ring R] [ring S] (f : R →+* S) :
  Module.{v} S ⥤ Module.{v} R :=
{ obj := restrict_scalars.obj' f,
  map := λ _ _, restrict_scalars.map' f,
  map_id' := λ _, linear_map.ext $ λ m, rfl,
  map_comp' := λ _ _ _ g h, linear_map.ext $ λ m, rfl }

@[simp] lemma restrict_scalars.map_apply {R : Type u₁} {S : Type u₂} [ring R] [ring S] (f : R →+* S)
  {M M' : Module.{v} S} (g : M ⟶ M') (x) : (restrict_scalars f).map g x = g x := rfl

@[simp] lemma restrict_scalars.smul_def {R : Type u₁} {S : Type u₂} [ring R] [ring S] (f : R →+* S)
  {M : Module.{v} S} (r : R) (m : (restrict_scalars f).obj M) : r • m = (f r • m : M) := rfl

lemma restrict_scalars.smul_def' {R : Type u₁} {S : Type u₂} [ring R] [ring S] (f : R →+* S)
  {M : Module.{v} S} (r : R) (m : M) : (r • m : (restrict_scalars f).obj M) = (f r • m : M) := rfl

@[priority 100]
instance smul_comm_class_mk {R : Type u₁} {S : Type u₂} [ring R] [comm_ring S] (f : R →+* S)
  (M : Type v) [add_comm_group M] [module S M] :
  @smul_comm_class R S M ((restrict_scalars.obj' f (Module.mk M)).is_module.to_has_smul) _ :=
{ smul_comm := λ r s m, (by simp [←mul_smul, mul_comm] : f r • s • m = s • f r • m) }

namespace extend_scalars

open tensor_product

variables {R : Type u₁} {S : Type u₂} [comm_ring R] [comm_ring S] (f : R →+* S)

section unbundled

variables (M : Type v) [add_comm_monoid M] [module R M]
-- This notation is necessary because we need to reason about `s ⊗ₜ m` where `s : S` and `m : M`;
-- without this notation, one need to work with `s : (restrict_scalars f).obj ⟨S⟩`.
localized "notation s `⊗ₜ[` R `,` f `]` m := @tensor_product.tmul R _ _ _ _ _
  (module.comp_hom _ f) _ s m" in change_of_rings

end unbundled

open_locale change_of_rings

variables (M : Module.{v} R)

/--
Extension of scalars turn an `R`-module into `S`-module by M ↦ S ⨂ M
-/
def obj' : Module S :=
⟨tensor_product R ((restrict_scalars f).obj ⟨S⟩) M⟩

/--
Extension of scalars is a functor where an `R`-module `M` is sent to `S ⊗ M` and
`l : M1 ⟶ M2` is sent to `s ⊗ m ↦ s ⊗ l m`
-/
def map' {M1 M2 : Module.{v} R} (l : M1 ⟶ M2) : (obj' f M1) ⟶ (obj' f M2) :=
-- The "by apply" part makes this require 75% fewer heartbeats to process (#16371).
by apply (@linear_map.base_change R S M1 M2 _ _ ((algebra_map S _).comp f).to_algebra _ _ _ _ l)

lemma map'_id {M : Module.{v} R} : map' f (𝟙 M) = 𝟙 _ :=
linear_map.ext $ λ (x : obj' f M),
begin
  dsimp only [map', Module.id_apply],
  induction x using tensor_product.induction_on with _ _ m s ihx ihy,
  { simp only [map_zero], },
  { rw [linear_map.base_change_tmul, Module.id_apply], },
  { rw [map_add, ihx, ihy] },
end

lemma map'_comp {M₁ M₂ M₃ : Module.{v} R} (l₁₂ : M₁ ⟶ M₂) (l₂₃ : M₂ ⟶ M₃) :
  map' f (l₁₂ ≫ l₂₃) = map' f l₁₂ ≫ map' f l₂₃ :=
linear_map.ext $ λ (x : obj' f M₁),
begin
  dsimp only [map'],
  induction x using tensor_product.induction_on with _ _ x y ihx ihy,
  { refl, },
  { refl, },
  { simp only [map_add, ihx, ihy], },
end

end extend_scalars

/--
Extension of scalars is a functor where an `R`-module `M` is sent to `S ⊗ M` and
`l : M1 ⟶ M2` is sent to `s ⊗ m ↦ s ⊗ l m`
-/
def extend_scalars {R : Type u₁} {S : Type u₂} [comm_ring R] [comm_ring S] (f : R →+* S) :
  Module.{v} R ⥤ Module.{max v u₂} S :=
{ obj := λ M, extend_scalars.obj' f M,
  map := λ M1 M2 l, extend_scalars.map' f l,
  map_id' := λ _, extend_scalars.map'_id f,
  map_comp' := λ _ _ _, extend_scalars.map'_comp f }

namespace extend_scalars

open_locale change_of_rings

variables {R : Type u₁} {S : Type u₂} [comm_ring R] [comm_ring S] (f : R →+* S)

@[simp] protected lemma smul_tmul {M : Module.{v} R} (s s' : S) (m : M) :
  s • (s' ⊗ₜ[R, f] m : (extend_scalars f).obj M) = (s * s') ⊗ₜ[R, f] m := rfl

@[simp] lemma map_tmul {M M' : Module.{v} R} (g : M ⟶ M') (s : S) (m : M) :
  (extend_scalars f).map g (s ⊗ₜ[R, f] m) = s ⊗ₜ[R, f] g m := rfl

end extend_scalars

end category_theory.Module


import data.int.interval
import linear_algebra.free_module.finite.basic
import ring_theory.finiteness
import topology.continuous_function.algebra

import for_mathlib.nnrat
import for_mathlib.rational_cones

/-!

# Gordan's Lemma

-/

universe u
variables {Λ : Type u} [add_comm_group Λ]
variable {ι : Type*}

open_locale big_operators nnrat

def explicit_dual_set (l : ι → Λ) : submodule ℕ (Λ →+ ℤ) :=
{ carrier := {x | ∀ i, 0 ≤ x (l i)},
  zero_mem' := λ i, le_rfl,
  add_mem' := λ x y hx hy i, add_nonneg (hx i) (hy i),
  smul_mem' := λ n x hx i, nsmul_nonneg (hx i) n }

lemma mem_explicit_dual_set (l : ι → Λ) (x : Λ →+ ℤ) :
  x ∈ explicit_dual_set l ↔ ∀ i, 0 ≤ x (l i) := iff.rfl

def dual_finset (S : finset Λ) : submodule ℕ (Λ →+ ℤ) :=
explicit_dual_set (coe : (S : set Λ) → Λ)

lemma mem_dual_finset (S : finset Λ) (l : Λ →+ ℤ) :
  l ∈ dual_finset S ↔ ∀ x ∈ S, 0 ≤ l x :=
begin
  rw [dual_finset, mem_explicit_dual_set],
  simp
end

lemma dual_finset_antimono {S T : finset Λ} (hST : S ⊆ T) :
  dual_finset T ≤ dual_finset S :=
begin
  rintro φ hφ ⟨i, his : i ∈ S⟩,
  exact hφ ⟨i, hST his⟩,
end

lemma explicit_dual_set_eq_dual_finset [decidable_eq Λ] [fintype ι] (l : ι → Λ) :
  explicit_dual_set l = dual_finset (finset.image l finset.univ) :=
begin
  ext φ,
  split,
  { rintro hφ ⟨t, ht : t ∈ finset.image _ _⟩,
    rw finset.mem_image at ht,
    rcases ht with ⟨i, -, rfl⟩,
    exact hφ i },
  { rintro hφ i,
    refine hφ ⟨l i, (_ : l i ∈ finset.image _ _)⟩,
    rw finset.mem_image,
    exact ⟨i, finset.mem_univ _, rfl⟩ }
end

def intersect_halfspaces (l : ι → Λ →+ ℤ) : submodule ℕ Λ :=
{ carrier := {x | ∀ i, 0 ≤ l i x},
  zero_mem' := λ i, by simp only [add_monoid_hom.map_zero],
  add_mem' := λ x y hx hy i,
  begin
    simp only [add_monoid_hom.map_add],
    apply add_nonneg (hx i) (hy i)
  end,
  smul_mem' := λ c x hx i,
  begin
    simp only [nsmul_eq_mul, add_monoid_hom.map_nsmul],
    apply mul_nonneg (int.coe_zero_le c) (hx i),
  end }

lemma mem_intersect_halfspaces (l : ι → Λ →+ ℤ) (x : Λ) :
  x ∈ intersect_halfspaces l ↔ ∀ i, 0 ≤ l i x := iff.rfl

def intersect_halfspaces_set (s : set (Λ →+ ℤ)) : submodule ℕ Λ :=
intersect_halfspaces (coe : (s : set (Λ →+ ℤ)) → (Λ →+ ℤ))

lemma mem_intersect_halfspaces_set (S : set (Λ →+ ℤ)) (x : Λ) :
  x ∈ intersect_halfspaces_set S ↔ ∀ (f : Λ →+ ℤ), f ∈ S → 0 ≤ f x :=
begin
  rw [intersect_halfspaces_set, mem_intersect_halfspaces],
  simp
end

variables {α : Type*}

def to_rational_point : (α → ℤ) →ₗ[ℤ] (α → ℚ) :=
{ to_fun := λ f x, f x,
  map_add' := λ f g, by { ext1 x, simp only [int.cast_add, pi.add_apply] },
  map_smul' := λ m f, by { ext1 x, simp only [zsmul_eq_mul, pi.mul_apply, int.cast_mul, eq_int_cast,
    mul_eq_mul_right_iff, int.cast_eq_zero], left, refl } }

@[simp] lemma to_rational_point_apply (x : α → ℤ) (i : α) :
  to_rational_point x i = x i := rfl

lemma to_rational_point_injective : function.injective (to_rational_point : (α → ℤ) → (α → ℚ)) :=
begin
  intros x y h,
  ext i,
  rw function.funext_iff at h,
  specialize h i,
  simpa using h
end

def lattice_restrict (S : submodule ℚ≥0 (α → ℚ)) : submodule ℕ (α → ℤ) :=
{ carrier := to_rational_point ⁻¹' (S : set (α → ℚ)),
  zero_mem' :=
    by simp only [linear_map.map_zero, set.mem_preimage, set_like.mem_coe, submodule.zero_mem],
  add_mem' := λ a b (ha : to_rational_point a ∈ S) (hb : to_rational_point b ∈ S),
  begin
    change to_rational_point (a + b) ∈ S,
    simp only [linear_map.map_add],
    apply S.add_mem ha hb,
  end,
  smul_mem' := λ c x (hx : to_rational_point x ∈ S),
  begin
    change to_rational_point (c • x) ∈ S,
    rw linear_map.map_smul_of_tower,
    exact submodule.smul_of_tower_mem S c hx,
  end }

lemma mem_lattice_restrict (S : submodule (ℚ≥0) (α → ℚ)) (x : α → ℤ) :
  x ∈ lattice_restrict S ↔ to_rational_point x ∈ S :=
iff.rfl

def is_integer (x : ℚ) := ∃ (z : ℤ), x = z
def is_integer_point (x : α → ℚ) := ∀ a, is_integer (x a)

def floor_point (x : α → ℚ) : α → ℤ := λ i, ⌊x i⌋
lemma floor_point_eq_of_is_integer_point (x : α → ℚ) (hx : is_integer_point x) :
  (λ i, floor_point x i : α → ℚ) = x :=
begin
  ext1 i,
  obtain ⟨z, hz⟩ := hx i,
  simp [floor_point, hz],
end

lemma exists_scalings {ι : Type*} (s : finset ι) (v : ι → ℚ) :
  ∃ (n : ℕ), 0 < n ∧ ∀ i ∈ s, is_integer (n • v i) :=
begin
  classical,
  apply finset.induction_on s,
  { exact ⟨1, by norm_num, by simp⟩ },
  { rintro x s hx ⟨m, hm₁, hm₂⟩,
    refine ⟨m * (v x).denom, mul_pos hm₁ (v x).pos, _⟩,
    simp only [forall_eq_or_imp, nsmul_eq_mul, finset.mem_insert, nat.cast_mul],
    refine ⟨⟨m * (v x).num, _⟩, _⟩,
    { push_cast,
      rw mul_assoc,
      norm_cast,
      rw [mul_comm ((v x).denom : ℚ), rat.mul_denom_eq_num],
      norm_cast },
    intros y hy,
    obtain ⟨z, hz⟩ := hm₂ y hy,
    rw mul_right_comm,
    refine ⟨z * (v x).denom, _⟩,
    push_cast,
    rw ←hz,
    simp }
end

lemma point_exists_scaling {α : Type*} [fintype α] (x : α → ℚ) :
  ∃ (n : ℕ), 0 < n ∧ is_integer_point ((n) • x) :=
let ⟨m, hm₁, hm₂⟩ := exists_scalings finset.univ x in ⟨m, hm₁, λ a, by simpa using hm₂ a⟩

open_locale classical

noncomputable def scale_factor {α : Type*} [fintype α] (x : α → ℚ) : ℕ :=
nat.find (point_exists_scaling x)

lemma scale_factor_pos {α : Type*} [fintype α] (x : α → ℚ) : 0 < scale_factor x :=
(nat.find_spec (point_exists_scaling x)).1

lemma rat_scale_factor_ne_zero {α : Type*} [fintype α] (x : α → ℚ) :
  (scale_factor x : ℚ) ≠ 0 :=
begin
  norm_cast,
  apply (scale_factor_pos x).ne',
end

noncomputable def scale_up {α : Type*} [fintype α] (x : α → ℚ) : α → ℤ :=
floor_point (scale_factor x • x)

lemma scale_up_is {α : Type*} [fintype α] (x : α → ℚ) :
  (λ (i : α), ↑(scale_up x i)) = scale_factor x • x :=
floor_point_eq_of_is_integer_point _ (nat.find_spec (point_exists_scaling x)).2

lemma scale_up_coord {α : Type*} [fintype α] (x : α → ℚ) (a : α) :
  (scale_up x a : ℚ) = scale_factor x * x a :=
begin
  suffices : (scale_up x a : ℚ) = (scale_factor x • x) a,
  { simpa using this },
  rw ←scale_up_is,
end

lemma to_rational_point_scale_up {α : Type*} [fintype α] (x : α → ℚ) :
  to_rational_point (scale_up x) = scale_factor x • x :=
begin
  ext1 i,
  simp only [scale_up_coord, to_rational_point_apply, nsmul_eq_mul, pi.mul_apply, mul_eq_mul_right_iff],
  left, refl,
end

example {a b : ℤ} : (a : ℚ) = b → a = b :=
λ h, (rat.coe_int_inj a b).mp h

noncomputable def upgrade_functional {α : Type*} [fintype α] (f : (α → ℤ) →+ ℤ) : (α → ℚ) →ₗ[ℚ] ℚ :=
{ to_fun := λ g, (f (scale_up g) : ℚ) / scale_factor g,
  map_add' := λ g₁ g₂,
  begin
    field_simp [rat_scale_factor_ne_zero],
    norm_cast,
    suffices : f ((scale_factor g₁ * scale_factor g₂) • scale_up (g₁ + g₂)) =
      f (scale_factor (g₁ + g₂) • (scale_factor g₂ • scale_up g₁ + scale_factor g₁ • scale_up g₂)),
    { simp only [add_monoid_hom.map_nsmul, add_monoid_hom.map_add] at this,
      simp only [nsmul_eq_mul, mul_comm _ (f _)] at this,
      rw this,
      apply mul_comm },
    congr' 1,
    ext1 a,
    simp only [pi.add_apply, pi.smul_apply],
    simp only [nsmul_eq_mul, int.coe_nat_mul, mul_add],
    rw ←rat.coe_int_inj,
    push_cast,
    simp only [scale_up_coord, pi.add_apply],
    ring!,
  end,
  map_smul' := λ m x,
  begin
    simp only [algebra.id.smul_eq_mul],
    rw ←rat.num_div_denom m,
    field_simp [rat_scale_factor_ne_zero, m.pos.ne', -rat.num_div_denom],
    simp only [rat.num_div_denom],
    norm_cast,
    suffices :
      f ((m.denom * scale_factor x) • scale_up (m • x)) =
        f ((scale_factor (m • x) * m.num : ℤ) • scale_up x),
    { simp only [add_monoid_hom.map_zsmul, add_monoid_hom.map_nsmul] at this,
      simp only [int.coe_nat_mul],
      simp only [algebra.id.smul_eq_mul, rat.num_div_denom, nsmul_eq_mul, int.coe_nat_mul] at this,
      rw [mul_comm (f _), this, mul_comm _ m.num, mul_right_comm] },
    congr' 1,
    ext1 a,
    simp only [pi.smul_apply],
    simp only [algebra.id.smul_eq_mul, nsmul_eq_mul, int.coe_nat_mul],
    rw ←rat.coe_int_inj,
    push_cast,
    simp only [scale_up_coord, pi.smul_apply, algebra.id.smul_eq_mul, ←rat.mul_denom_eq_num],
    ring!,
  end }.

lemma upgrade_id {α : Type*} [fintype α] (f : (α → ℤ) →+ ℤ) (g : α → ℤ) :
  upgrade_functional f (to_rational_point g) = f g :=
begin
  dsimp [upgrade_functional, to_rational_point],
  rw div_eq_iff (rat_scale_factor_ne_zero _),
  norm_cast,
  rw [mul_comm, ←nsmul_eq_mul, ←add_monoid_hom.map_nsmul],
  congr' 1,
  ext a,
  simp only [nsmul_eq_mul, pi.mul_apply],
  rw ←rat.coe_int_inj,
  rw scale_up_coord,
  norm_cast,
end

section

lemma finitely_generated_iff_integrally_generated [fintype α] (C : submodule (ℚ≥0) (α → ℚ)) :
  C.fg ↔ ∃ S : finset (α → ℤ), submodule.span (ℚ≥0) (S.image to_rational_point : set (α → ℚ)) = C :=
begin
  split,
  { rintro ⟨S, rfl⟩,
    refine ⟨S.image scale_up, _⟩,
    apply le_antisymm,
    { rw submodule.span_le,
      intros x,
      simp only [to_rational_point_scale_up, and_imp, set.mem_image, finset.mem_coe,
        exists_exists_and_eq_and, set_like.mem_coe, exists_imp_distrib, finset.coe_image],
      rintro y hy rfl,
      have : y ∈ submodule.span (ℚ≥0) (S : set (α → ℚ)) := submodule.subset_span hy,
      have z := submodule.smul_mem _ (scale_factor y : ℚ≥0) this,
      convert z using 1,
      ext1 i,
      simp only [nsmul_eq_mul, pi.smul_apply],
      refl, },
    { rw submodule.span_le,
      intros x,
      simp only [set_like.mem_coe, finset.mem_coe, finset.coe_image, ←set.image_comp],
      intro hx,
      have : scale_factor x • x ∈ ((to_rational_point ∘ scale_up) '' (S : set (α → ℚ))),
      { refine ⟨_, hx, _⟩,
        simp only [nsmul_eq_mul, function.comp_app, to_rational_point_scale_up] },
      have : scale_factor x • x ∈
        submodule.span ℚ≥0 (to_rational_point ∘ scale_up '' (S : set (α → ℚ))) :=
        submodule.subset_span this,
      have hx₂ := submodule.smul_mem _ ((scale_factor x)⁻¹ : ℚ≥0) this,
      convert hx₂ using 1,
      ext1 i,
      simp only [nsmul_eq_mul, pi.mul_apply, pi.smul_apply],
      change _ = _ * (_ * _),
      simp,
      rw ←mul_assoc,
      convert (one_mul (x i)).symm,
      convert inv_mul_cancel _,
      apply rat_scale_factor_ne_zero } },
  { rintro ⟨S, rfl⟩,
    refine ⟨_, rfl⟩ }
end.

lemma finitely_generated_iff_integrally_generated_type {α : Type u} [fintype α]
  (C : submodule (ℚ≥0) (α → ℚ)) :
  C.fg ↔ ∃ (ι : Type u) (s : finset ι) (v : ι → α → ℤ) (hv : function.injective v),
    submodule.span (ℚ≥0) (s.image (λ i, to_rational_point (v i)) : set (α → ℚ)) = C :=
begin
  rw finitely_generated_iff_integrally_generated,
  split,
  { rintro ⟨S, rfl⟩,
    refine ⟨_, S, id, λ _ _ h, h, rfl⟩ },
  { rintro ⟨ι, s, v, _, rfl⟩,
    refine ⟨s.image v, _⟩,
    rw finset.image_image }
end

lemma bounded_lattice_thing [fintype α] {k : α → ℕ} (C : set (α → ℤ))
  (hC : ∀ (x : α → ℤ) i, x ∈ C → int.nat_abs (x i) ≤ k i) : C.finite :=
begin
  classical,
  let C' : finset (α → ℤ) :=
    (finset.univ.pi (λ i, finset.Ico (-(k i : ℤ)) (k i+1))).image (λ f a, f a (finset.mem_univ _)),
  have : C ⊆ C',
  { intros x hx,
    simp only [set.mem_image, finset.mem_univ, finset.mem_pi, forall_true_left, finset.mem_coe,
      finset.mem_Ico, finset.coe_image],
    refine ⟨λ a _, x a, λ a, _, _⟩,
    { have : abs (x a) ≤ k a,
      { rw int.abs_eq_nat_abs,
        exact_mod_cast hC x a hx },
      rw abs_le at this,
      refine ⟨this.1, _⟩,
      rw int.lt_add_one_iff,
      apply this.2 },
    refl },
  apply set.finite.subset _ this,
  exact finset.finite_to_set C',
end

lemma finset.sum_nat_abs_le {ι : Type*} (s : finset ι) (f : ι → ℤ) :
  (∑ i in s, f i).nat_abs ≤ ∑ i in s, (f i).nat_abs :=
finset.le_sum_of_subadditive _ rfl int.nat_abs_add_le _ _

lemma floor_add_floor_le {α : Type*} [linear_ordered_ring α] [floor_ring α] (x y : α) :
  ⌊x⌋ + ⌊y⌋ ≤ ⌊x + y⌋ :=
begin
  rw [int.le_floor, int.cast_add],
  apply add_le_add (int.floor_le x) (int.floor_le y),
end

lemma finset.floor_le {α : Type*} [linear_ordered_ring α] [floor_ring α] {ι : Type*} (s : finset ι)
  (f : ι → α) :
  ∑ i in s, ⌊f i⌋ ≤ ⌊∑ i in s, f i⌋ :=
begin
  apply finset.induction_on s,
  { simp },
  { intros i s hi ih,
    rw [finset.sum_insert hi, finset.sum_insert hi],
    apply le_trans (add_le_add_left ih _) (floor_add_floor_le _ _) }
end

lemma ceil_add_le {α : Type*} [linear_ordered_ring α] [floor_ring α] (x y : α) :
  ⌈x + y⌉ ≤ ⌈x⌉ + ⌈y⌉ :=
begin
  rw [int.ceil_le, int.cast_add],
  apply add_le_add (int.le_ceil x) (int.le_ceil y),
end

lemma finset.le_ceil {α : Type*} [linear_ordered_ring α] [floor_ring α] {ι : Type*} (s : finset ι)
  (f : ι → α) :
  ⌈∑ i in s, f i⌉ ≤ ∑ i in s, ⌈f i⌉ :=
finset.le_sum_of_subadditive _ (by simp) ceil_add_le _ _

lemma nat_abs_lt_nat_abs_of_nonneg_of_lt {a b : ℤ} (w₁ : 0 ≤ a) (w₂ : a < b) :
  a.nat_abs < b.nat_abs :=
begin
  lift b to ℕ using le_trans w₁ (le_of_lt w₂),
  lift a to ℕ using w₁,
  simpa using w₂,
end

lemma int.coe_sum {α : Type*} (f : α → ℕ) (s : finset α) :
  ∑ (x : α) in s, (f x : ℤ) = (↑∑ i in s, f i : ℤ) :=
begin
  apply finset.induction_on s,
  { simp },
  { intros i t hi ih,
    simp only [finset.sum_insert hi, ih],
    simp }
end

lemma finset.mem_span_iff {R M : Type*} [ring R] [add_comm_monoid M] [module R M] (S : finset M)
  (x : M) :
  x ∈ submodule.span R (S : set M) ↔ ∃ (w : M → R), ∑ i in S, w i • i = x :=
begin
  exact mem_span_finset
end

set_option pp.proofs true

lemma missing [fintype α] (w : α → ℤ) (n : ℕ) :
  to_rational_point (n • w) = (n : ℚ≥0) • to_rational_point w :=
begin
  simp only [nsmul_eq_mul],
  induction n,
  { simp },
  { simp [add_smul, ←n_ih, add_mul],  },
end

lemma my_result [fintype α] (C : submodule (ℚ≥0) (α → ℚ)) (hC : C.fg) :
  (lattice_restrict C).fg :=
begin
  rw finitely_generated_iff_integrally_generated_type at hC,
  rcases hC with ⟨ι, s, w, hw, rfl⟩,
  let B := {x : α → ℤ |
                ∃ w' : ι → ℚ≥0, (∀ (i ∈ s), w' i < 1) ∧
                ∑ i in s, w' i • to_rational_point (w i) = to_rational_point x},
  let k : α → ℕ := λ a, ∑ i in s, int.nat_abs (w i a),
  have : ∀ (x : α → ℤ) a, x ∈ B → int.nat_abs (x a) ≤ k a,
  { rintro x a ⟨w', hw', hw''⟩,
    have hw''' : (∑ (i : ι) in s, w' i • to_rational_point (w i)) a = to_rational_point x a,
    { rw hw'' },
    simp only [finset.sum_apply, algebra.id.smul_eq_mul, to_rational_point_apply,
      pi.smul_apply] at hw''',
    change ∑ (c : ι) in s, (w' c : ℚ) * (w c a) = x a at hw''',
    clear hw'',
    have : abs (∑ (c : ι) in s, (w' c : ℚ) * w c a) ≤ ∑ (c : ι) in s, abs (w c a),
    { apply le_trans (finset.abs_sum_le_sum_abs _ _) _,
      apply finset.sum_le_sum,
      intros i hi,
      rw abs_mul,
      apply mul_le_of_le_one_left,
      exact abs_nonneg (w i a),
      rw abs_le,
      refine ⟨_, (hw' i hi).le⟩,
      apply le_trans (show (-1 : ℚ) ≤ 0, by norm_num) (w' i).2 },
    rw hw''' at this,
    norm_cast at this,
    simp only [int.abs_eq_nat_abs] at this,
    rw int.coe_sum at this,
    norm_cast at this,
    apply this },
  let B' := set.finite.to_finset (bounded_lattice_thing _ this),
  refine ⟨B' ∪ s.image w, _⟩,
  apply le_antisymm,
  { rw submodule.span_le,
    simp only [set.union_subset_iff, finset.coe_union, set.finite.coe_to_finset],
    split,
    { rintro x ⟨w', hw', hw''⟩,
      change to_rational_point x ∈ _,
      rw ←hw'',
      simp only [set_like.mem_coe],
      refine submodule.sum_smul_mem _ _ _,
      intros i hi,
      apply submodule.subset_span,
      simp only [set.mem_image, finset.mem_coe, finset.coe_image],
      refine ⟨_, hi, rfl⟩ },
    { simp only [set.image_subset_iff, finset.coe_image],
      intros x hx,
      change to_rational_point (w x) ∈ _,
      apply submodule.subset_span,
      refine ⟨_, hx, rfl⟩ } },
  { rintro x (hx : to_rational_point _ ∈ _),
    simp only [set_like.mem_coe, mem_span_finset] at hx,
    rcases hx with ⟨f, hf⟩,
    rw finset.sum_image at hf,
    { simp only [finset.coe_union, set.finite.coe_to_finset, finset.coe_image],
      let f' : ι → ℚ≥0 := λ i, f (to_rational_point (w i)),
      let ns : ι → ℕ := λ i, (⌊(f' i : ℚ)⌋).nat_abs,
      let g' : ι → ℚ≥0 := λ i, f' i - ns i,
      have ns' : ∀ i, (ns i : ℤ) = ⌊(f' i : ℚ)⌋,
      { intro i,
        change (int.nat_abs _ : ℤ) = _,
        rw [←int.abs_eq_nat_abs, abs_of_nonneg],
        rw [int.floor_nonneg],
        apply (f' i).2 },
      have hg' : ∀ i, (g' i : ℚ) = f' i - ns i,
      { intros i,
        change max _ _ = _,
        simp only [nnrat.coe_nat_cast],
        rw max_eq_left,
        rw sub_nonneg,
        change (int.nat_abs _ : ℚ) ≤ _,
        suffices : ((int.nat_abs ⌊(f' i : ℚ)⌋ : ℤ) : ℚ) ≤ f' i,
        { simpa using this },
        rw ns',
        apply int.floor_le },
      change ∑ x in s, f' x • to_rational_point (w x) = to_rational_point x at hf,
      -- have :  ≤ ↑(f' i) - ↑(ns i)
      have : ∀ i, (ns i : ℚ≥0) + g' i = f' i,
      { intro i,
        apply nnrat.coe_injective,
        rw [nnrat.coe_add, hg'],
        simp },
      simp_rw [←this, add_smul, finset.sum_add_distrib] at hf,
      let x_floors := ∑ (x : ι) in s, ns x • w x,
      have : x - x_floors ∈ B,
      { refine ⟨g', _, _⟩,
        { intros i hi,
          rw ←nnrat.coe_lt_coe,
          rw hg',
          simp only [nnrat.coe_one],
          suffices : (f' i : ℚ) - ((ns i : ℤ) : ℚ) < 1,
          { simpa using this },
          rw ns',
          apply int.fract_lt_one },
        rw linear_map.map_sub,
        rw linear_map.map_sum,
        rw eq_sub_iff_add_eq',
        rw ←hf,
        congr' 1,
        apply finset.sum_congr rfl,
        intros i hi,
        apply missing },
      { have : x = x - x_floors + x_floors,
        { simp },
        rw this,
        refine submodule.add_mem _ _ _,
        { apply submodule.subset_span,
          left,
          apply ‹x - x_floors ∈ B› },
        apply submodule.sum_smul_mem _ ns _,
        intros i hi,
        apply submodule.subset_span,
        right,
        refine ⟨_, hi, rfl⟩ } },
    intros x hx y hy t,
    apply hw,
    apply to_rational_point_injective t, }
end

end

-- instance {α : Type*} [fintype α] : finite_dimensional ℚ (α → ℚ) :=
-- @is_noetherian_pi _ _ _ _ _ _ _ (λ i, infer_instance)

lemma finset_Gordan_aux_pi {α : Type*} [fintype α] (S : finset ((α → ℤ) →+ ℤ)) :
  (intersect_halfspaces_set (S : set ((α → ℤ) →+ ℤ))).fg  :=
begin
  classical,
  let S' : finset ((α → ℚ) →ₗ[ℚ] ℚ) := S.image upgrade_functional,
  suffices : lattice_restrict (set_down_one (S' : set ((α → ℚ) →ₗ[ℚ] ℚ))) =
              intersect_halfspaces_set (S : set ((α → ℤ) →+ ℤ)),
  { rw ←this,
    apply my_result,
    rw ←fg_iff_is_polyhedral_cone,
    rw is_polyhedral_cone_iff_finset,
    refine ⟨_, rfl⟩ },
  ext x,
  simp [mem_lattice_restrict, mem_intersect_halfspaces_set, upgrade_id],
end

/-- A finset version of Gordan's Lemma. -/
lemma finset_Gordan_aux [module.finite ℤ Λ] [module.free ℤ Λ] (S : finset (Λ →+ ℤ)) :
  (intersect_halfspaces_set (S : set (Λ →+ ℤ))).fg :=
begin
  classical,
  have e := linear_equiv.restrict_scalars ℕ (module.free.choose_basis ℤ Λ).equiv_fun,
    -- deliberately forget the data here, it makes the simp at the end easier
  let e' : (Λ →+ ℤ) → (module.free.choose_basis_index ℤ Λ → ℤ) →+ ℤ :=
    λ f, f.comp e.symm.to_linear_map.to_add_monoid_hom,
  let L := (intersect_halfspaces_set ↑(S.image e')).map
    (e.symm : (module.free.choose_basis_index ℤ Λ → ℤ) →ₗ[ℕ] Λ),
  have : L.fg := submodule.fg.map _ (finset_Gordan_aux_pi (S.image e')),
  suffices : L = intersect_halfspaces_set (S : set (Λ →+ ℤ)),
  { rwa ←this },
  ext x,
  simp [mem_intersect_halfspaces_set, linear_equiv.symm_apply_eq],
end

/-- A finset version of Gordan's Lemma. -/
lemma finset_Gordan [module.finite ℤ Λ] [module.free ℤ Λ] (S : finset Λ) :
  (dual_finset S).fg :=
begin
  classical,
  let S' : finset ((Λ →+ ℤ) →+ ℤ) := S.image add_monoid_hom.eval,
  letI := module.free.add_monoid_hom Λ ℤ, --RB: not sure why this is needed
  have := finset_Gordan_aux S',
  convert this using 1,
  ext x,
  simp [mem_dual_finset, mem_intersect_halfspaces_set],
end

/-- A fintype version of Gordan's Lemma. -/
lemma explicit_gordan [module.finite ℤ Λ] [module.free ℤ Λ] [fintype ι] (l : ι → Λ) :
  (explicit_dual_set l).fg :=
begin
  classical,
  rw explicit_dual_set_eq_dual_finset,
  apply finset_Gordan,
end


/-
Copyright (c) 2020 Aaron Anderson, Jalex Stark. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Aaron Anderson, Jalex Stark.
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.matrix.char_p
import Mathlib.linear_algebra.char_poly.basic
import Mathlib.linear_algebra.matrix
import Mathlib.ring_theory.polynomial.basic
import Mathlib.algebra.polynomial.big_operators
import Mathlib.group_theory.perm.cycles
import Mathlib.field_theory.finite.basic
import Mathlib.PostPort

universes u v u_1

namespace Mathlib

/-!
# Characteristic polynomials

We give methods for computing coefficients of the characteristic polynomial.

## Main definitions

- `char_poly_degree_eq_dim` proves that the degree of the characteristic polynomial
  over a nonzero ring is the dimension of the matrix
- `det_eq_sign_char_poly_coeff` proves that the determinant is the constant term of the characteristic
  polynomial, up to sign.
- `trace_eq_neg_char_poly_coeff` proves that the trace is the negative of the (d-1)th coefficient of the
  characteristic polynomial, where d is the dimension of the matrix.
  For a nonzero ring, this is the second-highest coefficient.

-/

theorem char_matrix_apply_nat_degree {R : Type u} [comm_ring R] {n : Type v} [DecidableEq n] [fintype n] {M : matrix n n R} [nontrivial R] (i : n) (j : n) : polynomial.nat_degree (char_matrix M i j) = ite (i = j) 1 0 := sorry

theorem char_matrix_apply_nat_degree_le {R : Type u} [comm_ring R] {n : Type v} [DecidableEq n] [fintype n] {M : matrix n n R} (i : n) (j : n) : polynomial.nat_degree (char_matrix M i j) ≤ ite (i = j) 1 0 := sorry

theorem char_poly_sub_diagonal_degree_lt {R : Type u} [comm_ring R] {n : Type v} [DecidableEq n] [fintype n] (M : matrix n n R) : polynomial.degree (char_poly M - finset.prod finset.univ fun (i : n) => polynomial.X - coe_fn polynomial.C (M i i)) <
  ↑(fintype.card n - 1) := sorry

theorem char_poly_coeff_eq_prod_coeff_of_le {R : Type u} [comm_ring R] {n : Type v} [DecidableEq n] [fintype n] (M : matrix n n R) {k : ℕ} (h : fintype.card n - 1 ≤ k) : polynomial.coeff (char_poly M) k =
  polynomial.coeff (finset.prod finset.univ fun (i : n) => polynomial.X - coe_fn polynomial.C (M i i)) k := sorry

theorem det_of_card_zero {R : Type u} [comm_ring R] {n : Type v} [DecidableEq n] [fintype n] (h : fintype.card n = 0) (M : matrix n n R) : matrix.det M = 1 := sorry

theorem char_poly_degree_eq_dim {R : Type u} [comm_ring R] {n : Type v} [DecidableEq n] [fintype n] [nontrivial R] (M : matrix n n R) : polynomial.degree (char_poly M) = ↑(fintype.card n) := sorry

theorem char_poly_nat_degree_eq_dim {R : Type u} [comm_ring R] {n : Type v} [DecidableEq n] [fintype n] [nontrivial R] (M : matrix n n R) : polynomial.nat_degree (char_poly M) = fintype.card n :=
  polynomial.nat_degree_eq_of_degree_eq_some (char_poly_degree_eq_dim M)

theorem char_poly_monic {R : Type u} [comm_ring R] {n : Type v} [DecidableEq n] [fintype n] (M : matrix n n R) : polynomial.monic (char_poly M) := sorry

theorem trace_eq_neg_char_poly_coeff {R : Type u} [comm_ring R] {n : Type v} [DecidableEq n] [fintype n] [Nonempty n] (M : matrix n n R) : coe_fn (matrix.trace n R R) M = -polynomial.coeff (char_poly M) (fintype.card n - 1) := sorry

-- I feel like this should use polynomial.alg_hom_eval₂_algebra_map

theorem mat_poly_equiv_eval {R : Type u} [comm_ring R] {n : Type v} [DecidableEq n] [fintype n] (M : matrix n n (polynomial R)) (r : R) (i : n) (j : n) : polynomial.eval (coe_fn (matrix.scalar n) r) (coe_fn mat_poly_equiv M) i j = polynomial.eval r (M i j) := sorry

theorem eval_det {R : Type u} [comm_ring R] {n : Type v} [DecidableEq n] [fintype n] (M : matrix n n (polynomial R)) (r : R) : polynomial.eval r (matrix.det M) = matrix.det (polynomial.eval (coe_fn (matrix.scalar n) r) (coe_fn mat_poly_equiv M)) := sorry

theorem det_eq_sign_char_poly_coeff {R : Type u} [comm_ring R] {n : Type v} [DecidableEq n] [fintype n] (M : matrix n n R) : matrix.det M = (-1) ^ fintype.card n * polynomial.coeff (char_poly M) 0 := sorry

@[simp] theorem finite_field.char_poly_pow_card {n : Type v} [DecidableEq n] [fintype n] {K : Type u_1} [field K] [fintype K] (M : matrix n n K) : char_poly (M ^ fintype.card K) = char_poly M := sorry

@[simp] theorem zmod.char_poly_pow_card {n : Type v} [DecidableEq n] [fintype n] {p : ℕ} [fact (nat.prime p)] (M : matrix n n (zmod p)) : char_poly (M ^ p) = char_poly M :=
  eq.mp (Eq._oldrec (Eq.refl (char_poly (M ^ fintype.card (zmod p)) = char_poly M)) (zmod.card p))
    (finite_field.char_poly_pow_card M)

theorem finite_field.trace_pow_card {n : Type v} [DecidableEq n] [fintype n] {K : Type u_1} [field K] [fintype K] [Nonempty n] (M : matrix n n K) : coe_fn (matrix.trace n K K) (M ^ fintype.card K) = coe_fn (matrix.trace n K K) M ^ fintype.card K := sorry

theorem zmod.trace_pow_card {n : Type v} [DecidableEq n] [fintype n] {p : ℕ} [fact (nat.prime p)] [Nonempty n] (M : matrix n n (zmod p)) : coe_fn (matrix.trace n (zmod p) (zmod p)) (M ^ p) = coe_fn (matrix.trace n (zmod p) (zmod p)) M ^ p := sorry

namespace matrix

theorem is_integral {R : Type u} [comm_ring R] {n : Type v} [DecidableEq n] [fintype n] (M : matrix n n R) : is_integral R M :=
  Exists.intro (char_poly M) { left := char_poly_monic M, right := aeval_self_char_poly M }

theorem min_poly_dvd_char_poly {n : Type v} [DecidableEq n] [fintype n] {K : Type u_1} [field K] (M : matrix n n K) : minpoly K M ∣ char_poly M :=
  minpoly.dvd K M (aeval_self_char_poly M)


import data.fin order.basic tactic.split_ifs
import category_theory.base

open category_theory

def simplex_category := ℕ

local notation `Δ` := simplex_category
local notation `[`n`]` := fin (n + 1)

instance : has_coe_to_sort (Δ) :=
{S := Type, coe := λ n, [n]}

/- Nota bene: We will abuse the notation (n : Δ)
   to denote what a mathematician would call [n].
-/

/- This defines the set of monotone maps. The best solution
   is probably to rename `monotone` to `is_monotone,
   so that we can use `monotone` instead of the following
   `order_preserving_map`.
-/
def order_preserving_map (m n : Δ) :=
{f : m → n // monotone f}

instance {m n : Δ} : has_coe_to_fun (order_preserving_map m n) :=
{ F := λ _, m → n, coe := λ f, f.val }

instance : category Δ :=
{ hom := order_preserving_map, --λ m n : Δ, {f : m → n // monotone f},
  id := λ X, ⟨id, monotone_id⟩,
  comp := λ _ _ _ f g, ⟨g.val ∘ f.val, g.2.comp f.2⟩ }

namespace simplex_category

protected lemma hom_eq2 {m n : Δ} {f g : m ⟶ n} : f = g ↔ f.val = g.val := by cases f; cases g; simp

variables {n : Δ}

/-- The i-th face map from [n] to [n+1] -/
def δ (i : [n+1]) : n ⟶ ((n + 1) : ℕ) :=
⟨λ a, if h : i.val ≤ a.val then a.succ else a.cast_succ,
  begin
    intros a b H,
    dsimp,
    split_ifs with ha hb,
    { show a.succ.val ≤ b.succ.val,
      simpa using nat.succ_le_succ H },
    { exfalso,
      exact hb (nat.le_trans ha H) },
    { show a.val ≤ b.succ.val,
      simpa using nat.le_trans H (nat.le_succ b) },
    { exact H }
  end⟩

/-- The i-th degeneracy map from [n+1] to [n] -/
def σ (i : [n]) : @has_hom.hom Δ _ ((n + 1) : ℕ) n :=
⟨λ a, if h : a.val ≤ i.val
    then ⟨a.val, lt_of_le_of_lt h i.is_lt⟩
    else ⟨a.val.pred,
      (nat.sub_lt_right_iff_lt_add (lt_of_le_of_lt i.val.zero_le (not_le.mp h))).mpr a.is_lt⟩,
  begin
    intros a b H,
    dsimp,
    split_ifs with ha hb,
    { exact H },
    { simp at hb,
      have hb' : i.val ≤ nat.pred b.val :=
      begin
        rw ←nat.pred_succ i.val,
        exact nat.pred_le_pred hb
      end,
      exact nat.le_trans ha hb' },
    { exfalso,
      exact ha (nat.le_trans H h) },
    { exact nat.pred_le_pred H }
  end⟩

lemma simplicial_identity₁ {i j : [n+1]} (H : i ≤ j) : δ i ≫ δ j.succ = δ j ≫ δ i.cast_succ :=
begin
  rw simplex_category.hom_eq2,
  dsimp [category_struct.comp, function.comp, δ],
  funext a,
  by_cases hja : (j.val ≤ a.val),
  { have hja' : ((fin.succ j).val ≤ (fin.succ a).val) := by simp; exact nat.succ_le_succ hja,
    have hia : ((fin.cast_succ i).val ≤ (fin.succ a).val) := by simp; exact nat.le_trans H (nat.le_trans hja (nat.le_succ a.val)),
    erw [dif_pos hja, dif_pos (nat.le_trans H hja), dif_pos hja', dif_pos hia] },
  { rw [dif_neg hja],
    by_cases hia : (i.val ≤ a.val),
    { have hia' : ((fin.cast_succ i).val ≤ (fin.cast_succ a).val) := hia,
      have hja' : ¬(j.succ.val ≤ a.succ.val) := by simp at *; exact nat.succ_le_succ hja,
      erw [dif_pos hia, dif_pos hia', dif_neg hja'],
      apply fin.eq_of_veq,
      simp },
    { have hja' : ¬(j.succ.val ≤ a.cast_succ.val) := by simp at *; exact nat.le_trans hja (nat.le_succ j.val),
      have hia' : ¬((fin.cast_succ i).val ≤ (fin.cast_succ a).val) := by unfold fin.cast_succ; exact hia,
      erw [dif_neg hia, dif_neg hja', dif_neg hia'] } }
end

-- lemma simplicial_identity₂ {i : [n+1]} {j : [n]} (H : i ≤ j.raise) : δ i.raise ≫ σ j.succ = σ j ≫ δ i := sorry
-- lemma simplicial_identity₃
-- lemma simplicial_identity₄
-- lemma simplicial_identity₅

end simplex_category