/-
Copyright (c) 2019 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison, Bhavik Mehta
-/
import category_theory.monad.adjunction
import category_theory.adjunction.limits
import category_theory.limits.preserves.shapes.terminal

/-!
# Limits and colimits in the category of algebras

This file shows that the forgetful functor `forget T : algebra T ⥤ C` for a monad `T : C ⥤ C`
creates limits and creates any colimits which `T` preserves.
This is used to show that `algebra T` has any limits which `C` has, and any colimits which `C` has
and `T` preserves.
This is generalised to the case of a monadic functor `D ⥤ C`.

## TODO

Dualise for the category of coalgebras and comonadic left adjoints.
-/

namespace category_theory
open category
open category_theory.limits

universes v₁ v₂ u₁ u₂ -- morphism levels before object levels. See note [category_theory universes].

namespace monad

variables {C : Type u₁} [category.{v₁} C]
variables {T : monad C}

variables {J : Type v₁} [small_category J]

namespace forget_creates_limits

variables (D : J ⥤ algebra T) (c : cone (D ⋙ T.forget)) (t : is_limit c)

/-- (Impl) The natural transformation used to define the new cone -/
@[simps] def γ : (D ⋙ T.forget ⋙ ↑T) ⟶ D ⋙ T.forget := { app := λ j, (D.obj j).a }

/-- (Impl) This new cone is used to construct the algebra structure -/
@[simps π_app] def new_cone : cone (D ⋙ forget T) :=
{ X := T.obj c.X,
  π := (functor.const_comp _ _ ↑T).inv ≫ whisker_right c.π T ≫ γ D }

/-- The algebra structure which will be the apex of the new limit cone for `D`. -/
@[simps] def cone_point : algebra T :=
{ A := c.X,
  a := t.lift (new_cone D c),
  unit' := t.hom_ext $ λ j,
  begin
    rw [category.assoc, t.fac, new_cone_π_app, ←T.η.naturality_assoc, functor.id_map,
      (D.obj j).unit],
    dsimp, simp -- See library note [dsimp, simp]
  end,
  assoc' := t.hom_ext $ λ j,
  begin
    rw [category.assoc, category.assoc, t.fac (new_cone D c), new_cone_π_app,
      ←functor.map_comp_assoc, t.fac (new_cone D c), new_cone_π_app, ←T.μ.naturality_assoc,
      (D.obj j).assoc, functor.map_comp, category.assoc],
    refl,
  end }

