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

import category_theory.idempotents.karoubi

/-!
# Extension of functors to the idempotent completion

In this file, we construct an extension `functor_extension₁`
of functors `C ⥤ karoubi D` to functors `karoubi C ⥤ karoubi D`. This results in an
equivalence `karoubi_universal₁ C D : (C ⥤ karoubi D) ≌ (karoubi C ⥤ karoubi D)`.

We also construct an extension `functor_extension₂` of functors
`(C ⥤ D) ⥤ (karoubi C ⥤ karoubi D)`. Moreover,
when `D` is idempotent complete, we get equivalences
`karoubi_universal₂ C D : C ⥤ D ≌ karoubi C ⥤ karoubi D`
and `karoubi_universal C D : C ⥤ D ≌ karoubi C ⥤ D`.

We occasionally state and use equalities of functors because it is
sometimes convenient to use rewrites when proving properties of
functors obtained using the constructions in this file. Users are
encouraged to use the corresponding natural isomorphism
whenever possible.

-/

open category_theory.category
open category_theory.idempotents.karoubi

namespace category_theory

namespace idempotents

variables {C D E : Type*} [category C] [category D] [category E]

/-- A natural transformation between functors `karoubi C ⥤ D` is determined
by its value on objects coming from `C`. -/
lemma nat_trans_eq {F G : karoubi C ⥤ D} (φ : F ⟶ G) (P : karoubi C) :
  φ.app P = F.map (decomp_id_i P) ≫ φ.app P.X ≫ G.map (decomp_id_p P) :=
begin
  rw [← φ.naturality, ← assoc, ← F.map_comp],
  conv { to_lhs, rw [← id_comp (φ.app P), ← F.map_id], },
  congr,
  apply decomp_id,
end

namespace functor_extension₁

/-- The canonical extension of a functor `C ⥤ karoubi D` to a functor
`karoubi C ⥤ karoubi D` -/
@[simps]
def obj (F : C ⥤ karoubi D) : karoubi C ⥤ karoubi D :=
{ obj := λ P, ⟨(F.obj P.X).X, (F.map P.p).f,
    by simpa only [F.map_comp, hom_ext] using F.congr_map P.idem⟩,
  map := λ P Q f, ⟨(F.map f.f).f,
    by simpa only [F.map_comp, hom_ext] using F.congr_map f.comm⟩, }

