/-
Copyright (c) 2015 Floris van Doorn. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Floris van Doorn

Definition of general colimits and sequential colimits.
-/
import ..init

universes u v w
hott_theory

namespace hott

/- definition of a general colimit -/
open hott.eq nat hott.quotient sigma equiv is_trunc

namespace colimit
section
  parameters {I : Type u} {J : Type v} (A : I → Type w) (dom cod : J → I)
             (f : Π(j : J), A (dom j) → A (cod j))
  variables {i : I} (a : A i) (j : J) (b : A (dom j))

  local notation `B` := Σ(i : I), A i
  inductive colim_rel : B → B → Type (max u v w)
  | Rmk : Π{j : J} (a : A (dom j)), colim_rel ⟨cod j, f j a⟩ ⟨dom j, a⟩
  open colim_rel
  local notation `R` := colim_rel

  -- TODO: define this in root namespace
  @[hott] def colimit : Type _ :=
  quotient colim_rel

  @[hott] def incl : colimit :=
  class_of R ⟨i, a⟩

  @[hott, reducible] def ι := @incl

  @[hott] def cglue : eq.{max u v w} (ι (f j b)) (ι b) :=
  eq_of_rel colim_rel (Rmk _ : colim_rel ⟨_, f j b⟩ ⟨_, b⟩)

  @[hott, elab_as_eliminator] protected def rec {P : colimit → Type _}
    (Pincl : Π⦃i : I⦄ (x : A i), P (ι x))
    (Pglue : Π(j : J) (x : A (dom j)), Pincl (f j x) =[cglue j x] Pincl x)
      (y : colimit) : P y :=
  begin
    fapply (quotient.rec_on y),
    { intro a, induction a, apply Pincl},
    { intros a a' H, induction H, apply Pglue}
  end

  @[hott, elab_as_eliminator] protected def rec_on {P : colimit → Type _} (y : colimit)
    (Pincl : Π⦃i : I⦄ (x : A i), P (ι x))
    (Pglue : Π(j : J) (x : A (dom j)), Pincl (f j x) =[cglue j x] Pincl x) : P y :=
  rec Pincl Pglue y

  @[hott] theorem rec_cglue {P : colimit → Type _}
    (Pincl : Π⦃i : I⦄ (x : A i), P (ι x))
    (Pglue : Π(j : J) (x : A (dom j)), Pincl (f j x) =[cglue j x] Pincl x)
      {j : J} (x : A (dom j)) : apd (rec Pincl Pglue) (cglue j x) = Pglue j x :=
  by delta cglue hott.colimit.rec; dsimp [quotient.rec_on]; apply rec_eq_of_rel

  @[hott] protected def elim {P : Type _} (Pincl : Π⦃i : I⦄ (x : A i), P)
    (Pglue : Π(j : J) (x : A (dom j)), Pincl (f j x) = Pincl x) (y : colimit) : P :=
  @rec (λ _, P) Pincl (λj a, pathover_of_eq _ (Pglue j a)) y

  @[hott] protected def elim_on {P : Type _} (y : colimit)
    (Pincl : Π⦃i : I⦄ (x : A i), P)
    (Pglue : Π(j : J) (x : A (dom j)), Pincl (f j x) = Pincl x) : P :=
  elim Pincl Pglue y

  @[hott, hsimp] def elim_incl {P : Type _} (Pincl : Π⦃i : I⦄ (x : A i), P)
    (Pglue : Π(j : J) (x : A (dom j)), Pincl (f j x) = Pincl x) :
    hott.colimit.elim Pincl Pglue (ι a) = Pincl a := idp

  @[hott] theorem elim_cglue {P : Type _}
    (Pincl : Π⦃i : I⦄ (x : A i), P)
    (Pglue : Π(j : J) (x : A (dom j)), Pincl (f j x) = Pincl x)
      {j : J} (x : A (dom j)) : ap (elim Pincl Pglue) (cglue j x) = Pglue j x :=
  begin
    apply eq_of_fn_eq_fn_inv ((pathover_constant (cglue _ _ _ _ j x)) _ _),
    refine (apd_eq_pathover_of_eq_ap _ _)⁻¹ ⬝ rec_eq_of_rel _ _ _
  end

  @[hott] protected def elim_type (Pincl : Π⦃i : I⦄ (x : A i), Type _)
    (Pglue : Π(j : J) (x : A (dom j)), Pincl (f j x) ≃ Pincl x) (y : colimit) : Type _ :=
  elim Pincl (λj a, ua (Pglue j a)) y

  @[hott] protected def elim_type_on (y : colimit)
    (Pincl : Π⦃i : I⦄ (x : A i), Type _)
    (Pglue : Π(j : J) (x : A (dom j)), Pincl (f j x) ≃ Pincl x) : Type _ :=
  elim_type Pincl Pglue y

  @[hott] theorem elim_type_cglue (Pincl : Π⦃i : I⦄ (x : A i), Type _)
    (Pglue : Π(j : J) (x : A (dom j)), Pincl (f j x) ≃ Pincl x)
      {j : J} (x : A (dom j)) : transport (elim_type Pincl Pglue) (cglue j x) = Pglue j x :=
  by rwr tr_eq_cast_ap_fn; delta elim_type; rwr elim_cglue; apply cast_ua_fn

  @[hott] protected def rec_prop {P : colimit → Type _} [H : Πx, is_prop (P x)]
    (Pincl : Π⦃i : I⦄ (x : A i), P (ι x)) (y : colimit) : P y :=
  rec Pincl (λa b, is_prop.elimo _ _ _) y

  @[hott] protected def elim_prop {P : Type _} [H : is_prop P] (Pincl : Π⦃i : I⦄ (x : A i), P)
    (y : colimit) : P :=
  elim Pincl (λa b, is_prop.elim _ _) y

end
end colimit

/- definition of a sequential colimit -/
namespace seq_colim
section
  /-
    we define it directly in terms of quotients. An alternative definition could be
    @[hott] def seq_colim := colimit.colimit A id succ f
  -/
  parameters {A : ℕ → Type u} (f : Π⦃n⦄, A n → A (succ n))
  variables {n : ℕ} (a : A n)

  local notation `B` := Σ(n : ℕ), A n
  inductive seq_rel : B → B → Type u
  | Rmk : Π{n : ℕ} (a : A n), seq_rel ⟨succ n, f a⟩ ⟨n, a⟩
  open seq_rel
  local notation `R` := seq_rel

  -- TODO: define this in root namespace
  @[hott] def seq_colim : Type _ :=
  quotient seq_rel

  @[hott] def inclusion : seq_colim :=
  class_of R ⟨n, a⟩

  @[reducible,hott] def sι := @inclusion

  @[hott] def glue : sι (f a) = sι a :=
  eq_of_rel seq_rel (Rmk a)

  @[hott] protected def rec {P : seq_colim → Type _}
    (Pincl : Π⦃n : ℕ⦄ (a : A n), P (sι a))
    (Pglue : Π(n : ℕ) (a : A n), Pincl (f a) =[glue a] Pincl a) (aa : seq_colim) : P aa :=
  begin
    fapply (quotient.rec_on aa),
    { intro a, induction a, apply Pincl},
    { intros a a' H, induction H, apply Pglue}
  end

  @[hott] protected def rec_on {P : seq_colim → Type _} (aa : seq_colim)
    (Pincl : Π⦃n : ℕ⦄ (a : A n), P (sι a))
    (Pglue : Π⦃n : ℕ⦄ (a : A n), Pincl (f a) =[glue a] Pincl a)
      : P aa :=
  rec Pincl Pglue aa

  @[hott] theorem rec_glue {P : seq_colim → Type _} (Pincl : Π⦃n : ℕ⦄ (a : A n), P (sι a))
    (Pglue : Π⦃n : ℕ⦄ (a : A n), Pincl (f a) =[glue a] Pincl a) {n : ℕ} (a : A n)
      : apd (rec Pincl Pglue) (glue a) = Pglue a :=
  by delta glue seq_colim.rec; dsimp [quotient.rec_on]; apply rec_eq_of_rel

  @[hott] protected def elim {P : Type _} (Pincl : Π⦃n : ℕ⦄ (a : A n), P)
    (Pglue : Π⦃n : ℕ⦄ (a : A n), Pincl (f a) = Pincl a) : seq_colim → P :=
  rec Pincl (λn a, pathover_of_eq _ (Pglue a))

  @[hott, hsimp] def elim_incl {P : Type _} (Pincl : Π⦃n : ℕ⦄ (a : A n), P)
    (Pglue : Π⦃n : ℕ⦄ (a : A n), Pincl (f a) = Pincl a) :
    hott.seq_colim.elim Pincl Pglue (sι a) = Pincl a :=
  idp

  @[hott] protected def elim_on {P : Type _} (aa : seq_colim)
    (Pincl : Π⦃n : ℕ⦄ (a : A n), P)
    (Pglue : Π⦃n : ℕ⦄ (a : A n), Pincl (f a) = Pincl a) : P :=
  elim Pincl Pglue aa

  @[hott] theorem elim_glue {P : Type _} (Pincl : Π⦃n : ℕ⦄ (a : A n), P)
    (Pglue : Π⦃n : ℕ⦄ (a : A n), Pincl (f a) = Pincl a) {n : ℕ} (a : A n)
      : ap (elim Pincl Pglue) (glue a) = Pglue a :=
  begin
    apply eq_of_fn_eq_fn_inv ((pathover_constant (glue _ a)) _ _),
    refine (apd_eq_pathover_of_eq_ap _ _)⁻¹ ⬝ rec_eq_of_rel _ _ _
  end

  @[hott] protected def elim_type (Pincl : Π⦃n : ℕ⦄ (a : A n), Type _)
    (Pglue : Π⦃n : ℕ⦄ (a : A n), Pincl (f a) ≃ Pincl a) : seq_colim → Type _ :=
  elim Pincl (λn a, ua (Pglue a))

  @[hott] protected def elim_type_on (aa : seq_colim)
    (Pincl : Π⦃n : ℕ⦄ (a : A n), Type _)
    (Pglue : Π⦃n : ℕ⦄ (a : A n), Pincl (f a) ≃ Pincl a) : Type _ :=
  elim_type Pincl Pglue aa

  @[hott] theorem elim_type_glue (Pincl : Π⦃n : ℕ⦄ (a : A n), Type _)
    (Pglue : Π⦃n : ℕ⦄ (a : A n), Pincl (f a) ≃ Pincl a) {n : ℕ} (a : A n)
      : transport (elim_type Pincl Pglue) (glue a) = Pglue a :=
  by rwr tr_eq_cast_ap_fn; dunfold elim_type; rwr elim_glue; apply cast_ua_fn

  @[hott] theorem elim_type_glue_inv (Pincl : Π⦃n : ℕ⦄ (a : A n), Type _)
    (Pglue : Π⦃n : ℕ⦄ (a : A n), Pincl (f a) ≃ Pincl a) {n : ℕ} (a : A n)
    : transport (hott.seq_colim.elim_type Pincl Pglue) (glue a)⁻¹ = (Pglue a)⁻¹ᶠ :=
  by rwr tr_eq_cast_ap_fn; dunfold elim_type; rwr [ap_inv, elim_glue]; dsimp; apply cast_ua_inv_fn

  @[hott] protected def rec_prop {P : seq_colim → Type _} [H : Πx, is_prop (P x)]
    (Pincl : Π⦃n : ℕ⦄ (a : A n), P (sι a)) (aa : seq_colim) : P aa :=
  rec Pincl (by intros; apply is_prop.elimo) aa

  @[hott] protected def elim_prop {P : Type _} [H : is_prop P] (Pincl : Π⦃n : ℕ⦄ (a : A n), P)
    : seq_colim → P :=
  elim Pincl (λa b, is_prop.elim _ _)

end
end seq_colim

end hott


/-
Copyright (c) 2019 Zhouhang Zhou. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Zhouhang Zhou
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.algebra.pointwise
import Mathlib.order.filter.basic
import Mathlib.PostPort

universes u v

namespace Mathlib

/-!
# Pointwise operations on filters.

The pointwise operations on filters have nice properties, such as
  • `map m (f₁ * f₂) = map m f₁ * map m f₂`
  • `𝓝 x * 𝓝 y = 𝓝 (x * y)`

-/

namespace filter

protected instance has_one {α : Type u} [HasOne α] : HasOne (filter α) :=
  { one := principal 1 }

@[simp] theorem mem_zero {α : Type u} [HasZero α] (s : set α) : s ∈ 0 ↔ 0 ∈ s := sorry

protected instance has_mul {α : Type u} [monoid α] : Mul (filter α) :=
  { mul :=
      fun (f g : filter α) =>
        mk (set_of fun (s : set α) => ∃ (t₁ : set α), ∃ (t₂ : set α), t₁ ∈ f ∧ t₂ ∈ g ∧ t₁ * t₂ ⊆ s) sorry sorry sorry }

theorem mem_add {α : Type u} [add_monoid α] {f : filter α} {g : filter α} {s : set α} : s ∈ f + g ↔ ∃ (t₁ : set α), ∃ (t₂ : set α), t₁ ∈ f ∧ t₂ ∈ g ∧ t₁ + t₂ ⊆ s :=
  iff.rfl

theorem mul_mem_mul {α : Type u} [monoid α] {f : filter α} {g : filter α} {s : set α} {t : set α} (hs : s ∈ f) (ht : t ∈ g) : s * t ∈ f * g :=
  Exists.intro s (Exists.intro t { left := hs, right := { left := ht, right := set.subset.refl (s * t) } })

protected theorem mul_le_mul {α : Type u} [monoid α] {f₁ : filter α} {f₂ : filter α} {g₁ : filter α} {g₂ : filter α} (hf : f₁ ≤ f₂) (hg : g₁ ≤ g₂) : f₁ * g₁ ≤ f₂ * g₂ := sorry

theorem ne_bot.add {α : Type u} [add_monoid α] {f : filter α} {g : filter α} : ne_bot f → ne_bot g → ne_bot (f + g) := sorry

protected theorem add_assoc {α : Type u} [add_monoid α] (f : filter α) (g : filter α) (h : filter α) : f + g + h = f + (g + h) := sorry

protected theorem one_mul {α : Type u} [monoid α] (f : filter α) : 1 * f = f := sorry

protected theorem add_zero {α : Type u} [add_monoid α] (f : filter α) : f + 0 = f := sorry

protected instance monoid {α : Type u} [monoid α] : monoid (filter α) :=
  monoid.mk Mul.mul filter.mul_assoc 1 filter.one_mul filter.mul_one

protected theorem map_add {α : Type u} {β : Type v} [add_monoid α] [add_monoid β] (m : α → β) [is_add_hom m] {f₁ : filter α} {f₂ : filter α} : map m (f₁ + f₂) = map m f₁ + map m f₂ := sorry

protected theorem map_one {α : Type u} {β : Type v} [monoid α] [monoid β] (m : α → β) [is_monoid_hom m] : map m 1 = 1 := sorry

-- TODO: prove similar statements when `m` is group homomorphism etc.

theorem Mathlib.map.is_add_monoid_hom {α : Type u} {β : Type v} [add_monoid α] [add_monoid β] (m : α → β) [is_add_monoid_hom m] : is_add_monoid_hom (map m) :=
  is_add_monoid_hom.mk (filter.map_zero m)

-- The other direction does not hold in general.

theorem comap_mul_comap_le {α : Type u} {β : Type v} [monoid α] [monoid β] (m : α → β) [is_mul_hom m] {f₁ : filter β} {f₂ : filter β} : comap m f₁ * comap m f₂ ≤ comap m (f₁ * f₂) := sorry

theorem tendsto.mul_mul {α : Type u} {β : Type v} [monoid α] [monoid β] {m : α → β} [is_mul_hom m] {f₁ : filter α} {g₁ : filter α} {f₂ : filter β} {g₂ : filter β} : tendsto m f₁ f₂ → tendsto m g₁ g₂ → tendsto m (f₁ * g₁) (f₂ * g₂) :=
  fun (hf : tendsto m f₁ f₂) (hg : tendsto m g₁ g₂) =>
    eq.mpr (id (Eq._oldrec (Eq.refl (tendsto m (f₁ * g₁) (f₂ * g₂))) (tendsto.equations._eqn_1 m (f₁ * g₁) (f₂ * g₂))))
      (eq.mpr (id (Eq._oldrec (Eq.refl (map m (f₁ * g₁) ≤ f₂ * g₂)) (filter.map_mul m))) (filter.mul_le_mul hf hg))


import GMLInit.Data.Fin.Basic

namespace Fin

def equivEmpty : Equiv (Fin 0) Empty where
  fwd := (nomatch .)
  rev := (nomatch .)
  spec {k} := nomatch k

def equivUnit : Equiv (Fin 1) Unit where
  fwd _ := ()
  rev _ := ⟨0, Nat.zero_lt_one⟩
  spec {k x} := match k, x with
  | ⟨0, _⟩, () => ⟨fun _ => rfl, fun _ => rfl⟩

def equivBool : Equiv (Fin 2) Bool where
  fwd
  | ⟨0, _⟩ => false
  | ⟨1, _⟩ => true
  rev
  | false => ⟨0, Nat.zero_lt_succ 1⟩
  | true => ⟨1, Nat.succ_lt_succ Nat.zero_lt_one⟩
  spec {k x} := match k, x with
  | ⟨0, _⟩, false  => ⟨fun _ => rfl, fun _ => rfl⟩
  | ⟨0, _⟩, true  => ⟨Bool.noConfusion, fun h => Nat.noConfusion (Fin.val_eq_of_eq h)⟩
  | ⟨1, _⟩, false  => ⟨Bool.noConfusion, fun h => Nat.noConfusion (Fin.val_eq_of_eq h)⟩
  | ⟨1, _⟩, true  => ⟨fun _ => rfl, fun _ => rfl⟩

def equivOrdering : Equiv (Fin 3) Ordering where
  fwd
  | ⟨0, _⟩ => .eq
  | ⟨1, _⟩ => .lt
  | ⟨2, _⟩ => .gt
  rev
  | .eq => ⟨0, Nat.zero_lt_succ 2⟩
  | .lt => ⟨1, Nat.succ_lt_succ (Nat.zero_lt_succ 1)⟩
  | .gt => ⟨2, Nat.succ_lt_succ (Nat.succ_lt_succ Nat.zero_lt_one)⟩
  spec {k x} := match k, x with
  | ⟨0, _⟩, .eq  => ⟨fun _ => rfl, fun _ => rfl⟩
  | ⟨0, _⟩, .lt  => ⟨Ordering.noConfusion, fun h => Nat.noConfusion (Fin.val_eq_of_eq h)⟩
  | ⟨0, _⟩, .gt  => ⟨Ordering.noConfusion, fun h => Nat.noConfusion (Fin.val_eq_of_eq h)⟩
  | ⟨1, _⟩, .eq  => ⟨Ordering.noConfusion, fun h => Nat.noConfusion (Fin.val_eq_of_eq h)⟩
  | ⟨1, _⟩, .lt  => ⟨fun _ => rfl, fun _ => rfl⟩
  | ⟨1, _⟩, .gt  => ⟨Ordering.noConfusion, fun h => Nat.noConfusion (Nat.succ.inj (Fin.val_eq_of_eq h))⟩
  | ⟨2, _⟩, .eq  => ⟨Ordering.noConfusion, fun h => Nat.noConfusion (Fin.val_eq_of_eq h)⟩
  | ⟨2, _⟩, .lt  => ⟨Ordering.noConfusion, fun h => Nat.noConfusion (Nat.succ.inj (Fin.val_eq_of_eq h))⟩
  | ⟨2, _⟩, .gt  => ⟨fun _ => rfl, fun _ => rfl⟩

def encodeOptionNone : Fin (n+1) := ⟨n, Nat.lt_succ_self n⟩

def encodeOptionSome : Fin n → Fin (n+1)
| ⟨i, hi⟩ => ⟨i, Nat.lt_trans hi (Nat.lt_succ_self n)⟩

def decodeOption : Fin (n+1) → Option (Fin n)
| ⟨k, _⟩ => if hk : k < n then some ⟨k, hk⟩ else none

def equivOption (n : Nat) : Equiv (Fin (n+1)) (Option (Fin n)) where
  fwd := decodeOption
  rev
  | some i => encodeOptionSome i
  | none => encodeOptionNone
  spec {k x} := match k, x with
  | ⟨k, hk⟩, some ⟨i, hi⟩ => by
    constr
    · intro h
      unfold decodeOption at h
      unfold encodeOptionSome
      simp at h ⊢
      split at h
      next =>
        cases h
        rfl
      next =>
        contradiction
    · intro h
      unfold decodeOption
      unfold encodeOptionSome at h
      simp at h ⊢
      cases h
      split
      next =>
        rfl
      next =>
        contradiction
  | ⟨k, hk⟩, none => by
    constr
    · intro h
      unfold decodeOption at h
      unfold encodeOptionNone
      simp at h ⊢
      split at h
      next =>
        contradiction
      next =>
        antisymmetry using LE.le
        · apply Nat.le_of_not_gt
          assumption
        · apply Nat.le_of_lt_succ
          assumption
    · intro h
      unfold decodeOption
      unfold encodeOptionNone at h
      simp at h ⊢
      cases h
      split
      next =>
        apply Nat.lt_irrefl n
        assumption
      next =>
        rfl

def encodeSumLeft : Fin m → Fin (m + n)
| ⟨i, hi⟩ => ⟨i, Nat.lt_of_lt_of_le hi (Nat.le_add_right m n)⟩

def encodeSumRight : Fin n → Fin (m + n)
| ⟨j, hj⟩ => ⟨m + j, Nat.add_lt_add_left hj m⟩

def decodeSum : Fin (m + n) → Sum (Fin m) (Fin n)
| ⟨k, hk⟩ =>
  if hkm : k < m then
    Sum.inl ⟨k, hkm⟩
  else
    have hn : n > 0 := by
      by_contradiction
      | assuming h =>
        have h : n = 0 := Nat.eq_zero_of_le_zero (Nat.le_of_not_gt h)
        cases h
        contradiction
    have hkm : k - m < n := by
      rw [Nat.sub_lt_iff_lt_add_of_pos k m n hn]
      exact hk
    Sum.inr ⟨k - m, hkm⟩

def equivSum (m n : Nat) : Equiv (Fin (m + n)) (Sum (Fin m) (Fin n)) where
  fwd := decodeSum
  rev
  | .inl x => encodeSumLeft x
  | .inr y => encodeSumRight y
  spec {k x} := match k, x with
  | ⟨k, hk⟩, .inl ⟨i, hi⟩ => by
    constr
    · intro h
      unfold decodeSum at h
      unfold encodeSumLeft
      simp at h ⊢
      split at h
      next =>
        cases h
        rfl
      next =>
        contradiction
    · intro h
      unfold decodeSum
      unfold encodeSumLeft at h
      simp at h ⊢
      cases h
      split
      next =>
        rfl
      next =>
        contradiction
  | ⟨k, hk⟩, .inr ⟨j, hj⟩ => by
    constr
    · intro h
      unfold decodeSum at h
      unfold encodeSumRight
      simp at h ⊢
      split at h
      next =>
        contradiction
      next =>
        cases h
        rw [Nat.add_sub_cancel']
        apply Nat.le_of_not_gt
        assumption
    · intro h
      unfold decodeSum
      unfold encodeSumRight at h
      simp at h ⊢
      cases h
      split
      next h =>
        absurd h
        apply Nat.not_lt_of_ge
        exact Nat.le_add_right ..
      next =>
        congr
        exact Nat.add_sub_cancel_left ..

def encodeProd : Fin m × Fin n → Fin (m * n)
| (⟨i, hi⟩, ⟨j,hj⟩) => Fin.mk (n * i + j) $ calc
  _ < n * i + n := Nat.add_lt_add_left hj ..
  _ = n * (i + 1) := Nat.mul_succ ..
  _ ≤ n * m := Nat.mul_le_mul_left n (Nat.succ_le_of_lt hi)
  _ = m * n := Nat.mul_comm ..

def decodeProdLeft : Fin (m * n) → Fin m
| ⟨k, hk⟩ =>
  have hn : n > 0 := by
    apply Nat.pos_of_nonzero
    intro hz
    rw [hz, Nat.mul_zero] at hk
    contradiction
  Fin.mk (k / n) $ by rw [Nat.div_lt_iff_lt_mul hn]; exact hk

def decodeProdRight : Fin (m * n) → Fin n
| ⟨k, hk⟩ =>
  have hn : n > 0 := by
    apply Nat.pos_of_nonzero
    intro hz
    rw [hz, Nat.mul_zero] at hk
    contradiction
  ⟨k % n, Nat.mod_lt k hn⟩

abbrev decodeProd (k : Fin (m * n)) := (decodeProdLeft k, decodeProdRight k)

def equivProd (m n : Nat) : Equiv (Fin (m * n)) (Fin m × Fin n) where
  fwd := decodeProd
  rev := encodeProd
  spec {k x} := match k, x with
  | ⟨k, hk⟩, (⟨i,hi⟩, ⟨j,hj⟩) => by
    constr
    · intro h
      unfold decodeProd decodeProdLeft decodeProdRight at h
      unfold encodeProd
      simp at h ⊢
      cases h with
      | intro hl hr =>
        cases hl
        cases hr
        exact Nat.div_add_mod ..
    · intro h
      unfold decodeProd decodeProdLeft decodeProdRight
      unfold encodeProd at h
      simp at h ⊢
      cases h
      have hn : n > 0 := by
        apply Nat.pos_of_nonzero
        intro hz
        rw [hz, Nat.mul_zero] at hk
        contradiction
      constr
      · rw [Nat.add_comm]
        rw [Nat.add_mul_div_left _ _ hn]
        rw [Nat.div_eq_of_lt hj]
        rw [Nat.zero_add]
      · rw [Nat.add_comm]
        rw [Nat.add_mul_mod_self_left]
        rw [Nat.mod_eq_of_lt hj]

def encodeFun : {m : Nat} → (Fin m → Fin n) → Fin (n ^ m)
| 0, _ => Fin.mk 0 $ by rw [Nat.pow_zero n]; exact Nat.zero_lt_one
| m+1, f => Fin.mk (n * (encodeFun fun k => f k.succ).val + (f 0).val) $ calc
  _ < n * (encodeFun fun k => f k.succ).val + n := Nat.add_lt_add_left (f 0).isLt _
  _ = n * ((encodeFun fun k => f k.succ).val + 1) := Nat.mul_succ ..
  _ ≤ n * n ^ m := Nat.mul_le_mul_left n (Nat.succ_le_of_lt (encodeFun fun k => f k.succ).isLt)
  _ = n ^ m * n := Nat.mul_comm ..
  _ = n ^ (m+1) := Nat.pow_succ ..

def decodeFun : {m : Nat} → Fin (n ^ m) → Fin m → Fin n
| 0, _ => (nomatch .)
| m+1, ⟨k, hk⟩ =>
  have hn : n > 0 := by
    apply Nat.pos_of_nonzero
    intro h
    rw [h, Nat.pow_succ, Nat.mul_zero] at hk
    contradiction
  fun
  | ⟨0, _⟩ => ⟨k % n, Nat.mod_lt k hn⟩
  | ⟨i+1, hi⟩ =>
    have h : k / n < n ^ m := by rw [Nat.div_lt_iff_lt_mul hn]; exact hk
    decodeFun ⟨k / n, h⟩ ⟨i, Nat.lt_of_succ_lt_succ hi⟩

theorem specFun (k : Fin (n ^ m)) (x : Fin m → Fin n) :
  decodeFun k = x ↔ encodeFun x = k := by
  induction m with
  | zero =>
    match k with
    | ⟨0, _⟩ =>
      constr
      · intro | rfl => rfl
      · intro; funext ⟨_,_⟩; contradiction
  | succ m ih =>
    have ih1 : decodeFun (encodeFun (fun k => x (succ k))) = fun k => x (succ k) := by rw [ih]
    match k with
    | ⟨k, hk⟩ =>
      have hnpos : n > 0 := by
        apply Nat.pos_of_nonzero
        intro h
        rw [h] at hk
        contradiction
      constr
      · intro h
        clean at h
        unfold encodeFun
        apply Fin.eq
        clean
        transitivity (n * (k / n) + k % n)
        · congr
          · have : k / n < n ^ m := by rw [Nat.div_lt_iff_lt_mul hnpos]; exact hk
            have : (encodeFun fun k => x (succ k)) = ⟨k / n, this⟩ := by rw [←ih, ←h]; rfl
            erw [this]
            done
          · rw [←h]
            unfold decodeFun
            clean
            split
            next => rfl
            next heq => injection heq; contradiction
        · rw [Nat.add_comm]
          exact Nat.mod_add_div ..
      · intro h
        unfold encodeFun at h
        injection h with h
        unfold decodeFun
        funext ⟨i, hi⟩
        clean
        split
        next heq =>
          cases heq
          apply Fin.eq
          simp only [←h]
          rw [Nat.add_comm]
          rw [Nat.add_mul_mod_self_left]
          rw [Nat.mod_eq_of_lt (x 0).isLt]
          rfl
        next i _ heq =>
          cases heq
          rw [Nat.add_comm] at h
          have : (encodeFun fun k => x (succ k)) = k / n := by
            rw [←h]
            rw [Nat.add_mul_div_left (H := hnpos)]
            rw [Nat.div_eq_of_lt (x 0).isLt]
            rw [Nat.zero_add]
            rfl
          transitivity ((decodeFun (encodeFun fun k => x (succ k))) ⟨i, Nat.lt_of_succ_lt_succ hi⟩)
          · congr
            rw [←h]
            rw [Nat.add_mul_div_left (H := hnpos)]
            rw [Nat.div_eq_of_lt (x 0).isLt]
            rw [Nat.zero_add]
            rfl
          · rw [ih1]
            rfl

def equivFun (n m : Nat) : Equiv (Fin (n ^ m)) (Fin m → Fin n) where
  fwd := decodeFun
  rev := encodeFun
  spec {k x} := specFun k x

def sum : {n : Nat} → (Fin n → Nat) → Nat
| 0, _ => 0
| n+1, f => f ⟨0, Nat.zero_lt_succ n⟩ + sum fun ⟨i, hi⟩ => f ⟨i+1, Nat.succ_lt_succ hi⟩

def encodeSigma (f : Fin n → Nat) (x : (i : Fin n) × Fin (f i)) : Fin (sum f) :=
  match n, f, x with
  | _+1, _, ⟨⟨0, _⟩, ⟨j, hj⟩⟩ =>
    ⟨j, Nat.lt_of_lt_of_le hj (Nat.le_add_right ..)⟩
  | n+1, f, ⟨⟨i+1, hi⟩, ⟨j, hj⟩⟩ =>
    match encodeSigma (fun ⟨i, hi⟩ => f ⟨i+1, Nat.succ_lt_succ hi⟩) ⟨⟨i, Nat.lt_of_succ_lt_succ hi⟩, ⟨j, hj⟩⟩ with
    | ⟨k, hk⟩ => ⟨f ⟨0, Nat.zero_lt_succ n⟩ + k, Nat.add_lt_add_left hk ..⟩

def decodeSigma (f : Fin n → Nat) (k : Fin (sum f)) : (i : Fin n) × Fin (f i) :=
  match n, f, k with
  | n+1, f, ⟨k, hk⟩ =>
    if hk0 : k < f ⟨0, Nat.zero_lt_succ n⟩ then
      ⟨⟨0, Nat.zero_lt_succ n⟩, ⟨k, hk0⟩⟩
    else
      have hpos : 0 < sum fun ⟨i, hi⟩ => f ⟨i+1, Nat.succ_lt_succ hi⟩ := by
        apply Nat.pos_of_nonzero
        intro hz
        rw [sum, hz, Nat.add_zero] at hk
        contradiction
      have hkf : k - f ⟨0, Nat.zero_lt_succ n⟩ < sum fun ⟨i, hi⟩ => f ⟨i+1, Nat.succ_lt_succ hi⟩ := by
        rw [Nat.sub_lt_iff_lt_add_of_pos _ _ _ hpos]
        exact hk
      match decodeSigma (fun ⟨i, hi⟩ => f ⟨i+1, Nat.succ_lt_succ hi⟩) ⟨k - f ⟨0, Nat.zero_lt_succ n⟩, hkf⟩ with
      | ⟨⟨i, hi⟩, j⟩ => ⟨⟨i+1, Nat.succ_lt_succ hi⟩, j⟩

theorem specSigma (f : Fin n → Nat) (k : Fin (sum f)) (x : (i : Fin n) × Fin (f i)) : decodeSigma f k = x ↔ encodeSigma f x = k := by
  induction n with
  | zero => match k, x with | ⟨_, _⟩, _ => contradiction
  | succ n ih =>
    match k, x with
    | ⟨k, hk⟩, ⟨⟨0, _⟩, ⟨_,_⟩⟩ =>
      constr
      · intro h
        unfold decodeSigma at h
        congr
        split at h
        next => cases h; rfl
        next => cases h
      · intro h
        unfold decodeSigma
        cases h
        split
        next => rfl
        next => contradiction
    | ⟨k, hk⟩, ⟨⟨i+1, hi⟩, ⟨j, hj⟩⟩ =>
      constr
      · intro h
        simp only [decodeSigma] at h
        split at h
        next => cases h
        next hge =>
          have hge := Nat.ge_of_not_lt hge
          have hpos : 0 < sum fun ⟨i, hi⟩ => f ⟨i+1, Nat.succ_lt_succ hi⟩ := by
            apply Nat.pos_of_nonzero
            intro hz
            rw [Fin.sum, hz, Nat.add_zero] at hk
            contradiction
          have hk' : k - f ⟨0, Nat.zero_lt_succ n⟩ < sum fun ⟨i, hi⟩ => f ⟨i+1, Nat.succ_lt_succ hi⟩ := by
            rw [Nat.sub_lt_iff_lt_add_of_pos _ _ _ hpos]
            exact hk
          have : encodeSigma (fun ⟨i,hi⟩ => f ⟨i+1, Nat.succ_lt_succ hi⟩) ⟨⟨i, Nat.lt_of_succ_lt_succ hi⟩, ⟨j, hj⟩⟩ = ⟨k - f ⟨0, Nat.zero_lt_succ n⟩, hk'⟩ := by
            rw [←ih]
            injection h with h1 h2
            cases h1
            apply Sigma.eq
            · rfl
            · exact h2
          simp [encodeSigma]
          transitivity (f ⟨0, Nat.zero_lt_succ n⟩ + (encodeSigma (fun ⟨i,hi⟩ => f ⟨i+1, Nat.succ_lt_succ hi⟩) ⟨⟨i, Nat.lt_of_succ_lt_succ hi⟩, ⟨j, hj⟩⟩).val)
          · rfl
          · rw [this]
            rw [Nat.add_comm, Nat.sub_add_cancel]
            exact hge
      · intro h
        simp only [decodeSigma]
        simp only [encodeSigma] at h
        split
        next hlt =>
          cases h
          absurd hlt
          apply Nat.not_lt_of_ge
          exact Nat.le_add_right ..
        next hge =>
          have hge := Nat.ge_of_not_lt hge
          have hpos : 0 < sum fun ⟨i, hi⟩ => f ⟨i+1, Nat.succ_lt_succ hi⟩ := by
            apply Nat.pos_of_nonzero
            intro hz
            rw [Fin.sum, hz] at hk
            contradiction
          have hk' : k - f ⟨0, Nat.zero_lt_succ n⟩ < sum fun ⟨i, hi⟩ => f ⟨i+1, Nat.succ_lt_succ hi⟩ := by
            rw [Nat.sub_lt_iff_lt_add_of_pos _ _ _ hpos]
            exact hk
          have : decodeSigma (fun ⟨i,hi⟩ => f ⟨i+1, Nat.succ_lt_succ hi⟩) ⟨k - f ⟨0, Nat.zero_lt_succ n⟩, hk'⟩ = ⟨⟨i, Nat.lt_of_succ_lt_succ hi⟩, ⟨j,hj⟩⟩ := by
            rw [ih]
            cases h
            apply Fin.eq
            clean
            rw [Nat.add_sub_cancel_left]
            rfl
          congr 1
          · apply Fin.eq
            transitivity ((decodeSigma (fun ⟨i,hi⟩ => f ⟨i+1, Nat.succ_lt_succ hi⟩) ⟨k - f ⟨0, Nat.zero_lt_succ n⟩, hk'⟩).1.1+1)
            · rfl
            · rw [this]
          · have t' : (decodeSigma (fun ⟨i,hi⟩ => f ⟨i+1, Nat.succ_lt_succ hi⟩) ⟨k - f ⟨0, Nat.zero_lt_succ n⟩, hk'⟩).fst.val = i := by
              rw [this]
            cases t'
            apply heq_of_eq
            transitivity ((decodeSigma (fun ⟨i,hi⟩ => f ⟨i+1, Nat.succ_lt_succ hi⟩) ⟨k - f ⟨0, Nat.zero_lt_succ n⟩, hk'⟩).2)
            · apply Fin.eq
              rfl
            · apply Fin.eq
              clean
              rw [this]

def equivSigma (f : Fin n → Nat) : Equiv (Fin (sum f)) ((i : Fin n) × Fin (f i)) where
  fwd := decodeSigma f
  rev := encodeSigma f
  spec {k x} := specSigma f k x

def prod : {n : Nat} → (Fin n → Nat) → Nat
| 0, _ => 1
| n+1, f => f ⟨0, Nat.zero_lt_succ n⟩ * prod fun ⟨i, hi⟩ => f ⟨i+1, Nat.succ_lt_succ hi⟩

def encodePi (f : Fin n → Nat) (x : (i : Fin n) → Fin (f i)) : Fin (prod f) :=
  match n, f, x with
  | 0, _, _ => ⟨0, Nat.zero_lt_one⟩
  | n+1, f, x =>
    match encodePi (fun ⟨i, hi⟩ => f ⟨i+1, Nat.succ_lt_succ hi⟩) (fun ⟨i, hi⟩ => x ⟨i+1, Nat.succ_lt_succ hi⟩) with
    | ⟨k, hk⟩ => Fin.mk (f ⟨0, Nat.zero_lt_succ n⟩ * k + (x ⟨0, Nat.zero_lt_succ n⟩).val) $ calc
      _ < f ⟨0, Nat.zero_lt_succ n⟩ * k + f ⟨0, Nat.zero_lt_succ n⟩ := Nat.add_lt_add_left (x ⟨0, Nat.zero_lt_succ n⟩).isLt ..
      _ = f ⟨0, Nat.zero_lt_succ n⟩ * (k + 1) := Nat.mul_succ ..
      _ ≤ f ⟨0, Nat.zero_lt_succ n⟩ * prod fun ⟨i, hi⟩ => f ⟨i+1, Nat.succ_lt_succ hi⟩ := Nat.mul_le_mul_left _ (Nat.succ_le_of_lt hk)

def decodePi (f : Fin n → Nat) (k : Fin (prod f)) : (i : Fin n) → Fin (f i) :=
  match n, f, k with
  | 0, _, _ => (nomatch .)
  | n+1, f, ⟨k, hk⟩ =>
    have hf : f ⟨0, Nat.zero_lt_succ n⟩ > 0 := by
      apply Nat.pos_of_nonzero
      intro h
      rw [prod, h, Nat.zero_mul] at hk
      contradiction
    have hk' : k / f ⟨0, Nat.zero_lt_succ n⟩ < prod fun ⟨i, hi⟩ => f ⟨i+1, Nat.succ_lt_succ hi⟩ := by
      rw [Nat.div_lt_iff_lt_mul hf, Nat.mul_comm]
      exact hk
    match decodePi (fun ⟨i, hi⟩ => f ⟨i+1, Nat.succ_lt_succ hi⟩) ⟨k / f ⟨0, Nat.zero_lt_succ n⟩, hk'⟩ with
    | x => fun
      | ⟨0, _⟩ => ⟨k % f ⟨0, Nat.zero_lt_succ n⟩, Nat.mod_lt k hf⟩
      | ⟨i+1, hi⟩ => x ⟨i, Nat.lt_of_succ_lt_succ hi⟩

theorem specPi (f : Fin n → Nat) (k : Fin (prod f)) (x : (i : Fin n) → Fin (f i)) :
  decodePi f k = x ↔ encodePi f x = k := by
    induction n with
    | zero =>
      constr
      · intro
        match k with
        | ⟨0, _⟩ => rfl
      · intro
        funext ⟨_,_⟩
        contradiction
    | succ n ih =>
      constr
      · intro h
        match k with
        | ⟨k, hk⟩ =>
          apply Fin.eq
          simp only [encodePi]
          transitivity (f ⟨0, Nat.zero_lt_succ n⟩ * (k / f ⟨0, Nat.zero_lt_succ n⟩) + k % f ⟨0, Nat.zero_lt_succ n⟩)
          · congr 1
            · congr 1
              have hpos : f ⟨0, Nat.zero_lt_succ n⟩ > 0 := by
                apply Nat.pos_of_nonzero
                intro hz
                rw [Fin.prod, hz, Nat.zero_mul] at hk
                contradiction
              have hk' : k / f ⟨0, Nat.zero_lt_succ n⟩ < Fin.prod fun k => f (succ k) := by
                rw [Nat.div_lt_iff_lt_mul hpos]
                rw [Nat.mul_comm]
                exact hk
              have : encodePi (fun i => f (succ i)) (fun i => x (succ i)) = ⟨k / f ⟨0, Nat.zero_lt_succ n⟩, hk'⟩ := by
                rw [←ih]
                funext i
                rw [←h]
                rfl
              transitivity (encodePi (fun i => f (succ i)) (fun i => x (succ i))).val
              · rfl
              · rw [this]
            · rw [←h]
              rfl
          · rw [Nat.add_comm]
            exact Nat.mod_add_div ..
      · intro h
        funext i
        simp only [decodePi]
        split
        next =>
          apply Fin.eq
          clean
          rw [←h]
          simp only [encodePi]
          rw [Nat.add_comm]
          rw [Nat.add_mul_mod_self_left]
          rw [Nat.mod_eq_of_lt]
          exact (x ⟨0, Nat.zero_lt_succ n⟩).isLt
        next i hi =>
          match k with
          | ⟨k, hk⟩ =>
            simp only [encodePi] at h
            apply Fin.eq
            have hpos : f ⟨0, Nat.zero_lt_succ n⟩ > 0 := by
              apply Nat.pos_of_nonzero
              intro hz
              rw [Fin.prod, hz, Nat.zero_mul] at hk
              contradiction
            have hk' : k / f ⟨0, Nat.zero_lt_succ n⟩ < Fin.prod fun k => f (succ k) := by
              rw [Nat.div_lt_iff_lt_mul hpos]
              rw [Nat.mul_comm]
              exact hk
            have : decodePi (fun i => f (succ i)) ⟨k / f ⟨0, Nat.zero_lt_succ n⟩, hk'⟩ = fun i => x (succ i) := by
              rw [ih]
              cases h
              apply Fin.eq
              clean
              rw [Nat.add_comm]
              rw [Nat.add_mul_div_left _ _ hpos]
              rw [Nat.div_eq_of_lt (x ⟨0, Nat.zero_lt_succ n⟩).isLt]
              rw [Nat.zero_add]
              rfl
            clean
            transitivity (decodePi (fun i => f (succ i)) ⟨k / f ⟨0, Nat.zero_lt_succ n⟩, hk'⟩ ⟨i, Nat.lt_of_succ_lt_succ hi⟩).val
            · rfl
            · rw [this]
              rfl

def equivPi (f : Fin n → Nat) : Equiv (Fin (prod f)) ((i : Fin n) → Fin (f i)) where
  fwd := decodePi f
  rev := encodePi f
  spec {k x} := specPi f k x

def count (p : Fin n → Prop) [DecidablePred p] : Nat :=
  sum fun i => if p i then 1 else 0

def encodeSubtype (p : Fin n → Prop) [inst : DecidablePred p] (i : { i // p i }) : Fin (count p) :=
  match n, p, inst, i with
  | n+1, p, inst, ⟨⟨0, _⟩, hp⟩ =>
    have : count p > 0 := by simp_arith only [count, sum, if_pos hp]
    ⟨0, this⟩
  | n+1, p, inst, ⟨⟨i+1, hi⟩, hp⟩ =>
    match encodeSubtype (fun i => p (succ i)) ⟨⟨i, Nat.lt_of_succ_lt_succ hi⟩, hp⟩ with
    | ⟨k, hk⟩ =>
      if h0 : p ⟨0, Nat.zero_lt_succ n⟩ then
        have : count p = count (fun i => p (succ i)) + 1 := by
          simp_arith only [count, sum, if_pos h0]; rfl
        this ▸ ⟨k+1, Nat.succ_lt_succ hk⟩
      else
        have : count p = count (fun i => p (succ i)) := by
          simp_arith only [count, sum, if_neg h0]; rfl
        this ▸ ⟨k, hk⟩

def decodeSubtype (p : Fin n → Prop) [inst : DecidablePred p] (k : Fin (count p)) : { i // p i } :=
  match n, p, inst, k with
  | n+1, p, inst, ⟨k, hk⟩ =>
    if h0 : p ⟨0, Nat.zero_lt_succ n⟩ then
      have : count p = count (fun i => p (succ i)) + 1 := by
        simp_arith only [count, sum, if_pos h0]; rfl
      match k with
      | 0 => ⟨⟨0, Nat.zero_lt_succ n⟩, h0⟩
      | k + 1 =>
        match decodeSubtype (fun i => p (succ i)) ⟨k, Nat.lt_of_succ_lt_succ' (this ▸ hk)⟩ with
        | ⟨⟨i, hi⟩, hp⟩ => ⟨⟨i+1, Nat.succ_lt_succ hi⟩, hp⟩
    else
      have : count p = count (fun i => p (succ i)) := by
        simp_arith only [count, sum, if_neg h0]; rfl
      match decodeSubtype (fun i => p (succ i)) ⟨k, this ▸ hk⟩ with
      | ⟨⟨i, hi⟩, hp⟩ => ⟨⟨i+1, Nat.succ_lt_succ hi⟩, hp⟩

theorem specSubtype (p : Fin n → Prop) [inst : DecidablePred p] (k : Fin (count p)) (i : { i // p i }) :
  decodeSubtype p k = i ↔ encodeSubtype p i = k := by
  induction n with
  | zero =>
    simp [count, sum] at k
    cases k
    contradiction
  | succ n ih =>
    constr
    · intro h
      simp only [decodeSubtype] at h
      split at h
      next h0 =>
        have : count p = count (fun i => p (succ i)) + 1 := by
          simp_arith only [count, sum, if_pos h0]; rfl
        split at h
        next =>
          cases h
          simp only [encodeSubtype]
          apply Fin.eq
          symmetry
          assumption
        next heq _ =>
          cases h
          simp only [encodeSubtype, dif_pos h0]
          apply Fin.eq
          simp only [val_ndrec]
          match k with
          | ⟨0, _⟩ => contradiction
          | ⟨k+1, hk⟩ =>
            cases heq
            congr 1
            transitivity (Fin.mk k (Nat.lt_of_succ_lt_succ (this ▸ hk))).val
            · apply Fin.val_eq_of_eq
              rw [←ih]
              rfl
            · rfl
      next h0 =>
        have : count p = count (fun i => p (succ i)) := by
          simp_arith only [count, sum, if_neg h0]; rfl
        match k, i with
        | ⟨_, _⟩, ⟨⟨0, _⟩, _⟩ => contradiction
        | ⟨k, hk⟩, ⟨⟨i+1, hi⟩, hp⟩ =>
          apply Fin.eq
          simp only [encodeSubtype, dif_neg h0, val_ndrec]
          clean at h
          transitivity (Fin.mk k (this ▸ hk)).val
          · apply Fin.val_eq_of_eq
            rw [←ih]
            cases h
            rfl
          · rfl
    · intro h
      simp only [decodeSubtype]
      split
      next h0 =>
        have : count p = count (fun i => p (succ i)) + 1 := by
          simp_arith only [count, sum, if_pos h0]; rfl
        split
        next heq _ =>
          match k, i with
          | ⟨_,_⟩, ⟨⟨0,_⟩, _⟩ => rfl
          | ⟨k,hk⟩, ⟨⟨i+1,hi⟩, hp⟩ =>
            cases heq
            simp only [encodeSubtype, dif_pos h0] at h
            have h := val_eq_of_eq h
            rw [val_ndrec] at h
            contradiction
        next k' hk' heq _ =>
          match k, i with
          | ⟨_,_⟩, ⟨⟨0, _⟩, _⟩ =>
            simp only [encodeSubtype] at h
            cases h
            contradiction
          | ⟨k,hk⟩, ⟨⟨i+1, hi⟩, hp⟩ =>
            cases heq
            have : decodeSubtype (fun i => p (succ i)) ⟨k', Nat.lt_of_succ_lt_succ' (this ▸ hk')⟩ = ⟨⟨i, Nat.lt_of_succ_lt_succ hi⟩, hp⟩ := by
              rw [ih]
              simp only [encodeSubtype, dif_pos h0] at h
              let h := val_eq_of_eq h
              rw [val_ndrec] at h
              cases h
              rfl
            congr
            transitivity (⟨⟨i, Nat.lt_of_succ_lt_succ hi⟩, hp⟩ : { i // p (succ i) }).val.val
            · apply congrArg Fin.val
              apply congrArg Subtype.val
              rw [ih]
              have h := Fin.val_eq_of_eq h
              simp only [encodeSubtype, dif_pos h0, val_ndrec] at h
              cases h
              rfl
            · rfl
      next h0 =>
        match k, i with
        | ⟨k, hk⟩, ⟨⟨0, _⟩, hp⟩ =>
          contradiction
        | ⟨k, hk⟩, ⟨⟨i+1, hi⟩, hp⟩ =>
          congr
          transitivity (⟨⟨i, Nat.lt_of_succ_lt_succ hi⟩, hp⟩ : { i // p (succ i) }).val.val
          · apply congrArg Fin.val
            apply congrArg Subtype.val
            rw [ih]
            apply Fin.eq
            have h := Fin.val_eq_of_eq h
            simp only [encodeSubtype, dif_neg h0, val_ndrec] at h
            cases h
            rfl
          · rfl

def equivSubtype (p : Fin n → Prop) [DecidablePred p] : Equiv (Fin (count p)) { i // p i } where
  fwd := decodeSubtype p
  rev := encodeSubtype p
  spec {k x} := specSubtype p k x

abbrev repr (s : Setoid (Fin n)) [DecidableRel s.r] (i : Fin n) : Prop := Fin.find? (s.r i) = some i

def quot (s : Setoid (Fin n)) [DecidableRel s.r] : Nat := count (repr s)

private def getRepr (s : Setoid (Fin n)) [DecidableRel s.r] (i : Fin n) : Fin (quot s) :=
    match h : Fin.find? (s.r i) with
    | some j =>
      have : repr s j := by
        have hij := of_decide_eq_true <| Fin.find?_some _ h
        unfold repr
        rw [←h]
        congr
        funext k
        rw [decide_eq_decide]
        constr
        · intro hjk
          transitivity j
          · exact hij
          · exact hjk
        · intro hik
          transitivity i
          · symmetry
            exact hij
          · exact hik
      encodeSubtype (repr s) ⟨j, this⟩
    | none => absurd (Fin.find?_none i h) $ by
      rw [decide_eq_false_iff_not]
      intro h
      apply h
      exact Setoid.refl ..

private theorem getRepr_eq_getRepr_of_equiv (s : Setoid (Fin n)) [DecidableRel s.r] {{i j : Fin n}} : s.r i j → getRepr s i = getRepr s j := by
  intro hij
  unfold getRepr
  split
  next i' hi' =>
    split
    next j' hj' =>
      clean
      congr
      apply Option.some.inj
      rw [←hi', ←hj']
      congr
      funext k
      rw [decide_eq_decide]
      constr
      · intro hik
        transitivity i
        · symmetry
          exact hij
        · exact hik
      · intro hjk
        transitivity j
        · exact hij
        · exact hjk
    next h =>
      absurd (Fin.find?_none j h)
      rw [decide_eq_false_iff_not]
      intro h
      apply h
      exact Setoid.refl ..
  next h =>
    absurd (Fin.find?_none i h)
    rw [decide_eq_false_iff_not]
    intro h
    apply h
    exact Setoid.refl ..

private theorem subtype_eq_of_val_equiv_val (s : Setoid (Fin n)) [DecidableRel s.r] {{i j : Subtype (repr s)}} : s.r i.val j.val → i = j := by
  intro hij
  match i, j with
  | ⟨i, hri⟩, ⟨j, hrj⟩ =>
    unfold repr at hri hrj
    apply Subtype.eq
    apply Option.some.inj
    rw [←hri, ←hrj]
    congr
    funext k
    rw [decide_eq_decide]
    constr
    · intro hik
      transitivity i
      · symmetry
        exact hij
      · exact hik
    · intro hjk
      transitivity j
      · exact hij
      · exact hjk

def encodeQuotient (s : Setoid (Fin n)) [DecidableRel s.r] (i : Quotient s) : Fin (quot s) :=
  Quotient.liftOn i (getRepr s) (getRepr_eq_getRepr_of_equiv s)

def decodeQuotient (s : Setoid (Fin n)) [DecidableRel s.r] (i : Fin (quot s)) : Quotient s :=
  Quotient.mk s (decodeSubtype (repr s) i)

theorem specQuotient (s : Setoid (Fin n)) [DecidableRel s.r] (k : Fin (quot s)) (i : Quotient s) :
  decodeQuotient s k = i ↔ encodeQuotient s i = k := by
  induction i using Quotient.inductionOn with
  | _ i =>
  unfold decodeQuotient encodeQuotient
  constr
  · intro h
    have h := Quotient.exact h
    transitivity (getRepr s i)
    · rfl
    · unfold getRepr
      split
      next j hj =>
        rw [←specSubtype]
        have hij := of_decide_eq_true (Fin.find?_some j hj)
        apply subtype_eq_of_val_equiv_val
        transitivity i
        · exact h
        · exact hij
      next hnone =>
        absurd (Fin.find?_none i hnone)
        rw [decide_eq_false_iff_not]
        intro h
        apply h
        exact Setoid.refl ..
  · intro h
    have h : getRepr s i = k := h
    apply Quotient.sound
    unfold getRepr at h
    split at h
    next j hj =>
      rw [←specSubtype] at h
      rw [h]
      symmetry
      apply of_decide_eq_true
      exact Fin.find?_some j hj
    next hnone =>
      absurd (Fin.find?_none i hnone)
      rw [decide_eq_false_iff_not]
      intro h
      apply h
      exact Setoid.refl ..

def equivQuotient (s : Setoid (Fin n)) [DecidableRel s.r] : Equiv (Fin (quot s)) (Quotient s) where
  fwd := decodeQuotient s
  rev := encodeQuotient s
  spec {k i} := specQuotient s k i

end Fin


import linear_algebra.finsupp_vector_space
import linear_algebra.free_module.finite.basic

import polyhedral_lattice.basic

/-!

# Hom(ι, Λ) for Λ a polyhedral lattice

If Λ is a polyhedral lattice and ι is a finite type, then ι → Λ is a polyhedral lattice.

## Implementation issue

We use `ι →₀ Λ` rather than `ι → Λ` to make life easier with sums.

-/
noncomputable theory

open_locale big_operators classical

variables (ι Λ : Type*)

namespace finsupp

section normed_add_comm_group

variables [normed_add_comm_group Λ]

instance : has_norm (ι →₀ Λ) := ⟨λ x, x.sum $ λ _, norm⟩

variables {ι Λ}

lemma norm_def (x : ι →₀ Λ) : ∥x∥ = x.sum (λ _, norm) := rfl

@[simp] lemma norm_single (i : ι) (l : Λ) : ∥single i l∥ = ∥l∥ :=
by simp only [norm_def, sum_single_index, norm_zero]

variables (ι Λ)

instance [fintype ι] : normed_add_comm_group (ι →₀ Λ) :=
normed_add_comm_group.of_core _ $
{ norm_eq_zero_iff := λ x,
  begin
    simp only [norm_def, sum, ← coe_nnnorm, ← nnreal.coe_sum, nnreal.coe_eq_zero, coe_zero,
      finset.sum_eq_zero_iff, nnnorm_eq_zero, mem_support_iff, ext_iff, pi.zero_apply, not_imp_self]
  end,
  triangle :=
  begin
    intros x y,
    have aux := λ z : ι →₀ Λ, @sum_fintype ι Λ _ _ _ _ z (λ i, norm) (λ i, norm_zero),
    simp only [norm_def, aux, ← finset.sum_add_distrib, add_apply],
    apply finset.sum_le_sum,
    rintro i -,
    apply norm_add_le,
  end,
  norm_neg := λ x,
  begin
    have aux := λ z : ι →₀ Λ, @sum_fintype ι Λ _ _ _ _ z (λ i, norm) (λ i, norm_zero),
    simp only [norm_def, aux, norm_neg, neg_apply]
  end }

variables {ι Λ}

lemma nnnorm_def [fintype ι] (x : ι →₀ Λ) : ∥x∥₊ = x.sum (λ _, nnnorm) :=
begin
  ext,
  simpa only [coe_nnnorm, finsupp.sum, nnreal.coe_sum] using norm_def x,
end

end normed_add_comm_group

end finsupp

namespace generates_norm

open finsupp

variables [polyhedral_lattice Λ]
variables {J : Type*} (x : J → Λ)

def finsupp_generators : ι × J → (ι →₀ Λ) := λ j, single j.1 (x j.2)

variables {Λ x} [fintype J] (hx : generates_norm x)

include hx

lemma finsupp [fintype ι] : generates_norm (finsupp_generators ι Λ x) :=
begin
  dsimp only [finsupp_generators],
  intro l,
  have := λ i, hx (l i),
  choose c H1 H2 using this,
  have hl : l = ∑ i, single i (l i),
  { conv_lhs { rw [← sum_single l, finsupp.sum] },
    apply finset.sum_subset (finset.subset_univ _),
    rintro i - hi,
    rw not_mem_support_iff at hi,
    rw [hi, single_zero] },
  simp only [← single_add_hom_apply, ← add_monoid_hom.map_nsmul] at hl ⊢,
  refine ⟨λ j, c j.1 j.2, _, _⟩,
  { simp only [H1, add_monoid_hom.map_sum] at hl,
    rw [hl, ← finset.univ_product_univ, finset.sum_product] },
  { have aux := λ z : ι →₀ Λ, @sum_fintype ι Λ _ _ _ _ z (λ i, norm) (λ i, norm_zero),
    simp only [norm_def, aux, ← finset.univ_product_univ, finset.sum_product, H2,
      single_add_hom_apply, norm_single], }
end

end generates_norm

namespace finsupp

variables [polyhedral_lattice Λ]

instance {ι : Type} [fintype ι] : polyhedral_lattice (ι →₀ Λ) :=
{ finite := module.finite.of_basis (finsupp.basis (λ i, module.free.choose_basis ℤ Λ)),
  free := module.free.of_basis (finsupp.basis (λ i, module.free.choose_basis ℤ Λ)),
  polyhedral' :=
  begin
    obtain ⟨J, _instJ, x, hx⟩ := polyhedral_lattice.polyhedral' Λ, resetI,
    refine ⟨ι × J, infer_instance, λ j, single j.1 (x j.2), _⟩,
    exact hx.finsupp _
  end }

end finsupp


-- 5.8 Exercises
-- #1

-- 4.6 Exercises
-- #3

variables (men : Type*) (barber : men)
variable  (shaves : men → men → Prop)

open classical

example (h : ∀ x : men, shaves barber x ↔ ¬ shaves x x) :
  false :=
begin
  have hb := h barber,
  cases hb with h1 h2,
  cases (em (shaves barber barber)) with hsbb hnsbb,
    have hnsbb := h1 hsbb,
    contradiction,
  have hsbb := h2 hnsbb,
  contradiction,
end


/-
Copyright (c) 2020 Adam Topaz. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Zhangir Azerbayev, Adam Topaz, Eric Wieser
-/

import algebra.ring_quot
import linear_algebra.tensor_algebra
import linear_algebra.alternating
import group_theory.perm.sign

/-!
# Exterior Algebras

We construct the exterior algebra of a module `M` over a commutative semiring `R`.

## Notation

The exterior algebra of the `R`-module `M` is denoted as `exterior_algebra R M`.
It is endowed with the structure of an `R`-algebra.

Given a linear morphism `f : M → A` from a module `M` to another `R`-algebra `A`, such that
`cond : ∀ m : M, f m * f m = 0`, there is a (unique) lift of `f` to an `R`-algebra morphism,
which is denoted `exterior_algebra.lift R f cond`.

The canonical linear map `M → exterior_algebra R M` is denoted `exterior_algebra.ι R`.

## Theorems

The main theorems proved ensure that `exterior_algebra R M` satisfies the universal property
of the exterior algebra.
1. `ι_comp_lift` is  fact that the composition of `ι R` with `lift R f cond` agrees with `f`.
2. `lift_unique` ensures the uniqueness of `lift R f cond` with respect to 1.

## Definitions

* `ι_multi` is the `alternating_map` corresponding to the wedge product of `ι R m` terms.

## Implementation details

The exterior algebra of `M` is constructed as a quotient of the tensor algebra, as follows.
1. We define a relation `exterior_algebra.rel R M` on `tensor_algebra R M`.
   This is the smallest relation which identifies squares of elements of `M` with `0`.
2. The exterior algebra is the quotient of the tensor algebra by this relation.

-/

universes u1 u2 u3

variables (R : Type u1) [comm_semiring R]
variables (M : Type u2) [add_comm_monoid M] [module R M]

namespace exterior_algebra
open tensor_algebra

/-- `rel` relates each `ι m * ι m`, for `m : M`, with `0`.

The exterior algebra of `M` is defined as the quotient modulo this relation.
-/
inductive rel : tensor_algebra R M → tensor_algebra R M → Prop
| of (m : M) : rel ((ι R m) * (ι R m)) 0

end exterior_algebra

/--
The exterior algebra of an `R`-module `M`.
-/
@[derive [inhabited, semiring, algebra R]]
def exterior_algebra := ring_quot (exterior_algebra.rel R M)

namespace exterior_algebra

variables {M}

instance {S : Type u3} [comm_ring S] [module S M] : ring (exterior_algebra S M) :=
ring_quot.ring (exterior_algebra.rel S M)

/--
The canonical linear map `M →ₗ[R] exterior_algebra R M`.
-/
def ι : M →ₗ[R] exterior_algebra R M :=
(ring_quot.mk_alg_hom R _).to_linear_map.comp (tensor_algebra.ι R)

variables {R}

/-- As well as being linear, `ι m` squares to zero -/
@[simp]
theorem ι_sq_zero (m : M) : (ι R m) * (ι R m) = 0 :=
begin
  erw [←alg_hom.map_mul, ring_quot.mk_alg_hom_rel R (rel.of m), alg_hom.map_zero _],
end

variables {A : Type*} [semiring A] [algebra R A]

@[simp]
theorem comp_ι_sq_zero (g : exterior_algebra R M →ₐ[R] A)
  (m : M) : g (ι R m) * g (ι R m) = 0 :=
by rw [←alg_hom.map_mul, ι_sq_zero, alg_hom.map_zero]

variables (R)

/--
Given a linear map `f : M →ₗ[R] A` into an `R`-algebra `A`, which satisfies the condition:
`cond : ∀ m : M, f m * f m = 0`, this is the canonical lift of `f` to a morphism of `R`-algebras
from `exterior_algebra R M` to `A`.
-/
@[simps symm_apply]
def lift : {f : M →ₗ[R] A // ∀ m, f m * f m = 0} ≃ (exterior_algebra R M →ₐ[R] A) :=
{ to_fun := λ f,
  ring_quot.lift_alg_hom R ⟨tensor_algebra.lift R (f : M →ₗ[R] A),
    λ x y (h : rel R M x y), by {
      induction h,
      rw [alg_hom.map_zero, alg_hom.map_mul, tensor_algebra.lift_ι_apply, f.prop] }⟩,
  inv_fun := λ F, ⟨F.to_linear_map.comp (ι R), λ m, by rw [
    linear_map.comp_apply, alg_hom.to_linear_map_apply, comp_ι_sq_zero]⟩,
  left_inv := λ f, by { ext, simp [ι] },
  right_inv := λ F, by { ext, simp [ι] } }

@[simp]
theorem ι_comp_lift (f : M →ₗ[R] A) (cond : ∀ m, f m * f m = 0) :
  (lift R ⟨f, cond⟩).to_linear_map.comp (ι R) = f :=
(subtype.mk_eq_mk.mp $ (lift R).symm_apply_apply ⟨f, cond⟩)

@[simp]
theorem lift_ι_apply (f : M →ₗ[R] A) (cond : ∀ m, f m * f m = 0) (x) :
  lift R ⟨f, cond⟩ (ι R x) = f x :=
(linear_map.ext_iff.mp $ ι_comp_lift R f cond) x

@[simp]
theorem lift_unique (f : M →ₗ[R] A) (cond : ∀ m, f m * f m = 0)
  (g : exterior_algebra R M →ₐ[R] A) : g.to_linear_map.comp (ι R) = f ↔ g = lift R ⟨f, cond⟩ :=
begin
  convert (lift R).symm_apply_eq,
  rw lift_symm_apply,
  simp only,
end

attribute [irreducible] ι lift
-- Marking `exterior_algebra` irreducible makes our `ring` instances inaccessible.
-- https://leanprover.zulipchat.com/#narrow/stream/113488-general/topic/algebra.2Esemiring_to_ring.20breaks.20semimodule.20typeclass.20lookup/near/212580241
-- For now, we avoid this by not marking it irreducible.

variables {R M}

@[simp]
theorem lift_comp_ι (g : exterior_algebra R M →ₐ[R] A) :
  lift R ⟨g.to_linear_map.comp (ι R), comp_ι_sq_zero _⟩ = g :=
begin
  convert (lift R).apply_symm_apply g,
  rw lift_symm_apply,
  refl,
end

/-- See note [partially-applied ext lemmas]. -/
@[ext]
theorem hom_ext {f g : exterior_algebra R M →ₐ[R] A}
  (h : f.to_linear_map.comp (ι R) = g.to_linear_map.comp (ι R)) : f = g :=
begin
  apply (lift R).symm.injective,
  rw [lift_symm_apply, lift_symm_apply],
  simp only [h],
end

/-- If `C` holds for the `algebra_map` of `r : R` into `exterior_algebra R M`, the `ι` of `x : M`,
and is preserved under addition and muliplication, then it holds for all of `exterior_algebra R M`.
-/
-- This proof closely follows `tensor_algebra.induction`
@[elab_as_eliminator]
lemma induction {C : exterior_algebra R M → Prop}
  (h_grade0 : ∀ r, C (algebra_map R (exterior_algebra R M) r))
  (h_grade1 : ∀ x, C (ι R x))
  (h_mul : ∀ a b, C a → C b → C (a * b))
  (h_add : ∀ a b, C a → C b → C (a + b))
  (a : exterior_algebra R M) :
  C a :=
begin
  -- the arguments are enough to construct a subalgebra, and a mapping into it from M
  let s : subalgebra R (exterior_algebra R M) := {
    carrier := C,
    mul_mem' := h_mul,
    add_mem' := h_add,
    algebra_map_mem' := h_grade0, },
  let of : { f : M →ₗ[R] s // ∀ m, f m * f m = 0 } :=
  ⟨(ι R).cod_restrict s.to_submodule h_grade1,
    λ m, subtype.eq $ ι_sq_zero m ⟩,
  -- the mapping through the subalgebra is the identity
  have of_id : alg_hom.id R (exterior_algebra R M) = s.val.comp (lift R of),
  { ext,
    simp [of], },
  -- finding a proof is finding an element of the subalgebra
  convert subtype.prop (lift R of a),
  exact alg_hom.congr_fun of_id a,
end

/-- The left-inverse of `algebra_map`. -/
def algebra_map_inv : exterior_algebra R M →ₐ[R] R :=
exterior_algebra.lift R ⟨(0 : M →ₗ[R] R), λ m, by simp⟩

lemma algebra_map_left_inverse :
  function.left_inverse algebra_map_inv (algebra_map R $ exterior_algebra R M) :=
λ x, by simp [algebra_map_inv]

/-- The left-inverse of `ι`.

As an implementation detail, we implement this using `triv_sq_zero_ext` which has a suitable
algebra structure. -/
def ι_inv : exterior_algebra R M →ₗ[R] M :=
(triv_sq_zero_ext.snd_hom R M).comp
  (lift R ⟨triv_sq_zero_ext.inr_hom R M, λ m, triv_sq_zero_ext.inr_mul_inr R _ m m⟩).to_linear_map

lemma ι_left_inverse : function.left_inverse ι_inv (ι R : M → exterior_algebra R M) :=
λ x, by simp [ι_inv]

@[simp]
lemma ι_add_mul_swap (x y : M) : ι R x * ι R y + ι R y * ι R x = 0 :=
calc _ = ι R (x + y) * ι R (x + y) : by simp [mul_add, add_mul]
   ... = _ : ι_sq_zero _

lemma ι_mul_prod_list {n : ℕ} (f : fin n → M) (i : fin n) :
  (ι R $ f i) * (list.of_fn $ λ i, ι R $ f i).prod = 0 :=
begin
  induction n with n hn,
  { exact i.elim0, },
  { rw [list.of_fn_succ, list.prod_cons, ←mul_assoc],
    by_cases h : i = 0,
    { rw [h, ι_sq_zero, zero_mul], },
    { replace hn := congr_arg ((*) $ ι R $ f 0) (hn (λ i, f $ fin.succ i) (i.pred h)),
      simp only at hn,
      rw [fin.succ_pred, ←mul_assoc, mul_zero] at hn,
      refine (eq_zero_iff_eq_zero_of_add_eq_zero _).mp hn,
      rw [← add_mul, ι_add_mul_swap, zero_mul], } }
end

variables (R)
/-- The product of `n` terms of the form `ι R m` is an alternating map.

This is a special case of `multilinear_map.mk_pi_algebra_fin` -/
def ι_multi (n : ℕ) :
  alternating_map R M (exterior_algebra R M) (fin n) :=
let F := (multilinear_map.mk_pi_algebra_fin R n (exterior_algebra R M)).comp_linear_map (λ i, ι R)
in
{ map_eq_zero_of_eq' := λ f x y hfxy hxy, begin
    rw [multilinear_map.comp_linear_map_apply, multilinear_map.mk_pi_algebra_fin_apply],
    wlog h : x < y := lt_or_gt_of_ne hxy using x y,
    clear hxy,
    induction n with n hn generalizing x y,
    { exact x.elim0, },
    { rw [list.of_fn_succ, list.prod_cons],
      by_cases hx : x = 0,
      -- one of the repeated terms is on the left
      { rw hx at hfxy h,
        rw [hfxy, ←fin.succ_pred y (ne_of_lt h).symm],
        exact ι_mul_prod_list (f ∘ fin.succ) _, },
      -- ignore the left-most term and induct on the remaining ones, decrementing indices
      { convert mul_zero _,
        refine hn (λ i, f $ fin.succ i)
          (x.pred hx) (y.pred (ne_of_lt $ lt_of_le_of_lt x.zero_le h).symm)
          (fin.pred_lt_pred_iff.mpr h) _,
        simp only [fin.succ_pred],
        exact hfxy, } }
  end,
  to_fun := F, ..F}
variables {R}

lemma ι_multi_apply {n : ℕ} (v : fin n → M) :
  ι_multi R n v = (list.of_fn $ λ i, ι R (v i)).prod := rfl

end exterior_algebra

namespace tensor_algebra

variables {R M}

/-- The canonical image of the `tensor_algebra` in the `exterior_algebra`, which maps
`tensor_algebra.ι R x` to `exterior_algebra.ι R x`. -/
def to_exterior : tensor_algebra R M →ₐ[R] exterior_algebra R M :=
tensor_algebra.lift R (exterior_algebra.ι R)

@[simp] lemma to_exterior_ι (m : M) : (tensor_algebra.ι R m).to_exterior = exterior_algebra.ι R m :=
by simp [to_exterior]

end tensor_algebra


/-
Copyright (c) 2022 Robert Y. Lewis. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Robert Y. Lewis, Heather Macbeth, Johan Commelin

! This file was ported from Lean 3 source module ring_theory.witt_vector.discrete_valuation_ring
! leanprover-community/mathlib commit 4e1eeebe63ac6d44585297e89c6e7ee5cbda487a
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.RingTheory.WittVector.Domain
import Mathbin.RingTheory.WittVector.MulCoeff
import Mathbin.RingTheory.DiscreteValuationRing
import Mathbin.Tactic.LinearCombination

/-!

# Witt vectors over a perfect ring

This file establishes that Witt vectors over a perfect field are a discrete valuation ring.
When `k` is a perfect ring, a nonzero `a : 𝕎 k` can be written as `p^m * b` for some `m : ℕ` and
`b : 𝕎 k` with nonzero 0th coefficient.
When `k` is also a field, this `b` can be chosen to be a unit of `𝕎 k`.

## Main declarations

* `witt_vector.exists_eq_pow_p_mul`: the existence of this element `b` over a perfect ring
* `witt_vector.exists_eq_pow_p_mul'`: the existence of this unit `b` over a perfect field
* `witt_vector.discrete_valuation_ring`: `𝕎 k` is a discrete valuation ring if `k` is a perfect
    field

-/

noncomputable section

namespace WittVector

variable {p : ℕ} [hp : Fact p.Prime]

include hp

-- mathport name: expr𝕎
local notation "𝕎" => WittVector p

section CommRing

variable {k : Type _} [CommRing k] [CharP k p]

/-- This is the `n+1`st coefficient of our inverse. -/
def succNthValUnits (n : ℕ) (a : Units k) (A : 𝕎 k) (bs : Fin (n + 1) → k) : k :=
  -↑(a⁻¹ ^ p ^ (n + 1)) *
    (A.coeff (n + 1) * ↑(a⁻¹ ^ p ^ (n + 1)) + nthRemainder p n (truncateFun (n + 1) A) bs)
#align witt_vector.succ_nth_val_units WittVector.succNthValUnits

/--
Recursively defines the sequence of coefficients for the inverse to a Witt vector whose first entry
is a unit.
-/
noncomputable def inverseCoeff (a : Units k) (A : 𝕎 k) : ℕ → k
  | 0 => ↑a⁻¹
  | n + 1 => succNthValUnits n a A fun i => inverse_coeff i.val decreasing_by apply Fin.is_lt
#align witt_vector.inverse_coeff WittVector.inverseCoeff

/--
Upgrade a Witt vector `A` whose first entry `A.coeff 0` is a unit to be, itself, a unit in `𝕎 k`.
-/
def mkUnit {a : Units k} {A : 𝕎 k} (hA : A.coeff 0 = a) : Units (𝕎 k) :=
  Units.mkOfMulEqOne A (WittVector.mk p (inverseCoeff a A))
    (by
      ext n
      induction' n with n ih
      · simp [WittVector.mul_coeff_zero, inverse_coeff, hA]
      let H_coeff :=
        A.coeff (n + 1) * ↑(a⁻¹ ^ p ^ (n + 1)) +
          nth_remainder p n (truncate_fun (n + 1) A) fun i : Fin (n + 1) => inverse_coeff a A i
      have H := Units.mul_inv (a ^ p ^ (n + 1))
      linear_combination (norm := skip) -H_coeff * H
      have ha : (a : k) ^ p ^ (n + 1) = ↑(a ^ p ^ (n + 1)) := by norm_cast
      have ha_inv : (↑a⁻¹ : k) ^ p ^ (n + 1) = ↑(a ^ p ^ (n + 1))⁻¹ := by exact_mod_cast inv_pow _ _
      simp only [nth_remainder_spec, inverse_coeff, succ_nth_val_units, hA, [anonymous],
        one_coeff_eq_of_pos, Nat.succ_pos', H_coeff, ha_inv, ha, inv_pow]
      ring!)
#align witt_vector.mk_unit WittVector.mkUnit

@[simp]
theorem coe_mkUnit {a : Units k} {A : 𝕎 k} (hA : A.coeff 0 = a) : (mkUnit hA : 𝕎 k) = A :=
  rfl
#align witt_vector.coe_mk_unit WittVector.coe_mkUnit

end CommRing

section Field

variable {k : Type _} [Field k] [CharP k p]

theorem isUnit_of_coeff_zero_ne_zero (x : 𝕎 k) (hx : x.coeff 0 ≠ 0) : IsUnit x :=
  by
  let y : kˣ := Units.mk0 (x.coeff 0) hx
  have hy : x.coeff 0 = y := rfl
  exact (mk_unit hy).IsUnit
#align witt_vector.is_unit_of_coeff_zero_ne_zero WittVector.isUnit_of_coeff_zero_ne_zero

variable (p)

theorem irreducible : Irreducible (p : 𝕎 k) :=
  by
  have hp : ¬IsUnit (p : 𝕎 k) := by
    intro hp
    simpa only [constant_coeff_apply, coeff_p_zero, not_isUnit_zero] using
      (constant_coeff : WittVector p k →+* _).isUnit_map hp
  refine' ⟨hp, fun a b hab => _⟩
  obtain ⟨ha0, hb0⟩ : a ≠ 0 ∧ b ≠ 0 := by
    rw [← mul_ne_zero_iff]
    intro h
    rw [h] at hab
    exact p_nonzero p k hab
  obtain ⟨m, a, ha, rfl⟩ := verschiebung_nonzero ha0
  obtain ⟨n, b, hb, rfl⟩ := verschiebung_nonzero hb0
  cases m
  · exact Or.inl (is_unit_of_coeff_zero_ne_zero a ha)
  cases n
  · exact Or.inr (is_unit_of_coeff_zero_ne_zero b hb)
  rw [iterate_verschiebung_mul] at hab
  apply_fun fun x => coeff x 1  at hab
  simp only [coeff_p_one, Nat.add_succ, add_comm _ n, Function.iterate_succ', Function.comp_apply,
    verschiebung_coeff_add_one, verschiebung_coeff_zero] at hab
  exact (one_ne_zero hab).elim
#align witt_vector.irreducible WittVector.irreducible

end Field

section PerfectRing

variable {k : Type _} [CommRing k] [CharP k p] [PerfectRing k p]

theorem exists_eq_pow_p_mul (a : 𝕎 k) (ha : a ≠ 0) :
    ∃ (m : ℕ)(b : 𝕎 k), b.coeff 0 ≠ 0 ∧ a = p ^ m * b :=
  by
  obtain ⟨m, c, hc, hcm⟩ := WittVector.verschiebung_nonzero ha
  obtain ⟨b, rfl⟩ := (frobenius_bijective p k).Surjective.iterate m c
  rw [WittVector.iterate_frobenius_coeff] at hc
  have := congr_fun (witt_vector.verschiebung_frobenius_comm.comp_iterate m) b
  simp only [Function.comp_apply] at this
  rw [← this] at hcm
  refine' ⟨m, b, _, _⟩
  · contrapose! hc
    have : 0 < p ^ m := pow_pos (Nat.Prime.pos (Fact.out _)) _
    simp [hc, zero_pow this]
  · rw [← mul_left_iterate (p : 𝕎 k) m]
    convert hcm
    ext1 x
    rw [mul_comm, ← WittVector.verschiebung_frobenius x]
#align witt_vector.exists_eq_pow_p_mul WittVector.exists_eq_pow_p_mul

end PerfectRing

section PerfectField

variable {k : Type _} [Field k] [CharP k p] [PerfectRing k p]

theorem exists_eq_pow_p_mul' (a : 𝕎 k) (ha : a ≠ 0) : ∃ (m : ℕ)(b : Units (𝕎 k)), a = p ^ m * b :=
  by
  obtain ⟨m, b, h₁, h₂⟩ := exists_eq_pow_p_mul a ha
  let b₀ := Units.mk0 (b.coeff 0) h₁
  have hb₀ : b.coeff 0 = b₀ := rfl
  exact ⟨m, mk_unit hb₀, h₂⟩
#align witt_vector.exists_eq_pow_p_mul' WittVector.exists_eq_pow_p_mul'

/-
Note: The following lemma should be an instance, but it seems to cause some
exponential blowups in certain typeclass resolution problems.
See the following Lean4 issue as well as the zulip discussion linked there:
https://github.com/leanprover/lean4/issues/1102
-/
/-- The ring of Witt Vectors of a perfect field of positive characteristic is a DVR.
-/
theorem discreteValuationRing : DiscreteValuationRing (𝕎 k) :=
  DiscreteValuationRing.of_hasUnitMulPowIrreducibleFactorization
    (by
      refine' ⟨p, Irreducible p, fun x hx => _⟩
      obtain ⟨n, b, hb⟩ := exists_eq_pow_p_mul' x hx
      exact ⟨n, b, hb.symm⟩)
#align witt_vector.discrete_valuation_ring WittVector.discreteValuationRing

end PerfectField

end WittVector


import init.function
import data.set.finite
import init.data.quot
import data.setoid.partition

noncomputable theory
local attribute [instance, priority 100] classical.prop_decidable

------------------------ for mathlib? -------------------------------
namespace finset

universes u v

-- finset equivalent to set.maps_to_image. Similar to: set.maps_to_image f ↑s
theorem maps_to_image {α : Type u} {β : Type v} (f : α → β) (s : finset α) :
set.maps_to f ↑s ↑(finset.image f s) :=
begin
rw set.maps_to',
rw finset.coe_image,
end

end finset

namespace set

universes u v
def func_to_univ {α : Type u} {β : Type v} (f : α → β) : (@set.univ α) → (@set.univ β) :=
set.maps_to.restrict f set.univ set.univ (set.maps_to_univ f set.univ)

end set
---------------------------------------------------------------------

namespace ARA
section ARA
-- The goal is to prove the main ARA result

@[reducible] def mut_compat {att : Type} [setoid att] (Y : set att) : Prop := ∀ x y ∈ Y, x ≈ y
@[reducible] def compat_func {att : Type} [setoid att] {X Y : set att} (φ : X → Y) : Prop := ∀ x : X, (x : att) ≈ ((φ x) : att)

inductive ARAe (rel att : Type) [setoid att] : Type
| relnm (R : rel) : ARAe
| union : ARAe → ARAe → ARAe
| proj (Y : finset att) : ARAe → ARAe
| selection (Y : finset att) (hmutc : mut_compat (↑Y : set att)) : ARAe → ARAe
| rename (φ : att → att) (hinj : function.injective φ) (hc : compat_func (set.func_to_univ φ)) : ARAe → ARAe
| join : ARAe → ARAe → ARAe

parameters {rel att dom : Type} [setoid att]

-- defines schema of an ARA expression
def ARAschema (e : ARAe rel att) (S : rel → finset att) : finset att :=
ARAe.rec_on e S -- relnm
              (λ e1 e2 e1S e2S, e1S ∪ e2S) -- union
              (λ Y e1 e1S, e1S ∩ Y) -- proj
              (λ Y hmutc e1 e1S, e1S) -- selection
              (λ φ hinj hc e1 e1S, finset.image φ e1S) -- rename
              (λ e1 e2 e1S e2S, e1S ∪ e2S) -- join

-- def well typed: union should be on relations with equal schema
def ARA_well_typed (e : ARAe rel att) (S : rel → finset att) : Prop :=
ARAe.rec_on e (λ R, true) -- relnm
              (λ e1 e2 e1W e2W, e1W ∧ e2W ∧ (ARAschema e1 S = ARAschema e2 S)) -- union
              (λ Y e1 e1W, e1W) -- proj
              (λ Y hmutc e1 e1W, e1W) -- selection
              (λ φ hinj hc e1 e1W, e1W) -- rename
              (λ e1 e2 e1W e2W, e1W ∧ e2W) -- join

-- def semantics
def dom_assign := quotient _inst_1 → finset dom -- not assumed that assigned domain is nonempty

@[reducible] def tuple (D : dom_assign) (X : finset att) := Π (A : (↑X : set att)), (↑(D⟦A⟧) : set dom)

structure relation (D : dom_assign) (α : Type) :=
(schema : finset att)
(rel : tuple D schema → α)

/-
structure db_instance (D : dom_assign) (S : rel → finset att) (α : Type) :=
(dbI : rel → relation D α)
(schema_respect : (∀ R : rel, (dbI R).schema = S R))
-/

def db_instance (D : dom_assign) (S : rel → finset att) (α : Type) := Π R : rel, tuple D (S R) → α

def db_instance_to_rel {D : dom_assign} {S : rel → finset att} {α : Type} (I : db_instance D S α) :
rel → relation D α :=
(λ R,
{
    schema := S R,
    rel := I R
})

variables {D : dom_assign} {α : Type} [semiring α]

theorem inclusion_compat {s t : set att} (h : s ⊆ t) : compat_func (set.inclusion h) :=
begin
intro x, refl,
end

--set_option trace.simplify.rewrite true
theorem restrict_compat {f : att → att} {s t : set att} (h1 : compat_func (set.func_to_univ f)) (h2 : set.maps_to f s t) :
compat_func (set.maps_to.restrict f s t h2) :=
begin
intro x, unfold compat_func at h1, rw set_coe.forall at h1, apply h1, exact trivial,
end

theorem compat_att_eq_dom {A B : att} (h: ⟦A⟧ = ⟦B⟧) : ↥(↑(D⟦A⟧) : set dom) = ↥(↑(D⟦B⟧) : set dom) :=
congr rfl (congr_arg coe (congr_arg D h))

theorem mut_compat_eq_dom {Y : set att} (h : mut_compat Y) (A B : Y) : ⟦(A : att)⟧ = ⟦(B : att)⟧ :=
begin
apply quotient.eq_rel.mpr, apply h, cases A, rw subtype.coe_mk, exact A_property, cases B, rw subtype.coe_mk, exact B_property,
end

theorem func_compat_eq_dom {X X' : finset att} {f : (↑X' : set att) → (↑X : set att)} (h : compat_func f)
(A : (↑X' : set att)) : ⟦(f A : att)⟧ = ⟦(A : att)⟧ :=
begin
apply quotient.eq_rel.mpr, unfold compat_func at h, rw set_coe.forall at h, cases A,
exact setoid.symm' _inst_1 (h A_val A_property),
end

def tuple_comp {D : dom_assign} {X X' : finset att} {f : (↑X' : set att) → (↑X : set att)} (t : tuple D X)
(h : compat_func f) : tuple D X' :=
(λ A, (eq.mp (compat_att_eq_dom (func_compat_eq_dom h A)) (t (f A))))

def relation_mut_eq {D : dom_assign} {X : finset att} {Y : set att} (h : mut_compat Y) (t : tuple D X) : Prop :=
(∀ A B : (↑X) ∩ Y,
let fil := (set.inclusion (set.inter_subset_left ↑X Y)) in
let fir := (set.inclusion (set.inter_subset_right ↑X Y)) in
(eq.mp (compat_att_eq_dom (mut_compat_eq_dom h (fir A) (fir B))) (t (fil A))) = t (fil B))

--set_option pp.implicit true
--set_option pp.coercions true

def rel_one (X : finset att) : relation D α :=
{
    schema := X,
    rel := (λ t, 1)
}
def rel_union (r r' : relation D α) : relation D α :=
{
    schema := r.schema ∪ r'.schema,
    rel := (λ t, r.rel(tuple_comp t (inclusion_compat (finset.subset_union_left r.schema r'.schema))) +
                  r'.rel(tuple_comp t (inclusion_compat (finset.subset_union_right r.schema r'.schema))))
}
def rel_proj (r : relation D α) (Y : finset att) (hfin : fintype (tuple D r.schema)) : relation D α :=
{
    schema := r.schema ∩ Y,
    rel := (λ t, finset.sum (set.finite.to_finset (set.finite.of_fintype -- use new finsum API
           {t' : tuple D r.schema | t = tuple_comp t' (inclusion_compat (finset.inter_subset_left r.schema Y))}
           )) r.rel)
}
def rel_selection (r : relation D α) (Y : finset att) (h : mut_compat ↑Y) : relation D α :=
{
    schema := r.schema,
    rel := (λ t, if relation_mut_eq h t then (r.rel t) else 0)
}
def rel_rename (r : relation D α) (φ : att → att) (h : (compat_func (set.func_to_univ φ))) : relation D α :=
{
    schema := finset.image φ r.schema,
    rel := (λ t, r.rel(tuple_comp t (restrict_compat h (finset.maps_to_image φ r.schema))))
}
def rel_join (r r' : relation D α) : relation D α :=
{
    schema := r.schema ∪ r'.schema,
    rel := (λ t, r.rel(tuple_comp t (inclusion_compat (finset.subset_union_left r.schema r'.schema))) *
                  r'.rel(tuple_comp t (inclusion_compat (finset.subset_union_right r.schema r'.schema))))
}

-- TODO: add usual notation for the above operations

/- possibly remove -/
def bundle_rel {D : dom_assign} {α : Type} {schema : finset att} (rel : tuple D schema → α) :
relation D α :=
{
    schema := schema,
    rel := rel
}

/- possibly remove -/
def ARA_output_with_schema (e : ARAe rel att) (S : rel → finset att) (I : db_instance D S α) :
tuple D (ARAschema e S) → α :=
ARAe.rec_on e I -- relnm
              (λ e1 e2 e1W e2W, (rel_union (bundle_rel e1W) (bundle_rel e2W)).rel) -- union
              (λ Y e1 e1W, (rel_proj (bundle_rel e1W) Y pi.fintype).rel) -- proj
              (λ Y hmutc e1 e1W, (rel_selection (bundle_rel e1W) Y hmutc).rel) -- selection
              (λ φ hinj hc e1 e1W, (rel_rename (bundle_rel e1W) φ hc).rel) -- rename
              (λ e1 e2 e1W e2W, (rel_join (bundle_rel e1W) (bundle_rel e2W)).rel) -- join

-- Note: we define semantics without assuming well-typedness.
-- This requires rel_union to be defined above in a more general setting.
def ARA_output (e : ARAe rel att) (S : rel → finset att) (I : db_instance D S α) : relation D α :=
ARAe.rec_on e (db_instance_to_rel I) -- relnm
              (λ e1 e2 e1W e2W, rel_union e1W e2W) -- union
              (λ Y e1 e1W, rel_proj e1W Y pi.fintype) -- proj
              (λ Y hmutc e1 e1W, rel_selection e1W Y hmutc) -- selection
              (λ φ hinj hc e1 e1W, rel_rename e1W φ hc) -- rename
              (λ e1 e2 e1W e2W, rel_join e1W e2W) -- join

-- Prove that output relation has schema ARAschema e S
theorem ARA_sound_schema (e : ARAe rel att) (S : rel → finset att) (I : db_instance D S α) :
(ARA_output e S I).schema = ARAschema e S :=
begin
induction e,
case relnm : {exact rfl},
case union : {
    change (ARA_output (e_a.union e_a_1) S I) with
      rel_union (ARA_output (e_a) S I) (ARA_output (e_a_1) S I),
    change (ARAschema (e_a.union e_a_1) S) with (ARAschema e_a S) ∪ (ARAschema e_a_1 S),
    unfold rel_union,
    rw [← e_ih_a, ← e_ih_a_1],
},
case proj : {
    change (ARA_output (ARAe.proj e_Y e_a) S I) with rel_proj (ARA_output e_a S I) e_Y pi.fintype,
    change (ARAschema (ARAe.proj e_Y e_a) S) with (ARAschema e_a S) ∩ e_Y,
    unfold rel_proj,
    rw [← e_ih],
},
case selection : {exact e_ih},
case rename : {
    change (ARA_output (ARAe.rename e_φ e_hinj e_hc e_a) S I) with rel_rename (ARA_output e_a S I) e_φ e_hc,
    change (ARAschema (ARAe.rename e_φ e_hinj e_hc e_a) S) with finset.image e_φ (ARAschema e_a S),
    unfold rel_rename,
    rw [← e_ih],
},
case join : {
    change (ARA_output (e_a.join e_a_1) S I) with
      rel_join (ARA_output (e_a) S I) (ARA_output (e_a_1) S I),
    change (ARAschema (e_a.join e_a_1) S) with (ARAschema e_a S) ∪ (ARAschema e_a_1 S),
    unfold rel_join,
    rw [← e_ih_a, ← e_ih_a_1],
},
end

theorem rel_union_comm (r r': relation D α) : rel_union r r' = rel_union r' r := sorry

end ARA
end ARA


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

import algebraic_topology.dold_kan.p_infty

/-!

# Decomposition of the Q endomorphisms

In this file, we obtain a lemma `decomposition_Q` which expresses
explicitly the projection `(Q q).f (n+1) : X _[n+1] ⟶ X _[n+1]`
(`X : simplicial_object C` with `C` a preadditive category) as
a sum of terms which are postcompositions with degeneracies.

(TODO @joelriou: when `C` is abelian, define the degenerate
subcomplex of the alternating face map complex of `X` and show
that it is a complement to the normalized Moore complex.)

Then, we introduce an ad hoc structure `morph_components X n Z` which
can be used in order to define morphisms `X _[n+1] ⟶ Z` using the
decomposition provided by `decomposition_Q`. This shall play a critical
role in the proof that the functor
`N₁ : simplicial_object C ⥤ karoubi (chain_complex C ℕ))`
reflects isomorphisms.

-/

open category_theory category_theory.category category_theory.preadditive opposite
open_locale big_operators simplicial

noncomputable theory

namespace algebraic_topology

namespace dold_kan

variables {C : Type*} [category C] [preadditive C] {X X' : simplicial_object C}

/-- In each positive degree, this lemma decomposes the idempotent endomorphism
`Q q` as a sum of morphisms which are postcompositions with suitable degeneracies.
As `Q q` is the complement projection to `P q`, this implies that in the case of
simplicial abelian groups, any $(n+1)$-simplex $x$ can be decomposed as
$x = x' + \sum (i=0}^{q-1} σ_{n-i}(y_i)$ where $x'$ is in the image of `P q` and
the $y_i$ are in degree $n$. -/
lemma decomposition_Q (n q : ℕ) :
  ((Q q).f (n+1) : X _[n+1] ⟶ X _[n+1]) =
  ∑ (i : fin (n+1)) in finset.filter (λ i : fin(n+1), (i:ℕ)<q) finset.univ,
    (P i).f (n+1) ≫ X.δ (i.rev).succ ≫ X.σ i.rev :=
begin
  induction q with q hq,
  { simp only [Q_eq_zero, homological_complex.zero_f_apply, nat.not_lt_zero,
      finset.filter_false, finset.sum_empty], },
  { by_cases hqn : q+1 ≤ n+1, swap,
    { rw [Q_is_eventually_constant (show n+1≤q, by linarith), hq],
      congr,
      ext,
      have hx := x.is_lt,
      simp only [nat.succ_eq_add_one],
      split; intro h; linarith, },
    { cases nat.le.dest (nat.succ_le_succ_iff.mp hqn) with a ha,
      rw [Q_eq, homological_complex.sub_f_apply, homological_complex.comp_f, hq],
      symmetry,
      conv_rhs { rw [sub_eq_add_neg, add_comm], },
      let q' : fin (n+1) := ⟨q, nat.succ_le_iff.mp hqn⟩,
      convert finset.sum_insert ( _ : q' ∉ _),
      { ext i,
        simp only [finset.mem_insert, finset.mem_filter, finset.mem_univ, true_and,
          nat.lt_succ_iff_lt_or_eq, fin.ext_iff],
        tauto, },
      { have hnaq' : n = a+q := by linarith,
        simpa only [fin.coe_mk, (higher_faces_vanish.of_P q n).comp_Hσ_eq hnaq',
          q'.rev_eq hnaq', neg_neg], },
      { simp only [finset.mem_filter, fin.coe_mk, lt_self_iff_false,
            and_false, not_false_iff], }, }, },
end

variable (X)

/-- The structure `morph_components` is an ad hoc structure that is used in
the proof that `N₁ : simplicial_object C ⥤ karoubi (chain_complex C ℕ))`
reflects isomorphisms. The fields are the data that are needed in order to
construct a morphism `X _[n+1] ⟶ Z` (see `φ`) using the decomposition of the
identity given by `decomposition_Q n (n+1)`. -/
@[ext, nolint has_nonempty_instance]
structure morph_components (n : ℕ) (Z : C) :=
(a : X _[n+1] ⟶ Z)
(b : fin (n+1) → (X _[n] ⟶ Z))

namespace morph_components

variables {X} {n : ℕ} {Z Z' : C} (f : morph_components X n Z) (g : X' ⟶ X) (h : Z ⟶ Z')
/-- The morphism `X _[n+1] ⟶ Z ` associated to `f : morph_components X n Z`. -/
def φ {Z : C} (f : morph_components X n Z) : X _[n+1] ⟶ Z :=
P_infty.f (n+1) ≫ f.a + ∑ (i : fin (n+1)), (P i).f (n+1) ≫ X.δ i.rev.succ ≫ f.b i.rev

variables (X n)
/-- the canonical `morph_components` whose associated morphism is the identity
(see `F_id`) thanks to `decomposition_Q n (n+1)` -/
@[simps]
def id : morph_components X n (X _[n+1]) :=
{ a := P_infty.f (n+1),
  b := λ i, X.σ i, }

@[simp] lemma id_φ : (id X n).φ = 𝟙 _ :=
begin
  simp only [← P_add_Q_f (n+1) (n+1), φ],
  congr' 1,
  { simp only [id, P_infty_f, P_f_idem], },
  { convert (decomposition_Q n (n+1)).symm,
    ext i,
    simpa only [finset.mem_univ, finset.mem_filter, true_and, true_iff] using fin.is_lt i, },
end

variables {X n}

/-- A `morph_components` can be postcomposed with a morphism. -/
@[simps]
def post_comp : morph_components X n Z' :=
{ a := f.a ≫ h,
  b := λ i, f.b i ≫ h }

@[simp] lemma post_comp_φ : (f.post_comp h).φ = f.φ ≫ h :=
begin
  unfold φ post_comp,
  simp only [add_comp, sum_comp, assoc],
end

/-- A `morph_components` can be precomposed with a morphism of simplicial objects. -/
@[simps]
def pre_comp : morph_components X' n Z :=
{ a := g.app (op [n+1]) ≫ f.a,
  b := λ i, g.app (op [n]) ≫ f.b i }

@[simp] lemma pre_comp_φ : (f.pre_comp g).φ = g.app (op [n+1]) ≫ f.φ :=
begin
  unfold φ pre_comp,
  simp only [P_infty_f, comp_add],
  congr' 1,
  { simp only [P_f_naturality_assoc], },
  { simp only [comp_sum, P_f_naturality_assoc, simplicial_object.δ_naturality_assoc], }
end

end morph_components

end dold_kan

end algebraic_topology


/-
Copyright (c) 2021 OpenAI. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kunhao Zheng, Stanislas Polu, David Renshaw, OpenAI GPT-f
-/
import mathzoo.imports.miniF2F

open_locale nat rat real big_operators topological_space

theorem mathd_numbertheory_24 :
  (∑ k in (finset.erase (finset.range 10) 0), 11^k) % 100 = 59 :=
begin
  norm_num [finset.sum],
end


/-
Copyright (c) 2020 Kyle Miller All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Kyle Miller.
-/
import tactic.linarith
import data.sym

open function
open sym

/-!
# The symmetric square

This file defines the symmetric square, which is `α × α` modulo
swapping.  This is also known as the type of unordered pairs.

More generally, the symmetric square is the second symmetric power
(see `data.sym`). The equivalence is `sym2.equiv_sym`.

From the point of view that an unordered pair is equivalent to a
multiset of cardinality two (see `sym2.equiv_multiset`), there is a
`has_mem` instance `sym2.mem`, which is a `Prop`-valued membership
test.  Given `a ∈ z` for `z : sym2 α`, it does not appear to be
possible, in general, to *computably* give the other element in the
pair.  For this, `sym2.vmem a z` is a `Type`-valued membership test
that gives a way to obtain the other element with `sym2.vmem.other`.

Recall that an undirected graph (allowing self loops, but no multiple
edges) is equivalent to a symmetric relation on the vertex type `α`.
Given a symmetric relation on `α`, the corresponding edge set is
constructed by `sym2.from_rel`.

## Notation

The symmetric square has a setoid instance, so `⟦(a, b)⟧` denotes a
term of the symmetric square.

## Tags

symmetric square, unordered pairs, symmetric powers
-/

universe u
variables {α : Type u}
namespace sym2

/--
This is the relation capturing the notion of pairs equivalent up to permutations.
-/
inductive rel (α : Type u) : (α × α) → (α × α) → Prop
| refl (x y : α) : rel (x, y) (x, y)
| swap (x y : α) : rel (x, y) (y, x)

attribute [refl] rel.refl

@[symm] lemma rel.symm {x y : α × α} : rel α x y → rel α y x :=
by { rintro ⟨_,_⟩, exact a, apply rel.swap }

@[trans] lemma rel.trans {x y z : α × α} : rel α x y → rel α y z → rel α x z :=
by { intros a b, cases_matching* rel _ _ _; apply rel.refl <|> apply rel.swap }

lemma rel.is_equivalence : equivalence (rel α) := by tidy; apply rel.trans; assumption

instance rel.setoid (α : Type u) : setoid (α × α) := ⟨rel α, rel.is_equivalence⟩

end sym2

/--
`sym2 α` is the symmetric square of `α`, which, in other words, is the
type of unordered pairs.

It is equivalent in a natural way to multisets of cardinality 2 (see
`sym2.equiv_multiset`).
-/
@[reducible]
def sym2 (α : Type u) := quotient (sym2.rel.setoid α)

namespace sym2

lemma eq_swap {a b : α} : ⟦(a, b)⟧ = ⟦(b, a)⟧ :=
by { rw quotient.eq, apply rel.swap }

lemma congr_right (a b c : α) : ⟦(a, b)⟧ = ⟦(a, c)⟧ ↔ b = c :=
by { split; intro h, { rw quotient.eq at h, cases h; refl }, rw h }

/--
The functor `sym2` is functorial, and this function constructs the induced maps.
-/
def map {α β : Type*} (f : α → β) : sym2 α → sym2 β :=
quotient.map (prod.map f f)
  (by { rintros _ _ h, cases h, { refl }, apply rel.swap })

@[simp]
lemma map_id : sym2.map (@id α) = id := by tidy

lemma map_comp {α β γ : Type*} {g : β → γ} {f : α → β} :
  sym2.map (g ∘ f) = sym2.map g ∘ sym2.map f := by tidy

section membership

/-! ### Declarations about membership -/

/--
This is a predicate that determines whether a given term is a member of a term of the
symmetric square.  From this point of view, the symmetric square is the subtype of
cardinality-two multisets on `α`.
-/
def mem (x : α) (z : sym2 α) : Prop :=
∃ (y : α), z = ⟦(x, y)⟧

instance : has_mem α (sym2 α) := ⟨mem⟩

lemma mk_has_mem (x y : α) : x ∈ ⟦(x, y)⟧ := ⟨y, rfl⟩
lemma mk_has_mem_right (x y : α) : y ∈ ⟦(x, y)⟧ := by { rw eq_swap, apply mk_has_mem }

/--
This is a type-valued version of the membership predicate `mem` that contains the other
element `y` of `z` such that `z = ⟦(x, y)⟧`.  It is a subsingleton already,
so there is no need to apply `trunc` to the type.
-/
@[nolint has_inhabited_instance]
def vmem (x : α) (z : sym2 α) : Type u :=
{y : α // z = ⟦(x, y)⟧}

instance (x : α) (z : sym2 α) : subsingleton {y : α // z = ⟦(x, y)⟧} :=
⟨by { rintros ⟨a, ha⟩ ⟨b, hb⟩, rw [ha, congr_right] at hb, tidy }⟩

/--
The `vmem` version of `mk_has_mem`.
-/
def mk_has_vmem (x y : α) : vmem x ⟦(x, y)⟧ :=
⟨y, rfl⟩

instance {a : α} {z : sym2 α} : has_lift (vmem a z) (mem a z) := ⟨λ h, ⟨h.val, h.property⟩⟩

/--
Given an element of a term of the symmetric square (using `vmem`), retrieve the other element.
-/
def vmem.other {a : α} {p : sym2 α} (h : vmem a p) : α := h.val

/--
The defining property of the other element is that it can be used to
reconstruct the term of the symmetric square.
-/
lemma vmem_other_spec {a : α} {z : sym2 α} (h : vmem a z) :
  z = ⟦(a, h.other)⟧ := by { delta vmem.other, tidy }

/--
This is the `mem`-based version of `other`.
-/
noncomputable def mem.other {a : α} {z : sym2 α} (h : a ∈ z) : α :=
classical.some h

lemma mem_other_spec {a : α} {z : sym2 α} (h : a ∈ z) :
  ⟦(a, h.other)⟧ = z := by erw ← classical.some_spec h

lemma other_is_mem_other {a : α} {z : sym2 α} (h : vmem a z) (h' : a ∈ z) :
  h.other = mem.other h' := by rw [← congr_right a, ← vmem_other_spec h, mem_other_spec]

lemma eq_iff {x y z w : α} :
  ⟦(x, y)⟧ = ⟦(z, w)⟧ ↔ (x = z ∧ y = w) ∨ (x = w ∧ y = z) :=
begin
  split; intro h,
  { rw quotient.eq at h, cases h; tidy },
  { cases h; rw [h.1, h.2], rw eq_swap }
end

@[simp] lemma mem_iff {a b c : α} : a ∈ ⟦(b, c)⟧ ↔ a = b ∨ a = c :=
{ mp  := by { rintro ⟨_, h⟩, rw eq_iff at h, tidy },
  mpr := by { rintro ⟨_⟩; subst a, { apply mk_has_mem }, rw eq_swap, apply mk_has_mem } }

end membership

/--
A type `α` is naturally included in the diagonal of `α × α`, and this function gives the image
of this diagonal in `sym2 α`.
-/
def diag (x : α) : sym2 α := ⟦(x, x)⟧

/--
A predicate for testing whether an element of `sym2 α` is on the diagonal.
-/
def is_diag (z : sym2 α) : Prop := z ∈ set.range (@diag α)

lemma is_diag_iff_proj_eq (z : α × α) : is_diag ⟦z⟧ ↔ z.1 = z.2 :=
begin
  cases z with a, split,
  { rintro ⟨_, h⟩, erw eq_iff at h, cc },
  { rintro ⟨⟩, use a, refl },
end

instance is_diag.decidable_pred (α : Type u) [decidable_eq α] : decidable_pred (@is_diag α) :=
by { intro z, induction z, { erw is_diag_iff_proj_eq, apply_instance }, apply subsingleton.elim }

section relations

/-! ### Declarations about symmetric relations -/

variables {r : α → α → Prop}

/--
Symmetric relations define a set on `sym2 α` by taking all those pairs
of elements that are related.
-/
def from_rel (sym : symmetric r) : set (sym2 α) :=
λ z, quotient.rec_on z (λ z, r z.1 z.2) (by { rintros _ _ ⟨_,_⟩, tidy })

@[simp]
lemma from_rel_proj_prop {sym : symmetric r} {z : α × α} :
  ⟦z⟧ ∈ from_rel sym ↔ r z.1 z.2 := by tidy

@[simp]
lemma from_rel_prop {sym : symmetric r} {a b : α} :
  ⟦(a, b)⟧ ∈ from_rel sym ↔ r a b := by simp only [from_rel_proj_prop]

lemma from_rel_irreflexive {sym : symmetric r} :
  irreflexive r ↔ ∀ {z}, z ∈ from_rel sym → ¬is_diag z :=
{ mp  := by { intros h z hr hd, induction z,
              erw is_diag_iff_proj_eq at hd, erw from_rel_proj_prop at hr, tidy },
  mpr := by { intros h x hr, rw ← @from_rel_prop _ _ sym at hr, exact h hr ⟨x, rfl⟩ }}

instance from_rel.decidable_as_set (sym : symmetric r) [h : decidable_rel r] :
  decidable_pred (λ x, x ∈ sym2.from_rel sym) :=
λ (x : sym2 α), quotient.rec_on x
  (λ x', by { simp_rw from_rel_proj_prop, apply_instance })
  (by tidy)

instance from_rel.decidable_pred (sym : symmetric r) [h : decidable_rel r] :
  decidable_pred (sym2.from_rel sym) :=
by { change decidable_pred (λ x, x ∈ sym2.from_rel sym), apply_instance }

end relations

section sym_equiv

/-! ### Equivalence to the second symmetric power -/

local attribute [instance] vector.perm.is_setoid

private def from_vector {α : Type*} : vector α 2 → α × α
| ⟨[a, b], h⟩ := (a, b)

private lemma perm_card_two_iff {α : Type*} {a₁ b₁ a₂ b₂ : α} :
  [a₁, b₁].perm [a₂, b₂] ↔ (a₁ = a₂ ∧ b₁ = b₂) ∨ (a₁ = b₂ ∧ b₁ = a₂) :=
{ mp  := by { simp [← multiset.coe_eq_coe, ← multiset.cons_coe, multiset.cons_eq_cons]; tidy },
  mpr := by { intro h, cases h; rw [h.1, h.2], apply list.perm.swap', refl } }

/--
The symmetric square is equivalent to length-2 vectors up to permutations.
-/
def sym2_equiv_sym' {α : Type*} : equiv (sym2 α) (sym' α 2) :=
{ to_fun := quotient.map
    (λ (x : α × α), ⟨[x.1, x.2], rfl⟩)
    (by { rintros _ _ ⟨_⟩, { refl }, apply list.perm.swap', refl }),
  inv_fun := quotient.map from_vector (begin
    rintros ⟨x, hx⟩ ⟨y, hy⟩ h,
    cases x with _ x, { simp at hx; tauto },
    cases x with _ x, { simp at hx; norm_num at hx },
    cases x with _ x, swap, { exfalso, simp at hx; linarith [hx] },
    cases y with _ y, { simp at hy; tauto },
    cases y with _ y, { simp at hy; norm_num at hy },
    cases y with _ y, swap, { exfalso, simp at hy; linarith [hy] },
    rcases perm_card_two_iff.mp h with ⟨rfl,rfl⟩|⟨rfl,rfl⟩, { refl },
    apply sym2.rel.swap,
  end),
  left_inv := by tidy,
  right_inv := λ x, begin
    induction x,
    { cases x with x hx,
      cases x with _ x, { simp at hx; tauto },
      cases x with _ x, { simp at hx; norm_num at hx },
      cases x with _ x, swap, { exfalso, simp at hx; linarith [hx] },
      refl },
    refl,
  end }

/--
The symmetric square is equivalent to the second symmetric power.
-/
def equiv_sym (α : Type*) : sym2 α ≃ sym α 2 :=
equiv.trans sym2_equiv_sym' (sym_equiv_sym' α 2).symm

/--
The symmetric square is equivalent to multisets of cardinality
two. (This is currently a synonym for `equiv_sym`, but it's provided
in case the definition for `sym` changes.)
-/
def equiv_multiset (α : Type*) : sym2 α ≃ {s : multiset α // s.card = 2} :=
equiv_sym α

end sym_equiv

section finite

/--
An algorithm for computing `sym2.rel`.
-/
def rel_bool [decidable_eq α] (x y : α × α) : bool :=
if x.1 = y.1 then x.2 = y.2 else
  if x.1 = y.2 then x.2 = y.1 else ff

lemma rel_bool_spec [decidable_eq α] (x y : α × α) :
  ↥(rel_bool x y) ↔ rel α x y :=
begin
  cases x with x₁ x₂, cases y with y₁ y₂,
  dsimp [rel_bool], split_ifs;
  simp only [false_iff, bool.coe_sort_ff, bool.of_to_bool_iff],
  rotate 2, { contrapose! h, cases h; cc },
  all_goals { subst x₁, split; intro h1,
    { subst h1; apply sym2.rel.swap },
    { cases h1; cc }}
end

/--
Given `[decidable_eq α]` and `[fintype α]`, the following instance gives `fintype (sym2 α)`.
-/
instance (α : Type*) [decidable_eq α] : decidable_rel (sym2.rel α) :=
λ x y, decidable_of_bool (rel_bool x y) (rel_bool_spec x y)

end finite

end sym2


import analysis.topology.topological_space
universe u

structure presheaf_of_types (α : Type u) [T : topological_space α] :=
(F : Π {U : set α}, T.is_open U → Type u)
(res : ∀ (U V : set α) (OU : T.is_open U) (OV : T.is_open V) (H : V ⊆ U),
  (F OU) → (F OV))
(Hid : ∀ (U : set α) (OU : T.is_open U), (res U U OU _ (set.subset.refl U)) = id)
(Hcomp : ∀ (U V W : set α) (OU : T.is_open U) (OV : T.is_open V) (OW : T.is_open W)
  (HUV : V ⊆ U) (HVW : W ⊆ V),
  (res U W OU OW (set.subset.trans HVW HUV)) = (res V W OV _ HVW) ∘ (res U V _ _ HUV) )

@[simp] lemma presheaf_of_types.Hcomp' {X : Type u} [TX : topological_space X]
  (FPT : presheaf_of_types X) :
∀ {U V W : set X} (OU : TX.is_open U) (OV : TX.is_open V) (OW : TX.is_open W)
  (HUV : V ⊆ U) (HVW : W ⊆ V) (s : FPT.F OU),
  (FPT.res U W OU OW (set.subset.trans HVW HUV)) s =
    (FPT.res V W OV OW HVW) ((FPT.res U V OU OV HUV) s) := begin
    intros U V W OU OV OW HUV HVW s,
      show _ = ((FPT.res V W OV OW HVW) ∘ (FPT.res U V OU OV HUV)) s,
      rw FPT.Hcomp,
    end

@[simp] lemma presheaf_of_types.Hid' {X : Type u} [TX : topological_space X]
  (FPT : presheaf_of_types X) :
∀ {U : set X} (OU : TX.is_open U) (s : FPT.F OU),
  (FPT.res U U OU OU (set.subset.refl U)) s = s := λ U OU s,by rw FPT.Hid U OU;simp

structure morphism_of_presheaves_of_types {α : Type u} [Tα : topological_space α]
  (FPT : presheaf_of_types α) (GPT : presheaf_of_types α) :=
(morphism : ∀ U : set α, ∀ HU : Tα.is_open U, (FPT.F HU) → GPT.F HU)
(commutes : ∀ U V : set α, ∀ HU : Tα.is_open U, ∀ HV : Tα.is_open V, ∀ Hsub : V ⊆ U,
  (GPT.res U V HU HV Hsub) ∘ (morphism U HU) = (morphism V HV) ∘ (FPT.res U V HU HV Hsub))

def composition_of_morphisms_of_presheaves_of_types {α : Type u} [Tα : topological_space α]
  {FPT GPT HPT : presheaf_of_types α} (fg : morphism_of_presheaves_of_types FPT GPT)
  (gh : morphism_of_presheaves_of_types GPT HPT) :
morphism_of_presheaves_of_types FPT HPT :=
{ morphism := λ U HU, gh.morphism U HU ∘ fg.morphism U HU,
  commutes := λ U V HU HV Hsub, begin
    show (HPT.res U V HU HV Hsub ∘ gh.morphism U HU) ∘ fg.morphism U HU =
    gh.morphism V HV ∘ (fg.morphism V HV ∘ FPT.res U V HU HV Hsub),
    rw gh.commutes U V HU HV Hsub,
    rw ←fg.commutes U V HU HV Hsub,
  end }

def is_identity_morphism_of_presheaves_of_types {α : Type u} [Tα : topological_space α]
  {FPT : presheaf_of_types α} (phi: morphism_of_presheaves_of_types FPT FPT) :=
  ∀ (U : set α) (OU : Tα.is_open U), phi.morphism U OU = id

def is_isomorphism_of_presheaves_of_types {α : Type u} [Tα : topological_space α]
  {FPT : presheaf_of_types α} {GPT : presheaf_of_types α} (phi: morphism_of_presheaves_of_types FPT GPT) :=
  ∃ psi : morphism_of_presheaves_of_types GPT FPT,
  is_identity_morphism_of_presheaves_of_types (composition_of_morphisms_of_presheaves_of_types phi psi)
  ∧ is_identity_morphism_of_presheaves_of_types (composition_of_morphisms_of_presheaves_of_types psi phi)

def are_isomorphic_presheaves_of_types {α : Type u} [Tα : topological_space α]
(FPT : presheaf_of_types α) (GPT : presheaf_of_types α) : Prop :=
∃ (fg : morphism_of_presheaves_of_types FPT GPT) (gf : morphism_of_presheaves_of_types GPT FPT),
  is_identity_morphism_of_presheaves_of_types (composition_of_morphisms_of_presheaves_of_types fg gf)
  ∧ is_identity_morphism_of_presheaves_of_types (composition_of_morphisms_of_presheaves_of_types gf fg)

-- Seems to me that stacks project implicitly claims presheaves form a category
-- so perhaps at some point one should check e.g. identity o phi = phi and
-- associativity of composition of morphisms. I didn't need these yet though.


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

! This file was ported from Lean 3 source module category_theory.monoidal.natural_transformation
! leanprover-community/mathlib commit d047eb4671130d5998b185e49a0443a0d2e9b191
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.CategoryTheory.Monoidal.Functor
import Mathlib.CategoryTheory.FullSubcategory

/-!
# Monoidal natural transformations

Natural transformations between (lax) monoidal functors must satisfy
an additional compatibility relation with the tensorators:
`F.μ X Y ≫ app (X ⊗ Y) = (app X ⊗ app Y) ≫ G.μ X Y`.

(Lax) monoidal functors between a fixed pair of monoidal categories
themselves form a category.
-/

set_option autoImplicit false

open CategoryTheory

universe v₁ v₂ v₃ u₁ u₂ u₃

open CategoryTheory.Category

open CategoryTheory.Functor

namespace CategoryTheory

open MonoidalCategory

variable {C : Type u₁} [Category.{v₁} C] [MonoidalCategory.{v₁} C] {D : Type u₂} [Category.{v₂} D]
  [MonoidalCategory.{v₂} D]

/-- A monoidal natural transformation is a natural transformation between (lax) monoidal functors
additionally satisfying:
`F.μ X Y ≫ app (X ⊗ Y) = (app X ⊗ app Y) ≫ G.μ X Y`
-/
@[ext]
structure MonoidalNatTrans (F G : LaxMonoidalFunctor C D) extends
  NatTrans F.toFunctor G.toFunctor where
  /-- The unit condition for a monoidal natural transformation. -/
  unit : F.ε ≫ app (𝟙_ C) = G.ε := by aesop_cat
  /-- The tensor condition for a monoidal natural transformation. -/
  tensor : ∀ X Y, F.μ _ _ ≫ app (X ⊗ Y) = (app X ⊗ app Y) ≫ G.μ _ _ := by aesop_cat
#align category_theory.monoidal_nat_trans CategoryTheory.MonoidalNatTrans

-- Porting note: `reassoc (attr := simp)` seems to add a `simp`
-- attribute to the original lemma as well.
attribute [reassoc (attr := simp)] MonoidalNatTrans.tensor
attribute [reassoc (attr := simp)] MonoidalNatTrans.unit

#align category_theory.monoidal_nat_trans.unit CategoryTheory.MonoidalNatTrans.unit
#align category_theory.monoidal_nat_trans.unit_assoc CategoryTheory.MonoidalNatTrans.unit_assoc
#align category_theory.monoidal_nat_trans.tensor CategoryTheory.MonoidalNatTrans.tensor
#align category_theory.monoidal_nat_trans.tensor_assoc CategoryTheory.MonoidalNatTrans.tensor_assoc

namespace MonoidalNatTrans

/-- The identity monoidal natural transformation. -/
@[simps!]
def id (F : LaxMonoidalFunctor C D) : MonoidalNatTrans F F :=
  { 𝟙 F.toFunctor with }
#align category_theory.monoidal_nat_trans.id CategoryTheory.MonoidalNatTrans.id

instance (F : LaxMonoidalFunctor C D) : Inhabited (MonoidalNatTrans F F) :=
  ⟨id F⟩

/-- Vertical composition of monoidal natural transformations. -/
@[simps!]
def vcomp {F G H : LaxMonoidalFunctor C D} (α : MonoidalNatTrans F G) (β : MonoidalNatTrans G H) :
    MonoidalNatTrans F H :=
  { NatTrans.vcomp α.toNatTrans β.toNatTrans with }
#align category_theory.monoidal_nat_trans.vcomp CategoryTheory.MonoidalNatTrans.vcomp

instance categoryLaxMonoidalFunctor : Category (LaxMonoidalFunctor C D) where
  Hom := MonoidalNatTrans
  id := id
  comp α β := vcomp α β
#align category_theory.monoidal_nat_trans.category_lax_monoidal_functor CategoryTheory.MonoidalNatTrans.categoryLaxMonoidalFunctor

@[simp]
theorem comp_toNatTrans_lax {F G H : LaxMonoidalFunctor C D} {α : F ⟶ G} {β : G ⟶ H} :
    (α ≫ β).toNatTrans = @CategoryStruct.comp (C ⥤ D) _ _ _ _ α.toNatTrans β.toNatTrans :=
  rfl
#align category_theory.monoidal_nat_trans.comp_to_nat_trans_lax CategoryTheory.MonoidalNatTrans.comp_toNatTrans_lax

instance categoryMonoidalFunctor : Category (MonoidalFunctor C D) :=
  InducedCategory.category MonoidalFunctor.toLaxMonoidalFunctor
#align category_theory.monoidal_nat_trans.category_monoidal_functor CategoryTheory.MonoidalNatTrans.categoryMonoidalFunctor

@[simp]
theorem comp_toNatTrans {F G H : MonoidalFunctor C D} {α : F ⟶ G} {β : G ⟶ H} :
    (α ≫ β).toNatTrans = @CategoryStruct.comp (C ⥤ D) _ _ _ _ α.toNatTrans β.toNatTrans :=
  rfl
#align category_theory.monoidal_nat_trans.comp_to_nat_trans CategoryTheory.MonoidalNatTrans.comp_toNatTrans

variable {E : Type u₃} [Category.{v₃} E] [MonoidalCategory.{v₃} E]

/-- Horizontal composition of monoidal natural transformations. -/
@[simps]
def hcomp {F G : LaxMonoidalFunctor C D} {H K : LaxMonoidalFunctor D E} (α : MonoidalNatTrans F G)
    (β : MonoidalNatTrans H K) : MonoidalNatTrans (F ⊗⋙ H) (G ⊗⋙ K) :=
  { NatTrans.hcomp α.toNatTrans β.toNatTrans with
    unit := by
      dsimp; simp
      conv_lhs => rw [← K.toFunctor.map_comp, α.unit]
    tensor := fun X Y => by
      dsimp; simp
      conv_lhs => rw [← K.toFunctor.map_comp, α.tensor, K.toFunctor.map_comp] }
#align category_theory.monoidal_nat_trans.hcomp CategoryTheory.MonoidalNatTrans.hcomp

section

attribute [local simp] NatTrans.naturality MonoidalNatTrans.unit MonoidalNatTrans.tensor

/-- The cartesian product of two monoidal natural transformations is monoidal. -/
@[simps]
def prod {F G : LaxMonoidalFunctor C D} {H K : LaxMonoidalFunctor C E} (α : MonoidalNatTrans F G)
    (β : MonoidalNatTrans H K) : MonoidalNatTrans (F.prod' H) (G.prod' K)
    where app X := (α.app X, β.app X)
#align category_theory.monoidal_nat_trans.prod CategoryTheory.MonoidalNatTrans.prod

end

end MonoidalNatTrans

namespace MonoidalNatIso

variable {F G : LaxMonoidalFunctor C D}

/-- Construct a monoidal natural isomorphism from object level isomorphisms,
and the monoidal naturality in the forward direction. -/
def ofComponents (app : ∀ X : C, F.obj X ≅ G.obj X)
    (naturality' : ∀ {X Y : C} (f : X ⟶ Y), F.map f ≫ (app Y).hom = (app X).hom ≫ G.map f)
    (unit' : F.ε ≫ (app (𝟙_ C)).hom = G.ε)
    (tensor' : ∀ X Y, F.μ X Y ≫ (app (X ⊗ Y)).hom = ((app X).hom ⊗ (app Y).hom) ≫ G.μ X Y) :
    F ≅ G where
  hom := { app := fun X => (app X).hom }
  inv := {
    (NatIso.ofComponents app @naturality').inv with
    app := fun X => (app X).inv
    unit := by
      dsimp
      rw [← unit', assoc, Iso.hom_inv_id, comp_id]
    tensor := fun X Y => by
      dsimp
      rw [Iso.comp_inv_eq, assoc, tensor', ← tensor_comp_assoc,
        Iso.inv_hom_id, Iso.inv_hom_id, tensor_id, id_comp] }
  hom_inv_id := by
    apply MonoidalNatTrans.ext
    ext x
    exact (app x).hom_inv_id
  inv_hom_id := by
    apply MonoidalNatTrans.ext
    ext x
    exact (app x).inv_hom_id
#align category_theory.monoidal_nat_iso.of_components CategoryTheory.MonoidalNatIso.ofComponents

@[simp]
theorem ofComponents.hom_app (app : ∀ X : C, F.obj X ≅ G.obj X) (naturality) (unit) (tensor) (X) :
    (ofComponents app naturality unit tensor).hom.app X = (app X).hom :=
  rfl
#align category_theory.monoidal_nat_iso.of_components.hom_app CategoryTheory.MonoidalNatIso.ofComponents.hom_app

@[simp]
theorem ofComponents.inv_app (app : ∀ X : C, F.obj X ≅ G.obj X) (naturality) (unit) (tensor) (X) :
    (ofComponents app naturality unit tensor).inv.app X = (app X).inv := by simp [ofComponents]
#align category_theory.monoidal_nat_iso.of_components.inv_app CategoryTheory.MonoidalNatIso.ofComponents.inv_app

instance isIso_of_isIso_app (α : F ⟶ G) [∀ X : C, IsIso (α.app X)] : IsIso α :=
  ⟨(IsIso.of_iso
        (ofComponents (fun X => asIso (α.app X)) (fun f => α.toNatTrans.naturality f) α.unit
          α.tensor)).1⟩
#align category_theory.monoidal_nat_iso.is_iso_of_is_iso_app CategoryTheory.MonoidalNatIso.isIso_of_isIso_app

end MonoidalNatIso

noncomputable section

/-- The unit of a monoidal equivalence can be upgraded to a monoidal natural transformation. -/
@[simps! toNatTrans] -- Porting note: have to manually specify the toNatTrans projection
def monoidalUnit (F : MonoidalFunctor C D) [IsEquivalence F.toFunctor] :
    LaxMonoidalFunctor.id C ⟶ F.toLaxMonoidalFunctor ⊗⋙ (monoidalInverse F).toLaxMonoidalFunctor :=
  let e := F.toFunctor.asEquivalence
  { toNatTrans := e.unit
    tensor := fun X Y => by
      -- This proof is not pretty; golfing welcome!
      dsimp
      simp only [Adjunction.homEquiv_unit, Adjunction.homEquiv_naturality_right,
        id_comp, assoc]
      simp only [← Functor.map_comp, assoc]
      erw [e.counit_app_functor, e.counit_app_functor,
        F.toLaxMonoidalFunctor.μ_natural, IsIso.inv_hom_id_assoc]
      simp only [CategoryTheory.IsEquivalence.inv_fun_map]
      slice_rhs 2 3 => erw [Iso.hom_inv_id_app]
      dsimp
      simp only [CategoryTheory.Category.id_comp]
      slice_rhs 1 2 =>
        rw [← tensor_comp, Iso.hom_inv_id_app, Iso.hom_inv_id_app]
        dsimp
        rw [tensor_id]
      simp }
#align category_theory.monoidal_unit CategoryTheory.monoidalUnit

instance (F : MonoidalFunctor C D) [IsEquivalence F.toFunctor] : IsIso (monoidalUnit F) :=
  haveI : ∀ X : C, IsIso ((monoidalUnit F).toNatTrans.app X) := by
    dsimp ; infer_instance
  MonoidalNatIso.isIso_of_isIso_app _

/-- The counit of a monoidal equivalence can be upgraded to a monoidal natural transformation. -/
@[simps! toNatTrans] -- Porting note: have to manually specify the toNatTrans projection
def monoidalCounit (F : MonoidalFunctor C D) [IsEquivalence F.toFunctor] :
    (monoidalInverse F).toLaxMonoidalFunctor ⊗⋙ F.toLaxMonoidalFunctor ⟶ LaxMonoidalFunctor.id D :=
  let e := F.toFunctor.asEquivalence
  { toNatTrans := e.counit
    unit := by
      dsimp
      simp only [comp_id, assoc, Functor.map_inv, Functor.map_comp,
        NatIso.inv_inv_app, IsIso.inv_comp, IsEquivalence.fun_inv_map, Adjunction.homEquiv_unit]
      erw [e.counit_app_functor, ← e.functor.map_comp_assoc, Iso.hom_inv_id_app]
      dsimp; simp
    tensor := fun X Y => by
      dsimp
      simp only [Adjunction.homEquiv_unit, Adjunction.homEquiv_naturality_right, assoc,
        comp_id, Functor.map_comp]
      simp only [IsEquivalence.fun_inv_map]
      erw [e.counit_app_functor]
      simp only [assoc]
      erw [← e.functor.map_comp_assoc]
      simp only [CategoryTheory.Iso.inv_hom_id_app, CategoryTheory.Iso.inv_hom_id_app_assoc]
      erw [Iso.hom_inv_id_app, CategoryTheory.Functor.map_id]
      simp only [id_comp, CategoryTheory.Iso.inv_hom_id_app,
        CategoryTheory.IsIso.hom_inv_id_assoc]
      erw [comp_id]
      rfl }
#align category_theory.monoidal_counit CategoryTheory.monoidalCounit

instance (F : MonoidalFunctor C D) [IsEquivalence F.toFunctor] : IsIso (monoidalCounit F) :=
  haveI : ∀ X : D, IsIso ((monoidalCounit F).toNatTrans.app X) :=
    by dsimp ; infer_instance
  MonoidalNatIso.isIso_of_isIso_app _

end

end CategoryTheory