/-- (Impl) Construct the lifted cone in `algebra T` which will be limiting. -/
@[simps] def lifted_cone : cone D :=
{ X := cone_point D c t,
  π := { app := λ j, { f := c.π.app j },
         naturality' := λ X Y f, by { ext1, dsimp, erw c.w f, simp } } }

/-- (Impl) Prove that the lifted cone is limiting. -/
@[simps]
def lifted_cone_is_limit : is_limit (lifted_cone D c t) :=
{ lift := λ s,
  { f := t.lift ((forget T).map_cone s),
    h' := t.hom_ext $ λ j,
    begin
      dsimp,
      rw [category.assoc, category.assoc, t.fac, new_cone_π_app, ←functor.map_comp_assoc, t.fac,
        functor.map_cone_π_app],
      apply (s.π.app j).h,
    end },
  uniq' := λ s m J,
  begin
    ext1,
    apply t.hom_ext,
    intro j,
    simpa [t.fac ((forget T).map_cone s) j] using congr_arg algebra.hom.f (J j),
  end }

end forget_creates_limits

-- Theorem 5.6.5 from [Riehl][riehl2017]
/-- The forgetful functor from the Eilenberg-Moore category creates limits. -/
noncomputable
instance forget_creates_limits : creates_limits (forget T) :=
{ creates_limits_of_shape := λ J 𝒥, by exactI
  { creates_limit := λ D,
    creates_limit_of_reflects_iso (λ c t,
    { lifted_cone := forget_creates_limits.lifted_cone D c t,
      valid_lift := cones.ext (iso.refl _) (λ j, (id_comp _).symm),
      makes_limit := forget_creates_limits.lifted_cone_is_limit _ _ _ } ) } }

/-- `D ⋙ forget T` has a limit, then `D` has a limit. -/
lemma has_limit_of_comp_forget_has_limit (D : J ⥤ algebra T) [has_limit (D ⋙ forget T)] :
  has_limit D :=
has_limit_of_created D (forget T)

namespace forget_creates_colimits

-- Let's hide the implementation details in a namespace
variables {D : J ⥤ algebra T} (c : cocone (D ⋙ forget T)) (t : is_colimit c)

-- We have a diagram D of shape J in the category of algebras, and we assume that we are given a
-- colimit for its image D ⋙ forget T under the forgetful functor, say its apex is L.

-- We'll construct a colimiting coalgebra for D, whose carrier will also be L.
-- To do this, we must find a map TL ⟶ L. Since T preserves colimits, TL is also a colimit.
-- In particular, it is a colimit for the diagram `(D ⋙ forget T) ⋙ T`
-- so to construct a map TL ⟶ L it suffices to show that L is the apex of a cocone for this diagram.
-- In other words, we need a natural transformation from const L to `(D ⋙ forget T) ⋙ T`.
-- But we already know that L is the apex of a cocone for the diagram `D ⋙ forget T`, so it
-- suffices to give a natural transformation `((D ⋙ forget T) ⋙ T) ⟶ (D ⋙ forget T)`:

/--
(Impl)
The natural transformation given by the algebra structure maps, used to construct a cocone `c` with
apex `colimit (D ⋙ forget T)`.
 -/
@[simps] def γ : ((D ⋙ forget T) ⋙ ↑T) ⟶ (D ⋙ forget T) := { app := λ j, (D.obj j).a }

/--
(Impl)
A cocone for the diagram `(D ⋙ forget T) ⋙ T` found by composing the natural transformation `γ`
with the colimiting cocone for `D ⋙ forget T`.
-/
@[simps]
def new_cocone : cocone ((D ⋙ forget T) ⋙ ↑T) :=
{ X := c.X,
  ι := γ ≫ c.ι }

variables [preserves_colimit (D ⋙ forget T) (T : C ⥤ C)]

/--
(Impl)
Define the map `λ : TL ⟶ L`, which will serve as the structure of the coalgebra on `L`, and
we will show is the colimiting object. We use the cocone constructed by `c` and the fact that
`T` preserves colimits to produce this morphism.
-/
@[reducible]
def lambda : ((T : C ⥤ C).map_cocone c).X ⟶ c.X :=
(is_colimit_of_preserves _ t).desc (new_cocone c)

/-- (Impl) The key property defining the map `λ : TL ⟶ L`. -/
lemma commuting (j : J) :
(T : C ⥤ C).map (c.ι.app j) ≫ lambda c t = (D.obj j).a ≫ c.ι.app j :=
(is_colimit_of_preserves _ t).fac (new_cocone c) j

variables [preserves_colimit ((D ⋙ forget T) ⋙ ↑T) (T : C ⥤ C)]

/--
(Impl)
Construct the colimiting algebra from the map `λ : TL ⟶ L` given by `lambda`. We are required to
show it satisfies the two algebra laws, which follow from the algebra laws for the image of `D` and
our `commuting` lemma.
-/
@[simps] def cocone_point :
algebra T :=
{ A := c.X,
  a := lambda c t,
  unit' :=
  begin
    apply t.hom_ext,
    intro j,
    rw [(show c.ι.app j ≫ T.η.app c.X ≫ _ = T.η.app (D.obj j).A ≫ _ ≫ _,
                  from T.η.naturality_assoc _ _), commuting, algebra.unit_assoc (D.obj j)],
    dsimp, simp -- See library note [dsimp, simp]
  end,
  assoc' :=
  begin
    refine (is_colimit_of_preserves _ (is_colimit_of_preserves _ t)).hom_ext (λ j, _),
    rw [functor.map_cocone_ι_app, functor.map_cocone_ι_app,
      (show (T : C ⥤ C).map ((T : C ⥤ C).map _) ≫ _ ≫ _ = _, from T.μ.naturality_assoc _ _),
      ←functor.map_comp_assoc, commuting, functor.map_comp, category.assoc, commuting],
    apply (D.obj j).assoc_assoc _,
  end }

/-- (Impl) Construct the lifted cocone in `algebra T` which will be colimiting. -/
@[simps] def lifted_cocone : cocone D :=
{ X := cocone_point c t,
  ι := { app := λ j, { f := c.ι.app j, h' := commuting _ _ _ },
         naturality' := λ A B f, by { ext1, dsimp, rw [comp_id], apply c.w } } }

/-- (Impl) Prove that the lifted cocone is colimiting. -/
@[simps]
def lifted_cocone_is_colimit : is_colimit (lifted_cocone c t) :=
{ desc := λ s,
  { f := t.desc ((forget T).map_cocone s),
    h' := (is_colimit_of_preserves (T : C ⥤ C) t).hom_ext $ λ j,
    begin
      dsimp,
      rw [←functor.map_comp_assoc, ←category.assoc, t.fac, commuting, category.assoc, t.fac],
      apply algebra.hom.h,
    end },
  uniq' := λ s m J,
  by { ext1, apply t.hom_ext, intro j, simpa using congr_arg algebra.hom.f (J j) } }

end forget_creates_colimits

open forget_creates_colimits

-- TODO: the converse of this is true as well
/--
The forgetful functor from the Eilenberg-Moore category for a monad creates any colimit
which the monad itself preserves.
-/
noncomputable
instance forget_creates_colimit (D : J ⥤ algebra T)
  [preserves_colimit (D ⋙ forget T) (T : C ⥤ C)]
  [preserves_colimit ((D ⋙ forget T) ⋙ ↑T) (T : C ⥤ C)] :
  creates_colimit D (forget T) :=
creates_colimit_of_reflects_iso $ λ c t,
{ lifted_cocone :=
  { X := cocone_point c t,
    ι :=
    { app := λ j, { f := c.ι.app j, h' := commuting _ _ _ },
      naturality' := λ A B f, by { ext1, dsimp, erw [comp_id, c.w] } } },
  valid_lift := cocones.ext (iso.refl _) (by tidy),
  makes_colimit := lifted_cocone_is_colimit _ _ }

noncomputable
instance forget_creates_colimits_of_shape
  [preserves_colimits_of_shape J (T : C ⥤ C)] :
  creates_colimits_of_shape J (forget T) :=
{ creates_colimit := λ K, by apply_instance }

noncomputable
instance forget_creates_colimits
  [preserves_colimits (T : C ⥤ C)] :
  creates_colimits (forget T) :=
{ creates_colimits_of_shape := λ J 𝒥₁, by apply_instance }

/--
For `D : J ⥤ algebra T`, `D ⋙ forget T` has a colimit, then `D` has a colimit provided colimits
of shape `J` are preserved by `T`.
-/
lemma forget_creates_colimits_of_monad_preserves
  [preserves_colimits_of_shape J (T : C ⥤ C)] (D : J ⥤ algebra T) [has_colimit (D ⋙ forget T)] :
has_colimit D :=
has_colimit_of_created D (forget T)

end monad

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

instance comp_comparison_forget_has_limit
  (F : J ⥤ D) (R : D ⥤ C) [monadic_right_adjoint R] [has_limit (F ⋙ R)] :
  has_limit ((F ⋙ monad.comparison (adjunction.of_right_adjoint R)) ⋙ monad.forget _) :=
@has_limit_of_iso _ _ _ _ (F ⋙ R) _ _
  (iso_whisker_left F (monad.comparison_forget (adjunction.of_right_adjoint R)).symm)

instance comp_comparison_has_limit
  (F : J ⥤ D) (R : D ⥤ C) [monadic_right_adjoint R] [has_limit (F ⋙ R)] :
  has_limit (F ⋙ monad.comparison (adjunction.of_right_adjoint R)) :=
monad.has_limit_of_comp_forget_has_limit (F ⋙ monad.comparison (adjunction.of_right_adjoint R))

/-- Any monadic functor creates limits. -/
noncomputable
def monadic_creates_limits (R : D ⥤ C) [monadic_right_adjoint R] :
  creates_limits R :=
creates_limits_of_nat_iso (monad.comparison_forget (adjunction.of_right_adjoint R))

/--
The forgetful functor from the Eilenberg-Moore category for a monad creates any colimit
which the monad itself preserves.
-/
noncomputable
def monadic_creates_colimit_of_preserves_colimit (R : D ⥤ C) (K : J ⥤ D)
  [monadic_right_adjoint R]
  [preserves_colimit (K ⋙ R) (left_adjoint R ⋙ R)]
  [preserves_colimit ((K ⋙ R) ⋙ left_adjoint R ⋙ R) (left_adjoint R ⋙ R)] :
  creates_colimit K R :=
begin
  apply creates_colimit_of_nat_iso (monad.comparison_forget (adjunction.of_right_adjoint R)),
  apply category_theory.comp_creates_colimit _ _,
  apply_instance,
  let i : ((K ⋙ monad.comparison (adjunction.of_right_adjoint R)) ⋙ monad.forget _) ≅ K ⋙ R :=
    functor.associator _ _ _ ≪≫
      iso_whisker_left K (monad.comparison_forget (adjunction.of_right_adjoint R)),
  apply category_theory.monad.forget_creates_colimit _,
  { dsimp,
    refine preserves_colimit_of_iso_diagram _ i.symm },
  { dsimp,
    refine preserves_colimit_of_iso_diagram _ (iso_whisker_right i (left_adjoint R ⋙ R)).symm },
end

/-- A monadic functor creates any colimits of shapes it preserves. -/
noncomputable
def monadic_creates_colimits_of_shape_of_preserves_colimits_of_shape (R : D ⥤ C)
  [monadic_right_adjoint R] [preserves_colimits_of_shape J R] : creates_colimits_of_shape J R :=
begin
  have : preserves_colimits_of_shape J (left_adjoint R ⋙ R),
  { apply category_theory.limits.comp_preserves_colimits_of_shape _ _,
    { haveI := adjunction.left_adjoint_preserves_colimits (adjunction.of_right_adjoint R),
      apply_instance },
    apply_instance },
  exactI ⟨λ K, monadic_creates_colimit_of_preserves_colimit _ _⟩,
end

/-- A monadic functor creates colimits if it preserves colimits. -/
noncomputable
def monadic_creates_colimits_of_preserves_colimits (R : D ⥤ C) [monadic_right_adjoint R]
  [preserves_colimits R] : creates_colimits R :=
{ creates_colimits_of_shape := λ J 𝒥₁,
    by exactI monadic_creates_colimits_of_shape_of_preserves_colimits_of_shape _ }

section

lemma has_limit_of_reflective (F : J ⥤ D) (R : D ⥤ C) [has_limit (F ⋙ R)] [reflective R] :
  has_limit F :=
by { haveI := monadic_creates_limits R, exact has_limit_of_created F R }

/-- If `C` has limits of shape `J` then any reflective subcategory has limits of shape `J`. -/
lemma has_limits_of_shape_of_reflective [has_limits_of_shape J C] (R : D ⥤ C) [reflective R] :
  has_limits_of_shape J D :=
{ has_limit := λ F, has_limit_of_reflective F R }

/-- If `C` has limits then any reflective subcategory has limits. -/
lemma has_limits_of_reflective (R : D ⥤ C) [has_limits C] [reflective R] : has_limits D :=
{ has_limits_of_shape := λ J 𝒥₁, by exactI has_limits_of_shape_of_reflective R }

/-- If `C` has colimits of shape `J` then any reflective subcategory has colimits of shape `J`. -/
lemma has_colimits_of_shape_of_reflective (R : D ⥤ C)
  [reflective R] [has_colimits_of_shape J C] : has_colimits_of_shape J D :=
{ has_colimit := λ F,
begin
  let c := (left_adjoint R).map_cocone (colimit.cocone (F ⋙ R)),
  letI := (adjunction.of_right_adjoint R).left_adjoint_preserves_colimits,
  let t : is_colimit c := is_colimit_of_preserves (left_adjoint R) (colimit.is_colimit _),
  apply has_colimit.mk ⟨_, (is_colimit.precompose_inv_equiv _ _).symm t⟩,
  apply (iso_whisker_left F (as_iso (adjunction.of_right_adjoint R).counit) : _) ≪≫ F.right_unitor,
end }

/-- If `C` has colimits then any reflective subcategory has colimits. -/
lemma has_colimits_of_reflective (R : D ⥤ C) [reflective R] [has_colimits C] :
  has_colimits D :=
{ has_colimits_of_shape := λ J 𝒥, by exactI has_colimits_of_shape_of_reflective R }

/--
The reflector always preserves terminal objects. Note this in general doesn't apply to any other
limit.
-/
noncomputable def left_adjoint_preserves_terminal_of_reflective
  (R : D ⥤ C) [reflective R] [has_terminal C] :
  preserves_limits_of_shape (discrete pempty) (left_adjoint R) :=
{ preserves_limit := λ K,
  begin
    letI : has_terminal D := has_limits_of_shape_of_reflective R,
    letI := monadic_creates_limits R,
    letI := category_theory.preserves_limit_of_creates_limit_and_has_limit (functor.empty _) R,
    letI : preserves_limit (functor.empty _) (left_adjoint R),
    { apply preserves_terminal_of_iso,
      apply _ ≪≫ as_iso ((adjunction.of_right_adjoint R).counit.app (⊤_ D)),
      apply (left_adjoint R).map_iso (preserves_terminal.iso R).symm },
    apply preserves_limit_of_iso_diagram (left_adjoint R) (functor.unique_from_empty _).symm,
  end }

end
end category_theory


import unitb.models.nondet
import unitb.refinement.basic

import util.cast

universe variable u

namespace nondet
open predicate
open unitb
local attribute [instance] classical.prop_decidable
variables α : Type

@[reducible]
private def pred := α → Prop

variables {α}

structure evt_ref (mc : program α) (ea ec : event α) : Prop :=
  (sim : ⟦ ec.step_of ⟧ ⟹ ⟦ ea.step_of ⟧)
  (delay : ea.coarse_sch ⋀ ea.fine_sch  >~>  ec.coarse_sch ⋁ - ea.coarse_sch in mc)
  (stable : unless mc ec.coarse_sch (-ea.coarse_sch))
  (resched : ea.coarse_sch ⋀ ea.fine_sch  >~>  ec.fine_sch ⋁ - ea.coarse_sch in mc)

structure evt_ref_piecewise (mc : program α) (ea ec : event α)
    {n : ℕ} (ccsch : fin n → pred α) : Prop :=
  (ccsch_def : ec.coarse_sch = (∀∀ i, ccsch i))
  (sim : ⟦ ec.step_of ⟧ ⟹ ⟦ ea.step_of ⟧)
  (delay : ∀ i, ea.coarse_sch ⋀ ea.fine_sch  ↦  ccsch i ⋁ - ea.coarse_sch in mc)
  (stable : ∀ i, unless mc (ccsch i) (-ea.coarse_sch))
  (resched : ea.coarse_sch ⋀ ea.fine_sch  >~>  ec.fine_sch ⋁ - ea.coarse_sch in mc)

open temporal

structure refined (ma mc : program α) : Prop :=
  (bij : mc.lbl = ma.lbl)
  (sim_init : mc^.first ⟹ ma^.first)
  (sim' : ∀ e, ⟦ mc.step_of e ⟧ ⟹ action (ma.step_of (e.cast bij) ))
  (delay : ∀ e, ma.coarse_sch_of e ⋀ ma.fine_sch_of e
            >~> mc.coarse_sch_of (e.cast' bij) ⋁ - ma.coarse_sch_of e in mc)
  (stable : ∀ e, unless mc (mc^.coarse_sch_of e) (-ma^.coarse_sch_of (e.cast bij)))
  (resched : ∀ e, ma^.coarse_sch_of e ⋀ ma^.fine_sch_of e
              >~> mc^.fine_sch_of (e.cast' bij) ⋁ - ma.coarse_sch_of e in mc)

lemma refined.sim {m₀ m₁ : program α} (R : refined m₀ m₁)
: ⟦ is_step m₁ ⟧ ⟹ ⟦ is_step m₀ ⟧ :=
begin
  simp [is_step_exists_event,R.bij],
  apply p_or_entails_p_or_right,
  apply p_exists_entails_p_exists' _ _ (λ l, cast R.bij l), intros e τ H,
  simp,
  have H'' : option.cast (some e) (R.bij) = some (cast (R.bij) e),
  { generalize : R.bij = P,
    rw cast_some },
  have H' := R.sim' (some e) τ H,
  rw H'' at H',
  apply H',
end

section piecewise_event_refinement

variables {mc : program α}
variables {ea ec : event α}
variables {n : ℕ}
variables {ccsch : fin n → α → Prop}
variables (H : evt_ref_piecewise mc ea ec ccsch)

include H

lemma piecewise_delay
: ea.coarse_sch ⋀ ea.fine_sch  >~>  ec.coarse_sch ⋁ -ea.coarse_sch in mc :=
begin
  apply often_imp_often.basis,
  rw H.ccsch_def,
  have H' := leads_to.completion H.delay H.stable,
  apply leads_to.antimono_left _ _ H', clear H H',
  intro, simp, begin [smt] by_cases ea.coarse_sch i end
end

lemma piecewise_event_refinement
: evt_ref mc ea ec :=
{ resched := H.resched
, stable  := by { rw H.ccsch_def, apply forall_unless H.stable }
, delay   := piecewise_delay H
, sim     := H.sim }

end piecewise_event_refinement

lemma event_refinement {ma mc : program α}
   (BIJ : mc.lbl = ma.lbl)
   (INIT : mc^.first ⟹ ma^.first)
   (EVT : ∀ e, evt_ref mc (ma.event' e) (mc.event' $ cast BIJ.symm e))
: refined ma mc :=
begin
  apply refined.mk BIJ,
  { apply INIT },
  { intro e,
    cases e with e,
    { simp [cast_none,step_of_none] },
    { unfold program.step_of program.event,
      simp [cast_some],
      have H := (EVT $ cast BIJ e).sim,
      simp [cast_cast] at H,
      apply H } },
  all_goals
    { intro e,
      cases e with e,
      simp [ program.coarse_sch_of_none,program.fine_sch_of_none,cast_none'],
      try { apply True_often_imp_often_True },
      try { apply True_unless } },
  { simp [cast_some'],
    apply (EVT e).delay },
  { simp [cast_some],
    have H := (EVT $ cast BIJ e).stable,
    simp [cast_cast] at H,
    apply H },
  { simp [cast_some'],
    apply (EVT e).resched },
end

variables  (ma mc : program α)

open temporal

theorem soundness : refined ma mc → unitb.refinement.refined ma mc :=
begin
  intros R τ M₁,
  apply nondet.program.ex.mk,
  { apply R.sim_init,
    apply M₁.init },
  { intro i,
    apply R.sim,
    apply M₁.safety },
  { intros e COARSE₀ FINE₀,
    let e' := e.cast' R.bij,
    have CF_SCH : (◻◇•(program.coarse_sch_of ma e ⋀ program.fine_sch_of ma e)) τ,
    { apply coincidence,
      apply COARSE₀,
      apply FINE₀, },
    have COARSE₁ : (◇◻•program.coarse_sch_of mc e') τ,
    { have COARSE₂ : (◻◇•program.coarse_sch_of mc e') τ,
      { revert COARSE₀,
        rw [imp_iff_not_or,p_not_eq_not,not_eventually,not_henceforth,not_init],
        rw [← p_or_to_fun,p_or_comm,← inf_often_p_or],
        apply (system_sem.often_imp_often_sem' _ M₁ (R.delay e)),
        apply CF_SCH },
      have UNLESS := unless_sem_str M₁.safety (R.stable e') COARSE₂,
      cases UNLESS with UNLESS H,
      { apply UNLESS },
      { have H' : (-◇◻•program.coarse_sch_of ma e) τ,
        { rw [not_eventually,not_henceforth,not_init],
          simp [option_cast_cast'] at H,
          apply H },
        cases H' COARSE₀, } },
    have FINE₁ : (◻◇•program.fine_sch_of mc e') τ,
    { revert COARSE₀,
      rw [imp_iff_not_or,p_not_eq_not,not_eventually,not_henceforth,not_init],
      rw [← p_or_to_fun,p_or_comm,← inf_often_p_or],
      apply system_sem.often_imp_often_sem' _ M₁ (R.resched _),
      apply CF_SCH, },
    apply inf_often_entails_inf_often _ _ (M₁.liveness _ COARSE₁ FINE₁),
    have H := R.sim' e',
    simp [option_cast_cast'] at H,
    apply H, },
end

end nondet


/-
Copyright (c) 2018 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import category_theory.isomorphism
import category_theory.functor.category
import category_theory.functor.fully_faithful

/-!
# Whiskering

Given a functor `F  : C ⥤ D` and functors `G H : D ⥤ E` and a natural transformation `α : G ⟶ H`,
we can construct a new natural transformation `F ⋙ G ⟶ F ⋙ H`,
called `whisker_left F α`. This is the same as the horizontal composition of `𝟙 F` with `α`.

This operation is functorial in `F`, and we package this as `whiskering_left`. Here
`(whiskering_left.obj F).obj G` is `F ⋙ G`, and
`(whiskering_left.obj F).map α` is `whisker_left F α`.
(That is, we might have alternatively named this as the "left composition functor".)

We also provide analogues for composition on the right, and for these operations on isomorphisms.

At the end of the file, we provide the left and right unitors, and the associator,
for functor composition.
(In fact functor composition is definitionally associative, but very often relying on this causes
extremely slow elaboration, so it is better to insert it explicitly.)
We also show these natural isomorphisms satisfy the triangle and pentagon identities.
-/

namespace category_theory

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

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

/--
If `α : G ⟶ H` then
`whisker_left F α : (F ⋙ G) ⟶ (F ⋙ H)` has components `α.app (F.obj X)`.
-/
@[simps] def whisker_left (F : C ⥤ D) {G H : D ⥤ E} (α : G ⟶ H) : (F ⋙ G) ⟶ (F ⋙ H) :=
{ app := λ X, α.app (F.obj X),
  naturality' := λ X Y f, by rw [functor.comp_map, functor.comp_map, α.naturality] }

/--
If `α : G ⟶ H` then
`whisker_right α F : (G ⋙ F) ⟶ (G ⋙ F)` has components `F.map (α.app X)`.
-/
@[simps] def whisker_right {G H : C ⥤ D} (α : G ⟶ H) (F : D ⥤ E) : (G ⋙ F) ⟶ (H ⋙ F) :=
{ app := λ X, F.map (α.app X),
  naturality' := λ X Y f,
    by rw [functor.comp_map, functor.comp_map, ←F.map_comp, ←F.map_comp, α.naturality] }

variables (C D E)

/--
Left-composition gives a functor `(C ⥤ D) ⥤ ((D ⥤ E) ⥤ (C ⥤ E))`.

`(whiskering_left.obj F).obj G` is `F ⋙ G`, and
`(whiskering_left.obj F).map α` is `whisker_left F α`.
-/
@[simps] def whiskering_left : (C ⥤ D) ⥤ ((D ⥤ E) ⥤ (C ⥤ E)) :=
{ obj := λ F,
  { obj := λ G, F ⋙ G,
    map := λ G H α, whisker_left F α },
  map := λ F G τ,
  { app := λ H,
    { app := λ c, H.map (τ.app c),
      naturality' := λ X Y f, begin dsimp, rw [←H.map_comp, ←H.map_comp, ←τ.naturality] end },
    naturality' := λ X Y f, begin ext, dsimp, rw [f.naturality] end } }

/--
Right-composition gives a functor `(D ⥤ E) ⥤ ((C ⥤ D) ⥤ (C ⥤ E))`.

`(whiskering_right.obj H).obj F` is `F ⋙ H`, and
`(whiskering_right.obj H).map α` is `whisker_right α H`.
-/
@[simps] def whiskering_right : (D ⥤ E) ⥤ ((C ⥤ D) ⥤ (C ⥤ E)) :=
{ obj := λ H,
  { obj := λ F, F ⋙ H,
    map := λ _ _ α, whisker_right α H },
  map := λ G H τ,
  { app := λ F,
    { app := λ c, τ.app (F.obj c),
      naturality' := λ X Y f, begin dsimp, rw [τ.naturality] end },
    naturality' := λ X Y f, begin ext, dsimp, rw [←nat_trans.naturality] end } }

variables {C} {D} {E}

instance faithful_whiskering_right_obj {F : D ⥤ E} [faithful F] :
  faithful ((whiskering_right C D E).obj F) :=
{ map_injective' := λ G H α β hαβ, nat_trans.ext _ _ $ funext $ λ X,
    functor.map_injective _ $ congr_fun (congr_arg nat_trans.app hαβ) X }

@[simp] lemma whisker_left_id (F : C ⥤ D) {G : D ⥤ E} :
  whisker_left F (nat_trans.id G) = nat_trans.id (F.comp G) :=
rfl
@[simp] lemma whisker_left_id' (F : C ⥤ D) {G : D ⥤ E} :
  whisker_left F (𝟙 G) = 𝟙 (F.comp G) :=
rfl

@[simp] lemma whisker_right_id {G : C ⥤ D} (F : D ⥤ E) :
  whisker_right (nat_trans.id G) F = nat_trans.id (G.comp F) :=
((whiskering_right C D E).obj F).map_id _
@[simp] lemma whisker_right_id' {G : C ⥤ D} (F : D ⥤ E) :
  whisker_right (𝟙 G) F = 𝟙 (G.comp F) :=
((whiskering_right C D E).obj F).map_id _

@[simp] lemma whisker_left_comp (F : C ⥤ D) {G H K : D ⥤ E} (α : G ⟶ H) (β : H ⟶ K) :
  whisker_left F (α ≫ β) = (whisker_left F α) ≫ (whisker_left F β) :=
rfl

@[simp] lemma whisker_right_comp {G H K : C ⥤ D} (α : G ⟶ H) (β : H ⟶ K) (F : D ⥤ E)  :
  whisker_right (α ≫ β) F = (whisker_right α F) ≫ (whisker_right β F) :=
((whiskering_right C D E).obj F).map_comp α β

/--
If `α : G ≅ H` is a natural isomorphism then
`iso_whisker_left F α : (F ⋙ G) ≅ (F ⋙ H)` has components `α.app (F.obj X)`.
-/
def iso_whisker_left (F : C ⥤ D) {G H : D ⥤ E} (α : G ≅ H) : (F ⋙ G) ≅ (F ⋙ H) :=
((whiskering_left C D E).obj F).map_iso α
@[simp] lemma iso_whisker_left_hom (F : C ⥤ D) {G H : D ⥤ E} (α : G ≅ H) :
  (iso_whisker_left F α).hom = whisker_left F α.hom :=
rfl
@[simp] lemma iso_whisker_left_inv (F : C ⥤ D) {G H : D ⥤ E} (α : G ≅ H) :
  (iso_whisker_left F α).inv = whisker_left F α.inv :=
rfl

/--
If `α : G ≅ H` then
`iso_whisker_right α F : (G ⋙ F) ≅ (H ⋙ F)` has components `F.map_iso (α.app X)`.
-/
def iso_whisker_right {G H : C ⥤ D} (α : G ≅ H) (F : D ⥤ E) : (G ⋙ F) ≅ (H ⋙ F) :=
((whiskering_right C D E).obj F).map_iso α
@[simp] lemma iso_whisker_right_hom {G H : C ⥤ D} (α : G ≅ H) (F : D ⥤ E) :
  (iso_whisker_right α F).hom = whisker_right α.hom F :=
rfl
@[simp] lemma iso_whisker_right_inv {G H : C ⥤ D} (α : G ≅ H) (F : D ⥤ E) :
  (iso_whisker_right α F).inv = whisker_right α.inv F :=
rfl

instance is_iso_whisker_left (F : C ⥤ D) {G H : D ⥤ E} (α : G ⟶ H) [is_iso α] :
  is_iso (whisker_left F α) :=
is_iso.of_iso (iso_whisker_left F (as_iso α))
instance is_iso_whisker_right {G H : C ⥤ D} (α : G ⟶ H) (F : D ⥤ E) [is_iso α] :
  is_iso (whisker_right α F) :=
is_iso.of_iso (iso_whisker_right (as_iso α) F)

variables {B : Type u₄} [category.{v₄} B]

local attribute [elab_simple] whisker_left whisker_right

@[simp] lemma whisker_left_twice (F : B ⥤ C) (G : C ⥤ D) {H K : D ⥤ E} (α : H ⟶ K) :
  whisker_left F (whisker_left G α) = whisker_left (F ⋙ G) α :=
rfl

@[simp] lemma whisker_right_twice {H K : B ⥤ C} (F : C ⥤ D) (G : D ⥤ E) (α : H ⟶ K) :
  whisker_right (whisker_right α F) G = whisker_right α (F ⋙ G) :=
rfl

lemma whisker_right_left (F : B ⥤ C) {G H : C ⥤ D} (α : G ⟶ H) (K : D ⥤ E) :
  whisker_right (whisker_left F α) K = whisker_left F (whisker_right α K) :=
rfl
end

namespace functor

universes u₅ v₅

variables {A : Type u₁} [category.{v₁} A]
variables {B : Type u₂} [category.{v₂} B]

/--
The left unitor, a natural isomorphism `((𝟭 _) ⋙ F) ≅ F`.
-/
@[simps] def left_unitor (F : A ⥤ B) : ((𝟭 A) ⋙ F) ≅ F :=
{ hom := { app := λ X, 𝟙 (F.obj X) },
  inv := { app := λ X, 𝟙 (F.obj X) } }

/--
The right unitor, a natural isomorphism `(F ⋙ (𝟭 B)) ≅ F`.
-/
@[simps] def right_unitor (F : A ⥤ B) : (F ⋙ (𝟭 B)) ≅ F :=
{ hom := { app := λ X, 𝟙 (F.obj X) },
  inv := { app := λ X, 𝟙 (F.obj X) } }

variables {C : Type u₃} [category.{v₃} C]
variables {D : Type u₄} [category.{v₄} D]

/--
The associator for functors, a natural isomorphism `((F ⋙ G) ⋙ H) ≅ (F ⋙ (G ⋙ H))`.

(In fact, `iso.refl _` will work here, but it tends to make Lean slow later,
and it's usually best to insert explicit associators.)
-/
@[simps] def associator (F : A ⥤ B) (G : B ⥤ C) (H : C ⥤ D) : ((F ⋙ G) ⋙ H) ≅ (F ⋙ (G ⋙ H)) :=
{ hom := { app := λ _, 𝟙 _ },
  inv := { app := λ _, 𝟙 _ } }

lemma triangle (F : A ⥤ B) (G : B ⥤ C) :
  (associator F (𝟭 B) G).hom ≫ (whisker_left F (left_unitor G).hom) =
    (whisker_right (right_unitor F).hom G) :=
by { ext, dsimp, simp }  -- See note [dsimp, simp].

variables {E : Type u₅} [category.{v₅} E]

variables (F : A ⥤ B) (G : B ⥤ C) (H : C ⥤ D) (K : D ⥤ E)

lemma pentagon :
  (whisker_right (associator F G H).hom K) ≫
    (associator F (G ⋙ H) K).hom ≫
    (whisker_left F (associator G H K).hom) =
  ((associator (F ⋙ G) H K).hom ≫ (associator F G (H ⋙ K)).hom) :=
by { ext, dsimp, simp }

end functor

end category_theory


import free_pfpng.setup

noncomputable theory

open_locale classical big_operators

open category_theory
open opposite

universe u

instance Condensed_Ab_to_CondensedSet_faithful :
  faithful Condensed_Ab_to_CondensedSet :=
{ map_injective' := begin
    intros X Y f g h, ext W t : 4,
    apply_fun (λ e, e.val.app W t) at h, dsimp at h,
    exact h
  end }

lemma category_theory.epi_to_colimit_of_exists {J : Type u}
  [small_category J] {C : Type*} [category.{u} C]
  {F : J ⥤ C} (T : C)
  (E : limits.cocone F) (hE : limits.is_colimit E)
  (f : T ⟶ E.X)
  (h : ∀ j : J,
    ∃ (Z : C) (p : Z ⟶ T) (q : Z ⟶ F.obj j) (hq : epi q),
      q ≫ E.ι.app j = p ≫ f) : epi f :=
begin
  constructor, intros W a b hh,
  apply hE.hom_ext, intros j, specialize h j,
  obtain ⟨Z,p,q,hq,w⟩ := h, resetI,
  rw ← cancel_epi q, simp_rw [← category.assoc, w,
    category.assoc, hh],
end

lemma epi_Profinite_to_Condensed_map_of_epi {X Y : Profinite.{u}}
  (f : X ⟶ Y) [hf : epi f] : epi (Profinite_to_Condensed.map f) :=
begin
  constructor, intros Z a b h, ext W q : 34, induction W using opposite.rec,
  have hZ := Z.2,
  rw is_sheaf_iff_is_sheaf_of_type at hZ,
  rw Z.val.is_proetale_sheaf_of_types_tfae.out 0 1 at hZ,
  let q' := q.down,
  dsimp at q q',
  dsimp [functor.is_proetale_sheaf_of_types] at hZ,
  specialize hZ punit W (λ _, Profinite.pullback f q')
    (λ _, Profinite.pullback.snd _ _) _ _,
  { intro w,
    rw Profinite.epi_iff_surjective at hf,
    obtain ⟨x, hx⟩ := hf (q' w),
    refine ⟨punit.star, ⟨(x, w), hx⟩, rfl⟩, },
  { intros i, dsimp, refine Z.val.map _ (b.val.app (op W) q),
    refine quiver.hom.op _, exact Profinite.pullback.snd _ _ },
  specialize hZ _,
  { clear hZ,
    rintro ⟨⟩ ⟨⟩ S g₁ g₂ H, dsimp only at H,
    apply_fun (λ φ, Z.val.map φ.op (b.val.app (op W) q)) at H,
    simp only [op_comp, Z.val.map_comp] at H, exact H, },
  obtain ⟨t,ht1,ht2⟩ := hZ,
  have : b.val.app (op W) q = t,
  { apply ht2,
    intros i, refl },
  rw this, apply ht2,
  intros i, dsimp,
  change (a.val.app (op W) ≫ Z.val.map _) q =
    (b.val.app (op W) ≫ Z.val.map _) q,
  simp only [← nat_trans.naturality],
  dsimp,
  apply_fun (λ e, Profinite_to_Condensed.map (Profinite.pullback.fst f q') ≫ e) at h,
  apply_fun (λ e, e.val.app (op (Profinite.pullback f q'))) at h,
  dsimp at h,
  let i : (Profinite.pullback f q').to_Condensed.val.obj (op (Profinite.pullback f q')) :=
    ulift.up (𝟙 _),
  apply_fun (λ e, e i) at h,
  dsimp [ulift_functor] at h,
  convert h,
  all_goals
  { ext1,
    dsimp [Profinite.to_Condensed],
    simp only [category.id_comp, Profinite.pullback.condition] },
end

/-
inductive pmz : set ℤ
| neg_one : pmz (-1)
| zero : pmz 0
| one : pmz 1

def pmz_eq : pmz = {0,1,-1} :=
begin
  ext, split,
  { intros h, cases h, right, right, simpa, left, simp, right, left, simp },
  { intros h, simp at h, rcases h with (rfl|rfl|rfl),
    apply pmz.zero,
    apply pmz.one,
    apply pmz.neg_one }
end

lemma pmz_finite : set.finite pmz :=
by simp [pmz_eq]

instance fintype_pmz : fintype pmz := pmz_finite.fintype
-/

--abbreviation Profinite.pow (S : Profinite.{u}) (n : ℕ) : Profinite.{u} :=
--Profinite.product (λ i : fin n, S)

/-- `S.pmz n` is `(S × {-1,0,1})^n`. -/
def Profinite.pmz (S : Profinite.{u}) (n : ℕ) : Profinite.{u} :=
Profinite.sigma $ λ (x : ulift.{u} (fin n → sign_type)), S.pow n

/-- the canonical map of condensed sets `(S × {-1,0,1})^n ⟶ ℤ[S]` -/
def Profinite.pmz_to_free' (S : Profinite.{u}) (n : ℕ) :
  (S.pmz n).to_Condensed ⟶ Condensed_Ab_to_CondensedSet.obj S.free' :=
(Profinite.to_Condensed_equiv (S.pmz n) (Condensed_Ab_to_CondensedSet.obj S.free')).symm $
  (CondensedSet.val_obj_sigma_equiv (λ (f : ulift.{u} (fin n → sign_type)), S.pow n)
    (Condensed_Ab_to_CondensedSet.obj S.free')).symm $
λ (f : ulift.{u} (fin n → sign_type)),
let e := proetale_topology.to_sheafify (S.to_Condensed.val ⋙ AddCommGroup.free') in
e.app (op $ S.pow n) $
  ∑ i : fin n, finsupp.single (ulift.up $ Profinite.product.π _ i) (f.down i : ℤ)

def Profinite.pmz_functor (n : ℕ) : Profinite.{u} ⥤ Profinite.{u} :=
{ obj := λ S, S.pmz n,
  map := λ S T f,
    Profinite.sigma.desc _ $ λ e,
      (Profinite.product.lift (λ i : fin n, T)
        (λ i, Profinite.product.π _ i ≫ f)) ≫ Profinite.sigma.ι _ e,
  map_id' := begin
    intros X,
    apply Profinite.sigma.hom_ext, intros e,
    erw category.comp_id, refl,
  end,
  map_comp' := begin
    intros X Y Z f g,
    apply Profinite.sigma.hom_ext, intros e, dsimp, simp,
    erw [Profinite.sigma.ι_desc],
    refl,
  end }

def Profinite.pmz_diagram (S : Profinite.{u}) (n : ℕ) :
  discrete_quotient S ⥤ Profinite.{u} :=
S.diagram ⋙ Profinite.pmz_functor n

def Profinite.pmz_cone (S : Profinite.{u}) (n : ℕ) : limits.cone (S.pmz_diagram n) :=
(Profinite.pmz_functor n).map_cone S.as_limit_cone

def Profinite.sigma_functor {J : Type u} [small_category J]
  (F : J ⥤ Profinite.{u}) (α : Type u) [fintype α] :
  J ⥤ Profinite.{u} :=
{ obj := λ j, Profinite.sigma (λ a : α, F.obj j),
  map := λ i j e, Profinite.sigma.desc _ $ λ a,
    F.map e ≫ Profinite.sigma.ι _ a,
  map_id' := begin
    intros j, apply Profinite.sigma.hom_ext, intros a,
    simp,
  end,
  map_comp' := begin
    intros i j k e f,
    apply Profinite.sigma.hom_ext, intros a,
    simp,
  end }

def Profinite.sigma_cone {J : Type u} [small_category J]
  {F : J ⥤ Profinite.{u}} (α : Type u) [fintype α]
  (E : limits.cone F) :
  limits.cone (Profinite.sigma_functor F α) :=
{ X := Profinite.sigma (λ a : α, E.X),
  π :=
  { app := λ j, Profinite.sigma.desc _ $ λ a,
      E.π.app j ≫ Profinite.sigma.ι _ a,
    naturality' := begin
      intros i j e, dsimp,
      apply Profinite.sigma.hom_ext, intros a,
      simp, dsimp [Profinite.sigma_functor], simp,
    end } }

def Profinite.sigma_to_limit {J : Type u} [small_category J]
  (F : J ⥤ Profinite.{u}) (α : Type u) [fintype α]
  (E : limits.cone F) :
  (Profinite.sigma_cone α E).X ⟶
    (Profinite.limit_cone (Profinite.sigma_functor F α)).X :=
Profinite.sigma.desc _ $ λ a, (Profinite.limit_cone_is_limit
  (Profinite.sigma_functor F α)).lift ⟨E.X,
  { app := λ j, E.π.app j ≫ Profinite.sigma.ι _ a,
  naturality' := begin
    intros i j e, dsimp [Profinite.sigma_functor],
    simp,
  end }⟩

lemma Profinite.exists_of_sigma_limit {J : Type u} [small_category J]
  (F : J ⥤ Profinite.{u}) (α : Type u) [fintype α] [is_cofiltered J]
  (t : (Profinite.limit_cone (Profinite.sigma_functor F α)).X) :
  ∃ (a₀ : α) (t₀ : (Profinite.limit_cone F).X),
    ∀ j : J, Profinite.sigma.ι _ a₀
      ((Profinite.limit_cone F).π.app j t₀) =
      (Profinite.limit_cone (Profinite.sigma_functor F α)).π.app j t :=
begin
  rcases t with ⟨t,ht⟩, dsimp at ht,
  obtain ⟨j₀⟩ : nonempty J := is_cofiltered.nonempty,
  let a₀ := (t j₀).1, use a₀,
  have h1 : ∀ ⦃i j : J⦄ (f : i ⟶ j), (t i).1 = (t j).1,
  { intros i j e, specialize ht e,
    apply_fun (λ q, q.1) at ht,
    cases t i, exact ht },
  have h2 : ∀ j : J, (t j).1 = a₀,
  { intros j,
    let j₁ := is_cofiltered.min j j₀,
    rw ← h1 (is_cofiltered.min_to_left j j₀), dsimp [a₀],
    rw ← h1 (is_cofiltered.min_to_right j j₀) },
  let t₀ : (Profinite.limit_cone F).X := ⟨_,_⟩,
  rotate,
  { intros j, exact (t j).2 },
  { intros i j e,
    specialize ht e,
    cases (t i),
    dsimp [Profinite.sigma_functor, Profinite.sigma.desc, Profinite.sigma.ι] at ht,
    cases t j,
    erw sigma.mk.inj_iff at ht,
    exact eq_of_heq ht.2 },
  use t₀,
  intros j,
  dsimp [Profinite.limit_cone, Profinite.sigma_functor, Profinite.sigma.ι,
    Profinite.sigma.desc, CompHaus.limit_cone, Top.limit_cone], ext,
  exact (h2 _).symm, refl,
end

lemma Profinite.bijective_sigma_to_limit {J : Type u} [small_category J]
  (F : J ⥤ Profinite.{u}) (α : Type u) [fintype α]
  (E : limits.cone F) (hE : limits.is_limit E) [is_cofiltered J] :
  function.bijective (Profinite.sigma_to_limit F α E) :=
begin
  split,
  { rintros ⟨a,x⟩ ⟨b,y⟩ h,
    dsimp [Profinite.sigma_to_limit, Profinite.sigma.desc,
      Profinite.limit_cone_is_limit, CompHaus.limit_cone_is_limit,
      Top.limit_cone_is_limit] at h,
    apply_fun (λ e, e.1) at h,
    have hh := h,
    obtain ⟨j₀⟩ : nonempty J := is_cofiltered.nonempty,
    apply_fun (λ e, (e j₀).1) at h, dsimp [Profinite.sigma.ι] at h,
    subst h, ext, refl,
    apply heq_of_eq,
    apply limits.concrete.is_limit_ext _ hE,
    intros jj, apply_fun (λ e, e jj) at hh,
    erw sigma.mk.inj_iff at hh,
    exact eq_of_heq hh.2 },
  { rintros t,
    obtain ⟨a,s,ht⟩ := Profinite.exists_of_sigma_limit F α t,
    use a, let EE : E.X ≅ (Profinite.limit_cone F).X :=
      hE.cone_point_unique_up_to_iso (Profinite.limit_cone_is_limit _),
    use EE.inv s, dsimp, ext j : 2,
    convert ht j, ext, refl,
    apply heq_of_eq,
    change ((hE.lift (Profinite.limit_cone F)) ≫ E.π.app j) s = _,
    rw hE.fac, refl }
end

lemma Profinite.is_iso_lift_sigma_cone {J : Type u} [small_category J]
  {F : J ⥤ Profinite.{u}} (α : Type u) [fintype α] [is_cofiltered J]
  (E : limits.cone F) (hE : limits.is_limit E) :
  is_iso ((Profinite.limit_cone_is_limit _).lift (Profinite.sigma_cone α E)) :=
begin
  apply Profinite.is_iso_of_bijective,
  convert Profinite.bijective_sigma_to_limit F α E hE,
  symmetry,
  apply (Profinite.limit_cone_is_limit (Profinite.sigma_functor F α)).uniq,
  intros j,
  apply Profinite.sigma.hom_ext,
  intros a, refl,
end

def Profinite.sigma_cone_is_limit {J : Type u} [small_category J]
  {F : J ⥤ Profinite.{u}} (α : Type u) [fintype α] [is_cofiltered J]
  (E : limits.cone F) (hE : limits.is_limit E) :
  limits.is_limit (Profinite.sigma_cone α E) :=
begin
  haveI : is_iso ((Profinite.limit_cone_is_limit _).lift (Profinite.sigma_cone α E)) :=
    Profinite.is_iso_lift_sigma_cone α E hE,
  apply limits.is_limit.of_point_iso (Profinite.limit_cone_is_limit _),
  assumption
end

def Profinite.pmz_to_limit (S : Profinite.{u}) (n : ℕ) :
  S.pmz n ⟶ (Profinite.limit_cone (S.pmz_diagram n)).X :=
Profinite.sigma.desc _ $ λ f,
  (Profinite.limit_cone_is_limit (S.pmz_diagram n)).lift ⟨S.pow n,
  { app := λ T, Profinite.map_pow (S.as_limit_cone.π.app T) n ≫
      Profinite.sigma.ι _ f,
    naturality' := begin
      intros A B e,
      dsimp [Profinite.pmz_diagram, Profinite.pmz_functor],
      simpa,
    end }⟩

def Profinite.pow_functor (n : ℕ) : Profinite.{u} ⥤ Profinite.{u} :=
{ obj := λ S, S.pow n,
  map := λ S T f, Profinite.map_pow f n,
  map_id' := begin
    intros X, apply Profinite.product.hom_ext, intros i, dsimp [Profinite.map_pow], simp,
  end,
  map_comp' := begin
    intros X Y Z f g,
    apply Profinite.product.hom_ext, intros i, dsimp [Profinite.map_pow], simp,
  end }

def Profinite.pow_cone {J : Type u} [small_category J] {F : J ⥤ Profinite.{u}}
  (E : limits.cone F) (n : ℕ) : limits.cone (F ⋙ Profinite.pow_functor n) :=
(Profinite.pow_functor n).map_cone E

def Profinite.pow_cone_is_limit
  {J : Type u} [small_category J] {F : J ⥤ Profinite.{u}}
  (E : limits.cone F) (hE : limits.is_limit E) (n : ℕ) :
  limits.is_limit (Profinite.pow_cone E n) :=
{ lift := λ Q, Profinite.product.lift _ $ λ a,
    hE.lift ⟨Q.X,
    { app := λ j, Q.π.app j ≫ Profinite.product.π _ a,
      naturality' := begin
        intros i j e, dsimp,
        simp only [category.id_comp, category.assoc],
        rw ← Q.w e,
        dsimp [Profinite.pow_functor, Profinite.map_pow],
        simp,
      end }⟩,
  fac' := begin
    intros Q j, apply Profinite.product.hom_ext, intros i,
    dsimp [Profinite.pow_cone, Profinite.pow_functor, Profinite.map_pow],
    simp only [category.assoc, Profinite.product.lift_π, Profinite.product.lift_π_assoc,
      limits.is_limit.fac],
  end,
  uniq' := begin
    intros Q m hm,
    apply Profinite.product.hom_ext, intros a,
    dsimp [Profinite.pow_cone, Profinite.pow_functor, Profinite.map_pow],
    simp only [Profinite.product.lift_π],
    apply hE.hom_ext,
    intros j,
    simp only [category.assoc, limits.is_limit.fac], rw ← hm,
    dsimp [Profinite.pow_cone, Profinite.pow_functor, Profinite.map_pow],
    simp only [category.assoc, Profinite.product.lift_π],
  end }

lemma Profinite.is_iso_pmz_to_limit (S : Profinite.{u}) (n : ℕ) :
  is_iso (S.pmz_to_limit n) :=
begin
  let E := Profinite.sigma_cone (ulift.{u} (fin n → sign_type))
    (Profinite.pow_cone S.as_limit_cone n),
  let hE : limits.is_limit E := Profinite.sigma_cone_is_limit _ _
    (Profinite.pow_cone_is_limit _ S.as_limit n),
  let q : E.X ≅ (Profinite.limit_cone (S.pmz_diagram n)).X :=
    hE.cone_point_unique_up_to_iso (Profinite.limit_cone_is_limit _),
  have : is_iso q.hom := infer_instance,
  convert this,
  apply Profinite.sigma.hom_ext, intros e,
  apply (Profinite.limit_cone_is_limit _).hom_ext,
  intros T,
  refl,
end

def Profinite.pmz_cone_is_limit (S : Profinite.{u}) (n : ℕ) :
  limits.is_limit (S.pmz_cone n) :=
begin
  apply limits.is_limit.of_point_iso (Profinite.limit_cone_is_limit _),
  convert Profinite.is_iso_pmz_to_limit S n,
  apply Profinite.sigma.hom_ext, intros a,
  apply (Profinite.limit_cone_is_limit _).hom_ext, intros j,
  refl,
end

-- A finite product of finite discrete sets is discrete.
instance Profinite.discrete_topology_pow
  (S : Profinite.{u}) [discrete_topology S] (n : ℕ) :
  discrete_topology (S.pow n) :=
Pi.discrete_topology

-- A finite union of finite products of finite discrete sets is discrete.
instance Profinite.discrete_topology_pmz
  (S : Profinite.{u}) [discrete_topology S] (n : ℕ) :
  discrete_topology (S.pmz n) :=
sigma.discrete_topology

-- move this
lemma _root_.sign_type.nnnorm_coe_int_le_one : ∀ i : sign_type, ∥(i : ℤ)∥₊ ≤ 1
| sign_type.zero := by { erw [nnnorm_zero], exact zero_le', }
| sign_type.neg := by simp
| sign_type.pos := by { erw [nnnorm_one], }

def Profinite.pmz_to_level_component (S : Profinite.{u}) (j : nnreal) (T : discrete_quotient S)
  (e : fin ⌊j⌋₊ → sign_type) :
  (Profinite.of ↥T).pow ⌊j⌋₊ ⟶
  (ProFiltPseuNormGrp₁.level.obj j).obj (free_pfpng_functor.obj (Fintype.of ↥T)) :=
{ to_fun := λ t,
  { val := ∑ i : fin ⌊j⌋₊, (λ s, if t i = s then (e i : ℤ) else 0),
    property := begin
      have : ∑ i : fin ⌊j⌋₊, (∑ s : T, if t i = s then (1 : nnreal) else 0) ≤ j,
      { calc _
            ≤ ∑ i : fin ⌊j⌋₊, (1 : nnreal) : _
        ... ≤ j : _,
        { apply finset.sum_le_sum, rintro i -, apply le_of_eq,
          erw [finset.sum_eq_single_of_mem (t i : T) (@finset.mem_univ T _ _), if_pos rfl],
          rintro s - hs, rw [if_neg hs.symm], },
        { simp only [finset.sum_const, finset.card_fin, nat.smul_one_eq_coe],
          exact nat.floor_le zero_le' } },
      apply pseudo_normed_group.filtration_mono this,
      apply pseudo_normed_group.sum_mem_filtration,
      rintro i -,
      apply finset.sum_le_sum,
      rintro s -,
      dsimp,
      split_ifs,
      { apply sign_type.nnnorm_coe_int_le_one },
      { rw nnnorm_zero },
    end },
  continuous_to_fun := continuous_of_discrete_topology }

def Profinite.pmz_to_level (S : Profinite.{u}) (j : nnreal) (T : discrete_quotient S) :
  (Profinite.of T).pmz ⌊j⌋₊ ⟶
    (ProFiltPseuNormGrp₁.level.obj j).obj (free_pfpng_functor.obj $ Fintype.of T) :=
Profinite.sigma.desc _ $ λ e, S.pmz_to_level_component j T (ulift.down e)

lemma Profinite.pmz_to_level_nat_trans_aux
  (S : Profinite.{u}) (j : nnreal) (T₁ T₂ : discrete_quotient S) (f : T₁ ⟶ T₂)
  (e : fin ⌊j⌋₊ → sign_type) (t : (Profinite.of T₁).pow ⌊j⌋₊) (s : T₂) :
(∑ i : fin ⌊j⌋₊, λ s : T₂, ite (S.fintype_diagram.map f (t i) = s) (e i : ℤ) 0) s =
  (@finset.filter (@bundled.α fintype (S.fintype_diagram.obj T₁))
     (λ w : T₁, S.fintype_diagram.map f w = s)
     (λ (a : @bundled.α fintype (S.fintype_diagram.obj T₁)),
        classical.prop_decidable _)
     (@finset.univ (@bundled.α fintype (S.fintype_diagram.obj T₁))
        (@Fintype.fintype (S.fintype_diagram.obj T₁)))).sum
    (∑ (i : fin ⌊j⌋₊), λ s : T₁, @ite ℤ (t i = s) _ ↑(e i) 0) :=
begin
  simp only [finset.sum_apply],
  rw finset.sum_comm,
  refine finset.sum_congr rfl _,
  rintro i -,
  rw finset.sum_ite_eq,
  simp only [finset.mem_filter, finset.mem_univ, true_and],
end

def Profinite.pmz_to_level_nat_trans (S : Profinite.{u}) (j : nnreal) :
  S.pmz_diagram ⌊j⌋₊ ⟶ (S.fintype_diagram ⋙ free_pfpng_functor) ⋙
    (ProFiltPseuNormGrp₁.level.obj j) :=
{ app := λ T, S.pmz_to_level j T,
  naturality' := begin
    intros T₁ T₂ f,
    dsimp [Profinite.pmz_diagram, Profinite.pmz_to_level, Profinite.pmz_functor],
    apply Profinite.sigma.hom_ext,
    rintro ⟨e⟩,
    simp only [Profinite.sigma.ι_desc_assoc, category.assoc, Profinite.sigma.ι_desc],
    ext t s,
    exact Profinite.pmz_to_level_nat_trans_aux S j T₁ T₂ f e t s,
  end }

def Profinite.pmz_to_free_pfpng (S : Profinite.{u}) (j : nnreal) :
  S.pmz ⌊j⌋₊ ⟶ (ProFiltPseuNormGrp₁.level.obj j).obj S.free_pfpng :=
let E := limits.is_limit_of_preserves (ProFiltPseuNormGrp₁.level.obj j)
  (limits.limit.is_limit (S.fintype_diagram ⋙ free_pfpng_functor)) in
E.map (S.pmz_cone _) (S.pmz_to_level_nat_trans j)

lemma Profinite.is_limit.surjective_of_surjective
  {J : Type u} [small_category J] (F G : J ⥤ Profinite.{u})
  (α : F ⟶ G) (cF : limits.cone F)
  (cG : limits.cone G) (hcF : limits.is_limit cF) (hcG : limits.is_limit cG)
  [is_cofiltered J] (surj : ∀ (j : J), function.surjective ⇑(α.app j)) :
  function.surjective ⇑(limits.is_limit.map cF hcG α) :=
begin
  have := CompHaus.is_limit.surjective_of_surjective
    (F ⋙ Profinite_to_CompHaus)
    (G ⋙ Profinite_to_CompHaus)
    (whisker_right α _)
    (Profinite_to_CompHaus.map_cone cF)
    (Profinite_to_CompHaus.map_cone cG)
    (limits.is_limit_of_preserves _ hcF)
    (limits.is_limit_of_preserves _ hcG)
    surj,
  change function.surjective
    (Profinite_to_CompHaus.map (limits.is_limit.map cF hcG α)),
  convert this,
  apply hcG.hom_ext, intros j,
  simp only [limits.is_limit.map_π, iso.trans_hom, iso.symm_hom,
    functor.map_iso_hom, limits.is_limit.unique_up_to_iso_hom,
    limits.cone.category_comp_hom, limits.is_limit.lift_cone_morphism_hom,
    limits.limit.is_limit_lift, limits.cones.functoriality_map_hom,
    Profinite_to_CompHaus_map],
  erw [category.assoc, category.assoc],
  erw hcG.fac,
  have := (lifted_limit_maps_to_original
    (limits.limit.is_limit (G ⋙ Profinite_to_CompHaus))).inv.w j,
  erw this,
  dsimp, simp only [limits.limit.lift_π, limits.cones.postcompose_obj_π,
    nat_trans.comp_app, functor.map_cone_π_app,
    Profinite_to_CompHaus_map, whisker_right_app],
  refl,
end

section
variables {α : Type*} [decidable_eq α] [nonempty α]

open finset

-- TODO: Inlining this yields an app-builder exception
lemma exists_signed_sum_aux {n : ℕ} (sgn : ℕ → sign_type) (b : α) [decidable_eq α]
  {f : α → ℤ}
  ⦃a : α⦄ (g : ℕ → α) (i : ℕ) :
  ite ((range (n - (f a).nat_abs)).piecewise g (λ _, a) i = b)
        ((range (n - (f a).nat_abs)).piecewise sgn (λ _, sign (f a)) i : ℤ) 0 =
    (range (n - (f a).nat_abs)).piecewise (λ j, ite (g j = b) ↑(sgn j) 0)
        (λ j, ite (a = b) ↑(sign (f a)) 0) i :=
by { unfold piecewise, split_ifs; refl }

-- switch to the version in mathlib
lemma refactor.exists_signed_sum (s : finset α) (n : ℕ) (f : α → ℤ) (hn : ∑ i in s, (f i).nat_abs ≤ n) :
  ∃ (sgn : ℕ → sign_type) (g : ℕ → α), (∀ i, g i ∉ s → sgn i = 0) ∧
    ∀ a ∈ s, (∑ i in range n, if g i = a then (sgn i : ℤ) else 0) = f a :=
begin
  induction s using finset.cons_induction with a s ha ih generalizing n,
  { exact ⟨0, classical.arbitrary _, λ _ _, rfl, λ _, false.elim⟩ },
  rw sum_cons at hn,
  obtain ⟨sgn, g, hg, hf⟩ := ih _ (le_tsub_of_add_le_left hn),
  refine ⟨(range $ n - (f a).nat_abs).piecewise sgn (λ _, sign (f a)),
    (range $ n - (f a).nat_abs).piecewise g (λ _, a), λ i hi, _, λ b hb, _⟩,
  { by_cases i ∈ range (n - (f a).nat_abs),
    { rw piecewise_eq_of_mem _ _ _ h at ⊢ hi,
      exact hg _ (λ h, hi $ subset_cons _ h) },
    { rw piecewise_eq_of_not_mem _ _ _ h at hi,
      exact (hi $ mem_cons_self _ _).elim } },
  transitivity ∑ i in range n, (range $ n - (f a).nat_abs).piecewise
    (λ j, ite (g j = b) (sgn j : ℤ) 0) (λ j, ite (a = b) (sign $ f a) 0) i,
  { exact sum_congr rfl (λ i _, exists_signed_sum_aux _ _ _ _) },
  rw [sum_piecewise, (inter_eq_right_iff_subset _ _).2 (range_mono tsub_le_self)],
  rw mem_cons at hb,
  obtain rfl | hb := hb,
  { rw [sum_eq_zero, zero_add, sum_const, if_pos rfl, card_sdiff (range_mono tsub_le_self),
      card_range, card_range, tsub_tsub_cancel_of_le
        (le_of_add_le_left hn), nsmul_eq_mul, mul_comm,
      ←int.sign_eq_sign, (f b).sign_mul_nat_abs],
    refine λ i hi, ite_eq_right_iff.2 _,
    rintro rfl,
    rw [hg _ ha, sign_type.coe_zero] },
  { simp_rw [if_neg (ne_of_mem_of_not_mem hb ha).symm, hf _ hb, sum_const_zero, add_zero] }
end

lemma Profinite.pmz_to_free_pfpng_epi_aux' [fintype α]
  (r : nnreal) (f : α → ℤ) (hf : ∑ i : α, ∥f i∥₊ ≤ r) :
  ∃ (sgn : ℕ → sign_type) (g : ℕ → α),
    ∀ t, (∑ i in range ⌊r⌋₊, if g i = t then (sgn i : ℤ) else 0) = f t :=
begin
  refine Exists₂.imp (λ _ _ h t, _) (refactor.exists_signed_sum univ ⌊r⌋₊ f _),
  { exact h.2 t (mem_univ _) },
  refine nat.le_floor _,
  simp_rw [nat.cast_sum, nnreal.coe_nat_abs],
  exact hf,
end

lemma Profinite.pmz_to_free_pfpng_epi_aux [fintype α]
  (r : nnreal) (f : α → ℤ) (hf : ∑ i : α, ∥f i∥₊ ≤ r) :
  ∃ (sgn : fin ⌊r⌋₊ → sign_type) (g : fin ⌊r⌋₊ → α),
    (∑ i : fin ⌊r⌋₊, (λ t : α, if g i = t then (sgn i : ℤ) else 0)) = f :=
begin
  obtain ⟨e,g,h⟩ := Profinite.pmz_to_free_pfpng_epi_aux' r f hf,
  let e' : fin ⌊r⌋₊ → sign_type := λ i, e i.1,
  let g' : fin ⌊r⌋₊ → α := λ i, g i.1,
  use [e',g'],
  ext t, rw ← h,
  simp only [finset.sum_apply],
  rw finset.sum_range, refl,
end

end

-- Move this
instance discrete_quotient.nonempty (X : Type*) [topological_space X] [h : nonempty X]
  (T : discrete_quotient X) : nonempty T := ⟨T.proj (nonempty.some h)⟩

instance Profinite.pmz_to_free_pfpng_epi (S : Profinite.{u}) [nonempty S] (j : nnreal) :
  epi (S.pmz_to_free_pfpng j) :=
begin
  rw Profinite.epi_iff_surjective,
  dsimp only [Profinite.pmz_to_free_pfpng],
  have := Profinite.is_limit.surjective_of_surjective _ _ (S.pmz_to_level_nat_trans j)
    (S.pmz_cone _)
    ((ProFiltPseuNormGrp₁.level.obj j).map_cone (limits.limit.cone _))
    (S.pmz_cone_is_limit _)
    (limits.is_limit_of_preserves _ (limits.limit.is_limit _)),
  apply this,
  intros T,
  rintros ⟨(f : T → ℤ), hf : ∑ i : T, _ ≤ _⟩,
  obtain ⟨e,t,ht⟩ := Profinite.pmz_to_free_pfpng_epi_aux j f hf,
  change ∃ a : Σ i, fin ⌊j⌋₊ → T, _,
  use ulift.up e, use t, apply subtype.ext,
  dsimp [Profinite.pmz_to_level_nat_trans, Profinite.pmz_to_level,
    Profinite.sigma.desc, Profinite.pmz_to_level_component],
  exact ht,
end

.

namespace Profinite.epi_free'_to_condensed_setup

variables (S : Profinite.{u}) (j : nnreal)

lemma free'_lift_app_eq (A : Condensed.{u} Ab.{u+1})
  (η : S.to_Condensed ⟶ Condensed_Ab_to_CondensedSet.obj A)
  (T : Profinite.{u}) :
  (proetale_topology.to_sheafify _).app _ ≫ (S.free'_lift η).val.app (op T) =
  free'_lift (η.val.app _) :=
begin
  dsimp [Profinite.free'_lift],
  rw [← nat_trans.comp_app, proetale_topology.to_sheafify_sheafify_lift],
  dsimp [adjunction.whisker_right, free'_lift], simp,
end

lemma free'_lift_app_eq' (A : Condensed.{u} Ab.{u+1})
  (η : S.to_Condensed ⟶ Condensed_Ab_to_CondensedSet.obj A)
  (T : Profinite.{u}) :
  (proetale_topology.to_sheafify _).app _ ≫ (S.free'_lift η).val.app (op T) =
  ((finsupp.lift ↥(A.val.obj (op T)) ℤ
      (((Sheaf_to_presheaf proetale_topology (Type (u+1))).obj S.to_Condensed).obj (op T)))
   (η.val.app (op T))).to_add_monoid_hom :=
begin
  rw free'_lift_app_eq, rw free'_lift_eq_finsupp_lift,
end

instance (A : Condensed.{u} Ab.{u+1}) (T) :
  add_comm_group ((Condensed_Ab_to_CondensedSet.obj A).val.obj T) :=
show add_comm_group (A.val.obj T), by apply_instance

lemma free_pfpng_ext (u v : S.free_pfpng)
  (huv : ∀ T : discrete_quotient S, S.free_pfpng_π T u = S.free_pfpng_π T v) : u = v :=
begin
  let E : limits.cone (S.fintype_diagram ⋙ free_pfpng_functor) :=
    ProFiltPseuNormGrp₁.bounded_cone
    ⟨Ab.explicit_limit_cone.{u u} _, Ab.explicit_limit_cone_is_limit _⟩,
  let hE : limits.is_limit E := ProFiltPseuNormGrp₁.bounded_cone_is_limit _,
  let ee : S.free_pfpng ≅ E.X := (limits.limit.is_limit _).cone_point_unique_up_to_iso hE,
  apply_fun ee.hom, swap,
  { intros x y hh, apply_fun ee.inv at hh, simpa using hh },
  ext T : 3, exact huv T,
end

variables (x : S.pmz ⌊j⌋₊) (T : discrete_quotient S)

lemma lhs_helper : (S.free_pfpng_π T) ((S.pmz_to_free_pfpng j) x).1 =
  ∑ i : fin ⌊j⌋₊, pi.single (T.proj (x.2 i)) (x.1.down i : ℤ) :=
begin
  change (((S.pmz_to_free_pfpng _) ≫ (ProFiltPseuNormGrp₁.level.obj j).map
    (S.free_pfpng_π T)) _).val = _,
  dsimp [Profinite.pmz_to_free_pfpng, Profinite.free_pfpng_π],
  erw ← comp_apply,
  erw limits.is_limit.fac,
  dsimp [Profinite.pmz_to_level_nat_trans, Profinite.pmz_to_level],
  rcases x with ⟨x1,x2⟩,
  dsimp [Profinite.pmz_cone, Profinite.sigma.desc, Profinite.pmz_to_level_component,
    Profinite.pmz_functor, Profinite.product.lift, Profinite.sigma.ι],
  congr' 1, ext i t, erw pi.single_apply,
  split_ifs with h1 h2 h3 h4,
  { refl },
  { exact false.elim (h2 h1.symm) },
  { exact false.elim (h1 h3.symm) },
  { refl }
end

lemma rhs_helper₁ :
  (λ (f : ulift (fin ⌊j⌋₊ → sign_type)),
  ∑ (x : fin ⌊j⌋₊),
    ((proetale_topology.to_sheafify (S.to_Condensed.val ⋙ AddCommGroup.free')).app
      (op (S.pow ⌊j⌋₊)))
      (finsupp.single {down := Profinite.product.π (λ (i : fin ⌊j⌋₊), S) x} ↑(f.down x))) =
  ∑ (x : fin ⌊j⌋₊), (λ f, (proetale_topology.to_sheafify
    (S.to_Condensed.val ⋙ AddCommGroup.free')).app (op (S.pow ⌊j⌋₊)) $
    finsupp.single ⟨Profinite.product.π _ x⟩ (f.down x)) := by { ext, simp }

def _root_.CompHausFiltPseuNormGrp.coe_add_monoid_hom
  (A : CompHausFiltPseuNormGrp.{u}) (T : Profinite.{u}) :
  (CompHausFiltPseuNormGrp.to_Condensed.obj A).val.obj (op T) →+ T → A :=
{ to_fun := λ f, f.down.1,
  map_zero' := rfl,
  map_add' := λ _ _, rfl }

lemma _root_.CompHausFiltPseuNormGrp.to_Condensed_app_sum_apply (n : ℕ)
  (A : CompHausFiltPseuNormGrp.{u}) (T : Profinite.{u})
    (g : fin n → (CompHausFiltPseuNormGrp.to_Condensed.obj A).val.obj (op T)) (t : T) :
  (ulift.down (∑ i : fin n, g i)).1 t = ∑ i : fin n,
    (ulift.down (g i)).1 t :=
begin
  let e := A.coe_add_monoid_hom T,
  change _ = ∑ (i : fin n), (e (g i)) t,
  rw [← finset.sum_apply t finset.univ (λ i : fin n, (e (g i))), ← e.map_sum],
  refl,
end

lemma Profinite.free'_lift_val_obj_sigma_equiv_symm {α : Type u} [fintype α]
  (A : Condensed.{u} Ab.{u+1}) (η : S.to_Condensed ⟶ Condensed_Ab_to_CondensedSet.obj A)
  (X : α → Profinite.{u}) (t) :
  (S.free'_lift η).val.app (op $ Profinite.sigma X)
  ((Condensed.val_obj_sigma_add_equiv _ _ ).symm t) =
  (Condensed.val_obj_sigma_add_equiv _ _ ).symm (λ a, (S.free'_lift η).val.app _ (t a)) :=
begin
  apply_fun Condensed.val_obj_sigma_add_equiv (λ (a : α), X a) A,
  simp only [add_equiv.apply_symm_apply],
  funext a,
  dsimp,
  simp only [← comp_apply, ← nat_trans.naturality],
  simp only [comp_apply],
  congr' 1,
  rw ← Condensed.val_obj_sigma_add_equiv_apply_apply,
  simp only [add_equiv.apply_symm_apply],
end

-- move and rename
def rhs_helper_equiv
  (A : ProFiltPseuNormGrp₁.{u}) :
  A ≃ (CompHausFiltPseuNormGrp.to_Condensed.obj
    (CHFPNG₁_to_CHFPNGₑₗ.obj
      (PFPNG₁_to_CHFPNG₁ₑₗ.obj A))).val.obj
      (op Profinite.punit) :=
{ to_fun := λ a, ulift.up $ ⟨λ _, a, begin
    obtain ⟨c,hc⟩ := ProFiltPseuNormGrp₁.exhaustive _ a,
    refine ⟨c, λ _, ⟨a,hc⟩, _, rfl⟩,
    apply continuous_of_discrete_topology
  end⟩,
  inv_fun := λ f, f.down.val punit.star,
  left_inv := λ t, rfl,
  right_inv := λ t, by { ext ⟨⟩, refl } }

-- move and rename
def rhs_helper_equiv' :
  S ≃ S.to_Condensed.val.obj (op Profinite.punit) :=
{ to_fun := λ s, ulift.up $ Profinite.pt s,
  inv_fun := λ s, (ulift.down s).1 punit.star,
  left_inv := λ t, rfl,
  right_inv := λ t, by { ext ⟨⟩, refl } }

lemma rhs_helper₄ {α : Type u} [fintype α]
  (A : ProFiltPseuNormGrp₁.{u})
  (X : α → Profinite.{u})
  (e : Π (a : α),
    (CompHausFiltPseuNormGrp.to_Condensed.obj
    (CHFPNG₁_to_CHFPNGₑₗ.obj
      (PFPNG₁_to_CHFPNG₁ₑₗ.obj A))).val.obj (op $ X a))
  (a₀ : α) (x₀ : X a₀) :
  ((Condensed.val_obj_sigma_add_equiv X _).symm e).down.val ⟨a₀,x₀⟩ =
  (e a₀).down.val x₀ :=
begin
  let B := Condensed_Ab_to_CondensedSet.obj
    (CompHausFiltPseuNormGrp.to_Condensed.obj
    (CHFPNG₁_to_CHFPNGₑₗ.obj
      (PFPNG₁_to_CHFPNG₁ₑₗ.obj A))) ,
  let e₀ : (X a₀).to_Condensed ⟶ B :=
    (Profinite.to_Condensed_equiv _ B).symm (e a₀),
  let ee : (Profinite.sigma X).to_Condensed ⟶ B :=
    (Profinite.to_Condensed_equiv _ B).symm ((Condensed.val_obj_sigma_add_equiv X _).symm e),
  apply_fun rhs_helper_equiv A,
  let s₀ : (X a₀).to_Condensed.val.obj (op Profinite.punit) :=
    rhs_helper_equiv' _ x₀,
  have : (rhs_helper_equiv A) ((e a₀).down.val x₀) =
    e₀.val.app _ s₀, refl,
  rw this,
  have : e₀ = (Profinite_to_Condensed.map (Profinite.sigma.ι X a₀)) ≫ ee,
  { dsimp only [e₀, ee], symmetry,
    apply _root_.Condensed.val_obj_sigma_add_equiv_symm_apply },
  rw this, refl,
end

lemma rhs_helper₃ (i : fin ⌊j⌋₊) :
  ((((S.free'_lift S.to_condensed_free_pfpng).val.app (op (S.pmz ⌊j⌋₊)))
    (((Condensed.val_obj_sigma_add_equiv (λ (f : ulift (fin ⌊j⌋₊ → sign_type)), S.pow ⌊j⌋₊)
      S.free').symm)
    (λ (f : ulift (fin ⌊j⌋₊ → sign_type)),
      ((proetale_topology.to_sheafify (S.to_Condensed.val ⋙ AddCommGroup.free')).app
      (op (S.pow ⌊j⌋₊)))
      (finsupp.single {down := Profinite.product.π (λ (i : fin ⌊j⌋₊), S) i}
        ↑(f.down i))))).down).1 x =
    (x.1.down i : ℤ) • (S.to_free_pfpng (x.2 i)).1 :=
begin
  erw Profinite.free'_lift_val_obj_sigma_equiv_symm,
  simp only [← comp_apply],
  erw [free'_lift_app_eq'],
  simp only [continuous_map.to_fun_eq_coe, linear_map.to_add_monoid_hom_coe, finsupp.lift_apply,
  Profinite.to_condensed_free_pfpng_app, finsupp.sum_single_index, zero_smul, subtype.val_eq_coe],
  -- This is now very close...
  let Q := Condensed.val_obj_sigma_add_equiv (λ (a : ulift (fin ⌊j⌋₊ → sign_type)), S.pow ⌊j⌋₊)
    S.condensed_free_pfpng,
  change (Q.symm _).down.1 _ = _,
  cases x with x1 x2,
  erw rhs_helper₄,
  refl,
end

lemma rhs_helper₂ (i : fin ⌊j⌋₊) : (S.free_pfpng_π T)
  (((((S.free'_lift S.to_condensed_free_pfpng).val.app (op (S.pmz ⌊j⌋₊)))
    (((Condensed.val_obj_sigma_add_equiv (λ (f : ulift (fin ⌊j⌋₊ → sign_type)), S.pow ⌊j⌋₊)
      S.free').symm)
    (λ (f : ulift (fin ⌊j⌋₊ → sign_type)),
      ((proetale_topology.to_sheafify (S.to_Condensed.val ⋙ AddCommGroup.free')).app
      (op (S.pow ⌊j⌋₊)))
      (finsupp.single {down := Profinite.product.π (λ (i : fin ⌊j⌋₊), S) i}
        ↑(f.down i))))).down).1 x) =
  pi.single (T.proj (x.snd i)) ↑(x.fst.down i) :=
begin
  rw rhs_helper₃,
  erw (S.free_pfpng_π T).to_add_monoid_hom.map_zsmul,
  change
    _ • (((S.to_free_pfpng) ≫ (ProFiltPseuNormGrp₁.level.obj 1).map (S.free_pfpng_π T)) _).val = _,
  dsimp [Profinite.to_free_pfpng, Profinite.free_pfpng_π,
    Profinite.free_pfpng_level_iso],
  dsimp [limits.is_limit.cone_point_unique_up_to_iso],
  erw ← comp_apply,
  erw ← comp_apply,
  erw limits.is_limit.fac,
  erw limits.is_limit.fac,
  dsimp [Fintype.free_pfpng_unit, Profinite.as_limit_cone],
  ext t, erw pi.single_apply, split_ifs; simp,
  { intros hh, exact false.elim (hh h.symm) },
  { intros hh, exact false.elim (h hh.symm) },
end

lemma rhs_helper :
  (S.free_pfpng_π T)
  ((((S.free'_lift S.to_condensed_free_pfpng).val.app (op (S.pmz ⌊j⌋₊)))
  ((S.pmz_to_free' ⌊j⌋₊).val.app (op (S.pmz ⌊j⌋₊)) {down := 𝟙 (S.pmz ⌊j⌋₊)})).1.1 x) =
  ∑ i : fin ⌊j⌋₊, pi.single (T.proj (x.2 i)) (x.1.down i : ℤ) :=
begin
  dsimp [Profinite.pmz_to_free'],
  rw [category_theory.functor.map_id, id_apply],
  simp only [add_monoid_hom.map_sum],
  rw [rhs_helper₁],
  rw [add_equiv.map_sum, add_monoid_hom.map_sum],
  have := _root_.CompHausFiltPseuNormGrp.to_Condensed_app_sum_apply ⌊j⌋₊ _ _ _ x,
  dsimp at this, erw this, clear this,
  erw (S.free_pfpng_π T).to_add_monoid_hom.map_sum,
  congr' 1, funext i, dsimp,
  erw rhs_helper₂,
end

lemma key (j : (ulift.{u+1} nnreal)) :
  Profinite_to_Condensed.map (S.pmz_to_free_pfpng j.down) ≫
    (CHFPNG₁_to_CHFPNGₑₗ.obj
    (PFPNG₁_to_CHFPNG₁ₑₗ.obj S.free_pfpng)).level_Condensed_diagram_cocone.ι.app j =
  S.pmz_to_free' ⌊j.down⌋₊ ≫
  Condensed_Ab_to_CondensedSet.map S.free'_to_condensed_free_pfpng :=
begin
  apply_fun Profinite.to_Condensed_equiv _ _,
  ext x : 3, dsimp at x,
  dsimp [CompHausFiltPseuNormGrp.level_Condensed_diagram_cocone,
    Profinite.free'_to_condensed_free_pfpng],
  apply free_pfpng_ext, intros T,
  erw lhs_helper, erw rhs_helper,
end

end Profinite.epi_free'_to_condensed_setup

instance Profinite.epi_free'_to_condensed_free_pfpng_of_nonempty
  (S : Profinite.{u}) [nonempty S] : epi S.free'_to_condensed_free_pfpng :=
begin
  apply functor.epi_of_epi_map (Condensed_Ab_to_CondensedSet),
  let E := CompHausFiltPseuNormGrp.level_Condensed_diagram_cocone
    (CHFPNG₁_to_CHFPNGₑₗ.obj
    ((PFPNG₁_to_CHFPNG₁ₑₗ.obj S.free_pfpng))),
  have hh : is_iso (limits.colimit.desc _ E),
  { change is_iso (CompHausFiltPseuNormGrp.colimit_to_Condensed_obj _),
    apply_instance },
  let hE : limits.is_colimit E := @limits.is_colimit.of_point_iso
    _ _ _ _ _ _ _ _ hh, -- <-- move this
  apply category_theory.epi_to_colimit_of_exists  _ E hE,
  intros j,
  let j' : nnreal := ulift.down j,
  use [(S.pmz ⌊j'⌋₊).to_Condensed, S.pmz_to_free' ⌊j'⌋₊,
    Profinite_to_Condensed.map (S.pmz_to_free_pfpng j')],
  split,
  { apply epi_Profinite_to_Condensed_map_of_epi },
  { apply Profinite.epi_free'_to_condensed_setup.key },
end


import data.finsupp.basic
import data.finsupp.indicator

variables {α β γ : Type*} [add_comm_monoid β]
open_locale classical
noncomputable theory

namespace finsupp

def sum_range : (α →₀ β) →+ β :=
{ to_fun := λ f, (f.map_domain default) (),
  map_zero' := rfl,
  map_add' := by simp [map_domain_add] }

variables (f g : α →₀ β)
lemma sum_range_eq_sum : f.sum_range = f.sum (λ _ v, v) :=
by simp [sum_range, map_domain]

@[simp] lemma sum_range_single (x : α) (y : β) : (finsupp.single x y).sum_range = y :=
by simp [sum_range]

@[simp] lemma map_domain_sum_range (h : α → γ) :
  (f.map_domain h).sum_range = f.sum_range :=
by simp [sum_range, ← finsupp.map_domain_comp]

end finsupp


import .choice5

-- Prove general definable choice from the 1D version.

open o_minimal

universe u

variables {R : Type u} [OQM R] {S : struc R} [o_minimal_add S]

section

variables {X Y : Type*} [definable_sheaf S X] [definable_sheaf S Y]

noncomputable
def chosen_n_aux : Π {n : ℕ} (s : set (Y × finvec n R)) (h : prod.fst '' s = set.univ) (y : Y),
  {v : finvec n R // (y, v) ∈ s}
| 0     s h y := ⟨fin_zero_elim, by { obtain ⟨⟨y', z⟩, h, rfl⟩ : y ∈ prod.fst '' s, by { rw h, trivial }, convert h }⟩
| (n+1) s h y :=
let π : Y × finvec (n+1) R → Y × finvec n R := λ p, (p.1, finvec.init p.2),
    t : set (Y × finvec n R)                := π '' s,
    i : t × R → Y × finvec (n+1) R          := λ p, (p.fst.val.fst, p.fst.val.snd.snoc p.snd),
    s' : set (t × R)                        := i ⁻¹' s
in  have prod.fst '' t = set.univ,
    { have : (prod.fst : Y × finvec (n+1) R → Y) = (prod.fst : Y × finvec n R → Y) ∘ π,
      { ext ⟨_, _⟩, refl },
      rwa [this, set.image_comp] at h },
let v : {v // (y, v) ∈ t} := (chosen_n_aux t this y),
    x : ↥t := ⟨(y, v), v.2⟩ in
⟨finvec.snoc v.1 (chosen_1 s' x),
begin
  apply chosen_1_mem s' _ x,
  { -- TODO: is this right? probably an easier way
    apply set.eq_univ_of_forall,
    rintro ⟨_, ⟨⟨y, r⟩, h, rfl⟩⟩,
    refine ⟨(⟨(y, fin.init r), ⟨(y, r), h, rfl⟩⟩, r (fin.last n)), _, rfl⟩,
    { change (y, _) ∈ s,
      convert h,
      rw finvec.snoc_eq_append,
      convert finvec.left_append_right r,
      ext j,
      fin_cases j,
      simp [finvec.right],
      refl } },
end⟩

end

section

variables {X : Type u} [has_coordinates R X] [is_definable S X]
variables {Y : Type u} [has_coordinates R Y] [is_definable S Y]

-- Inductive argument: definable choice for projections s ⊆ Y × Rⁿ → Y.
lemma definable_choice_n {n : ℕ} {s : set (Y × finvec n R)} (hs : def_set S s)
  (h : prod.fst '' s = set.univ) :
  ∃ g : Y → finvec n R, def_fun S g ∧ ∀ y, (y, g y) ∈ s :=
begin
  induction n with n IH,
  { refine ⟨λ y, fin_zero_elim, def_fun_const, λ y, _⟩,
    have : y ∈ prod.fst '' s := by { rw h, trivial },
    obtain ⟨⟨y', z⟩, h, rfl⟩ := this,
    convert h },
  { let π : Y × finvec (n+1) R → Y × finvec n R := λ p, (p.1, finvec.init p.2),
    have dπ : def_fun S π := def_fun.prod def_fun.id (by exact def_fun.finvec.init),
    let t : set (Y × finvec n R) := π '' s,
    have dt : def_set S t := def_fun.image dπ hs,
    have : prod.fst '' t = set.univ,
    { have : (prod.fst : Y × finvec (n+1) R → Y) = (prod.fst : Y × finvec n R → Y) ∘ π,
      { ext ⟨_, _⟩, refl },
      rwa [this, set.image_comp] at h },
    obtain ⟨g' : Y → finvec n R, hg'₁, hg'₂⟩ := IH dt this,
    -- Now, we need to massage the data into the form to apply `definable_choice_1`.
    letI : is_definable S t := is_definable.subtype dt,
    let i : t × R → Y × finvec (n+1) R := λ p, (p.fst.val.fst, p.fst.val.snd.snoc p.snd),
    have di : def_fun S i,
    { apply def_fun.prod',
      { exact def_fun.fst.comp (def_fun_subtype_val.comp def_fun.fst) },
      { apply def_fun.finvec.snoc,
        { exact def_fun.snd.comp (def_fun_subtype_val.comp def_fun.fst) },
        { exact def_fun.snd } } },
    let s' := i ⁻¹' s,
    have ds' : def_set S s' := di.preimage hs,
    have : prod.fst '' s' = set.univ,
    { -- TODO: is this right? probably an easier way
      apply set.eq_univ_of_forall,
      rintro ⟨_, ⟨⟨y, r⟩, h, rfl⟩⟩,
      refine ⟨(⟨(y, fin.init r), ⟨(y, r), h, rfl⟩⟩, r (fin.last n)), _, rfl⟩,
      { change (y, _) ∈ s,
        convert h,
        rw finvec.snoc_eq_append,
        convert finvec.left_append_right r,
        ext j,
        fin_cases j,
        simp [finvec.right],
        refl } },
    obtain ⟨g'' : t → R, hg''₁, hg''₂⟩ := definable_choice_1 ds' this,
    -- Finally combine all the stuff.
    refine ⟨λ y, finvec.snoc (g' y) (g'' ⟨⟨y, g' y⟩, hg'₂ y⟩), _, λ y, hg''₂ ⟨⟨y, g' y⟩, hg'₂ y⟩⟩,
    apply def_fun.finvec.snoc hg'₁,
    apply hg''₁.comp,
    apply def_fun_subtype_mk,
    exact def_fun.id.prod' hg'₁ }
end

-- General form of definable choice.
theorem definable_choice {f : X → Y} (hf : def_fun S f) (h : function.surjective f) :
  ∃ g : Y → X, def_fun S g ∧ f ∘ g = id :=
begin
  let j : X → Y × finvec _ R := λ x, (f x, coords R x),
  have dj : def_fun S j := def_fun.prod' hf def_fun.coords,
  let Γ := set.range j,
  have dΓ : def_set S Γ := dj.range,
  have : prod.fst '' Γ = set.univ,
  { apply set.eq_univ_of_forall, intro y,
    obtain ⟨x, rfl⟩ := h y,
    refine ⟨j x, set.mem_range_self _, rfl⟩ },
  obtain ⟨g', hg'₁, hg'₂⟩ := definable_choice_n dΓ this,
  simp only [Γ, set.mem_range] at hg'₂,
  choose g hg₂ using hg'₂,
  refine ⟨g, _, _⟩,
  { -- we should show that `coords R : X → (fin _ → R)` is a "definable embedding"
    -- & therefore `coords R ∘ g = g'`, `def_fun S g'` implies `def_fun S g`.
    -- this doesn't mean anything special, just definable & injective.
    have : coords R ∘ g = g',
    { ext y, have := hg₂ y, dsimp only [j] at this, dsimp only [(∘)], cc },
    apply def_fun.cancel def_fun.coords (injective_coords _),
    convert hg'₁ },
  { ext y, have := hg₂ y, dsimp only [j] at this, dsimp only [(∘), id], cc }
end

end


import ReactorModel.Determinism.Dependency

open Classical ReactorType Indexable

namespace Execution
namespace State

theorem exec_preserves_tag [Indexable α] (s : State α) (rcn : ID) : (s.exec rcn).tag = s.tag :=
  rfl

theorem exec_preserves_progress [Indexable α] (s : State α) (rcn : ID) :
    (s.exec rcn).progress = s.progress :=
  rfl

theorem exec_equiv [Indexable α] (s : State α) (rcn : ID) : s.rtr ≈ (s.exec rcn).rtr := by
  simp [exec]
  exact Equivalent.symm $ apply'_equiv _ _

variable [Proper α] {s : State α}

theorem target_not_mem_indep_output
    (h₂ : s.rtr[.rcn][i₂] = some rcn₂) (hi : i₁ ≮[s.rtr]≯ i₂) (hd : ⟨cpt, i⟩ ∈ rcn₂.deps .in) :
    (s.output i₁).All₂ (¬·.Targets cpt i) := by
  apply List.all₂_iff_forall.mpr
  intro c hc
  simp [output] at hc
  split at hc <;> try contradiction
  case _ rcn₁ h₁ =>
    cases cpt
    all_goals
      intro ⟨⟩
      apply absurd hd
    case stv =>
      exact hi.state_mem_rcn₁_deps_not_mem_rcn₂_deps h₁ h₂ hc
    all_goals
      exact hi.left.deps_disjoint h₁ h₂ (rcn₁.target_mem_deps hc) $ by simp [Change.Normal.target]

theorem exec_indep_restriction_eq (hi : i₁ ≮[s.rtr]≯ i₂) (h₂ : s.rtr[.rcn][i₂] = some rcn₂) :
    input.restriction (s.exec i₁) rcn₂ cpt = input.restriction s rcn₂ cpt := by
  simp [input.restriction]
  apply Partial.ext_restrict
  intro _ hd
  exact apply'_preserves_unchanged $ target_not_mem_indep_output h₂ hi hd

theorem exec_indep_input_eq
    (hi : i₁ ≮[s.rtr]≯ i₂) (h : s.rtr[.rcn][i₂] = some rcn₂)
    (h' : (s.exec i₁).rtr[.rcn][i₂] = some rcn₂) : (s.exec i₁).input i₂ = s.input i₂ := by
  simp [input, h, h']
  refine ⟨?_, by simp [exec]⟩
  ext1
  injection h' ▸ Equivalent.obj?_rcn_eq (s.exec_equiv i₁) ▸ h with h'
  exact h'.symm ▸ exec_indep_restriction_eq hi h

theorem exec_indep_output_eq (hi : i₁ ≮[s.rtr]≯ i₂) : (s.exec i₁).output i₂ = s.output i₂ := by
  simp [output]
  have e := Equivalent.obj?_rcn_eq $ s.exec_equiv i₁
  cases h : s.rtr[.rcn][i₂] <;> simp [e ▸ h]
  simp [exec_indep_input_eq hi h $ e ▸ h]

theorem indep_normal_output_disjoint (hi : i₁ ≮[s.rtr]≯ i₂) :
    List.Disjoint (s.output i₁ |>.filter (·.IsNormal)) (s.output i₂ |>.filter (·.IsNormal)) := by
  cases h₁ : s.rtr[.rcn][i₁] <;> cases h₂ : s.rtr[.rcn][i₂] <;> simp [output, *]
  case some.some rcn₁ rcn₂ =>
    simp [List.Disjoint, List.mem_filter]
    intro _ hc₁ hn
    cases hn
    case intro c =>
      intro hc₂ _
      replace hc₁ := rcn₁.target_mem_deps hc₁
      replace hc₂ := rcn₂.target_mem_deps hc₂
      simp [Change.Normal.target] at hc₁ hc₂
      cases hc : c.cpt <;> try cases ‹Kind›
      case stv =>
        -- by_cases h :
        -- have ⟨_, _, h₁, ho₁⟩ := Indexable.obj?_split h₁
        -- have ⟨_, _, h₂, ho₂⟩ := Indexable.obj?_split h₂
        --
        -- have := s.rtr.wellformed.overlap_prio h₁ ho₁ (hc ▸ hc₁)
        -- have := s.rtr.wellformed.state_local h₂ ho₂ (hc ▸ hc₂)
        sorry -- You've trying to construct a dependency between
      case act => sorry
      case prt.in => sorry
      case prt.out => sorry

theorem exec_indep_swap (hi : rcn₁ ≮[s.rtr]≯ rcn₂) :
    (s.exec rcn₁).exec rcn₂ = (s.exec rcn₂).exec rcn₁ := by
  ext1
  case tag => apply exec_preserves_tag
  case progress => apply exec_preserves_progress
  case rtr =>
    conv => lhs; rw [exec, exec_indep_output_eq hi]
    conv => rhs; rw [exec, exec_indep_output_eq hi.symm]
    apply apply'_normal_disjoint_comm $ indep_normal_output_disjoint hi

namespace State
namespace Execution


import order

import lib.list

import etv
import main.lemmas.join_n2_n2

open order_dual

variables {α : Type*} [linear_order α] (C : config α)

lemma config.has_interweaved_laced_has_ngon_ff
  {n : ℕ} {S : finset α}
  (cap4_free : ¬C.has_ncap 4 S) {p q r s : α}
  (label : C.label S) (q_lt_r : q < r) (sqr : ¬label.slope q r) :
  C.has_interweaved_laced (n+2) S p q r s → C.has_ngon (n+3) S :=
begin
  intro h, rcases h with ⟨⟨p_lt_q, q_le_r, r_lt_s⟩, ⟨pr_laced, qs_laced⟩⟩,
  rcases pr_laced with
    ⟨a, b, cp, c1, cr, hcp, hc1, hcr,
    ⟨⟨cp_in_S, c1_in_S, cr_in_S⟩, eq_ab,
      cp_last, c1_head, c1_last, cr_head⟩⟩,
  rcases qs_laced with
    ⟨c, d, cq, c2, cs, hcq, hc2, hcs,
    ⟨⟨cq_in_S, c2_in_S, cs_in_S⟩, eq_cd,
      cq_last, c2_head, c2_last, cs_head⟩⟩,

  have p_in_S : p ∈ S := begin
    apply c1_in_S,
    exact list.mem_of_mem_head' c1_head,
  end,
  have q_in_S : q ∈ S := begin
    apply c2_in_S,
    exact list.mem_of_mem_head' c2_head,
  end,
  have r_in_S : r ∈ S := begin
    apply c1_in_S,
    exact list.mem_of_mem_last' c1_last,
  end,
  have s_in_S : s ∈ S := begin
    apply c2_in_S,
    exact list.mem_of_mem_last' c2_last,
  end,

  have label := cap4_free_label cap4_free,
  by_cases spq : label.slope p q, swap,
  { apply ncup_is_ngon, linarith,
    use (p :: c2), split,
    apply hc2.extend_left spq; assumption,
    simp, tauto },
  -- (spq : ¬label.slope p q) from now on
  by_cases cpqr : C.cup3 p q r,
  { apply ncup_is_ngon, linarith,
    use (cp ++ q :: cr), split, swap, simp, tauto,
    have cp_nnil : cp ≠ [] := begin
      intro h, subst h, simp at cp_last, exact cp_last,
    end,
    rcases list.take_last cp_nnil with ⟨p, cp', eq_cp⟩,
    rw eq_cp at cp_last, simp at cp_last, subst cp_last,
    -- idea: implement a lemma for taking explicit head
    -- from a statement like this
    have cr_nnil : cr ≠ [] := begin
      intro h, subst h, simp at cr_head, exact cr_head,
    end,
    rcases list.take_head cr_nnil with ⟨r, cr', eq_cr⟩, split,
    rw eq_cr at cr_head, simp at cr_head, subst cr_head,
    rw [eq_cp, eq_cr], simp,
    refine ⟨_, _, _⟩, swap, assumption,
    have eq : cp' ++ [p, q] = cp' ++ [p] ++ [q] := by simp,
    rw eq, rw ←eq_cp,
    apply hcp.left.extend_right spq; try {assumption},
    rw eq_cp, simp,
    rw ←eq_cr,
    apply hcr.left.extend_left sqr; try {assumption},
    rw eq_cr, simp,
    simp, rw [hcp.right, hcr.right], linarith },
  { use [[p, q, r], c1], split, swap, simp, tauto,
    split, swap, rw hc1.right, simp, linarith,
    rw config.gon, simp,
    cases hc1 with c1_cup c1_length, rw c1_length,
    simp at c1_head c1_last,
    have h2n : 2 ≤ n + 2 := le_add_self, tauto, },
end

lemma config.has_interweaved_laced_has_ngon_tt
  {n : ℕ} {S : finset α}
  (cap4_free : ¬C.has_ncap 4 S) {p q r s : α}
  (label : C.label S) (q_lt_r : q < r) (sqr : label.slope q r) :
  C.has_interweaved_laced (n+2) S p q r s → C.has_ngon (n+3) S :=
begin
  rw [←mirror.has_interweaved_laced, ←mirror.has_ngon],
  have srq := sqr, rw ←mirror_slope at srq,
  rw ←mirror.has_ncap at cap4_free,
  apply C.mirror.has_interweaved_laced_has_ngon_ff; assumption
end

lemma config.has_interweaved_laced_has_ngon
  {n : ℕ} {S : finset α}
  (cap4_free : ¬C.has_ncap 4 S) {p q r s : α} :
  C.has_interweaved_laced (n+2) S p q r s → C.has_ngon (n+3) S :=
begin
  intro h, have q_le_r : q ≤ r :=
    by rw config.has_interweaved_laced at h; tauto,
  rw le_iff_eq_or_lt at q_le_r,
  cases q_le_r,
  { subst q_le_r, rcases h with ⟨-, pr_laced, qs_laced⟩,
    rcases pr_laced with ⟨-, -, -, c1, -, -, hc1, -,
      ⟨-, c1_in_S, -⟩, -,
      ⟨-, c1_head, c1_last, -⟩⟩,
    rcases qs_laced with ⟨-, -, -, c2, -, -, hc2, -,
      ⟨-, c2_in_S, -⟩, -,
      ⟨-, c2_head, c2_last, -⟩⟩,
    apply C.join_n2_n2 S cap4_free
      hc1 c1_in_S hc2 c2_in_S q c1_last c2_head, },
  rename q_le_r → q_lt_r,

  have label := cap4_free_label cap4_free,
  by_cases sqr : label.slope q r,
  { revert sqr h,
    apply C.has_interweaved_laced_has_ngon_tt; assumption, },
  { revert sqr h,
    apply C.has_interweaved_laced_has_ngon_ff; assumption, },
end


import number_theory.padics.padic_integers

--OUTPUT 1
theorem p_adic_units (p : ℕ) (x : ℕ) (h : gcd x p = 1) : ∃ y : ℤ_p, y * x = 1 :=
begin
  have h1 : ¬ (∃ y : ℤ_p, y * x = 1), from by {
    assume h2 : ∃ y : ℤ_p, y * x = 1,
    have h3 : ∃ y : ℤ_p, y * x = 1, from by {
      have h4 : ∃ y : ℤ_p, y * x = 1, from h2,
      have h5 : ∃ y : ℤ_p, y * x = 1, from h4,
      exact h5,
    },
    have h6 : ∃ y : ℤ_p, y * x = 1, from h3,
    have h7 : ∃ y : ℤ_p, y * x = 1, from h6,
    have h8 : ∃ y : ℤ_p, y * x = 1, from h7,
    have h9 : ∃ y : ℤ_p, y * x = 1, from h8,
    have h10 : ∃ y : ℤ_p, y * x = 1, from h9,
    have h11 : ∃ y : ℤ_p, y * x = 1, from h10,
    have h12 : ∃ y : ℤ_p, y * x = 1, from h11,
    have h13 : ∃ y : ℤ_p, y * x = 1, from h12,
    have h14 : ∃ y : ℤ_p, y * x = 1, from h13,
    have h15 : ∃ y : ℤ_p, y * x = 1, from h14,
    have h16 : ∃ y : ℤ_p, y * x = 1, from h15,
    have h17 : ∃ y : ℤ_p, y * x = 1, from h16,
    have h18 : ∃ y : ℤ_p, y * x = 1, from h17,
    have h19 : ∃ y : ℤ_p, y * x = 1, from h18,
    have h20 : ∃ y : ℤ_p, y * x = 1, from h19,
    have h21 : ∃ y : ℤ_p, y * x = 1, from h20,
    have h22 : ∃ y : ℤ_p, y * x = 1, from h21,
    have h23 : ∃ y : ℤ_p, y * x = 1, from h22,
    have h24 : ∃ y : ℤ_p, y * x = 1, from h23,
    have h25 : ∃ y : ℤ_p, y * x = 1, from h24,
    have h26 : ∃ y : ℤ_p, y * x = 1, from h25,
    have h27 : ∃ y : ℤ_p, y * x = 1, from h26,
    have h28 : ∃ y : ℤ_p, y * x = 1, from h27,
    have h29 : ∃ y : ℤ_p, y * x = 1, from h28,
    have h30 : ∃ y : ℤ_p, y * x = 1, from h29,
    have h31 : ∃ y : ℤ_p, y * x = 1, from h30,
    have h32 : ∃ y : ℤ_p, y * x = 1, from h31,
    have h33 : ∃ y : ℤ_p, y * x = 1, from h32,
    have h34 : ∃ y : ℤ_p, y * x = 1, from h33,
    have h35 : ∃ y : ℤ_p, y * x = 1, from h34,
    have h36 : ∃ y : ℤ_p, y * x = 1, from h35,
    have h37 : ∃ y : ℤ_p, y * x = 1, from h36,
    have h38 : ∃ y : ℤ_p, y * x = 1, from h37,
    have h39 : ∃ y : ℤ_p, y * x = 1, from h38,
    have h40 : ∃ y : ℤ_p, y * x = 1, from h39,
    have h41 : ∃ y : ℤ_p, y * x = 1, from h40,
    have h42 : ∃ y : ℤ_p, y * x = 1, from h41,
    have h43 : ∃ y : ℤ_p, y * x = 1, from h42,
    have h44 : ∃ y : ℤ_p, y * x = 1, from h43,
    have h45 : ∃ y : ℤ_p, y * x = 1, from h44,
    have h46 : ∃ y : ℤ_p, y * x = 1, from h45,
    have h47 : ∃ y : ℤ_p, y * x = 1, from h46,
    have h48 : ∃ y : ℤ_p, y * x = 1, from h47,
    have h49 : ∃ y : ℤ_p, y * x = 1, from h48,
    have h50 : ∃ y : ℤ_p, y * x = 1, from h49,
    have h51 : ∃ y : ℤ_p, y * x = 1, from h50,
    have h52 : ∃ y : ℤ_p, y * x = 1, from h51,
    have h53 : ∃ y : ℤ_p, y * x = 1, from h52,
    have h54 : ∃ y : ℤ_p, y * x = 1, from h53,
    have h55 : ∃ y : ℤ_p, y * x = 1, from h54,
    have h56 : ∃ y : ℤ_p, y * x = 1, from h55,
    have h57 : ∃ y : ℤ_p, y * x = 1, from h56,
    have h58 : ∃ y : ℤ_p, y * x = 1, from h57,
    have h59 : ∃ y : ℤ_p, y * x = 1, from h58,
    have h60 : ∃ y : ℤ_p, y * x = 1, from h59,
    have h61 : ∃ y : ℤ_p, y * x = 1, from h60,
    have h62 : ∃ y : ℤ_p, y * x = 1, from h61,
    have h63 : ∃ y : ℤ_p, y * x = 1, from h62,
    have h64 : ∃ y : ℤ_p, y * x = 1, from h63,
    have h65 : ∃ y : ℤ_p, y * x = 1, from h64,
    have h66 : ∃ y : ℤ_p, y * x = 1, from h65,
    have h67 : ∃ y : ℤ_p, y * x = 1, from h66,
    have h68 : ∃ y : ℤ_p, y * x = 1, from h67,
    have h69 : ∃ y : ℤ_p, y * x = 1, from h68,
    have h70 : ∃ y : ℤ_p, y * x = 1, from h69,
    have h71 : ∃ y : ℤ_p, y * x = 1, from h70,
    have h72 : ∃ y : ℤ_p, y * x = 1, from h71,
    have h73 : ∃ y : ℤ_p, y * x = 1, from h72,
    have h74 : ∃ y : ℤ_p, y * x = 1, from h73,
    have h75 : ∃ y : ℤ_p, y * x = 1,
end --Needs more than 2000 tokens!

--OUTPUT 2
theorem p_adic_units (p : ℕ) (x : ℕ) (h : nat.coprime x p) : is_unit (p_adic_int.padic_int p x) :=
begin
  have h1 : ¬ is_unit (p_adic_int.padic_int p x), from
    assume h2 : is_unit (p_adic_int.padic_int p x),
    have h3 : p_adic_int.norm (p_adic_int.padic_int p x) = 1, from
      by {rw h2, exact p_adic_int.norm_one},
    have h4 : p_adic_int.norm (p_adic_int.padic_int p x) < 1, from
      by {rw h3, exact p_adic_int.norm_one_lt_one},
    have h5 : p ∣ x, from p_adic_int.norm_lt_iff.mp h4,
    have h6 : ¬ nat.coprime x p, from nat.coprime_dvd_left h5,
    show false, from h6 h,
  show is_unit (p_adic_int.padic_int p x), from h1,
end

--OUTPUT 3
theorem p_adic_units (p : ℕ) (x : ℕ) : p.prime → x.coprime p → x.units (p_adic_int p) :=
begin
  assume hp : p.prime,
  assume hc : x.coprime p,
  have h1 : ¬ (x.units (p_adic_int p)), from by {
    assume hu : x.units (p_adic_int p),
    have h2 : (p_adic_int p).norm x = 1, from by {
      rw ← (units.norm_eq_one hu),
    },
    have h3 : (p_adic_int p).norm x < 1, from by {
      rw ← (units.norm_eq_one hu),
      rw ← (units.norm_eq_one hu),
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,
      norm_cast,

end --Needs more than 2000 tokens!

--OUTPUT 4
theorem p_adic_units (p : ℕ) (h : prime p) (x : ℕ) (hx : nat.coprime x p) : (x : ℚ_[p]) ∈ units (ℚ_[p]) :=
begin
  let h1 := nat.coprime_iff_prime_not_dvd h hx,
  let h2 := (norm_eq_zero_iff_not_unit_of_prime_of_norm_lt_one h h1).symm,
  let h3 := h2.mp (norm_lt_one_of_prime_of_norm_le_one h h1),
  have h4 : ¬ (x : ℚ_[p]) ∈ units (ℚ_[p]), from h3,
  have h5 : (x : ℚ_[p]) ∈ units (ℚ_[p]), from h4.elim,
  exact h5,
end

--OUTPUT 5
theorem p_adic_units (p : ℕ) (x : ℕ) (hp : prime p) (hx : coprime x p) : is_unit (Zp.of_nat p x) :=
begin
  let p_nat : ℕ := p,
  have h1 : ∀ (x : ℕ), ¬(is_unit (Zp.of_nat p x)) → p ∣ x, from by {
    assume (x : ℕ),
    assume hnunit : ¬(is_unit (Zp.of_nat p x)),
    have h2 : (Zp.of_nat p x).norm < 1, from by {
      have h3 : (Zp.of_nat p x).norm ≠ 1, from by {
        apply hnunit,
        apply Zp.of_nat_is_unit,
      },
      have h4 : (Zp.of_nat p x).norm ≤ 1, from by {
        apply Zp.norm_le_one,
      },
      apply lt_of_le_of_ne h4 h3,
    },
    have h5 : (Zp.of_nat p x).norm = p⁻¹, from by {
      apply Zp.norm_of_nat,
    },
    have h6 : p⁻¹ < 1, from by {
      rw ← h5 at h2,
      exact h2,
    },
    have h7 : p⁻¹ < p⁰, from by {
      apply lt_of_lt_of_le h6 (nat.zero_le p),
    },
    have h8 : p⁻¹ < p, from by {
      apply nat.sub_lt_sub_right_iff_lt_add.mp h7,
    },
    have h9 : p⁻¹ < p, from by {
      apply nat.inv_lt_of_lt_of_ne hp.ne_zero,
    },
    have h10 : p⁻¹ ≤ p⁻¹, from by {
      apply nat.le_of_lt h9,
    },
    have h11 : p⁻¹ = p⁻¹, from by {
      apply eq_of_le_of_ge h10 h10,
    },
    have h12 : p⁻¹ = p⁻¹, from by {
      apply eq_of_le_of_ge h10 h10,
    },
    have h13 : p⁻¹ = p⁻¹, from by {
      apply eq_of_le_of_ge h10 h10,
    },
    have h14 : p⁻¹ = p⁻¹, from by {
      apply eq_of_le_of_ge h10 h10,
    },
    have h15 : p⁻¹ = p⁻¹, from by {
      apply eq_of_le_of_ge h10 h10,
    },
    have h16 : p⁻¹ = p⁻¹, from by {
      apply eq_of_le_of_ge h10 h10,
    },
    have h17 : p⁻¹ = p⁻¹, from by {
      apply eq_of_le_of_ge h10 h10,
    },
    have h18 : p⁻¹ = p⁻¹, from by {
      apply eq_of_le_of_ge h10 h10,
    },
    have h19 : p⁻¹ = p⁻¹, from by {
      apply eq_of_le_of_ge h10 h10,
    },
    have h20 : p⁻¹ = p⁻¹, from by {
      apply eq_of_le_of_ge h10 h10,
    },
    have h21 : p⁻¹ = p⁻¹, from by {
      apply eq_of_le_of_ge h10 h10,
    },
    have h22 : p⁻¹ = p⁻¹, from by {
      apply eq_of_le_of_ge h10 h10,
    },
    have h23 : p⁻¹ = p⁻¹, from by {
      apply eq_of_le_of_ge h10 h10,
    },
    have h24 : p⁻¹ = p⁻¹, from by {
      apply eq_of_le_of_ge h10 h10,
    },
    have h25 : p⁻¹ = p⁻¹, from by {
      apply eq_of_le_of_ge h10 h10,
    },
    have h26 : p⁻¹ = p⁻¹, from by {
      apply eq_of_le_of_ge h10 h10,
    },
    have h27 : p⁻¹ = p⁻¹, from by {
      apply eq_of_le_of_ge h10 h10,
    },
    have h28 : p⁻¹ = p⁻¹, from by {
      apply eq_of_le_of_ge h10 h10,
    },
    have h29 : p⁻¹ = p⁻¹, from by {
      apply eq_of_le_of_ge h10 h10,
    },
    have h30 : p⁻¹ = p⁻¹, from by {
      apply eq_of_le_of_ge h10 h10,
    },
    have h31 : p⁻¹ = p⁻¹, from by {
      apply eq_of_le_of_ge h10 h10,
    },
    have h32 : p⁻¹ = p⁻¹, from by {
      apply eq_of_le_of_ge h10 h10,
    },
    have h33 : p⁻¹ = p⁻¹, from by {
      apply eq_of_le_of_ge h10 h10,
    },
    have h34 : p⁻¹ = p⁻¹, from by {
      apply eq_of_le_of_ge h10 h10,
    },
    have h35 : p⁻¹ = p⁻¹, from by {
      apply eq_of_le_of_ge h10 h10,
    },
    have h36 : p⁻¹ = p⁻¹, from by {
      apply eq_of_le_of_ge h10 h10,
    },
    have h37 : p⁻¹ = p⁻¹, from by {
      apply eq_of_le_of_ge h10 h10,
    },
    have h38 : p⁻¹ = p⁻¹, from by {
      apply eq_of_le_of_ge h10 h10,
    },
    have h39 : p⁻¹ = p⁻¹, from by {
      apply eq_of_le_of_ge h10 h10,
    },
    have h40 : p⁻¹ = p⁻¹, from by {
      apply eq_of_le_of_ge h10 h10,
    },
    have h41 : p⁻¹ = p⁻¹, from by {
      apply eq_of_le_of_ge h10 h10,
    },
    have h42 : p⁻¹ = p⁻¹, from by {
      apply eq_of_le_of_ge h10 h10,
    },
    have h43 : p⁻¹ = p⁻¹, from by {
      apply eq_of_le_of_ge h10 h10,
    },
    have h44 : p⁻¹ = p⁻¹, from by {
      apply eq_of_le_of_ge h10 h10,
    },
    have h45 : p⁻¹ = p⁻¹, from by {
      apply eq_of_le_of_ge h10 h10,
    },
    have h46 : p⁻¹ = p⁻¹, from by {
      apply eq_of_le_of_ge h10 h10,
    },
    have h47 : p⁻
end --Needs more than 2000 tokens!

--OUTPUT 6
theorem p_adic_units (p : ℕ) (x : ℕ) (h : nat.coprime x p): (∃ y : ℤ, (x * y) % p = 1) :=
begin
  have h1 : (∀ y : ℤ, (x * y) % p = 1) → (∃ y : ℤ, (x * y) % p = 1), from
    by {assume h2 : (∀ y : ℤ, (x * y) % p = 1), use 1, exact h2 1},
  have h2 : (∃ y : ℤ, (x * y) % p = 1) → (∀ y : ℤ, (x * y) % p = 1), from
    by {assume h3 : (∃ y : ℤ, (x * y) % p = 1), exact exists_unique.unique h3 (exists_unique.exists h3)
    (exists_unique.unique h3 (exists_unique.exists h3) (exists_unique.unique h3 (exists_unique.exists h3) (exists_unique.unique h3 (exists_unique.exists h3) (exists_unique.unique h3 (exists_unique.exists h3) (exists_unique.unique h3 (exists_unique.exists h3) (exists_unique.unique h3 (exists_unique.exists h3) (exists_unique.unique h3 (exists_unique.exists h3) (exists_unique.unique h3 (exists_unique.exists h3) (exists_unique.unique h3 (exists_unique.exists h3) (exists_unique.unique h3 (exists_unique.exists h3) (exists_unique.unique h3 (exists_unique.exists h3) (exists_unique.unique h3 (exists_unique.exists h3) (exists_unique.unique h3 (exists_unique.exists h3) (exists_unique.unique h3 (exists_unique.exists h3) (exists_unique.unique h3 (exists_unique.exists h3) (exists_unique.unique h3 (exists_unique.exists h3) (exists_unique.unique h3 (exists_unique.exists h3) (exists_unique.unique h3 (exists_unique.exists h3) (exists_unique.unique h3 (exists_unique.exists h3) (exists_unique.unique h3 (exists_unique.exists h3) (exists_unique.unique h3 (exists_unique.exists h3) (exists_unique.unique h3 (exists_unique.exists h3) (exists_unique.unique h3 (exists_unique.exists h3) (exists_unique.unique h3 (exists_unique.exists h3) (exists_unique.unique h3 (exists_unique.exists h3) (exists_unique.unique h3 (exists_unique.exists h3) (exists_unique.unique h3 (exists_unique.exists h3) (exists_unique.unique h3 (exists_unique.exists h3) (exists_unique.unique h3 (exists_unique.exists h3) (exists_unique.unique h3 (exists_unique.exists h3) (exists_unique.unique h3 (exists_unique.exists h3) (exists_unique.unique h3 (exists_unique.exists h3) (exists_unique.unique h3 (exists_unique.exists h3) (exists_unique.unique h3 (exists_unique.exists h3) (exists_unique.unique h3 (exists_unique.exists h3) (exists_unique.unique h3 (exists_unique.exists h3) (exists_unique.unique h3 (exists_unique.exists h3) (exists_unique.unique h3 (exists_unique.exists h3) (exists_unique.unique h3 (exists_unique.exists h3) (exists_unique.unique h3 (exists_unique.exists h3) (exists_unique.unique h3 (exists_unique.exists h3) (exists_unique.unique h3 (exists_unique.exists h3) (exists_unique.unique h3 (exists_unique.exists h3) (exists_unique.unique h3 (exists_unique.exists h3) (exists_unique.unique h3 (exists_unique.exists h3) (exists_unique.unique h3 (exists_unique.exists h3) (exists_unique.unique h3 (exists_unique.exists h3) (exists_unique.unique h3 (exists_unique.exists h3) (exists_unique.unique h3 (exists_unique.exists h3) (exists_unique.unique h3 (exists_unique.exists h3) (exists_unique.unique h3 (exists_unique.exists h3) (exists_unique.unique h3 (exists_unique.exists h3) (exists_unique.unique h3 (exists_unique.exists h3) (exists_unique.unique h3 (exists_unique.exists h3) (exists_unique.unique h3 (exists_unique.exists h3) (exists_unique.unique h3 (exists_unique.exists h3) (exists_unique.unique h3 (exists_unique.exists h3) (exists_unique.unique h3 (exists_unique.exists h3) (exists_unique.unique h3 (exists_unique.exists h3) (exists_unique.unique h3 (exists_unique.exists h3) (exists_unique.unique h3 (exists_unique.exists h3) (exists_unique.unique h3 (exists_unique.exists h3) (exists_unique.unique h3 (exists_unique.exists h3) (exists_unique.unique h3 (exists_unique.exists h3) (exists_unique.unique h3 (exists_unique.exists h3) (exists_unique.unique h3 (exists_unique.exists h3) (exists_unique.unique h3 (exists_unique.exists h3) (exists_unique.unique h3 (exists_unique.exists h3) (exists_unique.unique h3 (exists_unique.exists h3) (exists_unique.unique h3 (exists_unique.exists h3) (exists_unique.unique h3 (exists_unique.exists h3) (exists_unique.unique h3 (exists_unique.exists h3) (exists_unique.unique h3 (exists_unique.exists h3) (exists_unique.unique h3 (exists_unique.exists h3) (exists_unique.unique h3 (exists_unique.exists h3) (exists_unique.unique h3 (exists_unique.exists h3) (exists_unique.unique h3 (exists_unique.exists h3) (exists_unique.unique h3 (exists_unique.exists h3) (exists_unique.unique h3 (exists_unique.exists h3) (exists_unique.unique h3 (exists_unique.exists h3) (exists_unique.unique h3 (exists_unique.exists h3) (exists_unique.unique h3 (exists_unique.exists h3) (exists_unique.unique h3 (exists_unique.exists h3) (exists_unique.unique h3 (exists_unique.exists h3) (exists_unique.unique h3 (exists_unique.exists h3) (exists_unique.unique h3 (exists_unique.exists h3) (exists_unique.unique h3 (exists_unique.exists h3) (exists_unique.unique h3 (exists_unique.exists h3) (exists_unique.unique h3 (ex
end --Needs more than 2000 tokens!

/- FEW SHOT PROMPTS TO CODEX(START)
/--`theorem`
Power Set is Closed under Intersection
Let $S$ be a set.

Let $\powerset S$ be the power set of $S$.

Then:
:$\forall A, B \in \powerset S: A \cap B \in \powerset S$
`proof`
Let $A, B \in \powerset S$.

Then by the definition of power set, $A \subseteq S$ and $B \subseteq S$.

From Intersection is Subset we have that $A \cap B \subseteq A$.

It follows from Subset Relation is Transitive that $A \cap B \subseteq S$.

Thus $A \cap B \in \powerset S$ and closure is proved.
{{qed}}
-/
theorem power_set_intersection_closed {α : Type*} (S : set α) : ∀ A B ∈ 𝒫 S, (A ∩ B) ∈ 𝒫 S :=
begin
  assume (A : set α) (hA : A ∈ 𝒫 S) (B : set α) (hB : B ∈ 𝒫 S),
  have h1 : (A ⊆ S) ∧ (B ⊆ S), from by {split,apply set.subset_of_mem_powerset,exact hA,apply set.subset_of_mem_powerset,exact hB},
  have h2 : (A ∩ B) ⊆ A, from by apply set.inter_subset_left,
  have h3 : (A ∩ B) ⊆ S, from by {apply set.subset.trans h2 h1.left},
  show (A ∩ B) ∈  𝒫 S, from by {apply set.mem_powerset h3},
end

/--`theorem`
Square of Sum
 :$\forall x, y \in \R: \paren {x + y}^2 = x^2 + 2 x y + y^2$
`proof`
Follows from the distribution of multiplication over addition:

{{begin-eqn}}
{{eqn | l = \left({x + y}\right)^2
      | r = \left({x + y}\right) \cdot \left({x + y}\right)
}}
{{eqn | r = x \cdot \left({x + y}\right) + y \cdot \left({x + y}\right)
      | c = Real Multiplication Distributes over Addition
}}
{{eqn | r = x \cdot x + x \cdot y + y \cdot x + y \cdot y
      | c = Real Multiplication Distributes over Addition
}}
{{eqn | r = x^2 + 2xy + y^2
      | c =
}}
{{end-eqn}}
{{qed}}
-/
theorem square_of_sum (x y : ℝ) : (x + y)^2 = (x^2 + 2*x*y + y^2) :=
begin
  calc (x + y)^2 = (x+y)*(x+y) : by rw sq
  ... = x*(x+y) + y*(x+y) : by rw add_mul
  ... = x*x + x*y + y*x + y*y : by {rw [mul_comm x (x+y),mul_comm y (x+y)], rw [add_mul,add_mul], ring}
  ... = x^2 + 2*x*y + y^2 : by {repeat {rw ← sq}, rw mul_comm y x, ring}
end

/--`theorem`
Identity of Group is Unique
Let $\struct {G, \circ}$ be a group. Then there is a unique identity element $e \in G$.
`proof`
From Group has Latin Square Property, there exists a unique $x \in G$ such that:
:$a x = b$

and there exists a unique $y \in G$ such that:
:$y a = b$

Setting $b = a$, this becomes:

There exists a unique $x \in G$ such that:
:$a x = a$

and there exists a unique $y \in G$ such that:
:$y a = a$

These $x$ and $y$ are both $e$, by definition of identity element.
{{qed}}
-/
theorem group_identity_unique {G : Type*} [group G] : ∃! e : G, ∀ a : G, e * a = a ∧ a * e = a :=
begin
  have h1 : ∀ a b : G, ∃! x : G, a * x = b, from by {
    assume a b : G, use a⁻¹ * b, obviously, },
  have h2 : ∀ a b : G, ∃! y : G, y * a = b, from by {
    assume a b : G, use b * a⁻¹, obviously, },

  have h3 : ∀ a : G, ∃! x : G, a * x = a, from
    assume a : G, h1 a a,
  have h4 : ∀ a : G, ∃! y : G, y * a = a, from
    assume a : G, h2 a a,

  have h5 : ∀ a : G, classical.some (h3 a).exists = (1 : G), from assume a :G,
    exists_unique.unique (h3 a) (classical.some_spec (exists_unique.exists (h3 a)))
    (mul_one a),
  have h6 : ∀ a : G, classical.some (h4 a).exists = (1 : G), from assume a : G,
    exists_unique.unique (h4 a) (classical.some_spec (exists_unique.exists (h4 a))) (one_mul a),

  show ∃! e : G, ∀ a : G, e * a = a ∧ a * e = a, from by {
    use (1 : G),
    have h7 : ∀ e : G, (∀ a : G, e * a = a ∧ a * e = a) → e = 1, from by {
      assume (e : G) (hident : ∀ a : G, e * a = a ∧ a * e = a),
      have h8 : ∀ a : G, e = classical.some (h3 a).exists, from assume (a : G),
        exists_unique.unique (h3 a) (hident a).right
        (classical.some_spec (exists_unique.exists (h3 a))),
      have h9 : ∀ a : G, e = classical.some (h4 a).exists, from assume (a : G),
        exists_unique.unique (h4 a) (hident a).left
        (classical.some_spec (exists_unique.exists (h4 a))),
      show e = (1 : G), from eq.trans (h9 e) (h6 _),
    },
    exact ⟨by obviously, h7⟩,
  }
end

/--`theorem`
p-adic units
Given a prime number $p$ and a natural number $x$, if $x$ is coprime to $p$, then $x$ is a unit in the $p$-adic integers.
`proof`
Let us prove the contrapositive, that is, is $x$ is not a unit of $\mathbb{Z}_p$, then $x$ is not coprime to $p$.
We know that any element of $\mathbb{Z}_p$ is a unit if and only if it has norm 1, thus $\Vert x \Vert \neq 1$. Also, since every element of $\mathbb{Z}_p$ must have norm less than or equal to 1, we conclude that $\Vert x \Vert < 1$.
But this must imply that $p | x$.
This completes our proof.

QED
-/
theorem
FEW SHOT PROMPTS TO CODEX(END)-/