/-
Copyright (c) 2018 Jeremy Avigad. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Jeremy Avigad, Simon Hudon

! This file was ported from Lean 3 source module data.qpf.multivariate.basic
! leanprover-community/mathlib commit 23aa88e32dcc9d2a24cca7bc23268567ed4cd7d6
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Data.Pfunctor.Multivariate.Basic

/-!
# Multivariate quotients of polynomial functors.

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

Basic definition of multivariate QPF. QPFs form a compositional framework
for defining inductive and coinductive types, their quotients and nesting.

The idea is based on building ever larger functors. For instance, we can define
a list using a shape functor:

```lean
inductive list_shape (a b : Type)
| nil : list_shape
| cons : a -> b -> list_shape
```

This shape can itself be decomposed as a sum of product which are themselves
QPFs. It follows that the shape is a QPF and we can take its fixed point
and create the list itself:

```lean
def list (a : Type) := fix list_shape a -- not the actual notation
```

We can continue and define the quotient on permutation of lists and create
the multiset type:

```lean
def multiset (a : Type) := qpf.quot list.perm list a -- not the actual notion
```

And `multiset` is also a QPF. We can then create a novel data type (for Lean):

```lean
inductive tree (a : Type)
| node : a -> multiset tree -> tree
```

An unordered tree. This is currently not supported by Lean because it nests
an inductive type inside of a quotient. We can go further and define
unordered, possibly infinite trees:

```lean
coinductive tree' (a : Type)
| node : a -> multiset tree' -> tree'
```

by using the `cofix` construct. Those options can all be mixed and
matched because they preserve the properties of QPF. The latter example,
`tree'`, combines fixed point, co-fixed point and quotients.

## Related modules

 * constructions
   * fix
   * cofix
   * quot
   * comp
   * sigma / pi
   * prj
   * const

each proves that some operations on functors preserves the QPF structure

## Reference

 * [Jeremy Avigad, Mario M. Carneiro and Simon Hudon, *Data Types as Quotients of Polynomial Functors*][avigad-carneiro-hudon2019]
-/

universe u

open MvFunctor

#print MvQPF /-
/-- Multivariate quotients of polynomial functors.
-/
class MvQPF {n : ℕ} (F : TypeVec.{u} n → Type _) [MvFunctor F] where
  p : MvPFunctor.{u} n
  abs : ∀ {α}, P.Obj α → F α
  repr : ∀ {α}, F α → P.Obj α
  abs_repr : ∀ {α} (x : F α), abs (repr x) = x
  abs_map : ∀ {α β} (f : α ⟹ β) (p : P.Obj α), abs (f <$$> p) = f <$$> abs p
#align mvqpf MvQPF
-/

namespace MvQPF

variable {n : ℕ} {F : TypeVec.{u} n → Type _} [MvFunctor F] [q : MvQPF F]

include q

open MvFunctor (Liftp Liftr)

/-!
### Show that every mvqpf is a lawful mvfunctor.
-/

/- warning: mvqpf.id_map -> MvQPF.id_map is a dubious translation:
lean 3 declaration is
  forall {n : Nat} {F : (TypeVec.{u1} n) -> Type.{u2}} [_inst_1 : MvFunctor.{u1, u2} n F] [q : MvQPF.{u1, u2} n F _inst_1] {α : TypeVec.{u1} n} (x : F α), Eq.{succ u2} (F α) (MvFunctor.map.{u1, u2} n F _inst_1 α α (TypeVec.id.{u1} n α) x) x
but is expected to have type
  forall {n : Nat} {F : (TypeVec.{u2} n) -> Type.{u1}} [_inst_1 : MvFunctor.{u2, u1} n F] [q : MvQPF.{u2, u1} n F _inst_1] {α : TypeVec.{u2} n} (x : F α), Eq.{succ u1} (F α) (MvFunctor.map.{u2, u1} n F _inst_1 α α (TypeVec.id.{u2} n α) x) x
Case conversion may be inaccurate. Consider using '#align mvqpf.id_map MvQPF.id_mapₓ'. -/
protected theorem id_map {α : TypeVec n} (x : F α) : TypeVec.id <$$> x = x :=
  by
  rw [← abs_repr x]
  cases' repr x with a f
  rw [← abs_map]
  rfl
#align mvqpf.id_map MvQPF.id_map

/- warning: mvqpf.comp_map -> MvQPF.comp_map is a dubious translation:
lean 3 declaration is
  forall {n : Nat} {F : (TypeVec.{u1} n) -> Type.{u2}} [_inst_1 : MvFunctor.{u1, u2} n F] [q : MvQPF.{u1, u2} n F _inst_1] {α : TypeVec.{u1} n} {β : TypeVec.{u1} n} {γ : TypeVec.{u1} n} (f : TypeVec.Arrow.{u1, u1} n α β) (g : TypeVec.Arrow.{u1, u1} n β γ) (x : F α), Eq.{succ u2} (F γ) (MvFunctor.map.{u1, u2} n (fun {α : TypeVec.{u1} n} => F α) _inst_1 α γ (TypeVec.comp.{u1, u1, u1} n α β γ g f) x) (MvFunctor.map.{u1, u2} n F _inst_1 β γ g (MvFunctor.map.{u1, u2} n F _inst_1 α β f x))
but is expected to have type
  forall {n : Nat} {F : (TypeVec.{u2} n) -> Type.{u1}} [_inst_1 : MvFunctor.{u2, u1} n F] [q : MvQPF.{u2, u1} n F _inst_1] {α : TypeVec.{u2} n} {β : TypeVec.{u2} n} {γ : TypeVec.{u2} n} (f : TypeVec.Arrow.{u2, u2} n α β) (g : TypeVec.Arrow.{u2, u2} n β γ) (x : F α), Eq.{succ u1} (F γ) (MvFunctor.map.{u2, u1} n F _inst_1 α γ (TypeVec.comp.{u2, u2, u2} n α β γ g f) x) (MvFunctor.map.{u2, u1} n F _inst_1 β γ g (MvFunctor.map.{u2, u1} n F _inst_1 α β f x))
Case conversion may be inaccurate. Consider using '#align mvqpf.comp_map MvQPF.comp_mapₓ'. -/
@[simp]
theorem comp_map {α β γ : TypeVec n} (f : α ⟹ β) (g : β ⟹ γ) (x : F α) :
    (g ⊚ f) <$$> x = g <$$> f <$$> x := by
  rw [← abs_repr x]
  cases' repr x with a f
  rw [← abs_map, ← abs_map, ← abs_map]
  rfl
#align mvqpf.comp_map MvQPF.comp_map

#print MvQPF.lawfulMvFunctor /-
instance (priority := 100) lawfulMvFunctor : LawfulMvFunctor F
    where
  id_map := @MvQPF.id_map n F _ _
  comp_map := @comp_map n F _ _
#align mvqpf.is_lawful_mvfunctor MvQPF.lawfulMvFunctor
-/

/- warning: mvqpf.liftp_iff -> MvQPF.liftP_iff is a dubious translation:
lean 3 declaration is
  forall {n : Nat} {F : (TypeVec.{u1} n) -> Type.{u2}} [_inst_1 : MvFunctor.{u1, u2} n F] [q : MvQPF.{u1, u2} n F _inst_1] {α : TypeVec.{u1} n} (p : forall {{i : Fin2 n}}, (α i) -> Prop) (x : F α), Iff (MvFunctor.LiftP.{u1, u2} n F _inst_1 (fun (i : Fin2 n) => α i) p x) (Exists.{succ u1} (MvPFunctor.A.{u1} n (MvQPF.p.{u1, u2} n F _inst_1 q)) (fun (a : MvPFunctor.A.{u1} n (MvQPF.p.{u1, u2} n F _inst_1 q)) => Exists.{succ u1} (TypeVec.Arrow.{u1, u1} n (MvPFunctor.b.{u1} n (MvQPF.p.{u1, u2} n F _inst_1 q) a) α) (fun (f : TypeVec.Arrow.{u1, u1} n (MvPFunctor.b.{u1} n (MvQPF.p.{u1, u2} n F _inst_1 q) a) α) => And (Eq.{succ u2} (F α) x (MvQPF.abs.{u1, u2} n F _inst_1 q α (Sigma.mk.{u1, u1} (MvPFunctor.A.{u1} n (MvQPF.p.{u1, u2} n F _inst_1 q)) (fun (a : MvPFunctor.A.{u1} n (MvQPF.p.{u1, u2} n F _inst_1 q)) => TypeVec.Arrow.{u1, u1} n (MvPFunctor.b.{u1} n (MvQPF.p.{u1, u2} n F _inst_1 q) a) α) a f))) (forall (i : Fin2 n) (j : MvPFunctor.b.{u1} n (MvQPF.p.{u1, u2} n F _inst_1 q) a i), p i (f i j)))))
but is expected to have type
  forall {n : Nat} {F : (TypeVec.{u2} n) -> Type.{u1}} [_inst_1 : MvFunctor.{u2, u1} n F] [q : MvQPF.{u2, u1} n F _inst_1] {α : TypeVec.{u2} n} (p : forall {{i : Fin2 n}}, (α i) -> Prop) (x : F α), Iff (MvFunctor.LiftP.{u2, u1} n F _inst_1 (fun (i : Fin2 n) => α i) p x) (Exists.{succ u2} (MvPFunctor.A.{u2} n (MvQPF.P.{u2, u1} n F _inst_1 q)) (fun (a : MvPFunctor.A.{u2} n (MvQPF.P.{u2, u1} n F _inst_1 q)) => Exists.{succ u2} (TypeVec.Arrow.{u2, u2} n (MvPFunctor.B.{u2} n (MvQPF.P.{u2, u1} n F _inst_1 q) a) α) (fun (f : TypeVec.Arrow.{u2, u2} n (MvPFunctor.B.{u2} n (MvQPF.P.{u2, u1} n F _inst_1 q) a) α) => And (Eq.{succ u1} (F α) x (MvQPF.abs.{u2, u1} n F _inst_1 q α (Sigma.mk.{u2, u2} (MvPFunctor.A.{u2} n (MvQPF.P.{u2, u1} n F _inst_1 q)) (fun (a : MvPFunctor.A.{u2} n (MvQPF.P.{u2, u1} n F _inst_1 q)) => TypeVec.Arrow.{u2, u2} n (MvPFunctor.B.{u2} n (MvQPF.P.{u2, u1} n F _inst_1 q) a) α) a f))) (forall (i : Fin2 n) (j : MvPFunctor.B.{u2} n (MvQPF.P.{u2, u1} n F _inst_1 q) a i), p i (f i j)))))
Case conversion may be inaccurate. Consider using '#align mvqpf.liftp_iff MvQPF.liftP_iffₓ'. -/
-- Lifting predicates and relations
theorem liftP_iff {α : TypeVec n} (p : ∀ ⦃i⦄, α i → Prop) (x : F α) :
    LiftP p x ↔ ∃ a f, x = abs ⟨a, f⟩ ∧ ∀ i j, p (f i j) :=
  by
  constructor
  · rintro ⟨y, hy⟩
    cases' h : repr y with a f
    use a, fun i j => (f i j).val
    constructor
    · rw [← hy, ← abs_repr y, h, ← abs_map]
      rfl
    intro i j
    apply (f i j).property
  rintro ⟨a, f, h₀, h₁⟩; dsimp at *
  use abs ⟨a, fun i j => ⟨f i j, h₁ i j⟩⟩
  rw [← abs_map, h₀]; rfl
#align mvqpf.liftp_iff MvQPF.liftP_iff

/- warning: mvqpf.liftr_iff -> MvQPF.liftR_iff is a dubious translation:
lean 3 declaration is
  forall {n : Nat} {F : (TypeVec.{u1} n) -> Type.{u2}} [_inst_1 : MvFunctor.{u1, u2} n F] [q : MvQPF.{u1, u2} n F _inst_1] {α : TypeVec.{u1} n} (r : forall {{i : Fin2 n}}, (α i) -> (α i) -> Prop) (x : F α) (y : F α), Iff (MvFunctor.LiftR.{u1, u2} n F _inst_1 (fun (i : Fin2 n) => α i) r x y) (Exists.{succ u1} (MvPFunctor.A.{u1} n (MvQPF.p.{u1, u2} n F _inst_1 q)) (fun (a : MvPFunctor.A.{u1} n (MvQPF.p.{u1, u2} n F _inst_1 q)) => Exists.{succ u1} (TypeVec.Arrow.{u1, u1} n (MvPFunctor.b.{u1} n (MvQPF.p.{u1, u2} n F _inst_1 q) a) α) (fun (f₀ : TypeVec.Arrow.{u1, u1} n (MvPFunctor.b.{u1} n (MvQPF.p.{u1, u2} n F _inst_1 q) a) α) => Exists.{succ u1} (TypeVec.Arrow.{u1, u1} n (MvPFunctor.b.{u1} n (MvQPF.p.{u1, u2} n F _inst_1 q) a) α) (fun (f₁ : TypeVec.Arrow.{u1, u1} n (MvPFunctor.b.{u1} n (MvQPF.p.{u1, u2} n F _inst_1 q) a) α) => And (Eq.{succ u2} (F α) x (MvQPF.abs.{u1, u2} n F _inst_1 q α (Sigma.mk.{u1, u1} (MvPFunctor.A.{u1} n (MvQPF.p.{u1, u2} n F _inst_1 q)) (fun (a : MvPFunctor.A.{u1} n (MvQPF.p.{u1, u2} n F _inst_1 q)) => TypeVec.Arrow.{u1, u1} n (MvPFunctor.b.{u1} n (MvQPF.p.{u1, u2} n F _inst_1 q) a) α) a f₀))) (And (Eq.{succ u2} (F α) y (MvQPF.abs.{u1, u2} n F _inst_1 q α (Sigma.mk.{u1, u1} (MvPFunctor.A.{u1} n (MvQPF.p.{u1, u2} n F _inst_1 q)) (fun (a : MvPFunctor.A.{u1} n (MvQPF.p.{u1, u2} n F _inst_1 q)) => TypeVec.Arrow.{u1, u1} n (MvPFunctor.b.{u1} n (MvQPF.p.{u1, u2} n F _inst_1 q) a) α) a f₁))) (forall (i : Fin2 n) (j : MvPFunctor.b.{u1} n (MvQPF.p.{u1, u2} n F _inst_1 q) a i), r i (f₀ i j) (f₁ i j)))))))
but is expected to have type
  forall {n : Nat} {F : (TypeVec.{u2} n) -> Type.{u1}} [_inst_1 : MvFunctor.{u2, u1} n F] [q : MvQPF.{u2, u1} n F _inst_1] {α : TypeVec.{u2} n} (r : forall {i : Fin2 n}, (α i) -> (α i) -> Prop) (x : F α) (y : F α), Iff (MvFunctor.LiftR.{u2, u1} n F _inst_1 (fun {i : Fin2 n} => α i) (fun {i._@.Mathlib.Data.QPF.Multivariate.Basic._hyg.634 : Fin2 n} => r i._@.Mathlib.Data.QPF.Multivariate.Basic._hyg.634) x y) (Exists.{succ u2} (MvPFunctor.A.{u2} n (MvQPF.P.{u2, u1} n F _inst_1 q)) (fun (a : MvPFunctor.A.{u2} n (MvQPF.P.{u2, u1} n F _inst_1 q)) => Exists.{succ u2} (TypeVec.Arrow.{u2, u2} n (MvPFunctor.B.{u2} n (MvQPF.P.{u2, u1} n F _inst_1 q) a) α) (fun (f₀ : TypeVec.Arrow.{u2, u2} n (MvPFunctor.B.{u2} n (MvQPF.P.{u2, u1} n F _inst_1 q) a) α) => Exists.{succ u2} (TypeVec.Arrow.{u2, u2} n (MvPFunctor.B.{u2} n (MvQPF.P.{u2, u1} n F _inst_1 q) a) α) (fun (f₁ : TypeVec.Arrow.{u2, u2} n (MvPFunctor.B.{u2} n (MvQPF.P.{u2, u1} n F _inst_1 q) a) α) => And (Eq.{succ u1} (F α) x (MvQPF.abs.{u2, u1} n F _inst_1 q α (Sigma.mk.{u2, u2} (MvPFunctor.A.{u2} n (MvQPF.P.{u2, u1} n F _inst_1 q)) (fun (a : MvPFunctor.A.{u2} n (MvQPF.P.{u2, u1} n F _inst_1 q)) => TypeVec.Arrow.{u2, u2} n (MvPFunctor.B.{u2} n (MvQPF.P.{u2, u1} n F _inst_1 q) a) α) a f₀))) (And (Eq.{succ u1} (F α) y (MvQPF.abs.{u2, u1} n F _inst_1 q α (Sigma.mk.{u2, u2} (MvPFunctor.A.{u2} n (MvQPF.P.{u2, u1} n F _inst_1 q)) (fun (a : MvPFunctor.A.{u2} n (MvQPF.P.{u2, u1} n F _inst_1 q)) => TypeVec.Arrow.{u2, u2} n (MvPFunctor.B.{u2} n (MvQPF.P.{u2, u1} n F _inst_1 q) a) α) a f₁))) (forall (i : Fin2 n) (j : MvPFunctor.B.{u2} n (MvQPF.P.{u2, u1} n F _inst_1 q) a i), r i (f₀ i j) (f₁ i j)))))))
