/-
Copyright (c) 2018 Simon Hudon. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Simon Hudon
-/
import control.functor
import tactic.ext

/-!
# Traversable type class

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

Type classes for traversing collections. The concepts and laws are taken from
<http://hackage.haskell.org/package/base-4.11.1.0/docs/Data-Traversable.html>

Traversable collections are a generalization of functors. Whereas
functors (such as `list`) allow us to apply a function to every
element, it does not allow functions which external effects encoded in
a monad. Consider for instance a functor `invite : email → io response`
that takes an email address, sends an email and waits for a
response. If we have a list `guests : list email`, using calling
`invite` using `map` gives us the following: `map invite guests : list
(io response)`.  It is not what we need. We need something of type `io
(list response)`. Instead of using `map`, we can use `traverse` to
send all the invites: `traverse invite guests : io (list response)`.
`traverse` applies `invite` to every element of `guests` and combines
all the resulting effects. In the example, the effect is encoded in the
monad `io` but any applicative functor is accepted by `traverse`.

For more on how to use traversable, consider the Haskell tutorial:
<https://en.wikibooks.org/wiki/Haskell/Traversable>

## Main definitions
  * `traversable` type class - exposes the `traverse` function
  * `sequence` - based on `traverse`,
    turns a collection of effects into an effect returning a collection
  * `is_lawful_traversable` - laws for a traversable functor
  * `applicative_transformation` - the notion of a natural transformation for applicative functors

## Tags

traversable iterator functor applicative

## References

 * "Applicative Programming with Effects", by Conor McBride and Ross Paterson,
   Journal of Functional Programming 18:1 (2008) 1-13, online at
   <http://www.soi.city.ac.uk/~ross/papers/Applicative.html>
 * "The Essence of the Iterator Pattern", by Jeremy Gibbons and Bruno Oliveira,
   in Mathematically-Structured Functional Programming, 2006, online at
   <http://web.comlab.ox.ac.uk/oucl/work/jeremy.gibbons/publications/#iterator>
 * "An Investigation of the Laws of Traversals", by Mauro Jaskelioff and Ondrej Rypacek,
   in Mathematically-Structured Functional Programming, 2012,
   online at <http://arxiv.org/pdf/1202.2919>
-/

open function (hiding comp)

universes u v w

section applicative_transformation

variables (F : Type u → Type v) [applicative F] [is_lawful_applicative F]
variables (G : Type u → Type w) [applicative G] [is_lawful_applicative G]

