/-
Copyright (c) 2021 Adam Topaz. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Adam Topaz
-/
import topology.category.Profinite
import topology.locally_constant.basic
import topology.discrete_quotient

/-!
# Cofiltered limits of profinite sets.

This file contains some theorems about cofiltered limits of profinite sets.

## Main Results

- `exists_clopen_of_cofiltered` shows that any clopen set in a cofiltered limit of profinite
  sets is the pullback of a clopen set from one of the factors in the limit.
- `exists_locally_constant` shows that any locally constant function from a cofiltered limit
  of profinite sets factors through one of the components.
-/

namespace Profinite

open_locale classical
open category_theory
open category_theory.limits

universe u
variables {J : Type u} [small_category J] [is_cofiltered J]
  {F : J ⥤ Profinite.{u}} (C : cone F) (hC : is_limit C)

include hC

/--
If `X` is a cofiltered limit of profinite sets, then any clopen subset of `X` arises from
a clopen set in one of the terms in the limit.
-/
theorem exists_clopen_of_cofiltered {U : set C.X} (hU : is_clopen U) :
  ∃ (j : J) (V : set (F.obj j)) (hV : is_clopen V), U = C.π.app j ⁻¹' V :=
begin
  -- First, we have the topological basis of the cofiltered limit obtained by pulling back
  -- clopen sets from the factors in the limit. By continuity, all such sets are again clopen.
  have hB := Top.is_topological_basis_cofiltered_limit.{u}
    (F ⋙ Profinite.to_Top)
    (Profinite.to_Top.map_cone C)
    (is_limit_of_preserves _ hC)
    (λ j, {W | is_clopen W})
    _ (λ i, is_clopen_univ) (λ i U1 U2 hU1 hU2, hU1.inter hU2) _,
  rotate,
  { intros i,
    change topological_space.is_topological_basis
      {W : set (F.obj i) | is_clopen W},
    apply is_topological_basis_clopen },
  { rintros i j f V (hV : is_clopen _),
    refine ⟨hV.1.preimage _, hV.2.preimage _⟩;
    continuity },
  -- Using this, since `U` is open, we can write `U` as a union of clopen sets all of which
  -- are preimages of clopens from the factors in the limit.
  obtain ⟨S,hS,h⟩ := hB.open_eq_sUnion hU.1,
  clear hB,
  let j : S → J := λ s, (hS s.2).some,
  let V : Π (s : S), set (F.obj (j s)) := λ s, (hS s.2).some_spec.some,
  have hV : ∀ (s : S), is_clopen (V s) ∧ s.1 = C.π.app (j s) ⁻¹' (V s) :=
    λ s, (hS s.2).some_spec.some_spec,
  -- Since `U` is also closed, hence compact, it is covered by finitely many of the
  -- clopens constructed in the previous step.
  have := hU.2.is_compact.elim_finite_subcover (λ s : S, C.π.app (j s) ⁻¹' (V s)) _ _,
  rotate,
  { intros s,
    refine (hV s).1.1.preimage _,
    continuity },
  { dsimp only,
    rw h,
    rintro x ⟨T,hT,hx⟩,
    refine ⟨_,⟨⟨T,hT⟩,rfl⟩,_⟩,
    dsimp only,
    rwa ← (hV ⟨T,hT⟩).2 },
  -- We thus obtain a finite set `G : finset J` and a clopen set of `F.obj j` for each
  -- `j ∈ G` such that `U` is the union of the preimages of these clopen sets.
  obtain ⟨G,hG⟩ := this,
  -- Since `J` is cofiltered, we can find a single `j0` dominating all the `j ∈ G`.
  -- Pulling back all of the sets from the previous step to `F.obj j0` and taking a union,
  -- we obtain a clopen set in `F.obj j0` which works.
  obtain ⟨j0,hj0⟩ := is_cofiltered.inf_objs_exists (G.image j),
  let f : Π (s : S) (hs : s ∈ G), j0 ⟶ j s :=
    λ s hs, (hj0 (finset.mem_image.mpr ⟨s,hs,rfl⟩)).some,
  let W : S → set (F.obj j0) := λ s,
    if hs : s ∈ G then F.map (f s hs) ⁻¹' (V s) else set.univ,
  -- Conclude, using the `j0` and the clopen set of `F.obj j0` obtained above.
  refine ⟨j0, ⋃ (s : S) (hs : s ∈ G), W s, _, _⟩,
  { apply is_clopen_bUnion,
    intros s hs,
    dsimp only [W],
    rw dif_pos hs,
    refine ⟨(hV s).1.1.preimage _, (hV s).1.2.preimage _⟩;
    continuity },
  { ext x,
    split,
    { intro hx,
      simp_rw [set.preimage_Union, set.mem_Union],
      obtain ⟨_, ⟨s,rfl⟩, _, ⟨hs, rfl⟩, hh⟩ := hG hx,
      refine ⟨s, hs, _⟩,
      dsimp only [W] at hh ⊢,
      rwa [dif_pos hs, ← set.preimage_comp, ← Profinite.coe_comp, C.w] },
    { intro hx,
      simp_rw [set.preimage_Union, set.mem_Union] at hx,
      obtain ⟨s,hs,hx⟩ := hx,
      rw h,
      refine ⟨s.1,s.2,_⟩,
      rw (hV s).2,
      dsimp only [W] at hx,
      rwa [dif_pos hs, ← set.preimage_comp, ← Profinite.coe_comp, C.w] at hx } }
end

lemma exists_locally_constant_fin_two (f : locally_constant C.X (fin 2)) :
  ∃ (j : J) (g : locally_constant (F.obj j) (fin 2)), f = g.comap (C.π.app _) :=
begin
  let U := f ⁻¹' {0},
  have hU : is_clopen U := f.is_locally_constant.is_clopen_fiber _,
  obtain ⟨j,V,hV,h⟩ := exists_clopen_of_cofiltered C hC hU,
  use [j, locally_constant.of_clopen hV],
  apply locally_constant.locally_constant_eq_of_fiber_zero_eq,
  rw locally_constant.coe_comap _ _ (C.π.app j).continuous,
  conv_rhs { rw set.preimage_comp },
  rw [locally_constant.of_clopen_fiber_zero hV, ← h],
end

theorem exists_locally_constant_fintype_aux {α : Type*} [fintype α] (f : locally_constant C.X α) :
  ∃ (j : J) (g : locally_constant (F.obj j) (α → fin 2)),
    f.map (λ a b, if a = b then (0 : fin 2) else 1) = g.comap (C.π.app _) :=
begin
  let ι : α → α → fin 2 := λ x y, if x = y then 0 else 1,
  let ff := (f.map ι).flip,
  have hff := λ (a : α), exists_locally_constant_fin_two _ hC (ff a),
  choose j g h using hff,
  let G : finset J := finset.univ.image j,
  obtain ⟨j0,hj0⟩ := is_cofiltered.inf_objs_exists G,
  have hj : ∀ a, j a ∈ G,
  { intros a,
    simp [G] },
  let fs : Π (a : α), j0 ⟶ j a := λ a, (hj0 (hj a)).some,
  let gg : α → locally_constant (F.obj j0) (fin 2) := λ a, (g a).comap (F.map (fs _)),
  let ggg := locally_constant.unflip gg,
  refine ⟨j0, ggg, _⟩,
  have : f.map ι = locally_constant.unflip (f.map ι).flip, by simp,
  rw this, clear this,
  have : locally_constant.comap (C.π.app j0) ggg =
    locally_constant.unflip (locally_constant.comap (C.π.app j0) ggg).flip, by simp,
  rw this, clear this,
  congr' 1,
  ext1 a,
  change ff a = _,
  rw h,
  dsimp [ggg, gg],
  ext1,
  repeat
  { rw locally_constant.coe_comap,
    dsimp [locally_constant.flip, locally_constant.unflip] },
  { congr' 1,
    change _ = ((C.π.app j0) ≫ (F.map (fs a))) x,
    rw C.w },
  all_goals { continuity },
end

theorem exists_locally_constant_fintype_nonempty {α : Type*} [fintype α] [nonempty α]
  (f : locally_constant C.X α) :
  ∃ (j : J) (g : locally_constant (F.obj j) α), f = g.comap (C.π.app _) :=
begin
  inhabit α,
  obtain ⟨j,gg,h⟩ := exists_locally_constant_fintype_aux _ hC f,
  let ι : α → α → fin 2 := λ a b, if a = b then 0 else 1,
  let σ : (α → fin 2) → α := λ f, if h : ∃ (a : α), ι a = f then h.some else arbitrary _,
  refine ⟨j, gg.map σ, _⟩,
  ext,
  rw locally_constant.coe_comap _ _ (C.π.app j).continuous,
  dsimp [σ],
  have h1 : ι (f x) = gg (C.π.app j x),
  { change f.map (λ a b, if a = b then (0 : fin 2) else 1) x = _,
    rw [h, locally_constant.coe_comap _ _ (C.π.app j).continuous] },
  have h2 : ∃ a : α, ι a = gg (C.π.app j x) := ⟨f x, h1⟩,
  rw dif_pos h2,
  apply_fun ι,
  { rw h2.some_spec,
    exact h1 },
  { intros a b hh,
    apply_fun (λ e, e a) at hh,
    dsimp [ι] at hh,
    rw if_pos rfl at hh,
    split_ifs at hh with hh1 hh1,
    { exact hh1.symm },
    { exact false.elim (bot_ne_top hh) } }
end

/-- Any locally constant function from a cofiltered limit of profinite sets factors through
one of the components. -/
theorem exists_locally_constant {α : Type*} (f : locally_constant C.X α) :
  ∃ (j : J) (g : locally_constant (F.obj j) α), f = g.comap (C.π.app _) :=
begin
  let S := f.discrete_quotient,
  let ff : S → α := f.lift,
  casesI is_empty_or_nonempty S,
  { suffices : ∃ j, is_empty (F.obj j),
    { refine this.imp (λ j hj, _),
      refine ⟨⟨hj.elim, λ A, _⟩, _⟩,
      { convert is_open_empty,
        exact @set.eq_empty_of_is_empty _ hj _ },
      { ext x,
        exact hj.elim' (C.π.app j x) } },
    simp only [← not_nonempty_iff, ← not_forall],
    intros h,
    haveI : ∀ j : J, nonempty ((F ⋙ Profinite.to_Top).obj j) := h,
    haveI : ∀ j : J, t2_space ((F ⋙ Profinite.to_Top).obj j) := λ j,
      (infer_instance : t2_space (F.obj j)),
    haveI : ∀ j : J, compact_space ((F ⋙ Profinite.to_Top).obj j) := λ j,
      (infer_instance : compact_space (F.obj j)),
    have cond := Top.nonempty_limit_cone_of_compact_t2_cofiltered_system
      (F ⋙ Profinite.to_Top),
    suffices : nonempty C.X, from is_empty.false (S.proj this.some),
    let D := Profinite.to_Top.map_cone C,
    have hD : is_limit D := is_limit_of_preserves Profinite.to_Top hC,
    have CD := (hD.cone_point_unique_up_to_iso (Top.limit_cone_is_limit.{u} _)).inv,
    exact cond.map CD },
  { let f' : locally_constant C.X S := ⟨S.proj, S.proj_is_locally_constant⟩,
    obtain ⟨j, g', hj⟩ := exists_locally_constant_fintype_nonempty _ hC f',
    refine ⟨j, ⟨ff ∘ g', g'.is_locally_constant.comp _⟩,_⟩,
    ext1 t,
    apply_fun (λ e, e t) at hj,
    rw locally_constant.coe_comap _ _ (C.π.app j).continuous at hj ⊢,
    dsimp at hj ⊢,
    rw ← hj,
    refl },
end

end Profinite


import GroundZero.Proto

namespace GroundZero.Types
universe u v

theorem UIP {A : Type u} {a b : A} (p q : a = b) : p = q :=
begin rfl end

section
  variable (A : Sort u)

  instance : @Reflexive A Eq  := ⟨@Eq.refl A⟩
  instance : @Symmetric A Eq  := ⟨@Eq.symm A⟩
  instance : @Transitive A Eq := ⟨@Eq.trans A⟩
end

inductive Id {A : Type u} : A → A → Type u
| refl {a : A} : Id a a

infix:50 (priority := high) " = " => Id

/- fails!
hott theorem Id.UIP {A : Type u} {a b : A} (p q : a = b) : p = q :=
begin cases p; cases q; apply Id.refl end
-/

@[match_pattern] abbrev idp {A : Type u} (a : A) : a = a := Id.refl

attribute [eliminator] Id.casesOn

hott def J₁ {A : Type u} {a : A} (B : Π (b : A), a = b → Type v)
  (Bidp : B a (idp a)) {b : A} (p : a = b) : B b p :=
@Id.casesOn A a B b p Bidp

hott def J₂ {A : Type u} {b : A} (B : Π (a : A), a = b → Type v)
  (Bidp : B b (idp b)) {a : A} (p : a = b) : B a p :=
by { induction p; apply Bidp }

namespace Id
  hott def symm {A : Type u} {a b : A} (p : a = b) : b = a :=
  begin induction p; apply idp end

  hott def trans {A : Type u} {a b c : A}
    (p : a = b) (q : b = c) : a = c :=
  begin induction p; apply q end

  instance (A : Type u) : Reflexive  (@Id A) := ⟨@Id.refl A⟩
  instance (A : Type u) : Symmetric  (@Id A) := ⟨@symm A⟩
  instance (A : Type u) : Transitive (@Id A) := ⟨@trans A⟩

  hott def inv {A : Type u} {a b : A} (p : a = b) : b = a := symm p

  infixl:60 " ⬝ " => trans
  postfix:max "⁻¹" => symm

  hott def JSymm {A : Type} {a b : A} (B : Π x, b = x → Type v)
    (p : a = b) (w : B b (idp b)) : J₁ B w p⁻¹ = J₂ (λ x q, B x q⁻¹) w p :=
  begin induction p; reflexivity end

  hott def compInv {A : Type u} {a b : A} (p : a = b) : p ⬝ p⁻¹ = idp a :=
  begin induction p; reflexivity end

  hott def invComp {A : Type u} {a b : A} (p : a = b) : p⁻¹ ⬝ p = idp b :=
  begin induction p; reflexivity end

  hott def reflLeft {A : Type u} {a b : A} (p : a = b) : idp a ⬝ p = p :=
  begin induction p; reflexivity end

  hott def reflRight {A : Type u} {a b : A} (p : a = b) : p ⬝ idp b = p :=
  begin induction p; reflexivity end

  hott def reflTwice {A : Type u} {a b : A} (p : a = b) : idp a ⬝ p ⬝ idp b = p :=
  begin induction p; reflexivity end

  hott def explodeInv {A : Type u} {a b c : A} (p : a = b) (q : b = c) : (p ⬝ q)⁻¹ = q⁻¹ ⬝ p⁻¹ :=
  begin induction p; induction q; reflexivity end

  hott def invInv {A : Type u} {a b : A} (p : a = b) : (p⁻¹)⁻¹ = p :=
  begin induction p; reflexivity end

  hott def invEqIfEqInv {A : Type u} {a b : A} {p : a = b} {q : b = a} : p⁻¹ = q → p = q⁻¹ :=
  begin induction p; intro η; induction η; reflexivity end

  hott def eqEnvIfInvEq {A : Type u} {a b : A} {p : a = b} {q : b = a} : p = q⁻¹ → p⁻¹ = q :=
  λ η => @invEqIfEqInv A b a p⁻¹ q⁻¹ (invInv p ⬝ η) ⬝ invInv q

  hott def assoc {A : Type u} {a b c d : A}
    (p : a = b) (q : b = c) (r : c = d) :
    p ⬝ (q ⬝ r) = (p ⬝ q) ⬝ r :=
  begin induction p; reflexivity end

  hott def mpr {A B : Type u} (p : A = B) : B → A :=
  begin induction p; intro x; exact x end

  hott def map {A : Type u} {B : Type v} {a b : A}
    (f : A → B) (p : a = b) : f a = f b :=
  begin induction p; reflexivity end

  hott def cancelCompInv {A : Type u} {a b c : A} (p : a = b) (q : b = c) : (p ⬝ q) ⬝ q⁻¹ = p :=
  (assoc p q q⁻¹)⁻¹ ⬝ map (trans p) (compInv q) ⬝ (reflRight p)

  hott def cancelInvComp {A : Type u} {a b c : A} (p : a = b) (q : c = b) : (p ⬝ q⁻¹) ⬝ q = p :=
  (assoc p q⁻¹ q)⁻¹ ⬝ map (trans p) (invComp q) ⬝ (reflRight p)

  hott def mapInv {A : Type u} {B : Type v} {a b : A}
    (f : A → B) (p : a = b) : map f p⁻¹ = (map f p)⁻¹ :=
  begin induction p; reflexivity end

  hott def transCancelLeft {A : Type u} {a b c : A}
    (r : a = b) (p q : b = c) : r ⬝ p = r ⬝ q → p = q :=
  begin intro μ; induction r; exact μ end

  hott def transCancelRight {A : Type u} {a b c : A}
    (r : b = c) (p q : a = b) : p ⬝ r = q ⬝ r → p = q :=
  begin
    intro μ; induction r; transitivity; { symmetry; apply reflRight };
    symmetry; transitivity; { symmetry; apply reflRight }; exact μ⁻¹
  end

  hott def idConjIfComm {A : Type u} {a : A}
    (p q : a = a) : p ⬝ q = q ⬝ p → q⁻¹ ⬝ p ⬝ q = p :=
  begin
    intro r; apply transCancelLeft q;
    transitivity; apply assoc;
    transitivity; apply map (· ⬝ q);
    transitivity; apply assoc; apply map (· ⬝ p);
    apply compInv; exact r
  end

  hott def compReflIfEq {A : Type u} {a b : A} (p q : a = b) : p = q → p⁻¹ ⬝ q = idp b :=
  begin intro A; induction A; apply invComp end

  section
    variable {A : Type u} {B : Type v} {a b : A} (f : A → B) (p : a = b)

    def cong := map f p
    def ap   := map f p
  end

  hott def ap₂ {A : Type u} {B : Type v} {a b : A} {p q : a = b}
    (f : A → B) (r : p = q) : ap f p = ap f q :=
  ap (ap f) r

  class dotted (space : Type u) :=
  (point : space)

  structure pointed :=
  (space : Type u) (point : space)

  notation "Type⁎" => pointed

  def pointed.map (A B : Type⁎) :=
  Σ (f : A.space → B.space), f A.point = B.point
  notation "Map⁎" => pointed.map

  namespace pointed.map
    variable {A B : Type⁎} (φ : Map⁎ A B)

    def ap : A.space → B.space := φ.fst
    def id : φ.ap A.point = B.point := φ.snd
  end pointed.map

  def loopSpace (X : Type⁎) : Type⁎ :=
  ⟨X.point = X.point, Id.refl⟩

  hott def iteratedLoopSpace : Type⁎ → ℕ → Type⁎
  | X,   0   => X
  | X, n + 1 => iteratedLoopSpace (loopSpace X) n

  def loopPointedSpace (A : Type u) [dotted A] :=
  iteratedLoopSpace ⟨A, dotted.point⟩

  macro:max "Ω" n:superscript "(" τ:term ")" : term => do
    `((loopPointedSpace $τ $(← Meta.Notation.parseSuperscript n)).space)

  macro:max "Θ" n:superscript "(" τ:term ")" : term => do
    `((iteratedLoopSpace $τ $(← Meta.Notation.parseSuperscript n)).point)
end Id

def Not (A : Type u) : Type u := A → (𝟎 : Type)
def Neq {A : Type u} (a b : A) := Not (Id a b)

namespace Not
  prefix:90 (priority := high) "¬" => Not
  infix:50 (priority := high) " ≠ " => Neq

  def absurd {A : Type u} {B : Type v} (h : A) (g : ¬A) : B :=
  nomatch (g h)

  def univ : (𝟎 : Type u) → (𝟎 : Type v) :=
  λ e, nomatch e
end Not

namespace whiskering
  variable {A : Type u} {a b c : A}

  hott def rightWhs {p q : a = b} (ν : p = q) (r : b = c) : p ⬝ r = q ⬝ r :=
  begin induction r; apply (Id.reflRight p) ⬝ ν ⬝ (Id.reflRight q)⁻¹ end

  infix:60 " ⬝ᵣ " => rightWhs

  hott def leftWhs {r s : b = c} (q : a = b) (κ : r = s) : q ⬝ r = q ⬝ s :=
  begin induction q; exact (Id.reflLeft r) ⬝ κ ⬝ (Id.reflLeft s)⁻¹ end

  infix:60 " ⬝ₗ " => leftWhs

  variable {p q : a = b} {r s : b = c}

  hott def horizontalComp₁ (ν : p = q) (κ : r = s) := (ν ⬝ᵣ r) ⬝ (q ⬝ₗ κ)
  infix:65 " ⋆ " => horizontalComp₁

  hott def horizontalComp₂ (ν : p = q) (κ : r = s) := (p ⬝ₗ κ) ⬝ (ν ⬝ᵣ s)
  infix:65 " ⋆′ " => horizontalComp₂

  hott lemma compUniq (ν : p = q) (κ : r = s) : ν ⋆ κ = ν ⋆′ κ :=
  begin induction p; induction r; induction ν; induction κ; reflexivity end

  hott lemma loop₁ {A : Type u} {a : A} {ν κ : idp a = idp a} : ν ⬝ κ = ν ⋆ κ :=
  begin
    apply Id.symm; transitivity;
    { apply Id.map (· ⬝ (Id.refl ⬝ κ ⬝ Id.refl));
      apply Id.reflTwice };
    apply Id.map (ν ⬝ ·); apply Id.reflTwice
  end

  hott lemma loop₂ {A : Type u} {a : A} {ν κ : idp a = idp a} : ν ⋆′ κ = κ ⬝ ν :=
  begin
    transitivity;
    { apply Id.map (· ⬝ (Id.refl ⬝ ν ⬝ Id.refl));
      apply Id.reflTwice };
    apply Id.map (κ ⬝ ·); apply Id.reflTwice
  end

  hott theorem «Eckmann–Hilton argument» {A : Type u} {a : A}
    (ν κ : idp a = idp a) : ν ⬝ κ = κ ⬝ ν :=
  loop₁ ⬝ compUniq ν κ ⬝ loop₂
end whiskering

end GroundZero.Types