Case conversion may be inaccurate. Consider using '#align mvqpf.liftr_iff MvQPF.liftR_iffₓ'. -/
theorem liftR_iff {α : TypeVec n} (r : ∀ ⦃i⦄, α i → α i → Prop) (x y : F α) :
    LiftR r x y ↔ ∃ a f₀ f₁, x = abs ⟨a, f₀⟩ ∧ y = abs ⟨a, f₁⟩ ∧ ∀ i j, r (f₀ i j) (f₁ i j) :=
  by
  constructor
  · rintro ⟨u, xeq, yeq⟩
    cases' h : repr u with a f
    use a, fun i j => (f i j).val.fst, fun i j => (f i j).val.snd
    constructor
    · rw [← xeq, ← abs_repr u, h, ← abs_map]
      rfl
    constructor
    · rw [← yeq, ← abs_repr u, h, ← abs_map]
      rfl
    intro i j
    exact (f i j).property
  rintro ⟨a, f₀, f₁, xeq, yeq, h⟩
  use abs ⟨a, fun i j => ⟨(f₀ i j, f₁ i j), h i j⟩⟩
  dsimp; constructor
  · rw [xeq, ← abs_map]
    rfl
  rw [yeq, ← abs_map]; rfl
#align mvqpf.liftr_iff MvQPF.liftR_iff

open Set

open MvFunctor

/- warning: mvqpf.mem_supp -> MvQPF.mem_supp is a dubious translation:
lean 3 declaration is
  forall {n : Nat} {F : (TypeVec.{u1} n) -> Type.{u2}} [_inst_1 : MvFunctor.{u1, u2} n F] [q : MvQPF.{u1, u2} n F _inst_1] {α : TypeVec.{u1} n} (x : F α) (i : Fin2 n) (u : α i), Iff (Membership.Mem.{u1, u1} (α i) (Set.{u1} (α i)) (Set.hasMem.{u1} (α i)) u (MvFunctor.supp.{u1, u2} n F _inst_1 α x i)) (forall (a : MvPFunctor.A.{u1} n (MvQPF.p.{u1, u2} n F _inst_1 q)) (f : TypeVec.Arrow.{u1, u1} n (MvPFunctor.b.{u1} n (MvQPF.p.{u1, u2} n F _inst_1 q) a) α), (Eq.{succ u2} (F α) (MvQPF.abs.{u1, u2} n F _inst_1 q α (Sigma.mk.{u1, u1} (MvPFunctor.A.{u1} n (MvQPF.p.{u1, u2} n F _inst_1 q)) (fun (a : MvPFunctor.A.{u1} n (MvQPF.p.{u1, u2} n F _inst_1 q)) => TypeVec.Arrow.{u1, u1} n (MvPFunctor.b.{u1} n (MvQPF.p.{u1, u2} n F _inst_1 q) a) α) a f)) x) -> (Membership.Mem.{u1, u1} (α i) (Set.{u1} (α i)) (Set.hasMem.{u1} (α i)) u (Set.image.{u1, u1} (MvPFunctor.b.{u1} n (MvQPF.p.{u1, u2} n F _inst_1 q) a i) (α i) (f i) (Set.univ.{u1} (MvPFunctor.b.{u1} n (MvQPF.p.{u1, u2} n F _inst_1 q) a i)))))
but is expected to have type
  forall {n : Nat} {F : (TypeVec.{u2} n) -> Type.{u1}} [_inst_1 : MvFunctor.{u2, u1} n F] [q : MvQPF.{u2, u1} n F _inst_1] {α : TypeVec.{u2} n} (x : F α) (i : Fin2 n) (u : α i), Iff (Membership.mem.{u2, u2} (α i) (Set.{u2} (α i)) (Set.instMembershipSet.{u2} (α i)) u (MvFunctor.supp.{u2, u1} n F _inst_1 α x i)) (forall (a : MvPFunctor.A.{u2} n (MvQPF.P.{u2, u1} n F _inst_1 q)) (f : TypeVec.Arrow.{u2, u2} n (MvPFunctor.B.{u2} n (MvQPF.P.{u2, u1} n F _inst_1 q) a) α), (Eq.{succ u1} (F α) (MvQPF.abs.{u2, u1} n F _inst_1 q α (Sigma.mk.{u2, u2} (MvPFunctor.A.{u2} n (MvQPF.P.{u2, u1} n F _inst_1 q)) (fun (a : MvPFunctor.A.{u2} n (MvQPF.P.{u2, u1} n F _inst_1 q)) => TypeVec.Arrow.{u2, u2} n (MvPFunctor.B.{u2} n (MvQPF.P.{u2, u1} n F _inst_1 q) a) α) a f)) x) -> (Membership.mem.{u2, u2} (α i) (Set.{u2} (α i)) (Set.instMembershipSet.{u2} (α i)) u (Set.image.{u2, u2} (MvPFunctor.B.{u2} n (MvQPF.P.{u2, u1} n F _inst_1 q) a i) (α i) (f i) (Set.univ.{u2} (MvPFunctor.B.{u2} n (MvQPF.P.{u2, u1} n F _inst_1 q) a i)))))
Case conversion may be inaccurate. Consider using '#align mvqpf.mem_supp MvQPF.mem_suppₓ'. -/
theorem mem_supp {α : TypeVec n} (x : F α) (i) (u : α i) :
    u ∈ supp x i ↔ ∀ a f, abs ⟨a, f⟩ = x → u ∈ f i '' univ :=
  by
  rw [supp]; dsimp; constructor
  · intro h a f haf
    have : liftp (fun i u => u ∈ f i '' univ) x :=
      by
      rw [liftp_iff]
      refine' ⟨a, f, haf.symm, _⟩
      intro i u
      exact mem_image_of_mem _ (mem_univ _)
    exact h this
  intro h p; rw [liftp_iff]
  rintro ⟨a, f, xeq, h'⟩
  rcases h a f xeq.symm with ⟨i, _, hi⟩
  rw [← hi]; apply h'
#align mvqpf.mem_supp MvQPF.mem_supp

/- warning: mvqpf.supp_eq -> MvQPF.supp_eq is a dubious translation:
lean 3 declaration is
  forall {n : Nat} {F : (TypeVec.{u1} n) -> Type.{u2}} [_inst_1 : MvFunctor.{u1, u2} n F] [q : MvQPF.{u1, u2} n F _inst_1] {α : TypeVec.{u1} n} {i : Fin2 n} (x : F α), Eq.{succ u1} (Set.{u1} (α i)) (MvFunctor.supp.{u1, u2} n F _inst_1 α x i) (setOf.{u1} (α i) (fun (u : α i) => forall (a : MvPFunctor.A.{u1} n (MvQPF.p.{u1, u2} n F _inst_1 q)) (f : TypeVec.Arrow.{u1, u1} n (MvPFunctor.b.{u1} n (MvQPF.p.{u1, u2} n F _inst_1 q) a) α), (Eq.{succ u2} (F α) (MvQPF.abs.{u1, u2} n F _inst_1 q α (Sigma.mk.{u1, u1} (MvPFunctor.A.{u1} n (MvQPF.p.{u1, u2} n F _inst_1 q)) (fun (a : MvPFunctor.A.{u1} n (MvQPF.p.{u1, u2} n F _inst_1 q)) => TypeVec.Arrow.{u1, u1} n (MvPFunctor.b.{u1} n (MvQPF.p.{u1, u2} n F _inst_1 q) a) α) a f)) x) -> (Membership.Mem.{u1, u1} (α i) (Set.{u1} (α i)) (Set.hasMem.{u1} (α i)) u (Set.image.{u1, u1} (MvPFunctor.b.{u1} n (MvQPF.p.{u1, u2} n F _inst_1 q) a i) (α i) (f i) (Set.univ.{u1} (MvPFunctor.b.{u1} n (MvQPF.p.{u1, u2} n F _inst_1 q) a i))))))
but is expected to have type
  forall {n : Nat} {F : (TypeVec.{u2} n) -> Type.{u1}} [_inst_1 : MvFunctor.{u2, u1} n F] [q : MvQPF.{u2, u1} n F _inst_1] {α : TypeVec.{u2} n} {i : Fin2 n} (x : F α), Eq.{succ u2} (Set.{u2} (α i)) (MvFunctor.supp.{u2, u1} n F _inst_1 α x i) (setOf.{u2} (α i) (fun (u : α i) => forall (a : MvPFunctor.A.{u2} n (MvQPF.P.{u2, u1} n F _inst_1 q)) (f : TypeVec.Arrow.{u2, u2} n (MvPFunctor.B.{u2} n (MvQPF.P.{u2, u1} n F _inst_1 q) a) α), (Eq.{succ u1} (F α) (MvQPF.abs.{u2, u1} n F _inst_1 q α (Sigma.mk.{u2, u2} (MvPFunctor.A.{u2} n (MvQPF.P.{u2, u1} n F _inst_1 q)) (fun (a : MvPFunctor.A.{u2} n (MvQPF.P.{u2, u1} n F _inst_1 q)) => TypeVec.Arrow.{u2, u2} n (MvPFunctor.B.{u2} n (MvQPF.P.{u2, u1} n F _inst_1 q) a) α) a f)) x) -> (Membership.mem.{u2, u2} (α i) (Set.{u2} (α i)) (Set.instMembershipSet.{u2} (α i)) u (Set.image.{u2, u2} (MvPFunctor.B.{u2} n (MvQPF.P.{u2, u1} n F _inst_1 q) a i) (α i) (f i) (Set.univ.{u2} (MvPFunctor.B.{u2} n (MvQPF.P.{u2, u1} n F _inst_1 q) a i))))))
Case conversion may be inaccurate. Consider using '#align mvqpf.supp_eq MvQPF.supp_eqₓ'. -/
theorem supp_eq {α : TypeVec n} {i} (x : F α) :
    supp x i = { u | ∀ a f, abs ⟨a, f⟩ = x → u ∈ f i '' univ } := by ext <;> apply mem_supp
#align mvqpf.supp_eq MvQPF.supp_eq

/- warning: mvqpf.has_good_supp_iff -> MvQPF.has_good_supp_iff is a dubious translation:
lean 3 declaration is
  forall {n : Nat} {F : (TypeVec.{u1} n) -> Type.{u2}} [_inst_1 : MvFunctor.{u1, u2} n F] [q : MvQPF.{u1, u2} n F _inst_1] {α : TypeVec.{u1} n} (x : F α), Iff (forall (p : forall (i : Fin2 n), (α i) -> Prop), Iff (MvFunctor.LiftP.{u1, u2} n F _inst_1 α p x) (forall (i : Fin2 n) (u : α i), (Membership.Mem.{u1, u1} (α i) (Set.{u1} (α i)) (Set.hasMem.{u1} (α i)) u (MvFunctor.supp.{u1, u2} n F _inst_1 α x i)) -> (p i u))) (Exists.{succ u1} (MvPFunctor.A.{u1} n (MvQPF.p.{u1, u2} n F _inst_1 q)) (fun (a : MvPFunctor.A.{u1} n (MvQPF.p.{u1, u2} n F _inst_1 q)) => Exists.{succ u1} (TypeVec.Arrow.{u1, u1} n (MvPFunctor.b.{u1} n (MvQPF.p.{u1, u2} n F _inst_1 q) a) α) (fun (f : TypeVec.Arrow.{u1, u1} n (MvPFunctor.b.{u1} n (MvQPF.p.{u1, u2} n F _inst_1 q) a) α) => And (Eq.{succ u2} (F α) (MvQPF.abs.{u1, u2} n F _inst_1 q α (Sigma.mk.{u1, u1} (MvPFunctor.A.{u1} n (MvQPF.p.{u1, u2} n F _inst_1 q)) (fun (a : MvPFunctor.A.{u1} n (MvQPF.p.{u1, u2} n F _inst_1 q)) => TypeVec.Arrow.{u1, u1} n (MvPFunctor.b.{u1} n (MvQPF.p.{u1, u2} n F _inst_1 q) a) α) a f)) x) (forall (i : Fin2 n) (a' : MvPFunctor.A.{u1} n (MvQPF.p.{u1, u2} n F _inst_1 q)) (f' : TypeVec.Arrow.{u1, u1} n (MvPFunctor.b.{u1} n (MvQPF.p.{u1, u2} n F _inst_1 q) a') α), (Eq.{succ u2} (F α) (MvQPF.abs.{u1, u2} n F _inst_1 q α (Sigma.mk.{u1, u1} (MvPFunctor.A.{u1} n (MvQPF.p.{u1, u2} n F _inst_1 q)) (fun (a : MvPFunctor.A.{u1} n (MvQPF.p.{u1, u2} n F _inst_1 q)) => TypeVec.Arrow.{u1, u1} n (MvPFunctor.b.{u1} n (MvQPF.p.{u1, u2} n F _inst_1 q) a) α) a' f')) x) -> (HasSubset.Subset.{u1} (Set.{u1} (α i)) (Set.hasSubset.{u1} (α i)) (Set.image.{u1, u1} (MvPFunctor.b.{u1} n (MvQPF.p.{u1, u2} n F _inst_1 q) a i) (α i) (f i) (Set.univ.{u1} (MvPFunctor.b.{u1} n (MvQPF.p.{u1, u2} n F _inst_1 q) a i))) (Set.image.{u1, u1} (MvPFunctor.b.{u1} n (MvQPF.p.{u1, u2} n F _inst_1 q) a' i) (α i) (f' i) (Set.univ.{u1} (MvPFunctor.b.{u1} n (MvQPF.p.{u1, u2} n F _inst_1 q) a' i))))))))
but is expected to have type
  forall {n : Nat} {F : (TypeVec.{u2} n) -> Type.{u1}} [_inst_1 : MvFunctor.{u2, u1} n F] [q : MvQPF.{u2, u1} n F _inst_1] {α : TypeVec.{u2} n} (x : F α), Iff (forall (p : forall (i : Fin2 n), (α i) -> Prop), Iff (MvFunctor.LiftP.{u2, u1} n F _inst_1 α p x) (forall (i : Fin2 n) (u : α i), (Membership.mem.{u2, u2} (α i) (Set.{u2} (α i)) (Set.instMembershipSet.{u2} (α i)) u (MvFunctor.supp.{u2, u1} n F _inst_1 α x i)) -> (p i u))) (Exists.{succ u2} (MvPFunctor.A.{u2} n (MvQPF.P.{u2, u1} n F _inst_1 q)) (fun (a : MvPFunctor.A.{u2} n (MvQPF.P.{u2, u1} n F _inst_1 q)) => Exists.{succ u2} (TypeVec.Arrow.{u2, u2} n (MvPFunctor.B.{u2} n (MvQPF.P.{u2, u1} n F _inst_1 q) a) α) (fun (f : TypeVec.Arrow.{u2, u2} n (MvPFunctor.B.{u2} n (MvQPF.P.{u2, u1} n F _inst_1 q) a) α) => And (Eq.{succ u1} (F α) (MvQPF.abs.{u2, u1} n F _inst_1 q α (Sigma.mk.{u2, u2} (MvPFunctor.A.{u2} n (MvQPF.P.{u2, u1} n F _inst_1 q)) (fun (a : MvPFunctor.A.{u2} n (MvQPF.P.{u2, u1} n F _inst_1 q)) => TypeVec.Arrow.{u2, u2} n (MvPFunctor.B.{u2} n (MvQPF.P.{u2, u1} n F _inst_1 q) a) α) a f)) x) (forall (i : Fin2 n) (a' : MvPFunctor.A.{u2} n (MvQPF.P.{u2, u1} n F _inst_1 q)) (f' : TypeVec.Arrow.{u2, u2} n (MvPFunctor.B.{u2} n (MvQPF.P.{u2, u1} n F _inst_1 q) a') α), (Eq.{succ u1} (F α) (MvQPF.abs.{u2, u1} n F _inst_1 q α (Sigma.mk.{u2, u2} (MvPFunctor.A.{u2} n (MvQPF.P.{u2, u1} n F _inst_1 q)) (fun (a : MvPFunctor.A.{u2} n (MvQPF.P.{u2, u1} n F _inst_1 q)) => TypeVec.Arrow.{u2, u2} n (MvPFunctor.B.{u2} n (MvQPF.P.{u2, u1} n F _inst_1 q) a) α) a' f')) x) -> (HasSubset.Subset.{u2} (Set.{u2} (α i)) (Set.instHasSubsetSet.{u2} (α i)) (Set.image.{u2, u2} (MvPFunctor.B.{u2} n (MvQPF.P.{u2, u1} n F _inst_1 q) a i) (α i) (f i) (Set.univ.{u2} (MvPFunctor.B.{u2} n (MvQPF.P.{u2, u1} n F _inst_1 q) a i))) (Set.image.{u2, u2} (MvPFunctor.B.{u2} n (MvQPF.P.{u2, u1} n F _inst_1 q) a' i) (α i) (f' i) (Set.univ.{u2} (MvPFunctor.B.{u2} n (MvQPF.P.{u2, u1} n F _inst_1 q) a' i))))))))
