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

! This file was ported from Lean 3 source module group_theory.nielsen_schreier
! leanprover-community/mathlib commit 1bda4fc53de6ade5ab9da36f2192e24e2084a2ce
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.CategoryTheory.Action
import Mathbin.Combinatorics.Quiver.Arborescence
import Mathbin.Combinatorics.Quiver.ConnectedComponent
import Mathbin.GroupTheory.IsFreeGroup

/-!
# The Nielsen-Schreier theorem

This file proves that a subgroup of a free group is itself free.

## Main result

- `subgroup_is_free_of_is_free H`: an instance saying that a subgroup of a free group is free.

## Proof overview

The proof is analogous to the proof using covering spaces and fundamental groups of graphs,
but we work directly with groupoids instead of topological spaces. Under this analogy,

- `is_free_groupoid G` corresponds to saying that a space is a graph.
- `End_mul_equiv_subgroup H` plays the role of replacing 'subgroup of fundamental group' with
  'fundamental group of covering space'.
- `action_groupoid_is_free G A` corresponds to the fact that a covering of a (single-vertex)
  graph is a graph.
- `End_is_free T` corresponds to the fact that, given a spanning tree `T` of a
  graph, its fundamental group is free (generated by loops from the complement of the tree).

## Implementation notes

Our definition of `is_free_groupoid` is nonstandard. Normally one would require that functors
`G ⥤ X` to any _groupoid_ `X` are given by graph homomorphisms from the generators, but we only
consider _groups_ `X`. This simplifies the argument since functor equality is complicated in
general, but simple for functors to single object categories.

## References

https://ncatlab.org/nlab/show/Nielsen-Schreier+theorem

## Tags

free group, free groupoid, Nielsen-Schreier

-/

noncomputable section

open Classical

universe v u

/- ./././Mathport/Syntax/Translate/Command.lean:224:11: unsupported: unusual advanced open style -/
open CategoryTheory CategoryTheory.ActionCategory CategoryTheory.SingleObj Quiver

/-- `is_free_groupoid.generators G` is a type synonym for `G`. We think of this as
the vertices of the generating quiver of `G` when `G` is free. We can't use `G` directly,
since `G` already has a quiver instance from being a groupoid. -/
@[nolint unused_arguments has_nonempty_instance]
def IsFreeGroupoid.Generators (G) [Groupoid G] :=
  G
#align is_free_groupoid.generators IsFreeGroupoid.Generators

/-- A groupoid `G` is free when we have the following data:
 - a quiver on `is_free_groupoid.generators G` (a type synonym for `G`)
 - a function `of` taking a generating arrow to a morphism in `G`
 - such that a functor from `G` to any group `X` is uniquely determined
   by assigning labels in `X` to the generating arrows.

   This definition is nonstandard. Normally one would require that functors `G ⥤ X`
   to any _groupoid_ `X` are given by graph homomorphisms from `generators`. -/
class IsFreeGroupoid (G) [Groupoid.{v} G] where
  quiverGenerators : Quiver.{v + 1} (IsFreeGroupoid.Generators G)
  of : ∀ {a b : IsFreeGroupoid.Generators G}, (a ⟶ b) → ((show G from a) ⟶ b)
  unique_lift :
    ∀ {X : Type v} [Group X] (f : Labelling (IsFreeGroupoid.Generators G) X),
      ∃! F : G ⥤ CategoryTheory.SingleObj X, ∀ (a b) (g : a ⟶ b), F.map (of g) = f g
#align is_free_groupoid IsFreeGroupoid

namespace IsFreeGroupoid

attribute [instance] quiver_generators

/-- Two functors from a free groupoid to a group are equal when they agree on the generating
quiver. -/
@[ext]
theorem ext_functor {G} [Groupoid.{v} G] [IsFreeGroupoid G] {X : Type v} [Group X]
    (f g : G ⥤ CategoryTheory.SingleObj X) (h : ∀ (a b) (e : a ⟶ b), f.map (of e) = g.map (of e)) :
    f = g :=
  let ⟨_, _, u⟩ := @unique_lift G _ _ X _ fun (a b : Generators G) (e : a ⟶ b) => g.map (of e)
  trans (u _ h) (u _ fun _ _ _ => rfl).symm
#align is_free_groupoid.ext_functor IsFreeGroupoid.ext_functor

/-- An action groupoid over a free group is free. More generally, one could show that the groupoid
of elements over a free groupoid is free, but this version is easier to prove and suffices for our
purposes.