/-- Extension of a natural transformation `φ` between functors
`C ⥤ karoubi D` to a natural transformation between the
extension of these functors to `karoubi C ⥤ karoubi D` -/
@[simps]
def map {F G : C ⥤ karoubi D} (φ : F ⟶ G) : obj F ⟶ obj G :=
{ app := λ P,
  { f := (F.map P.p).f ≫ (φ.app P.X).f,
    comm := begin
      have h := φ.naturality P.p,
      have h' := F.congr_map P.idem,
      simp only [hom_ext, karoubi.comp_f, F.map_comp] at h h',
      simp only [obj_obj_p, assoc, ← h],
      slice_rhs 1 3 { rw [h', h'], },
    end, },
  naturality' := λ P Q f, begin
    ext,
    dsimp [obj],
    have h := φ.naturality f.f,
    have h' := F.congr_map (comp_p f),
    have h'' := F.congr_map (p_comp f),
    simp only [hom_ext, functor.map_comp, comp_f] at ⊢ h h' h'',
    slice_rhs 2 3 { rw ← h, },
    slice_lhs 1 2 { rw h', },
    slice_rhs 1 2 { rw h'', },
  end }

end functor_extension₁

variables (C D E)

/-- The canonical functor `(C ⥤ karoubi D) ⥤ (karoubi C ⥤ karoubi D)` -/
@[simps]
def functor_extension₁ : (C ⥤ karoubi D) ⥤ (karoubi C ⥤ karoubi D) :=
{ obj := functor_extension₁.obj,
  map := λ F G, functor_extension₁.map,
  map_id' := λ F, by { ext P, exact comp_p (F.map P.p), },
  map_comp' := λ F G H φ φ', begin
    ext P,
    simp only [comp_f, functor_extension₁.map_app_f, nat_trans.comp_app, assoc],
    have h := φ.naturality P.p,
    have h' := F.congr_map P.idem,
    simp only [hom_ext, comp_f, F.map_comp] at h h',
    slice_rhs 2 3 { rw ← h, },
    slice_rhs 1 2 { rw h', },
    simp only [assoc],
  end, }

lemma functor_extension₁_comp_whiskering_left_to_karoubi :
  functor_extension₁ C D ⋙
    (whiskering_left C (karoubi C) (karoubi D)).obj (to_karoubi C) = 𝟭 _ :=
begin
  refine functor.ext _ _,
  { intro F,
    refine functor.ext _ _,
    { intro X,
      ext,
      { dsimp,
        rw [id_comp, comp_id, F.map_id, id_eq], },
      { refl, }, },
    { intros X Y f,
      ext,
      dsimp,
      simp only [comp_id, eq_to_hom_f, eq_to_hom_refl, comp_p, functor_extension₁.obj_obj_p,
        to_karoubi_obj_p, comp_f],
      dsimp,
      simp only [functor.map_id, id_eq, p_comp], }, },
  { intros F G φ,
    ext X,
    dsimp,
    simp only [eq_to_hom_app, F.map_id, comp_f, eq_to_hom_f, id_eq, p_comp,
      eq_to_hom_refl, comp_id, comp_p, functor_extension₁.obj_obj_p,
      to_karoubi_obj_p, F.map_id X], },
end

/-- The natural isomorphism expressing that functors `karoubi C ⥤ karoubi D` obtained
using `functor_extension₁` actually extends the original functors `C ⥤ karoubi D`. -/
@[simps]
def functor_extension₁_comp_whiskering_left_to_karoubi_iso :
  functor_extension₁ C D ⋙
    (whiskering_left C (karoubi C) (karoubi D)).obj (to_karoubi C) ≅ 𝟭 _ :=
eq_to_iso (functor_extension₁_comp_whiskering_left_to_karoubi C D)

/-- The counit isomorphism of the equivalence `(C ⥤ karoubi D) ≌ (karoubi C ⥤ karoubi D)`. -/
@[simps]
def karoubi_universal₁.counit_iso :
  (whiskering_left C (karoubi C) (karoubi D)).obj (to_karoubi C) ⋙
    functor_extension₁ C D ≅ 𝟭 _ :=
nat_iso.of_components (λ G,
  { hom :=
    { app := λ P,
      { f := (G.map (decomp_id_p P)).f,
        comm := by simpa only [hom_ext, G.map_comp, G.map_id] using G.congr_map
          (show P.decomp_id_p = (to_karoubi C).map P.p ≫ P.decomp_id_p ≫ 𝟙 _, by simp), },
      naturality' := λ P Q f,
        by simpa only [hom_ext, G.map_comp] using (G.congr_map (decomp_id_p_naturality f)).symm, },
    inv :=
    { app := λ P,
      { f := (G.map (decomp_id_i P)).f,
        comm := by simpa only [hom_ext, G.map_comp, G.map_id] using G.congr_map
          (show P.decomp_id_i = 𝟙 _ ≫ P.decomp_id_i ≫ (to_karoubi C).map P.p, by simp), },
      naturality' := λ P Q f,
        by simpa only [hom_ext, G.map_comp] using G.congr_map (decomp_id_i_naturality f), },
    hom_inv_id' := begin
      ext P,
      simpa only [hom_ext, G.map_comp, G.map_id] using G.congr_map P.decomp_p.symm,
    end,
    inv_hom_id' := begin
      ext P,
      simpa only [hom_ext, G.map_comp, G.map_id] using G.congr_map P.decomp_id.symm,
    end, })
(λ G₁ G₂ φ, begin
  ext P,
  dsimp,
  simpa only [nat_trans_eq φ P, comp_f, functor_extension₁.map_app_f,
    functor.comp_map, whisker_left_app, assoc, P.decomp_p, G₁.map_comp],
end)

/-- The equivalence of categories `(C ⥤ karoubi D) ≌ (karoubi C ⥤ karoubi D)`. -/
@[simps]
def karoubi_universal₁ : (C ⥤ karoubi D) ≌ (karoubi C ⥤ karoubi D) :=
{ functor := functor_extension₁ C D,
  inverse := (whiskering_left C (karoubi C) (karoubi D)).obj (to_karoubi C),
  unit_iso := (functor_extension₁_comp_whiskering_left_to_karoubi_iso C D).symm,
  counit_iso := karoubi_universal₁.counit_iso C D,
  functor_unit_iso_comp' := λ F, begin
    ext P,
    dsimp [functor_extension₁.map, karoubi_universal₁.counit_iso],
    simpa only [comp_f, eq_to_hom_app, eq_to_hom_f, eq_to_hom_refl, comp_id,
      hom_ext, F.map_comp, comp_p] using F.congr_map P.idem,
  end, }

lemma functor_extension₁_comp (F : C ⥤ karoubi D) (G : D ⥤ karoubi E) :
  (functor_extension₁ C E).obj (F ⋙ (functor_extension₁ D E).obj G) =
    (functor_extension₁ C D).obj F ⋙ (functor_extension₁ D E).obj G :=
functor.ext (by tidy) (λ X Y f, by { dsimp, simpa only [id_comp, comp_id], })

/-- The canonical functor `(C ⥤ D) ⥤ (karoubi C ⥤ karoubi D)` -/
@[simps]
def functor_extension₂ : (C ⥤ D) ⥤ (karoubi C ⥤ karoubi D) :=
(whiskering_right C D (karoubi D)).obj (to_karoubi D) ⋙ functor_extension₁ C D

lemma functor_extension₂_comp_whiskering_left_to_karoubi :
  functor_extension₂ C D ⋙ (whiskering_left C (karoubi C) (karoubi D)).obj (to_karoubi C) =
  (whiskering_right C D (karoubi D)).obj (to_karoubi D) :=
by simp only [functor_extension₂, functor.assoc,
  functor_extension₁_comp_whiskering_left_to_karoubi, functor.comp_id]

/-- The natural isomorphism expressing that functors `karoubi C ⥤ karoubi D` obtained
using `functor_extension₂` actually extends the original functors `C ⥤ D`. -/
@[simps]
def functor_extension₂_comp_whiskering_left_to_karoubi_iso :
  functor_extension₂ C D ⋙ (whiskering_left C (karoubi C) (karoubi D)).obj (to_karoubi C) ≅
  (whiskering_right C D (karoubi D)).obj (to_karoubi D) :=
eq_to_iso (functor_extension₂_comp_whiskering_left_to_karoubi C D)

section is_idempotent_complete

variable [is_idempotent_complete D]

noncomputable instance : is_equivalence (to_karoubi D) := to_karoubi_is_equivalence D

/-- The equivalence of categories `(C ⥤ D) ≌ (karoubi C ⥤ karoubi D)` when `D`
is idempotent complete. -/
@[simps]
noncomputable def karoubi_universal₂ : (C ⥤ D) ≌ (karoubi C ⥤ karoubi D) :=
(equivalence.congr_right (to_karoubi D).as_equivalence).trans
    (karoubi_universal₁ C D)

lemma karoubi_universal₂_functor_eq :
  (karoubi_universal₂ C D).functor = functor_extension₂ C D := rfl

noncomputable instance : is_equivalence (functor_extension₂ C D) :=
by { rw ← karoubi_universal₂_functor_eq, apply_instance, }

/-- The extension of functors functor `(C ⥤ D) ⥤ (karoubi C ⥤ D)`
when `D` is idempotent compltete. -/
@[simps]
noncomputable def functor_extension : (C ⥤ D) ⥤ (karoubi C ⥤ D) :=
functor_extension₂ C D ⋙ (whiskering_right (karoubi C) (karoubi D) D).obj
    (to_karoubi_is_equivalence D).inverse

/-- The equivalence `(C ⥤ D) ≌ (karoubi C ⥤ D)` when `D` is idempotent complete. -/
@[simps]
noncomputable def karoubi_universal : (C ⥤ D) ≌ (karoubi C ⥤ D) :=
(karoubi_universal₂ C D).trans (equivalence.congr_right (to_karoubi D).as_equivalence.symm)

lemma karoubi_universal_functor_eq :
  (karoubi_universal C D).functor = functor_extension C D := rfl

noncomputable instance : is_equivalence (functor_extension C D) :=
by { rw ← karoubi_universal_functor_eq, apply_instance, }

noncomputable instance : is_equivalence ((whiskering_left C (karoubi C) D).obj (to_karoubi C)) :=
is_equivalence.cancel_comp_right _ ((whiskering_right C _ _).obj (to_karoubi D) ⋙
    (whiskering_right C _ _).obj (to_karoubi D).inv)
  (is_equivalence.of_equivalence (@equivalence.congr_right _ _ _ _ C _
      ((to_karoubi D).as_equivalence.trans (to_karoubi D).as_equivalence.symm)))
  (by { change is_equivalence (karoubi_universal C D).inverse, apply_instance, })

variables {C D}

lemma whiskering_left_obj_preimage_app {F G : karoubi C ⥤ D}
  (τ : to_karoubi _ ⋙ F ⟶ to_karoubi _ ⋙ G) (P : karoubi C) :
  (((whiskering_left _ _ _).obj (to_karoubi _)).preimage τ).app P =
    F.map P.decomp_id_i ≫ τ.app P.X ≫ G.map P.decomp_id_p :=
begin
  rw nat_trans_eq,
  congr' 2,
  exact congr_app (((whiskering_left _ _ _).obj (to_karoubi _)).image_preimage τ) P.X,
end

end is_idempotent_complete

end idempotents

end category_theory


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

Traversable instance for lazy_lists.
-/
import control.traversable.equiv
import control.traversable.instances
import data.lazy_list

/-!
## Definitions on lazy lists

This file contains various definitions and proofs on lazy lists.

TODO: move the `lazy_list.lean` file from core to mathlib.
-/

universes u

namespace thunk

/-- Creates a thunk with a (non-lazy) constant value. -/
def mk {α} (x : α) : thunk α := λ _, x

instance {α : Type u} [decidable_eq α] : decidable_eq (thunk α) | a b :=
have a = b ↔ a () = b (), from ⟨by cc, by intro; ext x; cases x; assumption⟩,
by rw this; apply_instance

end thunk

namespace lazy_list

open function

/-- Isomorphism between strict and lazy lists. -/
def list_equiv_lazy_list (α : Type*) : list α ≃ lazy_list α :=
{ to_fun := lazy_list.of_list,
  inv_fun := lazy_list.to_list,
  right_inv := by { intro, induction x, refl, simp! [*],
                    ext, cases x, refl },
  left_inv := by { intro, induction x, refl, simp! [*] } }

instance {α : Type u} : inhabited (lazy_list α) := ⟨nil⟩

instance {α : Type u} [decidable_eq α] : decidable_eq (lazy_list α)
| nil nil := is_true rfl
| (cons x xs) (cons y ys) :=
  if h : x = y then
    match decidable_eq (xs ()) (ys ()) with
    | is_false h2 := is_false (by intro; cc)
    | is_true h2 :=
      have xs = ys, by ext u; cases u; assumption,
      is_true (by cc)
    end
  else
    is_false (by intro; cc)
| nil (cons _ _) := is_false (by cc)
| (cons _ _) nil := is_false (by cc)

/-- Traversal of lazy lists using an applicative effect. -/
protected def traverse {m : Type u → Type u} [applicative m] {α β : Type u}
    (f : α → m β) : lazy_list α → m (lazy_list β)
| lazy_list.nil := pure lazy_list.nil
| (lazy_list.cons x xs) := lazy_list.cons <$> f x <*> (thunk.mk <$> traverse (xs ()))

instance : traversable lazy_list :=
{ map := @lazy_list.traverse id _,
  traverse := @lazy_list.traverse }

instance : is_lawful_traversable lazy_list :=
begin
  apply equiv.is_lawful_traversable' list_equiv_lazy_list;
  intros ; resetI; ext,
  { induction x, refl,
    simp! [equiv.map,functor.map] at *,
    simp [*], refl, },
  { induction x, refl,
    simp! [equiv.map,functor.map_const] at *,
    simp [*], refl, },
  { induction x,
    { simp! [traversable.traverse,equiv.traverse] with functor_norm, refl },
    simp! [equiv.map,functor.map_const,traversable.traverse] at *, rw x_ih,
    dsimp [list_equiv_lazy_list,equiv.traverse,to_list,traversable.traverse,list.traverse],
    simp! with functor_norm, refl },
end

/-- `init xs`, if `xs` non-empty, drops the last element of the list.
Otherwise, return the empty list. -/
def init {α} : lazy_list α → lazy_list α
| lazy_list.nil := lazy_list.nil
| (lazy_list.cons x xs) :=
  let xs' := xs () in
  match xs' with
  | lazy_list.nil := lazy_list.nil
  | (lazy_list.cons _ _) := lazy_list.cons x (init xs')
  end

/-- Return the first object contained in the list that satisfies
predicate `p` -/
def find {α} (p : α → Prop) [decidable_pred p] : lazy_list α → option α
| nil        := none
| (cons h t) := if p h then some h else find (t ())

/-- `interleave xs ys` creates a list where elements of `xs` and `ys` alternate. -/
def interleave {α} : lazy_list α → lazy_list α → lazy_list α
| lazy_list.nil xs := xs
| a@(lazy_list.cons x xs) lazy_list.nil := a
| (lazy_list.cons x xs) (lazy_list.cons y ys) :=
  lazy_list.cons x (lazy_list.cons y (interleave (xs ()) (ys ())))

/-- `interleave_all (xs::ys::zs::xss)` creates a list where elements of `xs`, `ys`
and `zs` and the rest alternate. Every other element of the resulting list is taken from
`xs`, every fourth is taken from `ys`, every eighth is taken from `zs` and so on. -/
def interleave_all {α} : list (lazy_list α) → lazy_list α
| [] := lazy_list.nil
| (x :: xs) := interleave x (interleave_all xs)

/-- Monadic bind operation for `lazy_list`. -/
protected def bind {α β} : lazy_list α → (α → lazy_list β) → lazy_list β
| lazy_list.nil _ := lazy_list.nil
| (lazy_list.cons x xs) f := lazy_list.append (f x) (bind (xs ()) f)

/-- Reverse the order of a `lazy_list`.
It is done by converting to a `list` first because reversal involves evaluating all
the list and if the list is all evaluated, `list` is a better representation for
it than a series of thunks. -/
def reverse {α} (xs : lazy_list α) : lazy_list α :=
of_list xs.to_list.reverse

instance : monad lazy_list :=
{ pure := @lazy_list.singleton,
  bind := @lazy_list.bind }

lemma append_assoc {α} (xs ys zs : lazy_list α) :
  (xs.append ys).append zs = xs.append (ys.append zs) :=
by induction xs; simp [append, *]

lemma append_bind {α β} (xs : lazy_list α) (ys : thunk (lazy_list α)) (f : α → lazy_list β) :
  (@lazy_list.append _ xs ys).bind f = (xs.bind f).append ((ys ()).bind f) :=
by induction xs; simp [lazy_list.bind, append, *, append_assoc, append, lazy_list.bind]

instance : is_lawful_monad lazy_list :=
{ pure_bind := by { intros, apply append_nil },
  bind_assoc := by { intros, dsimp [(>>=)], induction x; simp [lazy_list.bind, append_bind, *], },
  id_map :=
  begin
    intros,
    simp [(<$>)],
    induction x; simp [lazy_list.bind, *, singleton, append],
    ext ⟨ ⟩, refl,
  end }

/-- Try applying function `f` to every element of a `lazy_list` and
return the result of the first attempt that succeeds. -/
def mfirst {m} [alternative m] {α β} (f : α → m β) : lazy_list α → m β
| nil := failure
| (cons x xs) :=
  f x <|> mfirst (xs ())

/-- Membership in lazy lists -/
protected def mem {α} (x : α) : lazy_list α → Prop
| lazy_list.nil := false
| (lazy_list.cons y ys) := x = y ∨ mem (ys ())

instance {α} : has_mem α (lazy_list α) :=
⟨ lazy_list.mem ⟩

instance mem.decidable {α} [decidable_eq α] (x : α) : Π xs : lazy_list α, decidable (x ∈ xs)
| lazy_list.nil := decidable.false
| (lazy_list.cons y ys) :=
  if h : x = y
    then decidable.is_true (or.inl h)
    else decidable_of_decidable_of_iff (mem.decidable (ys ())) (by simp [*, (∈), lazy_list.mem])

@[simp]
lemma mem_nil {α} (x : α) : x ∈ @lazy_list.nil α ↔ false := iff.rfl

@[simp]
lemma mem_cons {α} (x y : α) (ys : thunk (lazy_list α)) :
  x ∈ @lazy_list.cons α y ys ↔ x = y ∨ x ∈ ys () := iff.rfl

theorem forall_mem_cons {α} {p : α → Prop} {a : α} {l : thunk (lazy_list α)} :
  (∀ x ∈ @lazy_list.cons _ a l, p x) ↔ p a ∧ ∀ x ∈ l (), p x :=
by simp only [has_mem.mem, lazy_list.mem, or_imp_distrib, forall_and_distrib, forall_eq]

/-! ### map for partial functions -/

/-- Partial map. If `f : Π a, p a → β` is a partial function defined on
  `a : α` satisfying `p`, then `pmap f l h` is essentially the same as `map f l`
  but is defined only when all members of `l` satisfy `p`, using the proof
  to apply `f`. -/
@[simp] def pmap {α β} {p : α → Prop} (f : Π a, p a → β) :
  Π l : lazy_list α, (∀ a ∈ l, p a) → lazy_list β
| lazy_list.nil         H := lazy_list.nil
| (lazy_list.cons x xs) H := lazy_list.cons (f x (forall_mem_cons.1 H).1)
                               (pmap (xs ()) (forall_mem_cons.1 H).2)

/-- "Attach" the proof that the elements of `l` are in `l` to produce a new `lazy_list`
  with the same elements but in the type `{x // x ∈ l}`. -/
def attach {α} (l : lazy_list α) : lazy_list {x // x ∈ l} := pmap subtype.mk l (λ a, id)

instance {α} [has_repr α] : has_repr (lazy_list α) :=
⟨ λ xs, repr xs.to_list ⟩

end lazy_list


import category_theory.adjunction

namespace category_theory

variables {C D : Type*} [category C] [category D]

structure unit_desc (F : C ⥤ D) :=
( obj : D → C )
( unit : Π (X : D), X ⟶ F.obj (obj X) )
( desc : Π {X Y}, (X ⟶ F.obj Y) → (obj X ⟶ Y))
( unit_comp_desc : Π {X Y} (f : X ⟶ F.obj Y), unit X ≫ F.map (desc f) = f )
( desc_unit : Π {X Y} (f : obj X ⟶ Y), desc (unit X ≫ F.map f) = f )

variables {F : C ⥤ D} (ud : unit_desc F)

private lemma unit_desc_ext
  {X : D} {Y : C} {f g : ud.obj X ⟶ Y}
  (H : ud.unit X ≫ F.map f = ud.unit X ≫ F.map g) : f = g :=
by rw [← ud.desc_unit f, H, ud.desc_unit]

def unit_desc.to_functor : D ⥤ C :=
{ obj := ud.obj,
  map := λ X Y f, ud.desc (f ≫ ud.unit Y),
  map_id' := λ X, by rw [category.id_comp, ← category.comp_id (ud.unit X), ← F.map_id,
      ud.desc_unit],
  map_comp' := λ X Y Z f g, unit_desc_ext ud $
    by rw [F.map_comp, ud.unit_comp_desc, ← category.assoc, ud.unit_comp_desc,
      category.assoc, category.assoc, ud.unit_comp_desc] }

def unit_desc.adjunction :
  ud.to_functor ⊣ F :=
adjunction.mk_of_hom_equiv
{ hom_equiv := λ X Y,
  { to_fun := λ f, ud.unit X ≫ F.map f,
    inv_fun := λ f, ud.desc f,
    left_inv := λ f, ud.desc_unit f,
    right_inv := λ f, ud.unit_comp_desc f },
  hom_equiv_naturality_left_symm' :=
    begin
      intros X' X Y f g,
      dsimp [unit_desc.to_functor],
      apply unit_desc_ext ud,
      rw [ud.unit_comp_desc, F.map_comp, ← category.assoc,
        ud.unit_comp_desc, category.assoc, ud.unit_comp_desc],
    end,
  hom_equiv_naturality_right' :=
    begin
      intros X Y Y' f g,
      dsimp [unit_desc.to_functor],
      rw [F.map_comp, category.assoc]
    end }

structure counit_lift (F : C ⥤ D) :=
( obj : D → C )
( counit : Π (X : D), F.obj (obj X) ⟶ X )
( lift : Π {X Y}, (F.obj X ⟶ Y) → (X ⟶ obj Y))
( lift_comp_counit : Π {X Y} (f : F.obj X ⟶ Y), F.map (lift f) ≫ counit Y = f )
( lift_counit : Π {X Y} (f : X ⟶ obj Y), lift (F.map f ≫ counit Y) = f )

variable (cl : counit_lift F)

private lemma counit_lift_ext
  {X : C} {Y : D} {f g : X ⟶ cl.obj Y}
  (H : F.map f ≫ cl.counit Y = F.map g ≫ cl.counit Y) : f = g :=
by rw [← cl.lift_counit f, H, cl.lift_counit]

def counit_lift.to_functor : D ⥤ C :=
{ obj := cl.obj,
  map := λ X Y f, cl.lift (cl.counit X ≫ f),
  map_id' := λ X, by rw [category.comp_id, ← category.id_comp (cl.counit X), ← F.map_id,
      cl.lift_counit],
  map_comp' := λ X Y Z f g, counit_lift_ext cl $
    by rw [F.map_comp, cl.lift_comp_counit, category.assoc, cl.lift_comp_counit,
      ← category.assoc, ← category.assoc, cl.lift_comp_counit] }

def counit_lift.adjunction :
  F ⊣ cl.to_functor :=
adjunction.mk_of_hom_equiv
{ hom_equiv := λ X Y,
  { to_fun := λ f, cl.lift f,
    inv_fun := λ f, F.map f ≫ cl.counit Y,
    left_inv := λ f, cl.lift_comp_counit f,
    right_inv := λ f, cl.lift_counit f },
  hom_equiv_naturality_left_symm' :=
    begin
      intros X Y Y' f g,
      dsimp [counit_lift.to_functor],
      rw [F.map_comp, category.assoc]
    end,
  hom_equiv_naturality_right' :=
    begin
      intros X' X Y f g,
      dsimp [counit_lift.to_functor],
      apply counit_lift_ext cl,
      rw [cl.lift_comp_counit, F.map_comp, category.assoc,
        cl.lift_comp_counit, ← category.assoc, cl.lift_comp_counit],
    end }

end category_theory


import condensed.ab
import condensed.top_comparison
import condensed.adjunctions_module
import condensed.extr.equivalence
import category_theory.sites.limits
import algebra.category.Group.filtered_colimits

import for_mathlib.abelian_category
import for_mathlib.module_epi

universe u

open category_theory

/-

S extr. disc.
A cond ab group.

A ↦ Hom_{CondSet}(S,A) = A(S) commutes with limits and colimits.

A(-) commutes with finite products, in Ab, finite products = finite coproducts.

Z[S] is projective.

A -> B epi, Hom(Z[S],A) -> Hom(Z[S],B) -- A(S) -> B(S) WTS: surjective.

1. If S is extr. disc. and A -> B is an epi of cond ab, then A(S) -> B(S) surjective.
  B -> B/A

-/

noncomputable theory

variables (R : Type (u + 1)) [ring R]

def CondensedMod.free (S : CondensedSet) : CondensedMod R :=
(CondensedSet_to_CondensedMod R).obj $ S

local notation R`[`S`]` := CondensedMod.free R S.to_Condensed

variable {R}

def Condensed.forgetMod (S : CondensedMod R) : CondensedSet :=
(CondensedMod_to_CondensedSet R).obj S

def quiver.hom.forgetMod {S T : CondensedMod R} (e : S ⟶ T) :
  S.forgetMod ⟶ T.forgetMod :=
(CondensedMod_to_CondensedSet R).map e

variable (R)

namespace CondensedMod

def to_free (S : CondensedSet) : S ⟶ (free R S).forgetMod :=
(CondensedMod_CondensedSet_adjunction R).hom_equiv _ _ $ 𝟙 _

def free_lift {S : CondensedSet} {A : CondensedMod R} (e : S ⟶ A.forgetMod) :
  free R S ⟶ A :=
((CondensedMod_CondensedSet_adjunction R).hom_equiv _ _).symm e

@[simp]
lemma to_free_free_lift {S : CondensedSet} {A : CondensedMod R} (e : S ⟶ A.forgetMod) :
  to_free R S ≫ (free_lift R e).forgetMod = e :=
begin
  dsimp only [Condensed.forgetMod, to_free, free_lift, quiver.hom.forgetMod],
  rw [adjunction.hom_equiv_unit, adjunction.hom_equiv_counit, category.assoc,
    category_theory.functor.map_id, category.id_comp, functor.map_comp,
    (CondensedMod_CondensedSet_adjunction R).unit_naturality_assoc,
    adjunction.right_triangle_components, category.comp_id],
end

lemma free_lift_unique {S : CondensedSet} {A : CondensedMod R}
  (e : S ⟶ A.forgetMod) (f : free R S ⟶ A)
  (h : to_free R S ≫ f.forgetMod = e) : f = free_lift R e :=
begin
  apply_fun ((CondensedMod_CondensedSet_adjunction R).hom_equiv _ _),
  dsimp [free_lift],
  rw equiv.apply_symm_apply,
  exact h
end

@[ext]
lemma free_hom_ext {S : CondensedSet} {A : CondensedMod R} (f g : free R S ⟶ A)
  (h : to_free R S ≫ f.forgetMod = to_free R S ≫ g.forgetMod) : f = g :=
by rw [free_lift_unique _ _ f rfl, free_lift_unique _ _ g rfl, h]

end CondensedMod

@[simps]
def hom_equiv_evaluation_Mod (S : Profinite.{u}) (A : CondensedMod R) :
  (R[S] ⟶ A) ≃ ((CondensedMod_to_CondensedSet R ⋙ CondensedSet.evaluation S).obj A) :=
((CondensedMod_CondensedSet_adjunction R).hom_equiv S.to_Condensed A).trans $
  (equiv_of_fully_faithful $ Sheaf_to_presheaf.{u} _ _).trans $ yoneda'_equiv _ _ .

lemma hom_equiv_evaluation_Mod_apply_eq_app_id (S : Profinite.{u}) (A : CondensedMod R)
  (f : R[S] ⟶ A) : hom_equiv_evaluation_Mod R S A f =
  (CondensedMod.to_free R _ ≫ (CondensedMod_to_CondensedSet R).map f).val.app _ ⟨𝟙 _⟩ := rfl

open_locale big_operators
lemma exists_hom_equiv_Mod_evaluation_symm_app_eq
  (S : Profinite.{u}) (A : CondensedMod R)
  (f : A.val.obj (opposite.op S)) : ∃ (t : R[S].val.obj (opposite.op S)),
  ((hom_equiv_evaluation_Mod R S A).symm f).val.app _ t = f :=
begin
  -- This proof can probably be made simpler using some adjunction voodoo...
  use (hom_equiv_evaluation_Mod _ _ _) (𝟙 _),
  dsimp [hom_equiv_evaluation_Mod, adjunction.whisker_right],
  simp_rw [← comp_apply, ← nat_trans.comp_app],
  erw [category.comp_id, proetale_topology.to_sheafify_sheafify_lift],
  dsimp [functor.preimage, full.preimage, yoneda'_equiv, CondensedMod_to_CondensedSet,
    functor.right_unitor, ulift_functor, Profinite.to_Condensed],
  have := (Module.adj R).right_triangle_components,
  apply_fun (λ e, e f) at this,
  dsimp at this,
  convert this,
  dsimp [Module.adj],
  erw finsupp.lift_symm_apply ((A.val.obj (opposite.op S)) →₀ R) R _ linear_map.id f,
  erw finsupp.lift_symm_apply (ulift (S ⟶ S) →₀ R) R _ linear_map.id (ulift.up (𝟙 S)),
  simp,
end

local attribute [instance] limits.has_zero_object.has_zero

open category_theory.limits
open opposite

-- sanity check
example (S : Profinite.{u}) : preserves_zero_objects
  (Condensed.evaluation (Module.{u+1} R) S) :=
infer_instance

instance projective_free_CondensedMod (S : Profinite.{u}) [projective S] :
  projective (R[S]) :=
{ factors := λ A B f g hg, begin
    rw epi_iff_is_zero_cokernel at hg,
    -- this follows from the fact that evaluation preserves colimits.
    let e : (cokernel g).val.obj (op S) ≅ cokernel (g.val.app (op S)) := begin
      refine (is_colimit_of_preserves (Condensed.evaluation (Module R) S)
      (colimit.is_colimit _)).cocone_point_unique_up_to_iso
        (colimit.is_colimit _) ≪≫ has_colimit.iso_of_nat_iso _,
      refine nat_iso.of_components _ _,
      { rintros (a|b), exact eq_to_iso rfl, exact eq_to_iso rfl },
      rintros (a|b) (c|d) (e|e),
      all_goals { dsimp },
      all_goals { simp, try { refl } },
    end,
    replace hg := is_zero_of_preserves (Condensed.evaluation (Module.{u+1} R) S) hg,
    dsimp [Condensed.evaluation] at hg,
    replace hg := is_zero_of_iso_of_zero hg e,
    rw ← epi_iff_is_zero_cokernel at hg,
    replace hg : function.surjective (g.val.app (op S)) := begin
      resetI,
      apply Module.surjective_of_epi,
    end,
    let f₁ := hom_equiv_evaluation_Mod _ _ _ f,
    dsimp at f₁,
    obtain ⟨f',h⟩ := hg f₁,
    use (hom_equiv_evaluation_Mod _ _ _).symm f',
    apply_fun (hom_equiv_evaluation_Mod _ _ _),
    change _ = f₁,
    rw [← h, hom_equiv_evaluation_Mod_apply, Sheaf.hom.comp_val, nat_trans.comp_app],
    dsimp [hom_equiv_evaluation_Mod, adjunction.whisker_right, functor.associator],
    erw [category.id_comp, ← comp_apply, ← comp_apply, ← category.assoc, ← nat_trans.comp_app,
      ← nat_trans.comp_app],
    erw proetale_topology.to_sheafify_sheafify_lift,
    dsimp [functor.preimage, full.preimage, yoneda'_equiv, ulift_functor,
      CondensedMod_to_CondensedSet, Profinite.to_Condensed],

    congr' 1,
    have := (Module.adj R).right_triangle_components,
    apply_fun (λ e, e f') at this,
    dsimp at this,
    convert this,

    dsimp [Module.adj],
    erw finsupp.lift_symm_apply ((A.val.obj (opposite.op S)) →₀ R) R _ linear_map.id f',
    erw finsupp.lift_symm_apply (ulift (S ⟶ S) →₀ R) R _ linear_map.id (ulift.up (𝟙 S)),

    simp,
  end } .

lemma is_zero_iff_forall_zero_Mod {A : CondensedMod R} :
  is_zero A ↔ ∀ (S : ExtrDisc), is_zero (A.val.obj (op S.val)) :=
begin
  split,
  { intros h S,
    apply is_zero_of_preserves (Condensed.evaluation (Module.{u+1} R) S.val),
    assumption },
  { intro h,
    let FF := ((Sheaf_to_presheaf _ _ : CondensedMod R ⥤ _) ⋙
      (whiskering_left _ _ _).obj (ExtrDisc_to_Profinite.op)),
    suffices : A ≅ ⊥_ _, by { apply is_zero_of_iso_of_zero _ this.symm, exact is_zero_initial },
    let e : Π S : ExtrDisc, (A.val.obj (op S.val)) ≅ ⊥_ _ :=
      λ S, is_zero.iso (h S) is_zero_initial,
    symmetry,
    apply (colimit.is_colimit _).cocone_point_unique_up_to_iso (_ : is_colimit (as_empty_cocone _)),
    haveI : creates_colimits FF := @Condensed_to_ExtrDisc_presheaf_creates_colimits.{u u+2}
        (@Module.{u+1 u+1} R _) (@Module.Module_category.{u+1 u+1} R _) _ _ _ _ _,
    haveI := reflects_colimits_of_size_shrink.{0 u+1 0 u+1} FF,
    apply (is_colimit_of_reflects.{0 0 (u+1) (u+1) (u+2) (u+2)} FF),
    apply evaluation_jointly_reflects_colimits,
    intros S,
    have := is_colimit_empty_cocone_equiv (Module R)
      (as_empty_cocone (A.val.obj (op S.unop.val)))
      (((evaluation ExtrDiscᵒᵖ (Module R)).obj S).map_cocone (FF.map_cocone (as_empty_cocone A)))
      (eq_to_iso rfl),
    apply this.to_fun,
    specialize e S.unop,
    let t : as_empty_cocone (A.val.obj (op (unop S).val)) ≅ as_empty_cocone (⊥_ _) :=
      cocones.ext e (by rintro ⟨⟨⟩⟩),
    apply is_colimit.of_iso_colimit _ t.symm,
    refine ⟨λ r, _, _, _⟩,
    { dsimp, refine initial.to r.X, },
    { rintro s ⟨⟨⟩⟩ },
    { intros s m h, apply is_zero.eq_of_src, apply is_zero_initial } }
end

lemma is_epi_iff_forall_surjective_Mod {A B : CondensedMod R} (f : A ⟶ B) :
  epi f ↔ ∀ (S : ExtrDisc), function.surjective (f.val.app (op S.val)) :=
begin
  rw epi_iff_is_zero_cokernel,
  rw is_zero_iff_forall_zero_Mod,
  apply forall_congr (λ S, _),
  let FF := Condensed.evaluation (Module.{u+1} R) S.val,
  haveI : preserves_colimits FF := infer_instance,
  let e : (cokernel f).val.obj (op S.val) ≅ cokernel (f.val.app (op S.val)) := begin
    change FF.obj (cokernel f) ≅ cokernel (FF.map f),
    change (FF.map_cocone _).X ≅ _,
    refine (is_colimit_of_preserves FF (colimit.is_colimit _)).cocone_point_unique_up_to_iso
      (colimit.is_colimit _) ≪≫ _,
    dsimp,
    apply has_colimit.iso_of_nat_iso,
    -- This isomorphism is probably somewhere in mathlib... or somewhere in this repo.
    refine nat_iso.of_components _ _,
    { rintros (i|i),
      { exact iso.refl _ },
      { exact iso.refl _ } },
    { rintros (i|i) (j|j) (f|f),
      { dsimp, simpa, },
      { dsimp, simp, },
      { dsimp, simpa, },
      { dsimp, simpa, } },
  end,
  have : is_zero ((cokernel f).val.obj (op S.val)) ↔ is_zero (cokernel (f.val.app (op S.val))),
  { split,
    { intro h, apply is_zero_of_iso_of_zero h e, },
    { intro h, apply is_zero_of_iso_of_zero h e.symm, } },
  rw [this, ← epi_iff_is_zero_cokernel],
  clear e,
  split,
  { introsI h,
    apply Module.surjective_of_epi },
  { intros h, exact concrete_category.epi_of_surjective (f.val.app (op S.val)) h}
end

theorem CondensedMod_has_enough_projectives_aux (A : CondensedMod R) :
  ∃ (B : CondensedMod R) (hB : projective B) (f : B ⟶ A), epi f :=
begin
  let II := Σ (S : ExtrDisc), A.val.obj (op S.val),
  let X : II → CondensedMod R := λ i, R[i.1.val],
  let f : Π i, X i ⟶ A := λ i, (hom_equiv_evaluation_Mod _ i.1.val A).symm i.2,

  -- Move this.
  haveI : has_colimits (CondensedMod R) := begin
    change has_colimits (Sheaf _ _),
    exact category_theory.Sheaf.category_theory.limits.has_colimits.{(u+2) u (u+1)},
  end,

  use [∐ X, infer_instance, sigma.desc f],

  rw is_epi_iff_forall_surjective_Mod,

  intros S t,
  obtain ⟨w,hw⟩ := exists_hom_equiv_Mod_evaluation_symm_app_eq R S.val A t,
  use (sigma.ι X ⟨S,t⟩).val.app (op S.val) w,
  rw [← comp_apply, ← nat_trans.comp_app],
  change (((sigma.ι X ⟨S,t⟩) ≫ sigma.desc f).val.app (op S.val)) w = _,
  erw colimit.ι_desc,
  exact hw,
end

instance CondensedMod_has_enough_projective : enough_projectives (CondensedMod R) :=
begin
  constructor,
  intros B,
  obtain ⟨X,hX,f,hf⟩ := CondensedMod_has_enough_projectives_aux R B,
  resetI,
  constructor,
  refine ⟨X,hX,f,hf⟩,
end


-- COMPLETENESS

import syntax
import tableau
import soundness
-- import modelgraphs

open has_sat

-- Each local rule preserves truth "upwards"
lemma localRuleTruth {W : Type} {M : kripkeModel W} {w : W} {X : finset formula} {B : finset (finset formula)} :
  localRule X B → (∃ Y ∈ B, (M,w) ⊨ Y) → (M,w) ⊨ X :=
begin
  intro r,
  cases r,
  case localRule.bot {
    simp,
  },
  case localRule.not {
    simp,
  },
  case localRule.neg : a f notnotf_in_a {
    intro hyp,
    rcases hyp with ⟨b, b_in_B, w_sat_b⟩,
    intros phi phi_in_a,
    have b_is_af : b = insert f (a \ {~~f}), {
      simp at *, subst b_in_B,
    },
    have phi_in_b_or_is_f : phi ∈ b ∨ phi = ~~f, {
      rw b_is_af,
      simp,
      finish,
    },
    cases phi_in_b_or_is_f with phi_in_b phi_is_notnotf,
    {
      apply w_sat_b,
      exact phi_in_b,
    },
    {
      rw phi_is_notnotf,
      unfold evaluate at *,
      simp, -- this removes double negation
      apply w_sat_b,
      rw b_is_af ,
      simp at *,
    },
  },
  case localRule.con : a f g fandg_in_a {
    intro hyp,
    rcases hyp with ⟨b, b_in_B, w_sat_b⟩,
    intros phi phi_in_a,
    simp at b_in_B,
    have b_is_fga : b = insert f (insert g (a \ {f⋏g})), {
      subst b_in_B, ext1, simp,
    },
    have phi_in_b_or_is_fandg : phi ∈ b ∨ phi = f⋏g, {
      rw b_is_fga,
      simp,
      finish,
    },
    cases phi_in_b_or_is_fandg with phi_in_b phi_is_fandg,
    {
      apply w_sat_b,
      exact phi_in_b,
    },
    { rw phi_is_fandg,
      unfold evaluate at *,
      split,
      { apply w_sat_b, rw b_is_fga, simp, },
      { apply w_sat_b, rw b_is_fga, simp, },
    },
  },
  case localRule.nCo : a f g not_fandg_in_a {
    intro hyp,
    rcases hyp with ⟨b, b_in_B, w_sat_b⟩,
    intros phi phi_in_a,
    simp at *,
    have phi_in_b_or_is_notfandg : phi ∈ b ∨ phi = ~(f⋏g), {
      cases b_in_B ; { rw b_in_B, simp, finish, },
    },
    cases b_in_B,
    { -- b contains ~f
      cases phi_in_b_or_is_notfandg with phi_in_b phi_def,
      { exact w_sat_b phi phi_in_b, },
      {
        rw phi_def,
        unfold evaluate,
        rw b_in_B at w_sat_b,
        specialize w_sat_b (~f),
        rw not_and_distrib,
        left,
        unfold evaluate at w_sat_b,
        apply w_sat_b,
        finish,
      },
    },
    { -- b contains ~g
     cases phi_in_b_or_is_notfandg with phi_in_b phi_def,
      { exact w_sat_b phi phi_in_b, },
      {
        rw phi_def,
        unfold evaluate,
        rw b_in_B at w_sat_b,
        specialize w_sat_b (~g),
        rw not_and_distrib,
        right,
        unfold evaluate at w_sat_b,
        apply w_sat_b,
        finish,
      },
    },
  },
end

-- Each local rule is "complete", i.e. preserves satisfiability "upwards"
lemma localRuleCompleteness {X : finset formula} { B : finset (finset formula) } :
  localRule X B → (∃ Y ∈ B, satisfiable Y) → satisfiable X :=
begin
  intro lr,
  intro sat_B,
  rcases sat_B with ⟨Y, Y_in_B, sat_Y⟩,
  unfold satisfiable at *,
  rcases sat_Y with ⟨W,M,w,w_sat_Y⟩,
  use [W,M,w],
  apply localRuleTruth lr,
  tauto,
end

-- Lemma 11 (but rephrased to be about local tableau!?)
lemma inconsUpwards {X} {ltX : localTableau X} : (Π en ∈ endNodesOf ⟨X, ltX⟩, inconsistent en) → inconsistent X :=
begin
  intro lhs,
  unfold inconsistent at *,
  let leafTableaus : Π en ∈ endNodesOf ⟨X, ltX⟩, closedTableau en := λ Y YinEnds, (lhs Y YinEnds).some,
  split,
  exact closedTableau.loc ltX leafTableaus,
end

-- Converse of Lemma 11
lemma consToEndNodes {X} {ltX : localTableau X} : consistent X → (∃ en ∈ endNodesOf ⟨X, ltX⟩, consistent en) :=
begin
  intro consX,
  unfold consistent at *,
  have claim := not.imp consX (@inconsUpwards X ltX),
  simp at claim,
  tauto,
end

def projOfConsSimpIsCons : Π {X ϕ}, consistent X → simple X → ~□ϕ ∈ X → consistent (projection X ∪ {~ϕ}) :=
begin
  intros X ϕ consX simpX notBoxPhi_in_X,
  unfold consistent at *,
  unfold inconsistent at *,
  by_contradiction h,
  simp at *,
  cases h with ctProj,
  have ctX : closedTableau X, {
    apply closedTableau.atm notBoxPhi_in_X simpX,
    simp, exact ctProj,
  },
  cases consX, tauto,
end

lemma locTabEndSatThenSat {X Y} (ltX : localTableau X) (Y_endOf_X : Y ∈ endNodesOf ⟨X, ltX⟩) :
  satisfiable Y → satisfiable X :=
begin
  intro satY,
  induction ltX,
  case byLocalRule : X B lr next IH {
    apply localRuleCompleteness lr,
    cases lr,
    case localRule.bot : W bot_in_W {
      simp at *,
      exact Y_endOf_X,
    },
    case localRule.not : _ ϕ h {
      simp at *,
      exact Y_endOf_X,
    },
    case localRule.neg : Z ϕ notNotPhi_inX {
      simp at *,
      specialize IH (insert ϕ (Z.erase (~~ϕ))),
      simp at IH,
      apply IH,
      rcases Y_endOf_X with ⟨W, W_def, Y_endOf_W⟩,
      subst W_def,
      exact Y_endOf_W,
    },
    case localRule.con : Z ϕ ψ _ {
      simp at *,
      specialize IH (insert ϕ (insert ψ (Z.erase (ϕ⋏ψ)))),
      simp at IH,
      apply IH,
      rcases Y_endOf_X with ⟨W, W_def, Y_endOf_W⟩,
      subst W_def,
      exact Y_endOf_W,
    },
    case localRule.nCo : Z ϕ ψ _ {
      simp at *,
      rcases Y_endOf_X with ⟨W, W_def, Y_endOf_W⟩,
      cases W_def,
      all_goals { subst W_def, },
      { specialize IH (insert (~ϕ) (Z.erase (~(ϕ⋏ψ)))),
        simp at IH,
        use (insert (~ϕ) (Z.erase (~(ϕ⋏ψ)))),
        split,
        { left, refl, },
        { apply IH, exact Y_endOf_W, }
      },
      { specialize IH (insert (~ψ) (Z.erase (~(ϕ⋏ψ)))),
        simp at IH,
        use (insert (~ψ) (Z.erase (~(ϕ⋏ψ)))),
        split,
        { right, refl, },
        { apply IH, exact Y_endOf_W, }
      },
    },
  },
  case sim : X simpX {
    finish,
  },
end

lemma almostCompleteness : Π n X, lengthOfSet X = n → consistent X → satisfiable X :=
begin
  intro n,
  apply nat.strong_induction_on n,
  intros n IH,
  intros X lX_is_n consX,
  refine if simpX : simple X then _ else _,
  -- CASE 1: X is simple
  rw Lemma1_simple_sat_iff_all_projections_sat simpX,
  split,
  { -- show that X is not closed
    by_contradiction h,
    unfold consistent at consX,
    unfold inconsistent at consX,
    simp at consX,
    cases consX, apply consX,
    unfold closed at h,
    refine if botInX : ⊥ ∈ X then _ else _,
    { apply closedTableau.loc, rotate, apply localTableau.byLocalRule,
      exact localRule.bot botInX,
      intros Y YinEmpty, cases YinEmpty,
      rw botNoEndNodes, intros Y YinEmpty, cases YinEmpty,
    },
    { have f1 : ∃ (f : formula) (H : f ∈ X), ~f ∈ X := by tauto,
      have : nonempty (closedTableau X), {
      rcases f1 with ⟨f, f_in_X, notf_in_X⟩,
      fconstructor,
      apply closedTableau.loc, rotate, apply localTableau.byLocalRule,
      apply localRule.not ⟨f_in_X , notf_in_X⟩,
      intros Y YinEmpty, cases YinEmpty,
      rw notNoEndNodes, intros Y YinEmpty, cases YinEmpty,
      },
      exact classical.choice this,
    },
  },
  { -- show that all projections are sat
    intros R notBoxR_in_X,
    apply IH (lengthOfSet (projection X ∪ {~R})),
    { -- projection decreases lengthOfSet
      subst lX_is_n,
      exact atmRuleDecreasesLength notBoxR_in_X,
    },
    { refl, },
    { exact projOfConsSimpIsCons consX simpX notBoxR_in_X, },
  },
  -- CASE 2: X is not simple
  rename simpX notSimpX,
  rcases notSimpleThenLocalRule notSimpX with ⟨B,lrExists⟩,
  have lr := classical.choice lrExists,
  have rest : Π (Y : finset formula), Y ∈ B → localTableau Y, {
    intros Y Y_in_B,
    set N := hasLength.lengthOf Y,
    exact classical.choice (existsLocalTableauFor N Y (by refl))
  },
  rcases @consToEndNodes X (localTableau.byLocalRule lr rest) consX with ⟨E, E_endOf_X, consE⟩,
  have satE : satisfiable E, {
    apply IH (lengthOfSet E),
    { -- end Node of local rule is LT
      subst lX_is_n,
      apply endNodesOfLocalRuleLT E_endOf_X,
    },
    { refl, },
    { exact consE, },
  },
  exact locTabEndSatThenSat (localTableau.byLocalRule lr rest) E_endOf_X satE,
end

-- Theorem 4, page 37
theorem completeness : ∀ X, consistent X ↔ satisfiable X :=
begin
  intro X,
  split,
  { intro X_is_consistent,
    let n := lengthOfSet X,
    apply almostCompleteness n X (by refl) X_is_consistent,
  },
  -- use Theorem 2:
  exact correctness X,
end

lemma singletonCompleteness : ∀ φ, consistent {φ} ↔ satisfiable φ :=
begin
  intro f,
  have := completeness {f},
  simp only [singletonSat_iff_sat] at *,
  tauto,
end


@[inline] def ok {ε : Type u} (a : α) : Except ε α := pure a

/- simple exception handling monad -/
def divide (x: Float ) (y: Float): ExceptT String Id Float :=
  if y == 0 then
    throw "can't divide by zero"
  else
    ok (x / y)

#eval divide 5 0  -- Except.error "can't divide by zero"

#check (Except String) -- Type u_1 → Type (max 0 u_1)

#check ExceptT String Id

def test :=
  divide 5 0

#check test  -- ExceptT String Id Float
#eval test -- Except.error "can't divide by zero"
#eval test.run -- this was done implicitly for us
#eval test |>.run -- this is the best way to call run if run takes arguments.

def testCatch :=
    try
      let r ← divide 8 0 -- 'r' is type Float
      return toString r
    catch e =>
      return s!"Caught exception: {e}"

#check testCatch -- ExceptT String Id String
#eval testCatch -- Caught exception: can't divide by zero

/- unwrap Except using match -/
def testUnwrap : String := Id.run do
    let r := divide 8 0 -- r is type ExceptT String Id Float
    match r with
    | .ok a => toString a -- 'a' is type Float
    | .error e => s!"Caught exception: {e}"

#check testUnwrap -- String
#eval testUnwrap -- "Caught exception: can't divide by zero"

/- unwrap Except using coercion -/
instance : Coe (ExceptT α Id α) α where
  coe a := match a with
    | .ok v => v
    | .error v => v

def testCoerce : String :=
  let act : ExceptT String Id String := do
    let r ← divide 8 0
    return r.toString
  act

#check testCoerce -- String
#eval testCoerce  -- "can't divide by zero"

/- adding StateT -/

def divideLog (x: Float ) (y: Float): StateT Nat Id Float :=
  if y == 0 then
    return 0
  else do
    modify fun s => s + 1
    return x / y

#check divideLog              -- Float → Float → StateT Nat Id Float
#reduce StateT Nat Id Float   -- Nat → Float × Nat

#eval divideLog 8 4 0         -- (2.000000, 1)
#eval (divideLog 8 4).run 0   -- (2.000000, 1)
#eval divideLog 8 4 |>.run 0  -- (2.000000, 1)

def testDivideLog := do
  let mut state := 0
  for x in [0:10] do
    for y in [0:10] do
      let r ← divideLog x.toFloat y.toFloat |>.run state
      state := r.2
  state

#eval testDivideLog -- 90

/- chaining monads using bind -/
def divideIt (x:Float) (y:Float) : StateT Nat (ExceptT String Id) Float :=
  if y == 0 then
    throw "can't divide by zero"
  else
    bind (modify fun s => s + 1) (fun _ => pure (x / y))

#check divideIt
#reduce StateT Nat (ExceptT String Id) Float
#eval divideIt 5 2 |>.run 0 -- Except.ok (5.000000, 1)

def testIt := do
  let mut log := 0
  for x in [0:10] do
    for y in [0:10] do
      try
        let r ← divideIt x.toFloat y.toFloat |>.run log
        log := r.2
      catch _  =>
        ok ()
  ok log

#eval testIt -- 90

/- using do notation -/
def divideDo (x:Float) (y:Float) : (StateT Nat (ExceptT String Id)) Float := do
  if y == 0 then
    throw "can't divide by zero"
  else
    modify fun s => s + 1
    pure (x / y)

#eval divideDo 5 2 |>.run 0 -- Except.ok (2.500000, 1)

/- Adding ReadeT monad -/
def divideWithArgs (x:Float) (y:Float) : ReaderT (List String) (StateT Nat (ExceptT String Id)) Float :=
  bind (modify fun s => s + 1) fun _ =>
    bind (get) fun s =>
      bind (read) fun args =>
        if (s > 10 && args.contains "--limit") then
          throw "too many divides"
        else if y == 0 then
          throw "can't divide by zero"
        else
          pure (x / y)

#reduce ReaderT (List String) (StateT Nat (ExceptT String Id)) Float -- List String → Nat → Except String (Float × Nat)
#eval divideWithArgs 5 2 |>.run [] |>.run 0 -- Except.ok (2.500000, 1)
#eval divideWithArgs 5 0 |>.run [] |>.run 0 -- Except.error "can't divide by zero"
#eval divideWithArgs 5 2 |>.run ["--limit"] |>.run 10 -- Except.error "too many divides"

def divideWithArgsDo (x:Float) (y:Float) : ReaderT (List String) (StateT Nat (ExceptT String Id)) Float := do
  modify fun s => s + 1
  let s ← get
  let args ← read
  if (s > 10 && args.contains "--limit") then
    throw "too many divides"
  else if y == 0 then
    throw "can't divide by zero"
  else
    pure (x / y)

#eval divideWithArgsDo 5 2 |>.run [] |>.run 0 -- Except.ok (2.500000, 1)
#eval divideWithArgsDo 5 0 |>.run [] |>.run 0 -- Except.error "can't divide by zero"
#eval divideWithArgsDo 5 2 |>.run ["--limit"] |>.run 10 -- Except.error "too many divides"

/- proof that these are the same-/
example : divideWithArgs x y = divideWithArgsDo x y := by
  simp[divideWithArgs, divideWithArgsDo]    -- Goals accomplished 🎉

/- monad composition using lifting -/
def divideRefactored (x:Float) (y:Float) : ReaderT (List String) (StateT Nat (ExceptT String Id)) Float := do
  modify fun s => s + 1
  let s ← get
  let args ← read
  if (s > 10 && args.contains "--limit") then
    throw "too many divides"
  else
    divide x y

#eval divideRefactored 5 2 |>.run [] |>.run 0 -- Except.ok (2.500000, 1)
#eval divideRefactored 5 0 |>.run [] |>.run 0 -- Except.error "can't divide by zero"
#eval divideRefactored 5 2 |>.run ["--limit"] |>.run 10 -- Except.error "too many divides"

#reduce ReaderT (List String) (StateT Nat (ExceptT String Id)) Float
#reduce ExceptT String Id Float

def lift1 (x : ExceptT String Id Float) : (StateT Nat (ExceptT String Id)) Float :=
  x

#print lift1  -- fun x => liftM x

#reduce lift1 -- fun x s => Except.rec (fun a => Except.error a) (fun a => Except.ok (a, s)) x

#eval lift1 (divide 5 1) |>.run 3 -- Except.ok (5.000000, 3)

def lift2 (x : StateT Nat (ExceptT String Id) Float)  : ReaderT (List String) (StateT Nat (ExceptT String Id)) Float :=
  x

def transitive (x : StateT Nat (ExceptT String Id) Float) := do
  let x := lift1 (divide 5 1)
  lift2 x

#eval lift2 (lift1 (divide 5 1)) |>.run ["discarded", "state"] |>.run 4 -- Except.ok (5.000000, 4)

#reduce ExceptT String Id -- Except String α

/- some common patterns with structures and abbreviations -/
structure Config where
  x : Nat
  y : Nat
  deriving Repr

abbrev CoolM := StateT Config (ExceptT Nat Id)

def doSomethingCool : CoolM Nat :=do
  let s ← get
  set {s with x := 10}
  pure 0

#check doSomethingCool -- CoolM Nat
#reduce CoolM Nat      -- Config → Except Nat (Nat × Config)
#synth Monad CoolM     -- StateT.instMonadStateT
#eval doSomethingCool |>.run  {x := 0, y := 0} -- Except.ok (0, { x := 10, y := 0 })


/-
Copyright (c) 2021 Eric Wieser. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Eric Wieser
-/
import data.dfinsupp
import data.finsupp.basic
import algebra.module.linear_map

/-!
# Conversion between `finsupp` and homogenous `dfinsupp`

This module provides conversions between `finsupp` and `dfinsupp`.
It is in its own file since neither `finsupp` or `dfinsupp` depend on each other.

## Main definitions

* `finsupp.to_dfinsupp : (ι →₀ M) → (Π₀ i : ι, M)`
* `dfinsupp.to_finsupp : (Π₀ i : ι, M) → (ι →₀ M)`
* Bundled equiv versions of the above:
  * `finsupp_equiv_dfinsupp : (ι →₀ M) ≃ (Π₀ i : ι, M)`
  * `finsupp_add_equiv_dfinsupp : (ι →₀ M) ≃+ (Π₀ i : ι, M)`
  * `finsupp_lequiv_dfinsupp R : (ι →₀ M) ≃ₗ[R] (Π₀ i : ι, M)`

## Theorems

The defining features of these operations is that they preserve the function and support:

* `finsupp.to_dfinsupp_coe`
* `finsupp.to_dfinsupp_support`
* `dfinsupp.to_finsupp_coe`
* `dfinsupp.to_finsupp_support`

and therefore map `finsupp.single` to `dfinsupp.single` and vice versa:

* `finsupp.to_dfinsupp_single`
* `dfinsupp.to_finsupp_single`

as well as preserving arithmetic operations.

For the bundled equivalences, we provide lemmas that they reduce to `finsupp.to_dfinsupp`:

* `finsupp_add_equiv_dfinsupp_apply`
* `finsupp_lequiv_dfinsupp_apply`
* `finsupp_add_equiv_dfinsupp_symm_apply`
* `finsupp_lequiv_dfinsupp_symm_apply`

## Implementation notes

We provide `dfinsupp.to_finsupp` and `finsupp_equiv_dfinsupp` computably by adding
`[decidable_eq ι]` and `[Π m : M, decidable (m ≠ 0)]` arguments. To aid with definitional unfolding,
these arguments are also present on the `noncomputable` equivs.
-/

variables {ι : Type*} {R : Type*} {M : Type*}

/-! ### Basic definitions and lemmas -/
section defs

/-- Interpret a `finsupp` as a homogenous `dfinsupp`. -/
def finsupp.to_dfinsupp [has_zero M] (f : ι →₀ M) : Π₀ i : ι, M :=
⟦⟨f, f.support.1, λ i, (classical.em (f i = 0)).symm.imp_left (finsupp.mem_support_iff.mpr)⟩⟧

@[simp] lemma finsupp.to_dfinsupp_coe [has_zero M] (f : ι →₀ M) : ⇑f.to_dfinsupp = f := rfl

section
variables [decidable_eq ι] [has_zero M]

@[simp] lemma finsupp.to_dfinsupp_single (i : ι) (m : M) :
  (finsupp.single i m).to_dfinsupp = dfinsupp.single i m :=
by { ext, simp [finsupp.single_apply, dfinsupp.single_apply] }

variables [Π m : M, decidable (m ≠ 0)]

@[simp] lemma to_dfinsupp_support (f : ι →₀ M) : f.to_dfinsupp.support = f.support :=
by { ext, simp, }

/-- Interpret a homogenous `dfinsupp` as a `finsupp`.

Note that the elaborator has a lot of trouble with this definition - it is often necessary to
write `(dfinsupp.to_finsupp f : ι →₀ M)` instead of `f.to_finsupp`, as for some unknown reason
using dot notation or omitting the type ascription prevents the type being resolved correctly. -/
def dfinsupp.to_finsupp (f : Π₀ i : ι, M) : ι →₀ M :=
⟨f.support, f, λ i, by simp only [dfinsupp.mem_support_iff]⟩

@[simp] lemma dfinsupp.to_finsupp_coe (f : Π₀ i : ι, M) : ⇑f.to_finsupp = f := rfl
@[simp] lemma dfinsupp.to_finsupp_support (f : Π₀ i : ι, M) : f.to_finsupp.support = f.support :=
by { ext, simp, }

@[simp] lemma dfinsupp.to_finsupp_single (i : ι) (m : M) :
  (dfinsupp.single i m : Π₀ i : ι, M).to_finsupp = finsupp.single i m :=
by { ext, simp [finsupp.single_apply, dfinsupp.single_apply] }

@[simp] lemma finsupp.to_dfinsupp_to_finsupp (f : ι →₀ M) : f.to_dfinsupp.to_finsupp = f :=
finsupp.coe_fn_injective rfl

@[simp] lemma dfinsupp.to_finsupp_to_dfinsupp (f : Π₀ i : ι, M) : f.to_finsupp.to_dfinsupp = f :=
dfinsupp.coe_fn_injective rfl

end

end defs

/-! ### Lemmas about arithmetic operations -/
section lemmas

namespace finsupp

@[simp] lemma to_dfinsupp_zero [has_zero M] :
  (0 : ι →₀ M).to_dfinsupp = 0 := dfinsupp.coe_fn_injective rfl

@[simp] lemma to_dfinsupp_add [add_zero_class M] (f g : ι →₀ M) :
  (f + g).to_dfinsupp = f.to_dfinsupp + g.to_dfinsupp := dfinsupp.coe_fn_injective rfl

@[simp] lemma to_dfinsupp_neg [add_group M] (f : ι →₀ M) :
  (-f).to_dfinsupp = -f.to_dfinsupp := dfinsupp.coe_fn_injective rfl

@[simp] lemma to_dfinsupp_sub [add_group M] (f g : ι →₀ M) :
  (f - g).to_dfinsupp = f.to_dfinsupp - g.to_dfinsupp :=
dfinsupp.coe_fn_injective (sub_eq_add_neg _ _)

@[simp] lemma to_dfinsupp_smul [semiring R] [add_comm_monoid M] [module R M]
  (r : R) (f : ι →₀ M) : (r • f).to_dfinsupp = r • f.to_dfinsupp :=
dfinsupp.coe_fn_injective rfl

end finsupp

namespace dfinsupp
variables [decidable_eq ι]

@[simp] lemma to_finsupp_zero [has_zero M] [Π m : M, decidable (m ≠ 0)] :
  to_finsupp 0 = (0 : ι →₀ M) := finsupp.coe_fn_injective rfl

@[simp] lemma to_finsupp_add [add_zero_class M] [Π m : M, decidable (m ≠ 0)] (f g : Π₀ i : ι, M) :
  (to_finsupp (f + g) : ι →₀ M) = (to_finsupp f + to_finsupp g) :=
finsupp.coe_fn_injective $ dfinsupp.coe_add _ _

@[simp] lemma to_finsupp_neg [add_group M] [Π m : M, decidable (m ≠ 0)] (f : Π₀ i : ι, M) :
  (to_finsupp (-f) : ι →₀ M) = -to_finsupp f :=
finsupp.coe_fn_injective $ dfinsupp.coe_neg _

@[simp] lemma to_finsupp_sub [add_group M] [Π m : M, decidable (m ≠ 0)] (f g : Π₀ i : ι, M) :
  (to_finsupp (f - g) : ι →₀ M) = to_finsupp f - to_finsupp g :=
finsupp.coe_fn_injective $ dfinsupp.coe_sub _ _

@[simp] lemma to_finsupp_smul [semiring R] [add_comm_monoid M] [module R M]
  [Π m : M, decidable (m ≠ 0)]
  (r : R) (f : Π₀ i : ι, M) : (to_finsupp (r • f) : ι →₀ M) = r • to_finsupp f :=
finsupp.coe_fn_injective $ dfinsupp.coe_smul _ _

end dfinsupp

end lemmas

/-! ### Bundled `equiv`s -/

section equivs

/-- `finsupp.to_dfinsupp` and `dfinsupp.to_finsupp` together form an equiv. -/
@[simps {fully_applied := ff}]
def finsupp_equiv_dfinsupp [decidable_eq ι] [has_zero M] [Π m : M, decidable (m ≠ 0)] :
  (ι →₀ M) ≃ (Π₀ i : ι, M) :=
{ to_fun := finsupp.to_dfinsupp, inv_fun := dfinsupp.to_finsupp,
  left_inv := finsupp.to_dfinsupp_to_finsupp, right_inv := dfinsupp.to_finsupp_to_dfinsupp }

/-- The additive version of `finsupp.to_finsupp`. Note that this is `noncomputable` because
`finsupp.has_add` is noncomputable. -/
@[simps {fully_applied := ff}]
noncomputable def finsupp_add_equiv_dfinsupp
  [decidable_eq ι] [add_zero_class M] [Π m : M, decidable (m ≠ 0)] :
  (ι →₀ M) ≃+ (Π₀ i : ι, M) :=
{ to_fun := finsupp.to_dfinsupp, inv_fun := dfinsupp.to_finsupp,
  map_add' := finsupp.to_dfinsupp_add,
  .. finsupp_equiv_dfinsupp}

variables (R)

/-- The additive version of `finsupp.to_finsupp`. Note that this is `noncomputable` because
`finsupp.has_add` is noncomputable. -/
@[simps {fully_applied := ff}]
noncomputable def finsupp_lequiv_dfinsupp
  [decidable_eq ι] [semiring R] [add_comm_monoid M] [Π m : M, decidable (m ≠ 0)] [module R M] :
  (ι →₀ M) ≃ₗ[R] (Π₀ i : ι, M) :=
{ to_fun := finsupp.to_dfinsupp, inv_fun := dfinsupp.to_finsupp,
  map_smul' := finsupp.to_dfinsupp_smul,
  map_add' := finsupp.to_dfinsupp_add,
  .. finsupp_equiv_dfinsupp}

end equivs


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

/-!
# Differential objects in a category.

A differential object in a category with zero morphisms and a shift is
an object `X` equipped with
a morphism `d : X ⟶ X⟦1⟧`, such that `d^2 = 0`.

We build the category of differential objects, and some basic constructions
such as the forgetful functor, zero morphisms and zero objects, and the shift functor
on differential objects.
-/

open category_theory.limits

universes v u

namespace category_theory

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

variables [has_zero_morphisms C] [has_shift C]

/--
A differential object in a category with zero morphisms and a shift is
an object `X` equipped with
a morphism `d : X ⟶ X⟦1⟧`, such that `d^2 = 0`.
-/
@[nolint has_inhabited_instance]
structure differential_object :=
(X : C)
(d : X ⟶ X⟦1⟧)
(d_squared' : d ≫ d⟦1⟧' = 0 . obviously)

restate_axiom differential_object.d_squared'
attribute [simp] differential_object.d_squared

variables {C}

namespace differential_object

/--
A morphism of differential objects is a morphism commuting with the differentials.
-/
@[ext, nolint has_inhabited_instance]
structure hom (X Y : differential_object C) :=
(f : X.X ⟶ Y.X)
(comm' : X.d ≫ f⟦1⟧' = f ≫ Y.d . obviously)

restate_axiom hom.comm'
attribute [simp, reassoc] hom.comm

namespace hom

/-- The identity morphism of a differential object. -/
@[simps]
def id (X : differential_object C) : hom X X :=
{ f := 𝟙 X.X }

/-- The composition of morphisms of differential objects. -/
@[simps]
def comp {X Y Z : differential_object C} (f : hom X Y) (g : hom Y Z) : hom X Z :=
{ f := f.f ≫ g.f, }

end hom

instance category_of_differential_objects : category (differential_object C) :=
{ hom := hom,
  id := hom.id,
  comp := λ X Y Z f g, hom.comp f g, }

@[simp]

@[simp]
lemma comp_f {X Y Z : differential_object C} (f : X ⟶ Y) (g : Y ⟶ Z) :
  (f ≫ g).f = f.f ≫ g.f :=
rfl

variables (C)

/-- The forgetful functor taking a differential object to its underlying object. -/
def forget : (differential_object C) ⥤ C :=
{ obj := λ X, X.X,
  map := λ X Y f, f.f, }

instance forget_faithful : faithful (forget C) :=
{ }

instance has_zero_morphisms : has_zero_morphisms (differential_object C) :=
{ has_zero := λ X Y,
  ⟨{ f := 0, }⟩}

variables {C}

@[simp]
lemma zero_f (P Q : differential_object C) : (0 : P ⟶ Q).f = 0 := rfl

/--
An isomorphism of differential objects gives an isomorphism of the underlying objects.
-/
@[simps] def iso_app {X Y : differential_object C} (f : X ≅ Y) : X.X ≅ Y.X :=
⟨f.hom.f, f.inv.f, by { dsimp, rw [← comp_f, iso.hom_inv_id, id_f] },
  by { dsimp, rw [← comp_f, iso.inv_hom_id, id_f] }⟩

@[simp] lemma iso_app_refl (X : differential_object C) : iso_app (iso.refl X) = iso.refl X.X := rfl
@[simp] lemma iso_app_symm {X Y : differential_object C} (f : X ≅ Y) :
  iso_app f.symm = (iso_app f).symm := rfl
@[simp] lemma iso_app_trans {X Y Z : differential_object C} (f : X ≅ Y) (g : Y ≅ Z) :
  iso_app (f ≪≫ g) = iso_app f ≪≫ iso_app g := rfl

end differential_object

namespace functor

universes v' u'
variables (D : Type u') [category.{v'} D]
variables [has_zero_morphisms D] [has_shift D]

/--
A functor `F : C ⥤ D` which commutes with shift functors on `C` and `D` and preserves zero morphisms
can be lifted to a functor `differential_object C ⥤ differential_object D`.
-/
@[simps]
def map_differential_object (F : C ⥤ D) (η : (shift C).functor.comp F ⟶ F.comp (shift D).functor)
  (hF : ∀ c c', F.map (0 : c ⟶ c') = 0) :
  differential_object C ⥤ differential_object D :=
{ obj := λ X, { X := F.obj X.X,
    d := F.map X.d ≫ η.app X.X,
    d_squared' := begin
      dsimp, rw [functor.map_comp, ← functor.comp_map F (shift D).functor],
      slice_lhs 2 3 { rw [← η.naturality X.d] },
      rw [functor.comp_map],
      slice_lhs 1 2 { rw [← F.map_comp, X.d_squared, hF] },
      rw [zero_comp, zero_comp],
    end },
  map := λ X Y f, { f := F.map f.f,
    comm' := begin
      dsimp,
      slice_lhs 2 3 { rw [← functor.comp_map F (shift D).functor, ← η.naturality f.f] },
      slice_lhs 1 2 { rw [functor.comp_map, ← F.map_comp, f.comm, F.map_comp] },
      rw [category.assoc]
    end },
  map_id' := by { intros, ext, simp },
  map_comp' := by { intros, ext, simp }, }

end functor

end category_theory

namespace category_theory

namespace differential_object

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

variables [has_zero_object C] [has_zero_morphisms C] [has_shift C]

local attribute [instance] has_zero_object.has_zero

instance has_zero_object : has_zero_object (differential_object C) :=
{ zero :=
  { X := (0 : C),
    d := 0, },
  unique_to := λ X, ⟨⟨{ f := 0 }⟩, λ f, (by ext)⟩,
  unique_from := λ X, ⟨⟨{ f := 0 }⟩, λ f, (by ext)⟩, }

end differential_object

namespace differential_object

variables (C : Type (u+1)) [large_category C] [concrete_category C]
  [has_zero_morphisms C] [has_shift C]

instance concrete_category_of_differential_objects :
  concrete_category (differential_object C) :=
{ forget := forget C ⋙ category_theory.forget C }

instance : has_forget₂ (differential_object C) C :=
{ forget₂ := forget C }

end differential_object

/-! The category of differential objects itself has a shift functor. -/
namespace differential_object

variables (C : Type u) [category.{v} C]
variables [has_zero_morphisms C] [has_shift C]

/-- The shift functor on `differential_object C`. -/
@[simps]
def shift_functor : differential_object C ⥤ differential_object C :=
{ obj := λ X,
  { X := X.X⟦1⟧,
    d := X.d⟦1⟧',
    d_squared' := begin
      dsimp,
      rw [←functor.map_comp, X.d_squared, is_equivalence_preserves_zero_morphisms],
    end },
  map := λ X Y f,
  { f := f.f⟦1⟧',
    comm' := begin dsimp, rw [←functor.map_comp, f.comm, ←functor.map_comp], end, }, }

/-- The inverse shift functor on `differential C`, at the level of objects. -/
@[simps]
def shift_inverse_obj : differential_object C → differential_object C :=
λ X,
{ X := X.X⟦-1⟧,
  d := X.d⟦-1⟧' ≫ (shift C).unit_inv.app X.X ≫ (shift C).counit_inv.app X.X,
  d_squared' := begin
    dsimp,
    rw functor.map_comp,
    slice_lhs 3 4 { erw ←(shift C).counit_inv.naturality, },
    slice_lhs 2 3 { erw ←(shift C).unit_inv.naturality, },
    slice_lhs 1 2 { erw [←functor.map_comp, X.d_squared], },
    simp,
  end, }

/-- The inverse shift functor on `differential C`. -/
@[simps]
def shift_inverse : differential_object C ⥤ differential_object C :=
{ obj := shift_inverse_obj C,
  map := λ X Y f,
  { f := f.f⟦-1⟧',
    comm' := begin
      dsimp,
      slice_lhs 3 4 { erw ←(shift C).counit_inv.naturality, },
      slice_lhs 2 3 { erw ←(shift C).unit_inv.naturality, },
      slice_lhs 1 2 { erw [←functor.map_comp, f.comm, functor.map_comp], },
      rw [category.assoc, category.assoc],
    end, }, }.

/-- The unit for the shift functor on `differential_object C`. -/
@[simps]
def shift_unit : 𝟭 (differential_object C) ⟶ shift_functor C ⋙ shift_inverse C :=
{ app := λ X,
  { f := (shift C).unit.app X.X,
    comm' := begin
      dsimp,
      slice_rhs 1 2 { erw ←(shift C).unit.naturality, },
      simp only [category.comp_id, functor.id_map, iso.hom_inv_id_app,
        category.assoc, equivalence.counit_inv_app_functor],
    end, }, }

/-- The inverse of the unit for the shift functor on `differential_object C`. -/
@[simps]
def shift_unit_inv : shift_functor C ⋙ shift_inverse C ⟶ 𝟭 (differential_object C) :=
{ app := λ X,
  { f := (shift C).unit_inv.app X.X,
    comm' := begin
      dsimp,
      slice_rhs 1 2 { erw ←(shift C).unit_inv.naturality, },
      rw [equivalence.counit_inv_app_functor],
      slice_lhs 3 4 { rw ←functor.map_comp, },
      simp only [iso.hom_inv_id_app, functor.comp_map, iso.hom_inv_id_app_assoc,
        nat_iso.cancel_nat_iso_inv_left, equivalence.inv_fun_map, category.assoc],
      dsimp,
      rw category_theory.functor.map_id,
    end, }, }.

/-- The unit isomorphism for the shift functor on `differential_object C`. -/
@[simps]
def shift_unit_iso : 𝟭 (differential_object C) ≅ shift_functor C ⋙ shift_inverse C :=
{ hom := shift_unit C,
  inv := shift_unit_inv C, }.

/-- The counit for the shift functor on `differential_object C`. -/
@[simps]
def shift_counit : shift_inverse C ⋙ shift_functor C ⟶ 𝟭 (differential_object C) :=
{ app := λ X,
  { f := (shift C).counit.app X.X,
    comm' :=
    begin
      dsimp,
      slice_rhs 1 2 { erw ←(shift C).counit.naturality, },
      rw [(shift C).functor.map_comp, (shift C).functor.map_comp],
      slice_lhs 3 4 { erw [←functor.map_comp, iso.inv_hom_id_app, functor.map_id], },
      erw equivalence.counit_app_functor,
      rw category.comp_id,
      refl,
    end, }, }

/-- The inverse of the counit for the shift functor on `differential_object C`. -/
@[simps]
def shift_counit_inv : 𝟭 (differential_object C) ⟶ shift_inverse C ⋙ shift_functor C :=
{ app := λ X,
  { f := (shift C).counit_inv.app X.X,
    comm' :=
    begin
      dsimp,
      rw [(shift C).functor.map_comp, (shift C).functor.map_comp],
      slice_rhs 1 2 { erw ←(shift C).counit_inv.naturality, },
      rw ←equivalence.counit_app_functor,
      slice_rhs 2 3 { rw iso.inv_hom_id_app, },
      rw category.id_comp,
      refl,
    end, }, }

/-- The counit isomorphism for the shift functor on `differential_object C`. -/
@[simps]
def shift_counit_iso : shift_inverse C ⋙ shift_functor C ≅ 𝟭 (differential_object C) :=
{ hom := shift_counit C,
  inv := shift_counit_inv C, }

/--
The category of differential objects in `C` itself has a shift functor.
-/
instance : has_shift (differential_object C) :=
{ shift :=
  { functor := shift_functor C,
    inverse := shift_inverse C,
    unit_iso := shift_unit_iso C,
    counit_iso := shift_counit_iso C, } }

end differential_object

end category_theory


import to_mathlib.partition
import to_mathlib.topology.constructions
import to_mathlib.geometry.manifold.misc_manifold

noncomputable theory

open_locale topology manifold big_operators
open set function

-- See: https://leanprover.zulipchat.com/#narrow/stream/113488-general/topic/Typeclass.20resolution.20under.20binders/near/281296989
instance real.normed_space.to_module (F : Type*) [normed_add_comm_group F] [normed_space ℝ F] : module ℝ F :=
by apply_instance

variables {E₁ E₂ F : Type*}
variables [normed_add_comm_group E₁] [normed_space ℝ E₁] [finite_dimensional ℝ E₁]
variables [normed_add_comm_group E₂] [normed_space ℝ E₂] [finite_dimensional ℝ E₂]
variables [normed_add_comm_group F] [normed_space ℝ F]

variables {H₁ M₁ H₂ M₂ : Type*}
variables [topological_space H₁] (I₁ : model_with_corners ℝ E₁ H₁)
variables [topological_space M₁] [charted_space H₁ M₁] [smooth_manifold_with_corners I₁ M₁]
variables [sigma_compact_space M₁] [t2_space M₁]
variables [topological_space H₂] (I₂ : model_with_corners ℝ E₂ H₂)
variables [topological_space M₂] [charted_space H₂ M₂] [smooth_manifold_with_corners I₂ M₂]

local notation `𝓒` := cont_mdiff (I₁.prod I₂) 𝓘(ℝ, F)
local notation `𝓒_on` := cont_mdiff_on (I₁.prod I₂) 𝓘(ℝ, F)

namespace smooth_partition_of_unity

variables {ι : Type*} (ρ : smooth_partition_of_unity ι I₁ M₁) {I₁} (I₂ M₂)

/-- If `ρ` is a smooth partition of unity for smooth manifold `M₁` and `M₂` is another smooth
manifold (with model `I₂`) then `ρ.prod M₂ I₂` is the smooth partition of unity for `M₁ × M₂`
obtained by precomposing each component of `ρ` with the projection map `M₁ × M₂ → M₁`. -/
def prod : smooth_partition_of_unity ι (I₁.prod I₂) (M₁ × M₂) :=
{ to_fun := λ i, (ρ i).comp ⟨prod.fst, cont_mdiff_fst⟩,
  locally_finite' :=
  begin
    convert ρ.locally_finite.prod_right (λ i, univ),
    ext i ⟨x, y⟩,
    simp only [mem_support, cont_mdiff_map.comp_apply, cont_mdiff_map.coe_fn_mk,
      prod_mk_mem_set_prod_eq, mem_univ, and_true],
  end,
  nonneg' := λ i z, by simp only [cont_mdiff_map.comp_apply, cont_mdiff_map.coe_fn_mk, ρ.nonneg i],
  sum_le_one' := λ z, by simp only [ρ.sum_le_one, cont_mdiff_map.comp_apply],
  sum_eq_one' := λ z h, by simp only [ρ.sum_eq_one, cont_mdiff_map.comp_apply, mem_univ], }

@[simp] lemma tsupport_prod (i : ι) :
  tsupport (ρ.prod M₂ I₂ i) = tsupport (ρ i) ×ˢ (univ : set M₂) :=
begin
  change closure (support (λ (xy : M₁ × M₂), (ρ i) xy.1)) = closure (support (ρ i)) ×ˢ univ,
  rw [← show closure univ = (univ : set M₂), from is_closed_univ.closure_eq, ← closure_prod_eq],
  congr,
  ext,
  simp,
end

end smooth_partition_of_unity

lemma exists_cont_mdiff_of_convex₂
  {P : M₁ → (M₂ → F) → Prop} (hP : ∀ x, convex ℝ {f | P x f}) {n : ℕ∞}
  (hP' : ∀ x : M₁, ∃ (U ∈ 𝓝 x) (f : M₁ → M₂ → F),
    𝓒_on n (uncurry f) (U ×ˢ (univ : set M₂)) ∧ ∀ y ∈ U, P y (f y)) :
  ∃ f : M₁ → M₂ → F, 𝓒 n (uncurry f) ∧ ∀ x, P x (f x) :=
begin
  replace hP' : ∀ x : M₁, ∃ U ∈ 𝓝 x, (is_open U) ∧ ∃ f : M₁ → M₂ → F,
    𝓒_on n (uncurry f) (U ×ˢ (univ : set M₂)) ∧ ∀ y ∈ U, P y (f y),
  { intros x,
    rcases ((nhds_basis_opens x).exists_iff _).mp (hP' x) with ⟨U, ⟨x_in, U_op⟩, f, hf, hfP⟩,
    exact ⟨U, U_op.mem_nhds x_in, U_op, f, hf, hfP⟩,
    rintros s t hst ⟨f, hf, hf'⟩,
    exact ⟨f, hf.mono (prod_mono hst subset.rfl), λ x hx, hf' x (hst hx)⟩, },
  choose U hU U_op φ hφ using hP',
  rcases smooth_bump_covering.exists_is_subordinate I₁ is_closed_univ (λ x h, hU x) with ⟨ι, b, hb⟩,
  let ρ := b.to_smooth_partition_of_unity,
  have subf : ∀ i, support (ρ i) ⊆ U (b.c i) := λ i,
    subset_closure.trans (smooth_bump_covering.is_subordinate.to_smooth_partition_of_unity hb i),
  refine ⟨λ x, ∑ᶠ i, (ρ i x) • φ (b.c i) x, _, λ x₀, _⟩,
  { have h₁ : uncurry (λ (x : M₁), ∑ᶠ (i : ι), ρ i x • φ (b.c i) x) =
              λ (xy : M₁ × M₂), ∑ᶠ (i : ι), (ρ.prod M₂ I₂ i xy) • uncurry (φ (b.c i)) xy,
    { ext ⟨x, y⟩,
      simp only [uncurry_apply_pair],
      change _ = ∑ᶠ i, ρ i x • φ (b.c i) x y,
      erw [← ρ.to_partition_of_unity.sum_finsupport_smul,
        ← ρ.to_partition_of_unity.sum_finsupport_smul],
      simp only [finset.sum_apply, pi.smul_apply], },
    rw h₁,
    rintros ⟨x, y⟩,
    refine (ρ.prod M₂ I₂).cont_diff_at_sum (λ i hxy, _),
    have hx : x ∈ U (b.c i),
    { suffices : x ∈ tsupport (ρ i),
      { exact smooth_bump_covering.is_subordinate.to_smooth_partition_of_unity hb i this, },
      rw [ρ.tsupport_prod M₂ I₂ i] at hxy,
      simpa using hxy, },
    refine ((hφ $ b.c i).1 ⟨x, y⟩ _).cont_mdiff_at _,
    { simpa only [prod_mk_mem_set_prod_eq, mem_univ, and_true], },
    { exact mem_nhds_prod_iff.mpr
      ⟨_, (U_op $ b.c i).mem_nhds hx, _, filter.univ_mem, subset.rfl⟩, }, },
  { erw ← ρ.to_partition_of_unity.sum_finsupport_smul,
    refine (hP x₀).sum_mem (λ i hi, (ρ.nonneg i x₀ : _))
      ρ.to_partition_of_unity.sum_finsupport (λ i hi, _),
    rw [partition_of_unity.mem_finsupport] at hi,
    exact (hφ $ b.c i).2 _ (subf _ hi), },
end

lemma exists_cont_diff_of_convex₂
  {P : E₁ → (E₂ → F) → Prop} (hP : ∀ x, convex ℝ {f | P x f}) {n : ℕ∞}
  (hP' : ∀ x : E₁, ∃ (U ∈ 𝓝 x) (f : E₁ → E₂ → F),
    cont_diff_on ℝ n (uncurry f) (U ×ˢ (univ : set E₂)) ∧ ∀ y ∈ U, P y (f y)) :
  ∃ f : E₁ → E₂ → F, cont_diff ℝ n (uncurry f) ∧ ∀ x, P x (f x) :=
begin
  simp_rw [← cont_mdiff_on_iff_cont_diff_on, model_with_corners_self_prod] at hP',
  simp_rw [← cont_mdiff_iff_cont_diff, model_with_corners_self_prod],
  rw [← charted_space_self_prod] at hP' ⊢, -- Why does `simp_rw` not succeed here?
  exact exists_cont_mdiff_of_convex₂ 𝓘(ℝ, E₁) 𝓘(ℝ, E₂) hP hP',
end


/-
Copyright (c) 2020 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import category_theory.monoidal.discrete
import category_theory.limits.shapes.terminal
import algebra.punit_instances

/-!
# The category of monoids in a monoidal category.
-/

universes v₁ v₂ u₁ u₂

open category_theory
open category_theory.monoidal_category

variables (C : Type u₁) [category.{v₁} C] [monoidal_category.{v₁} C]

/--
A monoid object internal to a monoidal category.

When the monoidal category is preadditive, this is also sometimes called an "algebra object".
-/
structure Mon_ :=
(X : C)
(one : 𝟙_ C ⟶ X)
(mul : X ⊗ X ⟶ X)
(one_mul' : (one ⊗ 𝟙 X) ≫ mul = (λ_ X).hom . obviously)
(mul_one' : (𝟙 X ⊗ one) ≫ mul = (ρ_ X).hom . obviously)
-- Obviously there is some flexibility stating this axiom.
-- This one has left- and right-hand sides matching the statement of `monoid.mul_assoc`,
-- and chooses to place the associator on the right-hand side.
-- The heuristic is that unitors and associators "don't have much weight".
(mul_assoc' : (mul ⊗ 𝟙 X) ≫ mul = (α_ X X X).hom ≫ (𝟙 X ⊗ mul) ≫ mul . obviously)

restate_axiom Mon_.one_mul'
restate_axiom Mon_.mul_one'
restate_axiom Mon_.mul_assoc'
attribute [reassoc] Mon_.one_mul Mon_.mul_one -- We prove a more general `@[simp]` lemma below.
attribute [simp, reassoc] Mon_.mul_assoc

namespace Mon_

/--
The trivial monoid object. We later show this is initial in `Mon_ C`.
-/
@[simps]
def trivial : Mon_ C :=
{ X := 𝟙_ C,
  one := 𝟙 _,
  mul := (λ_ _).hom,
  mul_assoc' :=
    by simp_rw [triangle_assoc, iso.cancel_iso_hom_right, tensor_right_iff, unitors_equal],
  mul_one' := by simp [unitors_equal] }

instance : inhabited (Mon_ C) := ⟨trivial C⟩

variables {C} {M : Mon_ C}

@[simp] lemma one_mul_hom {Z : C} (f : Z ⟶ M.X) : (M.one ⊗ f) ≫ M.mul = (λ_ Z).hom ≫ f :=
by rw [←id_tensor_comp_tensor_id, category.assoc, M.one_mul, left_unitor_naturality]

@[simp] lemma mul_one_hom {Z : C} (f : Z ⟶ M.X) : (f ⊗ M.one) ≫ M.mul = (ρ_ Z).hom ≫ f :=
by rw [←tensor_id_comp_id_tensor, category.assoc, M.mul_one, right_unitor_naturality]

lemma assoc_flip : (𝟙 M.X ⊗ M.mul) ≫ M.mul = (α_ M.X M.X M.X).inv ≫ (M.mul ⊗ 𝟙 M.X) ≫ M.mul :=
by simp

/-- A morphism of monoid objects. -/
@[ext]
structure hom (M N : Mon_ C) :=
(hom : M.X ⟶ N.X)
(one_hom' : M.one ≫ hom = N.one . obviously)
(mul_hom' : M.mul ≫ hom = (hom ⊗ hom) ≫ N.mul . obviously)

restate_axiom hom.one_hom'
restate_axiom hom.mul_hom'
attribute [simp, reassoc] hom.one_hom hom.mul_hom

/-- The identity morphism on a monoid object. -/
@[simps]
def id (M : Mon_ C) : hom M M :=
{ hom := 𝟙 M.X, }

instance hom_inhabited (M : Mon_ C) : inhabited (hom M M) := ⟨id M⟩

/-- Composition of morphisms of monoid objects. -/
@[simps]
def comp {M N O : Mon_ C} (f : hom M N) (g : hom N O) : hom M O :=
{ hom := f.hom ≫ g.hom, }

instance : category (Mon_ C) :=
{ hom := λ M N, hom M N,
  id := id,
  comp := λ M N O f g, comp f g, }

@[simp] lemma id_hom' (M : Mon_ C) : (𝟙 M : hom M M).hom = 𝟙 M.X := rfl
@[simp] lemma comp_hom' {M N K : Mon_ C} (f : M ⟶ N) (g : N ⟶ K) :
  (f ≫ g : hom M K).hom = f.hom ≫ g.hom := rfl

section
variables (C)

/-- The forgetful functor from monoid objects to the ambient category. -/
@[simps]
def forget : Mon_ C ⥤ C :=
{ obj := λ A, A.X,
  map := λ A B f, f.hom, }

end

instance forget_faithful : faithful (@forget C _ _) := { }

instance {A B : Mon_ C} (f : A ⟶ B) [e : is_iso ((forget C).map f)] : is_iso f.hom := e

/-- The forgetful functor from monoid objects to the ambient category reflects isomorphisms. -/
instance : reflects_isomorphisms (forget C) :=
{ reflects := λ X Y f e, by exactI ⟨⟨{
  hom := inv f.hom,
  mul_hom' :=
  begin
    simp only [is_iso.comp_inv_eq, hom.mul_hom, category.assoc, ←tensor_comp_assoc,
      is_iso.inv_hom_id, tensor_id, category.id_comp],
  end }, by tidy⟩⟩ }

instance unique_hom_from_trivial (A : Mon_ C) : unique (trivial C ⟶ A) :=
{ default :=
  { hom := A.one,
    one_hom' := by { dsimp, simp, },
    mul_hom' := by { dsimp, simp [A.one_mul, unitors_equal], } },
  uniq := λ f,
  begin
    ext, simp,
    rw [←category.id_comp f.hom],
    erw f.one_hom,
  end }

open category_theory.limits

instance : has_initial (Mon_ C) :=
has_initial_of_unique (trivial C)

end Mon_

namespace category_theory.lax_monoidal_functor

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

/--
A lax monoidal functor takes monoid objects to monoid objects.

That is, a lax monoidal functor `F : C ⥤ D` induces a functor `Mon_ C ⥤ Mon_ D`.
-/
-- TODO: map_Mod F A : Mod A ⥤ Mod (F.map_Mon A)
@[simps]
def map_Mon (F : lax_monoidal_functor C D) : Mon_ C ⥤ Mon_ D :=
{ obj := λ A,
  { X := F.obj A.X,
    one := F.ε ≫ F.map A.one,
    mul := F.μ _ _ ≫ F.map A.mul,
    one_mul' :=
    begin
      conv_lhs { rw [comp_tensor_id, ←F.to_functor.map_id], },
      slice_lhs 2 3 { rw [F.μ_natural], },
      slice_lhs 3 4 { rw [←F.to_functor.map_comp, A.one_mul], },
      rw [F.to_functor.map_id],
      rw [F.left_unitality],
    end,
    mul_one' :=
    begin
      conv_lhs { rw [id_tensor_comp, ←F.to_functor.map_id], },
      slice_lhs 2 3 { rw [F.μ_natural], },
      slice_lhs 3 4 { rw [←F.to_functor.map_comp, A.mul_one], },
      rw [F.to_functor.map_id],
      rw [F.right_unitality],
    end,
    mul_assoc' :=
    begin
      conv_lhs { rw [comp_tensor_id, ←F.to_functor.map_id], },
      slice_lhs 2 3 { rw [F.μ_natural], },
      slice_lhs 3 4 { rw [←F.to_functor.map_comp, A.mul_assoc], },
      conv_lhs { rw [F.to_functor.map_id] },
      conv_lhs { rw [F.to_functor.map_comp, F.to_functor.map_comp] },
      conv_rhs { rw [id_tensor_comp, ←F.to_functor.map_id], },
      slice_rhs 3 4 { rw [F.μ_natural], },
      conv_rhs { rw [F.to_functor.map_id] },
      slice_rhs 1 3 { rw [←F.associativity], },
      simp only [category.assoc],
    end, },
  map := λ A B f,
  { hom := F.map f.hom,
    one_hom' := by { dsimp, rw [category.assoc, ←F.to_functor.map_comp, f.one_hom], },
    mul_hom' :=
    begin
      dsimp,
      rw [category.assoc, F.μ_natural_assoc, ←F.to_functor.map_comp, ←F.to_functor.map_comp,
        f.mul_hom],
    end },
  map_id' := λ A, by { ext, simp, },
  map_comp' := λ A B C f g, by { ext, simp, }, }

variables (C D)

/-- `map_Mon` is functorial in the lax monoidal functor. -/
def map_Mon_functor : (lax_monoidal_functor C D) ⥤ (Mon_ C ⥤ Mon_ D) :=
{ obj := map_Mon,
  map := λ F G α,
  { app := λ A,
    { hom := α.app A.X, } } }

end category_theory.lax_monoidal_functor

namespace Mon_

open category_theory.lax_monoidal_functor

namespace equiv_lax_monoidal_functor_punit

/-- Implementation of `Mon_.equiv_lax_monoidal_functor_punit`. -/
@[simps]
def lax_monoidal_to_Mon : lax_monoidal_functor (discrete punit) C ⥤ Mon_ C :=
{ obj := λ F, (F.map_Mon : Mon_ _ ⥤ Mon_ C).obj (trivial (discrete punit)),
  map := λ F G α, ((map_Mon_functor (discrete punit) C).map α).app _ }

/-- Implementation of `Mon_.equiv_lax_monoidal_functor_punit`. -/
@[simps]
def Mon_to_lax_monoidal : Mon_ C ⥤ lax_monoidal_functor (discrete punit) C :=
{ obj := λ A,
  { obj := λ _, A.X,
    map := λ _ _ _, 𝟙 _,
    ε := A.one,
    μ := λ _ _, A.mul,
    map_id' := λ _, rfl,
    map_comp' := λ _ _ _ _ _, (category.id_comp (𝟙 A.X)).symm, },
  map := λ A B f,
  { app := λ _, f.hom,
    naturality' := λ _ _ _, by { dsimp, rw [category.id_comp, category.comp_id], },
    unit' := f.one_hom,
    tensor' := λ _ _, f.mul_hom, }, }

/-- Implementation of `Mon_.equiv_lax_monoidal_functor_punit`. -/
@[simps]
def unit_iso :
  𝟭 (lax_monoidal_functor (discrete punit) C) ≅ lax_monoidal_to_Mon C ⋙ Mon_to_lax_monoidal C :=
nat_iso.of_components (λ F,
  monoidal_nat_iso.of_components
    (λ _, F.to_functor.map_iso (eq_to_iso (by ext)))
    (by tidy) (by tidy) (by tidy))
  (by tidy)

/-- Implementation of `Mon_.equiv_lax_monoidal_functor_punit`. -/
@[simps]
def counit_iso : Mon_to_lax_monoidal C ⋙ lax_monoidal_to_Mon C ≅ 𝟭 (Mon_ C) :=
nat_iso.of_components (λ F, { hom := { hom := 𝟙 _, }, inv := { hom := 𝟙 _, } })
  (by tidy)

end equiv_lax_monoidal_functor_punit

open equiv_lax_monoidal_functor_punit

/--
Monoid objects in `C` are "just" lax monoidal functors from the trivial monoidal category to `C`.
-/
@[simps]
def equiv_lax_monoidal_functor_punit : lax_monoidal_functor (discrete punit) C ≌ Mon_ C :=
{ functor := lax_monoidal_to_Mon C,
  inverse := Mon_to_lax_monoidal C,
  unit_iso := unit_iso C,
  counit_iso := counit_iso C, }

end Mon_

/-!
Projects:
* Check that `Mon_ Mon ≌ CommMon`, via the Eckmann-Hilton argument.
  (You'll have to hook up the cartesian monoidal structure on `Mon` first, available in #3463)
* Check that `Mon_ Top ≌ [bundled topological monoids]`.
* Check that `Mon_ AddCommGroup ≌ Ring`.
  (We've already got `Mon_ (Module R) ≌ Algebra R`, in `category_theory.monoidal.internal.Module`.)
* Can you transport this monoidal structure to `Ring` or `Algebra R`?
  How does it compare to the "native" one?
* Show that if `C` is braided then `Mon_ C` is naturally monoidal.
-/


/-
Copyright (c) 2018 Chris Hughes. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Chris Hughes
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.fintype.basic
import Mathlib.data.finset.sort
import Mathlib.group_theory.perm.basic
import Mathlib.group_theory.order_of_element
import Mathlib.PostPort

universes u u_1 v

namespace Mathlib

/-!
# Sign of a permutation

The main definition of this file is `equiv.perm.sign`, associating a `units ℤ` sign with a
permutation.

This file also contains miscellaneous lemmas about `equiv.perm` and `equiv.swap`, building on top
of those in `data/equiv/basic` and `data/equiv/perm`.

-/

namespace equiv.perm

/--
`mod_swap i j` contains permutations up to swapping `i` and `j`.

We use this to partition permutations in `matrix.det_zero_of_row_eq`, such that each partition
sums up to `0`.
-/
def mod_swap {α : Type u} [DecidableEq α] (i : α) (j : α) : setoid (perm α) :=
  setoid.mk (fun (σ τ : perm α) => σ = τ ∨ σ = swap i j * τ) sorry

protected instance r.decidable_rel {α : Type u_1} [fintype α] [DecidableEq α] (i : α) (j : α) : DecidableRel setoid.r :=
  fun (σ τ : perm α) => or.decidable

/-- If the permutation `f` fixes the subtype `{x // p x}`, then this returns the permutation
  on `{x // p x}` induced by `f`. -/
def subtype_perm {α : Type u} (f : perm α) {p : α → Prop} (h : ∀ (x : α), p x ↔ p (coe_fn f x)) : perm (Subtype fun (x : α) => p x) :=
  mk (fun (x : Subtype fun (x : α) => p x) => { val := coe_fn f ↑x, property := sorry })
    (fun (x : Subtype fun (x : α) => p x) => { val := coe_fn (f⁻¹) ↑x, property := sorry }) sorry sorry

@[simp] theorem subtype_perm_one {α : Type u} (p : α → Prop) (h : ∀ (x : α), p x ↔ p (coe_fn 1 x)) : subtype_perm 1 h = 1 := sorry

/-- The inclusion map of permutations on a subtype of `α` into permutations of `α`,
  fixing the other points. -/
def of_subtype {α : Type u} {p : α → Prop} [decidable_pred p] : perm (Subtype p) →* perm α :=
  monoid_hom.mk
    (fun (f : perm (Subtype p)) =>
      mk (fun (x : α) => dite (p x) (fun (h : p x) => ↑(coe_fn f { val := x, property := h })) fun (h : ¬p x) => x)
        (fun (x : α) => dite (p x) (fun (h : p x) => ↑(coe_fn (f⁻¹) { val := x, property := h })) fun (h : ¬p x) => x)
        sorry sorry)
    sorry sorry

/-- Two permutations `f` and `g` are `disjoint` if their supports are disjoint, i.e.,
every element is fixed either by `f`, or by `g`. -/
def disjoint {α : Type u} (f : perm α) (g : perm α) :=
  ∀ (x : α), coe_fn f x = x ∨ coe_fn g x = x

theorem disjoint.symm {α : Type u} {f : perm α} {g : perm α} : disjoint f g → disjoint g f := sorry

theorem disjoint_comm {α : Type u} {f : perm α} {g : perm α} : disjoint f g ↔ disjoint g f :=
  { mp := disjoint.symm, mpr := disjoint.symm }

theorem disjoint.mul_comm {α : Type u} {f : perm α} {g : perm α} (h : disjoint f g) : f * g = g * f := sorry

@[simp] theorem disjoint_one_left {α : Type u} (f : perm α) : disjoint 1 f :=
  fun (_x : α) => Or.inl rfl

@[simp] theorem disjoint_one_right {α : Type u} (f : perm α) : disjoint f 1 :=
  fun (_x : α) => Or.inr rfl

theorem disjoint.mul_left {α : Type u} {f : perm α} {g : perm α} {h : perm α} (H1 : disjoint f h) (H2 : disjoint g h) : disjoint (f * g) h := sorry

theorem disjoint.mul_right {α : Type u} {f : perm α} {g : perm α} {h : perm α} (H1 : disjoint f g) (H2 : disjoint f h) : disjoint f (g * h) :=
  eq.mpr (id (Eq._oldrec (Eq.refl (disjoint f (g * h))) (propext disjoint_comm)))
    (disjoint.mul_left (disjoint.symm H1) (disjoint.symm H2))

theorem disjoint_prod_right {α : Type u} {f : perm α} (l : List (perm α)) (h : ∀ (g : perm α), g ∈ l → disjoint f g) : disjoint f (list.prod l) := sorry

theorem disjoint_prod_perm {α : Type u} {l₁ : List (perm α)} {l₂ : List (perm α)} (hl : list.pairwise disjoint l₁) (hp : l₁ ~ l₂) : list.prod l₁ = list.prod l₂ :=
  list.perm.prod_eq' hp (list.pairwise.imp (fun (f g : perm α) => disjoint.mul_comm) hl)

theorem of_subtype_subtype_perm {α : Type u} {f : perm α} {p : α → Prop} [decidable_pred p] (h₁ : ∀ (x : α), p x ↔ p (coe_fn f x)) (h₂ : ∀ (x : α), coe_fn f x ≠ x → p x) : coe_fn of_subtype (subtype_perm f h₁) = f := sorry

theorem of_subtype_apply_of_not_mem {α : Type u} {p : α → Prop} [decidable_pred p] (f : perm (Subtype p)) {x : α} (hx : ¬p x) : coe_fn (coe_fn of_subtype f) x = x :=
  dif_neg hx

theorem mem_iff_of_subtype_apply_mem {α : Type u} {p : α → Prop} [decidable_pred p] (f : perm (Subtype p)) (x : α) : p x ↔ p (coe_fn (coe_fn of_subtype f) x) := sorry

@[simp] theorem subtype_perm_of_subtype {α : Type u} {p : α → Prop} [decidable_pred p] (f : perm (Subtype p)) : subtype_perm (coe_fn of_subtype f) (mem_iff_of_subtype_apply_mem f) = f := sorry

theorem pow_apply_eq_self_of_apply_eq_self {α : Type u} {f : perm α} {x : α} (hfx : coe_fn f x = x) (n : ℕ) : coe_fn (f ^ n) x = x := sorry

theorem gpow_apply_eq_self_of_apply_eq_self {α : Type u} {f : perm α} {x : α} (hfx : coe_fn f x = x) (n : ℤ) : coe_fn (f ^ n) x = x := sorry

theorem pow_apply_eq_of_apply_apply_eq_self {α : Type u} {f : perm α} {x : α} (hffx : coe_fn f (coe_fn f x) = x) (n : ℕ) : coe_fn (f ^ n) x = x ∨ coe_fn (f ^ n) x = coe_fn f x := sorry

theorem gpow_apply_eq_of_apply_apply_eq_self {α : Type u} {f : perm α} {x : α} (hffx : coe_fn f (coe_fn f x) = x) (i : ℤ) : coe_fn (f ^ i) x = x ∨ coe_fn (f ^ i) x = coe_fn f x := sorry

/-- The `finset` of nonfixed points of a permutation. -/
def support {α : Type u} [DecidableEq α] [fintype α] (f : perm α) : finset α :=
  finset.filter (fun (x : α) => coe_fn f x ≠ x) finset.univ

@[simp] theorem mem_support {α : Type u} [DecidableEq α] [fintype α] {f : perm α} {x : α} : x ∈ support f ↔ coe_fn f x ≠ x := sorry

/-- `f.is_swap` indicates that the permutation `f` is a transposition of two elements. -/
def is_swap {α : Type u} [DecidableEq α] (f : perm α) :=
  ∃ (x : α), ∃ (y : α), x ≠ y ∧ f = swap x y

theorem is_swap.of_subtype_is_swap {α : Type u} [DecidableEq α] {p : α → Prop} [decidable_pred p] {f : perm (Subtype p)} (h : is_swap f) : is_swap (coe_fn of_subtype f) := sorry

theorem ne_and_ne_of_swap_mul_apply_ne_self {α : Type u} [DecidableEq α] {f : perm α} {x : α} {y : α} (hy : coe_fn (swap x (coe_fn f x) * f) y ≠ y) : coe_fn f y ≠ y ∧ y ≠ x := sorry

theorem support_swap_mul_eq {α : Type u} [DecidableEq α] [fintype α] {f : perm α} {x : α} (hffx : coe_fn f (coe_fn f x) ≠ x) : support (swap x (coe_fn f x) * f) = finset.erase (support f) x := sorry

theorem card_support_swap_mul {α : Type u} [DecidableEq α] [fintype α] {f : perm α} {x : α} (hx : coe_fn f x ≠ x) : finset.card (support (swap x (coe_fn f x) * f)) < finset.card (support f) := sorry

/-- Given a list `l : list α` and a permutation `f : perm α` such that the nonfixed points of `f`
  are in `l`, recursively factors `f` as a product of transpositions. -/
def swap_factors_aux {α : Type u} [DecidableEq α] (l : List α) (f : perm α) : (∀ {x : α}, coe_fn f x ≠ x → x ∈ l) →
  Subtype fun (l : List (perm α)) => list.prod l = f ∧ ∀ (g : perm α), g ∈ l → is_swap g :=
  sorry

/-- `swap_factors` represents a permutation as a product of a list of transpositions.
The representation is non unique and depends on the linear order structure.
For types without linear order `trunc_swap_factors` can be used. -/
def swap_factors {α : Type u} [DecidableEq α] [fintype α] [linear_order α] (f : perm α) : Subtype fun (l : List (perm α)) => list.prod l = f ∧ ∀ (g : perm α), g ∈ l → is_swap g :=
  swap_factors_aux (finset.sort LessEq finset.univ) f sorry

/-- This computably represents the fact that any permutation can be represented as the product of
  a list of transpositions. -/
def trunc_swap_factors {α : Type u} [DecidableEq α] [fintype α] (f : perm α) : trunc (Subtype fun (l : List (perm α)) => list.prod l = f ∧ ∀ (g : perm α), g ∈ l → is_swap g) :=
  quotient.rec_on_subsingleton (finset.val finset.univ)
    (fun (l : List α) (h : ∀ (x : α), coe_fn f x ≠ x → x ∈ quotient.mk l) => trunc.mk (swap_factors_aux l f h)) sorry

/-- An induction principle for permutations. If `P` holds for the identity permutation, and
is preserved under composition with a non-trivial swap, then `P` holds for all permutations. -/
theorem swap_induction_on {α : Type u} [DecidableEq α] [fintype α] {P : perm α → Prop} (f : perm α) : P 1 → (∀ (f : perm α) (x y : α), x ≠ y → P f → P (swap x y * f)) → P f := sorry

/-- Like `swap_induction_on`, but with the composition on the right of `f`.

An induction principle for permutations. If `P` holds for the identity permutation, and
is preserved under composition with a non-trivial swap, then `P` holds for all permutations. -/
theorem swap_induction_on' {α : Type u} [DecidableEq α] [fintype α] {P : perm α → Prop} (f : perm α) : P 1 → (∀ (f : perm α) (x y : α), x ≠ y → P f → P (f * swap x y)) → P f :=
  fun (h1 : P 1) (IH : ∀ (f : perm α) (x y : α), x ≠ y → P f → P (f * swap x y)) =>
    inv_inv f ▸ swap_induction_on (f⁻¹) h1 fun (f : perm α) => IH (f⁻¹)

theorem is_conj_swap {α : Type u} [DecidableEq α] {w : α} {x : α} {y : α} {z : α} (hwx : w ≠ x) (hyz : y ≠ z) : is_conj (swap w x) (swap y z) := sorry

/-- set of all pairs (⟨a, b⟩ : Σ a : fin n, fin n) such that b < a -/
def fin_pairs_lt (n : ℕ) : finset (sigma fun (a : fin n) => fin n) :=
  finset.sigma finset.univ fun (a : fin n) => finset.attach_fin (finset.range ↑a) sorry

theorem mem_fin_pairs_lt {n : ℕ} {a : sigma fun (a : fin n) => fin n} : a ∈ fin_pairs_lt n ↔ sigma.snd a < sigma.fst a := sorry

/-- `sign_aux σ` is the sign of a permutation on `fin n`, defined as the parity of the number of
  pairs `(x₁, x₂)` such that `x₂ < x₁` but `σ x₁ ≤ σ x₂` -/
def sign_aux {n : ℕ} (a : perm (fin n)) : units ℤ :=
  finset.prod (fin_pairs_lt n)
    fun (x : sigma fun (a : fin n) => fin n) => ite (coe_fn a (sigma.fst x) ≤ coe_fn a (sigma.snd x)) (-1) 1

@[simp] theorem sign_aux_one (n : ℕ) : sign_aux 1 = 1 := sorry

/-- `sign_bij_aux f ⟨a, b⟩` returns the pair consisting of `f a` and `f b` in decreasing order. -/
def sign_bij_aux {n : ℕ} (f : perm (fin n)) (a : sigma fun (a : fin n) => fin n) : sigma fun (a : fin n) => fin n :=
  dite (coe_fn f (sigma.snd a) < coe_fn f (sigma.fst a))
    (fun (hxa : coe_fn f (sigma.snd a) < coe_fn f (sigma.fst a)) =>
      sigma.mk (coe_fn f (sigma.fst a)) (coe_fn f (sigma.snd a)))
    fun (hxa : ¬coe_fn f (sigma.snd a) < coe_fn f (sigma.fst a)) =>
      sigma.mk (coe_fn f (sigma.snd a)) (coe_fn f (sigma.fst a))

theorem sign_bij_aux_inj {n : ℕ} {f : perm (fin n)} (a : sigma fun (a : fin n) => fin n) (b : sigma fun (a : fin n) => fin n) : a ∈ fin_pairs_lt n → b ∈ fin_pairs_lt n → sign_bij_aux f a = sign_bij_aux f b → a = b := sorry

theorem sign_bij_aux_surj {n : ℕ} {f : perm (fin n)} (a : sigma fun (a : fin n) => fin n) (H : a ∈ fin_pairs_lt n) : ∃ (b : sigma fun (a : fin n) => fin n), ∃ (H : b ∈ fin_pairs_lt n), a = sign_bij_aux f b := sorry

theorem sign_bij_aux_mem {n : ℕ} {f : perm (fin n)} (a : sigma fun (a : fin n) => fin n) : a ∈ fin_pairs_lt n → sign_bij_aux f a ∈ fin_pairs_lt n := sorry

@[simp] theorem sign_aux_inv {n : ℕ} (f : perm (fin n)) : sign_aux (f⁻¹) = sign_aux f := sorry

theorem sign_aux_mul {n : ℕ} (f : perm (fin n)) (g : perm (fin n)) : sign_aux (f * g) = sign_aux f * sign_aux g := sorry

-- TODO: slow

theorem sign_aux_swap {n : ℕ} {x : fin n} {y : fin n} (hxy : x ≠ y) : sign_aux (swap x y) = -1 := sorry

/-- When the list `l : list α` contains all nonfixed points of the permutation `f : perm α`,
  `sign_aux2 l f` recursively calculates the sign of `f`. -/
def sign_aux2 {α : Type u} [DecidableEq α] : List α → perm α → units ℤ :=
  sorry

theorem sign_aux_eq_sign_aux2 {α : Type u} [DecidableEq α] {n : ℕ} (l : List α) (f : perm α) (e : α ≃ fin n) (h : ∀ (x : α), coe_fn f x ≠ x → x ∈ l) : sign_aux (equiv.trans (equiv.trans (equiv.symm e) f) e) = sign_aux2 l f := sorry

/-- When the multiset `s : multiset α` contains all nonfixed points of the permutation `f : perm α`,
  `sign_aux2 f _` recursively calculates the sign of `f`. -/
def sign_aux3 {α : Type u} [DecidableEq α] [fintype α] (f : perm α) {s : multiset α} : (∀ (x : α), x ∈ s) → units ℤ :=
  quotient.hrec_on s (fun (l : List α) (h : ∀ (x : α), x ∈ quotient.mk l) => sign_aux2 l f) sorry

theorem sign_aux3_mul_and_swap {α : Type u} [DecidableEq α] [fintype α] (f : perm α) (g : perm α) (s : multiset α) (hs : ∀ (x : α), x ∈ s) : sign_aux3 (f * g) hs = sign_aux3 f hs * sign_aux3 g hs ∧ ∀ (x y : α), x ≠ y → sign_aux3 (swap x y) hs = -1 := sorry

/-- `sign` of a permutation returns the signature or parity of a permutation, `1` for even
permutations, `-1` for odd permutations. It is the unique surjective group homomorphism from
`perm α` to the group with two elements.-/
def sign {α : Type u} [DecidableEq α] [fintype α] : perm α →* units ℤ :=
  monoid_hom.mk' (fun (f : perm α) => sign_aux3 f finset.mem_univ) sorry

@[simp] theorem sign_mul {α : Type u} [DecidableEq α] [fintype α] (f : perm α) (g : perm α) : coe_fn sign (f * g) = coe_fn sign f * coe_fn sign g :=
  monoid_hom.map_mul sign f g

@[simp] theorem sign_trans {α : Type u} [DecidableEq α] [fintype α] (f : perm α) (g : perm α) : coe_fn sign (equiv.trans f g) = coe_fn sign g * coe_fn sign f := sorry

@[simp] theorem sign_one {α : Type u} [DecidableEq α] [fintype α] : coe_fn sign 1 = 1 :=
  monoid_hom.map_one sign

@[simp] theorem sign_refl {α : Type u} [DecidableEq α] [fintype α] : coe_fn sign (equiv.refl α) = 1 :=
  monoid_hom.map_one sign

@[simp] theorem sign_inv {α : Type u} [DecidableEq α] [fintype α] (f : perm α) : coe_fn sign (f⁻¹) = coe_fn sign f :=
  eq.mpr (id (Eq._oldrec (Eq.refl (coe_fn sign (f⁻¹) = coe_fn sign f)) (monoid_hom.map_inv sign f)))
    (eq.mpr (id (Eq._oldrec (Eq.refl (coe_fn sign f⁻¹ = coe_fn sign f)) (int.units_inv_eq_self (coe_fn sign f))))
      (Eq.refl (coe_fn sign f)))

@[simp] theorem sign_symm {α : Type u} [DecidableEq α] [fintype α] (e : perm α) : coe_fn sign (equiv.symm e) = coe_fn sign e :=
  sign_inv e

theorem sign_swap {α : Type u} [DecidableEq α] [fintype α] {x : α} {y : α} (h : x ≠ y) : coe_fn sign (swap x y) = -1 :=
  and.right (sign_aux3_mul_and_swap 1 1 (finset.val finset.univ) finset.mem_univ) x y h

@[simp] theorem sign_swap' {α : Type u} [DecidableEq α] [fintype α] {x : α} {y : α} : coe_fn sign (swap x y) = ite (x = y) 1 (-1) := sorry

theorem is_swap.sign_eq {α : Type u} [DecidableEq α] [fintype α] {f : perm α} (h : is_swap f) : coe_fn sign f = -1 := sorry

theorem sign_aux3_symm_trans_trans {α : Type u} {β : Type v} [DecidableEq α] [fintype α] [DecidableEq β] [fintype β] (f : perm α) (e : α ≃ β) {s : multiset α} {t : multiset β} (hs : ∀ (x : α), x ∈ s) (ht : ∀ (x : β), x ∈ t) : sign_aux3 (equiv.trans (equiv.trans (equiv.symm e) f) e) ht = sign_aux3 f hs := sorry

@[simp] theorem sign_symm_trans_trans {α : Type u} {β : Type v} [DecidableEq α] [fintype α] [DecidableEq β] [fintype β] (f : perm α) (e : α ≃ β) : coe_fn sign (equiv.trans (equiv.trans (equiv.symm e) f) e) = coe_fn sign f :=
  sign_aux3_symm_trans_trans f e finset.mem_univ finset.mem_univ

@[simp] theorem sign_trans_trans_symm {α : Type u} {β : Type v} [DecidableEq α] [fintype α] [DecidableEq β] [fintype β] (f : perm β) (e : α ≃ β) : coe_fn sign (equiv.trans (equiv.trans e f) (equiv.symm e)) = coe_fn sign f :=
  sign_symm_trans_trans f (equiv.symm e)

theorem sign_prod_list_swap {α : Type u} [DecidableEq α] [fintype α] {l : List (perm α)} (hl : ∀ (g : perm α), g ∈ l → is_swap g) : coe_fn sign (list.prod l) = (-1) ^ list.length l := sorry

theorem sign_surjective {α : Type u} [DecidableEq α] [fintype α] (hα : 1 < fintype.card α) : function.surjective ⇑sign := sorry

theorem eq_sign_of_surjective_hom {α : Type u} [DecidableEq α] [fintype α] {s : perm α →* units ℤ} (hs : function.surjective ⇑s) : s = sign := sorry

theorem sign_subtype_perm {α : Type u} [DecidableEq α] [fintype α] (f : perm α) {p : α → Prop} [decidable_pred p] (h₁ : ∀ (x : α), p x ↔ p (coe_fn f x)) (h₂ : ∀ (x : α), coe_fn f x ≠ x → p x) : coe_fn sign (subtype_perm f h₁) = coe_fn sign f := sorry

@[simp] theorem sign_of_subtype {α : Type u} [DecidableEq α] [fintype α] {p : α → Prop} [decidable_pred p] (f : perm (Subtype p)) : coe_fn sign (coe_fn of_subtype f) = coe_fn sign f := sorry

theorem sign_eq_sign_of_equiv {α : Type u} {β : Type v} [DecidableEq α] [fintype α] [DecidableEq β] [fintype β] (f : perm α) (g : perm β) (e : α ≃ β) (h : ∀ (x : α), coe_fn e (coe_fn f x) = coe_fn g (coe_fn e x)) : coe_fn sign f = coe_fn sign g := sorry

theorem sign_bij {α : Type u} {β : Type v} [DecidableEq α] [fintype α] [DecidableEq β] [fintype β] {f : perm α} {g : perm β} (i : (x : α) → coe_fn f x ≠ x → β) (h : ∀ (x : α) (hx : coe_fn f x ≠ x) (hx' : coe_fn f (coe_fn f x) ≠ coe_fn f x), i (coe_fn f x) hx' = coe_fn g (i x hx)) (hi : ∀ (x₁ x₂ : α) (hx₁ : coe_fn f x₁ ≠ x₁) (hx₂ : coe_fn f x₂ ≠ x₂), i x₁ hx₁ = i x₂ hx₂ → x₁ = x₂) (hg : ∀ (y : β), coe_fn g y ≠ y → ∃ (x : α), ∃ (hx : coe_fn f x ≠ x), i x hx = y) : coe_fn sign f = coe_fn sign g := sorry

@[simp] theorem support_swap {α : Type u} [DecidableEq α] [fintype α] {x : α} {y : α} (hxy : x ≠ y) : support (swap x y) = insert x (singleton y) := sorry

theorem card_support_swap {α : Type u} [DecidableEq α] [fintype α] {x : α} {y : α} (hxy : x ≠ y) : finset.card (support (swap x y)) = bit0 1 := sorry

/-- If we apply `prod_extend_right a (σ a)` for all `a : α` in turn,
we get `prod_congr_right σ`. -/
theorem prod_prod_extend_right {β : Type v} {α : Type u_1} [DecidableEq α] (σ : α → perm β) {l : List α} (hl : list.nodup l) (mem_l : ∀ (a : α), a ∈ l) : list.prod (list.map (fun (a : α) => prod_extend_right a (σ a)) l) = prod_congr_right σ := sorry

@[simp] theorem sign_prod_extend_right {α : Type u} {β : Type v} [DecidableEq α] [fintype α] [DecidableEq β] [fintype β] (a : α) (σ : perm β) : coe_fn sign (prod_extend_right a σ) = coe_fn sign σ := sorry

theorem sign_prod_congr_right {α : Type u} {β : Type v} [DecidableEq α] [fintype α] [DecidableEq β] [fintype β] (σ : α → perm β) : coe_fn sign (prod_congr_right σ) = finset.prod finset.univ fun (k : α) => coe_fn sign (σ k) := sorry

theorem sign_prod_congr_left {α : Type u} {β : Type v} [DecidableEq α] [fintype α] [DecidableEq β] [fintype β] (σ : α → perm β) : coe_fn sign (prod_congr_left σ) = finset.prod finset.univ fun (k : α) => coe_fn sign (σ k) := sorry

@[simp] theorem sign_perm_congr {α : Type u} {β : Type v} [DecidableEq α] [fintype α] [DecidableEq β] [fintype β] (e : α ≃ β) (p : perm α) : coe_fn sign (coe_fn (perm_congr e) p) = coe_fn sign p := sorry

@[simp] theorem sign_sum_congr {α : Type u} {β : Type v} [DecidableEq α] [fintype α] [DecidableEq β] [fintype β] (σa : perm α) (σb : perm β) : coe_fn sign (sum_congr σa σb) = coe_fn sign σa * coe_fn sign σb := sorry