Case conversion may be inaccurate. Consider using '#align mvqpf.has_good_supp_iff MvQPF.has_good_supp_iffₓ'. -/
theorem has_good_supp_iff {α : TypeVec n} (x : F α) :
    (∀ p, LiftP p x ↔ ∀ (i), ∀ u ∈ supp x i, p i u) ↔
      ∃ a f, abs ⟨a, f⟩ = x ∧ ∀ i a' f', abs ⟨a', f'⟩ = x → f i '' univ ⊆ f' i '' univ :=
  by
  constructor
  · intro h
    have : liftp (supp x) x := by
      rw [h]
      introv
      exact id
    rw [liftp_iff] at this
    rcases this with ⟨a, f, xeq, h'⟩
    refine' ⟨a, f, xeq.symm, _⟩
    intro a' f' h''
    rintro hu u ⟨j, h₂, hfi⟩
    have hh : u ∈ supp x a' := by rw [← hfi] <;> apply h'
    refine' (mem_supp x _ u).mp hh _ _ hu
  rintro ⟨a, f, xeq, h⟩ p; rw [liftp_iff]; constructor
  · rintro ⟨a', f', xeq', h'⟩ i u usuppx
    rcases(mem_supp x _ u).mp (@usuppx) a' f' xeq'.symm with ⟨i, _, f'ieq⟩
    rw [← f'ieq]
    apply h'
  intro h'
  refine' ⟨a, f, xeq.symm, _⟩; intro j y
  apply h'; rw [mem_supp]
  intro a' f' xeq'
  apply h _ a' f' xeq'
  apply mem_image_of_mem _ (mem_univ _)
#align mvqpf.has_good_supp_iff MvQPF.has_good_supp_iff

variable (q)

#print MvQPF.IsUniform /-
/-- A qpf is said to be uniform if every polynomial functor
representing a single value all have the same range. -/
def IsUniform : Prop :=
  ∀ ⦃α : TypeVec n⦄ (a a' : q.p.A) (f : q.p.B a ⟹ α) (f' : q.p.B a' ⟹ α),
    abs ⟨a, f⟩ = abs ⟨a', f'⟩ → ∀ i, f i '' univ = f' i '' univ
#align mvqpf.is_uniform MvQPF.IsUniform
-/

#print MvQPF.LiftPPreservation /-
/-- does `abs` preserve `liftp`? -/
def LiftPPreservation : Prop :=
  ∀ ⦃α : TypeVec n⦄ (p : ∀ ⦃i⦄, α i → Prop) (x : q.p.Obj α), LiftP p (abs x) ↔ LiftP p x
#align mvqpf.liftp_preservation MvQPF.LiftPPreservation
-/

#print MvQPF.SuppPreservation /-
/-- does `abs` preserve `supp`? -/
def SuppPreservation : Prop :=
  ∀ ⦃α⦄ (x : q.p.Obj α), supp (abs x) = supp x
#align mvqpf.supp_preservation MvQPF.SuppPreservation
-/

variable (q)

/- warning: mvqpf.supp_eq_of_is_uniform -> MvQPF.supp_eq_of_isUniform is a dubious translation:
lean 3 declaration is
  forall {n : Nat} {F : (TypeVec.{u1} n) -> Type.{u2}} [_inst_1 : MvFunctor.{u1, u2} n F] [q : MvQPF.{u1, u2} n F _inst_1], (MvQPF.IsUniform.{u1, u2} n F _inst_1 q) -> (forall {α : TypeVec.{u1} n} (a : MvPFunctor.A.{u1} n (MvQPF.p.{u1, u2} n F _inst_1 q)) (f : TypeVec.Arrow.{u1, u1} n (MvPFunctor.b.{u1} n (MvQPF.p.{u1, u2} n F _inst_1 q) a) α) (i : Fin2 n), Eq.{succ u1} (Set.{u1} (α i)) (MvFunctor.supp.{u1, u2} n F _inst_1 α (MvQPF.abs.{u1, u2} n F _inst_1 q α (Sigma.mk.{u1, u1} (MvPFunctor.A.{u1} n (MvQPF.p.{u1, u2} n F _inst_1 q)) (fun (a : MvPFunctor.A.{u1} n (MvQPF.p.{u1, u2} n F _inst_1 q)) => TypeVec.Arrow.{u1, u1} n (MvPFunctor.b.{u1} n (MvQPF.p.{u1, u2} n F _inst_1 q) a) α) a f)) i) (Set.image.{u1, u1} (MvPFunctor.b.{u1} n (MvQPF.p.{u1, u2} n F _inst_1 q) a i) (α i) (f i) (Set.univ.{u1} (MvPFunctor.b.{u1} n (MvQPF.p.{u1, u2} n F _inst_1 q) a i))))
but is expected to have type
  forall {n : Nat} {F : (TypeVec.{u2} n) -> Type.{u1}} [_inst_1 : MvFunctor.{u2, u1} n F] [q : MvQPF.{u2, u1} n F _inst_1], (MvQPF.IsUniform.{u2, u1} n F _inst_1 q) -> (forall {α : TypeVec.{u2} n} (a : MvPFunctor.A.{u2} n (MvQPF.P.{u2, u1} n F _inst_1 q)) (f : TypeVec.Arrow.{u2, u2} n (MvPFunctor.B.{u2} n (MvQPF.P.{u2, u1} n F _inst_1 q) a) α) (i : Fin2 n), Eq.{succ u2} (Set.{u2} (α i)) (MvFunctor.supp.{u2, u1} n F _inst_1 α (MvQPF.abs.{u2, u1} n F _inst_1 q α (Sigma.mk.{u2, u2} (MvPFunctor.A.{u2} n (MvQPF.P.{u2, u1} n F _inst_1 q)) (fun (a : MvPFunctor.A.{u2} n (MvQPF.P.{u2, u1} n F _inst_1 q)) => TypeVec.Arrow.{u2, u2} n (MvPFunctor.B.{u2} n (MvQPF.P.{u2, u1} n F _inst_1 q) a) α) a f)) i) (Set.image.{u2, u2} (MvPFunctor.B.{u2} n (MvQPF.P.{u2, u1} n F _inst_1 q) a i) (α i) (f i) (Set.univ.{u2} (MvPFunctor.B.{u2} n (MvQPF.P.{u2, u1} n F _inst_1 q) a i))))
Case conversion may be inaccurate. Consider using '#align mvqpf.supp_eq_of_is_uniform MvQPF.supp_eq_of_isUniformₓ'. -/
theorem supp_eq_of_isUniform (h : q.IsUniform) {α : TypeVec n} (a : q.p.A) (f : q.p.B a ⟹ α) :
    ∀ i, supp (abs ⟨a, f⟩) i = f i '' univ := by
  intro ; ext u; rw [mem_supp]; constructor
  · intro h'
    apply h' _ _ rfl
  intro h' a' f' e
  rw [← h _ _ _ _ e.symm]; apply h'
#align mvqpf.supp_eq_of_is_uniform MvQPF.supp_eq_of_isUniform

/- warning: mvqpf.liftp_iff_of_is_uniform -> MvQPF.liftP_iff_of_isUniform is a dubious translation:
lean 3 declaration is
  forall {n : Nat} {F : (TypeVec.{u1} n) -> Type.{u2}} [_inst_1 : MvFunctor.{u1, u2} n F] [q : MvQPF.{u1, u2} n F _inst_1], (MvQPF.IsUniform.{u1, u2} n F _inst_1 q) -> (forall {α : TypeVec.{u1} n} (x : F α) (p : forall (i : Fin2 n), (α i) -> Prop), Iff (MvFunctor.LiftP.{u1, u2} n F _inst_1 (fun (i : Fin2 n) => α i) p x) (forall (i : Fin2 n) (u : α i), (Membership.Mem.{u1, u1} (α i) (Set.{u1} (α i)) (Set.hasMem.{u1} (α i)) u (MvFunctor.supp.{u1, u2} n F _inst_1 α x i)) -> (p i u)))
but is expected to have type
  forall {n : Nat} {F : (TypeVec.{u2} n) -> Type.{u1}} [_inst_1 : MvFunctor.{u2, u1} n F] [q : MvQPF.{u2, u1} n F _inst_1], (MvQPF.IsUniform.{u2, u1} n F _inst_1 q) -> (forall {α : TypeVec.{u2} n} (x : F α) (p : forall (i : Fin2 n), (α i) -> Prop), Iff (MvFunctor.LiftP.{u2, u1} n F _inst_1 (fun (i : Fin2 n) => α i) p x) (forall (i : Fin2 n) (u : α i), (Membership.mem.{u2, u2} (α i) (Set.{u2} (α i)) (Set.instMembershipSet.{u2} (α i)) u (MvFunctor.supp.{u2, u1} n F _inst_1 α x i)) -> (p i u)))
Case conversion may be inaccurate. Consider using '#align mvqpf.liftp_iff_of_is_uniform MvQPF.liftP_iff_of_isUniformₓ'. -/
theorem liftP_iff_of_isUniform (h : q.IsUniform) {α : TypeVec n} (x : F α) (p : ∀ i, α i → Prop) :
    LiftP p x ↔ ∀ (i), ∀ u ∈ supp x i, p i u :=
  by
  rw [liftp_iff, ← abs_repr x]
  cases' repr x with a f; constructor
  · rintro ⟨a', f', abseq, hf⟩ u
    rw [supp_eq_of_is_uniform h, h _ _ _ _ abseq]
    rintro b ⟨i, _, hi⟩
    rw [← hi]
    apply hf
  intro h'
  refine' ⟨a, f, rfl, fun _ i => h' _ _ _⟩
  rw [supp_eq_of_is_uniform h]
  exact ⟨i, mem_univ i, rfl⟩
#align mvqpf.liftp_iff_of_is_uniform MvQPF.liftP_iff_of_isUniform

/- warning: mvqpf.supp_map -> MvQPF.supp_map is a dubious translation:
lean 3 declaration is
  forall {n : Nat} {F : (TypeVec.{u1} n) -> Type.{u2}} [_inst_1 : MvFunctor.{u1, u2} n F] [q : MvQPF.{u1, u2} n F _inst_1], (MvQPF.IsUniform.{u1, u2} n F _inst_1 q) -> (forall {α : TypeVec.{u1} n} {β : TypeVec.{u1} n} (g : TypeVec.Arrow.{u1, u1} n α β) (x : F α) (i : Fin2 n), Eq.{succ u1} (Set.{u1} (β i)) (MvFunctor.supp.{u1, u2} n (fun {α : TypeVec.{u1} n} => F α) _inst_1 β (MvFunctor.map.{u1, u2} n (fun {α : TypeVec.{u1} n} => F α) _inst_1 α β g x) i) (Set.image.{u1, u1} (α i) (β i) (g i) (MvFunctor.supp.{u1, u2} n (fun {α : TypeVec.{u1} n} => F α) _inst_1 α x i)))
but is expected to have type
  forall {n : Nat} {F : (TypeVec.{u2} n) -> Type.{u1}} [_inst_1 : MvFunctor.{u2, u1} n F] [q : MvQPF.{u2, u1} n F _inst_1], (MvQPF.IsUniform.{u2, u1} n F _inst_1 q) -> (forall {α : TypeVec.{u2} n} {β : TypeVec.{u2} n} (g : TypeVec.Arrow.{u2, u2} n α β) (x : F α) (i : Fin2 n), Eq.{succ u2} (Set.{u2} (β i)) (MvFunctor.supp.{u2, u1} n F _inst_1 β (MvFunctor.map.{u2, u1} n F _inst_1 α β g x) i) (Set.image.{u2, u2} (α i) (β i) (g i) (MvFunctor.supp.{u2, u1} n F _inst_1 α x i)))
Case conversion may be inaccurate. Consider using '#align mvqpf.supp_map MvQPF.supp_mapₓ'. -/
theorem supp_map (h : q.IsUniform) {α β : TypeVec n} (g : α ⟹ β) (x : F α) (i) :
    supp (g <$$> x) i = g i '' supp x i :=
  by
  rw [← abs_repr x]; cases' repr x with a f; rw [← abs_map, MvPFunctor.map_eq]
  rw [supp_eq_of_is_uniform h, supp_eq_of_is_uniform h, ← image_comp]
  rfl
#align mvqpf.supp_map MvQPF.supp_map

/- warning: mvqpf.supp_preservation_iff_uniform -> MvQPF.suppPreservation_iff_isUniform is a dubious translation:
lean 3 declaration is
  forall {n : Nat} {F : (TypeVec.{u1} n) -> Type.{u2}} [_inst_1 : MvFunctor.{u1, u2} n F] [q : MvQPF.{u1, u2} n F _inst_1], Iff (MvQPF.SuppPreservation.{u1, u2} n F _inst_1 q) (MvQPF.IsUniform.{u1, u2} n F _inst_1 q)
but is expected to have type
  forall {n : Nat} {F : (TypeVec.{u2} n) -> Type.{u1}} [_inst_1 : MvFunctor.{u2, u1} n F] [q : MvQPF.{u2, u1} n F _inst_1], Iff (MvQPF.SuppPreservation.{u2, u1} n F _inst_1 q) (MvQPF.IsUniform.{u2, u1} n F _inst_1 q)
Case conversion may be inaccurate. Consider using '#align mvqpf.supp_preservation_iff_uniform MvQPF.suppPreservation_iff_isUniformₓ'. -/
theorem suppPreservation_iff_isUniform : q.SuppPreservation ↔ q.IsUniform :=
  by
  constructor
  · intro h α a a' f f' h' i
    rw [← MvPFunctor.supp_eq, ← MvPFunctor.supp_eq, ← h, h', h]
  · rintro h α ⟨a, f⟩
    ext
    rwa [supp_eq_of_is_uniform, MvPFunctor.supp_eq]
#align mvqpf.supp_preservation_iff_uniform MvQPF.suppPreservation_iff_isUniform

/- warning: mvqpf.supp_preservation_iff_liftp_preservation -> MvQPF.suppPreservation_iff_liftpPreservation is a dubious translation:
lean 3 declaration is
  forall {n : Nat} {F : (TypeVec.{u1} n) -> Type.{u2}} [_inst_1 : MvFunctor.{u1, u2} n F] [q : MvQPF.{u1, u2} n F _inst_1], Iff (MvQPF.SuppPreservation.{u1, u2} n F _inst_1 q) (MvQPF.LiftPPreservation.{u1, u2} n F _inst_1 q)
but is expected to have type
  forall {n : Nat} {F : (TypeVec.{u2} n) -> Type.{u1}} [_inst_1 : MvFunctor.{u2, u1} n F] [q : MvQPF.{u2, u1} n F _inst_1], Iff (MvQPF.SuppPreservation.{u2, u1} n F _inst_1 q) (MvQPF.LiftPPreservation.{u2, u1} n F _inst_1 q)
Case conversion may be inaccurate. Consider using '#align mvqpf.supp_preservation_iff_liftp_preservation MvQPF.suppPreservation_iff_liftpPreservationₓ'. -/
theorem suppPreservation_iff_liftpPreservation : q.SuppPreservation ↔ q.LiftPPreservation :=
  by
  constructor <;> intro h
  · rintro α p ⟨a, f⟩
    have h' := h
    rw [supp_preservation_iff_uniform] at h'
    dsimp only [supp_preservation, supp] at h
    simp only [liftp_iff_of_is_uniform, supp_eq_of_is_uniform, MvPFunctor.liftP_iff', h',
      image_univ, mem_range, exists_imp]
    constructor <;> intros <;> subst_vars <;> solve_by_elim
  · rintro α ⟨a, f⟩
    simp only [liftp_preservation] at h
    ext
    simp [supp, h]
#align mvqpf.supp_preservation_iff_liftp_preservation MvQPF.suppPreservation_iff_liftpPreservation

/- warning: mvqpf.liftp_preservation_iff_uniform -> MvQPF.liftpPreservation_iff_uniform is a dubious translation:
lean 3 declaration is
  forall {n : Nat} {F : (TypeVec.{u1} n) -> Type.{u2}} [_inst_1 : MvFunctor.{u1, u2} n F] [q : MvQPF.{u1, u2} n F _inst_1], Iff (MvQPF.LiftPPreservation.{u1, u2} n F _inst_1 q) (MvQPF.IsUniform.{u1, u2} n F _inst_1 q)
but is expected to have type
  forall {n : Nat} {F : (TypeVec.{u2} n) -> Type.{u1}} [_inst_1 : MvFunctor.{u2, u1} n F] [q : MvQPF.{u2, u1} n F _inst_1], Iff (MvQPF.LiftPPreservation.{u2, u1} n F _inst_1 q) (MvQPF.IsUniform.{u2, u1} n F _inst_1 q)
Case conversion may be inaccurate. Consider using '#align mvqpf.liftp_preservation_iff_uniform MvQPF.liftpPreservation_iff_uniformₓ'. -/
theorem liftpPreservation_iff_uniform : q.LiftPPreservation ↔ q.IsUniform := by
  rw [← supp_preservation_iff_liftp_preservation, supp_preservation_iff_uniform]
#align mvqpf.liftp_preservation_iff_uniform MvQPF.liftpPreservation_iff_uniform

end MvQPF


import data.polynomial.eval
import time_bound

def polytime (c : code) : Prop :=
∃ (p : polynomial ℕ), time_bound c (λ n, p.eval n)

lemma polytime_fst : polytime code.fst :=
by { use (polynomial.monomial 1 1) + 1, simpa using time_bound_fst, }

lemma polytime_snd : polytime code.snd :=
by { use (polynomial.monomial 1 1) + 1, simpa using time_bound_snd, }

lemma polytime_bit (b : bool) : polytime (code.bit b) :=
by { use (polynomial.monomial 1 1) + 1, simpa using time_bound_bit b, }

lemma polytime_pair {c₁ c₂ : code} : polytime c₁ → polytime c₂ → polytime (code.pair c₁ c₂)
| ⟨p₁, e₁⟩ ⟨p₂, e₂⟩ := by { use p₁ + p₂ + 3, convert time_bound_pair e₁ e₂, simp, }

lemma polytime_comp {c₁ c₂ : code} : polytime c₁ → polytime c₂ → polytime (code.comp c₁ c₂)
| ⟨p₁, e₁⟩ ⟨p₂, e₂⟩ := by { use p₂ + (p₁.comp (p₂^2 + 1)) + 1, convert time_bound_comp e₁ e₂, simp, }

lemma polytime_case {c₁ c₂ c₃ : code} : polytime c₁ → polytime c₂ → polytime c₃ → polytime (code.case c₁ c₂ c₃)
| ⟨p₁, e₁⟩ ⟨p₂, e₂⟩ ⟨p₃, e₃⟩ := by { use p₁ + p₂ + (p₃.eval 0) + 1, convert time_bound_case' e₁ e₂ e₃, simp, }

lemma polytime_zero : polytime zero :=
by { apply polytime_comp, apply polytime_fst, apply polytime_bit, }

lemma polytime_one : polytime one :=
polytime_comp (polytime_bit _) polytime_zero

lemma polytime_tail : polytime tail :=
polytime_comp polytime_snd (polytime_comp (polytime_bit _) (polytime_comp (polytime_bit _) (polytime_bit _)))

lemma polytime_id : polytime code.id :=
polytime_comp polytime_snd (polytime_bit _)

lemma polytime_append_const (bs : list bool) : polytime (append_const bs) :=
by { induction bs, { exact polytime_id, }, apply polytime_comp (polytime_bit _), assumption, }

lemma polytime_const (n : ℕ) : polytime (code.const n) :=
polytime_comp (polytime_append_const _) polytime_zero

lemma polytime_to_bit : polytime to_bit :=
polytime_case polytime_one polytime_one polytime_zero

lemma polytime_cons_bit {f g : code} (fp : polytime f) (gp : polytime g) : polytime (cons_bit f g) :=
polytime_comp (polytime_case (polytime_comp polytime_tail polytime_tail) (polytime_bit _) polytime_zero)
(polytime_pair (polytime_comp polytime_to_bit fp) gp)

lemma polytime_ite {c f g : code} (cp : polytime c) (fp : polytime f) (gp : polytime g) : polytime (code.ite c f g) :=
polytime_comp (polytime_case fp gp fp) (polytime_cons_bit cp polytime_id)


/-
Copyright (c) 2021 Yury Kudryashov. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yury Kudryashov, Reid Barton
-/
import topology.separation

/-!
# The shrinking lemma

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

In this file we prove a few versions of the shrinking lemma. The lemma says that in a normal
topological space a point finite open covering can be “shrunk”: for a point finite open covering
`u : ι → set X` there exists a refinement `v : ι → set X` such that `closure (v i) ⊆ u i`.

For finite or countable coverings this lemma can be proved without the axiom of choice, see
[ncatlab](https://ncatlab.org/nlab/show/shrinking+lemma) for details. We only formalize the most
general result that works for any covering but needs the axiom of choice.

We prove two versions of the lemma:

* `exists_subset_Union_closure_subset` deals with a covering of a closed set in a normal space;
* `exists_Union_eq_closure_subset` deals with a covering of the whole space.

## Tags

normal space, shrinking lemma
-/

open set function
open_locale classical
noncomputable theory

variables {ι X : Type*} [topological_space X] [normal_space X]

namespace shrinking_lemma

/-- Auxiliary definition for the proof of `shrinking_lemma`. A partial refinement of a covering
`⋃ i, u i` of a set `s` is a map `v : ι → set X` and a set `carrier : set ι` such that

* `s ⊆ ⋃ i, v i`;
* all `v i` are open;
* if `i ∈ carrier v`, then `closure (v i) ⊆ u i`;
* if `i ∉ carrier`, then `v i = u i`.

This type is equipped with the folowing partial order: `v ≤ v'` if `v.carrier ⊆ v'.carrier`
and `v i = v' i` for `i ∈ v.carrier`. We will use Zorn's lemma to prove that this type has
a maximal element, then show that the maximal element must have `carrier = univ`. -/
@[nolint has_nonempty_instance] -- the trivial refinement needs `u` to be a covering
structure partial_refinement (u : ι → set X) (s : set X) :=
(to_fun : ι → set X)
(carrier : set ι)
(is_open' : ∀ i, is_open (to_fun i))
(subset_Union' : s ⊆ ⋃ i, to_fun i)
(closure_subset' : ∀ i ∈ carrier, closure (to_fun i) ⊆ (u i))
(apply_eq' : ∀ i ∉ carrier, to_fun i = u i)

namespace partial_refinement

variables {u : ι → set X} {s : set X}

instance : has_coe_to_fun (partial_refinement u s) (λ _, ι → set X) := ⟨to_fun⟩

lemma subset_Union (v : partial_refinement u s) : s ⊆ ⋃ i, v i := v.subset_Union'

lemma closure_subset (v : partial_refinement u s) {i : ι} (hi : i ∈ v.carrier) :
  closure (v i) ⊆ (u i) :=
v.closure_subset' i hi

lemma apply_eq (v : partial_refinement u s) {i : ι} (hi : i ∉ v.carrier) : v i = u i :=
v.apply_eq' i hi

protected

protected lemma subset (v : partial_refinement u s) (i : ι) : v i ⊆ u i :=
if h : i ∈ v.carrier then subset.trans subset_closure (v.closure_subset h)
else (v.apply_eq h).le

attribute [ext] partial_refinement

instance : partial_order (partial_refinement u s) :=
{ le := λ v₁ v₂, v₁.carrier ⊆ v₂.carrier ∧ ∀ i ∈ v₁.carrier, v₁ i = v₂ i,
  le_refl := λ v, ⟨subset.refl _, λ _ _, rfl⟩,
  le_trans := λ v₁ v₂ v₃ h₁₂ h₂₃,
    ⟨subset.trans h₁₂.1 h₂₃.1, λ i hi, (h₁₂.2 i hi).trans (h₂₃.2 i $ h₁₂.1 hi)⟩,
  le_antisymm := λ v₁ v₂ h₁₂ h₂₁,
    have hc : v₁.carrier = v₂.carrier, from subset.antisymm h₁₂.1 h₂₁.1,
    ext _ _ (funext $ λ x,
      if hx : x ∈ v₁.carrier then h₁₂.2 _ hx
      else (v₁.apply_eq hx).trans (eq.symm $ v₂.apply_eq $ hc ▸ hx)) hc }

/-- If two partial refinements `v₁`, `v₂` belong to a chain (hence, they are comparable)
and `i` belongs to the carriers of both partial refinements, then `v₁ i = v₂ i`. -/
lemma apply_eq_of_chain {c : set (partial_refinement u s)} (hc : is_chain (≤) c) {v₁ v₂}
  (h₁ : v₁ ∈ c) (h₂ : v₂ ∈ c) {i} (hi₁ : i ∈ v₁.carrier) (hi₂ : i ∈ v₂.carrier) :
  v₁ i = v₂ i :=
begin
  wlog hle : v₁ ≤ v₂,
  { cases hc.total h₁ h₂; [skip, symmetry]; apply_assumption; assumption' },
  exact hle.2 _ hi₁,
end

/-- The carrier of the least upper bound of a non-empty chain of partial refinements
is the union of their carriers. -/
def chain_Sup_carrier (c : set (partial_refinement u s)) : set ι :=
⋃ v ∈ c, carrier v

/-- Choice of an element of a nonempty chain of partial refinements. If `i` belongs to one of
`carrier v`, `v ∈ c`, then `find c ne i` is one of these partial refinements. -/
def find (c : set (partial_refinement u s)) (ne : c.nonempty) (i : ι) :
  partial_refinement u s :=
if hi : ∃ v ∈ c, i ∈ carrier v then hi.some else ne.some

lemma find_mem {c : set (partial_refinement u s)} (i : ι) (ne : c.nonempty) :
  find c ne i ∈ c :=
by { rw find, split_ifs, exacts [h.some_spec.fst, ne.some_spec] }

lemma mem_find_carrier_iff {c : set (partial_refinement u s)} {i : ι} (ne : c.nonempty) :
  i ∈ (find c ne i).carrier ↔ i ∈ chain_Sup_carrier c :=
begin
  rw find,
  split_ifs,
  { have : i ∈ h.some.carrier ∧ i ∈ chain_Sup_carrier c,
      from ⟨h.some_spec.snd, mem_Union₂.2 h⟩,
    simp only [this] },
  { have : i ∉ ne.some.carrier ∧ i ∉ chain_Sup_carrier c,
      from ⟨λ hi, h ⟨_, ne.some_spec, hi⟩, mt mem_Union₂.1 h⟩,
    simp only [this] }
end

lemma find_apply_of_mem {c : set (partial_refinement u s)} (hc : is_chain (≤) c) (ne : c.nonempty)
  {i v} (hv : v ∈ c) (hi : i ∈ carrier v) :
  find c ne i i = v i :=
apply_eq_of_chain hc (find_mem _ _) hv
  ((mem_find_carrier_iff _).2 $ mem_Union₂.2 ⟨v, hv, hi⟩) hi

/-- Least upper bound of a nonempty chain of partial refinements. -/
def chain_Sup (c : set (partial_refinement u s)) (hc : is_chain (≤) c)
  (ne : c.nonempty) (hfin : ∀ x ∈ s, {i | x ∈ u i}.finite) (hU : s ⊆ ⋃ i, u i) :
  partial_refinement u s :=
begin
  refine ⟨λ i, find c ne i i, chain_Sup_carrier c,
    λ i, (find _ _ _).is_open i,
    λ x hxs, mem_Union.2 _,
    λ i hi, (find c ne i).closure_subset ((mem_find_carrier_iff _).2 hi),
    λ i hi, (find c ne i).apply_eq (mt (mem_find_carrier_iff _).1 hi)⟩,
  rcases em (∃ i ∉ chain_Sup_carrier c, x ∈ u i) with ⟨i, hi, hxi⟩|hx,
  { use i,
    rwa (find c ne i).apply_eq (mt (mem_find_carrier_iff _).1 hi) },
  { simp_rw [not_exists, not_imp_not, chain_Sup_carrier, mem_Union₂] at hx,
    haveI : nonempty (partial_refinement u s) := ⟨ne.some⟩,
    choose! v hvc hiv using hx,
    rcases (hfin x hxs).exists_maximal_wrt v _ (mem_Union.1 (hU hxs))
      with ⟨i, hxi : x ∈ u i, hmax : ∀ j, x ∈ u j → v i ≤ v j → v i = v j⟩,
    rcases mem_Union.1 ((v i).subset_Union hxs) with ⟨j, hj⟩,
    use j,
    have hj' : x ∈ u j := (v i).subset _ hj,
    have : v j ≤ v i,
      from (hc.total (hvc _ hxi) (hvc _ hj')).elim (λ h, (hmax j hj' h).ge) id,
    rwa find_apply_of_mem hc ne (hvc _ hxi) (this.1 $ hiv _ hj') }
end

/-- `chain_Sup hu c hc ne hfin hU` is an upper bound of the chain `c`. -/
lemma le_chain_Sup {c : set (partial_refinement u s)} (hc : is_chain (≤) c)
  (ne : c.nonempty) (hfin : ∀ x ∈ s, {i | x ∈ u i}.finite) (hU : s ⊆ ⋃ i, u i)
  {v} (hv : v ∈ c) :
  v ≤ chain_Sup c hc ne hfin hU :=
⟨λ i hi, mem_bUnion hv hi, λ i hi, (find_apply_of_mem hc _ hv hi).symm⟩

/-- If `s` is a closed set, `v` is a partial refinement, and `i` is an index such that
`i ∉ v.carrier`, then there exists a partial refinement that is strictly greater than `v`. -/
lemma exists_gt (v : partial_refinement u s) (hs : is_closed s) (i : ι) (hi : i ∉ v.carrier) :
  ∃ v' : partial_refinement u s, v < v' :=
begin
  have I : s ∩ (⋂ j ≠ i, (v j)ᶜ) ⊆ v i,
  { simp only [subset_def, mem_inter_iff, mem_Inter, and_imp],
    intros x hxs H,
    rcases mem_Union.1 (v.subset_Union hxs) with ⟨j, hj⟩,
    exact (em (j = i)).elim (λ h, h ▸ hj) (λ h, (H j h hj).elim) },
  have C : is_closed (s ∩ (⋂ j ≠ i, (v j)ᶜ)),
    from is_closed.inter hs (is_closed_bInter $ λ _ _, is_closed_compl_iff.2 $ v.is_open _),
  rcases normal_exists_closure_subset C (v.is_open i) I with ⟨vi, ovi, hvi, cvi⟩,
  refine ⟨⟨update v i vi, insert i v.carrier, _, _, _, _⟩, _, _⟩,
  { intro j, by_cases h : j = i; simp [h, ovi, v.is_open] },
  { refine λ x hx, mem_Union.2 _,
    rcases em (∃ j ≠ i, x ∈ v j) with ⟨j, hji, hj⟩|h,
    { use j, rwa update_noteq hji },
    { push_neg at h, use i, rw update_same, exact hvi ⟨hx, mem_bInter h⟩ } },
  { rintro j (rfl|hj),
    { rwa [update_same, ← v.apply_eq hi] },
    { rw update_noteq (ne_of_mem_of_not_mem hj hi), exact v.closure_subset hj } },
  { intros j hj,
    rw [mem_insert_iff, not_or_distrib] at hj,
    rw [update_noteq hj.1, v.apply_eq hj.2] },
  { refine ⟨subset_insert _ _, λ j hj, _⟩,
    exact (update_noteq (ne_of_mem_of_not_mem hj hi) _ _).symm },
  { exact λ hle, hi (hle.1 $ mem_insert _ _) }
end

end partial_refinement

end shrinking_lemma

open shrinking_lemma

variables {u : ι → set X} {s : set X}

/-- Shrinking lemma. A point-finite open cover of a closed subset of a normal space can be "shrunk"
to a new open cover so that the closure of each new open set is contained in the corresponding
original open set. -/
lemma exists_subset_Union_closure_subset (hs : is_closed s) (uo : ∀ i, is_open (u i))
  (uf : ∀ x ∈ s, {i | x ∈ u i}.finite) (us : s ⊆ ⋃ i, u i) :
  ∃ v : ι → set X, s ⊆ Union v ∧ (∀ i, is_open (v i)) ∧ ∀ i, closure (v i) ⊆ u i :=
begin
  classical,
  haveI : nonempty (partial_refinement u s) := ⟨⟨u, ∅, uo, us, λ _, false.elim, λ _ _, rfl⟩⟩,
  have : ∀ c : set (partial_refinement u s), is_chain (≤) c → c.nonempty → ∃ ub, ∀ v ∈ c, v ≤ ub,
    from λ c hc ne, ⟨partial_refinement.chain_Sup c hc ne uf us,
      λ v hv, partial_refinement.le_chain_Sup _ _ _ _ hv⟩,
  rcases zorn_nonempty_partial_order this with ⟨v, hv⟩,
  suffices : ∀ i, i ∈ v.carrier,
    from ⟨v, v.subset_Union, λ i, v.is_open _, λ i, v.closure_subset (this i)⟩,
  contrapose! hv,
  rcases hv with ⟨i, hi⟩,
  rcases v.exists_gt hs i hi with ⟨v', hlt⟩,
  exact ⟨v', hlt.le, hlt.ne'⟩
end

/-- Shrinking lemma. A point-finite open cover of a closed subset of a normal space can be "shrunk"
to a new closed cover so that each new closed set is contained in the corresponding original open
set. See also `exists_subset_Union_closure_subset` for a stronger statement. -/
lemma exists_subset_Union_closed_subset (hs : is_closed s) (uo : ∀ i, is_open (u i))
  (uf : ∀ x ∈ s, {i | x ∈ u i}.finite) (us : s ⊆ ⋃ i, u i) :
  ∃ v : ι → set X, s ⊆ Union v ∧ (∀ i, is_closed (v i)) ∧ ∀ i, v i ⊆ u i :=
let ⟨v, hsv, hvo, hv⟩ := exists_subset_Union_closure_subset hs uo uf us
in ⟨λ i, closure (v i), subset.trans hsv (Union_mono $ λ i, subset_closure),
  λ i, is_closed_closure, hv⟩

/-- Shrinking lemma. A point-finite open cover of a closed subset of a normal space can be "shrunk"
to a new open cover so that the closure of each new open set is contained in the corresponding
original open set. -/
lemma exists_Union_eq_closure_subset (uo : ∀ i, is_open (u i)) (uf : ∀ x, {i | x ∈ u i}.finite)
  (uU : (⋃ i, u i) = univ) :
  ∃ v : ι → set X, Union v = univ ∧ (∀ i, is_open (v i)) ∧ ∀ i, closure (v i) ⊆ u i :=
let ⟨v, vU, hv⟩ := exists_subset_Union_closure_subset is_closed_univ uo (λ x _, uf x) uU.ge
in ⟨v, univ_subset_iff.1 vU, hv⟩

/-- Shrinking lemma. A point-finite open cover of a closed subset of a normal space can be "shrunk"
to a new closed cover so that each of the new closed sets is contained in the corresponding
original open set. See also `exists_Union_eq_closure_subset` for a stronger statement. -/
lemma exists_Union_eq_closed_subset (uo : ∀ i, is_open (u i)) (uf : ∀ x, {i | x ∈ u i}.finite)
  (uU : (⋃ i, u i) = univ) :
  ∃ v : ι → set X, Union v = univ ∧ (∀ i, is_closed (v i)) ∧ ∀ i, v i ⊆ u i :=
let ⟨v, vU, hv⟩ := exists_subset_Union_closed_subset is_closed_univ uo (λ x _, uf x) uU.ge
in ⟨v, univ_subset_iff.1 vU, hv⟩


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

import category_theory.skeletal
import tactic.linarith
import data.fintype.sort
import order.category.NonemptyFinLinOrd

/-! # The simplex category

We construct a skeletal model of the simplex category, with objects `ℕ` and the
morphism `n ⟶ m` being the monotone maps from `fin (n+1)` to `fin (m+1)`.

We show that this category is equivalent to `NonemptyFinLinOrd`.

## Remarks

The definitions `simplex_category` and `simplex_category.hom` are marked as irreducible.

We provide the following functions to work with these objects:
1. `simplex_category.mk` creates an object of `simplex_category` out of a natural number.
  Use the notation `[n]` in the `simplicial` locale.
2. `simplex_category.len` gives the "length" of an object of `simplex_category`, as a natural.
3. `simplex_category.hom.mk` makes a morphism out of a monotone map between `fin`'s.
4. `simplex_category.hom.to_preorder_hom` gives the underlying monotone map associated to a
  term of `simplex_category.hom`.

-/

universes u v

open category_theory

/-- The simplex category:
* objects are natural numbers `n : ℕ`
* morphisms from `n` to `m` are monotone functions `fin (n+1) → fin (m+1)`
-/
@[derive inhabited, irreducible]
def simplex_category := ulift.{u} ℕ

namespace simplex_category

section
local attribute [semireducible] simplex_category

-- TODO: Make `mk` irreducible.
/-- Interpet a natural number as an object of the simplex category. -/
def mk (n : ℕ) : simplex_category.{u} := ulift.up n

localized "notation `[`n`]` := simplex_category.mk n" in simplicial

-- TODO: Make `len` irreducible.
/-- The length of an object of `simplex_category`. -/
def len (n : simplex_category.{u}) : ℕ := n.down

@[ext] lemma ext (a b : simplex_category.{u}) : a.len = b.len → a = b := ulift.ext a b
@[simp] lemma len_mk (n : ℕ) : [n].len = n := rfl
@[simp] lemma mk_len (n : simplex_category.{u}) : [n.len] = n := by {cases n, refl}

/-- Morphisms in the simplex_category. -/
@[irreducible, nolint has_inhabited_instance]
protected def hom (a b : simplex_category.{u}) : Type u :=
ulift (fin (a.len + 1) →ₘ fin (b.len + 1))

namespace hom

local attribute [semireducible] simplex_category.hom

/-- Make a moprhism in `simplex_category` from a monotone map of fin's. -/
def mk {a b : simplex_category.{u}} (f : fin (a.len + 1) →ₘ fin (b.len + 1)) :
  simplex_category.hom a b :=
ulift.up f

/-- Recover the monotone map from a morphism in the simplex category. -/
def to_preorder_hom {a b : simplex_category.{u}} (f : simplex_category.hom a b) :
  fin (a.len + 1) →ₘ fin (b.len + 1) :=
ulift.down f

@[ext] lemma ext {a b : simplex_category.{u}} (f g : simplex_category.hom a b) :
  f.to_preorder_hom = g.to_preorder_hom → f = g := ulift.ext _ _

@[simp] lemma mk_to_preorder_hom {a b : simplex_category.{u}}
  (f : simplex_category.hom a b) : mk (f.to_preorder_hom) = f :=
by {cases f, refl}

@[simp] lemma to_preorder_hom_mk {a b : simplex_category.{u}}
  (f : fin (a.len + 1) →ₘ fin (b.len + 1)) : (mk f).to_preorder_hom = f :=
by simp [to_preorder_hom, mk]

lemma mk_to_preorder_hom_apply {a b : simplex_category.{u}}
  (f : fin (a.len + 1) →ₘ fin (b.len + 1)) (i : fin (a.len + 1)) :
  (mk f).to_preorder_hom i = f i := rfl

/-- Identity morphisms of `simplex_category`. -/
@[simp]
def id (a : simplex_category.{u}) :
  simplex_category.hom a a :=
mk preorder_hom.id

/-- Composition of morphisms of `simplex_category`. -/
@[simp]
def comp {a b c : simplex_category.{u}} (f : simplex_category.hom b c)
  (g : simplex_category.hom a b) : simplex_category.hom a c :=
mk $ f.to_preorder_hom.comp g.to_preorder_hom

end hom

@[simps]
instance small_category : small_category.{u} simplex_category :=
{ hom := λ n m, simplex_category.hom n m,
  id := λ m, simplex_category.hom.id _,
  comp := λ _ _ _ f g, simplex_category.hom.comp g f, }

/-- The constant morphism from [0]. -/
def const (x : simplex_category.{u}) (i : fin (x.len+1)) : [0] ⟶ x :=
  hom.mk $ ⟨λ _, i, by tauto⟩

@[simp]
lemma const_comp (x y : simplex_category.{u}) (i : fin (x.len + 1)) (f : x ⟶ y) :
  const x i ≫ f = const y (f.to_preorder_hom i) := rfl

/--
Make a morphism `[n] ⟶ [m]` from a monotone map between fin's.
This is useful for constructing morphisms beetween `[n]` directly
without identifying `n` with `[n].len`.
-/
@[simp]
def mk_hom {n m : ℕ} (f : (fin (n+1)) →ₘ (fin (m+1))) : [n] ⟶ [m] :=
simplex_category.hom.mk f

lemma hom_zero_zero (f : [0] ⟶ [0]) : f = 𝟙 _ :=
by { ext : 2, dsimp, apply subsingleton.elim }

end

open_locale simplicial

section generators
/-!
## Generating maps for the simplex category

TODO: prove that the simplex category is equivalent to
one given by the following generators and relations.
-/

/-- The `i`-th face map from `[n]` to `[n+1]` -/
def δ {n} (i : fin (n+2)) : [n] ⟶ [n+1] :=
mk_hom (fin.succ_above i).to_preorder_hom

/-- The `i`-th degeneracy map from `[n+1]` to `[n]` -/
def σ {n} (i : fin (n+1)) : [n+1] ⟶ [n] := mk_hom
{ to_fun := fin.pred_above i,
  monotone' := fin.pred_above_right_monotone i }

/-- The generic case of the first simplicial identity -/
lemma δ_comp_δ {n} {i j : fin (n+2)} (H : i ≤ j) :
  δ i ≫ δ j.succ = δ j ≫ δ i.cast_succ :=
begin
  ext k,
  dsimp [δ, fin.succ_above],
  simp only [order_embedding.to_preorder_hom_coe,
    order_embedding.coe_of_strict_mono,
    function.comp_app,
    simplex_category.hom.to_preorder_hom_mk,
    preorder_hom.comp_coe],
  rcases i with ⟨i, _⟩,
  rcases j with ⟨j, _⟩,
  rcases k with ⟨k, _⟩,
  split_ifs; { simp at *; linarith },
end

/-- The special case of the first simplicial identity -/
lemma δ_comp_δ_self {n} {i : fin (n+2)} : δ i ≫ δ i.cast_succ = δ i ≫ δ i.succ :=
(δ_comp_δ (le_refl i)).symm

/-- The second simplicial identity -/
lemma δ_comp_σ_of_le {n} {i : fin (n+2)} {j : fin (n+1)} (H : i ≤ j.cast_succ) :
  δ i.cast_succ ≫ σ j.succ = σ j ≫ δ i :=
begin
  ext k,
  suffices : ite (j.succ.cast_succ < ite (k < i) k.cast_succ k.succ)
    (ite (k < i) (k:ℕ) (k + 1) - 1) (ite (k < i) k (k + 1)) =
      ite ((if h : (j:ℕ) < k
        then k.pred (by { rintro rfl, exact nat.not_lt_zero _ h })
        else k.cast_lt (by { cases j, cases k, simp only [len_mk], linarith })).cast_succ < i)
          (ite (j.cast_succ < k) (k - 1) k) (ite (j.cast_succ < k) (k - 1) k + 1),
  { dsimp [δ, σ, fin.succ_above, fin.pred_above],
    simpa [fin.pred_above] with push_cast },
  rcases i with ⟨i, _⟩,
  rcases j with ⟨j, _⟩,
  rcases k with ⟨k, _⟩,
  simp only [subtype.mk_le_mk, fin.cast_succ_mk] at H,
  dsimp, simp only [if_congr, subtype.mk_lt_mk, dif_ctx_congr],
  split_ifs,
  -- Most of the goals can now be handled by `linarith`,
  -- but we have to deal with two of them by hand.
  swap 8,
  { exact (nat.succ_pred_eq_of_pos (lt_of_le_of_lt (zero_le _) ‹_›)).symm, },
  swap 7,
  { have : k ≤ i := nat.le_of_pred_lt ‹_›, linarith, },
  -- Hope for the best from `linarith`:
  all_goals { try { refl <|> simp at * }; linarith, },
end

/-- The first part of the third simplicial identity -/
lemma δ_comp_σ_self {n} {i : fin (n+1)} :
  δ i.cast_succ ≫ σ i = 𝟙 [n] :=
begin
  ext j,
  suffices : ite (fin.cast_succ i < ite (j < i) (fin.cast_succ j) j.succ)
    (ite (j < i) (j:ℕ) (j + 1) - 1) (ite (j < i) j (j + 1)) = j,
  { dsimp [δ, σ, fin.succ_above, fin.pred_above], simpa [fin.pred_above] with push_cast },
  rcases i with ⟨i, _⟩,
  rcases j with ⟨j, _⟩,
  dsimp, simp only [if_congr, subtype.mk_lt_mk],
  split_ifs; { simp at *; linarith, },
end

/-- The second part of the third simplicial identity -/
lemma δ_comp_σ_succ {n} {i : fin (n+1)} :
  δ i.succ ≫ σ i = 𝟙 [n] :=
begin
  ext j,
  rcases i with ⟨i, _⟩,
  rcases j with ⟨j, _⟩,
  dsimp [δ, σ, fin.succ_above, fin.pred_above],
  simp [fin.pred_above] with push_cast,
  split_ifs; { simp at *; linarith, },
end

/-- The fourth simplicial identity -/
lemma δ_comp_σ_of_gt {n} {i : fin (n+2)} {j : fin (n+1)} (H : j.cast_succ < i) :
  δ i.succ ≫ σ j.cast_succ = σ j ≫ δ i :=
begin
  ext k,
  dsimp [δ, σ, fin.succ_above, fin.pred_above],
  rcases i with ⟨i, _⟩,
  rcases j with ⟨j, _⟩,
  rcases k with ⟨k, _⟩,
  simp only [subtype.mk_lt_mk, fin.cast_succ_mk] at H,
  suffices : ite (_ < ite (k < i + 1) _ _) _ _ =
    ite _ (ite (j < k) (k - 1) k) (ite (j < k) (k - 1) k + 1),
  { simpa [apply_dite fin.cast_succ, fin.pred_above] with push_cast, },
  split_ifs,
  -- Most of the goals can now be handled by `linarith`,
  -- but we have to deal with three of them by hand.
  swap 2,
  { simp only [subtype.mk_lt_mk] at h_1,
    simp only [not_lt] at h_2,
    simp only [self_eq_add_right, one_ne_zero],
    exact lt_irrefl (k - 1) (lt_of_lt_of_le
      (nat.pred_lt (ne_of_lt (lt_of_le_of_lt (zero_le _) h_1)).symm)
      (le_trans (nat.le_of_lt_succ h) h_2)) },
  swap 4,
  { simp only [subtype.mk_lt_mk] at h_1,
    simp only [not_lt] at h,
    simp only [nat.add_succ_sub_one, add_zero],
    exfalso,
    exact lt_irrefl _ (lt_of_le_of_lt (nat.le_pred_of_lt (nat.lt_of_succ_le h)) h_3), },
  swap 4,
  { simp only [subtype.mk_lt_mk] at h_1,
    simp only [not_lt] at h_3,
    simp only [nat.add_succ_sub_one, add_zero],
    exact (nat.succ_pred_eq_of_pos (lt_of_le_of_lt (zero_le _) h_2)).symm, },
  -- Hope for the best from `linarith`:
  all_goals { simp at h_1 h_2 ⊢; linarith, },
end

local attribute [simp] fin.pred_mk

/-- The fifth simplicial identity -/
lemma σ_comp_σ {n} {i j : fin (n+1)} (H : i ≤ j) :
  σ i.cast_succ ≫ σ j = σ j.succ ≫ σ i :=
begin
  ext k,
  dsimp [σ, fin.pred_above],
  rcases i with ⟨i, _⟩,
  rcases j with ⟨j, _⟩,
  rcases k with ⟨k, _⟩,
  simp only [subtype.mk_le_mk] at H,
  -- At this point `simp with push_cast` makes good progress, but neither `simp?` nor `squeeze_simp`
  -- return usable sets of lemmas.
  -- To avoid using a non-terminal simp, we make a `suffices` statement indicating the shape
  -- of the goal we're looking for, and then use `simpa with push_cast`.
  -- I'm not sure this is actually much more robust that a non-terminal simp.
  suffices : ite (_ < dite (i < k) _ _) _ _ =
    ite (_ < dite (j + 1 < k) _ _) _ _,
  { simpa [fin.pred_above] with push_cast, },
  split_ifs,
  -- `split_ifs` created 12 goals.
  -- Most of them are dealt with `by simp at *; linarith`,
  -- but we pull out two harder ones to do by hand.
  swap 3,
  { simp only [not_lt] at h_2,
    exact false.elim
    (lt_irrefl (k - 1)
      (lt_of_lt_of_le (nat.pred_lt (id (ne_of_lt (lt_of_le_of_lt (zero_le i) h)).symm))
        (le_trans h_2 (nat.succ_le_of_lt h_1)))) },
  swap 3,
  { simp only [subtype.mk_lt_mk, not_lt] at h_1,
    exact false.elim
    (lt_irrefl j (lt_of_lt_of_le (nat.pred_lt_pred (nat.succ_ne_zero j) h_2) h_1)) },
  -- Deal with the rest automatically.
  all_goals { simp at *; linarith, },
end

end generators

section skeleton

/-- The functor that exhibits `simplex_category` as skeleton
of `NonemptyFinLinOrd` -/
@[simps obj map]
def skeletal_functor : simplex_category.{u} ⥤ NonemptyFinLinOrd.{v} :=
{ obj := λ a, NonemptyFinLinOrd.of $ ulift (fin (a.len + 1)),
  map := λ a b f,
    ⟨λ i, ulift.up (f.to_preorder_hom i.down), λ i j h, f.to_preorder_hom.monotone h⟩,
  map_id' := λ a, by { ext, simp, },
  map_comp' := λ a b c f g, by { ext, simp, }, }

lemma skeletal : skeletal simplex_category.{u} :=
λ X Y ⟨I⟩,
begin
  suffices : fintype.card (fin (X.len+1)) = fintype.card (fin (Y.len+1)),
  { ext, simpa },
  { apply fintype.card_congr,
    refine equiv.ulift.symm.trans (((skeletal_functor ⋙ forget _).map_iso I).to_equiv.trans _),
    apply equiv.ulift }
end

namespace skeletal_functor

instance : full skeletal_functor.{u v} :=
{ preimage := λ a b f, simplex_category.hom.mk ⟨λ i, (f (ulift.up i)).down, λ i j h, f.monotone h⟩,
  witness' := by { intros m n f, dsimp at *, ext1 ⟨i⟩, ext1, ext1, cases x, simp, } }

instance : faithful skeletal_functor.{u v} :=
{ map_injective' := λ m n f g h,
  begin
    ext1, ext1, ext1 i, apply ulift.up.inj,
    change (skeletal_functor.map f) ⟨i⟩ = (skeletal_functor.map g) ⟨i⟩,
    rw h,
  end }

instance : ess_surj skeletal_functor.{u v} :=
{ mem_ess_image := λ X, ⟨mk (fintype.card X - 1 : ℕ), ⟨begin
    have aux : fintype.card X = fintype.card X - 1 + 1,
    { exact (nat.succ_pred_eq_of_pos $ fintype.card_pos_iff.mpr ⟨⊥⟩).symm, },
    let f := mono_equiv_of_fin X aux,
    have hf := (finset.univ.order_emb_of_fin aux).strict_mono,
    refine
    { hom := ⟨λ i, f i.down, _⟩,
      inv := ⟨λ i, ⟨f.symm i⟩, _⟩,
      hom_inv_id' := _,
      inv_hom_id' := _ },
    { rintro ⟨i⟩ ⟨j⟩ h, show f i ≤ f j, exact hf.monotone h, },
    { intros i j h, show f.symm i ≤ f.symm j, rw ← hf.le_iff_le,
      show f (f.symm i) ≤ f (f.symm j), simpa only [order_iso.apply_symm_apply], },
    { ext1, ext1 ⟨i⟩, ext1, exact f.symm_apply_apply i },
    { ext1, ext1 i, exact f.apply_symm_apply i },
  end⟩⟩, }

noncomputable instance is_equivalence : is_equivalence skeletal_functor.{u v} :=
equivalence.of_fully_faithfully_ess_surj skeletal_functor

end skeletal_functor

/-- The equivalence that exhibits `simplex_category` as skeleton
of `NonemptyFinLinOrd` -/
noncomputable def skeletal_equivalence : simplex_category.{u} ≌ NonemptyFinLinOrd.{v} :=
functor.as_equivalence skeletal_functor

end skeleton

/--
`simplex_category` is a skeleton of `NonemptyFinLinOrd`.
-/
noncomputable
def is_skeleton_of : is_skeleton_of NonemptyFinLinOrd simplex_category skeletal_functor.{u v} :=
{ skel := skeletal,
  eqv := skeletal_functor.is_equivalence }

/-- The truncated simplex category. -/
@[derive small_category]
def truncated (n : ℕ) := {a : simplex_category.{u} // a.len ≤ n}

namespace truncated

instance {n} : inhabited (truncated n) := ⟨⟨[0],by simp⟩⟩

/--
The fully faithful inclusion of the truncated simplex category into the usual
simplex category.
-/
@[derive [full, faithful]]
def inclusion {n : ℕ} : simplex_category.truncated.{u} n ⥤ simplex_category.{u} :=
full_subcategory_inclusion _

end truncated

section concrete

instance : concrete_category.{0} simplex_category.{u} :=
{ forget :=
  { obj := λ i, fin (i.len + 1),
    map := λ i j f, f.to_preorder_hom },
  forget_faithful := {} }

end concrete

section epi_mono

/-- A morphism in `simplex_category` is a monomorphism precisely when it is an injective function
-/
theorem mono_iff_injective {n m : simplex_category.{u}} {f : n ⟶ m} :
  mono f ↔ function.injective f.to_preorder_hom :=
begin
  split,
  { introsI m x y h,
    have H : const n x ≫ f = const n y ≫ f,
    { dsimp, rw h },
    change (n.const x).to_preorder_hom 0 = (n.const y).to_preorder_hom 0,
    rw cancel_mono f at H,
    rw H },
  { exact concrete_category.mono_of_injective f }
end

/-- A morphism in `simplex_category` is an epimorphism if and only if it is a surjective function
-/
lemma epi_iff_surjective {n m : simplex_category.{u}} {f: n ⟶ m} :
  epi f ↔ function.surjective f.to_preorder_hom :=
begin
  split,
  { introsI hyp_f_epi x,
    by_contradiction h_ab,
    rw not_exists at h_ab,
    -- The proof is by contradiction: assume f is not surjective,
    -- then introduce two non-equal auxiliary functions equalizing f, and get a contradiction.
    -- First we define the two auxiliary functions.
    set chi_1 : m ⟶ [1] := hom.mk ⟨λ u, if u ≤ x then 0 else 1, begin
      intros a b h,
      dsimp only [],
      split_ifs with h1 h2 h3,
      any_goals { exact le_refl _ },
      { exact bot_le },
      { exact false.elim (h1 (le_trans h h3)) }
    end ⟩,
    set chi_2 : m ⟶ [1] := hom.mk ⟨λ u, if u < x then 0 else 1, begin
      intros a b h,
      dsimp only [],
      split_ifs with h1 h2 h3,
      any_goals { exact le_refl _ },
      { exact bot_le },
      { exact false.elim (h1 (lt_of_le_of_lt h h3)) }
    end ⟩,
    -- The two auxiliary functions equalize f
    have f_comp_chi_i : f ≫ chi_1 = f ≫ chi_2,
    { dsimp,
      ext,
      simp [le_iff_lt_or_eq, h_ab x_1] },
    -- We now just have to show the two auxiliary functions are not equal.
    rw category_theory.cancel_epi f at f_comp_chi_i, rename f_comp_chi_i eq_chi_i,
    apply_fun (λ e, e.to_preorder_hom x) at eq_chi_i,
    suffices : (0 : fin 2) = 1, by exact bot_ne_top this,
    simpa using eq_chi_i },
  { exact concrete_category.epi_of_surjective f }
end

/-- A monomorphism in `simplex_category` must increase lengths-/
lemma len_le_of_mono {x y : simplex_category.{u}} {f : x ⟶ y} :
  mono f → (x.len ≤ y.len) :=
begin
  intro hyp_f_mono,
  have f_inj : function.injective f.to_preorder_hom.to_fun,
  { exact mono_iff_injective.elim_left (hyp_f_mono) },
  simpa using fintype.card_le_of_injective f.to_preorder_hom.to_fun f_inj,
end

/-- An epimorphism in `simplex_category` must decrease lengths-/
lemma len_le_of_epi {x y : simplex_category.{u}} {f : x ⟶ y} :
  epi f → y.len ≤ x.len :=
begin
  intro hyp_f_epi,
  have f_surj : function.surjective f.to_preorder_hom.to_fun,
  { exact epi_iff_surjective.elim_left (hyp_f_epi) },
  simpa using fintype.card_le_of_surjective f.to_preorder_hom.to_fun f_surj,
end

lemma le_of_epi {n m : ℕ} {f : [n] ⟶ [m]} : epi f → (m ≤ n) :=
len_le_of_epi

end epi_mono

end simplex_category


/-
Copyright (c) 2020 Anatole Dedecker. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Anatole Dedecker
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.polynomial.ring_division
import Mathlib.linear_algebra.dimension
import Mathlib.algebra.polynomial.big_operators
import Mathlib.PostPort

universes u_1 l

namespace Mathlib

/-!
# Linear recurrence

Informally, a "linear recurrence" is an assertion of the form
`∀ n : ℕ, u (n + d) = a 0 * u n + a 1 * u (n+1) + ... + a (d-1) * u (n+d-1)`,
where `u` is a sequence, `d` is the *order* of the recurrence and the `a i`
are its *coefficients*.

In this file, we define the structure `linear_recurrence` so that
`linear_recurrence.mk d a` represents the above relation, and we call
a sequence `u` which verifies it a *solution* of the linear recurrence.

We prove a few basic lemmas about this concept, such as :

* the space of solutions is a submodule of `(ℕ → α)` (i.e a vector space if `α`
  is a field)
* the function that maps a solution `u` to its first `d` terms builds a `linear_equiv`
  between the solution space and `fin d → α`, aka `α ^ d`. As a consequence, two
  solutions are equal if and only if their first `d` terms are equals.
* a geometric sequence `q ^ n` is solution iff `q` is a root of a particular polynomial,
  which we call the *characteristic polynomial* of the recurrence

Of course, although we can inductively generate solutions (cf `mk_sol`), the
interesting part would be to determinate closed-forms for the solutions.
This is currently *not implemented*, as we are waiting for definition and
properties of eigenvalues and eigenvectors.

-/

/-- A "linear recurrence relation" over a commutative semiring is given by its
  order `n` and `n` coefficients. -/
structure linear_recurrence (α : Type u_1) [comm_semiring α]
where
  order : ℕ
  coeffs : fin order → α

protected instance linear_recurrence.inhabited (α : Type u_1) [comm_semiring α] : Inhabited (linear_recurrence α) :=
  { default := linear_recurrence.mk 0 Inhabited.default }

namespace linear_recurrence

/-- We say that a sequence `u` is solution of `linear_recurrence order coeffs` when we have
  `u (n + order) = ∑ i : fin order, coeffs i * u (n + i)` for any `n`. -/
def is_solution {α : Type u_1} [comm_semiring α] (E : linear_recurrence α) (u : ℕ → α) :=
  ∀ (n : ℕ), u (n + order E) = finset.sum finset.univ fun (i : fin (order E)) => coeffs E i * u (n + ↑i)

/-- A solution of a `linear_recurrence` which satisfies certain initial conditions.
  We will prove this is the only such solution. -/
def mk_sol {α : Type u_1} [comm_semiring α] (E : linear_recurrence α) (init : fin (order E) → α) : ℕ → α :=
  sorry

/-- `E.mk_sol` indeed gives solutions to `E`. -/
theorem is_sol_mk_sol {α : Type u_1} [comm_semiring α] (E : linear_recurrence α) (init : fin (order E) → α) : is_solution E (mk_sol α _inst_1 E init) := sorry

/-- `E.mk_sol init`'s first `E.order` terms are `init`. -/
theorem mk_sol_eq_init {α : Type u_1} [comm_semiring α] (E : linear_recurrence α) (init : fin (order E) → α) (n : fin (order E)) : mk_sol α _inst_1 E init ↑n = init n := sorry

/-- If `u` is a solution to `E` and `init` designates its first `E.order` values,
  then `∀ n, u n = E.mk_sol init n`. -/
theorem eq_mk_of_is_sol_of_eq_init {α : Type u_1} [comm_semiring α] (E : linear_recurrence α) {u : ℕ → α} {init : fin (order E) → α} (h : is_solution E u) (heq : ∀ (n : fin (order E)), u ↑n = init n) (n : ℕ) : u n = mk_sol α _inst_1 E init n := sorry

/-- If `u` is a solution to `E` and `init` designates its first `E.order` values,
  then `u = E.mk_sol init`. This proves that `E.mk_sol init` is the only solution
  of `E` whose first `E.order` values are given by `init`. -/
theorem eq_mk_of_is_sol_of_eq_init' {α : Type u_1} [comm_semiring α] (E : linear_recurrence α) {u : ℕ → α} {init : fin (order E) → α} (h : is_solution E u) (heq : ∀ (n : fin (order E)), u ↑n = init n) : u = mk_sol α _inst_1 E init :=
  funext (eq_mk_of_is_sol_of_eq_init α _inst_1 E (fun (x : ℕ) => u x) init h heq)

/-- The space of solutions of `E`, as a `submodule` over `α` of the semimodule `ℕ → α`. -/
def sol_space {α : Type u_1} [comm_semiring α] (E : linear_recurrence α) : submodule α (ℕ → α) :=
  submodule.mk (set_of fun (u : ℕ → α) => is_solution E u) sorry sorry sorry

/-- Defining property of the solution space : `u` is a solution
  iff it belongs to the solution space. -/
theorem is_sol_iff_mem_sol_space {α : Type u_1} [comm_semiring α] (E : linear_recurrence α) (u : ℕ → α) : is_solution E u ↔ u ∈ sol_space E :=
  iff.rfl

/-- The function that maps a solution `u` of `E` to its first
  `E.order` terms as a `linear_equiv`. -/
def to_init {α : Type u_1} [comm_semiring α] (E : linear_recurrence α) : linear_equiv α (↥(sol_space E)) (fin (order E) → α) :=
  linear_equiv.mk (fun (u : ↥(sol_space E)) (x : fin (order E)) => coe u ↑x) sorry sorry
    (fun (u : fin (order E) → α) => { val := mk_sol α _inst_1 E u, property := is_sol_mk_sol α _inst_1 E u }) sorry sorry

/-- Two solutions are equal iff they are equal on `range E.order`. -/
theorem sol_eq_of_eq_init {α : Type u_1} [comm_semiring α] (E : linear_recurrence α) (u : ℕ → α) (v : ℕ → α) (hu : is_solution E u) (hv : is_solution E v) : u = v ↔ set.eq_on u v ↑(finset.range (order E)) := sorry

/-! `E.tuple_succ` maps `![s₀, s₁, ..., sₙ]` to `![s₁, ..., sₙ, ∑ (E.coeffs i) * sᵢ]`,
  where `n := E.order`. This operation is quite useful for determining closed-form
  solutions of `E`. -/

/-- `E.tuple_succ` maps `![s₀, s₁, ..., sₙ]` to `![s₁, ..., sₙ, ∑ (E.coeffs i) * sᵢ]`,
  where `n := E.order`. -/
def tuple_succ {α : Type u_1} [comm_semiring α] (E : linear_recurrence α) : linear_map α (fin (order E) → α) (fin (order E) → α) :=
  linear_map.mk
    (fun (X : fin (order E) → α) (i : fin (order E)) =>
      dite (↑i + 1 < order E) (fun (h : ↑i + 1 < order E) => X { val := ↑i + 1, property := h })
        fun (h : ¬↑i + 1 < order E) => finset.sum finset.univ fun (i : fin (order E)) => coeffs E i * X i)
    sorry sorry

/-- The dimension of `E.sol_space` is `E.order`. -/
theorem sol_space_dim {α : Type u_1} [field α] (E : linear_recurrence α) : vector_space.dim α ↥(sol_space E) = ↑(order E) :=
  dim_fin_fun (order E) ▸ linear_equiv.dim_eq (to_init α comm_ring.to_comm_semiring E)

/-- The characteristic polynomial of `E` is
`X ^ E.order - ∑ i : fin E.order, (E.coeffs i) * X ^ i`. -/
def char_poly {α : Type u_1} [comm_ring α] (E : linear_recurrence α) : polynomial α :=
  coe_fn (polynomial.monomial (order E)) 1 -
    finset.sum finset.univ fun (i : fin (order E)) => coe_fn (polynomial.monomial ↑i) (coeffs E i)

/-- The geometric sequence `q^n` is a solution of `E` iff
  `q` is a root of `E`'s characteristic polynomial. -/
theorem geom_sol_iff_root_char_poly {α : Type u_1} [comm_ring α] (E : linear_recurrence α) (q : α) : (is_solution E fun (n : ℕ) => q ^ n) ↔ polynomial.is_root (char_poly E) q := sorry


import tactic
import data.nat.parity

example : ∃ (α : Type*) (P Q R : set α),
  (∀ x, P x → (Q x ∨ R x)) ∧ ¬ ((∀ x, P x → Q x) ∨ (∀ x, P x → R x)) :=
begin
  use [ℕ, set.univ, even, odd],
  split,
  { exact λ x _, nat.even_or_odd x },
  { push_neg,
    exact ⟨exists.intro 1 (by norm_num), exists.intro 0 (by norm_num)⟩ }
end


/-
Copyright (c) 2018 Reid Barton. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Reid Barton
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.topology.bases
import Mathlib.topology.dense_embedding
import Mathlib.PostPort

universes u u_1

namespace Mathlib

/-! # Stone-Čech compactification

Construction of the Stone-Čech compactification using ultrafilters.

Parts of the formalization are based on "Ultrafilters and Topology"
by Marius Stekelenburg, particularly section 5.
-/

/- The set of ultrafilters on α carries a natural topology which makes
  it the Stone-Čech compactification of α (viewed as a discrete space). -/

/-- Basis for the topology on `ultrafilter α`. -/
def ultrafilter_basis (α : Type u) : set (set (ultrafilter α)) :=
  set.range fun (s : set α) => set_of fun (u : ultrafilter α) => s ∈ u

protected instance ultrafilter.topological_space {α : Type u} : topological_space (ultrafilter α) :=
  topological_space.generate_from (ultrafilter_basis α)

theorem ultrafilter_basis_is_basis {α : Type u} :
    topological_space.is_topological_basis (ultrafilter_basis α) :=
  sorry

/-- The basic open sets for the topology on ultrafilters are open. -/
theorem ultrafilter_is_open_basic {α : Type u} (s : set α) :
    is_open (set_of fun (u : ultrafilter α) => s ∈ u) :=
  topological_space.is_open_of_is_topological_basis ultrafilter_basis_is_basis (Exists.intro s rfl)

/-- The basic open sets for the topology on ultrafilters are also closed. -/
theorem ultrafilter_is_closed_basic {α : Type u} (s : set α) :
    is_closed (set_of fun (u : ultrafilter α) => s ∈ u) :=
  sorry

/-- Every ultrafilter `u` on `ultrafilter α` converges to a unique
  point of `ultrafilter α`, namely `mjoin u`. -/
theorem ultrafilter_converges_iff {α : Type u} {u : ultrafilter (ultrafilter α)}
    {x : ultrafilter α} : ↑u ≤ nhds x ↔ x = mjoin u :=
  sorry

protected instance ultrafilter_compact {α : Type u} : compact_space (ultrafilter α) :=
  compact_space.mk
    (iff.mpr compact_iff_ultrafilter_le_nhds
      fun (f : ultrafilter (ultrafilter α)) (_x : ↑f ≤ filter.principal set.univ) =>
        Exists.intro (mjoin f) (Exists.intro trivial (iff.mpr ultrafilter_converges_iff rfl)))

protected instance ultrafilter.t2_space {α : Type u} : t2_space (ultrafilter α) :=
  iff.mpr t2_iff_ultrafilter
    fun (x y : ultrafilter α) (f : ultrafilter (ultrafilter α)) (fx : ↑f ≤ nhds x)
      (fy : ↑f ≤ nhds y) =>
      (fun (hx : x = mjoin f) =>
          (fun (hy : y = mjoin f) => Eq.trans hx (Eq.symm hy))
            (iff.mp ultrafilter_converges_iff fy))
        (iff.mp ultrafilter_converges_iff fx)

theorem ultrafilter_comap_pure_nhds {α : Type u} (b : ultrafilter α) :
    filter.comap pure (nhds b) ≤ ↑b :=
  sorry

theorem ultrafilter_pure_injective {α : Type u} : function.injective pure := sorry

/-- The range of `pure : α → ultrafilter α` is dense in `ultrafilter α`. -/
theorem dense_range_pure {α : Type u} : dense_range pure := sorry

/-- The map `pure : α → ultra_filter α` induces on `α` the discrete topology. -/
theorem induced_topology_pure {α : Type u} :
    topological_space.induced pure ultrafilter.topological_space = ⊥ :=
  sorry

/-- `pure : α → ultrafilter α` defines a dense inducing of `α` in `ultrafilter α`. -/
theorem dense_inducing_pure {α : Type u} : dense_inducing pure :=
  dense_inducing.mk (inducing.mk (Eq.symm induced_topology_pure)) dense_range_pure

-- The following refined version will never be used

/-- `pure : α → ultrafilter α` defines a dense embedding of `α` in `ultrafilter α`. -/
theorem dense_embedding_pure {α : Type u} : dense_embedding pure :=
  dense_embedding.mk
    (dense_inducing.mk (dense_inducing.to_inducing dense_inducing_pure)
      (dense_inducing.dense dense_inducing_pure))
    ultrafilter_pure_injective

/- Goal: Any function `α → γ` to a compact Hausdorff space `γ` has a
  unique extension to a continuous function `ultrafilter α → γ`. We
  already know it must be unique because `α → ultrafilter α` is a
  dense embedding and `γ` is Hausdorff. For existence, we will invoke
  `dense_embedding.continuous_extend`. -/

/-- The extension of a function `α → γ` to a function `ultrafilter α → γ`.
  When `γ` is a compact Hausdorff space it will be continuous. -/
def ultrafilter.extend {α : Type u} {γ : Type u_1} [topological_space γ] (f : α → γ) :
    ultrafilter α → γ :=
  dense_inducing.extend dense_inducing_pure f

theorem ultrafilter_extend_extends {α : Type u} {γ : Type u_1} [topological_space γ] [t2_space γ]
    (f : α → γ) : ultrafilter.extend f ∘ pure = f :=
  let _inst : topological_space α := ⊥;
  funext (dense_inducing.extend_eq dense_inducing_pure continuous_of_discrete_topology)

theorem continuous_ultrafilter_extend {α : Type u} {γ : Type u_1} [topological_space γ] [t2_space γ]
    [compact_space γ] (f : α → γ) : continuous (ultrafilter.extend f) :=
  sorry

/-- The value of `ultrafilter.extend f` on an ultrafilter `b` is the
  unique limit of the ultrafilter `b.map f` in `γ`. -/
theorem ultrafilter_extend_eq_iff {α : Type u} {γ : Type u_1} [topological_space γ] [t2_space γ]
    [compact_space γ] {f : α → γ} {b : ultrafilter α} {c : γ} :
    ultrafilter.extend f b = c ↔ ↑(ultrafilter.map f b) ≤ nhds c :=
  sorry

/- Now, we start with a (not necessarily discrete) topological space α
  and we want to construct its Stone-Čech compactification. We can
  build it as a quotient of `ultrafilter α` by the relation which
  identifies two points if the extension of every continuous function
  α → γ to a compact Hausdorff space sends the two points to the same
  point of γ. -/

protected instance stone_cech_setoid (α : Type u) [topological_space α] : setoid (ultrafilter α) :=
  setoid.mk
    (fun (x y : ultrafilter α) =>
      ∀ (γ : Type u) [_inst_2 : topological_space γ] [_inst_3 : t2_space γ]
        [_inst_4 : compact_space γ] (f : α → γ),
        continuous f → ultrafilter.extend f x = ultrafilter.extend f y)
    sorry

/-- The Stone-Čech compactification of a topological space. -/
def stone_cech (α : Type u) [topological_space α] := quotient (Mathlib.stone_cech_setoid α)

protected instance stone_cech.topological_space {α : Type u} [topological_space α] :
    topological_space (stone_cech α) :=
  eq.mpr sorry quotient.topological_space

protected instance stone_cech.inhabited {α : Type u} [topological_space α] [Inhabited α] :
    Inhabited (stone_cech α) :=
  eq.mpr sorry quotient.inhabited

/-- The natural map from α to its Stone-Čech compactification. -/
def stone_cech_unit {α : Type u} [topological_space α] (x : α) : stone_cech α :=
  quotient.mk (pure x)

/-- The image of stone_cech_unit is dense. (But stone_cech_unit need
  not be an embedding, for example if α is not Hausdorff.) -/
theorem dense_range_stone_cech_unit {α : Type u} [topological_space α] :
    dense_range stone_cech_unit :=
  dense_range.quotient dense_range_pure

/-- The extension of a continuous function from α to a compact
  Hausdorff space γ to the Stone-Čech compactification of α. -/
def stone_cech_extend {α : Type u} [topological_space α] {γ : Type u} [topological_space γ]
    [t2_space γ] [compact_space γ] {f : α → γ} (hf : continuous f) : stone_cech α → γ :=
  quotient.lift (ultrafilter.extend f) sorry

theorem stone_cech_extend_extends {α : Type u} [topological_space α] {γ : Type u}
    [topological_space γ] [t2_space γ] [compact_space γ] {f : α → γ} (hf : continuous f) :
    stone_cech_extend hf ∘ stone_cech_unit = f :=
  ultrafilter_extend_extends f

theorem continuous_stone_cech_extend {α : Type u} [topological_space α] {γ : Type u}
    [topological_space γ] [t2_space γ] [compact_space γ] {f : α → γ} (hf : continuous f) :
    continuous (stone_cech_extend hf) :=
  continuous_quot_lift (stone_cech_extend._proof_1 hf) (continuous_ultrafilter_extend f)

theorem convergent_eqv_pure {α : Type u} [topological_space α] {u : ultrafilter α} {x : α}
    (ux : ↑u ≤ nhds x) : u ≈ pure x :=
  sorry

theorem continuous_stone_cech_unit {α : Type u} [topological_space α] :
    continuous stone_cech_unit :=
  sorry

protected instance stone_cech.t2_space {α : Type u} [topological_space α] :
    t2_space (stone_cech α) :=
  sorry

protected instance stone_cech.compact_space {α : Type u} [topological_space α] :
    compact_space (stone_cech α) :=
  quotient.compact_space

end Mathlib


/-
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 ring_theory.polynomial.bernstein
! leanprover-community/mathlib commit bbeb185db4ccee8ed07dc48449414ebfa39cb821
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Data.Polynomial.Derivative
import Mathbin.Data.Nat.Choose.Sum
import Mathbin.RingTheory.Polynomial.Pochhammer
import Mathbin.Data.Polynomial.AlgebraMap
import Mathbin.LinearAlgebra.LinearIndependent
import Mathbin.Data.MvPolynomial.Pderiv

/-!
# Bernstein polynomials

The definition of the Bernstein polynomials
```
bernstein_polynomial (R : Type*) [comm_ring R] (n ν : ℕ) : R[X] :=
(choose n ν) * X^ν * (1 - X)^(n - ν)
```
and the fact that for `ν : fin (n+1)` these are linearly independent over `ℚ`.

We prove the basic identities
* `(finset.range (n + 1)).sum (λ ν, bernstein_polynomial R n ν) = 1`
* `(finset.range (n + 1)).sum (λ ν, ν • bernstein_polynomial R n ν) = n • X`
* `(finset.range (n + 1)).sum (λ ν, (ν * (ν-1)) • bernstein_polynomial R n ν) = (n * (n-1)) • X^2`

## Notes

See also `analysis.special_functions.bernstein`, which defines the Bernstein approximations
of a continuous function `f : C([0,1], ℝ)`, and shows that these converge uniformly to `f`.
-/

noncomputable section

open Nat (choose)

open Polynomial (X)

open BigOperators Polynomial

variable (R : Type _) [CommRing R]

/-- `bernstein_polynomial R n ν` is `(choose n ν) * X^ν * (1 - X)^(n - ν)`.

Although the coefficients are integers, it is convenient to work over an arbitrary commutative ring.
-/
def bernsteinPolynomial (n ν : ℕ) : R[X] :=
  choose n ν * X ^ ν * (1 - X) ^ (n - ν)
#align bernstein_polynomial bernsteinPolynomial

example : bernsteinPolynomial ℤ 3 2 = 3 * X ^ 2 - 3 * X ^ 3 :=
  by
  norm_num [bernsteinPolynomial, choose]
  ring

namespace bernsteinPolynomial

theorem eq_zero_of_lt {n ν : ℕ} (h : n < ν) : bernsteinPolynomial R n ν = 0 := by
  simp [bernsteinPolynomial, Nat.choose_eq_zero_of_lt h]
#align bernstein_polynomial.eq_zero_of_lt bernsteinPolynomial.eq_zero_of_lt

section

variable {R} {S : Type _} [CommRing S]

@[simp]
theorem map (f : R →+* S) (n ν : ℕ) :
    (bernsteinPolynomial R n ν).map f = bernsteinPolynomial S n ν := by simp [bernsteinPolynomial]
#align bernstein_polynomial.map bernsteinPolynomial.map

end

theorem flip (n ν : ℕ) (h : ν ≤ n) :
    (bernsteinPolynomial R n ν).comp (1 - X) = bernsteinPolynomial R n (n - ν) := by
  simp [bernsteinPolynomial, h, tsub_tsub_assoc, mul_right_comm]
#align bernstein_polynomial.flip bernsteinPolynomial.flip

theorem flip' (n ν : ℕ) (h : ν ≤ n) :
    bernsteinPolynomial R n ν = (bernsteinPolynomial R n (n - ν)).comp (1 - X) := by
  simp [← flip _ _ _ h, Polynomial.comp_assoc]
#align bernstein_polynomial.flip' bernsteinPolynomial.flip'

theorem eval_at_0 (n ν : ℕ) : (bernsteinPolynomial R n ν).eval 0 = if ν = 0 then 1 else 0 :=
  by
  rw [bernsteinPolynomial]
  split_ifs
  · subst h
    simp
  · simp [zero_pow (Nat.pos_of_ne_zero h)]
#align bernstein_polynomial.eval_at_0 bernsteinPolynomial.eval_at_0

theorem eval_at_1 (n ν : ℕ) : (bernsteinPolynomial R n ν).eval 1 = if ν = n then 1 else 0 :=
  by
  rw [bernsteinPolynomial]
  split_ifs
  · subst h
    simp
  · obtain w | w := (n - ν).eq_zero_or_pos
    · simp [Nat.choose_eq_zero_of_lt ((tsub_eq_zero_iff_le.mp w).lt_of_ne (Ne.symm h))]
    · simp [zero_pow w]
#align bernstein_polynomial.eval_at_1 bernsteinPolynomial.eval_at_1

theorem derivative_succ_aux (n ν : ℕ) :
    (bernsteinPolynomial R (n + 1) (ν + 1)).derivative =
      (n + 1) * (bernsteinPolynomial R n ν - bernsteinPolynomial R n (ν + 1)) :=
  by
  rw [bernsteinPolynomial]
  suffices
    ↑((n + 1).choose (ν + 1)) * (↑(ν + 1) * X ^ ν) * (1 - X) ^ (n - ν) -
        ↑((n + 1).choose (ν + 1)) * X ^ (ν + 1) * (↑(n - ν) * (1 - X) ^ (n - ν - 1)) =
      ↑(n + 1) *
        (↑(n.choose ν) * X ^ ν * (1 - X) ^ (n - ν) -
          ↑(n.choose (ν + 1)) * X ^ (ν + 1) * (1 - X) ^ (n - (ν + 1)))
    by
    simpa only [Polynomial.derivative_pow, ← sub_eq_add_neg, Nat.succ_sub_succ_eq_sub,
      Polynomial.derivative_mul, Polynomial.derivative_nat_cast, MulZeroClass.zero_mul,
      Nat.cast_add, algebraMap.coe_one, Polynomial.derivative_X, mul_one, zero_add,
      Polynomial.derivative_sub, Polynomial.derivative_one, zero_sub, mul_neg, Nat.sub_zero, ←
      Nat.cast_succ, Polynomial.C_eq_nat_cast]
  conv_rhs => rw [mul_sub]
  -- We'll prove the two terms match up separately.
  refine' congr (congr_arg Sub.sub _) _
  · simp only [← mul_assoc]
    refine' congr (congr_arg (· * ·) (congr (congr_arg (· * ·) _) rfl)) rfl
    -- Now it's just about binomial coefficients
    exact_mod_cast congr_arg (fun m : ℕ => (m : R[X])) (Nat.succ_mul_choose_eq n ν).symm
  · rw [← tsub_add_eq_tsub_tsub, ← mul_assoc, ← mul_assoc]
    congr 1
    rw [mul_comm, ← mul_assoc, ← mul_assoc]
    congr 1
    norm_cast
    congr 1
    convert(Nat.choose_mul_succ_eq n (ν + 1)).symm using 1
    · convert mul_comm _ _ using 2
      simp
    · apply mul_comm
#align bernstein_polynomial.derivative_succ_aux bernsteinPolynomial.derivative_succ_aux

theorem derivative_succ (n ν : ℕ) :
    (bernsteinPolynomial R n (ν + 1)).derivative =
      n * (bernsteinPolynomial R (n - 1) ν - bernsteinPolynomial R (n - 1) (ν + 1)) :=
  by
  cases n
  · simp [bernsteinPolynomial]
  · rw [Nat.cast_succ]
    apply derivative_succ_aux
#align bernstein_polynomial.derivative_succ bernsteinPolynomial.derivative_succ

theorem derivative_zero (n : ℕ) :
    (bernsteinPolynomial R n 0).derivative = -n * bernsteinPolynomial R (n - 1) 0 := by
  simp [bernsteinPolynomial, Polynomial.derivative_pow]
#align bernstein_polynomial.derivative_zero bernsteinPolynomial.derivative_zero

theorem iterate_derivative_at_0_eq_zero_of_lt (n : ℕ) {ν k : ℕ} :
    k < ν → ((Polynomial.derivative^[k]) (bernsteinPolynomial R n ν)).eval 0 = 0 :=
  by
  cases ν
  · rintro ⟨⟩
  · rw [Nat.lt_succ_iff]
    induction' k with k ih generalizing n ν
    · simp [eval_at_0]
    · simp only [derivative_succ, Int.coe_nat_eq_zero, mul_eq_zero, Function.comp_apply,
        Function.iterate_succ, Polynomial.iterate_derivative_sub,
        Polynomial.iterate_derivative_nat_cast_mul, Polynomial.eval_mul, Polynomial.eval_nat_cast,
        Polynomial.eval_sub]
      intro h
      apply mul_eq_zero_of_right
      rw [ih _ _ (Nat.le_of_succ_le h), sub_zero]
      convert ih _ _ (Nat.pred_le_pred h)
      exact (Nat.succ_pred_eq_of_pos (k.succ_pos.trans_le h)).symm
#align bernstein_polynomial.iterate_derivative_at_0_eq_zero_of_lt bernsteinPolynomial.iterate_derivative_at_0_eq_zero_of_lt

@[simp]
theorem iterate_derivative_succ_at_0_eq_zero (n ν : ℕ) :
    ((Polynomial.derivative^[ν]) (bernsteinPolynomial R n (ν + 1))).eval 0 = 0 :=
  iterate_derivative_at_0_eq_zero_of_lt R n (lt_add_one ν)
#align bernstein_polynomial.iterate_derivative_succ_at_0_eq_zero bernsteinPolynomial.iterate_derivative_succ_at_0_eq_zero

open Polynomial

@[simp]
theorem iterate_derivative_at_0 (n ν : ℕ) :
    ((Polynomial.derivative^[ν]) (bernsteinPolynomial R n ν)).eval 0 =
      (pochhammer R ν).eval (n - (ν - 1) : ℕ) :=
  by
  by_cases h : ν ≤ n
  · induction' ν with ν ih generalizing n h
    · simp [eval_at_0]
    · have h' : ν ≤ n - 1 := le_tsub_of_add_le_right h
      simp only [derivative_succ, ih (n - 1) h', iterate_derivative_succ_at_0_eq_zero,
        Nat.succ_sub_succ_eq_sub, tsub_zero, sub_zero, iterate_derivative_sub,
        iterate_derivative_nat_cast_mul, eval_one, eval_mul, eval_add, eval_sub, eval_X, eval_comp,
        eval_nat_cast, Function.comp_apply, Function.iterate_succ, pochhammer_succ_left]
      obtain rfl | h'' := ν.eq_zero_or_pos
      · simp
      · have : n - 1 - (ν - 1) = n - ν :=
          by
          rw [← Nat.succ_le_iff] at h''
          rw [← tsub_add_eq_tsub_tsub, add_comm, tsub_add_cancel_of_le h'']
        rw [this, pochhammer_eval_succ]
        rw_mod_cast [tsub_add_cancel_of_le (h'.trans n.pred_le)]
  · simp only [not_le] at h
    rw [tsub_eq_zero_iff_le.mpr (Nat.le_pred_of_lt h), eq_zero_of_lt R h]
    simp [pos_iff_ne_zero.mp (pos_of_gt h)]
#align bernstein_polynomial.iterate_derivative_at_0 bernsteinPolynomial.iterate_derivative_at_0

theorem iterate_derivative_at_0_ne_zero [CharZero R] (n ν : ℕ) (h : ν ≤ n) :
    ((Polynomial.derivative^[ν]) (bernsteinPolynomial R n ν)).eval 0 ≠ 0 :=
  by
  simp only [Int.coe_nat_eq_zero, bernsteinPolynomial.iterate_derivative_at_0, Ne.def,
    Nat.cast_eq_zero]
  simp only [← pochhammer_eval_cast]
  norm_cast
  apply ne_of_gt
  obtain rfl | h' := Nat.eq_zero_or_pos ν
  · simp
  · rw [← Nat.succ_pred_eq_of_pos h'] at h
    exact pochhammer_pos _ _ (tsub_pos_of_lt (Nat.lt_of_succ_le h))
#align bernstein_polynomial.iterate_derivative_at_0_ne_zero bernsteinPolynomial.iterate_derivative_at_0_ne_zero

/-!
Rather than redoing the work of evaluating the derivatives at 1,
we use the symmetry of the Bernstein polynomials.
-/

theorem iterate_derivative_at_1_eq_zero_of_lt (n : ℕ) {ν k : ℕ} :
    k < n - ν → ((Polynomial.derivative^[k]) (bernsteinPolynomial R n ν)).eval 1 = 0 :=
  by
  intro w
  rw [flip' _ _ _ (tsub_pos_iff_lt.mp (pos_of_gt w)).le]
  simp [Polynomial.eval_comp, iterate_derivative_at_0_eq_zero_of_lt R n w]
#align bernstein_polynomial.iterate_derivative_at_1_eq_zero_of_lt bernsteinPolynomial.iterate_derivative_at_1_eq_zero_of_lt

@[simp]
theorem iterate_derivative_at_1 (n ν : ℕ) (h : ν ≤ n) :
    ((Polynomial.derivative^[n - ν]) (bernsteinPolynomial R n ν)).eval 1 =
      (-1) ^ (n - ν) * (pochhammer R (n - ν)).eval (ν + 1) :=
  by
  rw [flip' _ _ _ h]
  simp [Polynomial.eval_comp, h]
  obtain rfl | h' := h.eq_or_lt
  · simp
  · congr
    norm_cast
    rw [← tsub_add_eq_tsub_tsub, tsub_tsub_cancel_of_le (nat.succ_le_iff.mpr h')]
#align bernstein_polynomial.iterate_derivative_at_1 bernsteinPolynomial.iterate_derivative_at_1

theorem iterate_derivative_at_1_ne_zero [CharZero R] (n ν : ℕ) (h : ν ≤ n) :
    ((Polynomial.derivative^[n - ν]) (bernsteinPolynomial R n ν)).eval 1 ≠ 0 :=
  by
  rw [bernsteinPolynomial.iterate_derivative_at_1 _ _ _ h, Ne.def, neg_one_pow_mul_eq_zero_iff, ←
    Nat.cast_succ, ← pochhammer_eval_cast, ← Nat.cast_zero, Nat.cast_inj]
  exact (pochhammer_pos _ _ (Nat.succ_pos ν)).ne'
#align bernstein_polynomial.iterate_derivative_at_1_ne_zero bernsteinPolynomial.iterate_derivative_at_1_ne_zero

open Submodule

theorem linearIndependent_aux (n k : ℕ) (h : k ≤ n + 1) :
    LinearIndependent ℚ fun ν : Fin k => bernsteinPolynomial ℚ n ν :=
  by
  induction' k with k ih
  · apply linearIndependent_empty_type
  · apply linear_independent_fin_succ'.mpr
    fconstructor
    · exact ih (le_of_lt h)
    · -- The actual work!
      -- We show that the (n-k)-th derivative at 1 doesn't vanish,
      -- but vanishes for everything in the span.
      clear ih
      simp only [Nat.succ_eq_add_one, add_le_add_iff_right] at h
      simp only [Fin.val_last, Fin.init_def]
      dsimp
      apply not_mem_span_of_apply_not_mem_span_image (@Polynomial.derivative ℚ _ ^ (n - k))
      simp only [not_exists, not_and, Submodule.mem_map, Submodule.span_image]
      intro p m
      apply_fun Polynomial.eval (1 : ℚ)
      simp only [LinearMap.pow_apply]
      -- The right hand side is nonzero,
      -- so it will suffice to show the left hand side is always zero.
      suffices ((Polynomial.derivative^[n - k]) p).eval 1 = 0
        by
        rw [this]
        exact (iterate_derivative_at_1_ne_zero ℚ n k h).symm
      apply span_induction m
      · simp
        rintro ⟨a, w⟩
        simp only [Fin.val_mk]
        rw [iterate_derivative_at_1_eq_zero_of_lt ℚ n ((tsub_lt_tsub_iff_left_of_le h).mpr w)]
      · simp
      · intro x y hx hy
        simp [hx, hy]
      · intro a x h
        simp [h]
#align bernstein_polynomial.linear_independent_aux bernsteinPolynomial.linearIndependent_aux

/-- The Bernstein polynomials are linearly independent.

We prove by induction that the collection of `bernstein_polynomial n ν` for `ν = 0, ..., k`
are linearly independent.
The inductive step relies on the observation that the `(n-k)`-th derivative, evaluated at 1,
annihilates `bernstein_polynomial n ν` for `ν < k`, but has a nonzero value at `ν = k`.
-/
theorem linearIndependent (n : ℕ) :
    LinearIndependent ℚ fun ν : Fin (n + 1) => bernsteinPolynomial ℚ n ν :=
  linearIndependent_aux n (n + 1) le_rfl
#align bernstein_polynomial.linear_independent bernsteinPolynomial.linearIndependent

theorem sum (n : ℕ) : (∑ ν in Finset.range (n + 1), bernsteinPolynomial R n ν) = 1 :=
  calc
    (∑ ν in Finset.range (n + 1), bernsteinPolynomial R n ν) = (X + (1 - X)) ^ n :=
      by
      rw [add_pow]
      simp only [bernsteinPolynomial, mul_comm, mul_assoc, mul_left_comm]
    _ = 1 := by simp

#align bernstein_polynomial.sum bernsteinPolynomial.sum

open Polynomial

open MvPolynomial

theorem sum_smul (n : ℕ) : (∑ ν in Finset.range (n + 1), ν • bernsteinPolynomial R n ν) = n • X :=
  by
  -- We calculate the `x`-derivative of `(x+y)^n`, evaluated at `y=(1-x)`,
  -- either directly or by using the binomial theorem.
  -- We'll work in `mv_polynomial bool R`.
  let x : MvPolynomial Bool R := MvPolynomial.X tt
  let y : MvPolynomial Bool R := MvPolynomial.X ff
  have pderiv_tt_x : pderiv tt x = 1 := by
    rw [pderiv_X]
    rfl
  have pderiv_tt_y : pderiv tt y = 0 := by
    rw [pderiv_X]
    rfl
  let e : Bool → R[X] := fun i => cond i X (1 - X)
  -- Start with `(x+y)^n = (x+y)^n`,
  -- take the `x`-derivative, evaluate at `x=X, y=1-X`, and multiply by `X`:
  trans aeval e (pderiv tt ((x + y) ^ n)) * X
  -- On the left hand side we'll use the binomial theorem, then simplify.
  · -- We first prepare a tedious rewrite:
    have w :
      ∀ k : ℕ,
        k • bernsteinPolynomial R n k =
          ↑k * Polynomial.X ^ (k - 1) * (1 - Polynomial.X) ^ (n - k) * ↑(n.choose k) *
            Polynomial.X :=
      by
      rintro (_ | k)
      · simp
      · rw [bernsteinPolynomial]
        simp only [← nat_cast_mul, Nat.succ_eq_add_one, Nat.add_succ_sub_one, add_zero, pow_succ]
        push_cast
        ring
    rw [add_pow, (pderiv tt).map_sum, (MvPolynomial.aeval e).map_sum, Finset.sum_mul]
    -- Step inside the sum:
    refine' Finset.sum_congr rfl fun k hk => (w k).trans _
    simp only [pderiv_tt_x, pderiv_tt_y, Algebra.id.smul_eq_mul, nsmul_eq_mul, e, Bool.cond_true,
      Bool.cond_false, add_zero, mul_one, MulZeroClass.mul_zero, smul_zero, MvPolynomial.aeval_X,
      MvPolynomial.pderiv_mul, Derivation.leibniz_pow, Derivation.map_coe_nat, map_natCast, map_pow,
      map_mul]
  · rw [(pderiv tt).leibniz_pow, (pderiv tt).map_add, pderiv_tt_x, pderiv_tt_y]
    simp only [Algebra.id.smul_eq_mul, nsmul_eq_mul, map_natCast, map_pow, map_add, map_mul, e,
      Bool.cond_true, Bool.cond_false, MvPolynomial.aeval_X, add_sub_cancel'_right, one_pow,
      add_zero, mul_one]
#align bernstein_polynomial.sum_smul bernsteinPolynomial.sum_smul

theorem sum_mul_smul (n : ℕ) :
    (∑ ν in Finset.range (n + 1), (ν * (ν - 1)) • bernsteinPolynomial R n ν) =
      (n * (n - 1)) • X ^ 2 :=
  by
  -- We calculate the second `x`-derivative of `(x+y)^n`, evaluated at `y=(1-x)`,
  -- either directly or by using the binomial theorem.
  -- We'll work in `mv_polynomial bool R`.
  let x : MvPolynomial Bool R := MvPolynomial.X tt
  let y : MvPolynomial Bool R := MvPolynomial.X ff
  have pderiv_tt_x : pderiv tt x = 1 := by
    rw [pderiv_X]
    rfl
  have pderiv_tt_y : pderiv tt y = 0 := by
    rw [pderiv_X]
    rfl
  let e : Bool → R[X] := fun i => cond i X (1 - X)
  -- Start with `(x+y)^n = (x+y)^n`,
  -- take the second `x`-derivative, evaluate at `x=X, y=1-X`, and multiply by `X`:
  trans aeval e (pderiv tt (pderiv tt ((x + y) ^ n))) * X ^ 2
  -- On the left hand side we'll use the binomial theorem, then simplify.
  · -- We first prepare a tedious rewrite:
    have w :
      ∀ k : ℕ,
        (k * (k - 1)) • bernsteinPolynomial R n k =
          ↑(n.choose k) *
              ((1 - Polynomial.X) ^ (n - k) * (↑k * (↑(k - 1) * Polynomial.X ^ (k - 1 - 1)))) *
            Polynomial.X ^ 2 :=
      by
      rintro (_ | _ | k)
      · simp
      · simp
      · rw [bernsteinPolynomial]
        simp only [← nat_cast_mul, Nat.succ_eq_add_one, Nat.add_succ_sub_one, add_zero, pow_succ]
        push_cast
        ring
    rw [add_pow, (pderiv tt).map_sum, (pderiv tt).map_sum, (MvPolynomial.aeval e).map_sum,
      Finset.sum_mul]
    -- Step inside the sum:
    refine' Finset.sum_congr rfl fun k hk => (w k).trans _
    simp only [pderiv_tt_x, pderiv_tt_y, Algebra.id.smul_eq_mul, nsmul_eq_mul, e, Bool.cond_true,
      Bool.cond_false, add_zero, zero_add, MulZeroClass.mul_zero, smul_zero, mul_one,
      MvPolynomial.aeval_X, MvPolynomial.pderiv_x_self, MvPolynomial.pderiv_x_of_ne,
      Derivation.leibniz_pow, Derivation.leibniz, Derivation.map_coe_nat, map_natCast, map_pow,
      map_mul, map_add]
  -- On the right hand side, we'll just simplify.
  ·
    simp only [pderiv_one, pderiv_mul, (pderiv _).leibniz_pow, (pderiv _).map_coe_nat,
      (pderiv tt).map_add, pderiv_tt_x, pderiv_tt_y, Algebra.id.smul_eq_mul, add_zero, mul_one,
      Derivation.map_smul_of_tower, map_nsmul, map_pow, map_add, e, Bool.cond_true, Bool.cond_false,
      MvPolynomial.aeval_X, add_sub_cancel'_right, one_pow, smul_smul, smul_one_mul]
#align bernstein_polynomial.sum_mul_smul bernsteinPolynomial.sum_mul_smul

/-- A certain linear combination of the previous three identities,
which we'll want later.
-/
theorem variance (n : ℕ) :
    (∑ ν in Finset.range (n + 1), (n • Polynomial.X - ν) ^ 2 * bernsteinPolynomial R n ν) =
      n • Polynomial.X * (1 - Polynomial.X) :=
  by
  have p :
    ((((Finset.range (n + 1)).Sum fun ν => (ν * (ν - 1)) • bernsteinPolynomial R n ν) +
          (1 - (2 * n) • Polynomial.X) *
            (Finset.range (n + 1)).Sum fun ν => ν • bernsteinPolynomial R n ν) +
        n ^ 2 • X ^ 2 * (Finset.range (n + 1)).Sum fun ν => bernsteinPolynomial R n ν) =
      _ :=
    rfl
  conv at p =>
    lhs
    rw [Finset.mul_sum, Finset.mul_sum, ← Finset.sum_add_distrib, ← Finset.sum_add_distrib]
    simp only [← nat_cast_mul]
    simp only [← mul_assoc]
    simp only [← add_mul]
  conv at p =>
    rhs
    rw [Sum, sum_smul, sum_mul_smul, ← nat_cast_mul]
  calc
    _ = _ := Finset.sum_congr rfl fun k m => _
    _ = _ := p
    _ = _ := _

  · congr 1
    simp only [← nat_cast_mul, push_cast]
    cases k <;>
      · simp
        ring
  · simp only [← nat_cast_mul, push_cast]
    cases n
    · simp
    · simp
      ring
#align bernstein_polynomial.variance bernsteinPolynomial.variance

end bernsteinPolynomial