/-
Copyright (c) 2017 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro
-/
import data.multiset.dedup
import data.list.min_max

/-!
# The fold operation for a commutative associative operation over a multiset.

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

namespace multiset
variables {α β : Type*}

/-! ### fold -/
section fold
variables (op : α → α → α) [hc : is_commutative α op] [ha : is_associative α op]
local notation (name := op) a ` * ` b := op a b
include hc ha

/-- `fold op b s` folds a commutative associative operation `op` over
  the multiset `s`. -/
def fold : α → multiset α → α := foldr op (left_comm _ hc.comm ha.assoc)

theorem fold_eq_foldr (b : α) (s : multiset α) :
  fold op b s = foldr op (left_comm _ hc.comm ha.assoc) b s := rfl

@[simp] theorem coe_fold_r (b : α) (l : list α) : fold op b l = l.foldr op b := rfl

theorem coe_fold_l (b : α) (l : list α) : fold op b l = l.foldl op b :=
(coe_foldr_swap op _ b l).trans $ by simp [hc.comm]

theorem fold_eq_foldl (b : α) (s : multiset α) :
  fold op b s = foldl op (right_comm _ hc.comm ha.assoc) b s :=
quot.induction_on s $ λ l, coe_fold_l _ _ _

@[simp] theorem fold_zero (b : α) : (0 : multiset α).fold op b = b := rfl

@[simp] theorem fold_cons_left : ∀ (b a : α) (s : multiset α),
  (a ::ₘ s).fold op b = a * s.fold op b := foldr_cons _ _

theorem fold_cons_right (b a : α) (s : multiset α) : (a ::ₘ s).fold op b = s.fold op b * a :=
by simp [hc.comm]

theorem fold_cons'_right (b a : α) (s : multiset α) : (a ::ₘ s).fold op b = s.fold op (b * a) :=
by rw [fold_eq_foldl, foldl_cons, ← fold_eq_foldl]