/-- A transformation between applicative functors.  It is a natural
transformation such that `app` preserves the `has_pure.pure` and
`functor.map` (`<*>`) operations. See
`applicative_transformation.preserves_map` for naturality. -/
structure applicative_transformation : Type (max (u+1) v w) :=
(app : Π α : Type u, F α → G α)
(preserves_pure' : ∀ {α : Type u} (x : α), app _ (pure x) = pure x)
(preserves_seq' : ∀ {α β : Type u} (x : F (α → β)) (y : F α), app _ (x <*> y) = app _ x <*> app _ y)

end applicative_transformation

namespace applicative_transformation

variables (F : Type u → Type v) [applicative F] [is_lawful_applicative F]
variables (G : Type u → Type w) [applicative G] [is_lawful_applicative G]

instance : has_coe_to_fun (applicative_transformation F G) (λ _, Π {α}, F α → G α) :=
⟨applicative_transformation.app⟩

variables {F G}

@[simp]
lemma app_eq_coe (η : applicative_transformation F G) : η.app = η := rfl

@[simp]
lemma coe_mk (f : Π (α : Type u), F α → G α) (pp ps) :
  ⇑(applicative_transformation.mk f pp ps) = f := rfl

protected
lemma congr_fun (η η' : applicative_transformation F G) (h : η = η') {α : Type u} (x : F α) :
  η x = η' x :=
congr_arg (λ η'' : applicative_transformation F G, η'' x) h

protected
lemma congr_arg (η : applicative_transformation F G) {α : Type u} {x y : F α} (h : x = y) :
  η x = η y :=
congr_arg (λ z : F α, η z) h

lemma coe_inj ⦃η η' : applicative_transformation F G⦄ (h : (η : Π α, F α → G α) = η') : η = η' :=
by { cases η, cases η', congr, exact h }

@[ext]
lemma ext ⦃η η' : applicative_transformation F G⦄ (h : ∀ (α : Type u) (x : F α), η x = η' x) :
  η = η' :=
by { apply coe_inj, ext1 α, exact funext (h α) }

lemma ext_iff {η η' : applicative_transformation F G} :
  η = η' ↔ ∀ (α : Type u) (x : F α), η x = η' x :=
⟨λ h α x, h ▸ rfl, λ h, ext h⟩

section preserves
variables (η : applicative_transformation F G)

@[functor_norm]
lemma preserves_pure {α} : ∀ (x : α), η (pure x) = pure x := η.preserves_pure'

@[functor_norm]
lemma preserves_seq {α β : Type u} : ∀ (x : F (α → β)) (y : F α), η (x <*> y) = η x <*> η y :=
η.preserves_seq'

@[functor_norm]
lemma preserves_map {α β} (x : α → β) (y : F α) : η (x <$> y) = x <$> η y :=
by rw [← pure_seq_eq_map, η.preserves_seq]; simp with functor_norm

lemma preserves_map' {α β} (x : α → β) : @η _ ∘ functor.map x = functor.map x ∘ @η _ :=
by { ext y, exact preserves_map η x y }

end preserves

/-- The identity applicative transformation from an applicative functor to itself. -/
def id_transformation : applicative_transformation F F :=
{ app := λ α, id,
  preserves_pure' := by simp,
  preserves_seq' := λ α β x y, by simp }

instance : inhabited (applicative_transformation F F) := ⟨id_transformation⟩

universes s t
variables {H : Type u → Type s} [applicative H] [is_lawful_applicative H]

/-- The composition of applicative transformations. -/
def comp (η' : applicative_transformation G H) (η : applicative_transformation F G) :
  applicative_transformation F H :=
{ app := λ α x, η' (η x),
  preserves_pure' := λ α x, by simp with functor_norm,
  preserves_seq' := λ α β x y, by simp with functor_norm }

@[simp]
lemma comp_apply (η' : applicative_transformation G H) (η : applicative_transformation F G)
  {α : Type u} (x : F α) :
  η'.comp η x = η' (η x) := rfl

lemma comp_assoc {I : Type u → Type t} [applicative I] [is_lawful_applicative I]
  (η'' : applicative_transformation H I)
  (η' : applicative_transformation G H)
  (η : applicative_transformation F G) :
  (η''.comp η').comp η = η''.comp (η'.comp η) := rfl

@[simp]
lemma comp_id (η : applicative_transformation F G) : η.comp id_transformation = η :=
ext $ λ α x, rfl

@[simp]

end applicative_transformation

open applicative_transformation

/-- A traversable functor is a functor along with a way to commute
with all applicative functors (see `sequence`).  For example, if `t`
is the traversable functor `list` and `m` is the applicative functor
`io`, then given a function `f : α → io β`, the function `functor.map f` is
`list α → list (io β)`, but `traverse f` is `list α → io (list β)`. -/
class traversable (t : Type u → Type u) extends functor t :=
(traverse : Π {m : Type u → Type u} [applicative m] {α β},
   (α → m β) → t α → m (t β))

open functor

export traversable (traverse)

section functions

variables {t : Type u → Type u}
variables {m : Type u → Type v} [applicative m]
variables {α β : Type u}

variables {f : Type u → Type u} [applicative f]

/-- A traversable functor commutes with all applicative functors. -/
def sequence [traversable t] : t (f α) → f (t α) := traverse id

end functions

/-- A traversable functor is lawful if its `traverse` satisfies a
number of additional properties.  It must send `id.mk` to `id.mk`,
send the composition of applicative functors to the composition of the
`traverse` of each, send each function `f` to `λ x, f <$> x`, and
satisfy a naturality condition with respect to applicative
transformations. -/
class is_lawful_traversable (t : Type u → Type u) [traversable t]
  extends is_lawful_functor t : Type (u+1) :=
(id_traverse : ∀ {α} (x : t α), traverse id.mk x = x )
(comp_traverse : ∀ {F G} [applicative F] [applicative G]
    [is_lawful_applicative F] [is_lawful_applicative G]
    {α β γ} (f : β → F γ) (g : α → G β) (x : t α),
  traverse (comp.mk ∘ map f ∘ g) x =
  comp.mk (map (traverse f) (traverse g x)))
(traverse_eq_map_id : ∀ {α β} (f : α → β) (x : t α),
  traverse (id.mk ∘ f) x = id.mk (f <$> x))
(naturality : ∀ {F G} [applicative F] [applicative G]
    [is_lawful_applicative F] [is_lawful_applicative G]
    (η : applicative_transformation F G) {α β} (f : α → F β) (x : t α),
  η (traverse f x) = traverse (@η _ ∘ f) x)

instance : traversable id := ⟨λ _ _ _ _, id⟩
instance : is_lawful_traversable id := by refine {..}; intros; refl

section

variables {F : Type u → Type v} [applicative F]

instance : traversable option := ⟨@option.traverse⟩

instance : traversable list := ⟨@list.traverse⟩

end

namespace sum

variables {σ : Type u}
variables {F : Type u → Type u}
variables [applicative F]

/-- Defines a `traverse` function on the second component of a sum type.
This is used to give a `traversable` instance for the functor `σ ⊕ -`. -/
protected def traverse {α β} (f : α → F β) : σ ⊕ α → F (σ ⊕ β)
| (sum.inl x) := pure (sum.inl x)
| (sum.inr x) := sum.inr <$> f x

end sum

instance {σ : Type u} : traversable.{u} (sum σ) := ⟨@sum.traverse _⟩


-- Copyright © 2019 François G. Dorais. All rights reserved.
-- Released under Apache 2.0 license as described in the file LICENSE.

import .basic
import .substitution

namespace universal
variables {τ : Type} {σ : Type*} {sig : signature τ σ}

structure homomorphism (alg₁ : algebra sig) (alg₂ : algebra sig) :=
(map {} (t) : alg₁.sort t → alg₂.sort t)
(func (f : σ) : ∀ (xs : Π (i : sig.index f), alg₁.sort i.val), alg₂.func f (λ i, map _ (xs i)) = map _ (alg₁.func f xs))

instance (alg₁ : algebra sig) (alg₂ : algebra sig) : has_coe_to_fun (homomorphism alg₁ alg₂) :=
{ F := λ _, Π {t}, alg₁.sort t → alg₂.sort t
, coe := λ h, h.map
}

namespace homomorphism
variables {alg₁ : algebra sig} {alg₂ : algebra sig} {alg₃ : algebra sig}

theorem eq : Π {{h₁ h₂ : homomorphism alg₁ alg₂}}, h₁.map = h₂.map → h₁ = h₂
| ⟨_,_⟩ ⟨_,_⟩ rfl := rfl

theorem ext {{h₁ h₂ : homomorphism alg₁ alg₂}} : (∀ {t} (x : alg₁.sort t), h₁.map t x = h₂.map t x) → h₁ = h₂ :=
λ H, eq $ funext $ λ _, funext $ λ x, H x

definition id (alg : algebra sig) : homomorphism alg alg :=
{ map := λ _, id
, func := λ _ _, rfl
}

definition comp (h₂₃ : homomorphism alg₂ alg₃) (h₁₂ : homomorphism alg₁ alg₂) : homomorphism alg₁ alg₃ :=
{ map := λ t x, h₂₃.map t (h₁₂.map t x)
, func := λ f xs, eq.subst (h₁₂.func f xs) (h₂₃.func f _)
}

class injective (h : homomorphism alg₁ alg₂) : Prop := intro ::
(elim [] (t) : function.injective (homomorphism.map h t))

class surjective (h : homomorphism alg₁ alg₂) : Prop := intro ::
(elim [] (t) : function.surjective (h.map t))

instance comp.inj (h₂₃ : homomorphism alg₂ alg₃) (h₁₂ : homomorphism alg₁ alg₂)
[injective h₂₃] [injective h₁₂] : injective (comp h₂₃ h₁₂) :=
⟨λ t, function.injective.comp (injective.elim h₂₃ t) (injective.elim h₁₂ t)⟩

instance comp.surj (h₂₃ : homomorphism alg₂ alg₃) (h₁₂ : homomorphism alg₁ alg₂)
[surjective h₂₃] [surjective h₁₂] : surjective (comp h₂₃ h₁₂) :=
⟨λ t, function.surjective.comp (surjective.elim h₂₃ t) (surjective.elim h₁₂ t)⟩

@[priority 0]
instance id.inj (alg : algebra sig) : injective (id alg) := ⟨λ _, function.injective_id⟩

@[priority 0]
instance id.surj (alg : algebra sig) : surjective (id alg) := ⟨λ _, function.surjective_id⟩

theorem eval (h : homomorphism alg₁ alg₂) {dom} :
∀ {cod} (t : term sig dom cod) (val : Π (i : index dom), alg₁.sort i.val),
h.map _ (alg₁.eval t val) = alg₂.eval t (λ i, h.map _ (val i))
| _ (term.proj i) val := rfl
| _ (term.func f ts) val :=
  have IH : (λ i, h.map _ (alg₁.eval (ts i) val)) = (λ i, alg₂.eval (ts i) (λ i, h.map _ (val i))),
  from funext $ λ i, eval (ts i) val,
  calc h.map _ (alg₁.eval (term.func f ts) val)
  = h.map _ (alg₁.func f (λ i, alg₁.eval (ts i) val)) : rfl ...
  = alg₂.func f (λ i, h.map _ (alg₁.eval (ts i) val)) : by rw h.func ...
  = alg₂.func f (λ i, alg₂.eval (ts i) (λ i, h.map _ (val i))) : by rw IH ...
  = alg₂.eval (term.func f ts) (λ i, h.map _ (val i)) : by reflexivity

end homomorphism

namespace algebra.valuation
variables {alg₁ : algebra sig} {alg₂ : algebra sig} (h : homomorphism alg₁ alg₂)

definition map {dom} (val : algebra.valuation alg₁ dom) : algebra.valuation alg₂ dom := λ i, h (val i)

theorem map_eval {dom} (val : algebra.valuation alg₁ dom) :
∀ {cod} (x : term sig dom cod), alg₂.eval x (val.map h) = h.map cod (alg₁.eval x val)
| _ (term.proj _) := rfl
| _ (term.func f xs) :=
  have (λ i, alg₂.eval (xs i) (val.map h)) = (λ i, h.map _ (alg₁.eval (xs i) val)),
  from funext $ λ i, map_eval (xs i),
  calc _
  = alg₂.func f (λ i, alg₂.eval (xs i) (val.map h)) : rfl ...
  = alg₂.func f (λ i, h.map _ (alg₁.eval (xs i) val)) : by rw this ...
  = h.map _ (alg₁.func f (λ i, alg₁.eval (xs i) val)) : by rw h.func f ...
  = h.map _ (alg₁.eval (term.func f xs) val) : by rw alg₁.eval_func

end algebra.valuation

definition algebra.eval_hom (alg : algebra sig) {dom : list τ} (val : Π (i : index dom), alg.sort i.val) :
homomorphism (term_algebra sig dom) alg :=
{ map := λ (cod) (t : term sig dom cod), alg.eval t val
, func := λ _ _, rfl
}

definition term.subst_hom {dom₁ dom₂ : list τ} (sub : substitution sig dom₁ dom₂) :
homomorphism (term_algebra sig dom₁) (term_algebra sig dom₂) :=
{ map := term.subst sub
, func := λ _ _, rfl
}

end universal


/-
Copyright (c) 2023 Joël Riou. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Joël Riou
-/

import for_mathlib.algebraic_topology.homotopical_algebra.model_category
import for_mathlib.category_theory.preadditive.mono_with_projective_coker
import algebra.homology.quasi_iso
import for_mathlib.algebra.homology.derived_category_plus

noncomputable theory

open category_theory category_theory.limits category_theory.category
open algebraic_topology cochain_complex.hom_complex category_theory.preadditive

open_locale zero_object

variables (C : Type*) [category C] [abelian C]

namespace cochain_complex

namespace minus

namespace projective_model_structure

variable {C}

def weq : morphism_property (cochain_complex.minus C) :=
(quasi_isomorphisms C (complex_shape.up ℤ)).inverse_image cochain_complex.minus.ι

lemma mem_weq_iff {X Y : cochain_complex.minus C} (f : X ⟶ Y) :
  weq f ↔ quasi_iso (ι.map f) :=
⟨λ h, ⟨λ n, h n⟩, λ h, h.is_iso⟩

def cof : morphism_property (cochain_complex.minus C) :=
λ X Y f, ∀ n, mono_with_projective_coker C (f.f n)

lemma cof_is_stable_under_composition :
  (cof : morphism_property (cochain_complex.minus C)).stable_under_composition :=
λ X Y Z f g hf hg n,
mono_with_projective_coker.is_stable_by_composition _ _ _ (hf _) (hg _)

def fib : morphism_property (cochain_complex.minus C) :=
λ X Y f, ∀ (n : ℤ), epi (f.f n)

variable (C)

@[simps]
def arrow_classes :
  category_with_fib_cof_weq (cochain_complex.minus C) :=
{ weq := weq,
  fib := fib,
  cof := cof, }

end projective_model_structure

end minus

end cochain_complex


/-
Copyright (c) 2020 Bhavik Mehta. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Bhavik Mehta
-/
import category_theory.adjunction.fully_faithful
import category_theory.reflects_isomorphisms
import category_theory.epi_mono

/-!
# Reflective functors

Basic properties of reflective functors, especially those relating to their essential image.

Note properties of reflective functors relating to limits and colimits are included in
`category_theory.monad.limits`.
-/

universes v₁ v₂ v₃ u₁ u₂ u₃

noncomputable theory

namespace category_theory

open category adjunction

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

/--
A functor is *reflective*, or *a reflective inclusion*, if it is fully faithful and right adjoint.
-/
class reflective (R : D ⥤ C) extends is_right_adjoint R, full R, faithful R.

variables {i : D ⥤ C}

/--
For a reflective functor `i` (with left adjoint `L`), with unit `η`, we have `η_iL = iL η`.
-/
-- TODO: This holds more generally for idempotent adjunctions, not just reflective adjunctions.
lemma unit_obj_eq_map_unit [reflective i] (X : C) :
  (of_right_adjoint i).unit.app (i.obj ((left_adjoint i).obj X))
    = i.map ((left_adjoint i).map ((of_right_adjoint i).unit.app X)) :=
begin
 rw [←cancel_mono (i.map ((of_right_adjoint i).counit.app ((left_adjoint i).obj X))),
     ←i.map_comp],
 simp,
end

/--
When restricted to objects in `D` given by `i : D ⥤ C`, the unit is an isomorphism. In other words,
`η_iX` is an isomorphism for any `X` in `D`.
More generally this applies to objects essentially in the reflective subcategory, see
`functor.ess_image.unit_iso`.
-/
instance is_iso_unit_obj [reflective i] {B : D} :
  is_iso ((of_right_adjoint i).unit.app (i.obj B)) :=
begin
  have : (of_right_adjoint i).unit.app (i.obj B) =
            inv (i.map ((of_right_adjoint i).counit.app B)),
  { rw ← comp_hom_eq_id,
    apply (of_right_adjoint i).right_triangle_components },
  rw this,
  exact is_iso.inv_is_iso,
end

/--
If `A` is essentially in the image of a reflective functor `i`, then `η_A` is an isomorphism.
This gives that the "witness" for `A` being in the essential image can instead be given as the
reflection of `A`, with the isomorphism as `η_A`.

(For any `B` in the reflective subcategory, we automatically have that `ε_B` is an iso.)
-/
lemma functor.ess_image.unit_is_iso [reflective i] {A : C} (h : A ∈ i.ess_image) :
  is_iso ((of_right_adjoint i).unit.app A) :=
begin
  suffices : (of_right_adjoint i).unit.app A =
                h.get_iso.inv ≫ (of_right_adjoint i).unit.app (i.obj h.witness) ≫
                  (left_adjoint i ⋙ i).map h.get_iso.hom,
  { rw this,
    apply_instance },
  rw ← nat_trans.naturality,
  simp,
end

/-- If `η_A` is an isomorphism, then `A` is in the essential image of `i`. -/
lemma mem_ess_image_of_unit_is_iso [is_right_adjoint i] (A : C)
  [is_iso ((of_right_adjoint i).unit.app A)] : A ∈ i.ess_image :=
⟨(left_adjoint i).obj A, ⟨(as_iso ((of_right_adjoint i).unit.app A)).symm⟩⟩

/-- If `η_A` is a split monomorphism, then `A` is in the reflective subcategory. -/
lemma mem_ess_image_of_unit_split_mono [reflective i] {A : C}
  [split_mono ((of_right_adjoint i).unit.app A)] : A ∈ i.ess_image :=
begin
  let η : 𝟭 C ⟶ left_adjoint i ⋙ i := (of_right_adjoint i).unit,
  haveI : is_iso (η.app (i.obj ((left_adjoint i).obj A))) := (i.obj_mem_ess_image _).unit_is_iso,
  have : epi (η.app A),
  { apply epi_of_epi (retraction (η.app A)) _,
    rw (show retraction _ ≫ η.app A = _, from η.naturality (retraction (η.app A))),
    apply epi_comp (η.app (i.obj ((left_adjoint i).obj A))) },
  resetI,
  haveI := is_iso_of_epi_of_split_mono (η.app A),
  exact mem_ess_image_of_unit_is_iso A,
end

/-- Composition of reflective functors. -/
instance reflective.comp (F : C ⥤ D) (G : D ⥤ E) [Fr : reflective F] [Gr : reflective G] :
  reflective (F ⋙ G) := { to_faithful := faithful.comp F G, }

/-- (Implementation) Auxiliary definition for `unit_comp_partial_bijective`. -/
def unit_comp_partial_bijective_aux [reflective i] (A : C) (B : D) :
  (A ⟶ i.obj B) ≃ (i.obj ((left_adjoint i).obj A) ⟶ i.obj B) :=
((adjunction.of_right_adjoint i).hom_equiv _ _).symm.trans (equiv_of_fully_faithful i)

/-- The description of the inverse of the bijection `unit_comp_partial_bijective_aux`. -/
lemma unit_comp_partial_bijective_aux_symm_apply [reflective i] {A : C} {B : D}
  (f : i.obj ((left_adjoint i).obj A) ⟶ i.obj B) :
  (unit_comp_partial_bijective_aux _ _).symm f = (of_right_adjoint i).unit.app A ≫ f :=
by simp [unit_comp_partial_bijective_aux]

/--
If `i` has a reflector `L`, then the function `(i.obj (L.obj A) ⟶ B) → (A ⟶ B)` given by
precomposing with `η.app A` is a bijection provided `B` is in the essential image of `i`.
That is, the function `λ (f : i.obj (L.obj A) ⟶ B), η.app A ≫ f` is bijective, as long as `B` is in
the essential image of `i`.
This definition gives an equivalence: the key property that the inverse can be described
nicely is shown in `unit_comp_partial_bijective_symm_apply`.

This establishes there is a natural bijection `(A ⟶ B) ≃ (i.obj (L.obj A) ⟶ B)`. In other words,
from the point of view of objects in `D`, `A` and `i.obj (L.obj A)` look the same: specifically
that `η.app A` is an isomorphism.
-/
def unit_comp_partial_bijective [reflective i] (A : C) {B : C} (hB : B ∈ i.ess_image) :
  (A ⟶ B) ≃ (i.obj ((left_adjoint i).obj A) ⟶ B) :=
calc (A ⟶ B) ≃ (A ⟶ i.obj hB.witness) : iso.hom_congr (iso.refl _) hB.get_iso.symm
     ...     ≃ (i.obj _ ⟶ i.obj hB.witness) : unit_comp_partial_bijective_aux _ _
     ...     ≃ (i.obj ((left_adjoint i).obj A) ⟶ B) : iso.hom_congr (iso.refl _) hB.get_iso

@[simp]
lemma unit_comp_partial_bijective_symm_apply [reflective i] (A : C) {B : C}
  (hB : B ∈ i.ess_image) (f) :
  (unit_comp_partial_bijective A hB).symm f = (of_right_adjoint i).unit.app A ≫ f :=
by simp [unit_comp_partial_bijective, unit_comp_partial_bijective_aux_symm_apply]

lemma unit_comp_partial_bijective_symm_natural [reflective i] (A : C) {B B' : C} (h : B ⟶ B')
  (hB : B ∈ i.ess_image) (hB' : B' ∈ i.ess_image) (f : i.obj ((left_adjoint i).obj A) ⟶ B) :
  (unit_comp_partial_bijective A hB').symm (f ≫ h) =
    (unit_comp_partial_bijective A hB).symm f ≫ h :=
by simp

lemma unit_comp_partial_bijective_natural [reflective i] (A : C) {B B' : C} (h : B ⟶ B')
  (hB : B ∈ i.ess_image) (hB' : B' ∈ i.ess_image) (f : A ⟶ B) :
  (unit_comp_partial_bijective A hB') (f ≫ h) = unit_comp_partial_bijective A hB f ≫ h :=
by rw [←equiv.eq_symm_apply, unit_comp_partial_bijective_symm_natural A h, equiv.symm_apply_apply]

/-- If `i : D ⥤ C` is reflective, the inverse functor of `i ≌ F.ess_image` can be explicitly
defined by the reflector. -/
@[simps]
def equiv_ess_image_of_reflective [reflective i] : D ≌ i.ess_image :=
{ functor := i.to_ess_image,
  inverse := i.ess_image_inclusion ⋙ (left_adjoint i : _),
  unit_iso := nat_iso.of_components (λ X, (as_iso $ (of_right_adjoint i).counit.app X).symm)
    (by { intros X Y f, dsimp, simp only [is_iso.eq_inv_comp, is_iso.comp_inv_eq, category.assoc],
      exact ((of_right_adjoint i).counit.naturality _).symm }),
  counit_iso := nat_iso.of_components
    (λ X, by { refine (iso.symm $ as_iso _), exact (of_right_adjoint i).unit.app X,
      apply_with (is_iso_of_reflects_iso _ i.ess_image_inclusion) { instances := ff },
      exact functor.ess_image.unit_is_iso X.prop })
    (by { intros X Y f, dsimp, simp only [is_iso.eq_inv_comp, is_iso.comp_inv_eq, category.assoc],
      exact ((of_right_adjoint i).unit.naturality f).symm }) }

end category_theory


/-
Copyright (c) 2021-2023 by the authors listed in the file AUTHORS and their
institutional affiliations. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Abdalrhman Mohamed
-/

import Smt.Reconstruction.Rewrites.Simp

namespace Smt.Reconstruction.Rewrites.Prop

scoped notation "const " c => fun _ => c

@[smt_simp] theorem bool_double_neg_elim [Decidable t] : Not (Not t) = t :=
  propext ⟨Decidable.of_not_not, not_not_intro⟩

@[smt_simp] theorem bool_eq_true : (t = True) = t :=
  propext ⟨of_eq_true, eq_true⟩
@[smt_simp] theorem bool_eq_false : (t = False) = (Not t) :=
  propext ⟨(· ▸ not_false), eq_false⟩

@[smt_simp] theorem bool_impl_false1 : (t → False) = (Not t) :=
  propext ⟨(·), (·)⟩
@[smt_simp] theorem bool_impl_false2 : (False → t) = True :=
  propext ⟨const trivial, const False.elim⟩
@[smt_simp] theorem bool_impl_true1 : (t → True) = True :=
  propext ⟨const trivial, const (const trivial)⟩
@[smt_simp] theorem bool_impl_true2 {t : Prop} : (True → t) = t :=
  propext ⟨(· trivial), (const ·)⟩

@[smt_simp] theorem bool_or_true : (xs ∨ True ∨ ys) = True :=
  (true_or _).symm ▸ or_true _
@[smt_simp] theorem bool_or_false : (xs ∨ False ∨ ys) = (xs ∨ ys) :=
  (false_or _).symm ▸ rfl
@[smt_simp] theorem bool_or_flatten : (xs ∨ (b ∨ ys) ∨ zs) = (xs ∨ zs ∨ b ∨ ys) :=
  sorry
@[smt_simp] theorem bool_or_dup : (xs ∨ b ∨ ys ∨ b ∨ zs) = (xs ∨ b ∨ ys ∨ zs) :=
  sorry

@[smt_simp] theorem bool_and_true : (xs ∧ True ∧ ys) = (xs ∧ ys) := (true_and _).symm ▸ rfl
@[smt_simp] theorem bool_and_false : (xs ∧ False ∧ ys) = False := (false_and _).symm ▸ and_false _
@[smt_simp] theorem bool_and_flatten : (xs ∧ (b ∧ ys) ∧ zs) = (xs ∧ zs ∧ b ∧ ys) := sorry
@[smt_simp] theorem bool_and_dup : (xs ∧ b ∧ ys ∧ b ∧ zs) = (xs ∧ b ∧ ys ∧ zs) := sorry

@[smt_simp] theorem bool_and_conf : (xs ∧ w ∧ ys ∧ ¬w ∧ zs) = False := sorry
@[smt_simp] theorem bool_or_taut : (xs ∨ w ∨ ys ∨ ¬w ∨ zs) = True := sorry

@[smt_simp] theorem ite_neg_branch [h : Decidable c] [Decidable y] : x = ¬y → ite c x y = (c = x) := fun hxny =>
  hxny ▸ h.byCases
    (fun hc => if_pos hc ▸ propext ⟨(propext ⟨const ·, const hc⟩), (· ▸ hc)⟩)
    (fun hnc => if_neg hnc ▸ propext
      ⟨fun hy => propext ⟨fun hc => False.elim (hnc hc), fun hny => False.elim (hny hy)⟩,
       fun hcny => bool_double_neg_elim (t := y) ▸ hcny ▸ hnc⟩)

end Smt.Reconstruction.Rewrites.Prop


/-
Copyright (c) 2022 Yaël Dillies. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yaël Dillies
-/
import order.category.BoundedLattice
import order.hom.complete_lattice

/-!
# The category of complete lattices

This file defines `CompleteLattice`, the category of complete lattices.
-/

universes u

open category_theory

/-- The category of complete lattices. -/
def CompleteLattice := bundled complete_lattice

namespace CompleteLattice

instance : has_coe_to_sort CompleteLattice Type* := bundled.has_coe_to_sort
instance (X : CompleteLattice) : complete_lattice X := X.str

/-- Construct a bundled `CompleteLattice` from a `complete_lattice`. -/
def of (α : Type*) [complete_lattice α] : CompleteLattice := bundled.of α

@[simp] lemma coe_of (α : Type*) [complete_lattice α] : ↥(of α) = α := rfl

instance : inhabited CompleteLattice := ⟨of punit⟩

instance : bundled_hom @complete_lattice_hom :=
{ to_fun := λ _ _ _ _, coe_fn,
  id := @complete_lattice_hom.id,
  comp := @complete_lattice_hom.comp,
  hom_ext := λ X Y _ _, by exactI fun_like.coe_injective }
instance : large_category.{u} CompleteLattice := bundled_hom.category complete_lattice_hom
instance : concrete_category CompleteLattice := bundled_hom.concrete_category complete_lattice_hom

instance has_forget_to_BoundedLattice : has_forget₂ CompleteLattice BoundedLattice :=
{ forget₂ := { obj := λ X, BoundedLattice.of X,
               map := λ X Y, complete_lattice_hom.to_bounded_lattice_hom },
  forget_comp := rfl }

/-- Constructs an isomorphism of complete lattices from an order isomorphism between them. -/
@[simps] def iso.mk {α β : CompleteLattice.{u}} (e : α ≃o β) : α ≅ β :=
{ hom := e,
  inv := e.symm,
  hom_inv_id' := by { ext, exact e.symm_apply_apply _ },
  inv_hom_id' := by { ext, exact e.apply_symm_apply _ } }

/-- `order_dual` as a functor. -/
@[simps] def dual : CompleteLattice ⥤ CompleteLattice :=
{ obj := λ X, of Xᵒᵈ, map := λ X Y, complete_lattice_hom.dual }

/-- The equivalence between `CompleteLattice` and itself induced by `order_dual` both ways. -/
@[simps functor inverse] def dual_equiv : CompleteLattice ≌ CompleteLattice :=
equivalence.mk dual dual
  (nat_iso.of_components (λ X, iso.mk $ order_iso.dual_dual X) $ λ X Y f, rfl)
  (nat_iso.of_components (λ X, iso.mk $ order_iso.dual_dual X) $ λ X Y f, rfl)

end CompleteLattice

lemma CompleteLattice_dual_comp_forget_to_BoundedLattice :
  CompleteLattice.dual ⋙ forget₂ CompleteLattice BoundedLattice =
    forget₂ CompleteLattice BoundedLattice ⋙ BoundedLattice.dual := rfl


example (a b : Nat) : True := by
  induction a generalizing b
  case zero => trivial
  case succ => trivial


/-
Copyright (c) 2020 Aaron Anderson. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors : Aaron Anderson
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.linear_algebra.basic
import Mathlib.order.atoms
import Mathlib.PostPort

universes u_1 u_2 u_3

namespace Mathlib

/-!
# Simple Modules

## Main Definitions
  * `is_simple_module` indicates that a module has no proper submodules
  (the only submodules are `⊥` and `⊤`).
  * A `division_ring` structure on the endomorphism ring of a simple module.

## Main Results
  * Schur's Lemma: `bijective_or_eq_zero` shows that a linear map between simple modules
  is either bijective or 0, leading to a `division_ring` structure on the endomorphism ring.

## TODO
  * Semisimple modules, Artin-Wedderburn Theory
  * Unify with the work on Schur's Lemma in a category theory context

-/

/-- A module is simple when it has only two submodules, `⊥` and `⊤`. -/
def is_simple_module (R : Type u_1) [comm_ring R] (M : Type u_2) [add_comm_group M] [module R M] :=
  is_simple_lattice (submodule R M)

-- Making this an instance causes the linter to complain of "dangerous instances"

theorem is_simple_module.nontrivial (R : Type u_1) [comm_ring R] (M : Type u_2) [add_comm_group M]
    [module R M] [is_simple_module R M] : nontrivial M :=
  sorry

namespace linear_map

theorem injective_or_eq_zero {R : Type u_1} [comm_ring R] {M : Type u_2} [add_comm_group M]
    [module R M] {N : Type u_3} [add_comm_group N] [module R N] [is_simple_module R M]
    (f : linear_map R M N) : function.injective ⇑f ∨ f = 0 :=
  eq.mpr (id (Eq._oldrec (Eq.refl (function.injective ⇑f ∨ f = 0)) (Eq.symm (propext ker_eq_bot))))
    (eq.mpr (id (Eq._oldrec (Eq.refl (ker f = ⊥ ∨ f = 0)) (Eq.symm (propext ker_eq_top))))
      (eq_bot_or_eq_top (ker f)))

theorem injective_of_ne_zero {R : Type u_1} [comm_ring R] {M : Type u_2} [add_comm_group M]
    [module R M] {N : Type u_3} [add_comm_group N] [module R N] [is_simple_module R M]
    {f : linear_map R M N} (h : f ≠ 0) : function.injective ⇑f :=
  or.resolve_right (injective_or_eq_zero f) h

theorem surjective_or_eq_zero {R : Type u_1} [comm_ring R] {M : Type u_2} [add_comm_group M]
    [module R M] {N : Type u_3} [add_comm_group N] [module R N] [is_simple_module R N]
    (f : linear_map R M N) : function.surjective ⇑f ∨ f = 0 :=
  sorry

theorem surjective_of_ne_zero {R : Type u_1} [comm_ring R] {M : Type u_2} [add_comm_group M]
    [module R M] {N : Type u_3} [add_comm_group N] [module R N] [is_simple_module R N]
    {f : linear_map R M N} (h : f ≠ 0) : function.surjective ⇑f :=
  or.resolve_right (surjective_or_eq_zero f) h

/-- Schur's Lemma for linear maps between (possibly distinct) simple modules -/
theorem bijective_or_eq_zero {R : Type u_1} [comm_ring R] {M : Type u_2} [add_comm_group M]
    [module R M] {N : Type u_3} [add_comm_group N] [module R N] [is_simple_module R M]
    [is_simple_module R N] (f : linear_map R M N) : function.bijective ⇑f ∨ f = 0 :=
  dite (f = 0) (fun (h : f = 0) => Or.inr h)
    fun (h : ¬f = 0) =>
      or.intro_left (f = 0) { left := injective_of_ne_zero h, right := surjective_of_ne_zero h }

theorem bijective_of_ne_zero {R : Type u_1} [comm_ring R] {M : Type u_2} [add_comm_group M]
    [module R M] {N : Type u_3} [add_comm_group N] [module R N] [is_simple_module R M]
    [is_simple_module R N] {f : linear_map R M N} (h : f ≠ 0) : function.bijective ⇑f :=
  or.resolve_right (bijective_or_eq_zero f) h

/-- Schur's Lemma makes the endomorphism ring of a simple module a division ring. -/
protected instance module.End.division_ring {R : Type u_1} [comm_ring R] {M : Type u_2}
    [add_comm_group M] [module R M] [DecidableEq (module.End R M)] [is_simple_module R M] :
    division_ring (module.End R M) :=
  division_ring.mk ring.add sorry ring.zero sorry sorry ring.neg ring.sub sorry sorry ring.mul sorry
    ring.one sorry sorry sorry sorry
    (fun (f : module.End R M) =>
      dite (f = 0) (fun (h : f = 0) => 0)
        fun (h : ¬f = 0) =>
          inverse f (equiv.inv_fun (equiv.of_bijective (⇑f) (bijective_of_ne_zero h))) sorry sorry)
    (div_inv_monoid.div._default ring.mul sorry ring.one sorry sorry
      fun (f : module.End R M) =>
        dite (f = 0) (fun (h : f = 0) => 0)
          fun (h : ¬f = 0) =>
            inverse f (equiv.inv_fun (equiv.of_bijective (⇑f) (bijective_of_ne_zero h))) sorry
              sorry)
    sorry sorry sorry

end Mathlib


import algebraic_topology.nerve
import algebraic_topology.simplicial_object
import category_theory.adjunction.basic
import category_theory.functor.basic
import category_theory.functor.category

import simplicial_realization

open category_theory quiver category_theory.simplicial_object

variables (C : Type*) [category C]

-- define the counit first
def point' : (simplex_category.skeletal_functor.obj (simplex_category.mk 0)) := begin
  simp, refine 0,
end

def obj' (n : fin 2) : (simplex_category.skeletal_functor.obj (simplex_category.mk 1)) := begin
  simp, refine n,
end

def arrow' : (obj' 0) ⟶ (obj' 1) := begin
  have H := nat.le_of_lt(nat.lt.base 0),
  refine ulift.up (plift.up H),
end

def obj (n : fin 2) : (simplex_category.to_Cat.obj (simplex_category.mk 1)) := begin
  simp, refine (obj' n),
end

#check simplex_category.to_Cat.map (simplex_category.δ 1)

def arrow : (obj 0) ⟶ (obj 1) := arrow'

def point : ((simplex_category.to_Cat.obj (simplex_category.mk 0))) := point'

lemma d1' : (simplex_category.skeletal_functor.map (simplex_category.δ 1)).to_fun point = (obj' 0) :=
begin
  simp, dsimp [obj'], dsimp [simplex_category.hom.to_order_hom],
  dsimp [simplex_category.δ], dsimp [simplex_category.hom.mk],
  dsimp [point], dsimp [point'], simp, refl,
end

-- i dont know if theres a better way to do this but i also do not care
lemma d1 : (simplex_category.to_Cat.map (simplex_category.δ 1)).obj point = (obj 0) := begin

  simp,
  dsimp [forget₂], dsimp [has_forget₂.forget₂],

  dsimp [obj], dsimp [obj'],
  dsimp [simplex_category.hom.to_order_hom],
  dsimp [simplex_category.δ],
  dsimp [simplex_category.hom.mk],
  dsimp [point], dsimp [point'],
  dsimp [order_hom_class.to_lattice_hom],
  dsimp [coe], dsimp [lift_t], unfold has_lift_t.lift,
  unfold coe_t, unfold has_coe_t.coe,

  unfold coe_fn, unfold has_coe_to_fun.coe, simp,
  unfold coe_fn, unfold has_coe_to_fun.coe, unfold fun_like.coe,

  simp, refl,

end

lemma d0 : (simplex_category.to_Cat.map (simplex_category.δ 0)).obj point = (obj 1) := begin

  simp,
  dsimp [forget₂], dsimp [has_forget₂.forget₂],

  dsimp [obj], dsimp [obj'],
  dsimp [simplex_category.hom.to_order_hom],
  dsimp [simplex_category.δ],
  dsimp [simplex_category.hom.mk],
  dsimp [point], dsimp [point'],
  dsimp [order_hom_class.to_lattice_hom],
  dsimp [coe], dsimp [lift_t], unfold has_lift_t.lift,
  unfold coe_t, unfold has_coe_t.coe,

  unfold coe_fn, unfold has_coe_to_fun.coe, simp,
  unfold coe_fn, unfold has_coe_to_fun.coe, unfold fun_like.coe,

  simp, refl,

end

#check congr_fun
def counit.obj (X : HomotopyRealization.obj (nerve C)) : C := X.obj point
def one_simplex_to_morphsim {a b : nerve C _[0]} (f : a ⟶ b) : (counit.obj C a) ⟶ (counit.obj C b) := begin
  destruct f, intros,
  unfold nerve at val, simp at val,
  unfold δ at property,
  -- simp at property,
  destruct property, intros,
  dsimp [counit.obj], subst left, subst right,
  -- have H := val.map arrow,

  have H0 : (nerve C).map (simplex_category.δ 0).op val = ((simplex_category.to_Cat.map (simplex_category.δ 0).op.unop)) ⋙ val,
  refl,
  have H1 : (nerve C).map (simplex_category.δ 1).op val = ((simplex_category.to_Cat.map (simplex_category.δ 1).op.unop)) ⋙ val,
  refl,

  have H2 : (((nerve C).map (simplex_category.δ 1).op val).obj point) ⟶ (((nerve C).map (simplex_category.δ 0).op val).obj point) = ((((simplex_category.to_Cat.map (simplex_category.δ 1).op.unop)) ⋙ val).obj point) ⟶ ((((simplex_category.to_Cat.map (simplex_category.δ 0).op.unop)) ⋙ val).obj point),
  rw H0, rw H1,

  rw d1,
end

def counit.map' (X Y : HomotopyRealization.obj (nerve C)) (f : @path (nerve C _[0]) underlying X Y) : (counit.obj C X) ⟶ (counit.obj C Y) :=
begin
  induction f with _ _ α_1 α, refine (𝟙 _),
  have H := α.val,
  have H' := α.val.map arrow,
  refine (f_ih ≫ (α.val.map arrow)),
end

-- def counit.map (X Y : (HomotopyRealization.obj (nerve C))) (f : X ⟶ Y) :
-- (counit.obj C X) ⟶  (counit.obj C Y) := begin
--   dsimp [hom] at f, dsimp [Cat.of] at f, dsimp [bundled.of] at f,
--   dsimp [hom] at f,
--   have H := pick_rep f, cases H, --revert H, introsrintro ⟨f', frw⟩,

-- end

def adjoint : HomotopyRealization ⊣ nerve_functor := adjunction.mk_of_unit_counit {
  counit := {
      app := λ a, { obj := λ p, counit.obj a p, map := λ p q α, begin
          apply counit.map, refine α,
      end}
  }
}

lemma counit_respects_homotopies (C : Type) [category C] (h : (nerve C) _[2])
: C = C :=
begin
  refl,
end