/-
Copyright (c) 2021 Rémy Degenne. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Rémy Degenne

! This file was ported from Lean 3 source module measure_theory.function.ae_measurable_sequence
! leanprover-community/mathlib commit d003c55042c3cd08aefd1ae9a42ef89441cdaaf3
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.MeasureTheory.MeasurableSpace

/-!
# Sequence of measurable functions associated to a sequence of a.e.-measurable functions

We define here tools to prove statements about limits (infi, supr...) of sequences of
`ae_measurable` functions.
Given a sequence of a.e.-measurable functions `f : ι → α → β` with hypothesis
`hf : ∀ i, ae_measurable (f i) μ`, and a pointwise property `p : α → (ι → β) → Prop` such that we
have `hp : ∀ᵐ x ∂μ, p x (λ n, f n x)`, we define a sequence of measurable functions `ae_seq hf p`
and a measurable set `ae_seq_set hf p`, such that
* `μ (ae_seq_set hf p)ᶜ = 0`
* `x ∈ ae_seq_set hf p → ∀ i : ι, ae_seq hf hp i x = f i x`
* `x ∈ ae_seq_set hf p → p x (λ n, f n x)`
-/

open MeasureTheory

open Classical

variable {ι : Sort _} {α β γ : Type _} [MeasurableSpace α] [MeasurableSpace β] {f : ι → α → β}
  {μ : Measure α} {p : α → (ι → β) → Prop}

/-- If we have the additional hypothesis `∀ᵐ x ∂μ, p x (λ n, f n x)`, this is a measurable set
whose complement has measure 0 such that for all `x ∈ ae_seq_set`, `f i x` is equal to
`(hf i).mk (f i) x` for all `i` and we have the pointwise property `p x (λ n, f n x)`. -/
def aeSeqSet (hf : ∀ i, AeMeasurable (f i) μ) (p : α → (ι → β) → Prop) : Set α :=
  toMeasurable μ ({ x | (∀ i, f i x = (hf i).mk (f i) x) ∧ p x fun n => f n x }ᶜ)ᶜ
#align ae_seq_set aeSeqSet

/-- A sequence of measurable functions that are equal to `f` and verify property `p` on the
measurable set `ae_seq_set hf p`. -/
noncomputable def aeSeq (hf : ∀ i, AeMeasurable (f i) μ) (p : α → (ι → β) → Prop) : ι → α → β :=
  fun i x => ite (x ∈ aeSeqSet hf p) ((hf i).mk (f i) x) (⟨f i x⟩ : Nonempty β).some
#align ae_seq aeSeq

namespace aeSeq

section MemAeSeqSet

theorem mk_eq_fun_of_mem_aeSeqSet (hf : ∀ i, AeMeasurable (f i) μ) {x : α} (hx : x ∈ aeSeqSet hf p)
    (i : ι) : (hf i).mk (f i) x = f i x :=
  haveI h_ss : aeSeqSet hf p ⊆ { x | ∀ i, f i x = (hf i).mk (f i) x } :=
    by
    rw [aeSeqSet, ← compl_compl { x | ∀ i, f i x = (hf i).mk (f i) x }, Set.compl_subset_compl]
    refine' Set.Subset.trans (set.compl_subset_compl.mpr fun x h => _) (subset_to_measurable _ _)
    exact h.1
  (h_ss hx i).symm
#align ae_seq.mk_eq_fun_of_mem_ae_seq_set aeSeq.mk_eq_fun_of_mem_aeSeqSet

theorem aeSeq_eq_mk_of_mem_aeSeqSet (hf : ∀ i, AeMeasurable (f i) μ) {x : α}
    (hx : x ∈ aeSeqSet hf p) (i : ι) : aeSeq hf p i x = (hf i).mk (f i) x := by
  simp only [aeSeq, hx, if_true]
#align ae_seq.ae_seq_eq_mk_of_mem_ae_seq_set aeSeq.aeSeq_eq_mk_of_mem_aeSeqSet

theorem aeSeq_eq_fun_of_mem_aeSeqSet (hf : ∀ i, AeMeasurable (f i) μ) {x : α}
    (hx : x ∈ aeSeqSet hf p) (i : ι) : aeSeq hf p i x = f i x := by
  simp only [ae_seq_eq_mk_of_mem_ae_seq_set hf hx i, mk_eq_fun_of_mem_ae_seq_set hf hx i]
#align ae_seq.ae_seq_eq_fun_of_mem_ae_seq_set aeSeq.aeSeq_eq_fun_of_mem_aeSeqSet

theorem propOfMemAeSeqSet (hf : ∀ i, AeMeasurable (f i) μ) {x : α} (hx : x ∈ aeSeqSet hf p) :
    p x fun n => aeSeq hf p n x :=
  by
  simp only [aeSeq, hx, if_true]
  rw [funext fun n => mk_eq_fun_of_mem_ae_seq_set hf hx n]
  have h_ss : aeSeqSet hf p ⊆ { x | p x fun n => f n x } :=
    by
    rw [← compl_compl { x | p x fun n => f n x }, aeSeqSet, Set.compl_subset_compl]
    refine' Set.Subset.trans (set.compl_subset_compl.mpr _) (subset_to_measurable _ _)
    exact fun x hx => hx.2
  have hx' := Set.mem_of_subset_of_mem h_ss hx
  exact hx'
#align ae_seq.prop_of_mem_ae_seq_set aeSeq.propOfMemAeSeqSet

theorem funPropOfMemAeSeqSet (hf : ∀ i, AeMeasurable (f i) μ) {x : α} (hx : x ∈ aeSeqSet hf p) :
    p x fun n => f n x :=
  by
  have h_eq : (fun n => f n x) = fun n => aeSeq hf p n x :=
    funext fun n => (ae_seq_eq_fun_of_mem_ae_seq_set hf hx n).symm
  rw [h_eq]
  exact prop_of_mem_ae_seq_set hf hx
#align ae_seq.fun_prop_of_mem_ae_seq_set aeSeq.funPropOfMemAeSeqSet

end MemAeSeqSet

theorem aeSeqSet_measurableSet {hf : ∀ i, AeMeasurable (f i) μ} : MeasurableSet (aeSeqSet hf p) :=
  (measurableSet_toMeasurable _ _).compl
#align ae_seq.ae_seq_set_measurable_set aeSeq.aeSeqSet_measurableSet

theorem measurable (hf : ∀ i, AeMeasurable (f i) μ) (p : α → (ι → β) → Prop) (i : ι) :
    Measurable (aeSeq hf p i) :=
  Measurable.ite aeSeqSet_measurableSet (hf i).measurable_mk <| measurable_const' fun x y => rfl
#align ae_seq.measurable aeSeq.measurable

theorem measure_compl_aeSeqSet_eq_zero [Countable ι] (hf : ∀ i, AeMeasurable (f i) μ)
    (hp : ∀ᵐ x ∂μ, p x fun n => f n x) : μ (aeSeqSet hf pᶜ) = 0 :=
  by
  rw [aeSeqSet, compl_compl, measure_to_measurable]
  have hf_eq := fun i => (hf i).ae_eq_mk
  simp_rw [Filter.EventuallyEq, ← ae_all_iff] at hf_eq
  exact Filter.Eventually.and hf_eq hp
#align ae_seq.measure_compl_ae_seq_set_eq_zero aeSeq.measure_compl_aeSeqSet_eq_zero

theorem aeSeq_eq_mk_ae [Countable ι] (hf : ∀ i, AeMeasurable (f i) μ)
    (hp : ∀ᵐ x ∂μ, p x fun n => f n x) : ∀ᵐ a : α ∂μ, ∀ i : ι, aeSeq hf p i a = (hf i).mk (f i) a :=
  haveI h_ss : aeSeqSet hf p ⊆ { a : α | ∀ i, aeSeq hf p i a = (hf i).mk (f i) a } := fun x hx i =>
    by simp only [aeSeq, hx, if_true]
  le_antisymm
    (le_trans (measure_mono (set.compl_subset_compl.mpr h_ss))
      (le_of_eq (measure_compl_ae_seq_set_eq_zero hf hp)))
    (zero_le _)
#align ae_seq.ae_seq_eq_mk_ae aeSeq.aeSeq_eq_mk_ae

theorem aeSeq_eq_fun_ae [Countable ι] (hf : ∀ i, AeMeasurable (f i) μ)
    (hp : ∀ᵐ x ∂μ, p x fun n => f n x) : ∀ᵐ a : α ∂μ, ∀ i : ι, aeSeq hf p i a = f i a :=
  haveI h_ss : { a : α | ¬∀ i : ι, aeSeq hf p i a = f i a } ⊆ aeSeqSet hf pᶜ := fun x =>
    mt fun hx i => ae_seq_eq_fun_of_mem_ae_seq_set hf hx i
  measure_mono_null h_ss (measure_compl_ae_seq_set_eq_zero hf hp)
#align ae_seq.ae_seq_eq_fun_ae aeSeq.aeSeq_eq_fun_ae

theorem aeSeq_n_eq_fun_n_ae [Countable ι] (hf : ∀ i, AeMeasurable (f i) μ)
    (hp : ∀ᵐ x ∂μ, p x fun n => f n x) (n : ι) : aeSeq hf p n =ᵐ[μ] f n :=
  ae_all_iff.mp (aeSeq_eq_fun_ae hf hp) n
#align ae_seq.ae_seq_n_eq_fun_n_ae aeSeq.aeSeq_n_eq_fun_n_ae

theorem supᵢ [CompleteLattice β] [Countable ι] (hf : ∀ i, AeMeasurable (f i) μ)
    (hp : ∀ᵐ x ∂μ, p x fun n => f n x) : (⨆ n, aeSeq hf p n) =ᵐ[μ] ⨆ n, f n :=
  by
  simp_rw [Filter.EventuallyEq, ae_iff, supᵢ_apply]
  have h_ss : aeSeqSet hf p ⊆ { a : α | (⨆ i : ι, aeSeq hf p i a) = ⨆ i : ι, f i a } :=
    by
    intro x hx
    congr
    exact funext fun i => ae_seq_eq_fun_of_mem_ae_seq_set hf hx i
  exact measure_mono_null (set.compl_subset_compl.mpr h_ss) (measure_compl_ae_seq_set_eq_zero hf hp)
#align ae_seq.supr aeSeq.supᵢ

end aeSeq


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

! This file was ported from Lean 3 source module data.set.pointwise.iterate
! leanprover-community/mathlib commit f2f413b9d4be3a02840d0663dace76e8fe3da053
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Data.Set.Pointwise.Smul
import Mathbin.Algebra.Hom.Iterate
import Mathbin.Dynamics.FixedPoints.Basic

/-!
# Results about pointwise operations on sets with iteration.

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

open Pointwise

open Set Function

/- warning: smul_eq_self_of_preimage_zpow_eq_self -> smul_eq_self_of_preimage_zpow_eq_self is a dubious translation:
lean 3 declaration is
  forall {G : Type.{u1}} [_inst_1 : CommGroup.{u1} G] {n : Int} {s : Set.{u1} G}, (Eq.{succ u1} (Set.{u1} G) (Set.preimage.{u1, u1} G G (fun (x : G) => HPow.hPow.{u1, 0, u1} G Int G (instHPow.{u1, 0} G Int (DivInvMonoid.Pow.{u1} G (Group.toDivInvMonoid.{u1} G (CommGroup.toGroup.{u1} G _inst_1)))) x n) s) s) -> (forall {g : G} {j : Nat}, (Eq.{succ u1} G (HPow.hPow.{u1, 0, u1} G Int G (instHPow.{u1, 0} G Int (DivInvMonoid.Pow.{u1} G (Group.toDivInvMonoid.{u1} G (CommGroup.toGroup.{u1} G _inst_1)))) g (HPow.hPow.{0, 0, 0} Int Nat Int (instHPow.{0, 0} Int Nat (Monoid.Pow.{0} Int Int.monoid)) n j)) (OfNat.ofNat.{u1} G 1 (OfNat.mk.{u1} G 1 (One.one.{u1} G (MulOneClass.toHasOne.{u1} G (Monoid.toMulOneClass.{u1} G (DivInvMonoid.toMonoid.{u1} G (Group.toDivInvMonoid.{u1} G (CommGroup.toGroup.{u1} G _inst_1))))))))) -> (Eq.{succ u1} (Set.{u1} G) (SMul.smul.{u1, u1} G (Set.{u1} G) (Set.smulSet.{u1, u1} G G (Mul.toSMul.{u1} G (MulOneClass.toHasMul.{u1} G (Monoid.toMulOneClass.{u1} G (DivInvMonoid.toMonoid.{u1} G (Group.toDivInvMonoid.{u1} G (CommGroup.toGroup.{u1} G _inst_1))))))) g s) s))
but is expected to have type
  forall {G : Type.{u1}} [_inst_1 : CommGroup.{u1} G] {n : Int} {s : Set.{u1} G}, (Eq.{succ u1} (Set.{u1} G) (Set.preimage.{u1, u1} G G (fun (x : G) => HPow.hPow.{u1, 0, u1} G Int G (instHPow.{u1, 0} G Int (DivInvMonoid.Pow.{u1} G (Group.toDivInvMonoid.{u1} G (CommGroup.toGroup.{u1} G _inst_1)))) x n) s) s) -> (forall {g : G} {j : Nat}, (Eq.{succ u1} G (HPow.hPow.{u1, 0, u1} G Int G (instHPow.{u1, 0} G Int (DivInvMonoid.Pow.{u1} G (Group.toDivInvMonoid.{u1} G (CommGroup.toGroup.{u1} G _inst_1)))) g (HPow.hPow.{0, 0, 0} Int Nat Int Int.instHPowIntNat n j)) (OfNat.ofNat.{u1} G 1 (One.toOfNat1.{u1} G (InvOneClass.toOne.{u1} G (DivInvOneMonoid.toInvOneClass.{u1} G (DivisionMonoid.toDivInvOneMonoid.{u1} G (DivisionCommMonoid.toDivisionMonoid.{u1} G (CommGroup.toDivisionCommMonoid.{u1} G _inst_1)))))))) -> (Eq.{succ u1} (Set.{u1} G) (HSMul.hSMul.{u1, u1, u1} G (Set.{u1} G) (Set.{u1} G) (instHSMul.{u1, u1} G (Set.{u1} G) (Set.smulSet.{u1, u1} G G (MulAction.toSMul.{u1, u1} G G (DivInvMonoid.toMonoid.{u1} G (Group.toDivInvMonoid.{u1} G (CommGroup.toGroup.{u1} G _inst_1))) (Monoid.toMulAction.{u1} G (DivInvMonoid.toMonoid.{u1} G (Group.toDivInvMonoid.{u1} G (CommGroup.toGroup.{u1} G _inst_1))))))) g s) s))