Analogous to the fact that a covering space of a graph is a graph. (A free groupoid is like a graph,
and a groupoid of elements is like a covering space.) -/
instance actionGroupoidIsFree {G A : Type u} [Group G] [IsFreeGroup G] [MulAction G A] :
    IsFreeGroupoid (ActionCategory G A)
    where
  quiverGenerators :=
    ⟨fun a b => { e : IsFreeGroup.Generators G // IsFreeGroup.of e • a.back = b.back }⟩
  of a b e := ⟨IsFreeGroup.of e, e.property⟩
  unique_lift := by
    intro X _ f
    let f' : fgp.generators G → (A → X) ⋊[mulAutArrow] G := fun e =>
      ⟨fun b => @f ⟨(), _⟩ ⟨(), b⟩ ⟨e, smul_inv_smul _ b⟩, fgp.of e⟩
    rcases fgp.unique_lift f' with ⟨F', hF', uF'⟩
    refine' ⟨uncurry F' _, _, _⟩
    · suffices semidirect_product.right_hom.comp F' = MonoidHom.id _ by
        exact monoid_hom.ext_iff.mp this
      ext
      rw [MonoidHom.comp_apply, hF']
      rfl
    · rintro ⟨⟨⟩, a : A⟩ ⟨⟨⟩, b⟩ ⟨e, h : fgp.of e • a = b⟩
      change (F' (fgp.of _)).left _ = _
      rw [hF']
      cases inv_smul_eq_iff.mpr h.symm
      rfl
    · intro E hE
      have : curry E = F' := by
        apply uF'
        intro e
        ext
        · convert hE _ _ _
          rfl
        · rfl
      apply functor.hext
      · intro
        apply Unit.ext
      · refine' action_category.cases _
        intros
        simp only [← this, uncurry_map, curry_apply_left, coe_back, hom_of_pair.val]
#align is_free_groupoid.action_groupoid_is_free IsFreeGroupoid.actionGroupoidIsFree

namespace SpanningTree

/- In this section, we suppose we have a free groupoid with a spanning tree for its generating
quiver. The goal is to prove that the vertex group at the root is free. A picture to have in mind
is that we are 'pulling' the endpoints of all the edges of the quiver along the spanning tree to
the root. -/
variable {G : Type u} [Groupoid.{u} G] [IsFreeGroupoid G]
  (T : WideSubquiver (Symmetrify <| Generators G)) [Arborescence T]

/-- The root of `T`, except its type is `G` instead of the type synonym `T`. -/
private def root' : G :=
  show T from root T
#align is_free_groupoid.spanning_tree.root' is_free_groupoid.spanning_tree.root'

-- this has to be marked noncomputable, see issue #451.
-- It might be nicer to define this in terms of `compose_path`
/-- A path in the tree gives a hom, by composition. -/
noncomputable def homOfPath : ∀ {a : G}, Path (root T) a → (root' T ⟶ a)
  | _, path.nil => 𝟙 _
  | a, path.cons p f => hom_of_path p ≫ Sum.recOn f.val (fun e => of e) fun e => inv (of e)
#align is_free_groupoid.spanning_tree.hom_of_path IsFreeGroupoid.SpanningTree.homOfPath

/-- For every vertex `a`, there is a canonical hom from the root, given by the path in the tree. -/
def treeHom (a : G) : root' T ⟶ a :=
  homOfPath T default
#align is_free_groupoid.spanning_tree.tree_hom IsFreeGroupoid.SpanningTree.treeHom

/-- Any path to `a` gives `tree_hom T a`, since paths in the tree are unique. -/
theorem treeHom_eq {a : G} (p : Path (root T) a) : treeHom T a = homOfPath T p := by
  rw [tree_hom, Unique.default_eq]
#align is_free_groupoid.spanning_tree.tree_hom_eq IsFreeGroupoid.SpanningTree.treeHom_eq

@[simp]
theorem treeHom_root : treeHom T (root' T) = 𝟙 _ :=
  -- this should just be `tree_hom_eq T path.nil`, but Lean treats `hom_of_path` with suspicion.
    trans
    (treeHom_eq T Path.nil) rfl
#align is_free_groupoid.spanning_tree.tree_hom_root IsFreeGroupoid.SpanningTree.treeHom_root

/-- Any hom in `G` can be made into a loop, by conjugating with `tree_hom`s. -/
def loopOfHom {a b : G} (p : a ⟶ b) : End (root' T) :=
  treeHom T a ≫ p ≫ inv (treeHom T b)
#align is_free_groupoid.spanning_tree.loop_of_hom IsFreeGroupoid.SpanningTree.loopOfHom

/- ./././Mathport/Syntax/Translate/Basic.lean:635:2: warning: expanding binder collection (e «expr ∈ » wide_subquiver_symmetrify[quiver.wide_subquiver_symmetrify] T a b) -/
/-- Turning an edge in the spanning tree into a loop gives the indentity loop. -/
theorem loopOfHom_eq_id {a b : Generators G} (e) (_ : e ∈ wideSubquiverSymmetrify T a b) :
    loopOfHom T (of e) = 𝟙 (root' T) :=
  by
  rw [loop_of_hom, ← category.assoc, is_iso.comp_inv_eq, category.id_comp]
  cases H
  · rw [tree_hom_eq T (path.cons default ⟨Sum.inl e, H⟩), hom_of_path]
    rfl
  · rw [tree_hom_eq T (path.cons default ⟨Sum.inr e, H⟩), hom_of_path]
    simp only [is_iso.inv_hom_id, category.comp_id, category.assoc, tree_hom]
#align is_free_groupoid.spanning_tree.loop_of_hom_eq_id IsFreeGroupoid.SpanningTree.loopOfHom_eq_id

/-- Since a hom gives a loop, any homomorphism from the vertex group at the root
    extends to a functor on the whole groupoid. -/
@[simps]
def functorOfMonoidHom {X} [Monoid X] (f : End (root' T) →* X) : G ⥤ CategoryTheory.SingleObj X
    where
  obj _ := ()
  map a b p := f (loopOfHom T p)
  map_id' := by
    intro a
    rw [loop_of_hom, category.id_comp, is_iso.hom_inv_id, ← End.one_def, f.map_one, id_as_one]
  map_comp' := by
    intros
    rw [comp_as_mul, ← f.map_mul]
    simp only [is_iso.inv_hom_id_assoc, loop_of_hom, End.mul_def, category.assoc]
#align is_free_groupoid.spanning_tree.functor_of_monoid_hom IsFreeGroupoid.SpanningTree.functorOfMonoidHom

/-- Given a free groupoid and an arborescence of its generating quiver, the vertex
    group at the root is freely generated by loops coming from generating arrows
    in the complement of the tree. -/
def endIsFree : IsFreeGroup (End (root' T)) :=
  IsFreeGroup.ofUniqueLift ((wideSubquiverEquivSetTotal <| wideSubquiverSymmetrify T)ᶜ : Set _)
    (fun e => loopOfHom T (of e.val.Hom))
    (by
      intro X _ f
      let f' : labelling (generators G) X := fun a b e =>
        if h : e ∈ wide_subquiver_symmetrify T a b then 1 else f ⟨⟨a, b, e⟩, h⟩
      rcases unique_lift f' with ⟨F', hF', uF'⟩
      refine' ⟨F'.map_End _, _, _⟩
      · suffices ∀ {x y} (q : x ⟶ y), F'.map (loop_of_hom T q) = (F'.map q : X)
          by
          rintro ⟨⟨a, b, e⟩, h⟩
          rw [functor.map_End_apply, this, hF']
          exact dif_neg h
        intros
        suffices ∀ {a} (p : Path (root' T) a), F'.map (hom_of_path T p) = 1 by
          simp only [this, tree_hom, comp_as_mul, inv_as_inv, loop_of_hom, inv_one, mul_one,
            one_mul, functor.map_inv, functor.map_comp]
        intro a p
        induction' p with b c p e ih
        · rw [hom_of_path, F'.map_id, id_as_one]
        rw [hom_of_path, F'.map_comp, comp_as_mul, ih, mul_one]
        rcases e with ⟨e | e, eT⟩
        · rw [hF']
          exact dif_pos (Or.inl eT)
        · rw [F'.map_inv, inv_as_inv, inv_eq_one, hF']
          exact dif_pos (Or.inr eT)
      · intro E hE
        ext
        suffices (functor_of_monoid_hom T E).map x = F'.map x by
          simpa only [loop_of_hom, functor_of_monoid_hom_map, is_iso.inv_id, tree_hom_root,
            category.id_comp, category.comp_id] using this
        congr
        apply uF'
        intro a b e
        change E (loop_of_hom T _) = dite _ _ _
        split_ifs
        · rw [loop_of_hom_eq_id T e h, ← End.one_def, E.map_one]
        · exact hE ⟨⟨a, b, e⟩, h⟩)
#align is_free_groupoid.spanning_tree.End_is_free IsFreeGroupoid.SpanningTree.endIsFree

end SpanningTree

/-- Another name for the identity function `G → G`, to help type checking. -/
private def symgen {G : Type u} [Groupoid.{v} G] [IsFreeGroupoid G] :
    G → Symmetrify (Generators G) :=
  id
#align is_free_groupoid.symgen is_free_groupoid.symgen

/-- If there exists a morphism `a → b` in a free groupoid, then there also exists a zigzag
from `a` to `b` in the generating quiver. -/
theorem path_nonempty_of_hom {G} [Groupoid.{u, u} G] [IsFreeGroupoid G] {a b : G} :
    Nonempty (a ⟶ b) → Nonempty (Path (symgen a) (symgen b)) :=
  by
  rintro ⟨p⟩
  rw [← @weakly_connected_component.eq (generators G), eq_comm, ← free_group.of_injective.eq_iff, ←
    mul_inv_eq_one]
  let X := FreeGroup (weakly_connected_component <| generators G)
  let f : G → X := fun g => FreeGroup.of (weakly_connected_component.mk g)
  let F : G ⥤ CategoryTheory.SingleObj X := single_obj.difference_functor f
  change F.map p = ((CategoryTheory.Functor.const G).obj ()).map p
  congr ; ext
  rw [functor.const_obj_map, id_as_one, difference_functor_map, mul_inv_eq_one]
  apply congr_arg FreeGroup.of
  apply (weakly_connected_component.eq _ _).mpr
  exact ⟨hom.to_path (Sum.inr e)⟩
#align is_free_groupoid.path_nonempty_of_hom IsFreeGroupoid.path_nonempty_of_hom

/-- Given a connected free groupoid, its generating quiver is rooted-connected. -/
instance generators_connected (G) [Groupoid.{u, u} G] [IsConnected G] [IsFreeGroupoid G] (r : G) :
    RootedConnected (symgen r) :=
  ⟨fun b => path_nonempty_of_hom (CategoryTheory.nonempty_hom_of_connected_groupoid r b)⟩
#align is_free_groupoid.generators_connected IsFreeGroupoid.generators_connected

/-- A vertex group in a free connected groupoid is free. With some work one could drop the
connectedness assumption, by looking at connected components. -/
instance endIsFreeOfConnectedFree {G} [Groupoid G] [IsConnected G] [IsFreeGroupoid G] (r : G) :
    IsFreeGroup (End r) :=
  SpanningTree.endIsFree <| geodesicSubtree (symgen r)
#align is_free_groupoid.End_is_free_of_connected_free IsFreeGroupoid.endIsFreeOfConnectedFree

end IsFreeGroupoid

/-- The Nielsen-Schreier theorem: a subgroup of a free group is free. -/
instance subgroupIsFreeOfIsFree {G : Type u} [Group G] [IsFreeGroup G] (H : Subgroup G) :
    IsFreeGroup H :=
  IsFreeGroup.ofMulEquiv (endMulEquivSubgroup H)
#align subgroup_is_free_of_is_free subgroupIsFreeOfIsFree


/-
Copyright (c) 2020 Bhavik Mehta, Edward Ayers, Thomas Read. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Bhavik Mehta, Edward Ayers, Thomas Read
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.category_theory.limits.shapes.finite_products
import Mathlib.category_theory.limits.preserves.shapes.binary_products
import Mathlib.category_theory.closed.monoidal
import Mathlib.category_theory.monoidal.of_has_finite_products
import Mathlib.category_theory.adjunction.default
import Mathlib.category_theory.adjunction.mates
import Mathlib.category_theory.epi_mono
import Mathlib.PostPort

universes v u u₂

namespace Mathlib

/-!
# Cartesian closed categories

Given a category with finite products, the cartesian monoidal structure is provided by the local
instance `monoidal_of_has_finite_products`.

We define exponentiable objects to be closed objects with respect to this monoidal structure,
i.e. `(X × -)` is a left adjoint.

We say a category is cartesian closed if every object is exponentiable
(equivalently, that the category equipped with the cartesian monoidal structure is closed monoidal).

Show that exponential forms a difunctor and define the exponential comparison morphisms.

## TODO
Some of the results here are true more generally for closed objects and
for closed monoidal categories, and these could be generalised.
-/

namespace category_theory

/--
An object `X` is *exponentiable* if `(X × -)` is a left adjoint.
We define this as being `closed` in the cartesian monoidal structure.
-/
def exponentiable {C : Type u} [category C] [limits.has_finite_products C] (X : C) :=
  closed X

/--
If `X` and `Y` are exponentiable then `X ⨯ Y` is.
This isn't an instance because it's not usually how we want to construct exponentials, we'll usually
prove all objects are exponential uniformly.
-/
def binary_product_exponentiable {C : Type u} [category C] [limits.has_finite_products C] {X : C} {Y : C} (hX : exponentiable X) (hY : exponentiable Y) : exponentiable (X ⨯ Y) :=
  closed.mk (adjunction.left_adjoint_of_nat_iso (iso.symm (monoidal_category.tensor_left_tensor X Y)))

/--
The terminal object is always exponentiable.
This isn't an instance because most of the time we'll prove cartesian closed for all objects
at once, rather than just for this one.
-/
def terminal_exponentiable {C : Type u} [category C] [limits.has_finite_products C] : exponentiable (⊤_C) :=
  unit_closed

/--
A category `C` is cartesian closed if it has finite products and every object is exponentiable.
We define this as `monoidal_closed` with respect to the cartesian monoidal structure.
-/
def cartesian_closed (C : Type u) [category C] [limits.has_finite_products C] :=
  monoidal_closed C

/-- This is (-)^A. -/
def exp {C : Type u} [category C] (A : C) [limits.has_finite_products C] [exponentiable A] : C ⥤ C :=
  is_left_adjoint.right (monoidal_category.tensor_left A)

/-- The adjunction between A ⨯ - and (-)^A. -/
def exp.adjunction {C : Type u} [category C] (A : C) [limits.has_finite_products C] [exponentiable A] : functor.obj limits.prod.functor A ⊣ exp A :=
  is_left_adjoint.adj

/-- The evaluation natural transformation. -/
def ev {C : Type u} [category C] (A : C) [limits.has_finite_products C] [exponentiable A] : exp A ⋙ functor.obj limits.prod.functor A ⟶ 𝟭 :=
  adjunction.counit is_left_adjoint.adj

/-- The coevaluation natural transformation. -/
def coev {C : Type u} [category C] (A : C) [limits.has_finite_products C] [exponentiable A] : 𝟭 ⟶ functor.obj limits.prod.functor A ⋙ exp A :=
  adjunction.unit is_left_adjoint.adj

@[simp] theorem exp_adjunction_counit {C : Type u} [category C] (A : C) [limits.has_finite_products C] [exponentiable A] : adjunction.counit (exp.adjunction A) = ev A :=
  rfl

@[simp] theorem exp_adjunction_unit {C : Type u} [category C] (A : C) [limits.has_finite_products C] [exponentiable A] : adjunction.unit (exp.adjunction A) = coev A :=
  rfl

@[simp] theorem ev_naturality {C : Type u} [category C] (A : C) [limits.has_finite_products C] [exponentiable A] {X : C} {Y : C} (f : X ⟶ Y) : limits.prod.map 𝟙 (functor.map (exp A) f) ≫ nat_trans.app (ev A) Y = nat_trans.app (ev A) X ≫ f :=
  nat_trans.naturality (ev A) f

@[simp] theorem coev_naturality_assoc {C : Type u} [category C] (A : C) [limits.has_finite_products C] [exponentiable A] {X : C} {Y : C} (f : X ⟶ Y) {X' : C} (f' : functor.obj (functor.obj limits.prod.functor A ⋙ exp A) Y ⟶ X') : f ≫ nat_trans.app (coev A) Y ≫ f' = nat_trans.app (coev A) X ≫ functor.map (exp A) (limits.prod.map 𝟙 f) ≫ f' := sorry

@[simp] theorem ev_coev {C : Type u} [category C] (A : C) (B : C) [limits.has_finite_products C] [exponentiable A] : limits.prod.map 𝟙 (nat_trans.app (coev A) B) ≫ nat_trans.app (ev A) (A ⨯ B) = 𝟙 :=
  adjunction.left_triangle_components (exp.adjunction A)

@[simp] theorem coev_ev {C : Type u} [category C] (A : C) (B : C) [limits.has_finite_products C] [exponentiable A] : nat_trans.app (coev A) (functor.obj (exp A) B) ≫ functor.map (exp A) (nat_trans.app (ev A) B) = 𝟙 :=
  adjunction.right_triangle_components (exp.adjunction A)

protected instance obj.limits.preserves_colimits {C : Type u} [category C] (A : C) [limits.has_finite_products C] [exponentiable A] : limits.preserves_colimits (functor.obj limits.prod.functor A) :=
  adjunction.left_adjoint_preserves_colimits (exp.adjunction A)

-- Wrap these in a namespace so we don't clash with the core versions.

namespace cartesian_closed

/-- Currying in a cartesian closed category. -/
def curry {C : Type u} [category C] {A : C} {X : C} {Y : C} [limits.has_finite_products C] [exponentiable A] : (A ⨯ Y ⟶ X) → (Y ⟶ functor.obj (exp A) X) :=
  equiv.to_fun (adjunction.hom_equiv is_left_adjoint.adj Y X)

/-- Uncurrying in a cartesian closed category. -/
def uncurry {C : Type u} [category C] {A : C} {X : C} {Y : C} [limits.has_finite_products C] [exponentiable A] : (Y ⟶ functor.obj (exp A) X) → (A ⨯ Y ⟶ X) :=
  equiv.inv_fun (adjunction.hom_equiv is_left_adjoint.adj Y X)

end cartesian_closed

theorem curry_natural_left_assoc {C : Type u} [category C] {A : C} {X : C} {X' : C} {Y : C} [limits.has_finite_products C] [exponentiable A] (f : X ⟶ X') (g : A ⨯ X' ⟶ Y) : ∀ {X'_1 : C} (f' : functor.obj (exp A) Y ⟶ X'_1),
  cartesian_closed.curry (limits.prod.map 𝟙 f ≫ g) ≫ f' = f ≫ cartesian_closed.curry g ≫ f' := sorry

theorem curry_natural_right_assoc {C : Type u} [category C] {A : C} {X : C} {Y : C} {Y' : C} [limits.has_finite_products C] [exponentiable A] (f : A ⨯ X ⟶ Y) (g : Y ⟶ Y') {X' : C} (f' : functor.obj (exp A) Y' ⟶ X') : cartesian_closed.curry (f ≫ g) ≫ f' = cartesian_closed.curry f ≫ functor.map (exp A) g ≫ f' := sorry

theorem uncurry_natural_right {C : Type u} [category C] {A : C} {X : C} {Y : C} {Y' : C} [limits.has_finite_products C] [exponentiable A] (f : X ⟶ functor.obj (exp A) Y) (g : Y ⟶ Y') : cartesian_closed.uncurry (f ≫ functor.map (exp A) g) = cartesian_closed.uncurry f ≫ g :=
  adjunction.hom_equiv_naturality_right_symm is_left_adjoint.adj f g

theorem uncurry_natural_left {C : Type u} [category C] {A : C} {X : C} {X' : C} {Y : C} [limits.has_finite_products C] [exponentiable A] (f : X ⟶ X') (g : X' ⟶ functor.obj (exp A) Y) : cartesian_closed.uncurry (f ≫ g) = limits.prod.map 𝟙 f ≫ cartesian_closed.uncurry g :=
  adjunction.hom_equiv_naturality_left_symm is_left_adjoint.adj f g

@[simp] theorem uncurry_curry {C : Type u} [category C] {A : C} {X : C} {Y : C} [limits.has_finite_products C] [exponentiable A] (f : A ⨯ X ⟶ Y) : cartesian_closed.uncurry (cartesian_closed.curry f) = f :=
  equiv.left_inv (adjunction.hom_equiv is_left_adjoint.adj X Y) f

@[simp] theorem curry_uncurry {C : Type u} [category C] {A : C} {X : C} {Y : C} [limits.has_finite_products C] [exponentiable A] (f : X ⟶ functor.obj (exp A) Y) : cartesian_closed.curry (cartesian_closed.uncurry f) = f :=
  equiv.right_inv (adjunction.hom_equiv is_left_adjoint.adj X Y) f

theorem curry_eq_iff {C : Type u} [category C] {A : C} {X : C} {Y : C} [limits.has_finite_products C] [exponentiable A] (f : A ⨯ Y ⟶ X) (g : Y ⟶ functor.obj (exp A) X) : cartesian_closed.curry f = g ↔ f = cartesian_closed.uncurry g :=
  adjunction.hom_equiv_apply_eq is_left_adjoint.adj f g

theorem eq_curry_iff {C : Type u} [category C] {A : C} {X : C} {Y : C} [limits.has_finite_products C] [exponentiable A] (f : A ⨯ Y ⟶ X) (g : Y ⟶ functor.obj (exp A) X) : g = cartesian_closed.curry f ↔ cartesian_closed.uncurry g = f :=
  adjunction.eq_hom_equiv_apply is_left_adjoint.adj f g

-- I don't think these two should be simp.

theorem uncurry_eq {C : Type u} [category C] {A : C} {X : C} {Y : C} [limits.has_finite_products C] [exponentiable A] (g : Y ⟶ functor.obj (exp A) X) : cartesian_closed.uncurry g = limits.prod.map 𝟙 g ≫ nat_trans.app (ev A) X :=
  adjunction.hom_equiv_counit is_left_adjoint.adj

theorem curry_eq {C : Type u} [category C] {A : C} {X : C} {Y : C} [limits.has_finite_products C] [exponentiable A] (g : A ⨯ Y ⟶ X) : cartesian_closed.curry g = nat_trans.app (coev A) Y ≫ functor.map (exp A) g :=
  adjunction.hom_equiv_unit is_left_adjoint.adj

theorem uncurry_id_eq_ev {C : Type u} [category C] [limits.has_finite_products C] (A : C) (X : C) [exponentiable A] : cartesian_closed.uncurry 𝟙 = nat_trans.app (ev A) X := sorry

theorem curry_id_eq_coev {C : Type u} [category C] [limits.has_finite_products C] (A : C) (X : C) [exponentiable A] : cartesian_closed.curry 𝟙 = nat_trans.app (coev A) X := sorry

theorem curry_injective {C : Type u} [category C] {A : C} {X : C} {Y : C} [limits.has_finite_products C] [exponentiable A] : function.injective cartesian_closed.curry :=
  equiv.injective (adjunction.hom_equiv is_left_adjoint.adj Y X)

theorem uncurry_injective {C : Type u} [category C] {A : C} {X : C} {Y : C} [limits.has_finite_products C] [exponentiable A] : function.injective cartesian_closed.uncurry :=
  equiv.injective (equiv.symm (adjunction.hom_equiv is_left_adjoint.adj Y X))

/--
Show that the exponential of the terminal object is isomorphic to itself, i.e. `X^1 ≅ X`.

The typeclass argument is explicit: any instance can be used.
-/
def exp_terminal_iso_self {C : Type u} [category C] {X : C} [limits.has_finite_products C] [exponentiable (⊤_C)] : functor.obj (exp (⊤_C)) X ≅ X :=
  yoneda.ext (functor.obj (exp (⊤_C)) X) X
    (fun (Y : C) (f : Y ⟶ functor.obj (exp (⊤_C)) X) => iso.inv (limits.prod.left_unitor Y) ≫ cartesian_closed.uncurry f)
    (fun (Y : C) (f : Y ⟶ X) => cartesian_closed.curry (iso.hom (limits.prod.left_unitor Y) ≫ f)) sorry sorry sorry

/-- The internal element which points at the given morphism. -/
def internalize_hom {C : Type u} [category C] {A : C} {Y : C} [limits.has_finite_products C] [exponentiable A] (f : A ⟶ Y) : ⊤_C ⟶ functor.obj (exp A) Y :=
  cartesian_closed.curry (limits.prod.fst ≫ f)

/-- Pre-compose an internal hom with an external hom. -/
def pre {C : Type u} [category C] {A : C} {B : C} [limits.has_finite_products C] [exponentiable A] (f : B ⟶ A) [exponentiable B] : exp A ⟶ exp B :=
  coe_fn (transfer_nat_trans_self (exp.adjunction A) (exp.adjunction B)) (functor.map limits.prod.functor f)

theorem prod_map_pre_app_comp_ev {C : Type u} [category C] {A : C} {B : C} [limits.has_finite_products C] [exponentiable A] (f : B ⟶ A) [exponentiable B] (X : C) : limits.prod.map 𝟙 (nat_trans.app (pre f) X) ≫ nat_trans.app (ev B) X = limits.prod.map f 𝟙 ≫ nat_trans.app (ev A) X :=
  transfer_nat_trans_self_counit (exp.adjunction A) (exp.adjunction B) (functor.map limits.prod.functor f) X

theorem uncurry_pre {C : Type u} [category C] {A : C} {B : C} [limits.has_finite_products C] [exponentiable A] (f : B ⟶ A) [exponentiable B] (X : C) : cartesian_closed.uncurry (nat_trans.app (pre f) X) = limits.prod.map f 𝟙 ≫ nat_trans.app (ev A) X := sorry

theorem coev_app_comp_pre_app {C : Type u} [category C] {A : C} {B : C} {X : C} [limits.has_finite_products C] [exponentiable A] (f : B ⟶ A) [exponentiable B] : nat_trans.app (coev A) X ≫ nat_trans.app (pre f) (A ⨯ X) =
  nat_trans.app (coev B) X ≫ functor.map (exp B) (limits.prod.map f 𝟙) :=
  unit_transfer_nat_trans_self is_left_adjoint.adj (exp.adjunction B) (functor.map limits.prod.functor f) X

@[simp] theorem pre_id {C : Type u} [category C] [limits.has_finite_products C] (A : C) [exponentiable A] : pre 𝟙 = 𝟙 := sorry

@[simp] theorem pre_map {C : Type u} [category C] [limits.has_finite_products C] {A₁ : C} {A₂ : C} {A₃ : C} [exponentiable A₁] [exponentiable A₂] [exponentiable A₃] (f : A₁ ⟶ A₂) (g : A₂ ⟶ A₃) : pre (f ≫ g) = pre g ≫ pre f := sorry

/-- The internal hom functor given by the cartesian closed structure. -/
def internal_hom {C : Type u} [category C] [limits.has_finite_products C] [cartesian_closed C] : Cᵒᵖ ⥤ C ⥤ C :=
  functor.mk (fun (X : Cᵒᵖ) => exp (opposite.unop X)) fun (X Y : Cᵒᵖ) (f : X ⟶ Y) => pre (has_hom.hom.unop f)

/-- If an initial object `I` exists in a CCC, then `A ⨯ I ≅ I`. -/
@[simp] theorem zero_mul_hom {C : Type u} [category C] {A : C} [limits.has_finite_products C] [exponentiable A] {I : C} (t : limits.is_initial I) : iso.hom (zero_mul t) = limits.prod.snd :=
  Eq.refl (iso.hom (zero_mul t))

/-- If an initial object `0` exists in a CCC, then `0 ⨯ A ≅ 0`. -/
def mul_zero {C : Type u} [category C] {A : C} [limits.has_finite_products C] [exponentiable A] {I : C} (t : limits.is_initial I) : I ⨯ A ≅ I :=
  limits.prod.braiding I A ≪≫ zero_mul t

/-- If an initial object `0` exists in a CCC then `0^B ≅ 1` for any `B`. -/
def pow_zero {C : Type u} [category C] (B : C) [limits.has_finite_products C] {I : C} (t : limits.is_initial I) [cartesian_closed C] : functor.obj (exp I) B ≅ ⊤_C :=
  iso.mk Inhabited.default (cartesian_closed.curry (iso.hom (mul_zero t) ≫ limits.is_initial.to t B))

-- TODO: Generalise the below to its commutated variants.

-- TODO: Define a distributive category, so that zero_mul and friends can be derived from this.

/-- In a CCC with binary coproducts, the distribution morphism is an isomorphism. -/
def prod_coprod_distrib {C : Type u} [category C] [limits.has_finite_products C] [limits.has_binary_coproducts C] [cartesian_closed C] (X : C) (Y : C) (Z : C) : Z ⨯ X ⨿ (Z ⨯ Y) ≅ Z ⨯ (X ⨿ Y) :=
  iso.mk (limits.coprod.desc (limits.prod.map 𝟙 limits.coprod.inl) (limits.prod.map 𝟙 limits.coprod.inr))
    (cartesian_closed.uncurry
      (limits.coprod.desc (cartesian_closed.curry limits.coprod.inl) (cartesian_closed.curry limits.coprod.inr)))

/--
If an initial object `I` exists in a CCC then it is a strict initial object,
i.e. any morphism to `I` is an iso.
This actually shows a slightly stronger version: any morphism to an initial object from an
exponentiable object is an isomorphism.
-/
def strict_initial {C : Type u} [category C] {A : C} [limits.has_finite_products C] [exponentiable A] {I : C} (t : limits.is_initial I) (f : A ⟶ I) : is_iso f :=
  is_iso_of_mono_of_split_epi f

protected instance to_initial_is_iso {C : Type u} [category C] {A : C} [limits.has_finite_products C] [exponentiable A] [limits.has_initial C] (f : A ⟶ ⊥_C) : is_iso f :=
  strict_initial limits.initial_is_initial f

/-- If an initial object `0` exists in a CCC then every morphism from it is monic. -/
theorem initial_mono {C : Type u} [category C] [limits.has_finite_products C] {I : C} (B : C) (t : limits.is_initial I) [cartesian_closed C] : mono (limits.is_initial.to t B) :=
  mono.mk
    fun (B_1 : C) (g h : B_1 ⟶ I) (_x : g ≫ limits.is_initial.to t B = h ≫ limits.is_initial.to t B) =>
      eq_of_inv_eq_inv (limits.is_initial.hom_ext t (inv g) (inv h))

protected instance initial.mono_to {C : Type u} [category C] [limits.has_finite_products C] [limits.has_initial C] (B : C) [cartesian_closed C] : mono (limits.initial.to B) :=
  initial_mono B limits.initial_is_initial

/--
Transport the property of being cartesian closed across an equivalence of categories.

Note we didn't require any coherence between the choice of finite products here, since we transport
along the `prod_comparison` isomorphism.
-/
def cartesian_closed_of_equiv {C : Type u} [category C] [limits.has_finite_products C] {D : Type u₂} [category D] [limits.has_finite_products D] (e : C ≌ D) [h : cartesian_closed C] : cartesian_closed D :=
  monoidal_closed.mk
    fun (X : D) =>
      closed.mk
        (adjunction.left_adjoint_of_nat_iso
          (iso_whisker_right (equivalence.counit_iso e)
              (functor.obj limits.prod.functor X ⋙ equivalence.inverse e ⋙ equivalence.functor e) ≪≫
            id (iso_whisker_left (functor.obj limits.prod.functor X) (equivalence.counit_iso e))))


/-
Copyright (c) 2022 Jujian Zhang. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Jujian Zhang, Eric Wieser

! This file was ported from Lean 3 source module algebra.graded_mul_action
! leanprover-community/mathlib commit 0ebfdb71919ac6ca5d7fbc61a082fa2519556818
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Algebra.GradedMonoid

/-!
# Additively-graded multiplicative action structures

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

This module provides a set of heterogeneous typeclasses for defining a multiplicative structure
over the sigma type `graded_monoid A` such that `(•) : A i → M j → M (i + j)`; that is to say, `A`
has an additively-graded multiplicative action on `M`. The typeclasses are:

* `graded_monoid.ghas_smul A M`
* `graded_monoid.gmul_action A M`

With the `sigma_graded` locale open, these respectively imbue:

* `has_smul (graded_monoid A) (graded_monoid M)`
* `mul_action (graded_monoid A) (graded_monoid M)`

For now, these typeclasses are primarily used in the construction of `direct_sum.gmodule.module` and
the rest of that file.

## Internally graded multiplicative actions

In addition to the above typeclasses, in the most frequent case when `A` is an indexed collection of
`set_like` subobjects (such as `add_submonoid`s, `add_subgroup`s, or `submodule`s), this file
provides the `Prop` typeclasses:

* `set_like.has_graded_smul A M` (which provides the obvious `graded_monoid.ghas_smul A` instance)

which provides the API lemma

* `set_like.graded_smul_mem_graded`

Note that there is no need for `set_like.graded_mul_action` or similar, as all the information it
would contain is already supplied by `has_graded_smul` when the objects within `A` and `M` have
a `mul_action` instance.

## tags

graded action
-/

variable {ι : Type _}

namespace GradedMonoid

/-! ### Typeclasses -/

section Defs

variable (A : ι → Type _) (M : ι → Type _)

#print GradedMonoid.GSmul /-
/-- A graded version of `has_smul`. Scalar multiplication combines grades additively, i.e.
if `a ∈ A i` and `m ∈ M j`, then `a • b` must be in `M (i + j)`-/
class GSmul [Add ι] where
  smul {i j} : A i → M j → M (i + j)
#align graded_monoid.ghas_smul GradedMonoid.GSmul
-/

#print GradedMonoid.GMul.toGSmul /-
/-- A graded version of `has_mul.to_has_smul` -/
instance GMul.toGSmul [Add ι] [GMul A] : GSmul A A where smul _ _ := GMul.mul
#align graded_monoid.ghas_mul.to_ghas_smul GradedMonoid.GMul.toGSmul
-/

#print GradedMonoid.GSmul.toSMul /-
instance GSmul.toSMul [Add ι] [GSmul A M] : SMul (GradedMonoid A) (GradedMonoid M) :=
  ⟨fun (x : GradedMonoid A) (y : GradedMonoid M) => ⟨_, GSmul.smul x.snd y.snd⟩⟩
#align graded_monoid.ghas_smul.to_has_smul GradedMonoid.GSmul.toSMul
-/

/- warning: graded_monoid.mk_smul_mk -> GradedMonoid.mk_smul_mk is a dubious translation:
lean 3 declaration is
  forall {ι : Type.{u1}} (A : ι -> Type.{u2}) (M : ι -> Type.{u3}) [_inst_1 : Add.{u1} ι] [_inst_2 : GradedMonoid.GSmul.{u1, u2, u3} ι A M _inst_1] {i : ι} {j : ι} (a : A i) (b : M j), Eq.{succ (max u1 u3)} (GradedMonoid.{u1, u3} ι (fun {j : ι} => M j)) (SMul.smul.{max u1 u2, max u1 u3} (GradedMonoid.{u1, u2} ι (fun {i : ι} => A i)) (GradedMonoid.{u1, u3} ι (fun {j : ι} => M j)) (GradedMonoid.GSmul.toSMul.{u1, u2, u3} ι (fun {i : ι} => A i) (fun {j : ι} => M j) _inst_1 _inst_2) (GradedMonoid.mk.{u1, u2} ι (fun {i : ι} => A i) i a) (GradedMonoid.mk.{u1, u3} ι (fun {j : ι} => M j) j b)) (GradedMonoid.mk.{u1, u3} ι (fun {j : ι} => M j) (HAdd.hAdd.{u1, u1, u1} ι ι ι (instHAdd.{u1} ι _inst_1) i j) (GradedMonoid.GSmul.smul.{u1, u2, u3} ι (fun {i : ι} => A i) M _inst_1 _inst_2 i j a b))
but is expected to have type
  forall {ι : Type.{u3}} (A : ι -> Type.{u2}) (M : ι -> Type.{u1}) [_inst_1 : Add.{u3} ι] [_inst_2 : GradedMonoid.GSmul.{u3, u2, u1} ι A M _inst_1] {i : ι} {j : ι} (a : A i) (b : M j), Eq.{max (succ u3) (succ u1)} (GradedMonoid.{u3, u1} ι M) (HSMul.hSMul.{max u2 u3, max u1 u3, max u3 u1} (GradedMonoid.{u3, u2} ι A) (GradedMonoid.{u3, u1} ι M) (GradedMonoid.{u3, u1} ι M) (instHSMul.{max u3 u2, max u3 u1} (GradedMonoid.{u3, u2} ι A) (GradedMonoid.{u3, u1} ι M) (GradedMonoid.GSmul.toSMul.{u3, u2, u1} ι A M _inst_1 _inst_2)) (GradedMonoid.mk.{u3, u2} ι A i a) (GradedMonoid.mk.{u3, u1} ι M j b)) (GradedMonoid.mk.{u3, u1} ι M (HAdd.hAdd.{u3, u3, u3} ι ι ι (instHAdd.{u3} ι _inst_1) i j) (GradedMonoid.GSmul.smul.{u3, u2, u1} ι A M _inst_1 _inst_2 i j a b))
Case conversion may be inaccurate. Consider using '#align graded_monoid.mk_smul_mk GradedMonoid.mk_smul_mkₓ'. -/
theorem mk_smul_mk [Add ι] [GSmul A M] {i j} (a : A i) (b : M j) :
    mk i a • mk j b = mk (i + j) (GSmul.smul a b) :=
  rfl
#align graded_monoid.mk_smul_mk GradedMonoid.mk_smul_mk

#print GradedMonoid.GMulAction /-
/-- A graded version of `mul_action`. -/
class GMulAction [AddMonoid ι] [GMonoid A] extends GSmul A M where
  one_smul (b : GradedMonoid M) : (1 : GradedMonoid A) • b = b
  mul_smul (a a' : GradedMonoid A) (b : GradedMonoid M) : (a * a') • b = a • a' • b
#align graded_monoid.gmul_action GradedMonoid.GMulAction
-/

#print GradedMonoid.GMonoid.toGMulAction /-
/-- The graded version of `monoid.to_mul_action`. -/
instance GMonoid.toGMulAction [AddMonoid ι] [GMonoid A] : GMulAction A A :=
  { GMul.toGSmul _ with
    one_smul := GMonoid.one_mul
    mul_smul := GMonoid.mul_assoc }
#align graded_monoid.gmonoid.to_gmul_action GradedMonoid.GMonoid.toGMulAction
-/

#print GradedMonoid.GMulAction.toMulAction /-
instance GMulAction.toMulAction [AddMonoid ι] [GMonoid A] [GMulAction A M] :
    MulAction (GradedMonoid A) (GradedMonoid M)
    where
  one_smul := GMulAction.one_smul
  mul_smul := GMulAction.mul_smul
#align graded_monoid.gmul_action.to_mul_action GradedMonoid.GMulAction.toMulAction
-/

end Defs

end GradedMonoid

/-! ### Shorthands for creating instance of the above typeclasses for collections of subobjects -/

section Subobjects

variable {R : Type _}

#print SetLike.GradedSmul /-
/-- A version of `graded_monoid.ghas_smul` for internally graded objects. -/
class SetLike.GradedSmul {S R N M : Type _} [SetLike S R] [SetLike N M] [SMul R M] [Add ι]
  (A : ι → S) (B : ι → N) : Prop where
  smul_mem : ∀ ⦃i j : ι⦄ {ai bj}, ai ∈ A i → bj ∈ B j → ai • bj ∈ B (i + j)
#align set_like.has_graded_smul SetLike.GradedSmul
-/

#print SetLike.toGSmul /-
instance SetLike.toGSmul {S R N M : Type _} [SetLike S R] [SetLike N M] [SMul R M] [Add ι]
    (A : ι → S) (B : ι → N) [SetLike.GradedSmul A B] :
    GradedMonoid.GSmul (fun i => A i) fun i => B i
    where smul i j a b := ⟨(a : R) • b, SetLike.GradedSmul.smul_mem a.2 b.2⟩
#align set_like.ghas_smul SetLike.toGSmul
-/

/- warning: set_like.coe_ghas_smul -> SetLike.coe_GSmul is a dubious translation:
lean 3 declaration is
  forall {ι : Type.{u1}} {S : Type.{u2}} {R : Type.{u3}} {N : Type.{u4}} {M : Type.{u5}} [_inst_1 : SetLike.{u2, u3} S R] [_inst_2 : SetLike.{u4, u5} N M] [_inst_3 : SMul.{u3, u5} R M] [_inst_4 : Add.{u1} ι] (A : ι -> S) (B : ι -> N) [_inst_5 : SetLike.GradedSmul.{u1, u2, u3, u4, u5} ι S R N M _inst_1 _inst_2 _inst_3 _inst_4 A B] {i : ι} {j : ι} (x : coeSort.{succ u2, succ (succ u3)} S Type.{u3} (SetLike.hasCoeToSort.{u2, u3} S R _inst_1) (A i)) (y : coeSort.{succ u4, succ (succ u5)} N Type.{u5} (SetLike.hasCoeToSort.{u4, u5} N M _inst_2) (B j)), Eq.{succ u5} M ((fun (a : Type.{u5}) (b : Type.{u5}) [self : HasLiftT.{succ u5, succ u5} a b] => self.0) ((fun (i : ι) => coeSort.{succ u4, succ (succ u5)} N Type.{u5} (SetLike.hasCoeToSort.{u4, u5} N M _inst_2) (B i)) (HAdd.hAdd.{u1, u1, u1} ι ι ι (instHAdd.{u1} ι _inst_4) i j)) M (HasLiftT.mk.{succ u5, succ u5} ((fun (i : ι) => coeSort.{succ u4, succ (succ u5)} N Type.{u5} (SetLike.hasCoeToSort.{u4, u5} N M _inst_2) (B i)) (HAdd.hAdd.{u1, u1, u1} ι ι ι (instHAdd.{u1} ι _inst_4) i j)) M (CoeTCₓ.coe.{succ u5, succ u5} ((fun (i : ι) => coeSort.{succ u4, succ (succ u5)} N Type.{u5} (SetLike.hasCoeToSort.{u4, u5} N M _inst_2) (B i)) (HAdd.hAdd.{u1, u1, u1} ι ι ι (instHAdd.{u1} ι _inst_4) i j)) M (coeBase.{succ u5, succ u5} ((fun (i : ι) => coeSort.{succ u4, succ (succ u5)} N Type.{u5} (SetLike.hasCoeToSort.{u4, u5} N M _inst_2) (B i)) (HAdd.hAdd.{u1, u1, u1} ι ι ι (instHAdd.{u1} ι _inst_4) i j)) M (coeSubtype.{succ u5} M (fun (x : M) => Membership.Mem.{u5, u4} M N (SetLike.hasMem.{u4, u5} N M _inst_2) x (B (HAdd.hAdd.{u1, u1, u1} ι ι ι (instHAdd.{u1} ι _inst_4) i j))))))) (GradedMonoid.GSmul.smul.{u1, u3, u5} ι (fun (i : ι) => coeSort.{succ u2, succ (succ u3)} S Type.{u3} (SetLike.hasCoeToSort.{u2, u3} S R _inst_1) (A i)) (fun (i : ι) => coeSort.{succ u4, succ (succ u5)} N Type.{u5} (SetLike.hasCoeToSort.{u4, u5} N M _inst_2) (B i)) _inst_4 (SetLike.toGSmul.{u1, u2, u3, u4, u5} ι S R N M _inst_1 _inst_2 _inst_3 _inst_4 (fun (i : ι) => A i) (fun (i : ι) => B i) _inst_5) i j x y)) (SMul.smul.{u3, u5} R M _inst_3 ((fun (a : Type.{u3}) (b : Type.{u3}) [self : HasLiftT.{succ u3, succ u3} a b] => self.0) (coeSort.{succ u2, succ (succ u3)} S Type.{u3} (SetLike.hasCoeToSort.{u2, u3} S R _inst_1) (A i)) R (HasLiftT.mk.{succ u3, succ u3} (coeSort.{succ u2, succ (succ u3)} S Type.{u3} (SetLike.hasCoeToSort.{u2, u3} S R _inst_1) (A i)) R (CoeTCₓ.coe.{succ u3, succ u3} (coeSort.{succ u2, succ (succ u3)} S Type.{u3} (SetLike.hasCoeToSort.{u2, u3} S R _inst_1) (A i)) R (coeBase.{succ u3, succ u3} (coeSort.{succ u2, succ (succ u3)} S Type.{u3} (SetLike.hasCoeToSort.{u2, u3} S R _inst_1) (A i)) R (coeSubtype.{succ u3} R (fun (x : R) => Membership.Mem.{u3, u2} R S (SetLike.hasMem.{u2, u3} S R _inst_1) x (A i)))))) x) ((fun (a : Type.{u5}) (b : Type.{u5}) [self : HasLiftT.{succ u5, succ u5} a b] => self.0) (coeSort.{succ u4, succ (succ u5)} N Type.{u5} (SetLike.hasCoeToSort.{u4, u5} N M _inst_2) (B j)) M (HasLiftT.mk.{succ u5, succ u5} (coeSort.{succ u4, succ (succ u5)} N Type.{u5} (SetLike.hasCoeToSort.{u4, u5} N M _inst_2) (B j)) M (CoeTCₓ.coe.{succ u5, succ u5} (coeSort.{succ u4, succ (succ u5)} N Type.{u5} (SetLike.hasCoeToSort.{u4, u5} N M _inst_2) (B j)) M (coeBase.{succ u5, succ u5} (coeSort.{succ u4, succ (succ u5)} N Type.{u5} (SetLike.hasCoeToSort.{u4, u5} N M _inst_2) (B j)) M (coeSubtype.{succ u5} M (fun (x : M) => Membership.Mem.{u5, u4} M N (SetLike.hasMem.{u4, u5} N M _inst_2) x (B j)))))) y))
but is expected to have type
  forall {ι : Type.{u1}} {S : Type.{u5}} {R : Type.{u4}} {N : Type.{u3}} {M : Type.{u2}} [_inst_1 : SetLike.{u5, u4} S R] [_inst_2 : SetLike.{u3, u2} N M] [_inst_3 : SMul.{u4, u2} R M] [_inst_4 : Add.{u1} ι] (A : ι -> S) (B : ι -> N) [_inst_5 : SetLike.GradedSmul.{u1, u5, u4, u3, u2} ι S R N M _inst_1 _inst_2 _inst_3 _inst_4 A B] {i : ι} {j : ι} (x : Subtype.{succ u4} R (fun (x : R) => Membership.mem.{u4, u5} R S (SetLike.instMembership.{u5, u4} S R _inst_1) x (A i))) (y : Subtype.{succ u2} M (fun (x : M) => Membership.mem.{u2, u3} M N (SetLike.instMembership.{u3, u2} N M _inst_2) x (B j))), Eq.{succ u2} M (Subtype.val.{succ u2} M (fun (x : M) => Membership.mem.{u2, u2} M (Set.{u2} M) (Set.instMembershipSet.{u2} M) x (SetLike.coe.{u3, u2} N M _inst_2 (B (HAdd.hAdd.{u1, u1, u1} ι ι ι (instHAdd.{u1} ι _inst_4) i j)))) (GradedMonoid.GSmul.smul.{u1, u4, u2} ι (fun (i : ι) => Subtype.{succ u4} R (fun (x : R) => Membership.mem.{u4, u5} R S (SetLike.instMembership.{u5, u4} S R _inst_1) x (A i))) (fun (i : ι) => Subtype.{succ u2} M (fun (x : M) => Membership.mem.{u2, u3} M N (SetLike.instMembership.{u3, u2} N M _inst_2) x (B i))) _inst_4 (SetLike.toGSmul.{u1, u5, u4, u3, u2} ι S R N M _inst_1 _inst_2 _inst_3 _inst_4 (fun (i : ι) => A i) (fun (i : ι) => B i) _inst_5) i j x y)) (HSMul.hSMul.{u4, u2, u2} R M M (instHSMul.{u4, u2} R M _inst_3) (Subtype.val.{succ u4} R (fun (x : R) => Membership.mem.{u4, u5} R S (SetLike.instMembership.{u5, u4} S R _inst_1) x (A i)) x) (Subtype.val.{succ u2} M (fun (x : M) => Membership.mem.{u2, u3} M N (SetLike.instMembership.{u3, u2} N M _inst_2) x (B j)) y))
Case conversion may be inaccurate. Consider using '#align set_like.coe_ghas_smul SetLike.coe_GSmulₓ'. -/
@[simp]
theorem SetLike.coe_GSmul {S R N M : Type _} [SetLike S R] [SetLike N M] [SMul R M] [Add ι]
    (A : ι → S) (B : ι → N) [SetLike.GradedSmul A B] {i j : ι} (x : A i) (y : B j) :
    (@GradedMonoid.GSmul.smul ι (fun i => A i) (fun i => B i) _ _ i j x y : M) = (x : R) • y :=
  rfl
#align set_like.coe_ghas_smul SetLike.coe_GSmul

/- warning: set_like.has_graded_mul.to_has_graded_smul -> SetLike.GradedMul.toGradedSmul is a dubious translation:
lean 3 declaration is
  forall {ι : Type.{u1}} {R : Type.{u2}} [_inst_1 : AddMonoid.{u1} ι] [_inst_2 : Monoid.{u2} R] {S : Type.{u3}} [_inst_3 : SetLike.{u3, u2} S R] (A : ι -> S) [_inst_4 : SetLike.GradedMonoid.{u1, u2, u3} ι R S _inst_3 _inst_2 _inst_1 A], SetLike.GradedSmul.{u1, u3, u2, u3, u2} ι S R S R _inst_3 _inst_3 (Mul.toSMul.{u2} R (MulOneClass.toHasMul.{u2} R (Monoid.toMulOneClass.{u2} R _inst_2))) (AddZeroClass.toHasAdd.{u1} ι (AddMonoid.toAddZeroClass.{u1} ι _inst_1)) A A
but is expected to have type
  forall {ι : Type.{u1}} {R : Type.{u2}} [_inst_1 : AddMonoid.{u1} ι] [_inst_2 : Monoid.{u2} R] {S : Type.{u3}} [_inst_3 : SetLike.{u3, u2} S R] (A : ι -> S) [_inst_4 : SetLike.GradedMonoid.{u1, u2, u3} ι R S _inst_3 _inst_2 _inst_1 A], SetLike.GradedSmul.{u1, u3, u2, u3, u2} ι S R S R _inst_3 _inst_3 (MulAction.toSMul.{u2, u2} R R _inst_2 (Monoid.toMulAction.{u2} R _inst_2)) (AddZeroClass.toAdd.{u1} ι (AddMonoid.toAddZeroClass.{u1} ι _inst_1)) A A
Case conversion may be inaccurate. Consider using '#align set_like.has_graded_mul.to_has_graded_smul SetLike.GradedMul.toGradedSmulₓ'. -/
/-- Internally graded version of `has_mul.to_has_smul`. -/
instance SetLike.GradedMul.toGradedSmul [AddMonoid ι] [Monoid R] {S : Type _} [SetLike S R]
    (A : ι → S) [SetLike.GradedMonoid A] : SetLike.GradedSmul A A
    where smul_mem i j ai bj hi hj := SetLike.GradedMonoid.mul_mem hi hj
#align set_like.has_graded_mul.to_has_graded_smul SetLike.GradedMul.toGradedSmul

end Subobjects

section HomogeneousElements

variable {S R N M : Type _} [SetLike S R] [SetLike N M]

/- warning: set_like.is_homogeneous.graded_smul -> SetLike.Homogeneous.graded_smul is a dubious translation:
lean 3 declaration is
  forall {ι : Type.{u1}} {S : Type.{u2}} {R : Type.{u3}} {N : Type.{u4}} {M : Type.{u5}} [_inst_1 : SetLike.{u2, u3} S R] [_inst_2 : SetLike.{u4, u5} N M] [_inst_3 : Add.{u1} ι] [_inst_4 : SMul.{u3, u5} R M] {A : ι -> S} {B : ι -> N} [_inst_5 : SetLike.GradedSmul.{u1, u2, u3, u4, u5} ι S R N M _inst_1 _inst_2 _inst_4 _inst_3 A B] {a : R} {b : M}, (SetLike.Homogeneous.{u1, u3, u2} ι R S _inst_1 A a) -> (SetLike.Homogeneous.{u1, u5, u4} ι M N _inst_2 B b) -> (SetLike.Homogeneous.{u1, u5, u4} ι M N _inst_2 B (SMul.smul.{u3, u5} R M _inst_4 a b))
but is expected to have type
  forall {ι : Type.{u5}} {S : Type.{u2}} {R : Type.{u4}} {N : Type.{u1}} {M : Type.{u3}} [_inst_1 : SetLike.{u2, u4} S R] [_inst_2 : SetLike.{u1, u3} N M] [_inst_3 : Add.{u5} ι] [_inst_4 : SMul.{u4, u3} R M] {A : ι -> S} {B : ι -> N} [_inst_5 : SetLike.GradedSmul.{u5, u2, u4, u1, u3} ι S R N M _inst_1 _inst_2 _inst_4 _inst_3 A B] {a : R} {b : M}, (SetLike.Homogeneous.{u5, u4, u2} ι R S _inst_1 A a) -> (SetLike.Homogeneous.{u5, u3, u1} ι M N _inst_2 B b) -> (SetLike.Homogeneous.{u5, u3, u1} ι M N _inst_2 B (HSMul.hSMul.{u4, u3, u3} R M M (instHSMul.{u4, u3} R M _inst_4) a b))
Case conversion may be inaccurate. Consider using '#align set_like.is_homogeneous.graded_smul SetLike.Homogeneous.graded_smulₓ'. -/
theorem SetLike.Homogeneous.graded_smul [Add ι] [SMul R M] {A : ι → S} {B : ι → N}
    [SetLike.GradedSmul A B] {a : R} {b : M} :
    SetLike.Homogeneous A a → SetLike.Homogeneous B b → SetLike.Homogeneous B (a • b)
  | ⟨i, hi⟩, ⟨j, hj⟩ => ⟨i + j, SetLike.GradedSmul.smul_mem hi hj⟩
#align set_like.is_homogeneous.graded_smul SetLike.Homogeneous.graded_smul

end HomogeneousElements


/-
Copyright (c) 2019 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import category_theory.yoneda
import topology.sheaves.presheaf
import topology.category.TopCommRing
import topology.continuous_function.algebra

/-!
# Presheaves of functions

We construct some simple examples of presheaves of functions on a topological space.
* `presheaf_to_Types X T`, where `T : X → Type`,
  is the presheaf of dependently-typed (not-necessarily continuous) functions
* `presheaf_to_Type X T`, where `T : Type`,
  is the presheaf of (not-necessarily-continuous) functions to a fixed target type `T`
* `presheaf_to_Top X T`, where `T : Top`,
  is the presheaf of continuous functions into a topological space `T`
* `presheaf_To_TopCommRing X R`, where `R : TopCommRing`
  is the presheaf valued in `CommRing` of functions functions into a topological ring `R`
* as an example of the previous construction,
  `presheaf_to_TopCommRing X (TopCommRing.of ℂ)`
  is the presheaf of rings of continuous complex-valued functions on `X`.
-/

universes v u

open category_theory
open topological_space
open opposite

namespace Top

variables (X : Top.{v})

/--
The presheaf of dependently typed functions on `X`, with fibres given by a type family `T`.
There is no requirement that the functions are continuous, here.
-/
def presheaf_to_Types (T : X → Type v) : X.presheaf (Type v) :=
{ obj := λ U, Π x : (unop U), T x,
  map := λ U V i g, λ (x : unop V), g (i.unop x) }

@[simp] lemma presheaf_to_Types_obj
  {T : X → Type v} {U : (opens X)ᵒᵖ} :
  (presheaf_to_Types X T).obj U = Π x : (unop U), T x :=
rfl

@[simp] lemma presheaf_to_Types_map
  {T : X → Type v} {U V : (opens X)ᵒᵖ} {i : U ⟶ V} {f} :
  (presheaf_to_Types X T).map i f = λ x, f (i.unop x) :=
rfl

/--
The presheaf of functions on `X` with values in a type `T`.
There is no requirement that the functions are continuous, here.
-/
-- We don't just define this in terms of `presheaf_to_Types`,
-- as it's helpful later to see (at a syntactic level) that `(presheaf_to_Type X T).obj U`
-- is a non-dependent function.
-- We don't use `@[simps]` to generate the projection lemmas here,
-- as it turns out to be useful to have `presheaf_to_Type_map`
-- written as an equality of functions (rather than being applied to some argument).
def presheaf_to_Type (T : Type v) : X.presheaf (Type v) :=
{ obj := λ U, (unop U) → T,
  map := λ U V i g, g ∘ i.unop }

@[simp] lemma presheaf_to_Type_obj
  {T : Type v} {U : (opens X)ᵒᵖ} :
  (presheaf_to_Type X T).obj U = ((unop U) → T) :=
rfl

@[simp] lemma presheaf_to_Type_map
  {T : Type v} {U V : (opens X)ᵒᵖ} {i : U ⟶ V} {f} :
  (presheaf_to_Type X T).map i f = f ∘ i.unop :=
rfl

/-- The presheaf of continuous functions on `X` with values in fixed target topological space
`T`. -/
def presheaf_to_Top (T : Top.{v}) : X.presheaf (Type v) :=
(opens.to_Top X).op ⋙ (yoneda.obj T)

@[simp] lemma presheaf_to_Top_obj (T : Top.{v}) (U : (opens X)ᵒᵖ) :
  (presheaf_to_Top X T).obj U = ((opens.to_Top X).obj (unop U) ⟶ T) :=
rfl

/-- The (bundled) commutative ring of continuous functions from a topological space
to a topological commutative ring, with pointwise multiplication. -/
-- TODO upgrade the result to TopCommRing?
def continuous_functions (X : Top.{v}ᵒᵖ) (R : TopCommRing.{v}) : CommRing.{v} :=
CommRing.of (unop X ⟶ (forget₂ TopCommRing Top).obj R)

namespace continuous_functions

/-- Pulling back functions into a topological ring along a continuous map is a ring homomorphism. -/
def pullback {X Y : Topᵒᵖ} (f : X ⟶ Y) (R : TopCommRing) :
  continuous_functions X R ⟶ continuous_functions Y R :=
{ to_fun := λ g, f.unop ≫ g,
  map_one' := rfl,
  map_zero' := rfl,
  map_add' := by tidy,
  map_mul' := by tidy }

/-- A homomorphism of topological rings can be postcomposed with functions from a source space `X`;
this is a ring homomorphism (with respect to the pointwise ring operations on functions). -/
def map (X : Top.{u}ᵒᵖ) {R S : TopCommRing.{u}} (φ : R ⟶ S) :
  continuous_functions X R ⟶ continuous_functions X S :=
{ to_fun := λ g, g ≫ ((forget₂ TopCommRing Top).map φ),
  map_one' := by ext; exact φ.1.map_one,
  map_zero' := by ext; exact φ.1.map_zero,
  map_add' := by intros; ext; apply φ.1.map_add,
  map_mul' := by intros; ext; apply φ.1.map_mul }
end continuous_functions

/-- An upgraded version of the Yoneda embedding, observing that the continuous maps
from `X : Top` to `R : TopCommRing` form a commutative ring, functorial in both `X` and `R`. -/
def CommRing_yoneda : TopCommRing.{u} ⥤ (Top.{u}ᵒᵖ ⥤ CommRing.{u}) :=
{ obj := λ R,
  { obj := λ X, continuous_functions X R,
    map := λ X Y f, continuous_functions.pullback f R },
  map := λ R S φ,
  { app := λ X, continuous_functions.map X φ } }

/--
The presheaf (of commutative rings), consisting of functions on an open set `U ⊆ X` with
values in some topological commutative ring `T`.

For example, we could construct the presheaf of continuous complex valued functions of `X` as
```
presheaf_to_TopCommRing X (TopCommRing.of ℂ)
```
(this requires `import topology.instances.complex`).
-/
def presheaf_to_TopCommRing (T : TopCommRing.{v}) :
  X.presheaf CommRing.{v} :=
(opens.to_Top X).op ⋙ (CommRing_yoneda.obj T)

end Top


import Category.Init

/-!
# Category **Set**

`CSet` is the **Set** category:
- objects are all the sets, and
- arrows are all the total functions between sets.
-/

namespace Cat.CSet

  structure All where
    Elm : α
    set : Set α

  @[simp]
  def All.mem (self : All) (elm : self.Elm) : Prop :=
    elm ∈ self.set

  --- `Membership` would be nice but the dependent nature of `All.mem` prevents it AFAICT.
  infixr:60 " ∋ " => All.mem

  structure Fn (s₁ s₂ : All) where
    apply (a₁ : s₁.Elm) : s₁ ∋ a₁ → s₂.Elm
    apply_post (a₁ : s₁.Elm) (legal₁ : s₁ ∋ a₁) :
      s₂ ∋ apply a₁ legal₁

  def Fn.compose
    (g : Fn s₂ s₃)
    (f : Fn s₁ s₂)
    : Fn s₁ s₃
  where
    apply (a₁ : s₁.Elm) (legal₁ : s₁ ∋ a₁) :=
      let a₂ := f.apply a₁ legal₁
      let legal₂ := f.apply_post a₁ legal₁
      g.apply a₂ legal₂
    apply_post (a₁ : s₁.Elm) (legal₁ : s₁ ∋ a₁) :=
      let a₂ := f.apply a₁ legal₁
      let legal₂ := f.apply_post a₁ legal₁
      g.apply_post a₂ legal₂

  theorem Fn.compose_assoc
    (h : Fn s₃ s₄)
    (g : Fn s₂ s₃)
    (f : Fn s₁ s₂)
    : h.compose (g.compose f) = (h.compose g).compose f
  :=
    rfl

  protected def Fn.id {s : outParam All} : Fn s s where
    apply a _ := a
    apply_post _ := id

  theorem Fn.compose_id
    (f : Fn s₁ s₂)
    : f.compose Fn.id = f
  :=
    rfl

  theorem Fn.id_compose
    (f : Fn s₁ s₂)
    : Fn.id.compose f = f
  :=
    rfl

end Cat.CSet

instance Cat.CSet : Cat.Abstract CSet.All CSet.Fn where
  compose :=
    CSet.Fn.compose
  compose_assoc :=
    CSet.Fn.compose_assoc

  id :=
    @CSet.Fn.id
  id_compose :=
    CSet.Fn.id_compose
  compose_id :=
    CSet.Fn.compose_id


import category_theory.colimit_lemmas
import homotopy_theory.formal.cylinder.hep

import .category
import .colimits
import .cylinder
import .homeomorphism
import .inter_union
import .smush

noncomputable theory

open set

open category_theory (hiding preimage_id)
local notation f ` ∘ `:80 g:80 := g ≫ f

namespace homotopy_theory.topological_spaces
open homotopy_theory.topological_spaces.Top
local notation `Top` := Top.{0}

structure pair :=
(space : Top)
(subset : set space)

variables (P Q R : pair)
-- TODO: Is this too weird?
local notation `X` := P.space
local notation `A` := P.subset
local notation `Y` := Q.space
local notation `B` := Q.subset
local notation `Z` := R.space
local notation `C` := R.subset

-- The subspace component of a pair, considered as a space.
def pair.subspace := Top.mk_ob A

local notation `A'` := P.subspace
local notation `B'` := Q.subspace

-- The inclusion of the subspace, considered as a morphism of Top.
@[reducible] def pair.incl : A' ⟶ X := incl A

section homeomorphism

def Top.homeomorphism.of_pairs (h : homeomorphism X Y) : Prop := A = h.hom ⁻¹' B
structure pair.homeomorphism :=
(h : homeomorphism X Y)
(is_of_pairs : h.of_pairs P Q)

notation P ` ≅ₚ ` Q := pair.homeomorphism P Q

variables {P Q R}
include P Q

lemma pair.homeomorphism.is_of_pairs' (h : P ≅ₚ Q) : A = h.h.equiv ⁻¹' B :=
h.is_of_pairs

lemma pair.homeomorphism.is_of_pairs.mk' (h : homeomorphism X Y)
  (ha : ∀ a ∈ A, h.hom a ∈ B) (hb : ∀ b ∈ B, h.inv b ∈ A) : h.of_pairs P Q :=
begin
  ext p, split, { exact ha p },
  { intro hp, apply function.comp _ (hb (h.hom p)) hp,
    change h.equiv.symm (h.equiv p) ∈ _ → p ∈ _,
    simp }
end

def pair.homeomorphism.on_subspaces (h : P ≅ₚ Q) : homeomorphism A' B' :=
h.h.restrict h.is_of_pairs

lemma is_closed_congr (h : P ≅ₚ Q) : is_closed A ↔ is_closed B :=
by rw [h.is_of_pairs', h.h.is_closed_iff]; refl

@[symm] def pair.homeomorphism.symm (h : P ≅ₚ Q) : Q ≅ₚ P :=
pair.homeomorphism.mk h.h.symm $
  show B = h.h.equiv.symm ⁻¹' A, from
  by rw [h.is_of_pairs', ←set.preimage_comp]; simp [preimage_id]

include R

@[trans] def pair.homeomorphism.trans (h₁ : P ≅ₚ Q) (h₂ : Q ≅ₚ R) : P ≅ₚ R :=
pair.homeomorphism.mk (h₁.h.trans h₂.h) $
  show A = (function.comp h₂.h.equiv h₁.h.equiv) ⁻¹' C, from
  by rw [set.preimage_comp, h₁.is_of_pairs', h₂.is_of_pairs']

end homeomorphism

@[reducible] def pair.empty (W : Top) : pair := pair.mk W ∅

section prod

def pair.prod : pair :=
pair.mk (Top.prod X Y) {p | p.1 ∈ A ∨ p.2 ∈ B}

notation P ` ⊗ `:35 Q:34 := pair.prod P Q

variables {P Q R}
include P Q

lemma pair.prod.is_closed (ha : is_closed A) (hb : is_closed B) :
  is_closed (P ⊗ Q).subset :=
is_closed_union
   (continuous_iff_is_closed.mp continuous_fst _ ha)
   (continuous_iff_is_closed.mp continuous_snd _ hb)

lemma prod_comm_is_of_pairs : prod_comm.of_pairs (P ⊗ Q) (Q ⊗ P) :=
by ext pq; cases pq; exact or.comm

def pair.prod_comm : P ⊗ Q ≅ₚ Q ⊗ P :=
pair.homeomorphism.mk prod_comm prod_comm_is_of_pairs

include R

lemma prod_assoc_is_of_pairs : prod_assoc.of_pairs ((P ⊗ Q) ⊗ R) (P ⊗ (Q ⊗ R)) :=
by ext pqr; rcases pqr with ⟨⟨p, q⟩, r⟩; exact or.assoc

def pair.prod_assoc : (P ⊗ Q) ⊗ R ≅ₚ P ⊗ (Q ⊗ R) :=
pair.homeomorphism.mk prod_assoc prod_assoc_is_of_pairs

-- Maybe we should have made `pair` a category and P ⊗ - a functor
def pair.prod.congr_right (h : Q ≅ₚ R) : P ⊗ Q ≅ₚ P ⊗ R :=
pair.homeomorphism.mk h.h.prod_congr_right
  begin
    ext pq, cases pq with p q,
    change p ∈ A ∨ q ∈ B ↔ p ∈ A ∨ q ∈ h.h.equiv ⁻¹' C,
    rw h.is_of_pairs'
  end

end prod

section pushout

/-

If A and B are closed, then there is a pushout square

  A × B → X × B
    ↓       ↓
  A × Y → (P ⊗ Q).subspace = A × Y ∪ X × B.

Note that A × B here denotes the product of the (sub)spaces A and B,
not the subspace of X × Y on the product of the subsets A and B; and
the same for A × Y and X × B.

-/

variables (ha : is_closed A) (hb : is_closed B)

-- TODO: product bifunctor
protected def pair.i₀ : Top.prod A' B' ⟶ Top.prod A' Y :=
Top.mk_hom (λ p, (p.1, p.2.val)) (by continuity!)

protected def pair.i₁ : Top.prod A' B' ⟶ Top.prod X B' :=
Top.mk_hom (λ p, (p.1.val, p.2)) (by continuity!)

protected def pair.j₀ : Top.prod A' Y ⟶ (P ⊗ Q).subspace :=
Top.mk_hom (λ p, ⟨(p.1.val, p.2), or.inl p.1.property⟩)
  (by continuity!)

protected def pair.j₁ : Top.prod X B' ⟶ (P ⊗ Q).subspace :=
Top.mk_hom (λ p, ⟨(p.1, p.2.val), or.inr p.2.property⟩)
  (by continuity!)

local notation `XY` := Top.prod X Y

-- Establish an isomorphism to the intersection-union pushout square
-- of subspaces of X × Y.

-- The next few definitions are very slow to compile! Was it always this way?

protected def pair.k : homeomorphism (Top.prod A' B') (Top.mk_ob {p : XY | p.1 ∈ A ∧ p.2 ∈ B}) :=
{ hom :=
    Top.mk_hom
      (λ p, ⟨(p.1.val, p.2.val), ⟨p.1.property, p.2.property⟩⟩)
      (by continuity!),
  inv :=
    Top.mk_hom
      (λ p, (⟨p.val.1, p.property.left⟩, ⟨p.val.2, p.property.right⟩))
      (by continuity!),
  hom_inv_id' := by ext p; rcases p with ⟨⟨a, ha⟩, ⟨b, hb⟩⟩; refl,
  inv_hom_id' := by ext p; rcases p with ⟨⟨a, b⟩, ⟨ha, hb⟩⟩; refl }

protected def pair.l1 : homeomorphism (Top.prod A' Y) (Top.mk_ob {p : XY | p.1 ∈ A}) :=
{ hom := Top.mk_hom (λ p, ⟨(p.1.val, p.2), p.1.property⟩) (by continuity!),
  inv := Top.mk_hom (λ p, (⟨p.val.1, p.property⟩, p.val.2)) (by continuity!),
  hom_inv_id' := by ext p; rcases p with ⟨⟨a, ha⟩, y⟩; refl,
  inv_hom_id' := by ext p; rcases p with ⟨⟨a, y⟩, ha⟩; refl }

protected def pair.l2 : homeomorphism (Top.prod X B') (Top.mk_ob {p : XY | p.2 ∈ B}) :=
{ hom := Top.mk_hom (λ p, ⟨(p.1, p.2.val), p.2.property⟩) (by continuity!),
  inv := Top.mk_hom (λ p, (p.val.1, ⟨p.val.2, p.property⟩)) (by continuity!),
  hom_inv_id' := by ext p; rcases p with ⟨x, ⟨b, hb⟩⟩; refl,
  inv_hom_id' := by ext p; rcases p with ⟨⟨x, b⟩, hb⟩; refl }

protected def pair.po :
  Is_pushout (pair.i₀ P Q) (pair.i₁ P Q) (pair.j₀ P Q) (pair.j₁ P Q) :=
Is_pushout_of_isomorphic
  (@Is_pushout_inter_union (Top.prod X Y) _ _
    (continuous_iff_is_closed.mp continuous_fst _ ha)
    (continuous_iff_is_closed.mp continuous_snd _ hb))
  (pair.i₀ P Q) (pair.i₁ P Q)
  (pair.k P Q) (pair.l1 P Q) (pair.l2 P Q) (by funext; refl) (by funext; refl)

end pushout

section interval

def I_0 : pair := pair.mk I01 {0}
instance I_0.subspace.has_zero : has_zero I_0.subspace :=
⟨⟨(0 : I01), mem_singleton _⟩⟩

def I_0.subspace.singleton : * ≃ I_0.subspace :=
{ to_fun := λ _, 0,
  inv_fun := λ _, punit.star,
  left_inv := λ ⟨⟩, rfl,
  right_inv := λ z, show 0 = z, from subtype.eq (mem_singleton_iff.mp z.property).symm }

end interval

section cofibered

open homotopy_theory.cylinder
local notation `i` := i.{0}

-- A pair is cofibered if the inclusion of the subspace is a
-- cofibration.
def pair.cofibered : Prop := hep 0 P.incl

lemma pair.empty_cofibered (W : Top) : (pair.empty W).cofibered :=
have Is_initial_object.{0} (pair.empty W).subspace, from
  Top.is_initial_object_of_to_empty _ (by intro p; rcases p with ⟨_,⟨⟩⟩),
hep_initial_induced 0 this
  (preserves_initial_object.Is_initial_object_of_Is_initial_object this)

def pair.admits_retract : Prop := ∃ r : X ⟶ A', r ∘ P.incl = 𝟙 A'

-- A pair (X, A) is cofibered if and only if the inclusion map of the
-- pair (X × I, A × I ∪ X × {0}) admits a retract.
--
-- This result holds even without the assumption that A is closed; see
-- [Strøm, Note on Cofibrations II, Theorem 2]. However, a more
-- intricate argument is then needed to show that A × I ∪ X × {0} is a
-- pushout when (X, A) is cofibered.
lemma pair.cofibered_iff (ha : is_closed A) :
  P.cofibered ↔ (P ⊗ I_0).admits_retract :=
have po : _ := pair.po P I_0 ha (is_closed_singleton : is_closed (_ : set I01)),
have po' : _ :=
  Is_pushout_of_isomorphic po
    (i 0 @> P.subspace) P.incl
    (prod_singleton I_0.subspace.singleton)
    (homeomorphism.refl _)
    (prod_singleton I_0.subspace.singleton)
    (by ext; refl) (by ext; refl),
iff.trans (homotopy_theory.cylinder.hep_iff_pushout_retract 0 po'.transpose) $ begin
  have : pair.incl (P ⊗ I_0) = po'.transpose.induced (i 0 @> X) (I &> pair.incl P) _, {
    apply po'.uniqueness,
    { rw [Is_pushout.induced_commutes₁], refl },
    { rw [Is_pushout.induced_commutes₀], refl },
  },
  unfold pair.admits_retract, rw this, refl
end

variables {P Q}
-- TODO: Should these be ↔?
lemma admits_retract_congr (h : P ≅ₚ Q) : P.admits_retract → Q.admits_retract :=
assume ⟨r, hr⟩,
⟨h.on_subspaces.hom ∘ r ∘ h.h.inv, calc
  h.on_subspaces.hom ∘ r ∘ h.h.inv ∘ Q.incl
    = h.on_subspaces.hom ∘ r ∘ h.h.inv ∘
      (Q.incl ∘ h.on_subspaces.hom) ∘ h.on_subspaces.inv      : by simp
... = h.on_subspaces.hom ∘ (r ∘ P.incl) ∘ h.on_subspaces.inv
    : by simp [pair.homeomorphism.on_subspaces, homeomorphism.restriction_commutes]
... = 𝟙 _  : by rw hr; simp⟩

lemma cofibered_congr (h : P ≅ₚ Q) (ha : is_closed A) : P.cofibered → Q.cofibered :=
have P ⊗ I_0 ≅ₚ Q ⊗ I_0, from calc
  P ⊗ I_0 ≅ₚ I_0 ⊗ P  : pair.prod_comm
  ...     ≅ₚ I_0 ⊗ Q  : pair.prod.congr_right h -- TODO: congr_left
  ...     ≅ₚ Q ⊗ I_0  : pair.prod_comm,
calc
  P.cofibered
    → (P ⊗ I_0).admits_retract  : (P.cofibered_iff ha).mp
... → (Q ⊗ I_0).admits_retract  : admits_retract_congr this
... → Q.cofibered               : (Q.cofibered_iff ((is_closed_congr h).mp ha)).mpr

lemma prod_empty_admits_retract (K : Top) :
  P.admits_retract → (P ⊗ pair.empty K).admits_retract :=
assume ⟨r, hr⟩,
let r' : Top.prod X K ⟶ (P ⊗ pair.empty K).subspace :=
  pair.j₀ P (pair.empty K) ∘ Top.prod_maps r (𝟙 K) in
begin
  existsi r',
  ext p; rcases p with ⟨⟨a, k⟩, h|⟨⟨⟩⟩⟩,
  { change (r a).val = a,
    exact congr_arg subtype.val (@@Top.hom_congr hr ⟨a, h⟩) },
  { refl }
end

-- A condition for the product of closed pairs to be
-- cofibered. Actually, P and Q only need to be cofibered (and only
-- one of them needs to be closed); see [Strøm, Note on Cofibrations
-- II, Theorem 6]. The argument is more intricate and the statement
-- below will suffice for our purposes. We'll show that (Dⁿ, Sⁿ⁻¹)
-- satisfies the hypothesis on Q.
lemma prod_cofibered (ha : is_closed A) (hb : is_closed B)
  (hq : Q ⊗ I_0 ≅ₚ pair.empty Y ⊗ I_0) :
  P.cofibered → (P ⊗ Q).cofibered :=
let Q' := pair.empty Y in
have _ := calc
  (P ⊗ I_0) ⊗ Q'
    ≅ₚ P ⊗ (I_0 ⊗ Q')  : pair.prod_assoc
... ≅ₚ P ⊗ (Q' ⊗ I_0)  : pair.prod.congr_right pair.prod_comm
... ≅ₚ P ⊗ (Q ⊗ I_0)   : pair.prod.congr_right hq.symm
... ≅ₚ (P ⊗ Q) ⊗ I_0   : pair.prod_assoc.symm,
calc
  P.cofibered
    → (P ⊗ I_0).admits_retract         : (pair.cofibered_iff P ha).mp
... → ((P ⊗ I_0) ⊗ Q').admits_retract  : prod_empty_admits_retract _
... → ((P ⊗ Q) ⊗ I_0).admits_retract   : admits_retract_congr this
... → (P ⊗ Q).cofibered  : (pair.cofibered_iff _ (pair.prod.is_closed ha hb)).mpr

section smush

variables (V : Type) [topological_space V] [smush.admissible' V]

def unit_disk : Top :=
Top.mk_ob (smush.unit_disk V)

def unit_disk_sphere : pair :=
pair.mk (unit_disk V) {v | smush.admissible.norm v.val = (1 : ℝ)}

lemma unit_disk_sphere.is_closed : is_closed (unit_disk_sphere V).subset :=
is_closed_eq (by continuity!) continuous_const

def smush : unit_disk_sphere V ⊗ I_0 ≅ₚ pair.empty (unit_disk V) ⊗ I_0 :=
pair.homeomorphism.mk
  (homeomorphism.of_equiv (smush.H_equiv V)
    (smush.continuous_H V) (smush.continuous_vHv V))
  (begin
    change {p : unit_disk V × I01 | _ ∨ p.2 ∈ ({0} : set I01)} =
      (smush.H V) ⁻¹' {p : unit_disk V × I01 | p.1 ∈ ∅ ∨ p.2 ∈ ({0} : set I01)},
    convert smush.Ht0 V;
    { ext p, change _ ∨ _ ↔ _ ∨ _, apply or_congr (iff.refl _),
      rw mem_singleton_iff, apply subtype.ext_iff },
  end)

lemma prod_disk_sphere_cofibered (ha : is_closed A) :
  P.cofibered → (P ⊗ unit_disk_sphere V).cofibered :=
prod_cofibered P _ ha (unit_disk_sphere.is_closed V) (smush V)

end smush

def I_01 := pair.mk I01 {0, 1}
def I_01_is_D1_S0 : I_01 ≅ₚ unit_disk_sphere ℝ :=
pair.homeomorphism.mk
  { hom :=
      Top.mk_hom
        (λ t, ⟨2 * t.val - 1, by cases t.property; erw abs_le; split; linarith⟩)
        (by continuity!),
    inv :=
      Top.mk_hom
        (λ t, by refine ⟨(1 / 2) * (t.val + 1), _, _⟩; cases abs_le.mp t.property; linarith)
        (by continuity!),
    hom_inv_id' := begin
      ext t,
      change (1 / 2) * ((2 * t.val - 1) + 1) = t.val,
      ring
    end,
    inv_hom_id' := begin
      ext t,
      change 2 * ((1 / 2) * (t.val + 1)) - 1 = t.val,
      ring
    end }
  begin
    apply pair.homeomorphism.is_of_pairs.mk',
    { intros a ha, change a ∈ {(0 : I01), (1 : I01)} at ha,
      have ha' : a = (0 : I01) ∨ a = (1 : I01) := by simp at ha; exact ha,
      cases ha' with ha' ha',
      { subst ha', change abs (2 * (0 : ℝ) - 1) = 1, norm_num },
      { subst ha', change abs (2 * (1 : ℝ) - 1) = 1, norm_num } },
    { intros b hb, cases b with b hb', change abs b = 1 at hb,
      rw abs_eq at hb, swap, exact zero_le_one,
      cases hb with hb hb; change subtype.mk _ _ ∈ I_01.subset,
      { subst hb, have : (1 : I01) ∈ ({0, 1} : set I01), by simp, convert this, norm_num },
      { subst hb, have : (0 : I01) ∈ ({0, 1} : set I01), by simp, convert this, norm_num } }
  end

lemma I_01.is_closed : is_closed I_01.subset :=
(is_closed_congr I_01_is_D1_S0).mpr (unit_disk_sphere.is_closed ℝ)

lemma prod_I_01_cofibered (ha : is_closed A) :
  P.cofibered → (P ⊗ I_01).cofibered :=
calc
  P.cofibered
    → (P ⊗ unit_disk_sphere ℝ).cofibered
    : prod_disk_sphere_cofibered P ℝ ha
... → (P ⊗ I_01).cofibered
    : cofibered_congr (pair.prod.congr_right I_01_is_D1_S0.symm)
        (pair.prod.is_closed ha (unit_disk_sphere.is_closed ℝ))

end cofibered

end homotopy_theory.topological_spaces


import Lean.Meta
import Lean.Elab
import Mathlib.Algebra.Group.Defs
import Std
import Lean
import Experiments.ProdSeq
import Experiments.GeneralAbelianGroup
open Lean Meta Elab Nat Term Std ProdSeq ToExpr

instance (n: ℕ) : Inhabited (ℤ ^ n) := ⟨zeros n⟩

def ℤbasisElem (n : ℕ) (j : ℕ) : ℤ ^ n := ℤbasis n |>.get! j

theorem List.get!_of_get [Inhabited α] : (k : ℕ) → (l : List α) → (hk : k < l.length) → l.get! k = l.get ⟨k, hk⟩
  | _, .nil, _ => by contradiction
  | .zero, .cons _ _, _ => rfl
  | .succ _, .cons _ _, _ => by rw [get!, get]; apply get!_of_get

@[simp] theorem induced_free_map_at {A : Type _} [AddCommGroup A] {n : ℕ} (l : List A) (h : l.length = n) (k: ℕ) (hk : k < n) :
 (inducedFreeMap l h) (ℤbasisElem n k) = l.get ⟨k, h ▸ hk⟩ := by
   rw [ℤbasisElem, List.get!_of_get, List.mapget (inducedFreeMap l h)]
   apply List.get_index_eq; apply map_basis
   · simp [h, hk]

section ToExpr

instance : ToExpr Int where
  toExpr :=
    fun
      | Int.ofNat n => mkApp (mkConst ``Int.ofNat) $ toExpr n
      | Int.negSucc n => mkApp (mkConst ``Int.negSucc) $ toExpr n
  toTypeExpr := mkConst ``Int

instance prodToExpr {A B : Type _} [ToExpr A] [ToExpr B] : ToExpr (A × B) := inferInstance

instance : ToExpr Unit where
  toExpr := fun | Unit.unit => mkConst ``Unit.unit
  toTypeExpr := mkConst ``Unit

@[instance] def powToExpr {A : Type _} [ToExpr A] : (n : ℕ) → ToExpr (A ^ n)
  | .zero => inferInstanceAs (ToExpr Unit)
  | .succ m => @prodToExpr _ _ inferInstance $ powToExpr m

instance {α : Type _} [ToExpr α] : ToExpr (List α) where
  toExpr :=
    let rec lstexpr : List α → Expr
      | .nil => mkConst ``List.nil
      | .cons h t => mkApp (mkApp (mkConst ``List.cons) $ toExpr h) $ lstexpr t
    lstexpr
  toTypeExpr := mkApp (mkConst ``List) $ toTypeExpr α

end ToExpr

def zeroExpr : ℕ → TermElabM Expr
| 0 => return mkConst ``Unit.unit
| n + 1 => do mkAppM ``Prod.mk #[toExpr (0 : Int), ←  zeroExpr n]

def ℤbasisExpr : ℕ → ℕ → TermElabM Expr
| 0, _ => return mkConst ``Unit.unit
| n + 1, 0 => do mkAppM ``Prod.mk #[toExpr (1 : Int), ←  zeroExpr n]
| n + 1, k + 1 => do mkAppM ``Prod.mk #[toExpr (1 : Int), ← ℤbasisExpr n k]

elab "ℤbasisElem#"  n:term "at" j:term  : term => do
      let nExp ← elabTerm n (some <| mkConst ``Nat)
      let jExp ← elabTerm j (some <| mkConst ``Nat)
      mkAppM ``ℤbasisElem #[nExp, jExp]

elab "ℤbasisExpr#"  n:term "at" j:term  : term => do
      let nExp ← elabTerm n (some <| mkConst ``Nat)
      let jExp ← elabTerm j (some <| mkConst ``Nat)
      let n ← exprNat nExp
      let j ← exprNat jExp
      ℤbasisExpr n j

#eval ℤbasisElem# 3 at 1
#eval ℤbasisExpr# 3 at 1

def ℤbasisArrM (n: ℕ): TermElabM (Array Expr) := do
  let mut arr := #[]
  for j in [0:n] do
    arr := arr.push (← mkAppM ``ℤbasisElem #[toExpr n, toExpr j])
  return arr

-- def ℤbasisArrM (n: ℕ): TermElabM (Array Expr) := do
--  return ℤbasis n |>.map toExpr |>.toArray

elab "arr#"  n:term "at" j:term  : term => do
      let nExp ← elabTerm n (some <| mkConst ``Nat)
      let jExp ← elabTerm j (some <| mkConst ``Nat)
      let n' ← exprNat nExp
      let j' ← exprNat jExp
      let arr ← ℤbasisArrM n'
      return arr[j']

#eval arr# 7 at 2

def toFreeM (e : Expr) : TermElabM Expr := do
  let t ← addTreeM e
  let (indTree, lst) ← AddTree.indexTreeM'' t
  let arr ←  ℤbasisArrM (lst.length)
  IndexAddTree.foldMapM indTree arr

elab "free#" t:term : term => do
  let e ← elabTerm t none
  toFreeM e

def egFree {α : Type _}[AddCommGroup α][Repr α][DecidableEq α][Inhabited α]
    (x y : α) := free# (x + y + x - y + x + y)

#eval egFree (5 : ℤ) (2 : ℤ )

def provedLength{α : Type _}(l: List α) : PSigma (fun n : ℕ  => l.length = n) := PSigma.mk (l.length) rfl

@[simp] def inducedFreeMap!{A: Type _}[AddCommGroup A](l: List A) :=
    @inducedFreeMap A _ l.length l rfl

instance ind_hom! {A : Type _} [AddCommGroup A]  (l : List A)  : AddCommGroup.Homomorphism (inducedFreeMap! l) := FreeAbelianGroup.induced_hom A _

def viaFreeM (e: Expr) : TermElabM Expr := do
  let t ← addTreeM e
  let (indTree, lst) ← AddTree.indexTreeM'' t
  let lstPackPair ←  listToExpr lst
  let (lstPack, α) := lstPackPair
  let pl ← mkAppM ``provedLength #[lstPack]
  let n ← exprNat (← mkAppM ``PSigma.fst #[pl])
  let pf ← mkAppM ``PSigma.snd #[pl]
  let pf' ← mkAppOptM
      ``Eq.trans #[none, none, none, toExpr n, pf,
        ← mkAppM ``Eq.refl #[toExpr n]]
  let n := List.length lst
--  let pf ← mkAppM ``Eq.refl #[toExpr lst.length]
  let arr ←  ℤbasisArrM n
  let freeElem ← IndexAddTree.foldMapM indTree arr
  let fromFree ← mkAppOptM
      ``inducedFreeMap #[some α, none, some <| toExpr n, some lstPack, some (pf')]
  mkAppM' fromFree #[freeElem]

elab "viafree#" t:term : term => do
  let e ← elabTerm t none
  viaFreeM e

def egViaFree {α : Type}[AddCommGroup α][Repr α][DecidableEq α][Inhabited α]
   (x y : α) := viafree# (x + y + x - y + x + y)

#eval egViaFree (5 : ℤ) (2 : ℤ)

theorem egViaFreeEql{α : Type}[AddCommGroup α][Repr α][DecidableEq α][Inhabited α]
    (x y z : α) : x + z - y + x - y + z =  viafree# (x + z - y + x - y + z)  := by
       simp only [AddCommGroup.Homomorphism.neg_dist, AddCommGroup.add_distrib, induced_free_map_at, List.get]

#print egViaFreeEql

def freeGroupEqM (e : Expr) : TermElabM Expr := do
  let freeElemIm ← viaFreeM e
  let eqn ← mkEq e freeElemIm
  let mvar ← mkFreshExprMVar $ some eqn
  let tac ← `(tactic| simp only [AddCommGroup.Homomorphism.neg_dist, AddCommGroup.add_distrib, induced_free_map_at, List.get])
  let (goals, _) ← Elab.runTactic mvar.mvarId! tac
  guard goals.isEmpty
  match freeElemIm with
    | .app ϕ freeElem _ =>
      let freeElemR ← reduce freeElem -- the transparency here can be adjusted
      let res ← mkFreshExprMVar $ some $ ← mkEq e (mkApp ϕ freeElemR)
      assignExprMVar res.mvarId! mvar
      return res
    | _ => failure

elab "freeGroupEq#" t:term : term => do
  freeGroupEqM $ ← elabTerm t none

#check (fun (x y z : ℤ) => freeGroupEq# x + x + y - x - y + z - x)

example {x y z : ℤ} : x + x + y - x - y + z - x = z := by
    have p := freeGroupEq# (x + x + y - x - y + z - x)
    rw [p, map_free_elem]
    simp [List.sum]
    rw [SubNegMonoid.gsmul_zero', zero_add, SubNegMonoid.gsmul_zero', zero_add, SubNegMonoid.gsmul_one]