theorem fold_cons'_left (b a : α) (s : multiset α) : (a ::ₘ s).fold op b = s.fold op (a * b) :=
by rw [fold_cons'_right, hc.comm]

theorem fold_add (b₁ b₂ : α) (s₁ s₂ : multiset α) :
  (s₁ + s₂).fold op (b₁ * b₂) = s₁.fold op b₁ * s₂.fold op b₂ :=
multiset.induction_on s₂
  (by rw [add_zero, fold_zero, ← fold_cons'_right, ← fold_cons_right op])
  (by simp {contextual := tt}; cc)

theorem fold_bind {ι : Type*} (s : multiset ι) (t : ι → multiset α) (b : ι → α) (b₀ : α) :
  (s.bind t).fold op ((s.map b).fold op b₀) = (s.map (λ i, (t i).fold op (b i))).fold op b₀ :=
begin
  induction s using multiset.induction_on with a ha ih,
  { rw [zero_bind, map_zero, map_zero, fold_zero] },
  { rw [cons_bind, map_cons, map_cons, fold_cons_left, fold_cons_left, fold_add, ih] },
end

theorem fold_singleton (b a : α) : ({a} : multiset α).fold op b = a * b := foldr_singleton _ _ _ _

theorem fold_distrib {f g : β → α} (u₁ u₂ : α) (s : multiset β) :
  (s.map (λx, f x * g x)).fold op (u₁ * u₂) = (s.map f).fold op u₁ * (s.map g).fold op u₂ :=
multiset.induction_on s (by simp) (by simp {contextual := tt}; cc)

theorem fold_hom {op' : β → β → β} [is_commutative β op'] [is_associative β op']
  {m : α → β} (hm : ∀x y, m (op x y) = op' (m x) (m y)) (b : α) (s : multiset α) :
  (s.map m).fold op' (m b) = m (s.fold op b) :=
multiset.induction_on s (by simp) (by simp [hm] {contextual := tt})

theorem fold_union_inter [decidable_eq α] (s₁ s₂ : multiset α) (b₁ b₂ : α) :
  (s₁ ∪ s₂).fold op b₁ * (s₁ ∩ s₂).fold op b₂ = s₁.fold op b₁ * s₂.fold op b₂ :=
by rw [← fold_add op, union_add_inter, fold_add op]

@[simp] theorem fold_dedup_idem [decidable_eq α] [hi : is_idempotent α op] (s : multiset α)
  (b : α) :
  (dedup s).fold op b = s.fold op b :=
multiset.induction_on s (by simp) $ λ a s IH, begin
  by_cases a ∈ s; simp [IH, h],
  show fold op b s = op a (fold op b s),
  rw [← cons_erase h, fold_cons_left, ← ha.assoc, hi.idempotent],
end

end fold

section order

lemma max_le_of_forall_le {α : Type*} [canonically_linear_ordered_add_monoid α]
  (l : multiset α) (n : α) (h : ∀ (x ∈ l), x ≤ n) :
  l.fold max ⊥ ≤ n :=
begin
  induction l using quotient.induction_on,
  simpa using list.max_le_of_forall_le _ _ h
end

lemma max_nat_le_of_forall_le (l : multiset ℕ) (n : ℕ) (h : ∀ (x ∈ l), x ≤ n) :
  l.fold max 0 ≤ n :=
max_le_of_forall_le l n h

end order

open nat

theorem le_smul_dedup [decidable_eq α] (s : multiset α) :
  ∃ n : ℕ, s ≤ n • dedup s :=
⟨(s.map (λ a, count a s)).fold max 0, le_iff_count.2 $ λ a, begin
  rw count_nsmul, by_cases a ∈ s,
  { refine le_trans _ (nat.mul_le_mul_left _ $ count_pos.2 $ mem_dedup.2 h),
    have : count a s ≤ fold max 0 (map (λ a, count a s) (a ::ₘ erase s a));
    [simp [le_max_left], simpa [cons_erase h]] },
  { simp [count_eq_zero.2 h, nat.zero_le] }
end⟩

end multiset


/-
Copyright (c) 2017 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl, Mario Carneiro, Oliver Nash
-/
import data.finset.card

/-!
# Finsets in product types

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

This file defines finset constructions on the product type `α × β`. Beware not to confuse with the
`finset.prod` operation which computes the multiplicative product.

## Main declarations

* `finset.product`: Turns `s : finset α`, `t : finset β` into their product in `finset (α × β)`.
* `finset.diag`: For `s : finset α`, `s.diag` is the `finset (α × α)` of pairs `(a, a)` with
  `a ∈ s`.
* `finset.off_diag`: For `s : finset α`, `s.off_diag` is the `finset (α × α)` of pairs `(a, b)` with
  `a, b ∈ s` and `a ≠ b`.
-/

open multiset

variables {α β γ : Type*}

namespace finset

/-! ### prod -/
section prod
variables {s s' : finset α} {t t' : finset β} {a : α} {b : β}

/-- `product s t` is the set of pairs `(a, b)` such that `a ∈ s` and `b ∈ t`. -/
protected def product (s : finset α) (t : finset β) : finset (α × β) := ⟨_, s.nodup.product t.nodup⟩

/- This notation binds more strongly than (pre)images, unions and intersections. -/
infixr (name := finset.product) ` ×ˢ `:82 := finset.product

@[simp] lemma product_val : (s ×ˢ t).1 = s.1 ×ˢ t.1 := rfl

@[simp] lemma mem_product {p : α × β} : p ∈ s ×ˢ t ↔ p.1 ∈ s ∧ p.2 ∈ t := mem_product

lemma mk_mem_product (ha : a ∈ s) (hb : b ∈ t) : (a, b) ∈ s ×ˢ t := mem_product.2 ⟨ha, hb⟩

@[simp, norm_cast] lemma coe_product (s : finset α) (t : finset β) :
  (↑(s ×ˢ t) : set (α × β)) = s ×ˢ t :=
set.ext $ λ x, finset.mem_product

lemma subset_product_image_fst [decidable_eq α] : (s ×ˢ t).image prod.fst ⊆ s :=
λ i, by simp [mem_image] {contextual := tt}

lemma subset_product_image_snd [decidable_eq β] : (s ×ˢ t).image prod.snd ⊆ t :=
λ i, by simp [mem_image] {contextual := tt}

lemma product_image_fst [decidable_eq α] (ht : t.nonempty) : (s ×ˢ t).image prod.fst = s :=
by { ext i, simp [mem_image, ht.bex] }

lemma product_image_snd [decidable_eq β] (ht : s.nonempty) : (s ×ˢ t).image prod.snd = t :=
by { ext i, simp [mem_image, ht.bex] }

lemma subset_product [decidable_eq α] [decidable_eq β] {s : finset (α × β)} :
  s ⊆ s.image prod.fst ×ˢ s.image prod.snd :=
λ p hp, mem_product.2 ⟨mem_image_of_mem _ hp, mem_image_of_mem _ hp⟩

lemma product_subset_product (hs : s ⊆ s') (ht : t ⊆ t') : s ×ˢ t ⊆ s' ×ˢ t' :=
λ ⟨x,y⟩ h, mem_product.2 ⟨hs (mem_product.1 h).1, ht (mem_product.1 h).2⟩

lemma product_subset_product_left (hs : s ⊆ s') : s ×ˢ t ⊆ s' ×ˢ t :=
product_subset_product hs (subset.refl _)

lemma product_subset_product_right (ht : t ⊆ t') : s ×ˢ t ⊆ s ×ˢ t' :=
product_subset_product (subset.refl _) ht

lemma map_swap_product (s : finset α) (t : finset β) :
  (t ×ˢ s).map ⟨prod.swap, prod.swap_injective⟩ = s ×ˢ t :=
coe_injective $ by { push_cast, exact set.image_swap_prod _ _ }

@[simp] lemma image_swap_product [decidable_eq α] [decidable_eq β] (s : finset α) (t : finset β) :
  (t ×ˢ s).image prod.swap = s ×ˢ t :=
coe_injective $ by { push_cast, exact set.image_swap_prod _ _ }

lemma product_eq_bUnion [decidable_eq α] [decidable_eq β] (s : finset α) (t : finset β) :
  s ×ˢ t = s.bUnion (λa, t.image $ λb, (a, b)) :=
ext $ λ ⟨x, y⟩, by simp only [mem_product, mem_bUnion, mem_image, exists_prop, prod.mk.inj_iff,
  and.left_comm, exists_and_distrib_left, exists_eq_right, exists_eq_left]

lemma product_eq_bUnion_right [decidable_eq α] [decidable_eq β] (s : finset α) (t : finset β) :
  s ×ˢ t = t.bUnion (λ b, s.image $ λ a, (a, b)) :=
ext $ λ ⟨x, y⟩, by simp only [mem_product, mem_bUnion, mem_image, exists_prop, prod.mk.inj_iff,
  and.left_comm, exists_and_distrib_left, exists_eq_right, exists_eq_left]

/-- See also `finset.sup_product_left`. -/
@[simp] lemma product_bUnion [decidable_eq γ] (s : finset α) (t : finset β) (f : α × β → finset γ) :
  (s ×ˢ t).bUnion f = s.bUnion (λ a, t.bUnion (λ b, f (a, b))) :=
by { classical, simp_rw [product_eq_bUnion, bUnion_bUnion, image_bUnion] }

@[simp] lemma card_product (s : finset α) (t : finset β) : card (s ×ˢ t) = card s * card t :=
multiset.card_product _ _

lemma filter_product (p : α → Prop) (q : β → Prop) [decidable_pred p] [decidable_pred q] :
  (s ×ˢ t).filter (λ (x : α × β), p x.1 ∧ q x.2) = s.filter p ×ˢ t.filter q :=
by { ext ⟨a, b⟩, simp only [mem_filter, mem_product],
     exact and_and_and_comm (a ∈ s) (b ∈ t) (p a) (q b) }

lemma filter_product_left (p : α → Prop) [decidable_pred p] :
  (s ×ˢ t).filter (λ (x : α × β), p x.1) = s.filter p ×ˢ t :=
by simpa using filter_product p (λ _, true)

lemma filter_product_right (q : β → Prop) [decidable_pred q] :
  (s ×ˢ t).filter (λ (x : α × β), q x.2) = s ×ˢ t.filter q :=
by simpa using filter_product (λ _ : α, true) q

lemma filter_product_card (s : finset α) (t : finset β)
  (p : α → Prop) (q : β → Prop) [decidable_pred p] [decidable_pred q] :
  ((s ×ˢ t).filter (λ (x : α × β), p x.1 ↔ q x.2)).card =
  (s.filter p).card * (t.filter q).card + (s.filter (not ∘ p)).card * (t.filter (not ∘ q)).card :=
begin
  classical,
  rw [← card_product, ← card_product, ← filter_product, ← filter_product, ← card_union_eq],
  { apply congr_arg, ext ⟨a, b⟩, simp only [filter_union_right, mem_filter, mem_product],
    split; intros h; use h.1,
    simp only [function.comp_app, and_self, h.2, em (q b)],
    cases h.2; { try { simp at h_1 }, simp [h_1] } },
  { apply finset.disjoint_filter_filter',
    exact (disjoint_compl_right.inf_left _).inf_right _ }
end

lemma empty_product (t : finset β) : (∅ : finset α) ×ˢ t = ∅ := rfl

lemma product_empty (s : finset α) : s ×ˢ (∅ : finset β) = ∅ :=
eq_empty_of_forall_not_mem (λ x h, (finset.mem_product.1 h).2)

lemma nonempty.product (hs : s.nonempty) (ht : t.nonempty) : (s ×ˢ t).nonempty :=
let ⟨x, hx⟩ := hs, ⟨y, hy⟩ := ht in ⟨(x, y), mem_product.2 ⟨hx, hy⟩⟩

lemma nonempty.fst (h : (s ×ˢ t).nonempty) : s.nonempty :=
let ⟨xy, hxy⟩ := h in ⟨xy.1, (mem_product.1 hxy).1⟩

lemma nonempty.snd (h : (s ×ˢ t).nonempty) : t.nonempty :=
let ⟨xy, hxy⟩ := h in ⟨xy.2, (mem_product.1 hxy).2⟩

@[simp] lemma nonempty_product : (s ×ˢ t).nonempty ↔ s.nonempty ∧ t.nonempty :=
⟨λ h, ⟨h.fst, h.snd⟩, λ h, h.1.product h.2⟩

@[simp] lemma product_eq_empty {s : finset α} {t : finset β} : s ×ˢ t = ∅ ↔ s = ∅ ∨ t = ∅ :=
by rw [←not_nonempty_iff_eq_empty, nonempty_product, not_and_distrib, not_nonempty_iff_eq_empty,
  not_nonempty_iff_eq_empty]

@[simp] lemma singleton_product {a : α} :
  ({a} : finset α) ×ˢ t = t.map ⟨prod.mk a, prod.mk.inj_left _⟩ :=
by { ext ⟨x, y⟩, simp [and.left_comm, eq_comm] }

@[simp] lemma product_singleton {b : β} :
  s ×ˢ {b} = s.map ⟨λ i, (i, b), prod.mk.inj_right _⟩ :=
by { ext ⟨x, y⟩, simp [and.left_comm, eq_comm] }

lemma singleton_product_singleton {a : α} {b : β} :
  ({a} : finset α) ×ˢ ({b} : finset β) = {(a, b)} :=
by simp only [product_singleton, function.embedding.coe_fn_mk, map_singleton]

@[simp] lemma union_product [decidable_eq α] [decidable_eq β] :
  (s ∪ s') ×ˢ t = s ×ˢ t ∪ s' ×ˢ t :=
by { ext ⟨x, y⟩, simp only [or_and_distrib_right, mem_union, mem_product] }

@[simp] lemma product_union [decidable_eq α] [decidable_eq β] :
  s ×ˢ (t ∪ t') = s ×ˢ t ∪ s ×ˢ t' :=
by { ext ⟨x, y⟩, simp only [and_or_distrib_left, mem_union, mem_product] }

lemma inter_product [decidable_eq α] [decidable_eq β] :
  (s ∩ s') ×ˢ t = s ×ˢ t ∩ s' ×ˢ t :=
by { ext ⟨x, y⟩, simp only [←and_and_distrib_right, mem_inter, mem_product] }

lemma product_inter [decidable_eq α] [decidable_eq β] :
  s ×ˢ (t ∩ t') = s ×ˢ t ∩ s ×ˢ t' :=
by { ext ⟨x, y⟩, simp only [←and_and_distrib_left, mem_inter, mem_product] }

lemma product_inter_product [decidable_eq α] [decidable_eq β] :
  s ×ˢ t ∩ s' ×ˢ t' = (s ∩ s') ×ˢ (t ∩ t') :=
by { ext ⟨x, y⟩, simp only [and_assoc, and.left_comm, mem_inter, mem_product] }

lemma disjoint_product : disjoint (s ×ˢ t) (s' ×ˢ t') ↔ disjoint s s' ∨ disjoint t t' :=
by simp_rw [←disjoint_coe, coe_product, set.disjoint_prod]

@[simp] lemma disj_union_product (hs : disjoint s s') :
  s.disj_union s' hs ×ˢ t = (s ×ˢ t).disj_union (s' ×ˢ t)
    (disjoint_product.mpr $ or.inl hs) :=
eq_of_veq $ multiset.add_product _ _ _

@[simp] lemma product_disj_union (ht : disjoint t t') :
  s ×ˢ t.disj_union t' ht = (s ×ˢ t).disj_union (s ×ˢ t')
    (disjoint_product.mpr $ or.inr ht) :=
eq_of_veq $ multiset.product_add _ _ _

end prod

section diag
variables [decidable_eq α] (s t : finset α)

/-- Given a finite set `s`, the diagonal, `s.diag` is the set of pairs of the form `(a, a)` for
`a ∈ s`. -/
def diag := (s ×ˢ s).filter (λ a : α × α, a.fst = a.snd)

/-- Given a finite set `s`, the off-diagonal, `s.off_diag` is the set of pairs `(a, b)` with `a ≠ b`
for `a, b ∈ s`. -/
def off_diag := (s ×ˢ s).filter (λ (a : α × α), a.fst ≠ a.snd)

variables {s} {x : α × α}

@[simp] lemma mem_diag : x ∈ s.diag ↔ x.1 ∈ s ∧ x.1 = x.2 :=
by { simp only [diag, mem_filter, mem_product], split; intros h;
     simp only [h, and_true, eq_self_iff_true, and_self], rw ←h.2, exact h.1 }

@[simp] lemma mem_off_diag : x ∈ s.off_diag ↔ x.1 ∈ s ∧ x.2 ∈ s ∧ x.1 ≠ x.2 :=
by { simp only [off_diag, mem_filter, mem_product], split; intros h;
     simp only [h, ne.def, not_false_iff, and_self] }

variables (s)

@[simp, norm_cast] lemma coe_off_diag : (s.off_diag : set (α × α)) = (s : set α).off_diag :=
set.ext $ λ _, mem_off_diag

@[simp] lemma diag_card : (diag s).card = s.card :=
begin
  suffices : diag s = s.image (λ a, (a, a)),
  { rw this, apply card_image_of_inj_on, exact λ x1 h1 x2 h2 h3, (prod.mk.inj h3).1 },
  ext ⟨a₁, a₂⟩, rw mem_diag, split; intros h; rw finset.mem_image at *,
  { use [a₁, h.1, prod.mk.inj_iff.mpr ⟨rfl, h.2⟩] },
  { rcases h with ⟨a, h1, h2⟩, have h := prod.mk.inj h2, rw [←h.1, ←h.2], use h1 },
end

@[simp] lemma off_diag_card : (off_diag s).card = s.card * s.card - s.card :=
begin
  suffices : (diag s).card + (off_diag s).card = s.card * s.card,
  { nth_rewrite 2 ← s.diag_card, simp only [diag_card] at *, rw tsub_eq_of_eq_add_rev, rw this },
  rw ← card_product,
  apply filter_card_add_filter_neg_card_eq_card,
end

@[mono] lemma diag_mono : monotone (diag : finset α → finset (α × α)) :=
λ s t h x hx, mem_diag.2 $ and.imp_left (@h _) $ mem_diag.1 hx

@[mono] lemma off_diag_mono : monotone (off_diag : finset α → finset (α × α)) :=
λ s t h x hx, mem_off_diag.2 $ and.imp (@h _) (and.imp_left $ @h _) $ mem_off_diag.1 hx

@[simp] lemma diag_empty : (∅ : finset α).diag = ∅ := rfl

@[simp] lemma off_diag_empty : (∅ : finset α).off_diag = ∅ := rfl

@[simp] lemma diag_union_off_diag : s.diag ∪ s.off_diag = s ×ˢ s :=
filter_union_filter_neg_eq _ _

@[simp] lemma disjoint_diag_off_diag : disjoint s.diag s.off_diag :=
disjoint_filter_filter_neg _ _ _

lemma product_sdiff_diag : s ×ˢ s \ s.diag = s.off_diag :=
by rw [←diag_union_off_diag, union_comm, union_sdiff_self,
    sdiff_eq_self_of_disjoint (disjoint_diag_off_diag _).symm]

lemma product_sdiff_off_diag : s ×ˢ s \ s.off_diag = s.diag :=
by rw [←diag_union_off_diag, union_sdiff_self, sdiff_eq_self_of_disjoint (disjoint_diag_off_diag _)]

lemma diag_inter : (s ∩ t).diag = s.diag ∩ t.diag :=
ext $ λ x, by simpa only [mem_diag, mem_inter] using and_and_distrib_right _ _ _

lemma off_diag_inter : (s ∩ t).off_diag = s.off_diag ∩ t.off_diag :=
coe_injective $ by { push_cast, exact set.off_diag_inter _ _ }

variables {s t}

lemma off_diag_union (h : disjoint s t) :
  (s ∪ t).off_diag = s.off_diag ∪ t.off_diag ∪ s ×ˢ t ∪ t ×ˢ s :=
coe_injective $ by { push_cast, exact set.off_diag_union (disjoint_coe.2 h) }

variables (a : α)

@[simp] lemma off_diag_singleton : ({a} : finset α).off_diag = ∅ :=
by simp [←finset.card_eq_zero]

lemma diag_singleton : ({a} : finset α).diag = {(a, a)} :=
by rw [←product_sdiff_off_diag, off_diag_singleton, sdiff_empty, singleton_product_singleton]

lemma diag_insert : (insert a s).diag = insert (a, a) s.diag :=
by rw [insert_eq, insert_eq, diag_union, diag_singleton]

lemma off_diag_insert (has : a ∉ s) :
  (insert a s).off_diag = s.off_diag ∪ {a} ×ˢ s ∪ s ×ˢ {a} :=
by rw [insert_eq, union_comm, off_diag_union (disjoint_singleton_right.2 has), off_diag_singleton,
  union_empty, union_right_comm]

end diag
end finset


/-
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