Case conversion may be inaccurate. Consider using '#align smul_eq_self_of_preimage_zpow_eq_self smul_eq_self_of_preimage_zpow_eq_selfₓ'. -/
/-- Let `n : ℤ` and `s` a subset of a commutative group `G` that is invariant under preimage for
the map `x ↦ x^n`. Then `s` is invariant under the pointwise action of the subgroup of elements
`g : G` such that `g^(n^j) = 1` for some `j : ℕ`. (This subgroup is called the Prüfer subgroup when
 `G` is the `circle` and `n` is prime.) -/
@[to_additive
      "Let `n : ℤ` and `s` a subset of an additive commutative group `G` that is invariant\nunder preimage for the map `x ↦ n • x`. Then `s` is invariant under the pointwise action of the\nadditive subgroup of elements `g : G` such that `(n^j) • g = 0` for some `j : ℕ`. (This additive\nsubgroup is called the Prüfer subgroup when `G` is the `add_circle` and `n` is prime.)"]
theorem smul_eq_self_of_preimage_zpow_eq_self {G : Type _} [CommGroup G] {n : ℤ} {s : Set G}
    (hs : (fun x => x ^ n) ⁻¹' s = s) {g : G} {j : ℕ} (hg : g ^ n ^ j = 1) : g • s = s :=
  by
  suffices ∀ {g' : G} (hg' : g' ^ n ^ j = 1), g' • s ⊆ s
    by
    refine' le_antisymm (this hg) _
    conv_lhs => rw [← smul_inv_smul g s]
    replace hg : g⁻¹ ^ n ^ j = 1
    · rw [inv_zpow, hg, inv_one]
    simpa only [le_eq_subset, set_smul_subset_set_smul_iff] using this hg
  rw [(is_fixed_pt.preimage_iterate hs j : zpowGroupHom n^[j] ⁻¹' s = s).symm]
  rintro g' hg' - ⟨y, hy, rfl⟩
  change (zpowGroupHom n^[j]) (g' * y) ∈ s
  replace hg' : (zpowGroupHom n^[j]) g' = 1
  · simpa [zpowGroupHom]
  rwa [MonoidHom.iterate_map_mul, hg', one_mul]
#align smul_eq_self_of_preimage_zpow_eq_self smul_eq_self_of_preimage_zpow_eq_self
#align vadd_eq_self_of_preimage_zsmul_eq_self vadd_eq_self_of_preimage_zsmul_eq_self


inductive Term
  | Var (i : Nat)
  | Cons (l : Term) (r : Term)

def Subst := Nat → Nat

def depth : Term → Nat
  | .Var _ => 0
  | .Cons l r => 1 + depth l + depth r

def act (f : Subst) (t : Term) := match t with
  | .Var i => Term.Var (f i)
  | .Cons l r => Term.Cons (act f l) (act f r)

def strangers (u v : Term) := ∀ f : Subst, act f u ≠ act f v

abbrev P (c : Option Subst) u v := match c with
  | none => strangers u v
  | some f => act f u = act f v

def rel : WellFoundedRelation (Term × Term) := measure (λ (u, v) => depth u + depth v)

theorem decr_left (l₁ r₁ l₂ r₂ : Term) :
  rel.rel (l₁, l₂) (Term.Cons l₁ r₁, Term.Cons l₂ r₂) := by
  suffices h : depth l₁ + depth l₂ < depth (Term.Cons l₁ r₁) + depth (Term.Cons l₂ r₂) from h
  admit

theorem decr_right (l₁ r₁ l₂ r₂ : Term) (f : Subst) :
  rel.rel (act f r₁, act f r₂) (Term.Cons l₁ r₁, Term.Cons l₂ r₂) := by
  suffices h : depth (act f r₁) + depth (act f r₂) < depth (Term.Cons l₁ r₁) + depth (Term.Cons l₂ r₂) from h
  admit

def robinson (u v : Term) : { f : Option Subst // P f u v } := match u, v with
  | .Cons l₁ r₁, .Cons l₂ r₂ => match robinson l₁ l₂ with
    | ⟨ none, h ⟩ => ⟨ none, sorry ⟩
    | ⟨ some f, h ⟩ => match robinson (act f r₁) (act f r₂) with
      | ⟨ none, h ⟩ => ⟨ none, sorry ⟩
      | ⟨ some g, h ⟩ => ⟨ some (g ∘ f), sorry ⟩
  | .Var i, .Cons l r => ⟨ none, sorry ⟩
  | .Cons l r, .Var i => ⟨ none, sorry ⟩
  | .Var i, .Var j =>
    if i = j then ⟨ some id, sorry ⟩
    else ⟨ some λ n => if n = i then j else n, sorry ⟩
termination_by' invImage (λ ⟨ u, v ⟩ => (u, v)) rel
decreasing_by
  first
    | apply decr_left _ _ _ _
    | apply decr_right _ _ _ _ _

attribute [simp] robinson

set_option pp.proofs true
#check robinson._eq_1
#check robinson._eq_2
#check robinson._eq_3
#check robinson._eq_4

theorem ex : (robinson (Term.Var 0) (Term.Var 0)).1 = some id := by
  unfold robinson
  admit


-- import SciLean.Algebra
import SciLean.Data.FinProd
import SciLean.Data.ArrayN
import SciLean.Data.DataArray
import SciLean.Data.Mesh.PrismRepr

namespace SciLean

structure Prism where
  repr : PrismRepr
  repr_IsCanonical : repr.IsCanonical
deriving DecidableEq

structure Face (P : Prism) (dim : Option Nat := none) where
  repr : FaceRepr
  repr_ofPrism : repr.ofPrism = P.repr
  repr_dim : repr.dim = dim.getD repr.dim
deriving DecidableEq

structure Inclusion (Q : Prism) (P : Prism) where
  repr : FaceRepr
  repr_ofPrism : repr.ofPrism = P.repr
  repr_toPrism : repr.toPrism.toCanonical = Q.repr
deriving DecidableEq

namespace Prism

def dim (P : Prism) : Nat := P.repr.dim
def faceCount (n : Nat) (P : Prism) : Nat := P.repr.faceCount n
abbrev pointCount (P : Prism) : Nat := P.faceCount 0
abbrev edgeCount  (P : Prism) : Nat := P.faceCount 1

def toString (P : Prism) : String := P.repr.toString
instance : ToString Prism := ⟨λ P => P.toString⟩

instance : One Prism := ⟨.point, by simp⟩
instance : Inhabited Prism := ⟨.point, by simp⟩

def cone (P : Prism) : Prism := ⟨P.repr.cone, by apply PrismRepr.IsCanonical.cone; apply P.2; done⟩
def prod (P Q : Prism) : Prism := ⟨P.repr.prod Q.repr |>.toCanonical, by simp⟩
instance : Mul Prism := ⟨λ P Q => P.prod Q⟩

abbrev Space (P : Prism) := ℝ^{P.dim}

def inPrism (P : Prism) (x : ℝ^{P.dim}) : Bool :=
  match P with
  | ⟨.point, _⟩ => x = 0
  | ⟨.cone Q, _⟩ =>
    let Q : Prism := ⟨Q, sorry_proof⟩
    let x : ℝ^{Q.dim + 1} := x
    let t : ℝ := x[⟨Q.dim, by simp⟩]
    let y : ℝ^{Q.dim} := ⊞ i, x[⟨i.1, sorry_proof⟩]
    if t = 1 then
      x = 0
    else
      Q.inPrism (1/(1-t) * y)
  | ⟨.prod P₁ P₂, _⟩ =>
    let P₁ : Prism := ⟨P₁, sorry_proof⟩
    let P₂ : Prism := ⟨P₂, sorry_proof⟩
    let x₁ : ℝ^{P₁.dim} := ⊞ i, x[⟨i.1, sorry_proof⟩]
    let x₂ : ℝ^{P₂.dim} := ⊞ i, x[⟨P₁.dim + i.1, sorry_proof⟩]
    (P₁.inPrism x₁) ∧ (P₂.inPrism x₂)

def InPrism (P : Prism) (x : ℝ^{P.dim}) : Prop := (P.inPrism x = true)

@[match_pattern]
def point : Prism := ⟨.point, sorry_proof⟩
@[match_pattern]
def segment : Prism := ⟨.cone .point, sorry_proof⟩

@[match_pattern]
def triangle : Prism := ⟨.cone (.cone .point), sorry_proof⟩
@[match_pattern]
def square   : Prism := ⟨.prod (.cone .point) (.cone .point), sorry_proof⟩

@[match_pattern]
def tet     : Prism := triangle.cone
@[match_pattern]
def pyramid := square.cone
@[match_pattern]
def prism   := segment*triangle
@[match_pattern]
def cube    := segment*square

-- def Foo (P : Prism) : Type :=
--   match P.repr with
--   | .point => Int
--   | .cone .point => Int
--   | .prod (.cone .point) (.cone .point) => Float
--   | _ => Empty

-- example : Foo point = Int   := by rfl
-- example : Foo segment = Int := by rfl
-- example : Foo square = Float  := by rfl
-- example : Foo cube = Empty  := by rfl

-- def a : Foo point   := (5 : Int)
-- def b : Foo segment := (5 : Int)
-- def c : Foo square  := (5 : Float) -- This does not work :( -- The PrismRepr.toCanonical needs better implementation

/-- Number of prism in dimension `dim`

I'm fairly confident that prisms in dimension `d` are the same as unlabeled rooted trees on `d` vertices
https://oeis.org/A000081

-/
def prismCount : (dim : Nat) → Nat
  | 0 => 1
  | 1 => 1
  | 2 => 2
  | 3 => 4
  | 4 => 9
  | 5 => 20
  | 6 => 48
  | 7 => 115
  | _ => panic! "Number of prism for dim>4 is currently unknown! Implement this!"

/-- Number of prisms of dimension at most `dim` -/
def prismCumCount : (dim : Nat) → Nat
  | 0 => 1
  | 1 => 2
  | 2 => 4
  | 3 => 8
  | 4 => 17
  | 5 => 37
  | 6 => 85
  | 7 => 200
  | _ => panic! "Number of prism for dim>4 is currently unknown! Implement this!"

/-- Number of prime prisms in dimension `dim`

Prism is prime if it cannot be written as a produce of two non-trivial prism.
-/
def primePrismCount : (dim : Nat) → Nat
  | 0 => 0
  | n+1 => prismCount n

/-- Number of prime prisms of dimension at most `dim` -/
def primePrismCumCount : (dim : Nat) → Nat
  | 0 => 0
  | n+1 => prismCumCount n

def prismFromFin : (dim : Nat) → (Fin (prismCount dim)) → Prism
  | 0, ⟨0,_⟩ => point
  | 1, ⟨0,_⟩ => segment
  | 2, ⟨0,_⟩ => triangle
  | 2, ⟨1,_⟩ => square
  | 3, ⟨0,_⟩ => tet
  | 3, ⟨1,_⟩ => pyramid
  | 3, ⟨2,_⟩ => prism
  | 3, ⟨3,_⟩ => cube
  | 4, ⟨0,_⟩ => tet.cone
  | 4, ⟨1,_⟩ => pyramid.cone
  | 4, ⟨2,_⟩ => prism.cone
  | 4, ⟨3,_⟩ => cube.cone
  | 4, ⟨4,_⟩ => Prism.prod segment tet
  | 4, ⟨5,_⟩ => Prism.prod segment pyramid
  | 4, ⟨6,_⟩ => Prism.prod segment prism
  | 4, ⟨7,_⟩ => Prism.prod segment cube
  | 4, ⟨8,_⟩ => Prism.prod triangle triangle
  | _, _ => panic! "Getting prism from Fin n is not implemented for dim > 4!"

def prismFromNat : Nat → Prism
  | 0 => point
  | 1 => segment
  | 2 => triangle
  | 3 => square
  | 4 => tet
  | 5 => pyramid
  | 6 => prism
  | 7 => cube
  | 8 => tet.cone
  | 9 => pyramid.cone
  | 10 => prism.cone
  | 11 => cube.cone
  | 12 => Prism.prod segment tet
  | 13 => Prism.prod segment pyramid
  | 14 => Prism.prod segment prism
  | 15 => Prism.prod segment cube
  | 16 => Prism.prod triangle triangle
  | _ => panic! "Getting prism from Nat is not implemented for dim > 4!"

def primePrismFromNat : Nat → Prism
  | 0 => segment
  | 1 => triangle
  | 2 => tet
  | 3 => pyramid
  | 4 => tet.cone
  | 5 => pyramid.cone
  | 6 => prism.cone
  | 7 => cube.cone
  | _ => panic! "Getting prime prism from Nat is not implemented for dim > 4!"

def prismToFin (P : Prism) : Fin (prismCount P.dim) :=
  match P with
  -- 0D
  | ⟨.point, _⟩ => ⟨0, sorry_proof⟩
  -- 1D
  | ⟨.cone .point, _⟩ => ⟨0, sorry_proof⟩
  -- 2D
  | ⟨.cone (.cone .point), _⟩ => ⟨0, sorry_proof⟩
  | ⟨.prod (.cone .point) (.cone .point), _⟩ => ⟨1, sorry_proof⟩
  -- 3D
  | ⟨.cone (.cone (.cone .point)), _⟩ => ⟨0, sorry_proof⟩
  | ⟨.cone (.prod (.cone .point) (.cone .point)), _⟩ => ⟨1, sorry_proof⟩
  | ⟨.prod (.cone .point) (.cone (.cone .point)), _⟩ => ⟨2, sorry_proof⟩
  | ⟨.prod (.cone .point) (.prod (.cone .point) (.cone .point)), _⟩ => ⟨3, sorry_proof⟩
  -- 4D
  | ⟨.cone (.cone (.cone (.cone .point))), _⟩ => ⟨0, sorry_proof⟩
  | ⟨.cone (.cone (.prod (.cone .point) (.cone .point))), _⟩ => ⟨1, sorry_proof⟩
  | ⟨.cone (.prod (.cone .point) (.cone (.cone .point))), _⟩ => ⟨2, sorry_proof⟩
  | ⟨.cone (.prod (.cone .point) (.prod (.cone .point) (.cone .point))), _⟩ => ⟨3, sorry_proof⟩
  | ⟨.prod (.cone .point) (.cone (.cone (.cone .point))), _⟩ => ⟨4, sorry_proof⟩
  | ⟨.prod (.cone .point) (.cone (.prod (.cone .point) (.cone .point))), _⟩ => ⟨5, sorry_proof⟩
  | ⟨.prod (.cone .point) (.prod (.cone .point) (.cone (.cone .point))), _⟩ => ⟨6, sorry_proof⟩
  | ⟨.prod (.cone .point) (.prod (.cone .point) (.prod (.cone .point) (.cone .point))), _⟩ => ⟨7, sorry_proof⟩
  | ⟨.prod (.cone (.cone .point)) (.cone (.cone .point)), _⟩ => ⟨8, sorry_proof⟩

  | P =>
    have : Inhabited (Fin (prismCount P.dim)) := cast sorry_proof (⟨0, sorry_proof⟩ : Fin 1)
    panic! "Getting prism from Fin n is not implemented for dim > 4!"

def firstFace (P : Prism) (n : Option Nat := none) : Option (Face P n) :=
  match n with
  | none => match P.1.first 0 with
    | some f => ⟨f, sorry_proof, sorry_proof⟩ |> some
    | none => none
  | some n =>
  match P.1.first n with
  | some f => ⟨f, sorry_proof, sorry_proof⟩ |> some
  | none => none

/-- For prism `P = P₁ × ... × Pₘ` return `[P₁, ..., Pₘ]` i.e. list of all product factors. -/
def prodSplit (P : Prism) : List (Prism) :=
  if P.1 = .point
  then []
  else P.1.prodSplit.map (λ Pi => ⟨Pi, sorry_proof⟩)

opaque prodTally (P : Prism) : List (Prism × Nat) :=
  -- This implementation exploits the fact that P.prodSplit is ordered!
  let prod := P.prodSplit
  match prod.head? with
  | some head =>
    let (last, tally) : (Prism × Nat) × List (Prism × Nat) :=
      prod.tail.foldl (λ ((current,count), tally') P =>
        if P = current then
          ((current, count + 1), tally')
        else
          ((P,1), (current, count) :: tally')
        ) ((head,1), [])
    (last :: tally).reverse
  | none => []

/-- For a list `[(P₁,n₁), ... , (Pₘ,nₘ)]` construct `P = P₁^n₁ × ... × Pₘ^nₘ` -/
def listProd (Ps : List (Prism × Nat)) : Prism :=
  let rec prod (Qs : List (Prism × Nat)) : PrismRepr :=
    match Qs with
    | [] => .point
    | [(P,1)] => P.1
    | (_, 0) :: Ps => prod Ps
    | (P, n+1) :: Ps => P.1 * prod ((P,n) :: Ps)
  ⟨prod Ps |>.toCanonical, by simp⟩

def primePowers (P : Prism) : ArrayN Nat (primePrismCumCount P.dim) :=
  match P with
  -- 0D
  | ⟨.point, _⟩ => ⟨#[], by simp[dim]⟩
  -- 1D
  | ⟨.cone .point, _⟩ => ⟨#[1], by simp[dim]⟩
  -- 2D
  | ⟨.cone (.cone .point), _⟩ => ⟨#[0,1], by simp[dim]⟩
  | ⟨.prod (.cone .point) (.cone .point), _⟩ => ⟨#[2,0], by simp[dim]⟩
  -- 3D
  | ⟨.cone (.cone (.cone .point)), _⟩ => ⟨#[0,0,1,0], by simp[dim]⟩
  | ⟨.cone (.prod (.cone .point) (.cone .point)), _⟩ => ⟨#[0,0,0,1], sorry_proof⟩
  | ⟨.prod (.cone .point) (.cone (.cone .point)), _⟩ => ⟨#[1,1,0,0], sorry_proof⟩
  | ⟨.prod (.cone .point) (.prod (.cone .point) (.cone .point)), _⟩ => ⟨#[3,0,0,0], sorry_proof⟩
  -- 4D
  | ⟨.cone (.cone (.cone (.cone .point))), _⟩ => ⟨#[0,0,0,0,1,0,0,0], sorry_proof⟩
  | ⟨.cone (.cone (.prod (.cone .point) (.cone .point))), _⟩ => ⟨#[0,0,0,0,0,1,0,0], sorry_proof⟩
  | ⟨.cone (.prod (.cone .point) (.cone (.cone .point))), _⟩ => ⟨#[0,0,0,0,0,0,1,0], sorry_proof⟩
  | ⟨.cone (.prod (.cone .point) (.prod (.cone .point) (.cone .point))), _⟩ => ⟨#[0,0,0,0,0,0,0,1], sorry_proof⟩
  | ⟨.prod (.cone .point) (.cone (.cone (.cone .point))), _⟩ => ⟨#[1,0,1,0,0,0,0,0], sorry_proof⟩
  | ⟨.prod (.cone .point) (.cone (.prod (.cone .point) (.cone .point))), _⟩ => ⟨#[1,0,0,1,0,0,0,0], sorry_proof⟩
  | ⟨.prod (.cone .point) (.prod (.cone .point) (.cone (.cone .point))), _⟩ => ⟨#[2,1,0,0,0,0,0,0], sorry_proof⟩
  | ⟨.prod (.cone .point) (.prod (.cone .point) (.prod (.cone .point) (.cone .point))), _⟩ => ⟨#[4,0,0,0,0,0,0,0], sorry_proof⟩
  | ⟨.prod (.cone (.cone .point)) (.cone (.cone .point)), _⟩ => ⟨#[0,2,0,0,0,0,0,0], sorry_proof⟩
  | _ => panic! "PrimePowers is not implemented for prisms of dimension larger then four!"

end Prism

namespace Face

def dim (f : Face P n) : Nat := n.getD f.repr.dim
def toPrism (f : Face P n) : Prism := ⟨f.1.toPrism.toCanonical, by simp⟩
def ofPrism (_ : Face P n) : Prism := P

abbrev anyDim (f : Face P n) : Face P := ⟨f.1, f.2, by simp⟩
instance : Coe (Face P n) (Face P) := ⟨λ f => f.anyDim⟩

def comp (f : Face P n) (g : Face f.toPrism m) : Face P m :=
  ⟨f.repr.comp (g.repr.fromCanonical f.repr.toPrism (by simp[g.2,toPrism]; done))
   (by simp[g.2, toPrism,f.2]; done),
   by simp[f.repr_ofPrism],
   by simp; cases m; simp; simp; rw[g.repr_dim]; simp; done⟩

@[simp]
theorem comp_toPrism (f : Face P n) (g : Face f.toPrism m)
  : (f.comp g).toPrism = g.toPrism := by simp[comp,toPrism]

@[simp]
theorem comp_dim (f : Face P n) (g : Face f.toPrism m)
  : (f.comp g).dim = g.dim := by simp[comp,dim]

def tip (P : Prism) : Face (P.cone) (some 0) := ⟨.tip P.repr, by simp[FaceRepr.ofPrism,Prism.cone], by simp[FaceRepr.dim, FaceRepr.toPrism]⟩
def cone (f : Face P n) : Face (P.cone) (n.map (·+1)) := ⟨.cone f.repr, by simp[FaceRepr.ofPrism,Prism.cone, f.2], sorry_proof⟩
def base (f : Face P n) : Face (P.cone) n := ⟨.base f.repr, sorry_proof, sorry_proof⟩

instance : Add (Option Nat) := ⟨λ n m => match n, m with | some n, some m => n+m | _, _ => none⟩
def prod (f : Face P n) (g : Face Q m) : Face (P.prod Q) (n+m) := ⟨f.repr.prod g.repr |>.toCanonical, sorry_proof, sorry_proof⟩

def next (f : Face P n) : Option (Face P n) :=
  match f.repr.next with
  | some f' => ⟨f', sorry_proof, sorry_proof⟩ |> some
  | none =>
    match n with
    | some _ => none
    | none =>
      match f.ofPrism.firstFace (some (f.dim+1)) with
      | some f' => ⟨f'.1, f'.2, by simp⟩ |> some
      | none => none

instance (P : Prism) (n)
  : Iterable (Face P n) :=
{
  first := P.firstFace n
  next := λ f => f.next
  decEq := by infer_instance
}

def toFin (f : Face P (some n)) : Fin (P.faceCount n) := ⟨f.repr.index, sorry_proof⟩
def fromFin (P : Prism) (n : Nat) (i : Fin (P.faceCount n)) : Face P (some n) := ⟨FaceRepr.fromIndex P.1 n i, sorry_proof, sorry_proof⟩

instance : Enumtype (Face P (some n)) where
  numOf := P.faceCount n
  toFin := toFin
  fromFin := fromFin P n

  first_fromFin := sorry_proof
  next_fromFin  := sorry_proof
  next_toFin    := sorry_proof

instance (P : Prism)
  : Inhabited (Face P) := ⟨⟨P.repr.topFace, by simp, by simp⟩⟩

def faces {P : Prism} {n} (f : Face P n) (m : Option Nat := none)  := Iterable.fullRange (Face f.toPrism m)

end Face

namespace Prism

def faces (P : Prism) (n : Option Nat := none)  := Iterable.fullRange (Face P n)

end Prism

namespace Inclusion

def toFace (f : Inclusion Q P) : Face P Q.dim := ⟨f.1, f.2, by simp[Prism.dim, FaceRepr.dim]; rw[← f.3]; simp⟩

def comp (f : Inclusion Q P) (g : Inclusion S Q) : Inclusion S P :=
  ⟨f.repr.comp (g.repr.fromCanonical f.repr.toPrism (by simp[g.2, f.3]; done))
   (by simp[g.2, f.2]; done),
   by simp[f.2]; done,
   by simp[g.3]; done⟩

-- instance : Compose (Inclusion Q P) (Inclusion S Q) (Inclusion S P) where
--   compose f g := f.comp g

-- def toFin (f : Inclusion Q P) : Fin (P.faceCount Q.dim) := ⟨f.repr.index, sorry_proof⟩
-- def fromFin (Q P : Prism) (i : Fin (P.faceCount Q.dim)) : Inclusion Q P := ⟨FaceRepr.fromIndex P.1 Q.dim i, sorry_proof, sorry_proof⟩

end Inclusion

/-- Decomposition of a prism `P = P₁ * P₂`.

The internal representation of a decomposition is just `Fin n₁ × ... × Fin nₘ` for a prism `P = P₁^n₁ × ... × Pₘ^nₘ`.

When we have and element `(i₁, ..., iₘ) : PrismDecomposition P` we can construct the decomposition of `P` as:

    fst := P₁^i₁ × ... × Pₘ^iₘ
    snd := P₁^(n₁-i₁) × ... × Pₘ^(nₘ-iₘ)
 -/
def PrismDecomposition (P : Prism) := FinProd (P.prodTally.map (·.2+1))

-- with
--   @[computedField]
--   fst : (PrismDecomposition P) → Prism
--   | .powers ns => Prism.listProd <| P.prodTally.map (·.1) |>.zip ns.toList

  -- @[computedField]
  -- snd : (PrismDecomposition P) → Prism
  -- | .powers ns => (Prism.listProd <| P.prodTally.map (·.1) |>.zip ns.toListComplement

--------- PrismDecomposition -----------------------------------------
namespace PrismDecomposition

variable {l} {P : Prism}

def prisms (dec : PrismDecomposition P) : Prism × Prism :=
  let factors := P.prodTally.map (·.1)
  (Prism.listProd (factors |>.zip dec.toList),
   Prism.listProd (factors |>.zip dec.toListComplement))

/-- Given a prism decomposition `P = P₁ × P₂`, return `P₁` -/
def fst (dec : PrismDecomposition P) : Prism := dec.prisms.1
/-- Given a prism decomposition `P = P₁ × P₂`, return `P₂` -/
def snd (dec : PrismDecomposition P) : Prism := dec.prisms.2

/-- `PrismDecomposition P` truly represents a decomposition of a prism `P` -/
@[simp]
theorem mul_fst_snd (dec : PrismDecomposition P) : dec.fst * dec.snd = P := sorry_proof

instance : Enumtype (PrismDecomposition P) := by simp[PrismDecomposition]; infer_instance

end PrismDecomposition
----------------------------------------------------------------------

--------- Prism ------------------------------------------------------
namespace Prism

def topFace (P : Prism) : Face P P.dim := ⟨P.repr.topFace, by simp, by simp[FaceRepr.dim,Prism.dim]⟩

/-- Tries to find decomposition of `P` such that `P = P₁ * ??`
This is of course not possible in general and any excess powers ignored.

TODO: The implementation is really bad!!! Improve it!!
-/
def decomposeBy (P P₁ : Prism) : PrismDecomposition P :=
  let pt  := P.prodTally
  let pt₁ := P₁.prodTally

  let pt' := pt.map (λ (Pi, a) =>
    let find := pt₁.find? (λ ((Qi, _) : Prism × Nat) => Pi = Qi)
    match find with
    | some (_, b) => (Pi, b % (a+1))
    | none => (Pi, 0))

  let rec fromList {ns} (vals : List Nat) : FinProd ns :=
    match ns, vals with
    | [],  _ => Unit.unit
    | [n], [i] => ⟨i % n, sorry_proof⟩
    | n :: _ :: _, i :: j :: is => (⟨i % n, sorry_proof⟩, fromList (j :: is))
    | _, _ => absurd (a:=True) sorry_proof sorry_proof

  fromList (pt'.map (·.2))

/-- Number of `Q` prisms in `P` prism -/
def subprismCount (P Q : Prism) : Nat :=
  match P, Q with
  | ⟨.point, _⟩, ⟨.point, _⟩ => 1
  | ⟨.point, _⟩, _ => 0

  | ⟨.cone P', h⟩, ⟨.point, _⟩ =>
    let P' : Prism := ⟨P', by simp[h]⟩
    subprismCount P' point + 1
  | ⟨.cone P', h⟩, ⟨.cone Q', h'⟩ =>
    let P' : Prism := ⟨P', by simp[h]⟩
    let Q' : Prism := ⟨Q', by simp[h']⟩
    subprismCount P' Q' + subprismCount P' Q'.cone
  | ⟨.cone P', h⟩, ⟨.prod _ _, _⟩ =>
    let P' : Prism := ⟨P', by simp[h]⟩
    subprismCount P' Q

  | ⟨.prod P₁ P₂, _⟩, _ =>
    let P₁ : Prism := ⟨P₁, sorry_proof⟩
    let P₂ : Prism := ⟨P₂, sorry_proof⟩
    ∑ dec : (PrismDecomposition Q), subprismCount P₁ dec.fst * subprismCount P₂ dec.snd

-- TODO: Improve implementation, this is probably not very numerically stable
def barycentricInterpolate {P : Prism} {X} [Vec X] (f : Inclusion point P → X) (x : ℝ^{P.dim}) : X :=
  match P with
  | ⟨.point, h⟩ =>
    let ι : Inclusion point _ := ⟨.point, sorry_proof, sorry_proof⟩
    f ι
  | ⟨.cone P', _⟩ =>
    let x : ℝ^{P'.dim} := ⊞ i, x[⟨i.1,sorry_proof⟩]
    let t : ℝ := x[⟨P'.dim,sorry_proof⟩]

    let P' : Prism := ⟨P', sorry_proof⟩
    let f₀ := P'.barycentricInterpolate (λ ι => f ⟨ι.1.base, sorry_proof, sorry_proof⟩) (1/(1-t)*x)

    let f₁ := f ⟨.tip P'.1, sorry_proof, sorry_proof⟩

    (1-t) * f₀ + t * f₁
    -- f₁ + (1-t) * (f₀ - f₁)
    -- f₀ + t * (f₁-f₀)
  | ⟨.prod P Q, _⟩ =>
    let P : Prism := ⟨P, sorry_proof⟩
    let Q : Prism := ⟨Q, sorry_proof⟩
    let x : ℝ^{P.dim} := ⊞ i, x[⟨i.1,sorry_proof⟩]
    let y : ℝ^{Q.dim} := ⊞ i, x[⟨i.1+P.dim,sorry_proof⟩]

    P.barycentricInterpolate (x:=x) (λ ιP =>
      Q.barycentricInterpolate (x:=y) (λ ιQ =>
        f ⟨ιP.1.prod ιQ.1, sorry_proof, sorry_proof⟩))

end Prism

--------- Inclusion --------------------------------------------------
namespace Inclusion

def faceInclusion {P Q} (ι : Inclusion Q P) (x : ℝ^{Q.dim}) : ℝ^{P.dim} := sorry

variable {P Q : Prism}

/-- Splits `Inclusiton Q P` based on the decomposition `P = P₁ * P₂` into two inclusions `Inclusion Q₁ P₁` and `Inclusion Q₂ P₂`.

TODO: Reinspect this implementation, it was originally written for quotient implementation of Prism and might be problematic
-/
def split (ι : Inclusion Q P) (Pdec : PrismDecomposition P)
  : (Qdec : PrismDecomposition Q) × Inclusion Qdec.fst Pdec.fst × Inclusion Qdec.snd Pdec.snd
  :=
  let P₁ := Pdec.fst
  let P₂ := Pdec.snd
  match ι.repr.fromCanonical (P₁.repr.prod P₂.repr) sorry_proof with
  | .prod f g =>
    let Qdec : PrismDecomposition Q := Q.decomposeBy ⟨f.toPrism.toCanonical, sorry_proof⟩
    let ι₁ : Inclusion Qdec.fst Pdec.fst := ⟨f, sorry_proof, sorry_proof⟩
    let ι₂ : Inclusion Qdec.snd Pdec.snd := ⟨g, sorry_proof, sorry_proof⟩
    Sigma.mk Qdec (ι₁,ι₂) --, ι₂)
  | _ =>
    absurd (a := True) sorry_proof sorry_proof /- fromCanonical (P * Q) has to be always a face of type .prod f g -/

end Inclusion
----------------------------------------------------------------------

namespace Prism

def segment.point0 : Inclusion point segment := ⟨.base .point, sorry_proof, sorry_proof⟩
def segment.point1 : Inclusion point segment := ⟨.tip .point, sorry_proof, sorry_proof⟩

def triangle.point0 : Inclusion point triangle := ⟨.base (.base .point), sorry_proof, sorry_proof⟩
def triangle.point1 : Inclusion point triangle := ⟨.base (.tip .point), sorry_proof, sorry_proof⟩
def triangle.point2 : Inclusion point triangle := ⟨.tip (.cone .point), sorry_proof, sorry_proof⟩
def triangle.edge0 : Inclusion segment triangle := ⟨.base (.cone .point), sorry_proof, sorry_proof⟩
def triangle.edge1 : Inclusion segment triangle := ⟨.cone (.base .point), sorry_proof, sorry_proof⟩
def triangle.edge2 : Inclusion segment triangle := ⟨.cone (.tip .point), sorry_proof, sorry_proof⟩

end Prism

#eval show IO Unit from do
  let P := Prism.pyramid -- (Prism.cube*Prism.triangle*Prism.triangle)
  for (dec, li) in Enumtype.fullRange (PrismDecomposition P) do
    let d : FinProd _ := dec
    IO.println s!"{dec.fst} | {dec.snd} | {d.toList} {d.toListComplement}"

  for d in [0:P.dim+1] do
    IO.println s!"Listing {d}-faces:"
    for e in P.faces d do
      IO.println s!"index: {e.repr.index} | {FaceRepr.fromIndex P.1 d ⟨e.repr.index,sorry_proof⟩ == e.repr} | {e.repr}"

#eval show IO Unit from do
  for (dec, li) in Enumtype.fullRange (PrismDecomposition (Prism.square)) do
    let d : FinProd _ := dec
    IO.println s!"{dec.fst} | {dec.snd} | {d.toList} {d.toListComplement}"

    for e in Prism.square.faces (some 1) do
      let i : Inclusion Prism.segment Prism.square := ⟨e.1, sorry_proof, sorry_proof⟩
      let split := i.split dec
      IO.println s!"{split.2.1.repr} | {split.2.2.repr}"

#eval show IO Unit from do
  for (dec, li) in Enumtype.fullRange (PrismDecomposition (Prism.segment)) do
    let d : FinProd _ := dec
    IO.println s!"{dec.fst} | {dec.snd} | {d.toList} {d.toListComplement}"

    for e in Prism.segment.faces (some 0) do
      let i : Inclusion Prism.point Prism.segment := ⟨e.1, sorry_proof, sorry_proof⟩
      let split := i.split dec
      IO.println s!"{split.2.1.repr} | {split.2.2.repr}"


/-
Copyright (c) 2019 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl, Patrick Massot, Casper Putz, Anne Baanen
-/
import linear_algebra.matrix.nondegenerate
import linear_algebra.matrix.nonsingular_inverse
import linear_algebra.matrix.to_lin
import ring_theory.localization.fraction_ring
import ring_theory.localization.integer

/-!
# Matrices and linear equivalences

This file gives the map `matrix.to_linear_equiv` from matrices with invertible determinant,
to linear equivs.

## Main definitions

 * `matrix.to_linear_equiv`: a matrix with an invertible determinant forms a linear equiv

## Main results

 * `matrix.exists_mul_vec_eq_zero_iff`: `M` maps some `v ≠ 0` to zero iff `det M = 0`

## Tags

matrix, linear_equiv, determinant, inverse

-/

namespace matrix

open linear_map

variables {R M : Type*} [comm_ring R] [add_comm_group M] [module R M]
variables {n : Type*} [fintype n]

section to_linear_equiv'

variables [decidable_eq n]

/-- An invertible matrix yields a linear equivalence from the free module to itself.

See `matrix.to_linear_equiv` for the same map on arbitrary modules.
-/
def to_linear_equiv' (P : matrix n n R) (h : invertible P) : (n → R) ≃ₗ[R] (n → R) :=
{ inv_fun   := (⅟P).to_lin',
  left_inv  := λ v,
    show ((⅟P).to_lin'.comp P.to_lin') v = v,
    by rw [← matrix.to_lin'_mul, P.inv_of_mul_self, matrix.to_lin'_one, linear_map.id_apply],
  right_inv := λ v,
    show (P.to_lin'.comp (⅟P).to_lin') v = v,
    by rw [← matrix.to_lin'_mul, P.mul_inv_of_self, matrix.to_lin'_one, linear_map.id_apply],
  ..P.to_lin' }

@[simp] lemma to_linear_equiv'_apply (P : matrix n n R) (h : invertible P) :
  (↑(P.to_linear_equiv' h) : module.End R (n → R)) = P.to_lin' := rfl

@[simp] lemma to_linear_equiv'_symm_apply (P : matrix n n R) (h : invertible P) :
  (↑(P.to_linear_equiv' h).symm : module.End R (n → R)) = P⁻¹.to_lin' :=
show (⅟P).to_lin' = _, from congr_arg _ P.inv_of_eq_nonsing_inv

end to_linear_equiv'

section to_linear_equiv

variables (b : basis n R M)

include b

/-- Given `hA : is_unit A.det` and `b : basis R b`, `A.to_linear_equiv b hA` is
the `linear_equiv` arising from `to_lin b b A`.

See `matrix.to_linear_equiv'` for this result on `n → R`.
-/
@[simps apply]
noncomputable def to_linear_equiv [decidable_eq n] (A : matrix n n R) (hA : is_unit A.det) :
  M ≃ₗ[R] M :=
begin
  refine
  { to_fun := to_lin b b A,
    inv_fun := to_lin b b A⁻¹,
    left_inv := λ x, _,
    right_inv := λ x, _,
    .. to_lin b b A };
  rw ← linear_map.comp_apply;
  simp only [← matrix.to_lin_mul b b b,
             matrix.nonsing_inv_mul _ hA, matrix.mul_nonsing_inv _ hA,
             to_lin_one, linear_map.id_apply]
end

lemma ker_to_lin_eq_bot [decidable_eq n] (A : matrix n n R) (hA : is_unit A.det) :
  (to_lin b b A).ker = ⊥ :=
ker_eq_bot.mpr (to_linear_equiv b A hA).injective

lemma range_to_lin_eq_top [decidable_eq n] (A : matrix n n R) (hA : is_unit A.det) :
  (to_lin b b A).range = ⊤ :=
range_eq_top.mpr (to_linear_equiv b A hA).surjective

end to_linear_equiv

section nondegenerate

open_locale matrix

/-- This holds for all integral domains (see `matrix.exists_mul_vec_eq_zero_iff`),
not just fields, but it's easier to prove it for the field of fractions first. -/
lemma exists_mul_vec_eq_zero_iff_aux {K : Type*} [decidable_eq n] [field K] {M : matrix n n K} :
  (∃ (v ≠ 0), M.mul_vec v = 0) ↔ M.det = 0 :=
begin
  split,
  { rintros ⟨v, hv, mul_eq⟩,
    contrapose! hv,
    exact eq_zero_of_mul_vec_eq_zero hv mul_eq },
  { contrapose!,
    intros h,
    have : function.injective M.to_lin',
    { simpa only [← linear_map.ker_eq_bot, ker_to_lin'_eq_bot_iff, not_imp_not] using h },
    have : M ⬝ linear_map.to_matrix'
      ((linear_equiv.of_injective_endo M.to_lin' this).symm : (n → K) →ₗ[K] (n → K)) = 1,
    { refine matrix.to_lin'.injective (linear_map.ext $ λ v, _),
      rw [matrix.to_lin'_mul, matrix.to_lin'_one, matrix.to_lin'_to_matrix', linear_map.comp_apply],
      exact (linear_equiv.of_injective_endo M.to_lin' this).apply_symm_apply v },
    exact matrix.det_ne_zero_of_right_inverse this }
end

lemma exists_mul_vec_eq_zero_iff' {A : Type*} (K : Type*) [decidable_eq n]
  [comm_ring A] [nontrivial A]
  [field K] [algebra A K] [is_fraction_ring A K]
  {M : matrix n n A} :
  (∃ (v ≠ 0), M.mul_vec v = 0) ↔ M.det = 0 :=
begin
  have : (∃ (v ≠ 0), mul_vec ((algebra_map A K).map_matrix M) v = 0) ↔ _ :=
    exists_mul_vec_eq_zero_iff_aux,
  rw [← ring_hom.map_det, is_fraction_ring.to_map_eq_zero_iff] at this,
  refine iff.trans _ this, split; rintro ⟨v, hv, mul_eq⟩,
  { refine ⟨λ i, algebra_map _ _ (v i), mt (λ h, funext $ λ i, _) hv, _⟩,
    { exact is_fraction_ring.to_map_eq_zero_iff.mp (congr_fun h i) },
    { ext i,
      refine (ring_hom.map_mul_vec _ _ _ i).symm.trans _,
      rw [mul_eq, pi.zero_apply, ring_hom.map_zero, pi.zero_apply] } },
  { letI := classical.dec_eq K,
    obtain ⟨⟨b, hb⟩, ba_eq⟩ := is_localization.exist_integer_multiples_of_finset
      (non_zero_divisors A) (finset.univ.image v),
    choose f hf using ba_eq,
    refine ⟨λ i, f _ (finset.mem_image.mpr ⟨i, finset.mem_univ i, rfl⟩),
            mt (λ h, funext $ λ i, _) hv, _⟩,
    { have := congr_arg (algebra_map A K) (congr_fun h i),
      rw [hf, subtype.coe_mk, pi.zero_apply, ring_hom.map_zero, algebra.smul_def,
          mul_eq_zero, is_fraction_ring.to_map_eq_zero_iff] at this,
      exact this.resolve_left (non_zero_divisors.ne_zero hb), },
    { ext i,
      refine is_fraction_ring.injective A K _,
      calc algebra_map A K (M.mul_vec (λ (i : n), f (v i) _) i)
          = ((algebra_map A K).map_matrix M).mul_vec
              (algebra_map _ K b • v) i : _
      ... = 0 : _
      ... = algebra_map A K 0 : (ring_hom.map_zero _).symm,
      { simp_rw [ring_hom.map_mul_vec, mul_vec, dot_product, function.comp_app, hf,
          subtype.coe_mk, ring_hom.map_matrix_apply, pi.smul_apply, smul_eq_mul,
          algebra.smul_def] },
      { rw [mul_vec_smul, mul_eq, pi.smul_apply, pi.zero_apply, smul_zero] } } },
end

lemma exists_mul_vec_eq_zero_iff {A : Type*} [decidable_eq n] [comm_ring A] [is_domain A]
  {M : matrix n n A} :
  (∃ (v ≠ 0), M.mul_vec v = 0) ↔ M.det = 0 :=
exists_mul_vec_eq_zero_iff' (fraction_ring A)

lemma exists_vec_mul_eq_zero_iff {A : Type*} [decidable_eq n] [comm_ring A] [is_domain A]
  {M : matrix n n A} :
  (∃ (v ≠ 0), M.vec_mul v = 0) ↔ M.det = 0 :=
by simpa only [← M.det_transpose, ← mul_vec_transpose] using exists_mul_vec_eq_zero_iff

theorem nondegenerate_iff_det_ne_zero {A : Type*} [decidable_eq n] [comm_ring A] [is_domain A]
  {M : matrix n n A} :
  nondegenerate M ↔ M.det ≠ 0 :=
begin
  refine iff.trans _ (not_iff_not.mpr exists_vec_mul_eq_zero_iff),
  simp only [not_exists],
  split,
  { intros hM v hv hMv,
    obtain ⟨w, hwMv⟩ := hM.exists_not_ortho_of_ne_zero hv,
    simpa only [dot_product_mul_vec, hMv, zero_dot_product] using hwMv },
  { intros h v hv,
    refine not_imp_not.mp (h v) (funext $ λ i, _),
    simpa only [dot_product_mul_vec, dot_product_single, mul_one] using hv (pi.single i 1) }
end

alias nondegenerate_iff_det_ne_zero ↔ nondegenerate.det_ne_zero nondegenerate.of_det_ne_zero

end nondegenerate

end matrix


import algebra.algebra.tower
import ring_theory.localization.fraction_ring

def algebra.comp (R A B : Type*) [comm_semiring R] [comm_semiring A] [comm_semiring B]
  [algebra R A] [algebra A B] : algebra R B :=
(ring_hom.comp (algebra_map A B) (algebra_map R A)).to_algebra

lemma is_scalar_tower.comp (R A B : Type*) [comm_semiring R] [comm_semiring A] [comm_semiring B]
  [algebra R A] [algebra A B] :
  @is_scalar_tower R A B _ _ (algebra.comp R A B).to_has_smul :=
{ smul_assoc := λ r a b,
  begin
    letI : algebra R B := algebra.comp R A B,
    simp only [algebra.smul_def, map_mul, mul_assoc], refl,
  end }

@[priority 1000] instance is_scalar_tower.comp' (R A B S : Type*) [comm_semiring R] [comm_semiring A]
  [comm_semiring B] [comm_semiring S] [algebra R A] [algebra A B] [algebra A S] [algebra B S]
  [is_scalar_tower A B S] :
    @is_scalar_tower R B S (algebra.comp R A B).to_has_smul _ (algebra.comp R A S).to_has_smul:=
{ smul_assoc := λ x y z,
  begin
    haveI := is_scalar_tower.comp R A B,
    haveI := is_scalar_tower.comp R A S,
    nth_rewrite 0 [← one_smul A y],
    rw [← one_smul A (y • z), ← smul_assoc, ← smul_assoc, ← smul_assoc],
  end }

lemma algebra_map_injective' (R A K : Type*) [comm_ring R] [field A] [algebra R A]
  [is_fraction_ring R A] [field K] [algebra R K] [algebra A K] [is_scalar_tower R A K] :
  function.injective ⇑(algebra_map R K) :=
begin
  rw is_scalar_tower.algebra_map_eq R A K,
  exact function.injective.comp ((algebra_map A K).injective) (is_fraction_ring.injective R A)
end


/-
Copyright (c) 2020 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison, Bhavik Mehta
-/
import category_theory.monoidal.category
import category_theory.adjunction.limits
import category_theory.adjunction.mates

/-!
# Closed monoidal categories

Define (right) closed objects and (right) closed monoidal categories.

## TODO
Some of the theorems proved about cartesian closed categories
should be generalised and moved to this file.
-/
universes v u u₂

namespace category_theory

open category monoidal_category

/-- An object `X` is (right) closed if `(X ⊗ -)` is a left adjoint. -/
class closed {C : Type u} [category.{v} C] [monoidal_category.{v} C] (X : C) :=
(is_adj : is_left_adjoint (tensor_left X))

/-- A monoidal category `C` is (right) monoidal closed if every object is (right) closed. -/
class monoidal_closed (C : Type u) [category.{v} C] [monoidal_category.{v} C] :=
(closed' : Π (X : C), closed X)

attribute [instance, priority 100] monoidal_closed.closed'

variables {C : Type u} [category.{v} C] [monoidal_category.{v} C]

/--
If `X` and `Y` are closed then `X ⊗ Y` is.
This isn't an instance because it's not usually how we want to construct internal homs,
we'll usually prove all objects are closed uniformly.
-/
def tensor_closed {X Y : C}
  (hX : closed X) (hY : closed Y) : closed (X ⊗ Y) :=
{ is_adj :=
  begin
    haveI := hX.is_adj,
    haveI := hY.is_adj,
    exact adjunction.left_adjoint_of_nat_iso (monoidal_category.tensor_left_tensor _ _).symm
  end }

/--
The unit object is always closed.
This isn't an instance because most of the time we'll prove closedness for all objects at once,
rather than just for this one.
-/
def unit_closed : closed (𝟙_ C) :=
{ is_adj :=
  { right := 𝟭 C,
    adj := adjunction.mk_of_hom_equiv
    { hom_equiv := λ X _,
      { to_fun := λ a, (left_unitor X).inv ≫ a,
        inv_fun := λ a, (left_unitor X).hom ≫ a,
        left_inv := by tidy,
        right_inv := by tidy },
      hom_equiv_naturality_left_symm' := λ X' X Y f g,
      by { dsimp, rw left_unitor_naturality_assoc } } } }

variables (A B : C) {X X' Y Y' Z : C}

variables [closed A]

/--
This is the internal hom `A ⟶[C] -`.
Note that this is essentially an opaque definition,
and so will not agree definitionally with any "native" internal hom the category has.

TODO: we could introduce a `has_ihom` class
that allows specifying a particular definition of the internal hom,
and provide a low priority opaque instance.
-/
def ihom : C ⥤ C :=
(@closed.is_adj _ _ _ A _).right

namespace ihom

/-- The adjunction between `A ⊗ -` and `A ⟹ -`. -/
def adjunction : tensor_left A ⊣ ihom A :=
closed.is_adj.adj

/-- The evaluation natural transformation. -/
def ev : ihom A ⋙ tensor_left A ⟶ 𝟭 C :=
(ihom.adjunction A).counit

/-- The coevaluation natural transformation. -/
def coev : 𝟭 C ⟶ tensor_left A ⋙ ihom A :=
(ihom.adjunction A).unit

@[simp] lemma ihom_adjunction_counit : (ihom.adjunction A).counit = ev A := rfl
@[simp] lemma ihom_adjunction_unit : (ihom.adjunction A).unit = coev A := rfl

@[simp, reassoc]
lemma ev_naturality {X Y : C} (f : X ⟶ Y) :
  ((𝟙 A) ⊗ ((ihom A).map f)) ≫ (ev A).app Y = (ev A).app X ≫ f :=
(ev A).naturality f

@[simp, reassoc]
lemma coev_naturality {X Y : C} (f : X ⟶ Y) :
  f ≫ (coev A).app Y = (coev A).app X ≫ (ihom A).map ((𝟙 A) ⊗ f) :=
(coev A).naturality f

notation A ` ⟶[`C`] ` B:10 := (@ihom C _ _ A _).obj B

@[simp, reassoc] lemma ev_coev :
  ((𝟙 A) ⊗ ((coev A).app B)) ≫ (ev A).app (A ⊗ B) = 𝟙 (A ⊗ B) :=
adjunction.left_triangle_components (ihom.adjunction A)

@[simp, reassoc] lemma coev_ev :
  (coev A).app (A ⟶[C] B) ≫ (ihom A).map ((ev A).app B) = 𝟙 (A ⟶[C] B) :=
adjunction.right_triangle_components (ihom.adjunction A)

end ihom

open category_theory.limits

instance : preserves_colimits (tensor_left A) :=
(ihom.adjunction A).left_adjoint_preserves_colimits

variables {A}

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

/-- Currying in a monoidal closed category. -/
def curry : (A ⊗ Y ⟶ X) → (Y ⟶ (A ⟶[C] X)) :=
(ihom.adjunction A).hom_equiv _ _
/-- Uncurrying in a monoidal closed category. -/
def uncurry : (Y ⟶ (A ⟶[C] X)) → (A ⊗ Y ⟶ X) :=
((ihom.adjunction A).hom_equiv _ _).symm

@[simp] lemma hom_equiv_apply_eq (f : A ⊗ Y ⟶ X) :
  (ihom.adjunction A).hom_equiv _ _ f = curry f := rfl
@[simp] lemma hom_equiv_symm_apply_eq (f : Y ⟶ (A ⟶[C] X)) :
  ((ihom.adjunction A).hom_equiv _ _).symm f = uncurry f := rfl

@[reassoc]
lemma curry_natural_left (f : X ⟶ X') (g : A ⊗ X' ⟶ Y) :
  curry (((𝟙 _) ⊗ f) ≫ g) = f ≫ curry g :=
adjunction.hom_equiv_naturality_left _ _ _

@[reassoc]
lemma curry_natural_right (f : A ⊗ X ⟶ Y) (g : Y ⟶ Y') :
  curry (f ≫ g) = curry f ≫ (ihom _).map g :=
adjunction.hom_equiv_naturality_right _ _ _

@[reassoc]
lemma uncurry_natural_right  (f : X ⟶ (A ⟶[C] Y)) (g : Y ⟶ Y') :
  uncurry (f ≫ (ihom _).map g) = uncurry f ≫ g :=
adjunction.hom_equiv_naturality_right_symm _ _ _

@[reassoc]
lemma uncurry_natural_left  (f : X ⟶ X') (g : X' ⟶ (A ⟶[C] Y)) :
  uncurry (f ≫ g) = ((𝟙 _) ⊗ f) ≫ uncurry g :=
adjunction.hom_equiv_naturality_left_symm _ _ _

@[simp]
lemma uncurry_curry (f : A ⊗ X ⟶ Y) : uncurry (curry f) = f :=
(closed.is_adj.adj.hom_equiv _ _).left_inv f

@[simp]
lemma curry_uncurry (f : X ⟶ (A ⟶[C] Y)) : curry (uncurry f) = f :=
(closed.is_adj.adj.hom_equiv _ _).right_inv f

lemma curry_eq_iff (f : A ⊗ Y ⟶ X) (g : Y ⟶ (A ⟶[C] X)) :
  curry f = g ↔ f = uncurry g :=
adjunction.hom_equiv_apply_eq _ f g

lemma eq_curry_iff (f : A ⊗ Y ⟶ X) (g : Y ⟶ (A ⟶[C] X)) :
  g = curry f ↔ uncurry g = f :=
adjunction.eq_hom_equiv_apply _ f g

-- I don't think these two should be simp.
lemma uncurry_eq (g : Y ⟶ (A ⟶[C] X)) : uncurry g = ((𝟙 A) ⊗ g) ≫ (ihom.ev A).app X :=
adjunction.hom_equiv_counit _

lemma curry_eq (g : A ⊗ Y ⟶ X) : curry g = (ihom.coev A).app Y ≫ (ihom A).map g :=
adjunction.hom_equiv_unit _

lemma curry_injective : function.injective (curry : (A ⊗ Y ⟶ X) → (Y ⟶ (A ⟶[C] X))) :=
(closed.is_adj.adj.hom_equiv _ _).injective

lemma uncurry_injective : function.injective (uncurry : (Y ⟶ (A ⟶[C] X)) → (A ⊗ Y ⟶ X)) :=
(closed.is_adj.adj.hom_equiv _ _).symm.injective

variables (A X)

lemma uncurry_id_eq_ev : uncurry (𝟙 (A ⟶[C] X)) = (ihom.ev A).app X :=
by rw [uncurry_eq, tensor_id, id_comp]

lemma curry_id_eq_coev : curry (𝟙 _) = (ihom.coev A).app X :=
by { rw [curry_eq, (ihom A).map_id (A ⊗ _)], apply comp_id }

section pre

variables {A B} [closed B]

/-- Pre-compose an internal hom with an external hom. -/
def pre (f : B ⟶ A) : ihom A ⟶ ihom B :=
transfer_nat_trans_self (ihom.adjunction _) (ihom.adjunction _) ((tensoring_left C).map f)

lemma uncurry_pre (f : B ⟶ A) (X : C) :
  monoidal_closed.uncurry ((pre f).app X) = (f ⊗ 𝟙 _) ≫ (ihom.ev A).app X :=
by rw [uncurry_eq, id_tensor_pre_app_comp_ev]

lemma coev_app_comp_pre_app (f : B ⟶ A) :
  (ihom.coev A).app X ≫ (pre f).app (A ⊗ X) =
    (ihom.coev B).app X ≫ (ihom B).map (f ⊗ (𝟙 _)) :=
unit_transfer_nat_trans_self _ _ ((tensoring_left C).map f) X

@[simp]
lemma pre_id (A : C) [closed A] : pre (𝟙 A) = 𝟙 _ :=
by { simp only [pre, functor.map_id], dsimp, simp, }

@[simp]
lemma pre_map {A₁ A₂ A₃ : C} [closed A₁] [closed A₂] [closed A₃]
  (f : A₁ ⟶ A₂) (g : A₂ ⟶ A₃) :
  pre (f ≫ g) = pre g ≫ pre f :=
by rw [pre, pre, pre, transfer_nat_trans_self_comp, (tensoring_left C).map_comp]

end pre

/-- The internal hom functor given by the monoidal closed structure. -/
def internal_hom [monoidal_closed C] : Cᵒᵖ ⥤ C ⥤ C :=
{ obj := λ X, ihom X.unop,
  map := λ X Y f, pre f.unop }

end monoidal_closed

end category_theory


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

/-!
# Filtered colimits commute with finite limits.

We show that for a functor `F : J × K ⥤ Type v`, when `J` is finite and `K` is filtered,
the universal morphism `colimit_limit_to_limit_colimit F` comparing the
colimit (over `K`) of the limits (over `J`) with the limit of the colimits is an isomorphism.

(In fact, to prove that it is injective only requires that `J` has finitely many objects.)

## References
* Borceux, Handbook of categorical algebra 1, Theorem 2.13.4
* [Stacks: Filtered colimits](https://stacks.math.columbia.edu/tag/002W)
-/

universes v u

open category_theory
open category_theory.category
open category_theory.limits.types
open category_theory.limits.types.filtered_colimit

namespace category_theory.limits

variables {J K : Type v} [small_category J] [small_category K]
variables (F : J × K ⥤ Type v)

open category_theory.prod

variables [is_filtered K]

section
/-!
Injectivity doesn't need that we have finitely many morphisms in `J`,
only that there are finitely many objects.
-/
variables [fintype J]

/--
This follows this proof from
* Borceux, Handbook of categorical algebra 1, Theorem 2.13.4
-/
lemma colimit_limit_to_limit_colimit_injective :
  function.injective (colimit_limit_to_limit_colimit F) :=
begin
  classical,

  -- Suppose we have two terms `x y` in the colimit (over `K`) of the limits (over `J`),
  -- and that these have the same image under `colimit_limit_to_limit_colimit F`.
  intros x y h,
  -- These elements of the colimit have representatives somewhere:
  obtain ⟨kx, x, rfl⟩ := jointly_surjective' x,
  obtain ⟨ky, y, rfl⟩ := jointly_surjective' y,
  dsimp at x y,

  -- Since the images of `x` and `y` are equal in a limit, they are equal componentwise
  -- (indexed by `j : J`),
  replace h := λ j, congr_arg (limit.π ((curry.obj F) ⋙ colim) j) h,
  -- and they are equations in a filtered colimit,
  -- so for each `j` we have some place `k j` to the right of both `kx` and `ky`
  simp [colimit_eq_iff] at h,
  let k := λ j, (h j).some,
  let f : Π j, kx ⟶ k j := λ j, (h j).some_spec.some,
  let g : Π j, ky ⟶ k j := λ j, (h j).some_spec.some_spec.some,
  -- where the images of the components of the representatives become equal:
  have w : Π j,
    F.map ((𝟙 j, f j) : (j, kx) ⟶ (j, k j)) (limit.π ((curry.obj (swap K J ⋙ F)).obj kx) j x) =
    F.map ((𝟙 j, g j) : (j, ky) ⟶ (j, k j)) (limit.π ((curry.obj (swap K J ⋙ F)).obj ky) j y) :=
    λ j, (h j).some_spec.some_spec.some_spec,

  -- We now use that `K` is filtered, picking some point to the right of all these
  -- morphisms `f j` and `g j`.
  let O : finset K := (finset.univ).image k ∪ {kx, ky},
  have kxO : kx ∈ O := finset.mem_union.mpr (or.inr (by simp)),
  have kyO : ky ∈ O := finset.mem_union.mpr (or.inr (by simp)),
  have kjO : ∀ j, k j ∈ O := λ j, finset.mem_union.mpr (or.inl (by simp)),

  let H : finset (Σ' (X Y : K) (mX : X ∈ O) (mY : Y ∈ O), X ⟶ Y) :=
    (finset.univ).image (λ j : J, ⟨kx, k j, kxO,
      finset.mem_union.mpr (or.inl (by simp)),
      f j⟩) ∪
    (finset.univ).image (λ j : J, ⟨ky, k j, kyO,
      finset.mem_union.mpr (or.inl (by simp)),
      g j⟩),
  obtain ⟨S, T, W⟩ := is_filtered.sup_exists O H,

  have fH :
    ∀ j, (⟨kx, k j, kxO, kjO j, f j⟩ : (Σ' (X Y : K) (mX : X ∈ O) (mY : Y ∈ O), X ⟶ Y)) ∈ H :=
    λ j, (finset.mem_union.mpr (or.inl
    begin
      simp only [true_and, finset.mem_univ, eq_self_iff_true, exists_prop_of_true,
        finset.mem_image, heq_iff_eq],
      refine ⟨j, rfl, _⟩,
      simp only [heq_iff_eq],
      exact ⟨rfl, rfl, rfl⟩,
    end)),
  have gH :
    ∀ j, (⟨ky, k j, kyO, kjO j, g j⟩ : (Σ' (X Y : K) (mX : X ∈ O) (mY : Y ∈ O), X ⟶ Y)) ∈ H :=
    λ j, (finset.mem_union.mpr (or.inr
    begin
      simp only [true_and, finset.mem_univ, eq_self_iff_true, exists_prop_of_true,
        finset.mem_image, heq_iff_eq],
      refine ⟨j, rfl, _⟩,
      simp only [heq_iff_eq],
      exact ⟨rfl, rfl, rfl⟩,
    end)),

  -- Our goal is now an equation between equivalence classes of representatives of a colimit,
  -- and so it suffices to show those representative become equal somewhere, in particular at `S`.
  apply colimit_sound' (T kxO) (T kyO),

  -- We can check if two elements of a limit (in `Type`) are equal by comparing them componentwise.
  ext,

  -- Now it's just a calculation using `W` and `w`.
  simp only [functor.comp_map, limit.map_π_apply, curry.obj_map_app, swap_map],
  rw ←W _ _ (fH j),
  rw ←W _ _ (gH j),
  simp [w],
end

end

variables [fin_category J]

/--
This follows this proof from
* Borceux, Handbook of categorical algebra 1, Theorem 2.13.4
although with different names.
-/
lemma colimit_limit_to_limit_colimit_surjective :
  function.surjective (colimit_limit_to_limit_colimit F) :=
begin
  classical,
  -- We begin with some element `x` in the limit (over J) over the colimits (over K),
  intro x,
  -- This consists of some coherent family of elements in the various colimits,
  -- and so our first task is to pick representatives of these elements.
  have z := λ j, jointly_surjective' (limit.π (curry.obj F ⋙ limits.colim) j x),
  -- `k : J ⟶ K` records where the representative of the element in the `j`-th element of `x` lives
  let k : J → K := λ j, (z j).some,
  -- `y j : F.obj (j, k j)` is the representative
  let y : Π j, F.obj (j, k j) := λ j, (z j).some_spec.some,
  -- and we record that these representatives, when mapped back into the relevant colimits,
  -- are actually the components of `x`.
  have e : ∀ j,
    colimit.ι ((curry.obj F).obj j) (k j) (y j) =
    limit.π (curry.obj F ⋙ limits.colim) j x := λ j, (z j).some_spec.some_spec,
  clear_value k y, -- A little tidying up of things we no longer need.
  clear z,

  -- As a first step, we use that `K` is filtered to pick some point `k' : K` above all the `k j`
  let k' : K := is_filtered.sup (finset.univ.image k) ∅,
  -- and name the morphisms as `g j : k j ⟶ k'`.
  have g : Π j, k j ⟶ k' := λ j, is_filtered.to_sup (finset.univ.image k) ∅ (by simp),
  clear_value k',

  -- Recalling that the components of `x`, which are indexed by `j : J`, are "coherent",
  -- in other words preserved by morphisms in the `J` direction,
  -- we see that for any morphism `f : j ⟶ j'` in `J`,
  -- the images of `y j` and `y j'`, when mapped to `F.obj (j', k')` respectively by
  -- `(f, g j)` and `(𝟙 j', g j')`, both represent the same element in the colimit.
  have w : ∀ {j j' : J} (f : j ⟶ j'),
    colimit.ι ((curry.obj F).obj j') k' (F.map ((𝟙 j', g j') : (j', k j') ⟶ (j', k')) (y j')) =
    colimit.ι ((curry.obj F).obj j') k' (F.map ((f, g j) : (j, k j) ⟶ (j', k')) (y j)),
  { intros j j' f,
    have t : (f, g j) = (((f, 𝟙 (k j)) : (j, k j) ⟶ (j', k j)) ≫ (𝟙 j', g j) : (j, k j) ⟶ (j', k')),
    { simp only [id_comp, comp_id, prod_comp], },
    erw [colimit.w_apply, t, functor_to_types.map_comp_apply, colimit.w_apply, e,
      ←limit.w_apply f, ←e],
    simp, },

  -- Because `K` is filtered, we can restate this as saying that
  -- for each such `f`, there is some place to the right of `k'`
  -- where these images of `y j` and `y j'` become equal.
  simp_rw colimit_eq_iff at w,

  -- We take a moment to restate `w` more conveniently.
  let kf : Π {j j'} (f : j ⟶ j'), K := λ _ _ f, (w f).some,
  let gf : Π {j j'} (f : j ⟶ j'), k' ⟶ kf f := λ _ _ f, (w f).some_spec.some,
  let hf : Π {j j'} (f : j ⟶ j'), k' ⟶ kf f := λ _ _ f, (w f).some_spec.some_spec.some,
  have wf : Π {j j'} (f : j ⟶ j'),
    F.map ((𝟙 j', g j' ≫ gf f) : (j', k j') ⟶ (j', kf f)) (y j') =
    F.map ((f, g j ≫ hf f) : (j, k j) ⟶ (j', kf f)) (y j) := λ j j' f,
  begin
    have q :
      ((curry.obj F).obj j').map (gf f) (F.map _ (y j')) =
      ((curry.obj F).obj j').map (hf f) (F.map _ (y j)) :=
      (w f).some_spec.some_spec.some_spec,
    dsimp at q,
    simp_rw ←functor_to_types.map_comp_apply at q,
    convert q; simp only [comp_id],
  end,
  clear_value kf gf hf, -- and clean up some things that are no longer needed.
  clear w,

  -- We're now ready to use the fact that `K` is filtered a second time,
  -- picking some place to the right of all of
  -- the morphisms `gf f : k' ⟶ kh f` and `hf f : k' ⟶ kf f`.
  -- At this point we're relying on there being only finitely morphisms in `J`.
  let O := finset.univ.bUnion (λ j, finset.univ.bUnion (λ j', finset.univ.image (@kf j j'))) ∪ {k'},
  have kfO : ∀ {j j'} (f : j ⟶ j'), kf f ∈ O := λ j j' f, finset.mem_union.mpr (or.inl (
  begin
    rw [finset.mem_bUnion],
    refine ⟨j, finset.mem_univ j, _⟩,
    rw [finset.mem_bUnion],
    refine ⟨j', finset.mem_univ j', _⟩,
    rw [finset.mem_image],
    refine ⟨f, finset.mem_univ _, _⟩,
    refl,
  end)),
  have k'O : k' ∈ O := finset.mem_union.mpr (or.inr (finset.mem_singleton.mpr rfl)),
  let H : finset (Σ' (X Y : K) (mX : X ∈ O) (mY : Y ∈ O), X ⟶ Y) :=
    finset.univ.bUnion (λ j : J, finset.univ.bUnion (λ j' : J, finset.univ.bUnion (λ f : j ⟶ j',
      {⟨k', kf f, k'O, kfO f, gf f⟩, ⟨k', kf f, k'O, kfO f, hf f⟩}))),

  obtain ⟨k'', i', s'⟩ := is_filtered.sup_exists O H,
  -- We then restate this slightly more conveniently, as a family of morphism `i f : kf f ⟶ k''`,
  -- satisfying `gf f ≫ i f = hf f' ≫ i f'`.
  let i : Π {j j'} (f : j ⟶ j'), kf f ⟶ k'' := λ j j' f, i' (kfO f),
  have s : ∀ {j₁ j₂ j₃ j₄} (f : j₁ ⟶ j₂) (f' : j₃ ⟶ j₄), gf f ≫ i f = hf f' ≫ i f' :=
  begin
    intros,
    rw [s', s'],
    swap 2,
    exact k'O,
    swap 2,
    { rw [finset.mem_bUnion],
      refine ⟨j₁, finset.mem_univ _, _⟩,
      rw [finset.mem_bUnion],
      refine ⟨j₂, finset.mem_univ _, _⟩,
      rw [finset.mem_bUnion],
      refine ⟨f, finset.mem_univ _, _⟩,
      simp only [true_or, eq_self_iff_true, and_self, finset.mem_insert, heq_iff_eq], },
    { rw [finset.mem_bUnion],
      refine ⟨j₃, finset.mem_univ _, _⟩,
      rw [finset.mem_bUnion],
      refine ⟨j₄, finset.mem_univ _, _⟩,
      rw [finset.mem_bUnion],
      refine ⟨f', finset.mem_univ _, _⟩,
      simp only [eq_self_iff_true, or_true, and_self, finset.mem_insert, finset.mem_singleton,
        heq_iff_eq], }
  end,
  clear_value i,
  clear s' i' H kfO k'O O,

  -- We're finally ready to construct the pre-image, and verify it really maps to `x`.
  fsplit,

  { -- We construct the pre-image (which, recall is meant to be a point
    -- in the colimit (over `K`) of the limits (over `J`)) via a representative at `k''`.
    apply colimit.ι (curry.obj (swap K J ⋙ F) ⋙ limits.lim) k'' _,
    dsimp,
    -- This representative is meant to be an element of a limit,
    -- so we need to construct a family of elements in `F.obj (j, k'')` for varying `j`,
    -- then show that are coherent with respect to morphisms in the `j` direction.
    ext, swap,
    { -- We construct the elements as the images of the `y j`.
      exact λ j, F.map (⟨𝟙 j, g j ≫ gf (𝟙 j) ≫ i (𝟙 j)⟩ : (j, k j) ⟶ (j, k'')) (y j), },
    { -- After which it's just a calculation, using `s` and `wf`, to see they are coherent.
      dsimp,
      simp only [←functor_to_types.map_comp_apply, prod_comp, id_comp, comp_id],
      calc F.map ((f, g j ≫ gf (𝟙 j) ≫ i (𝟙 j)) : (j, k j) ⟶ (j', k'')) (y j)
          = F.map ((f, g j ≫ hf f ≫ i f) : (j, k j) ⟶ (j', k'')) (y j)
                : by rw s (𝟙 j) f
      ... = F.map ((𝟙 j', i f) : (j', kf f) ⟶ (j', k''))
              (F.map ((f, g j ≫ hf f) : (j, k j) ⟶ (j', kf f)) (y j))
                : by rw [←functor_to_types.map_comp_apply, prod_comp, comp_id, assoc]
      ... = F.map ((𝟙 j', i f) : (j', kf f) ⟶ (j', k''))
              (F.map ((𝟙 j', g j' ≫ gf f) : (j', k j') ⟶ (j', kf f)) (y j'))
                : by rw ←wf f
      ... = F.map ((𝟙 j', g j' ≫ gf f ≫ i f) : (j', k j') ⟶ (j', k'')) (y j')
                : by rw [←functor_to_types.map_comp_apply, prod_comp, id_comp, assoc]
      ... = F.map ((𝟙 j', g j' ≫ gf (𝟙 j') ≫ i (𝟙 j')) : (j', k j') ⟶ (j', k'')) (y j')
                : by rw [s f (𝟙 j'), ←s (𝟙 j') (𝟙 j')], }, },

  -- Finally we check that this maps to `x`.
  { -- We can do this componentwise:
    apply limit_ext,
    intro j,

    -- and as each component is an equation in a colimit, we can verify it by
    -- pointing out the morphism which carries one representative to the other:
    simp only [←e, colimit_eq_iff, curry.obj_obj_map, limit.π_mk,
      bifunctor.map_id_comp, id.def, types_comp_apply,
      limits.ι_colimit_limit_to_limit_colimit_π_apply],
    refine ⟨k'', 𝟙 k'', g j ≫ gf (𝟙 j) ≫ i (𝟙 j), _⟩,
    simp only [bifunctor.map_id_comp, types_comp_apply, bifunctor.map_id, types_id_apply], },
end

instance colimit_limit_to_limit_colimit_is_iso :
  is_iso (colimit_limit_to_limit_colimit F) :=
(is_iso_iff_bijective _).mpr
  ⟨colimit_limit_to_limit_colimit_injective F, colimit_limit_to_limit_colimit_surjective F⟩

end category_theory.limits


/-
Copyright (c) 2019 Zhouhang Zhou. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Zhouhang Zhou
-/
import algebra.pointwise
import order.filter.basic
/-!
# 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)`

-/

open classical set

universes u v w
variables {α : Type u} {β : Type v} {γ : Type w}

open_locale classical pointwise

namespace filter
open set

@[to_additive]
instance [has_one α] : has_one (filter α) := ⟨principal 1⟩

@[simp, to_additive]
lemma mem_one [has_one α] (s : set α) : s ∈ (1 : filter α) ↔ (1:α) ∈ s :=
calc
  s ∈ (1:filter α) ↔ 1 ⊆ s : iff.rfl
  ... ↔ (1 : α) ∈ s : by simp

@[to_additive]
instance [monoid α] : has_mul (filter α) := ⟨λf g,
{ sets             := { s | ∃t₁ t₂, t₁ ∈ f ∧ t₂ ∈ g ∧ t₁ * t₂ ⊆ s },
  univ_sets        :=
  begin
    have h₁ : (∃x, x ∈ f) := ⟨univ, univ_sets f⟩,
    have h₂ : (∃x, x ∈ g) := ⟨univ, univ_sets g⟩,
    simpa using and.intro h₁ h₂
  end,
  sets_of_superset := λx y hx hxy,
  begin
   rcases hx with ⟨t₁, ht₁, t₂, ht₂, t₁t₂⟩,
   exact ⟨t₁, ht₁, t₂, ht₂, subset.trans t₁t₂ hxy⟩
  end,
  inter_sets       := λx y,
  begin
    simp only [exists_prop, mem_set_of_eq, subset_inter_iff],
    rintros ⟨s₁, s₂, hs₁, hs₂, s₁s₂⟩ ⟨t₁, t₂, ht₁, ht₂, t₁t₂⟩,
    exact ⟨s₁ ∩ t₁, s₂ ∩ t₂, inter_sets f hs₁ ht₁, inter_sets g hs₂ ht₂,
    subset.trans (mul_subset_mul (inter_subset_left _ _) (inter_subset_left _ _)) s₁s₂,
    subset.trans (mul_subset_mul (inter_subset_right _ _) (inter_subset_right _ _)) t₁t₂⟩,
  end }⟩

@[to_additive]
lemma mem_mul [monoid α] {f g : filter α} {s : set α} :
  s ∈ f * g ↔ ∃t₁ t₂, t₁ ∈ f ∧ t₂ ∈ g ∧ t₁ * t₂  ⊆ s := iff.rfl

@[to_additive]
lemma mul_mem_mul [monoid α] {f g : filter α} {s t : set α} (hs : s ∈ f) (ht : t ∈ g) :
  s * t ∈ f * g := ⟨_, _, hs, ht, subset.refl _⟩

@[to_additive]
protected lemma mul_le_mul [monoid α] {f₁ f₂ g₁ g₂ : filter α} (hf : f₁ ≤ f₂) (hg : g₁ ≤ g₂) :
  f₁ * g₁ ≤ f₂ * g₂ := assume _ ⟨s, t, hs, ht, hst⟩, ⟨s, t, hf hs, hg ht, hst⟩

@[to_additive]
lemma ne_bot.mul [monoid α] {f g : filter α} : ne_bot f → ne_bot g → ne_bot (f * g) :=
begin
  simp only [forall_mem_nonempty_iff_ne_bot.symm],
  rintros hf hg s ⟨a, b, ha, hb, ab⟩,
  exact ((hf a ha).mul (hg b hb)).mono ab
end

@[to_additive]
protected lemma mul_assoc [monoid α] (f g h : filter α) : f * g * h = f * (g * h) :=
begin
  ext s, split,
  { rintros ⟨a, b, ⟨a₁, a₂, ha₁, ha₂, a₁a₂⟩, hb, ab⟩,
    refine ⟨a₁, a₂ * b, ha₁, mul_mem_mul ha₂ hb, _⟩, rw [← mul_assoc],
    calc
      a₁ * a₂ * b ⊆ a * b : mul_subset_mul a₁a₂ (subset.refl _)
      ...         ⊆ s     : ab },
  { rintros ⟨a, b, ha, ⟨b₁, b₂, hb₁, hb₂, b₁b₂⟩, ab⟩,
    refine ⟨a * b₁, b₂, mul_mem_mul ha hb₁, hb₂, _⟩, rw [mul_assoc],
    calc
      a * (b₁ * b₂) ⊆ a * b : mul_subset_mul (subset.refl _) b₁b₂
      ...           ⊆ s     : ab }
end

@[to_additive]
protected lemma one_mul [monoid α] (f : filter α) : 1 * f = f :=
begin
  ext s, split,
  { rintros ⟨t₁, t₂, ht₁, ht₂, t₁t₂⟩,
    refine mem_of_superset (mem_of_superset ht₂ _) t₁t₂,
    assume x hx,
    exact ⟨1, x, by rwa [← mem_one], hx, one_mul _⟩ },
  { assume hs, refine ⟨(1:set α), s, mem_principal_self _, hs, by simp only [one_mul]⟩ }
end

@[to_additive]
protected lemma mul_one [monoid α] (f : filter α) : f * 1 = f :=
begin
  ext s, split,
  { rintros ⟨t₁, t₂, ht₁, ht₂, t₁t₂⟩,
    refine mem_of_superset (mem_of_superset ht₁ _) t₁t₂,
    assume x hx,
    exact ⟨x, 1, hx, by rwa [← mem_one], mul_one _⟩ },
  { assume hs,
    refine ⟨s, (1:set α), hs, mem_principal_self _, by simp only [mul_one]⟩ }
end

@[to_additive filter.add_monoid]
instance [monoid α] : monoid (filter α) :=
{ mul_assoc := filter.mul_assoc,
  one_mul := filter.one_mul,
  mul_one := filter.mul_one,
  .. filter.has_mul,
  .. filter.has_one }

section map

variables [monoid α] [monoid β] {f : filter α} (m : mul_hom α β) (φ : α →* β)

@[to_additive]
protected lemma map_mul {f₁ f₂ : filter α} : map m (f₁ * f₂) = map m f₁ * map m f₂ :=
begin
  ext s,
  simp only [mem_mul], split,
  { rintro ⟨t₁, t₂, ht₁, ht₂, t₁t₂⟩,
    have : m '' (t₁ * t₂) ⊆ s := subset.trans (image_subset m t₁t₂) (image_preimage_subset _ _),
    refine ⟨m '' t₁, m '' t₂, image_mem_map ht₁, image_mem_map ht₂, _⟩,
    rwa ← image_mul m },
  { rintro ⟨t₁, t₂, ht₁, ht₂, t₁t₂⟩,
    refine ⟨m ⁻¹' t₁, m ⁻¹' t₂, ht₁, ht₂, image_subset_iff.1 _⟩,
    rw image_mul m,
    exact subset.trans
      (mul_subset_mul (image_preimage_subset _ _) (image_preimage_subset _ _)) t₁t₂ },
end

@[to_additive]
protected lemma map_one : map φ (1:filter α) = 1 :=
le_antisymm
  (le_principal_iff.2 $ mem_map_iff_exists_image.2 ⟨(1:set α), by simp,
    by { assume x, simp [φ.map_one] }⟩)
  (le_map $ assume s hs,
   begin
     simp only [mem_one],
     exact ⟨(1:α), (mem_one s).1 hs, φ.map_one⟩
   end)

/-- If `φ : α →* β` then `map_monoid_hom φ` is the monoid homomorphism
`filter α →* filter β` induced by `map φ`. -/
@[to_additive "If `φ : α →+ β` then `map_add_monoid_hom φ` is the monoid homomorphism
`filter α →+ filter β` induced by `map φ`."]
def map_monoid_hom : filter α →* filter β :=
{ to_fun := map φ,
  map_one' := filter.map_one φ,
  map_mul' := λ _ _, filter.map_mul φ.to_mul_hom }

-- The other direction does not hold in general.
@[to_additive]
lemma comap_mul_comap_le {f₁ f₂ : filter β} :
  comap m f₁ * comap m f₂ ≤ comap m (f₁ * f₂) :=
begin
  rintros s ⟨t, ⟨t₁, t₂, ht₁, ht₂, t₁t₂⟩, mt⟩,
  refine ⟨m ⁻¹' t₁, m ⁻¹' t₂, ⟨t₁, ht₁, subset.refl _⟩, ⟨t₂, ht₂, subset.refl _⟩, _⟩,
  have := subset.trans (preimage_mono t₁t₂) mt,
  exact subset.trans (preimage_mul_preimage_subset _) this
end

@[to_additive]
lemma tendsto.mul_mul {f₁ g₁ : filter α} {f₂ g₂ : filter β} :
  tendsto m f₁ f₂ → tendsto m g₁ g₂ → tendsto m (f₁ * g₁) (f₂ * g₂) :=
assume hf hg, by { rw [tendsto, filter.map_mul m], exact filter.mul_le_mul hf hg }

end map

end filter


/-
Copyright (c) 2017 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro
-/
import data.fintype.basic
import algebra.big_operators.ring
import algebra.big_operators.option

/-!
Results about "big operations" over a `fintype`, and consequent
results about cardinalities of certain types.

## Implementation note
This content had previously been in `data.fintype.basic`, but was moved here to avoid
requiring `algebra.big_operators` (and hence many other imports) as a
dependency of `fintype`.

However many of the results here really belong in `algebra.big_operators.basic`
and should be moved at some point.
-/

universes u v

variables {α : Type*} {β : Type*} {γ : Type*}

open_locale big_operators

namespace fintype

@[to_additive]
lemma prod_bool [comm_monoid α] (f : bool → α) : ∏ b, f b = f tt * f ff := by simp

lemma card_eq_sum_ones {α} [fintype α] : fintype.card α = ∑ a : α, 1 :=
finset.card_eq_sum_ones _

section
open finset

variables {ι : Type*} [decidable_eq ι] [fintype ι]

@[to_additive]
lemma prod_extend_by_one [comm_monoid α] (s : finset ι) (f : ι → α) :
  ∏ i, (if i ∈ s then f i else 1) = ∏ i in s, f i :=
by rw [← prod_filter, filter_mem_eq_inter, univ_inter]

end

section
variables {M : Type*} [fintype α] [comm_monoid M]

@[to_additive]
lemma prod_eq_one (f : α → M) (h : ∀ a, f a = 1) :
  (∏ a, f a) = 1 :=
finset.prod_eq_one $ λ a ha, h a

@[to_additive]
lemma prod_congr (f g : α → M) (h : ∀ a, f a = g a) :
  (∏ a, f a) = ∏ a, g a :=
finset.prod_congr rfl $ λ a ha, h a

@[to_additive]
lemma prod_eq_single {f : α → M} (a : α) (h : ∀ x ≠ a, f x = 1) :
  (∏ x, f x) = f a :=
finset.prod_eq_single a (λ x _ hx, h x hx) $ λ ha, (ha (finset.mem_univ a)).elim

@[to_additive]
lemma prod_eq_mul {f : α → M} (a b : α) (h₁ : a ≠ b) (h₂ : ∀ x, x ≠ a ∧ x ≠ b → f x = 1) :
  (∏ x, f x) = (f a) * (f b) :=
begin
  apply finset.prod_eq_mul a b h₁ (λ x _ hx, h₂ x hx);
  exact λ hc, (hc (finset.mem_univ _)).elim
end

/-- If a product of a `finset` of a subsingleton type has a given
value, so do the terms in that product. -/
@[to_additive "If a sum of a `finset` of a subsingleton type has a given
value, so do the terms in that sum."]
lemma eq_of_subsingleton_of_prod_eq {ι : Type*} [subsingleton ι] {s : finset ι}
    {f : ι → M} {b : M} (h : ∏ i in s, f i = b) : ∀ i ∈ s, f i = b :=
finset.eq_of_card_le_one_of_prod_eq (finset.card_le_one_of_subsingleton s) h

end

end fintype

open finset

section

variables {M : Type*} [fintype α] [comm_monoid M]

@[simp, to_additive]
lemma fintype.prod_option (f : option α → M) : ∏ i, f i = f none * ∏ i, f (some i) :=
finset.prod_insert_none f univ

end

@[to_additive]
theorem fin.prod_univ_def [comm_monoid β] {n : ℕ} (f : fin n → β) :
  ∏ i, f i = ((list.fin_range n).map f).prod :=
by simp [fin.univ_def, finset.fin_range]

@[to_additive]
theorem finset.prod_range [comm_monoid β] {n : ℕ} (f : ℕ → β) :
  ∏ i in finset.range n, f i = ∏ i : fin n, f i :=
begin
  fapply @finset.prod_bij' _ _ _ _ _ _,
  exact λ k w, ⟨k, (by simpa using w)⟩,
  swap 3,
  exact λ a m, a,
  swap 3,
  exact λ a m, by simpa using a.2,
  all_goals { tidy, },
end

@[to_additive]
theorem fin.prod_of_fn [comm_monoid β] {n : ℕ} (f : fin n → β) :
  (list.of_fn f).prod = ∏ i, f i :=
by rw [list.of_fn_eq_map, fin.prod_univ_def]

/-- A product of a function `f : fin 0 → β` is `1` because `fin 0` is empty -/
@[to_additive "A sum of a function `f : fin 0 → β` is `0` because `fin 0` is empty"]
theorem fin.prod_univ_zero [comm_monoid β] (f : fin 0 → β) : ∏ i, f i = 1 := rfl

/-- A product of a function `f : fin (n + 1) → β` over all `fin (n + 1)`
is the product of `f x`, for some `x : fin (n + 1)` times the remaining product -/
@[to_additive
/- A sum of a function `f : fin (n + 1) → β` over all `fin (n + 1)`
is the sum of `f x`, for some `x : fin (n + 1)` plus the remaining product -/]
theorem fin.prod_univ_succ_above [comm_monoid β] {n : ℕ} (f : fin (n + 1) → β)
  (x : fin (n + 1)) :
  ∏ i, f i = f x * ∏ i : fin n, f (x.succ_above i) :=
begin
  rw [fintype.prod_eq_mul_prod_compl x, ← fin.image_succ_above_univ, prod_image],
  exact λ _ _ _ _ h, x.succ_above.injective h
end

/-- A product of a function `f : fin (n + 1) → β` over all `fin (n + 1)`
is the product of `f 0` plus the remaining product -/
@[to_additive
/- A sum of a function `f : fin (n + 1) → β` over all `fin (n + 1)`
is the sum of `f 0` plus the remaining product -/]
theorem fin.prod_univ_succ [comm_monoid β] {n : ℕ} (f : fin (n + 1) → β) :
  ∏ i, f i = f 0 * ∏ i : fin n, f i.succ :=
fin.prod_univ_succ_above f 0

/-- A product of a function `f : fin (n + 1) → β` over all `fin (n + 1)`
is the product of `f (fin.last n)` plus the remaining product -/
@[to_additive
/- A sum of a function `f : fin (n + 1) → β` over all `fin (n + 1)`
is the sum of `f (fin.last n)` plus the remaining sum -/]
theorem fin.prod_univ_cast_succ [comm_monoid β] {n : ℕ} (f : fin (n + 1) → β) :
  ∏ i, f i = (∏ i : fin n, f i.cast_succ) * f (fin.last n) :=
by simpa [mul_comm] using fin.prod_univ_succ_above f (fin.last n)

@[to_additive sum_univ_one] theorem fin.prod_univ_one [comm_monoid β] (f : fin 1 → β) :
  ∏ i, f i = f 0 :=
by simp

@[to_additive] theorem fin.prod_univ_two [comm_monoid β] (f : fin 2 → β) :
  ∏ i, f i = f 0 * f 1 :=
by simp [fin.prod_univ_succ]

open finset

@[simp] theorem fintype.card_sigma {α : Type*} (β : α → Type*)
  [fintype α] [∀ a, fintype (β a)] :
  fintype.card (sigma β) = ∑ a, fintype.card (β a) :=
card_sigma _ _

@[simp] lemma finset.card_pi [decidable_eq α] {δ : α → Type*}
  (s : finset α) (t : Π a, finset (δ a)) :
  (s.pi t).card = ∏ a in s, card (t a) :=
multiset.card_pi _ _

@[simp] lemma fintype.card_pi_finset [decidable_eq α] [fintype α]
  {δ : α → Type*} (t : Π a, finset (δ a)) :
  (fintype.pi_finset t).card = ∏ a, card (t a) :=
by simp [fintype.pi_finset, card_map]

@[simp] lemma fintype.card_pi {β : α → Type*} [decidable_eq α] [fintype α]
  [f : Π a, fintype (β a)] : fintype.card (Π a, β a) = ∏ a, fintype.card (β a) :=
fintype.card_pi_finset _

-- FIXME ouch, this should be in the main file.
@[simp] lemma fintype.card_fun [decidable_eq α] [fintype α] [fintype β] :
  fintype.card (α → β) = fintype.card β ^ fintype.card α :=
by rw [fintype.card_pi, finset.prod_const]; refl

@[simp] lemma card_vector [fintype α] (n : ℕ) :
  fintype.card (vector α n) = fintype.card α ^ n :=
by rw fintype.of_equiv_card; simp

@[simp, to_additive]
lemma finset.prod_attach_univ [fintype α] [comm_monoid β] (f : {a : α // a ∈ @univ α _} → β) :
  ∏ x in univ.attach, f x = ∏ x, f ⟨x, (mem_univ _)⟩ :=
fintype.prod_equiv (equiv.subtype_univ_equiv (λ x, mem_univ _)) _ _ (λ x, by simp)

/-- Taking a product over `univ.pi t` is the same as taking the product over `fintype.pi_finset t`.
  `univ.pi t` and `fintype.pi_finset t` are essentially the same `finset`, but differ
  in the type of their element, `univ.pi t` is a `finset (Π a ∈ univ, t a)` and
  `fintype.pi_finset t` is a `finset (Π a, t a)`. -/
@[to_additive "Taking a sum over `univ.pi t` is the same as taking the sum over
  `fintype.pi_finset t`. `univ.pi t` and `fintype.pi_finset t` are essentially the same `finset`,
  but differ in the type of their element, `univ.pi t` is a `finset (Π a ∈ univ, t a)` and
  `fintype.pi_finset t` is a `finset (Π a, t a)`."]
lemma finset.prod_univ_pi [decidable_eq α] [fintype α] [comm_monoid β]
  {δ : α → Type*} {t : Π (a : α), finset (δ a)}
  (f : (Π (a : α), a ∈ (univ : finset α) → δ a) → β) :
  ∏ x in univ.pi t, f x = ∏ x in fintype.pi_finset t, f (λ a _, x a) :=
prod_bij (λ x _ a, x a (mem_univ _))
  (by simp)
  (by simp)
  (by simp [function.funext_iff] {contextual := tt})
  (λ x hx, ⟨λ a _, x a, by simp * at *⟩)

/-- The product over `univ` of a sum can be written as a sum over the product of sets,
  `fintype.pi_finset`. `finset.prod_sum` is an alternative statement when the product is not
  over `univ` -/
lemma finset.prod_univ_sum [decidable_eq α] [fintype α] [comm_semiring β] {δ : α → Type u_1}
  [Π (a : α), decidable_eq (δ a)] {t : Π (a : α), finset (δ a)}
  {f : Π (a : α), δ a → β} :
  ∏ a, ∑ b in t a, f a b = ∑ p in fintype.pi_finset t, ∏ x, f x (p x) :=
by simp only [finset.prod_attach_univ, prod_sum, finset.sum_univ_pi]

/-- Summing `a^s.card * b^(n-s.card)` over all finite subsets `s` of a fintype of cardinality `n`
gives `(a + b)^n`. The "good" proof involves expanding along all coordinates using the fact that
`x^n` is multilinear, but multilinear maps are only available now over rings, so we give instead
a proof reducing to the usual binomial theorem to have a result over semirings. -/
lemma fintype.sum_pow_mul_eq_add_pow
  (α : Type*) [fintype α] {R : Type*} [comm_semiring R] (a b : R) :
  ∑ s : finset α, a ^ s.card * b ^ (fintype.card α - s.card) =
  (a + b) ^ (fintype.card α) :=
finset.sum_pow_mul_eq_add_pow _ _ _

lemma fin.sum_pow_mul_eq_add_pow {n : ℕ} {R : Type*} [comm_semiring R] (a b : R) :
  ∑ s : finset (fin n), a ^ s.card * b ^ (n - s.card) = (a + b) ^ n :=
by simpa using fintype.sum_pow_mul_eq_add_pow (fin n) a b

lemma fin.prod_const [comm_monoid α] (n : ℕ) (x : α) : ∏ i : fin n, x = x ^ n := by simp

lemma fin.sum_const [add_comm_monoid α] (n : ℕ) (x : α) : ∑ i : fin n, x = n • x := by simp

@[to_additive]
lemma function.bijective.prod_comp [fintype α] [fintype β] [comm_monoid γ] {f : α → β}
  (hf : function.bijective f) (g : β → γ) :
  ∏ i, g (f i) = ∏ i, g i :=
fintype.prod_bijective f hf _ _ (λ x, rfl)

@[to_additive]
lemma equiv.prod_comp [fintype α] [fintype β] [comm_monoid γ] (e : α ≃ β) (f : β → γ) :
  ∏ i, f (e i) = ∏ i, f i :=
e.bijective.prod_comp f

/-- It is equivalent to sum a function over `fin n` or `finset.range n`. -/
@[to_additive]
lemma fin.prod_univ_eq_prod_range [comm_monoid α] (f : ℕ → α) (n : ℕ) :
  ∏ i : fin n, f i = ∏ i in range n, f i :=
calc (∏ i : fin n, f i) = ∏ i : {x // x ∈ range n}, f i :
  ((equiv.fin_equiv_subtype n).trans
    (equiv.subtype_equiv_right (λ _, mem_range.symm))).prod_comp (f ∘ coe)
... = ∏ i in range n, f i : by rw [← attach_eq_univ, prod_attach]

@[to_additive]
lemma finset.prod_fin_eq_prod_range [comm_monoid β] {n : ℕ} (c : fin n → β) :
  ∏ i, c i = ∏ i in finset.range n, if h : i < n then c ⟨i, h⟩ else 1 :=
begin
  rw [← fin.prod_univ_eq_prod_range, finset.prod_congr rfl],
  rintros ⟨i, hi⟩ _,
  simp only [fin.coe_eq_val, hi, dif_pos]
end

@[to_additive]
lemma finset.prod_to_finset_eq_subtype {M : Type*} [comm_monoid M] [fintype α]
  (p : α → Prop) [decidable_pred p] (f : α → M) :
    ∏ a in {x | p x}.to_finset, f a = ∏ a : subtype p, f a :=
by { rw ← finset.prod_subtype, simp }

@[to_additive] lemma finset.prod_fiberwise [decidable_eq β] [fintype β] [comm_monoid γ]
  (s : finset α) (f : α → β) (g : α → γ) :
  ∏ b : β, ∏ a in s.filter (λ a, f a = b), g a = ∏ a in s, g a :=
finset.prod_fiberwise_of_maps_to (λ x _, mem_univ _) _

@[to_additive]
lemma fintype.prod_fiberwise [fintype α] [decidable_eq β] [fintype β] [comm_monoid γ]
  (f : α → β) (g : α → γ) :
  (∏ b : β, ∏ a : {a // f a = b}, g (a : α)) = ∏ a, g a :=
begin
  rw [← (equiv.sigma_preimage_equiv f).prod_comp, ← univ_sigma_univ, prod_sigma],
  refl
end

lemma fintype.prod_dite [fintype α] {p : α → Prop} [decidable_pred p]
  [comm_monoid β] (f : Π (a : α) (ha : p a), β) (g : Π (a : α) (ha : ¬p a), β) :
  (∏ a, dite (p a) (f a) (g a)) = (∏ a : {a // p a}, f a a.2) * (∏ a : {a // ¬p a}, g a a.2) :=
begin
  simp only [prod_dite, attach_eq_univ],
  congr' 1,
  { convert (equiv.subtype_equiv_right _).prod_comp (λ x : {x // p x}, f x x.2),
    simp },
  { convert (equiv.subtype_equiv_right _).prod_comp (λ x : {x // ¬p x}, g x x.2),
    simp }
end

section
open finset

variables {α₁ : Type*} {α₂ : Type*} {M : Type*} [fintype α₁] [fintype α₂] [comm_monoid M]

@[to_additive]
lemma fintype.prod_sum_elim (f : α₁ → M) (g : α₂ → M) :
  (∏ x, sum.elim f g x) = (∏ a₁, f a₁) * (∏ a₂, g a₂) :=
by { classical, rw [univ_sum_type, prod_sum_elim] }

@[to_additive]
lemma fintype.prod_sum_type (f : α₁ ⊕ α₂ → M) :
  (∏ x, f x) = (∏ a₁, f (sum.inl a₁)) * (∏ a₂, f (sum.inr a₂)) :=
by simp only [← fintype.prod_sum_elim, sum.elim_comp_inl_inr]

end

namespace list

@[to_additive]
lemma prod_take_of_fn [comm_monoid α] {n : ℕ} (f : fin n → α) (i : ℕ) :
  ((of_fn f).take i).prod = ∏ j in finset.univ.filter (λ (j : fin n), j.val < i), f j :=
begin
  have A : ∀ (j : fin n), ¬ ((j : ℕ) < 0) := λ j, not_lt_bot,
  induction i with i IH, { simp [A] },
  by_cases h : i < n,
  { have : i < length (of_fn f), by rwa [length_of_fn f],
    rw prod_take_succ _ _ this,
    have A : ((finset.univ : finset (fin n)).filter (λ j, j.val < i + 1))
      = ((finset.univ : finset (fin n)).filter (λ j, j.val < i)) ∪ {(⟨i, h⟩ : fin n)},
        by { ext j, simp [nat.lt_succ_iff_lt_or_eq, fin.ext_iff, - add_comm] },
    have B : _root_.disjoint (finset.filter (λ (j : fin n), j.val < i) finset.univ)
      (singleton (⟨i, h⟩ : fin n)), by simp,
    rw [A, finset.prod_union B, IH],
    simp },
  { have A : (of_fn f).take i = (of_fn f).take i.succ,
    { rw ← length_of_fn f at h,
      have : length (of_fn f) ≤ i := not_lt.mp h,
      rw [take_all_of_le this, take_all_of_le (le_trans this (nat.le_succ _))] },
    have B : ∀ (j : fin n), ((j : ℕ) < i.succ) = ((j : ℕ) < i),
    { assume j,
      have : (j : ℕ) < i := lt_of_lt_of_le j.2 (not_lt.mp h),
      simp [this, lt_trans this (nat.lt_succ_self _)] },
    simp [← A, B, IH] }
end

@[to_additive]
lemma prod_of_fn [comm_monoid α] {n : ℕ} {f : fin n → α} :
  (of_fn f).prod = ∏ i, f i :=
begin
  convert prod_take_of_fn f n,
  { rw [take_all_of_le (le_of_eq (length_of_fn f))] },
  { have : ∀ (j : fin n), (j : ℕ) < n := λ j, j.is_lt,
    simp [this] }
end

lemma alternating_sum_eq_finset_sum {G : Type*} [add_comm_group G] :
  ∀ (L : list G), alternating_sum L = ∑ i : fin L.length, (-1 : ℤ) ^ (i : ℕ) • L.nth_le i i.is_lt
| [] := by { rw [alternating_sum, finset.sum_eq_zero], rintro ⟨i, ⟨⟩⟩ }
| (g :: []) :=
begin
  show g = ∑ i : fin 1, (-1 : ℤ) ^ (i : ℕ) • [g].nth_le i i.2,
  rw [fin.sum_univ_succ], simp,
end
| (g :: h :: L) :=
calc g + -h + L.alternating_sum
    = g + -h + ∑ i : fin L.length, (-1 : ℤ) ^ (i : ℕ) • L.nth_le i i.2 :
      congr_arg _ (alternating_sum_eq_finset_sum _)
... = ∑ i : fin (L.length + 2), (-1 : ℤ) ^ (i : ℕ) • list.nth_le (g :: h :: L) i _ :
begin
  rw [fin.sum_univ_succ, fin.sum_univ_succ, add_assoc],
  unfold_coes,
  simp [nat.succ_eq_add_one, pow_add],
  refl,
end

@[to_additive]
lemma alternating_prod_eq_finset_prod {G : Type*} [comm_group G] :
  ∀ (L : list G), alternating_prod L = ∏ i : fin L.length, (L.nth_le i i.2) ^ ((-1 : ℤ) ^ (i : ℕ))
| [] := by { rw [alternating_prod, finset.prod_eq_one], rintro ⟨i, ⟨⟩⟩ }
| (g :: []) :=
begin
  show g = ∏ i : fin 1, [g].nth_le i i.2 ^ (-1 : ℤ) ^ (i : ℕ),
  rw [fin.prod_univ_succ], simp,
end
| (g :: h :: L) :=
calc g * h⁻¹ * L.alternating_prod
    = g * h⁻¹ * ∏ i : fin L.length, L.nth_le i i.2 ^ (-1 : ℤ) ^ (i : ℕ) :
      congr_arg _ (alternating_prod_eq_finset_prod _)
... = ∏ i : fin (L.length + 2), list.nth_le (g :: h :: L) i _ ^ (-1 : ℤ) ^ (i : ℕ) :
begin
  rw [fin.prod_univ_succ, fin.prod_univ_succ, mul_assoc],
  unfold_coes,
  simp [nat.succ_eq_add_one, pow_add],
  refl,
end

end list