/-
Copyright (c) 2021 Yury G. Kudryashov. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yury G. Kudryashov

! This file was ported from Lean 3 source module geometry.manifold.partition_of_unity
! leanprover-community/mathlib commit f2ce6086713c78a7f880485f7917ea547a215982
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Geometry.Manifold.Algebra.Structures
import Mathbin.Geometry.Manifold.BumpFunction
import Mathbin.Topology.MetricSpace.PartitionOfUnity
import Mathbin.Topology.ShrinkingLemma

/-!
# Smooth partition of unity

In this file we define two structures, `smooth_bump_covering` and `smooth_partition_of_unity`. Both
structures describe coverings of a set by a locally finite family of supports of smooth functions
with some additional properties. The former structure is mostly useful as an intermediate step in
the construction of a smooth partition of unity but some proofs that traditionally deal with a
partition of unity can use a `smooth_bump_covering` as well.

Given a real manifold `M` and its subset `s`, a `smooth_bump_covering ι I M s` is a collection of
`smooth_bump_function`s `f i` indexed by `i : ι` such that

* the center of each `f i` belongs to `s`;
* the family of sets `support (f i)` is locally finite;
* for each `x ∈ s`, there exists `i : ι` such that `f i =ᶠ[𝓝 x] 1`.
In the same settings, a `smooth_partition_of_unity ι I M s` is a collection of smooth nonnegative
functions `f i : C^∞⟮I, M; 𝓘(ℝ), ℝ⟯`, `i : ι`, such that

* the family of sets `support (f i)` is locally finite;
* for each `x ∈ s`, the sum `∑ᶠ i, f i x` equals one;
* for each `x`, the sum `∑ᶠ i, f i x` is less than or equal to one.

We say that `f : smooth_bump_covering ι I M s` is *subordinate* to a map `U : M → set M` if for each
index `i`, we have `tsupport (f i) ⊆ U (f i).c`. This notion is a bit more general than
being subordinate to an open covering of `M`, because we make no assumption about the way `U x`
depends on `x`.

We prove that on a smooth finitely dimensional real manifold with `σ`-compact Hausdorff topology,
for any `U : M → set M` such that `∀ x ∈ s, U x ∈ 𝓝 x` there exists a `smooth_bump_covering ι I M s`
subordinate to `U`. Then we use this fact to prove a similar statement about smooth partitions of
unity, see `smooth_partition_of_unity.exists_is_subordinate`.

Finally, we use existence of a partition of unity to prove lemma
`exists_smooth_forall_mem_convex_of_local` that allows us to construct a globally defined smooth
function from local functions.

## TODO

* Build a framework for to transfer local definitions to global using partition of unity and use it
  to define, e.g., the integral of a differential form over a manifold. Lemma
  `exists_smooth_forall_mem_convex_of_local` is a first step in this direction.

## Tags

smooth bump function, partition of unity
-/

universe uι uE uH uM uF

open Function Filter FiniteDimensional Set

open Topology Manifold Classical Filter BigOperators

noncomputable section

variable {ι : Type uι} {E : Type uE} [NormedAddCommGroup E] [NormedSpace ℝ E]
  [FiniteDimensional ℝ E] {F : Type uF} [NormedAddCommGroup F] [NormedSpace ℝ F] {H : Type uH}
  [TopologicalSpace H] (I : ModelWithCorners ℝ E H) {M : Type uM} [TopologicalSpace M]
  [ChartedSpace H M] [SmoothManifoldWithCorners I M]

/-!
### Covering by supports of smooth bump functions

In this section we define `smooth_bump_covering ι I M s` to be a collection of
`smooth_bump_function`s such that their supports is a locally finite family of sets and for each `x
∈ s` some function `f i` from the collection is equal to `1` in a neighborhood of `x`. A covering of
this type is useful to construct a smooth partition of unity and can be used instead of a partition
of unity in some proofs.

We prove that on a smooth finite dimensional real manifold with `σ`-compact Hausdorff topology, for
any `U : M → set M` such that `∀ x ∈ s, U x ∈ 𝓝 x` there exists a `smooth_bump_covering ι I M s`
subordinate to `U`. Then we use this fact to prove a version of the Whitney embedding theorem: any
compact real manifold can be embedded into `ℝ^n` for large enough `n`.  -/

variable (ι M)

/-- We say that a collection of `smooth_bump_function`s is a `smooth_bump_covering` of a set `s` if

* `(f i).c ∈ s` for all `i`;
* the family `λ i, support (f i)` is locally finite;
* for each point `x ∈ s` there exists `i` such that `f i =ᶠ[𝓝 x] 1`;
  in other words, `x` belongs to the interior of `{y | f i y = 1}`;

If `M` is a finite dimensional real manifold which is a `σ`-compact Hausdorff topological space,
then for every covering `U : M → set M`, `∀ x, U x ∈ 𝓝 x`, there exists a `smooth_bump_covering`
subordinate to `U`, see `smooth_bump_covering.exists_is_subordinate`.

This covering can be used, e.g., to construct a partition of unity and to prove the weak
Whitney embedding theorem. -/
@[nolint has_nonempty_instance]
structure SmoothBumpCovering (s : Set M := univ) where
  c : ι → M
  toFun : ∀ i, SmoothBumpFunction I (c i)
  c_mem' : ∀ i, c i ∈ s
  locally_finite' : LocallyFinite fun i => support (to_fun i)
  eventuallyEq_one' : ∀ x ∈ s, ∃ i, to_fun i =ᶠ[𝓝 x] 1
#align smooth_bump_covering SmoothBumpCovering

/-- We say that that a collection of functions form a smooth partition of unity on a set `s` if

* all functions are infinitely smooth and nonnegative;
* the family `λ i, support (f i)` is locally finite;
* for all `x ∈ s` the sum `∑ᶠ i, f i x` equals one;
* for all `x`, the sum `∑ᶠ i, f i x` is less than or equal to one. -/
structure SmoothPartitionOfUnity (s : Set M := univ) where
  toFun : ι → C^∞⟮I, M; 𝓘(ℝ), ℝ⟯
  locally_finite' : LocallyFinite fun i => support (to_fun i)
  nonneg' : ∀ i x, 0 ≤ to_fun i x
  sum_eq_one' : ∀ x ∈ s, (∑ᶠ i, to_fun i x) = 1
  sum_le_one' : ∀ x, (∑ᶠ i, to_fun i x) ≤ 1
#align smooth_partition_of_unity SmoothPartitionOfUnity

variable {ι I M}

namespace SmoothPartitionOfUnity

variable {s : Set M} (f : SmoothPartitionOfUnity ι I M s) {n : ℕ∞}

instance {s : Set M} : CoeFun (SmoothPartitionOfUnity ι I M s) fun _ => ι → C^∞⟮I, M; 𝓘(ℝ), ℝ⟯ :=
  ⟨SmoothPartitionOfUnity.toFun⟩

protected theorem locallyFinite : LocallyFinite fun i => support (f i) :=
  f.locally_finite'
#align smooth_partition_of_unity.locally_finite SmoothPartitionOfUnity.locallyFinite

theorem nonneg (i : ι) (x : M) : 0 ≤ f i x :=
  f.nonneg' i x
#align smooth_partition_of_unity.nonneg SmoothPartitionOfUnity.nonneg

theorem sum_eq_one {x} (hx : x ∈ s) : (∑ᶠ i, f i x) = 1 :=
  f.sum_eq_one' x hx
#align smooth_partition_of_unity.sum_eq_one SmoothPartitionOfUnity.sum_eq_one

theorem sum_le_one (x : M) : (∑ᶠ i, f i x) ≤ 1 :=
  f.sum_le_one' x
#align smooth_partition_of_unity.sum_le_one SmoothPartitionOfUnity.sum_le_one

/-- Reinterpret a smooth partition of unity as a continuous partition of unity. -/
def toPartitionOfUnity : PartitionOfUnity ι M s :=
  { f with toFun := fun i => f i }
#align smooth_partition_of_unity.to_partition_of_unity SmoothPartitionOfUnity.toPartitionOfUnity

theorem smooth_sum : Smooth I 𝓘(ℝ) fun x => ∑ᶠ i, f i x :=
  smooth_finsum (fun i => (f i).Smooth) f.LocallyFinite
#align smooth_partition_of_unity.smooth_sum SmoothPartitionOfUnity.smooth_sum

theorem le_one (i : ι) (x : M) : f i x ≤ 1 :=
  f.toPartitionOfUnity.le_one i x
#align smooth_partition_of_unity.le_one SmoothPartitionOfUnity.le_one

theorem sum_nonneg (x : M) : 0 ≤ ∑ᶠ i, f i x :=
  f.toPartitionOfUnity.sum_nonneg x
#align smooth_partition_of_unity.sum_nonneg SmoothPartitionOfUnity.sum_nonneg

theorem contMdiff_smul {g : M → F} {i} (hg : ∀ x ∈ tsupport (f i), ContMdiffAt I 𝓘(ℝ, F) n g x) :
    ContMdiff I 𝓘(ℝ, F) n fun x => f i x • g x :=
  contMdiff_of_support fun x hx =>
    ((f i).ContMdiff.ContMdiffAt.of_le le_top).smul <| hg x <| tsupport_smul_subset_left _ _ hx
#align smooth_partition_of_unity.cont_mdiff_smul SmoothPartitionOfUnity.contMdiff_smul

theorem smooth_smul {g : M → F} {i} (hg : ∀ x ∈ tsupport (f i), SmoothAt I 𝓘(ℝ, F) g x) :
    Smooth I 𝓘(ℝ, F) fun x => f i x • g x :=
  f.contMdiff_smul hg
#align smooth_partition_of_unity.smooth_smul SmoothPartitionOfUnity.smooth_smul

/-- If `f` is a smooth partition of unity on a set `s : set M` and `g : ι → M → F` is a family of
functions such that `g i` is $C^n$ smooth at every point of the topological support of `f i`, then
the sum `λ x, ∑ᶠ i, f i x • g i x` is smooth on the whole manifold. -/
theorem contMdiff_finsum_smul {g : ι → M → F}
    (hg : ∀ (i), ∀ x ∈ tsupport (f i), ContMdiffAt I 𝓘(ℝ, F) n (g i) x) :
    ContMdiff I 𝓘(ℝ, F) n fun x => ∑ᶠ i, f i x • g i x :=
  (contMdiff_finsum fun i => f.contMdiff_smul (hg i)) <|
    f.LocallyFinite.Subset fun i => support_smul_subset_left _ _
#align smooth_partition_of_unity.cont_mdiff_finsum_smul SmoothPartitionOfUnity.contMdiff_finsum_smul

/-- If `f` is a smooth partition of unity on a set `s : set M` and `g : ι → M → F` is a family of
functions such that `g i` is smooth at every point of the topological support of `f i`, then the sum
`λ x, ∑ᶠ i, f i x • g i x` is smooth on the whole manifold. -/
theorem smooth_finsum_smul {g : ι → M → F}
    (hg : ∀ (i), ∀ x ∈ tsupport (f i), SmoothAt I 𝓘(ℝ, F) (g i) x) :
    Smooth I 𝓘(ℝ, F) fun x => ∑ᶠ i, f i x • g i x :=
  f.contMdiff_finsum_smul hg
#align smooth_partition_of_unity.smooth_finsum_smul SmoothPartitionOfUnity.smooth_finsum_smul

theorem finsum_smul_mem_convex {g : ι → M → F} {t : Set F} {x : M} (hx : x ∈ s)
    (hg : ∀ i, f i x ≠ 0 → g i x ∈ t) (ht : Convex ℝ t) : (∑ᶠ i, f i x • g i x) ∈ t :=
  ht.finsum_mem (fun i => f.NonNeg _ _) (f.sum_eq_one hx) hg
#align smooth_partition_of_unity.finsum_smul_mem_convex SmoothPartitionOfUnity.finsum_smul_mem_convex

/-- A smooth partition of unity `f i` is subordinate to a family of sets `U i` indexed by the same
type if for each `i` the closure of the support of `f i` is a subset of `U i`. -/
def IsSubordinate (f : SmoothPartitionOfUnity ι I M s) (U : ι → Set M) :=
  ∀ i, tsupport (f i) ⊆ U i
#align smooth_partition_of_unity.is_subordinate SmoothPartitionOfUnity.IsSubordinate

variable {f} {U : ι → Set M}

@[simp]
theorem isSubordinate_toPartitionOfUnity :
    f.toPartitionOfUnity.IsSubordinate U ↔ f.IsSubordinate U :=
  Iff.rfl
#align smooth_partition_of_unity.is_subordinate_to_partition_of_unity SmoothPartitionOfUnity.isSubordinate_toPartitionOfUnity

alias is_subordinate_to_partition_of_unity ↔ _ is_subordinate.to_partition_of_unity
#align smooth_partition_of_unity.is_subordinate.to_partition_of_unity SmoothPartitionOfUnity.IsSubordinate.toPartitionOfUnity

/-- If `f` is a smooth partition of unity on a set `s : set M` subordinate to a family of open sets
`U : ι → set M` and `g : ι → M → F` is a family of functions such that `g i` is $C^n$ smooth on
`U i`, then the sum `λ x, ∑ᶠ i, f i x • g i x` is $C^n$ smooth on the whole manifold. -/
theorem IsSubordinate.contMdiff_finsum_smul {g : ι → M → F} (hf : f.IsSubordinate U)
    (ho : ∀ i, IsOpen (U i)) (hg : ∀ i, ContMdiffOn I 𝓘(ℝ, F) n (g i) (U i)) :
    ContMdiff I 𝓘(ℝ, F) n fun x => ∑ᶠ i, f i x • g i x :=
  f.contMdiff_finsum_smul fun i x hx => (hg i).ContMdiffAt <| (ho i).mem_nhds (hf i hx)
#align smooth_partition_of_unity.is_subordinate.cont_mdiff_finsum_smul SmoothPartitionOfUnity.IsSubordinate.contMdiff_finsum_smul

/-- If `f` is a smooth partition of unity on a set `s : set M` subordinate to a family of open sets
`U : ι → set M` and `g : ι → M → F` is a family of functions such that `g i` is smooth on `U i`,
then the sum `λ x, ∑ᶠ i, f i x • g i x` is smooth on the whole manifold. -/
theorem IsSubordinate.smooth_finsum_smul {g : ι → M → F} (hf : f.IsSubordinate U)
    (ho : ∀ i, IsOpen (U i)) (hg : ∀ i, SmoothOn I 𝓘(ℝ, F) (g i) (U i)) :
    Smooth I 𝓘(ℝ, F) fun x => ∑ᶠ i, f i x • g i x :=
  hf.contMdiff_finsum_smul ho hg
#align smooth_partition_of_unity.is_subordinate.smooth_finsum_smul SmoothPartitionOfUnity.IsSubordinate.smooth_finsum_smul

end SmoothPartitionOfUnity

namespace BumpCovering

-- Repeat variables to drop [finite_dimensional ℝ E] and [smooth_manifold_with_corners I M]
theorem smooth_toPartitionOfUnity {E : Type uE} [NormedAddCommGroup E] [NormedSpace ℝ E]
    {H : Type uH} [TopologicalSpace H] {I : ModelWithCorners ℝ E H} {M : Type uM}
    [TopologicalSpace M] [ChartedSpace H M] {s : Set M} (f : BumpCovering ι M s)
    (hf : ∀ i, Smooth I 𝓘(ℝ) (f i)) (i : ι) : Smooth I 𝓘(ℝ) (f.toPartitionOfUnity i) :=
  (hf i).mul <|
    (smooth_finprod_cond fun j _ => smooth_const.sub (hf j)) <|
      by
      simp only [mul_support_one_sub]
      exact f.locally_finite
#align bump_covering.smooth_to_partition_of_unity BumpCovering.smooth_toPartitionOfUnity

variable {s : Set M}

/-- A `bump_covering` such that all functions in this covering are smooth generates a smooth
partition of unity.

In our formalization, not every `f : bump_covering ι M s` with smooth functions `f i` is a
`smooth_bump_covering`; instead, a `smooth_bump_covering` is a covering by supports of
`smooth_bump_function`s. So, we define `bump_covering.to_smooth_partition_of_unity`, then reuse it
in `smooth_bump_covering.to_smooth_partition_of_unity`. -/
def toSmoothPartitionOfUnity (f : BumpCovering ι M s) (hf : ∀ i, Smooth I 𝓘(ℝ) (f i)) :
    SmoothPartitionOfUnity ι I M s :=
  { f.toPartitionOfUnity with
    toFun := fun i => ⟨f.toPartitionOfUnity i, f.smooth_toPartitionOfUnity hf i⟩ }
#align bump_covering.to_smooth_partition_of_unity BumpCovering.toSmoothPartitionOfUnity

@[simp]
theorem toSmoothPartitionOfUnity_toPartitionOfUnity (f : BumpCovering ι M s)
    (hf : ∀ i, Smooth I 𝓘(ℝ) (f i)) :
    (f.toSmoothPartitionOfUnity hf).toPartitionOfUnity = f.toPartitionOfUnity :=
  rfl
#align bump_covering.to_smooth_partition_of_unity_to_partition_of_unity BumpCovering.toSmoothPartitionOfUnity_toPartitionOfUnity

@[simp]
theorem coe_toSmoothPartitionOfUnity (f : BumpCovering ι M s) (hf : ∀ i, Smooth I 𝓘(ℝ) (f i))
    (i : ι) : ⇑(f.toSmoothPartitionOfUnity hf i) = f.toPartitionOfUnity i :=
  rfl
#align bump_covering.coe_to_smooth_partition_of_unity BumpCovering.coe_toSmoothPartitionOfUnity

theorem IsSubordinate.toSmoothPartitionOfUnity {f : BumpCovering ι M s} {U : ι → Set M}
    (h : f.IsSubordinate U) (hf : ∀ i, Smooth I 𝓘(ℝ) (f i)) :
    (f.toSmoothPartitionOfUnity hf).IsSubordinate U :=
  h.toPartitionOfUnity
#align bump_covering.is_subordinate.to_smooth_partition_of_unity BumpCovering.IsSubordinate.toSmoothPartitionOfUnity

end BumpCovering

namespace SmoothBumpCovering

variable {s : Set M} {U : M → Set M} (fs : SmoothBumpCovering ι I M s) {I}

instance : CoeFun (SmoothBumpCovering ι I M s) fun x => ∀ i : ι, SmoothBumpFunction I (x.c i) :=
  ⟨toFun⟩

@[simp]
theorem coe_mk (c : ι → M) (to_fun : ∀ i, SmoothBumpFunction I (c i)) (h₁ h₂ h₃) :
    ⇑(mk c to_fun h₁ h₂ h₃ : SmoothBumpCovering ι I M s) = to_fun :=
  rfl
#align smooth_bump_covering.coe_mk SmoothBumpCovering.coe_mk

/--
We say that `f : smooth_bump_covering ι I M s` is *subordinate* to a map `U : M → set M` if for each
index `i`, we have `tsupport (f i) ⊆ U (f i).c`. This notion is a bit more general than
being subordinate to an open covering of `M`, because we make no assumption about the way `U x`
depends on `x`.
-/
def IsSubordinate {s : Set M} (f : SmoothBumpCovering ι I M s) (U : M → Set M) :=
  ∀ i, tsupport (f i) ⊆ U (f.c i)
#align smooth_bump_covering.is_subordinate SmoothBumpCovering.IsSubordinate

theorem IsSubordinate.support_subset {fs : SmoothBumpCovering ι I M s} {U : M → Set M}
    (h : fs.IsSubordinate U) (i : ι) : support (fs i) ⊆ U (fs.c i) :=
  Subset.trans subset_closure (h i)
#align smooth_bump_covering.is_subordinate.support_subset SmoothBumpCovering.IsSubordinate.support_subset

variable (I)

/-- Let `M` be a smooth manifold with corners modelled on a finite dimensional real vector space.
Suppose also that `M` is a Hausdorff `σ`-compact topological space. Let `s` be a closed set
in `M` and `U : M → set M` be a collection of sets such that `U x ∈ 𝓝 x` for every `x ∈ s`.
Then there exists a smooth bump covering of `s` that is subordinate to `U`. -/
theorem exists_isSubordinate [T2Space M] [SigmaCompactSpace M] (hs : IsClosed s)
    (hU : ∀ x ∈ s, U x ∈ 𝓝 x) :
    ∃ (ι : Type uM)(f : SmoothBumpCovering ι I M s), f.IsSubordinate U :=
  by
  -- First we deduce some missing instances
  haveI : LocallyCompactSpace H := I.locally_compact
  haveI : LocallyCompactSpace M := ChartedSpace.locally_compact H M
  haveI : NormalSpace M := normal_of_paracompact_t2
  -- Next we choose a covering by supports of smooth bump functions
  have hB := fun x hx => SmoothBumpFunction.nhds_basis_support I (hU x hx)
  rcases refinement_of_locallyCompact_sigmaCompact_of_nhds_basis_set hs hB with
    ⟨ι, c, f, hf, hsub', hfin⟩
  choose hcs hfU using hf
  -- Then we use the shrinking lemma to get a covering by smaller open
  rcases exists_subset_unionᵢ_closed_subset hs (fun i => (f i).isOpen_support)
      (fun x hx => hfin.point_finite x) hsub' with
    ⟨V, hsV, hVc, hVf⟩
  choose r hrR hr using fun i => (f i).exists_r_pos_lt_subset_ball (hVc i) (hVf i)
  refine' ⟨ι, ⟨c, fun i => (f i).updateR (r i) (hrR i), hcs, _, fun x hx => _⟩, fun i => _⟩
  · simpa only [SmoothBumpFunction.support_updateR]
  · refine' (mem_Union.1 <| hsV hx).imp fun i hi => _
    exact
      ((f i).updateR _ _).eventuallyEq_one_of_dist_lt ((f i).support_subset_source <| hVf _ hi)
        (hr i hi).2
  · simpa only [coe_mk, SmoothBumpFunction.support_updateR, tsupport] using hfU i
#align smooth_bump_covering.exists_is_subordinate SmoothBumpCovering.exists_isSubordinate

variable {I M}

protected theorem locallyFinite : LocallyFinite fun i => support (fs i) :=
  fs.locally_finite'
#align smooth_bump_covering.locally_finite SmoothBumpCovering.locallyFinite

protected theorem point_finite (x : M) : { i | fs i x ≠ 0 }.Finite :=
  fs.LocallyFinite.point_finite x
#align smooth_bump_covering.point_finite SmoothBumpCovering.point_finite

theorem mem_chartAt_source_of_eq_one {i : ι} {x : M} (h : fs i x = 1) :
    x ∈ (chartAt H (fs.c i)).source :=
  (fs i).support_subset_source <| by simp [h]
#align smooth_bump_covering.mem_chart_at_source_of_eq_one SmoothBumpCovering.mem_chartAt_source_of_eq_one

theorem mem_extChartAt_source_of_eq_one {i : ι} {x : M} (h : fs i x = 1) :
    x ∈ (extChartAt I (fs.c i)).source :=
  by
  rw [extChartAt_source]
  exact fs.mem_chart_at_source_of_eq_one h
#align smooth_bump_covering.mem_ext_chart_at_source_of_eq_one SmoothBumpCovering.mem_extChartAt_source_of_eq_one

/-- Index of a bump function such that `fs i =ᶠ[𝓝 x] 1`. -/
def ind (x : M) (hx : x ∈ s) : ι :=
  (fs.eventuallyEq_one' x hx).some
#align smooth_bump_covering.ind SmoothBumpCovering.ind

theorem eventuallyEq_one (x : M) (hx : x ∈ s) : fs (fs.ind x hx) =ᶠ[𝓝 x] 1 :=
  (fs.eventuallyEq_one' x hx).choose_spec
#align smooth_bump_covering.eventually_eq_one SmoothBumpCovering.eventuallyEq_one

theorem apply_ind (x : M) (hx : x ∈ s) : fs (fs.ind x hx) x = 1 :=
  (fs.eventuallyEq_one x hx).eq_of_nhds
#align smooth_bump_covering.apply_ind SmoothBumpCovering.apply_ind

theorem mem_support_ind (x : M) (hx : x ∈ s) : x ∈ support (fs <| fs.ind x hx) := by
  simp [fs.apply_ind x hx]
#align smooth_bump_covering.mem_support_ind SmoothBumpCovering.mem_support_ind

theorem mem_chartAt_ind_source (x : M) (hx : x ∈ s) : x ∈ (chartAt H (fs.c (fs.ind x hx))).source :=
  fs.mem_chartAt_source_of_eq_one (fs.apply_ind x hx)
#align smooth_bump_covering.mem_chart_at_ind_source SmoothBumpCovering.mem_chartAt_ind_source

theorem mem_extChartAt_ind_source (x : M) (hx : x ∈ s) :
    x ∈ (extChartAt I (fs.c (fs.ind x hx))).source :=
  fs.mem_extChartAt_source_of_eq_one (fs.apply_ind x hx)
#align smooth_bump_covering.mem_ext_chart_at_ind_source SmoothBumpCovering.mem_extChartAt_ind_source

/-- The index type of a `smooth_bump_covering` of a compact manifold is finite. -/
protected def fintype [CompactSpace M] : Fintype ι :=
  fs.LocallyFinite.fintypeOfCompact fun i => (fs i).nonempty_support
#align smooth_bump_covering.fintype SmoothBumpCovering.fintype

variable [T2Space M]

/-- Reinterpret a `smooth_bump_covering` as a continuous `bump_covering`. Note that not every
`f : bump_covering ι M s` with smooth functions `f i` is a `smooth_bump_covering`. -/
def toBumpCovering : BumpCovering ι M s
    where
  toFun i := ⟨fs i, (fs i).Continuous⟩
  locally_finite' := fs.LocallyFinite
  nonneg' i x := (fs i).NonNeg
  le_one' i x := (fs i).le_one
  eventuallyEq_one' := fs.eventuallyEq_one'
#align smooth_bump_covering.to_bump_covering SmoothBumpCovering.toBumpCovering

@[simp]
theorem isSubordinate_toBumpCovering {f : SmoothBumpCovering ι I M s} {U : M → Set M} :
    (f.toBumpCovering.IsSubordinate fun i => U (f.c i)) ↔ f.IsSubordinate U :=
  Iff.rfl
#align smooth_bump_covering.is_subordinate_to_bump_covering SmoothBumpCovering.isSubordinate_toBumpCovering

alias is_subordinate_to_bump_covering ↔ _ is_subordinate.to_bump_covering
#align smooth_bump_covering.is_subordinate.to_bump_covering SmoothBumpCovering.IsSubordinate.toBumpCovering

/-- Every `smooth_bump_covering` defines a smooth partition of unity. -/
def toSmoothPartitionOfUnity : SmoothPartitionOfUnity ι I M s :=
  fs.toBumpCovering.toSmoothPartitionOfUnity fun i => (fs i).Smooth
#align smooth_bump_covering.to_smooth_partition_of_unity SmoothBumpCovering.toSmoothPartitionOfUnity

theorem toSmoothPartitionOfUnity_apply (i : ι) (x : M) :
    fs.toSmoothPartitionOfUnity i x = fs i x * ∏ᶠ (j) (hj : WellOrderingRel j i), 1 - fs j x :=
  rfl
#align smooth_bump_covering.to_smooth_partition_of_unity_apply SmoothBumpCovering.toSmoothPartitionOfUnity_apply

theorem toSmoothPartitionOfUnity_eq_mul_prod (i : ι) (x : M) (t : Finset ι)
    (ht : ∀ j, WellOrderingRel j i → fs j x ≠ 0 → j ∈ t) :
    fs.toSmoothPartitionOfUnity i x =
      fs i x * ∏ j in t.filterₓ fun j => WellOrderingRel j i, 1 - fs j x :=
  fs.toBumpCovering.toPartitionOfUnity_eq_mul_prod i x t ht
#align smooth_bump_covering.to_smooth_partition_of_unity_eq_mul_prod SmoothBumpCovering.toSmoothPartitionOfUnity_eq_mul_prod

theorem exists_finset_toSmoothPartitionOfUnity_eventuallyEq (i : ι) (x : M) :
    ∃ t : Finset ι,
      fs.toSmoothPartitionOfUnity i =ᶠ[𝓝 x]
        fs i * ∏ j in t.filterₓ fun j => WellOrderingRel j i, 1 - fs j :=
  fs.toBumpCovering.exists_finset_toPartitionOfUnity_eventuallyEq i x
#align smooth_bump_covering.exists_finset_to_smooth_partition_of_unity_eventually_eq SmoothBumpCovering.exists_finset_toSmoothPartitionOfUnity_eventuallyEq

theorem toSmoothPartitionOfUnity_zero_of_zero {i : ι} {x : M} (h : fs i x = 0) :
    fs.toSmoothPartitionOfUnity i x = 0 :=
  fs.toBumpCovering.toPartitionOfUnity_zero_of_zero h
#align smooth_bump_covering.to_smooth_partition_of_unity_zero_of_zero SmoothBumpCovering.toSmoothPartitionOfUnity_zero_of_zero

theorem support_toSmoothPartitionOfUnity_subset (i : ι) :
    support (fs.toSmoothPartitionOfUnity i) ⊆ support (fs i) :=
  fs.toBumpCovering.support_toPartitionOfUnity_subset i
#align smooth_bump_covering.support_to_smooth_partition_of_unity_subset SmoothBumpCovering.support_toSmoothPartitionOfUnity_subset

theorem IsSubordinate.toSmoothPartitionOfUnity {f : SmoothBumpCovering ι I M s} {U : M → Set M}
    (h : f.IsSubordinate U) : f.toSmoothPartitionOfUnity.IsSubordinate fun i => U (f.c i) :=
  h.toBumpCovering.toPartitionOfUnity
#align smooth_bump_covering.is_subordinate.to_smooth_partition_of_unity SmoothBumpCovering.IsSubordinate.toSmoothPartitionOfUnity

theorem sum_toSmoothPartitionOfUnity_eq (x : M) :
    (∑ᶠ i, fs.toSmoothPartitionOfUnity i x) = 1 - ∏ᶠ i, 1 - fs i x :=
  fs.toBumpCovering.sum_toPartitionOfUnity_eq x
#align smooth_bump_covering.sum_to_smooth_partition_of_unity_eq SmoothBumpCovering.sum_toSmoothPartitionOfUnity_eq

end SmoothBumpCovering

variable (I)

/-- Given two disjoint closed sets in a Hausdorff σ-compact finite dimensional manifold, there
exists an infinitely smooth function that is equal to `0` on one of them and is equal to one on the
other. -/
theorem exists_smooth_zero_one_of_closed [T2Space M] [SigmaCompactSpace M] {s t : Set M}
    (hs : IsClosed s) (ht : IsClosed t) (hd : Disjoint s t) :
    ∃ f : C^∞⟮I, M; 𝓘(ℝ), ℝ⟯, EqOn f 0 s ∧ EqOn f 1 t ∧ ∀ x, f x ∈ Icc (0 : ℝ) 1 :=
  by
  have : ∀ x ∈ t, sᶜ ∈ 𝓝 x := fun x hx => hs.is_open_compl.mem_nhds (disjoint_right.1 hd hx)
  rcases SmoothBumpCovering.exists_isSubordinate I ht this with ⟨ι, f, hf⟩
  set g := f.to_smooth_partition_of_unity
  refine'
    ⟨⟨_, g.smooth_sum⟩, fun x hx => _, fun x => g.sum_eq_one, fun x =>
      ⟨g.sum_nonneg x, g.sum_le_one x⟩⟩
  suffices ∀ i, g i x = 0 by simp only [this, ContMdiffMap.coeFn_mk, finsum_zero, Pi.zero_apply]
  refine' fun i => f.to_smooth_partition_of_unity_zero_of_zero _
  exact nmem_support.1 (subset_compl_comm.1 (hf.support_subset i) hx)
#align exists_smooth_zero_one_of_closed exists_smooth_zero_one_of_closed

namespace SmoothPartitionOfUnity

/-- A `smooth_partition_of_unity` that consists of a single function, uniformly equal to one,
defined as an example for `inhabited` instance. -/
def single (i : ι) (s : Set M) : SmoothPartitionOfUnity ι I M s :=
  (BumpCovering.single i s).toSmoothPartitionOfUnity fun j =>
    by
    rcases eq_or_ne j i with (rfl | h)
    · simp only [smooth_one, ContinuousMap.coe_one, BumpCovering.coe_single, Pi.single_eq_same]
    · simp only [smooth_zero, BumpCovering.coe_single, Pi.single_eq_of_ne h, ContinuousMap.coe_zero]
#align smooth_partition_of_unity.single SmoothPartitionOfUnity.single

instance [Inhabited ι] (s : Set M) : Inhabited (SmoothPartitionOfUnity ι I M s) :=
  ⟨single I default s⟩

variable [T2Space M] [SigmaCompactSpace M]

/-- If `X` is a paracompact normal topological space and `U` is an open covering of a closed set
`s`, then there exists a `bump_covering ι X s` that is subordinate to `U`. -/
theorem exists_isSubordinate {s : Set M} (hs : IsClosed s) (U : ι → Set M) (ho : ∀ i, IsOpen (U i))
    (hU : s ⊆ ⋃ i, U i) : ∃ f : SmoothPartitionOfUnity ι I M s, f.IsSubordinate U :=
  by
  haveI : LocallyCompactSpace H := I.locally_compact
  haveI : LocallyCompactSpace M := ChartedSpace.locally_compact H M
  haveI : NormalSpace M := normal_of_paracompact_t2
  rcases BumpCovering.exists_isSubordinate_of_prop (Smooth I 𝓘(ℝ)) _ hs U ho hU with ⟨f, hf, hfU⟩
  · exact ⟨f.to_smooth_partition_of_unity hf, hfU.to_smooth_partition_of_unity hf⟩
  · intro s t hs ht hd
    rcases exists_smooth_zero_one_of_closed I hs ht hd with ⟨f, hf⟩
    exact ⟨f, f.smooth, hf⟩
#align smooth_partition_of_unity.exists_is_subordinate SmoothPartitionOfUnity.exists_isSubordinate

end SmoothPartitionOfUnity

variable [SigmaCompactSpace M] [T2Space M] {t : M → Set F} {n : ℕ∞}

/-- Let `M` be a σ-compact Hausdorff finite dimensional topological manifold. Let `t : M → set F`
be a family of convex sets. Suppose that for each point `x : M` there exists a neighborhood
`U ∈ 𝓝 x` and a function `g : M → F` such that `g` is $C^n$ smooth on `U` and `g y ∈ t y` for all
`y ∈ U`. Then there exists a $C^n$ smooth function `g : C^∞⟮I, M; 𝓘(ℝ, F), F⟯` such that `g x ∈ t x`
for all `x`. See also `exists_smooth_forall_mem_convex_of_local` and
`exists_smooth_forall_mem_convex_of_local_const`. -/
theorem exists_cont_mdiff_forall_mem_convex_of_local (ht : ∀ x, Convex ℝ (t x))
    (Hloc : ∀ x : M, ∃ U ∈ 𝓝 x, ∃ g : M → F, ContMdiffOn I 𝓘(ℝ, F) n g U ∧ ∀ y ∈ U, g y ∈ t y) :
    ∃ g : C^n⟮I, M; 𝓘(ℝ, F), F⟯, ∀ x, g x ∈ t x :=
  by
  choose U hU g hgs hgt using Hloc
  obtain ⟨f, hf⟩ :=
    SmoothPartitionOfUnity.exists_isSubordinate I isClosed_univ (fun x => interior (U x))
      (fun x => isOpen_interior) fun x hx => mem_Union.2 ⟨x, mem_interior_iff_mem_nhds.2 (hU x)⟩
  refine'
    ⟨⟨fun x => ∑ᶠ i, f i x • g i x,
        hf.cont_mdiff_finsum_smul (fun i => isOpen_interior) fun i => (hgs i).mono interior_subset⟩,
      fun x => f.finsum_smul_mem_convex (mem_univ x) (fun i hi => hgt _ _ _) (ht _)⟩
  exact interior_subset (hf _ <| subset_closure hi)
#align exists_cont_mdiff_forall_mem_convex_of_local exists_cont_mdiff_forall_mem_convex_of_local

/-- Let `M` be a σ-compact Hausdorff finite dimensional topological manifold. Let `t : M → set F`
be a family of convex sets. Suppose that for each point `x : M` there exists a neighborhood
`U ∈ 𝓝 x` and a function `g : M → F` such that `g` is smooth on `U` and `g y ∈ t y` for all `y ∈ U`.
Then there exists a smooth function `g : C^∞⟮I, M; 𝓘(ℝ, F), F⟯` such that `g x ∈ t x` for all `x`.
See also `exists_cont_mdiff_forall_mem_convex_of_local` and
`exists_smooth_forall_mem_convex_of_local_const`. -/
theorem exists_smooth_forall_mem_convex_of_local (ht : ∀ x, Convex ℝ (t x))
    (Hloc : ∀ x : M, ∃ U ∈ 𝓝 x, ∃ g : M → F, SmoothOn I 𝓘(ℝ, F) g U ∧ ∀ y ∈ U, g y ∈ t y) :
    ∃ g : C^∞⟮I, M; 𝓘(ℝ, F), F⟯, ∀ x, g x ∈ t x :=
  exists_cont_mdiff_forall_mem_convex_of_local I ht Hloc
#align exists_smooth_forall_mem_convex_of_local exists_smooth_forall_mem_convex_of_local

/-- Let `M` be a σ-compact Hausdorff finite dimensional topological manifold. Let `t : M → set F` be
a family of convex sets. Suppose that for each point `x : M` there exists a vector `c : F` such that
for all `y` in a neighborhood of `x` we have `c ∈ t y`. Then there exists a smooth function
`g : C^∞⟮I, M; 𝓘(ℝ, F), F⟯` such that `g x ∈ t x` for all `x`.  See also
`exists_cont_mdiff_forall_mem_convex_of_local` and `exists_smooth_forall_mem_convex_of_local`. -/
theorem exists_smooth_forall_mem_convex_of_local_const (ht : ∀ x, Convex ℝ (t x))
    (Hloc : ∀ x : M, ∃ c : F, ∀ᶠ y in 𝓝 x, c ∈ t y) : ∃ g : C^∞⟮I, M; 𝓘(ℝ, F), F⟯, ∀ x, g x ∈ t x :=
  exists_smooth_forall_mem_convex_of_local I ht fun x =>
    let ⟨c, hc⟩ := Hloc x
    ⟨_, hc, fun _ => c, smoothOn_const, fun y => id⟩
#align exists_smooth_forall_mem_convex_of_local_const exists_smooth_forall_mem_convex_of_local_const

/-- Let `M` be a smooth σ-compact manifold with extended distance. Let `K : ι → set M` be a locally
finite family of closed sets, let `U : ι → set M` be a family of open sets such that `K i ⊆ U i` for
all `i`. Then there exists a positive smooth function `δ : M → ℝ≥0` such that for any `i` and
`x ∈ K i`, we have `emetric.closed_ball x (δ x) ⊆ U i`. -/
theorem Emetric.exists_smooth_forall_closedBall_subset {M} [EMetricSpace M] [ChartedSpace H M]
    [SmoothManifoldWithCorners I M] [SigmaCompactSpace M] {K : ι → Set M} {U : ι → Set M}
    (hK : ∀ i, IsClosed (K i)) (hU : ∀ i, IsOpen (U i)) (hKU : ∀ i, K i ⊆ U i)
    (hfin : LocallyFinite K) :
    ∃ δ : C^∞⟮I, M; 𝓘(ℝ, ℝ), ℝ⟯,
      (∀ x, 0 < δ x) ∧ ∀ (i), ∀ x ∈ K i, EMetric.closedBall x (ENNReal.ofReal (δ x)) ⊆ U i :=
  by
  simpa only [mem_inter_iff, forall_and, mem_preimage, mem_Inter, @forall_swap ι M] using
    exists_smooth_forall_mem_convex_of_local_const I Emetric.exists_forall_closedBall_subset_aux₂
      (Emetric.exists_forall_closedBall_subset_aux₁ hK hU hKU hfin)
#align emetric.exists_smooth_forall_closed_ball_subset Emetric.exists_smooth_forall_closedBall_subset

/-- Let `M` be a smooth σ-compact manifold with a metric. Let `K : ι → set M` be a locally finite
family of closed sets, let `U : ι → set M` be a family of open sets such that `K i ⊆ U i` for all
`i`. Then there exists a positive smooth function `δ : M → ℝ≥0` such that for any `i` and `x ∈ K i`,
we have `metric.closed_ball x (δ x) ⊆ U i`. -/
theorem Metric.exists_smooth_forall_closedBall_subset {M} [MetricSpace M] [ChartedSpace H M]
    [SmoothManifoldWithCorners I M] [SigmaCompactSpace M] {K : ι → Set M} {U : ι → Set M}
    (hK : ∀ i, IsClosed (K i)) (hU : ∀ i, IsOpen (U i)) (hKU : ∀ i, K i ⊆ U i)
    (hfin : LocallyFinite K) :
    ∃ δ : C^∞⟮I, M; 𝓘(ℝ, ℝ), ℝ⟯,
      (∀ x, 0 < δ x) ∧ ∀ (i), ∀ x ∈ K i, Metric.closedBall x (δ x) ⊆ U i :=
  by
  rcases Emetric.exists_smooth_forall_closedBall_subset I hK hU hKU hfin with ⟨δ, hδ0, hδ⟩
  refine' ⟨δ, hδ0, fun i x hx => _⟩
  rw [← Metric.emetric_closedBall (hδ0 _).le]
  exact hδ i x hx
#align metric.exists_smooth_forall_closed_ball_subset Metric.exists_smooth_forall_closedBall_subset


import GMLInit.Data.Equiv

class Find (α : Sort _) where
  find? : (α → Bool) → Option α
  find_some {p : α → Bool} (x : α) : find? p = some x → p x = true
  find_none {p : α → Bool} (x : α) : find? p = none → p x = false

namespace Find

theorem find_is_some_iff_exists_true {α} [Find α] (p : α → Bool) : (find? p).isSome ↔ ∃ x, p x = true := by
  constr
  · match hp : find? p with
    | some x =>
      intro
      exists x
      exact find_some x hp
    | none =>
      intro
      contradiction
  · intro
    | ⟨x, hx⟩ =>
      match hp : find? p with
      | some _ =>
        rfl
      | none =>
        rw [find_none x hp] at hx
        contradiction

theorem find_is_none_iff_forall_false {α} [Find α] (p : α → Bool) : (find? p).isNone ↔ ∀ x, p x = false := by
  constr
  · match hp : find? p with
    | some x =>
      intro _
      contradiction
    | none =>
      intro _ x
      exact find_none x hp
  · intro h
    match hp : find? p with
    | some x =>
      absurd find_some x hp
      rw [h]
      intro
      contradiction
    | none =>
      rfl

instance [Find α] [Nonempty α] : Inhabited α where
  default :=
    match h : find? (λ _ => true) with
    | some x => x
    | none => Bool.noConfusion $ show true = false by
      cases inferInstanceAs (Nonempty α) with
      | intro x => rw [←find_none x h]

protected def ofEquiv {α β} [Find α] (e : Equiv α β) : Find β where
  find? p :=
    match find? (λ x => p (e.fwd x)) with
    | some x => some (e.fwd x)
    | none => none
  find_some := by
    intro p x h
    clean at h
    split at h
    next h' =>
      cases h
      apply find_some _ h'
    next =>
      contradiction
  find_none := by
    intro p x h
    clean at h
    split at h
    next =>
      contradiction
    next h' =>
      rw [←e.fwd_rev x]
      apply find_none _ h'

-- instance {α} (xs : List α) : Find (Index xs) where
--   find? := Index.find?
--   find_some := Index.find_some
--   find_none := Index.find_none

-- instance (α) [Finite α] : Find α :=
--   Find.ofEquiv (Finite.equivIndex α).inv

instance [Find α] : Find (Option α) where
  find? p :=
    match p none with
    | true => some none
    | false => match find? (λ x => p (some x)) with
      | some x => some (some x)
      | none => none
  find_some := by intro
    | p, some x, h =>
      clean at h
      split at h;
      next => cases h
      next =>
        apply Find.find_some (p := λ x => p (some x))
        split at h
        next h => cases h; assumption
        next => cases h
    | p, none, h =>
      clean at h
      split at h
      next => assumption
      next =>
        split at h
        next => cases h
        next => cases h
  find_none := by intro
    | p, some x, h =>
      clean at h
      split at h
      next => cases h
      next =>
        split at h
        next => cases h
        next =>
          apply find_none (p := λ x => p (some x))
          assumption
    | p, none, h =>
      clean at h
      split at h
      next => cases h
      next h =>
        split at h
        next => cases h
        next => assumption

instance (α β) [Find α] [Find β] : Find (Sum α β) where
  find? p :=
    match find? (λ x => p (Sum.inl x)), find? (λ y => p (Sum.inr y)) with
    | some x, _ => some (Sum.inl x)
    | _, some y => some (Sum.inr y)
    | _, _ => none
  find_some := by intro
    | p, Sum.inl x, h =>
      clean at h
      split at h
      next =>
        cases h
        apply Find.find_some (p := λ x => p (Sum.inl x))
        assumption
      next => cases h
      next => cases h
    | p, Sum.inr y, h =>
      clean at h
      split at h
      next => cases h
      next =>
        cases h
        apply Find.find_some (p := λ y => p (Sum.inr y))
        assumption
      next h => cases h
  find_none := by intro
    | p, Sum.inl x, h =>
      clean at h
      split at h
      next => cases h
      next => cases h
      next h' _ =>
        apply Find.find_none (p := λ x => p (Sum.inl x))
        cases h: find? (λ x => p (Sum.inl x)) with
        | none => rfl
        | some x => absurd h' x; exact h
    | p, Sum.inr y, h =>
      clean at h
      split at h
      next => cases h
      next => cases h
      next _ h' =>
        apply Find.find_none (p := λ x => p (Sum.inr x))
        cases h: find? (λ x => p (Sum.inr x)) with
        | none => rfl
        | some x => absurd h' x; exact h

instance (α) [Find α] (C : α → Prop) [DecidablePred C] : Find { x : α // C x } where
  find? p :=
    match find? (λ x => if h: C x then p ⟨x,h⟩ else false) with
    | some x => if h: C x then some ⟨x,h⟩ else none
    | none => none
  find_some := by intro
    | p, ⟨x,hx⟩ =>
      intro h
      clean at h
      split at h
      next hsome =>
        have := find_some (p := λ x => if h: C x then p ⟨x,h⟩ else false) _ hsome
        split at h
        cases h
        next => simp [hx] at this; exact this
        next => contradiction
      next => contradiction
  find_none := by intro
    | p, ⟨x,hx⟩ =>
      intro h
      clean at h
      split at h
      next hsome =>
        have := find_some (p := λ x => if h: C x then p ⟨x,h⟩ else false) _ hsome
        split at h
        next => contradiction
        next hx' => simp [hx'] at this
      next hnone =>
        have := find_none (p := λ x => if h: C x then p ⟨x,h⟩ else false) x hnone
        simp [hx] at this
        exact this

instance (α) (β : α → Type _) [Find α] [(x : α) → Find (β x)] : Find ((x : α) × β x) where
  find? p :=
    match find? (λ x => Option.isSome (find? (λ y => p ⟨x,y⟩))) with
    | some x =>
      match find? (λ y => p ⟨x,y⟩) with
      | some y => some ⟨x,y⟩
      | none => none
    | none => none
  find_some := by intro
    | p, ⟨x,y⟩ =>
      intro h
      clean at h
      split at h
      next hsome₁ =>
        clean at h
        split at h
        next hsome₂ =>
          cases h
          apply find_some (p := λ y => p ⟨x,y⟩)
          exact hsome₂
        next => contradiction
      next => contradiction
  find_none := by intro
    | p, ⟨x,y⟩ =>
      intro h
      clean at h
      split at h
      next x' hsome₁ =>
        have := find_some _ hsome₁
        clean at h
        split at h
        next => contradiction
        next hnone₂ =>
          rw [hnone₂] at this
          contradiction
      next hnone₁ =>
        have := find_none x hnone₁
        apply find_none (p := λ y => p ⟨x,y⟩)
        cases hy: find? (λ y => p ⟨x,y⟩) with
        | none => rfl
        | some _ =>
          rw [hy] at this
          contradiction

instance (α β) [Find α] [Find β] : Find (α × β) :=
  Find.ofEquiv (Sigma.equivProd α β).inv

instance (α) (r : α → α → Prop) [Find α] : Find (Quot r) where
  find? p :=
    match find? (λ x => p (Quot.mk r x)) with
    | some x => some (Quot.mk r x)
    | none => none
  find_some := by intro
    | p, x, h =>
      induction x using Quot.ind with
      | mk x =>
        clean at h
        split at h
        next =>
          injection h with h
          rw [←h]
          apply Find.find_some (p := λ x => p (Quot.mk r x))
          assumption
        next => cases h
  find_none := by intro
    | p, x, h =>
      induction x using Quot.ind with
      | mk x =>
        clean at h
        split at h
        next => cases h
        next =>
          apply Find.find_none (p := λ x => p (Quot.mk r x))
          assumption

instance (α) (s : Setoid α) [Find α] : Find (Quotient s) :=
  inferInstanceAs (Find (Quot s.r))

end Find


/-
Copyright (c) 2018 Bruno Bentzen. All rights reserved.
Released under the Apache License 2.0 (see "License");
Author: Bruno Bentzen
-/

import .syntax.lemmas .semantics.lemmas

variable {σ : nat}

/- soundness -/

theorem sndnss {Γ : ctx σ} {p : form σ} :
  (Γ ⊢ₛ₅ p) → (Γ ⊨ₛ₅ p) :=
begin
  intro h,
  induction h,
  { apply sem_csq.is_true,
    intros, apply ctx_tt_to_mem_tt,
    repeat {assumption} },

  { apply sem_csq.is_true,
    intros M w wmem ctt,
    apply is_true_pl1 },

  { apply sem_csq.is_true,
    intros M w wmem ctt,
    apply is_true_pl2 },

  { apply sem_csq.is_true,
    intros M w wmem ctt,
    apply is_true_pl3 },

    { apply sem_csq.is_true,
      induction h_ih_hpq,
      induction h_ih_hp,
      intros M w wmem ctt,
      revert h_ih_hpq,
      unfold forces_form, simp,
      intro hpq,
      cases (hpq M w wmem ctt),
      { assumption },
      { exfalso,
        apply tt_eq_ff_eq_false,
        rw eq.symm (h_ih_hp M w wmem ctt),
        assumption } },

    { apply sem_csq.is_true,
      intros M w wmem ctt,
      apply is_true_k },

    { apply sem_csq.is_true,
      intros M w wmem ctt,
      apply is_true_t,
      repeat {assumption} },

    { apply sem_csq.is_true,
      intros M w wmem ctt,
      apply is_true_s4 },

    { apply sem_csq.is_true,
      intros M w wmem ctt,
      apply is_true_b },

    { apply sem_csq.is_true,
      intros M w wmem ctt,
      unfold forces_form, simp,
      induction h_ih,
      intros v vmem wmem rwv,
      apply h_ih, assumption,
      apply empty_ctx_tt }
end


import data.setoid.partition
import group_theory.quotient_group

namespace chapter1.section3

variables {α β : Type*} (f : α → β)

-- #check @quotient α (setoid.ker f)
-- #check monoid_hom.ker
-- #check setoid.ker
-- #check set.range
-- #check setoid.quotient_ker_equiv_range

-- #check setoid.quotient_quotient_equiv_quotient

-- 命题 3-1
-- #check setoid.partition.order_iso
-- #check subtype
-- #check setoid.mk_classes

def my_setoid_ker {α : Type*} {β : Type*} (f : α → β) : setoid α := {
  r := λ x y, f x = f y,
  iseqv := begin
    refine ⟨_,_,_⟩,
    {
      intro x,
      refl,
    },
    {
      intros x y h,
      exact h.symm,
    },
    {
      intros x y z hxy hyz,
      rw hxy,
      rw hyz,
    }
  end
}

def function_to_image (f : α → β):  α → {x // x ∈ set.range f} := λ x , ⟨f x, set.mem_range_self x⟩

-- theorem tendsto_def {a : ℕ → ℝ} {t : ℝ} :
--   tendsto a t ↔ ∀ ε, 0 < ε → ∃ B : ℕ, ∀ n, B ≤ n → |a n - t| < ε :=
-- begin
--   -- true by definition
--   refl
-- end

-- #check @quotient.sound _ (setoid.ker f)
noncomputable def my_quotient_ker_equiv_range : @quotient α (@setoid.ker α β f) ≃ set.range f :=
begin
  refine equiv.of_bijective (λ k , @quotient.lift _ _ (setoid.ker f) (function_to_image f) (λ a b h , subtype.ext_val h) k)  _,
  dunfold function_to_image setoid.ker function.on_fun quotient.lift,
  split,
  {
    intros x y h,
    dsimp at *,
    rcases x,
    rcases y,
    dsimp at h,
    injection h,
    apply quot.sound,
    unfold_projs,
    assumption,
  },
  {
    rintro ⟨y, z, rfl⟩,
    dsimp,
    use @quotient.mk _ (setoid.ker f) z,
    dunfold setoid.ker function.on_fun quotient.mk,
    dsimp,
    refl,
  }
end

-- #check setoid.comap
-- #check setoid.comap_quotient_equiv
noncomputable def my_setoid_comap_quotient_equiv (f : α → β) (r : setoid β) :
  @quotient α (setoid.comap f r) ≃ set.range (@quotient.mk _ r ∘ f) :=
begin
  symmetry,
  apply (setoid.quotient_ker_equiv_range (quotient.mk ∘ f)).symm.trans,
  dunfold setoid.ker function.on_fun function.comp setoid.comap setoid.rel,
  apply quotient.congr_right,
  unfold_projs,
  dsimp,
  intros a b,
  finish,
end

-- #check quot
-- #check setoid.quotient_quotient_equiv_quotient
def my_quotient_quotient_equiv_quotient (r s : setoid α) (h : r ≤ s) :
  quotient (@setoid.ker (@quot α r.rel) (@quot α s.rel) (quot.map_right h)) ≃ @quotient α s :=
  begin
    dunfold has_le.le at h,
    dunfold setoid.ker function.on_fun quot.map_right,
    -- refine ⟨_,_,_,_⟩,
    -- {
    -- }
    sorry,
  end

end chapter1.section3


/- Spatial Reasoning Problem 04 -/
/- it can be found at: SpatialQs.txt -/

/- (4) John is carrying a vase.  There is a flower in the vase.  Is John carrying a flower?-/

constant U : Type

constants John Inside Carrying Flower Container Transfer On : U
constant objectTransferred : U → U → Prop
constant orientation : U → U → U → Prop
constant subclass : U → U → Prop
constant agent : U → U → Prop
constant ins : U → U → Prop

/- axioms from SUMO -/
axiom a1 : ∀ VAR1 VAR2 VAR3, (orientation VAR2 VAR1 Inside)
    ∧ (objectTransferred VAR3 VAR1) ∧ (ins VAR3 Transfer)
    → (objectTransferred VAR3 VAR2)
axiom a2 : subclass Carrying Transfer
axiom a3 : ∀ X Y Z, (subclass X Y) ∧ (ins Z X) → (ins Z Y)

/- axioms from problem -/
axiom a4 : ∃ C V F, (ins C Carrying) ∧ (objectTransferred C V)
    ∧ (agent C John) ∧ (ins F Flower) ∧ (ins V Container)
    ∧ (orientation F V Inside)

/- axioms to be added to SUMO -/
axiom a5 : ∀ T O O2, (ins T Transfer) ∧ (objectTransferred T O)
    ∧ (orientation O2 O Inside) → (objectTransferred T O2)
axiom a6 : ∀ T O O2, (ins T Transfer) ∧ (objectTransferred T O)
    ∧ (orientation O O2 On) → (objectTransferred T O2)

/- demonstration start -/
theorem john_is_carrying_a_flower : ∃ C F, (ins C Carrying)
∧ (agent C John) ∧ (ins F Flower) ∧ (objectTransferred C F) :=
begin
    apply exists.elim a4, assume C r1,
    apply exists.elim r1, assume V r2,
    apply exists.elim r2, assume F h,
    have h1, from h.left,
    have h2, from h.right.right.left,
    have h3, from h.right.right.right.left,

    have s1, from (a3 _ _ _) ⟨a2,h1⟩,
    have s2, from h.right.left,
    have s3, from h.right.right.right.right.right,
    have h4, from (a5 _ _ _) ⟨s1,⟨s2,s3⟩⟩,

    have h5 : ∃ F, ins C Carrying ∧ agent C John
        ∧ ins F Flower ∧ objectTransferred C F,
        from exists.intro F ⟨h1,⟨h2,⟨h3,h4⟩⟩⟩,
    have h6 : ∃ C F, ins C Carrying ∧ agent C John
        ∧ ins F Flower ∧ objectTransferred C F,
        from exists.intro C h5,

    assumption
end


/-
Copyright (c) 2021 Sébastien Gouëzel. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Sébastien Gouëzel
-/
import analysis.analytic.composition

/-!

# Inverse of analytic functions

We construct the left and right inverse of a formal multilinear series with invertible linear term,
we prove that they coincide and study their properties (notably convergence).

## Main statements

* `p.left_inv i`: the formal left inverse of the formal multilinear series `p`,
  for `i : E ≃L[𝕜] F` which coincides with `p₁`.
* `p.right_inv i`: the formal right inverse of the formal multilinear series `p`,
  for `i : E ≃L[𝕜] F` which coincides with `p₁`.
* `p.left_inv_comp` says that `p.left_inv i` is indeed a left inverse to `p` when `p₁ = i`.
* `p.right_inv_comp` says that `p.right_inv i` is indeed a right inverse to `p` when `p₁ = i`.
* `p.left_inv_eq_right_inv`: the two inverses coincide.
* `p.radius_right_inv_pos_of_radius_pos`: if a power series has a positive radius of convergence,
  then so does its inverse.

-/

open_locale big_operators classical topological_space
open finset filter

namespace formal_multilinear_series

variables {𝕜 : Type*} [nondiscrete_normed_field 𝕜]
{E : Type*} [normed_group E] [normed_space 𝕜 E]
{F : Type*} [normed_group F] [normed_space 𝕜 F]

/-! ### The left inverse of a formal multilinear series -/

/-- The left inverse of a formal multilinear series, where the `n`-th term is defined inductively
in terms of the previous ones to make sure that `(left_inv p i) ∘ p = id`. For this, the linear term
`p₁` in `p` should be invertible. In the definition, `i` is a linear isomorphism that should
coincide with `p₁`, so that one can use its inverse in the construction. The definition does not
use that `i = p₁`, but proofs that the definition is well-behaved do.

The `n`-th term in `q ∘ p` is `∑ qₖ (p_{j₁}, ..., p_{jₖ})` over `j₁ + ... + jₖ = n`. In this
expression, `qₙ` appears only once, in `qₙ (p₁, ..., p₁)`. We adjust the definition so that this
term compensates the rest of the sum, using `i⁻¹` as an inverse to `p₁`.

These formulas only make sense when the constant term `p₀` vanishes. The definition we give is
general, but it ignores the value of `p₀`.
-/
noncomputable def left_inv (p : formal_multilinear_series 𝕜 E F) (i : E ≃L[𝕜] F) :
  formal_multilinear_series 𝕜 F E
| 0     := 0
| 1     := (continuous_multilinear_curry_fin1 𝕜 F E).symm i.symm
| (n+2) := - ∑ c : {c : composition (n+2) // c.length < n + 2},
      have (c : composition (n+2)).length < n+2 := c.2,
      (left_inv (c : composition (n+2)).length).comp_along_composition
        (p.comp_continuous_linear_map i.symm) c

@[simp] lemma left_inv_coeff_zero (p : formal_multilinear_series 𝕜 E F) (i : E ≃L[𝕜] F) :
  p.left_inv i 0 = 0 := by rw left_inv

@[simp] lemma left_inv_coeff_one (p : formal_multilinear_series 𝕜 E F) (i : E ≃L[𝕜] F) :
  p.left_inv i 1 = (continuous_multilinear_curry_fin1 𝕜 F E).symm i.symm := by rw left_inv

/-- The left inverse does not depend on the zeroth coefficient of a formal multilinear
series. -/
lemma left_inv_remove_zero (p : formal_multilinear_series 𝕜 E F) (i : E ≃L[𝕜] F) :
  p.remove_zero.left_inv i = p.left_inv i :=
begin
  ext1 n,
  induction n using nat.strong_rec' with n IH,
  cases n, { simp }, -- if one replaces `simp` with `refl`, the proof times out in the kernel.
  cases n, { simp }, -- TODO: why?
  simp only [left_inv, neg_inj],
  refine finset.sum_congr rfl (λ c cuniv, _),
  rcases c with ⟨c, hc⟩,
  ext v,
  dsimp,
  simp [IH _ hc],
end

/-- The left inverse to a formal multilinear series is indeed a left inverse, provided its linear
term is invertible. -/
lemma left_inv_comp (p : formal_multilinear_series 𝕜 E F) (i : E ≃L[𝕜] F)
  (h : p 1 = (continuous_multilinear_curry_fin1 𝕜 E F).symm i) :
  (left_inv p i).comp p = id 𝕜 E :=
begin
  ext n v,
  cases n,
  { simp only [left_inv, continuous_multilinear_map.zero_apply, id_apply_ne_one, ne.def,
      not_false_iff, zero_ne_one, comp_coeff_zero']},
  cases n,
  { simp only [left_inv, comp_coeff_one, h, id_apply_one, continuous_linear_equiv.coe_apply,
      continuous_linear_equiv.symm_apply_apply, continuous_multilinear_curry_fin1_symm_apply] },
  have A : (finset.univ : finset (composition (n+2)))
    = {c | composition.length c < n + 2}.to_finset ∪ {composition.ones (n+2)},
  { refine subset.antisymm (λ c hc, _) (subset_univ _),
    by_cases h : c.length < n + 2,
    { simp [h] },
    { simp [composition.eq_ones_iff_le_length.2 (not_lt.1 h)] } },
  have B : disjoint ({c | composition.length c < n + 2} : set (composition (n + 2))).to_finset
    {composition.ones (n+2)}, by simp,
  have C : (p.left_inv i (composition.ones (n + 2)).length)
    (λ (j : fin (composition.ones n.succ.succ).length), p 1 (λ k,
      v ((fin.cast_le (composition.length_le _)) j)))
    = p.left_inv i (n+2) (λ (j : fin (n+2)), p 1 (λ k, v j)),
  { apply formal_multilinear_series.congr _ (composition.ones_length _) (λ j hj1 hj2, _),
    exact formal_multilinear_series.congr _ rfl (λ k hk1 hk2, by congr) },
  have D : p.left_inv i (n+2) (λ (j : fin (n+2)), p 1 (λ k, v j)) =
    - ∑ (c : composition (n + 2)) in {c : composition (n + 2) | c.length < n + 2}.to_finset,
        (p.left_inv i c.length) (p.apply_composition c v),
  { simp only [left_inv, continuous_multilinear_map.neg_apply, neg_inj,
      continuous_multilinear_map.sum_apply],
    convert (sum_to_finset_eq_subtype (λ (c : composition (n+2)), c.length < n+2)
      (λ (c : composition (n+2)), (continuous_multilinear_map.comp_along_composition
        (p.comp_continuous_linear_map ↑(i.symm)) c (p.left_inv i c.length))
          (λ (j : fin (n + 2)), p 1 (λ (k : fin 1), v j)))).symm.trans _,
    simp only [comp_continuous_linear_map_apply_composition,
      continuous_multilinear_map.comp_along_composition_apply],
    congr,
    ext c,
    congr,
    ext k,
    simp [h] },
  simp [formal_multilinear_series.comp, show n + 2 ≠ 1, by dec_trivial, A, finset.sum_union B,
    apply_composition_ones, C, D],
end

/-! ### The right inverse of a formal multilinear series -/

/-- The right inverse of a formal multilinear series, where the `n`-th term is defined inductively
in terms of the previous ones to make sure that `p ∘ (right_inv p i) = id`. For this, the linear
term `p₁` in `p` should be invertible. In the definition, `i` is a linear isomorphism that should
coincide with `p₁`, so that one can use its inverse in the construction. The definition does not
use that `i = p₁`, but proofs that the definition is well-behaved do.

The `n`-th term in `p ∘ q` is `∑ pₖ (q_{j₁}, ..., q_{jₖ})` over `j₁ + ... + jₖ = n`. In this
expression, `qₙ` appears only once, in `p₁ (qₙ)`. We adjust the definition of `qₙ` so that this
term compensates the rest of the sum, using `i⁻¹` as an inverse to `p₁`.

These formulas only make sense when the constant term `p₀` vanishes. The definition we give is
general, but it ignores the value of `p₀`.
-/
noncomputable def right_inv (p : formal_multilinear_series 𝕜 E F) (i : E ≃L[𝕜] F) :
  formal_multilinear_series 𝕜 F E
| 0     := 0
| 1     := (continuous_multilinear_curry_fin1 𝕜 F E).symm i.symm
| (n+2) :=
    let q : formal_multilinear_series 𝕜 F E := λ k, if h : k < n + 2 then right_inv k else 0 in
    - (i.symm : F →L[𝕜] E).comp_continuous_multilinear_map ((p.comp q) (n+2))

@[simp] lemma right_inv_coeff_zero (p : formal_multilinear_series 𝕜 E F) (i : E ≃L[𝕜] F) :
  p.right_inv i 0 = 0 := by rw right_inv

@[simp] lemma right_inv_coeff_one (p : formal_multilinear_series 𝕜 E F) (i : E ≃L[𝕜] F) :
  p.right_inv i 1 = (continuous_multilinear_curry_fin1 𝕜 F E).symm i.symm := by rw right_inv

/-- The right inverse does not depend on the zeroth coefficient of a formal multilinear
series. -/
lemma right_inv_remove_zero (p : formal_multilinear_series 𝕜 E F) (i : E ≃L[𝕜] F) :
  p.remove_zero.right_inv i = p.right_inv i :=
begin
  ext1 n,
  induction n using nat.strong_rec' with n IH,
  cases n, { simp },
  cases n, { simp },
  simp only [right_inv, neg_inj],
  unfold_coes,
  congr' 1,
  rw remove_zero_comp_of_pos _ _ (show 0 < n+2, by dec_trivial),
  congr' 1,
  ext k,
  by_cases hk : k < n+2; simp [hk, IH]
end

lemma comp_right_inv_aux1 {n : ℕ} (hn : 0 < n)
  (p : formal_multilinear_series 𝕜 E F) (q : formal_multilinear_series 𝕜 F E) (v : fin n → F) :
  p.comp q n v =
    (∑ (c : composition n) in {c : composition n | 1 < c.length}.to_finset,
      p c.length (q.apply_composition c v)) + p 1 (λ i, q n v) :=
begin
  have A : (finset.univ : finset (composition n))
    = {c | 1 < composition.length c}.to_finset ∪ {composition.single n hn},
  { refine subset.antisymm (λ c hc, _) (subset_univ _),
    by_cases h : 1 < c.length,
    { simp [h] },
    { have : c.length = 1,
        by { refine (eq_iff_le_not_lt.2 ⟨ _, h⟩).symm, exact c.length_pos_of_pos hn },
      rw ← composition.eq_single_iff_length hn at this,
      simp [this] } },
  have B : disjoint ({c | 1 < composition.length c} : set (composition n)).to_finset
    {composition.single n hn}, by simp,
  have C : p (composition.single n hn).length
              (q.apply_composition (composition.single n hn) v)
            = p 1 (λ (i : fin 1), q n v),
  { apply p.congr (composition.single_length hn) (λ j hj1 hj2, _),
    simp [apply_composition_single] },
  simp [formal_multilinear_series.comp, A, finset.sum_union B, C],
end

lemma comp_right_inv_aux2
  (p : formal_multilinear_series 𝕜 E F) (i : E ≃L[𝕜] F) (n : ℕ) (v : fin (n + 2) → F) :
  ∑ (c : composition (n + 2)) in {c : composition (n + 2) | 1 < c.length}.to_finset,
    p c.length (apply_composition (λ (k : ℕ), ite (k < n + 2) (p.right_inv i k) 0) c v) =
  ∑ (c : composition (n + 2)) in {c : composition (n + 2) | 1 < c.length}.to_finset,
    p c.length ((p.right_inv i).apply_composition c v) :=
begin
  have N : 0 < n + 2, by dec_trivial,
  refine sum_congr rfl (λ c hc, p.congr rfl (λ j hj1 hj2, _)),
  have : ∀ k, c.blocks_fun k < n + 2,
  { simp only [set.mem_to_finset, set.mem_set_of_eq] at hc,
    simp [← composition.ne_single_iff N, composition.eq_single_iff_length, ne_of_gt hc] },
  simp [apply_composition, this],
end

/-- The right inverse to a formal multilinear series is indeed a right inverse, provided its linear
term is invertible and its constant term vanishes. -/
lemma comp_right_inv (p : formal_multilinear_series 𝕜 E F) (i : E ≃L[𝕜] F)
  (h : p 1 = (continuous_multilinear_curry_fin1 𝕜 E F).symm i) (h0 : p 0 = 0) :
  p.comp (right_inv p i) = id 𝕜 F :=
begin
  ext n v,
  cases n,
  { simp only [h0, continuous_multilinear_map.zero_apply, id_apply_ne_one, ne.def, not_false_iff,
      zero_ne_one, comp_coeff_zero']},
  cases n,
  { simp only [comp_coeff_one, h, right_inv, continuous_linear_equiv.apply_symm_apply, id_apply_one,
      continuous_linear_equiv.coe_apply, continuous_multilinear_curry_fin1_symm_apply] },
  have N : 0 < n+2, by dec_trivial,
  simp [comp_right_inv_aux1 N, h, right_inv, lt_irrefl n, show n + 2 ≠ 1, by dec_trivial,
        ← sub_eq_add_neg, sub_eq_zero, comp_right_inv_aux2],
end

lemma right_inv_coeff (p : formal_multilinear_series 𝕜 E F) (i : E ≃L[𝕜] F) (n : ℕ) (hn : 2 ≤ n) :
  p.right_inv i n = - (i.symm : F →L[𝕜] E).comp_continuous_multilinear_map
    (∑ c in ({c | 1 < composition.length c}.to_finset : finset (composition n)),
      p.comp_along_composition (p.right_inv i) c) :=
begin
  cases n, { exact false.elim (zero_lt_two.not_le hn) },
  cases n, { exact false.elim (one_lt_two.not_le hn) },
  simp only [right_inv, neg_inj],
  congr' 1,
  ext v,
  have N : 0 < n + 2, by dec_trivial,
  have : (p 1) (λ (i : fin 1), 0) = 0 := continuous_multilinear_map.map_zero _,
  simp [comp_right_inv_aux1 N, lt_irrefl n, this, comp_right_inv_aux2]
end

/-! ### Coincidence of the left and the right inverse -/

private lemma left_inv_eq_right_inv_aux (p : formal_multilinear_series 𝕜 E F) (i : E ≃L[𝕜] F)
  (h : p 1 = (continuous_multilinear_curry_fin1 𝕜 E F).symm i) (h0 : p 0 = 0) :
  left_inv p i = right_inv p i := calc
left_inv p i = (left_inv p i).comp (id 𝕜 F) : by simp
... = (left_inv p i).comp (p.comp (right_inv p i)) : by rw comp_right_inv p i h h0
... = ((left_inv p i).comp p).comp (right_inv p i) : by rw comp_assoc
... = (id 𝕜 E).comp (right_inv p i) : by rw left_inv_comp p i h
... = right_inv p i : by simp

/-- The left inverse and the right inverse of a formal multilinear series coincide. This is not at
all obvious from their definition, but it follows from uniqueness of inverses (which comes from the
fact that composition is associative on formal multilinear series). -/
theorem left_inv_eq_right_inv (p : formal_multilinear_series 𝕜 E F) (i : E ≃L[𝕜] F)
  (h : p 1 = (continuous_multilinear_curry_fin1 𝕜 E F).symm i) :
  left_inv p i = right_inv p i := calc
left_inv p i = left_inv p.remove_zero i : by rw left_inv_remove_zero
... = right_inv p.remove_zero i : by { apply left_inv_eq_right_inv_aux; simp [h] }
... = right_inv p i : by rw right_inv_remove_zero

/-!
### Convergence of the inverse of a power series

Assume that `p` is a convergent multilinear series, and let `q` be its (left or right) inverse.
Using the left-inverse formula gives
$$
q_n = - (p_1)^{-n} \sum_{k=0}^{n-1} \sum_{i_1 + \dotsc + i_k = n} q_k (p_{i_1}, \dotsc, p_{i_k}).
$$
Assume for simplicity that we are in dimension `1` and `p₁ = 1`. In the formula for `qₙ`, the term
`q_{n-1}` appears with a multiplicity of `n-1` (choosing the index `i_j` for which `i_j = 2` while
all the other indices are equal to `1`), which indicates that `qₙ` might grow like `n!`. This is
bad for summability properties.

It turns out that the right-inverse formula is better behaved, and should instead be used for this
kind of estimate. It reads
$$
q_n = - (p_1)^{-1} \sum_{k=2}^n \sum_{i_1 + \dotsc + i_k = n} p_k (q_{i_1}, \dotsc, q_{i_k}).
$$
Here, `q_{n-1}` can only appear in the term with `k = 2`, and it only appears twice, so there is
hope this formula can lead to an at most geometric behavior.

Let `Qₙ = ∥qₙ∥`. Bounding `∥pₖ∥` with `C r^k` gives an inequality
$$
Q_n ≤ C' \sum_{k=2}^n r^k \sum_{i_1 + \dotsc + i_k = n} Q_{i_1} \dotsm Q_{i_k}.
$$

This formula is not enough to prove by naive induction on `n` a bound of the form `Qₙ ≤ D R^n`.
However, assuming that the inequality above were an equality, one could get a formula for the
generating series of the `Qₙ`:

$$
\begin{align}
Q(z) & := \sum Q_n z^n = Q_1 z + C' \sum_{2 \leq k \leq n} \sum_{i_1 + \dotsc + i_k = n}
  (r z^{i_1} Q_{i_1}) \dotsm (r z^{i_k} Q_{i_k})
\\ & = Q_1 z + C' \sum_{k = 2}^\infty (\sum_{i_1 \geq 1} r z^{i_1} Q_{i_1})
  \dotsm (\sum_{i_k \geq 1} r z^{i_k} Q_{i_k})
\\ & = Q_1 z + C' \sum_{k = 2}^\infty (r Q(z))^k
= Q_1 z + C' (r Q(z))^2 / (1 - r Q(z)).
\end{align}
$$

One can solve this formula explicitly. The solution is analytic in a neighborhood of `0` in `ℂ`,
hence its coefficients grow at most geometrically (by a contour integral argument), and therefore
the original `Qₙ`, which are bounded by these ones, are also at most geometric.

This classical argument is not really satisfactory, as it requires an a priori bound on a complex
analytic function. Another option would be to compute explicitly its terms (with binomial
coefficients) to obtain an explicit geometric bound, but this would be very painful.

Instead, we will use the above intuition, but in a slightly different form, with finite sums and an
induction. I learnt this trick in [pöschel2017siegelsternberg]. Let
$S_n = \sum_{k=1}^n Q_k a^k$ (where `a` is a positive real parameter to be chosen suitably small).
The above computation but with finite sums shows that

$$
S_n \leq Q_1 a + C' \sum_{k=2}^n (r S_{n-1})^k.
$$

In particular, $S_n \leq Q_1 a + C' (r S_{n-1})^2 / (1- r S_{n-1})$.
Assume that $S_{n-1} \leq K a$, where `K > Q₁` is fixed and `a` is small enough so that
`r K a ≤ 1/2` (to control the denominator). Then this equation gives a bound
$S_n \leq Q_1 a + 2 C' r^2 K^2 a^2$.
If `a` is small enough, this is bounded by `K a` as the second term is quadratic in `a`, and
therefore negligible.

By induction, we deduce `Sₙ ≤ K a` for all `n`, which gives in particular the fact that `aⁿ Qₙ`
remains bounded.
-/

/-- First technical lemma to control the growth of coefficients of the inverse. Bound the explicit
expression for `∑_{k<n+1} aᵏ Qₖ` in terms of a sum of powers of the same sum one step before,
in a general abstract setup. -/
lemma radius_right_inv_pos_of_radius_pos_aux1
  (n : ℕ) (p : ℕ → ℝ) (hp : ∀ k, 0 ≤ p k) {r a : ℝ} (hr : 0 ≤ r) (ha : 0 ≤ a) :
  ∑ k in Ico 2 (n + 1), a ^ k *
      (∑ c in ({c | 1 < composition.length c}.to_finset : finset (composition k)),
          r ^ c.length * ∏ j, p (c.blocks_fun j))
  ≤ ∑ j in Ico 2 (n + 1), r ^ j * (∑ k in Ico 1 n, a ^ k * p k) ^ j :=
calc
∑ k in Ico 2 (n + 1), a ^ k *
  (∑ c in ({c | 1 < composition.length c}.to_finset : finset (composition k)),
      r ^ c.length * ∏ j, p (c.blocks_fun j))
= ∑ k in Ico 2 (n + 1),
  (∑ c in ({c | 1 < composition.length c}.to_finset : finset (composition k)),
      ∏ j, r * (a ^ (c.blocks_fun j) * p (c.blocks_fun j))) :
begin
  simp_rw [mul_sum],
  apply sum_congr rfl (λ k hk, _),
  apply sum_congr rfl (λ c hc, _),
  rw [prod_mul_distrib, prod_mul_distrib, prod_pow_eq_pow_sum, composition.sum_blocks_fun,
      prod_const, card_fin],
  ring,
end
... ≤ ∑ d in comp_partial_sum_target 2 (n + 1) n,
        ∏ (j : fin d.2.length), r * (a ^ d.2.blocks_fun j * p (d.2.blocks_fun j)) :
begin
  rw sum_sigma',
  refine sum_le_sum_of_subset_of_nonneg _ (λ x hx1 hx2,
    prod_nonneg (λ j hj, mul_nonneg hr (mul_nonneg (pow_nonneg ha _) (hp _)))),
  rintros ⟨k, c⟩ hd,
  simp only [set.mem_to_finset, Ico.mem, mem_sigma, set.mem_set_of_eq] at hd,
  simp only [mem_comp_partial_sum_target_iff],
  refine ⟨hd.2, c.length_le.trans_lt hd.1.2, λ j, _⟩,
  have : c ≠ composition.single k (zero_lt_two.trans_le hd.1.1),
    by simp [composition.eq_single_iff_length, ne_of_gt hd.2],
  rw composition.ne_single_iff at this,
  exact (this j).trans_le (nat.lt_succ_iff.mp hd.1.2)
end
... = ∑ e in comp_partial_sum_source 2 (n+1) n, ∏ (j : fin e.1), r * (a ^ e.2 j * p (e.2 j)) :
begin
  symmetry,
  apply comp_change_of_variables_sum,
  rintros ⟨k, blocks_fun⟩ H,
  have K : (comp_change_of_variables 2 (n + 1) n ⟨k, blocks_fun⟩ H).snd.length = k, by simp,
  congr' 2; try { rw K },
  rw fin.heq_fun_iff K.symm,
  assume j,
  rw comp_change_of_variables_blocks_fun,
end
... = ∑ j in Ico 2 (n+1), r ^ j * (∑ k in Ico 1 n, a ^ k * p k) ^ j :
begin
  rw [comp_partial_sum_source, ← sum_sigma' (Ico 2 (n + 1))
    (λ (k : ℕ), (fintype.pi_finset (λ (i : fin k), Ico 1 n) : finset (fin k → ℕ)))
    (λ n e, ∏ (j : fin n), r * (a ^ e j * p (e j)))],
  apply sum_congr rfl (λ j hj, _),
  simp only [← @multilinear_map.mk_pi_algebra_apply ℝ (fin j) _ _ ℝ],
  simp only [← multilinear_map.map_sum_finset (multilinear_map.mk_pi_algebra ℝ (fin j) ℝ)
    (λ k (m : ℕ), r * (a ^ m * p m))],
  simp only [multilinear_map.mk_pi_algebra_apply],
  dsimp,
  simp [prod_const, ← mul_sum, mul_pow],
end

/-- Second technical lemma to control the growth of coefficients of the inverse. Bound the explicit
expression for `∑_{k<n+1} aᵏ Qₖ` in terms of a sum of powers of the same sum one step before,
in the specific setup we are interesting in, by reducing to the general bound in
`radius_right_inv_pos_of_radius_pos_aux1`. -/
lemma radius_right_inv_pos_of_radius_pos_aux2
  {n : ℕ} (hn : 2 ≤ n + 1) (p : formal_multilinear_series 𝕜 E F) (i : E ≃L[𝕜] F)
  {r a C : ℝ} (hr : 0 ≤ r) (ha : 0 ≤ a) (hC : 0 ≤ C) (hp : ∀ n, ∥p n∥ ≤ C * r ^ n) :
   (∑ k in Ico 1 (n + 1), a ^ k * ∥p.right_inv i k∥) ≤
     ∥(i.symm : F →L[𝕜] E)∥ * a + ∥(i.symm : F →L[𝕜] E)∥ * C * ∑ k in Ico 2 (n + 1),
      (r * ((∑ j in Ico 1 n, a ^ j * ∥p.right_inv i j∥))) ^ k :=
let I := ∥(i.symm : F →L[𝕜] E)∥ in calc
∑ k in Ico 1 (n + 1), a ^ k * ∥p.right_inv i k∥
    = a * I + ∑ k in Ico 2 (n + 1), a ^ k * ∥p.right_inv i k∥ :
by simp only [linear_isometry_equiv.norm_map, pow_one, right_inv_coeff_one,
              Ico.succ_singleton, sum_singleton, ← sum_Ico_consecutive _ one_le_two hn]
... = a * I + ∑ k in Ico 2 (n + 1), a ^ k *
        ∥(i.symm : F →L[𝕜] E).comp_continuous_multilinear_map
          (∑ c in ({c | 1 < composition.length c}.to_finset : finset (composition k)),
            p.comp_along_composition (p.right_inv i) c)∥ :
begin
  congr' 1,
  apply sum_congr rfl (λ j hj, _),
  rw [right_inv_coeff _ _ _ (Ico.mem.1 hj).1, norm_neg],
end
... ≤ a * ∥(i.symm : F →L[𝕜] E)∥ + ∑ k in Ico 2 (n + 1), a ^ k * (I *
      (∑ c in ({c | 1 < composition.length c}.to_finset : finset (composition k)),
        C * r ^ c.length * ∏ j, ∥p.right_inv i (c.blocks_fun j)∥)) :
begin
  apply_rules [add_le_add, le_refl, sum_le_sum (λ j hj, _), mul_le_mul_of_nonneg_left,
    pow_nonneg, ha],
  apply (continuous_linear_map.norm_comp_continuous_multilinear_map_le _ _).trans,
  apply mul_le_mul_of_nonneg_left _ (norm_nonneg _),
  apply (norm_sum_le _ _).trans,
  apply sum_le_sum (λ c hc, _),
  apply (comp_along_composition_norm _ _ _).trans,
  apply mul_le_mul_of_nonneg_right (hp _),
  exact prod_nonneg (λ j hj, norm_nonneg _),
end
... = I * a + I * C * ∑ k in Ico 2 (n + 1), a ^ k *
  (∑ c in ({c | 1 < composition.length c}.to_finset : finset (composition k)),
      r ^ c.length * ∏ j, ∥p.right_inv i (c.blocks_fun j)∥) :
begin
  simp_rw [mul_assoc C, ← mul_sum, ← mul_assoc, mul_comm _ (∥↑i.symm∥), mul_assoc, ← mul_sum,
    ← mul_assoc, mul_comm _ C, mul_assoc, ← mul_sum],
  ring,
end
... ≤ I * a + I * C * ∑ k in Ico 2 (n+1), (r * ((∑ j in Ico 1 n, a ^ j * ∥p.right_inv i j∥))) ^ k :
begin
  apply_rules [add_le_add, le_refl, mul_le_mul_of_nonneg_left, norm_nonneg, hC, mul_nonneg],
  simp_rw [mul_pow],
  apply radius_right_inv_pos_of_radius_pos_aux1 n (λ k, ∥p.right_inv i k∥)
    (λ k, norm_nonneg _) hr ha,
end

/-- If a a formal multilinear series has a positive radius of convergence, then its right inverse
also has a positive radius of convergence. -/
theorem radius_right_inv_pos_of_radius_pos (p : formal_multilinear_series 𝕜 E F) (i : E ≃L[𝕜] F)
  (hp : 0 < p.radius) : 0 < (p.right_inv i).radius :=
begin
  obtain ⟨C, r, Cpos, rpos, ple⟩ : ∃ C r (hC : 0 < C) (hr : 0 < r), ∀ (n : ℕ), ∥p n∥ ≤ C * r ^ n :=
    le_mul_pow_of_radius_pos p hp,
  let I := ∥(i.symm : F →L[𝕜] E)∥,
  -- choose `a` small enough to make sure that `∑_{k ≤ n} aᵏ Qₖ` will be controllable by
  -- induction
  obtain ⟨a, apos, ha1, ha2⟩ : ∃ a (apos : 0 < a),
    (2 * I * C * r^2 * (I + 1) ^ 2 * a ≤ 1) ∧ (r * (I + 1) * a ≤ 1/2),
  { have : tendsto (λ a, 2 * I * C * r^2 * (I + 1) ^ 2 * a) (𝓝 0)
      (𝓝 (2 * I * C * r^2 * (I + 1) ^ 2 * 0)) := tendsto_const_nhds.mul tendsto_id,
    have A : ∀ᶠ a in 𝓝 0, 2 * I * C * r^2 * (I + 1) ^ 2 * a < 1,
      by { apply (tendsto_order.1 this).2, simp [zero_lt_one] },
    have : tendsto (λ a, r * (I + 1) * a) (𝓝 0)
      (𝓝 (r * (I + 1) * 0)) := tendsto_const_nhds.mul tendsto_id,
    have B : ∀ᶠ a in 𝓝 0, r * (I + 1) * a < 1/2,
      by { apply (tendsto_order.1 this).2, simp [zero_lt_one] },
    have C : ∀ᶠ a in 𝓝[set.Ioi (0 : ℝ)] (0 : ℝ), (0 : ℝ) < a,
      by { filter_upwards [self_mem_nhds_within], exact λ a ha, ha },
    rcases (C.and ((A.and B).filter_mono inf_le_left)).exists with ⟨a, ha⟩,
    exact ⟨a, ha.1, ha.2.1.le, ha.2.2.le⟩ },
  -- check by induction that the partial sums are suitably bounded, using the choice of `a` and the
  -- inductive control from Lemma `radius_right_inv_pos_of_radius_pos_aux2`.
  let S := λ n, ∑ k in Ico 1 n, a ^ k * ∥p.right_inv i k∥,
  have IRec : ∀ n, 1 ≤ n → S n ≤ (I + 1) * a,
  { apply nat.le_induction,
    { simp only [S],
      rw [Ico.eq_empty_of_le (le_refl 1), sum_empty],
      exact mul_nonneg (add_nonneg (norm_nonneg _) zero_le_one) apos.le },
    { assume n one_le_n hn,
      have In : 2 ≤ n + 1, by linarith,
      have Snonneg : 0 ≤ S n :=
        sum_nonneg (λ x hx, mul_nonneg (pow_nonneg apos.le _) (norm_nonneg _)),
      have rSn : r * S n ≤ 1/2 := calc
        r * S n ≤ r * ((I+1) * a) : mul_le_mul_of_nonneg_left hn rpos.le
        ... ≤ 1/2 : by rwa [← mul_assoc],
      calc S (n + 1) ≤ I * a + I * C * ∑ k in Ico 2 (n + 1), (r * S n)^k :
         radius_right_inv_pos_of_radius_pos_aux2 In p i rpos.le apos.le Cpos.le ple
      ... = I * a + I * C * (((r * S n) ^ 2 - (r * S n) ^ (n + 1)) / (1 - r * S n)) :
        by { rw geom_sum_Ico' _ In, exact ne_of_lt (rSn.trans_lt (by norm_num)) }
      ... ≤ I * a + I * C * ((r * S n) ^ 2 / (1/2)) :
        begin
          apply_rules [add_le_add, le_refl, mul_le_mul_of_nonneg_left, mul_nonneg, norm_nonneg,
            Cpos.le],
          refine div_le_div (sq_nonneg _) _ (by norm_num) (by linarith),
          simp only [sub_le_self_iff],
          apply pow_nonneg (mul_nonneg rpos.le Snonneg),
        end
      ... = I * a + 2 * I * C * (r * S n) ^ 2 : by ring
      ... ≤ I * a + 2 * I * C * (r * ((I + 1) * a)) ^ 2 :
        by apply_rules [add_le_add, le_refl, mul_le_mul_of_nonneg_left, mul_nonneg, norm_nonneg,
            Cpos.le, zero_le_two, pow_le_pow_of_le_left, rpos.le]
      ... = (I + 2 * I * C * r^2 * (I + 1) ^ 2 * a) * a : by ring
      ... ≤ (I + 1) * a :
        by apply_rules [mul_le_mul_of_nonneg_right, apos.le, add_le_add, le_refl] } },
  -- conclude that all coefficients satisfy `aⁿ Qₙ ≤ (I + 1) a`.
  let a' : nnreal := ⟨a, apos.le⟩,
  suffices H : (a' : ennreal) ≤ (p.right_inv i).radius,
    by { apply lt_of_lt_of_le _ H, exact_mod_cast apos },
  apply le_radius_of_bound _ ((I + 1) * a) (λ n, _),
  by_cases hn : n = 0,
  { have : ∥p.right_inv i n∥ = ∥p.right_inv i 0∥, by congr; try { rw hn },
    simp only [this, norm_zero, zero_mul, right_inv_coeff_zero],
    apply_rules [mul_nonneg, add_nonneg, norm_nonneg, zero_le_one, apos.le] },
  { have one_le_n : 1 ≤ n := bot_lt_iff_ne_bot.2 hn,
    calc ∥p.right_inv i n∥ * ↑a' ^ n = a ^ n * ∥p.right_inv i n∥ : mul_comm _ _
    ... ≤ ∑ k in Ico 1 (n + 1), a ^ k * ∥p.right_inv i k∥ :
      begin
        have : ∀ k ∈ Ico 1 (n + 1), 0 ≤ a ^ k * ∥p.right_inv i k∥ :=
          λ k hk, mul_nonneg (pow_nonneg apos.le _) (norm_nonneg _),
        exact single_le_sum this (by simp [one_le_n]),
      end
    ... ≤ (I + 1) * a : IRec (n + 1) (by dec_trivial) }
end

end formal_multilinear_series


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

import for_mathlib.dold_kan.faces
import category_theory.idempotents.basic

/-!

# Construction of projections for the Dold-Kan correspondence

TODO (@joelriou) continue adding the various files referenced below

In this file, we construct endomorphisms `P q : K[X] ⟶ K[X]` for all
`q : ℕ`. We study how they behave with respect to face maps with the lemmas
`higher_faces_vanish.of_P`, `higher_faces_vanish.comp_P_eq_self` and
`comp_P_eq_self_iff`.

Then, we show that they are projections (see `P_f_idem`
and `P_idem`). They are natural transformations (see `nat_trans_P`
and `P_f_naturality`) and are compatible with the application
of additive functors (see `map_P`).

By passing to the limit, these endomorphisms `P q` shall be used in `p_infty.lean`
in order to define `P_infty : K[X] ⟶ K[X]`, see `equivalence.lean` for the general
strategy of proof of the Dold-Kan equivalence.

-/

open category_theory category_theory.category category_theory.limits
  category_theory.preadditive category_theory.simplicial_object opposite
  category_theory.idempotents
open_locale simplicial dold_kan

noncomputable theory

namespace algebraic_topology

namespace dold_kan

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

/-- This is the inductive definition of the projections `P q : K[X] ⟶ K[X]`,
with `P 0 := 𝟙 _` and `P (q+1) := P q ≫ (𝟙 _ + Hσ q)`. -/
noncomputable def P : ℕ → (K[X] ⟶ K[X])
| 0     := 𝟙 _
| (q+1) := P q ≫ (𝟙 _ + Hσ q)

/-- All the `P q` coincide with `𝟙 _` in degree 0. -/
@[simp]
lemma P_f_0_eq (q : ℕ) : ((P q).f 0 : X _[0] ⟶ X _[0]) = 𝟙 _ :=
begin
  induction q with q hq,
  { refl, },
  { unfold P,
    simp only [homological_complex.add_f_apply, homological_complex.comp_f,
      homological_complex.id_f, id_comp, hq, Hσ_eq_zero, add_zero], },
end

/-- `Q q` is the complement projection associated to `P q` -/
def Q (q : ℕ) : K[X] ⟶ K[X] := 𝟙 _ - P q

lemma P_add_Q (q : ℕ) : P q + Q q = 𝟙 K[X] := by { rw Q, abel, }

lemma P_add_Q_f (q n : ℕ) : (P q).f n + (Q q).f n = 𝟙 (X _[n]) :=
homological_complex.congr_hom (P_add_Q q) n

@[simp]
lemma Q_eq_zero : (Q 0 : K[X] ⟶ _) = 0 := sub_self _

lemma Q_eq (q : ℕ) : (Q (q+1) : K[X] ⟶ _) = Q q - P q ≫ Hσ q :=
by { unfold Q P, simp only [comp_add, comp_id], abel, }

/-- All the `Q q` coincide with `0` in degree 0. -/
@[simp]
lemma Q_f_0_eq (q : ℕ) : ((Q q).f 0 : X _[0] ⟶ X _[0]) = 0 :=
by simp only [homological_complex.sub_f_apply, homological_complex.id_f, Q, P_f_0_eq, sub_self]

namespace higher_faces_vanish

/-- This lemma expresses the vanishing of
`(P q).f (n+1) ≫ X.δ k : X _[n+1] ⟶ X _[n]` when `k≠0` and `k≥n-q+2` -/
lemma of_P : Π (q n : ℕ), higher_faces_vanish q (((P q).f (n+1) : X _[n+1] ⟶ X _[n+1]))
| 0     := λ n j hj₁, by { exfalso, have hj₂ := fin.is_lt j, linarith, }
| (q+1) := λ n, by { unfold P, exact (of_P q n).induction, }

@[reassoc]
lemma comp_P_eq_self {Y : C} {n q : ℕ} {φ : Y ⟶ X _[n+1]}
  (v : higher_faces_vanish q φ) : φ ≫ (P q).f (n+1) = φ :=
begin
  induction q with q hq,
  { unfold P,
    apply comp_id, },
  { unfold P,
    simp only [comp_add, homological_complex.comp_f, homological_complex.add_f_apply,
      comp_id, ← assoc, hq v.of_succ, add_right_eq_self],
    by_cases hqn : n<q,
    { exact v.of_succ.comp_Hσ_eq_zero hqn, },
    { cases nat.le.dest (not_lt.mp hqn) with a ha,
      have hnaq : n=a+q := by linarith,
      simp only [v.of_succ.comp_Hσ_eq hnaq, neg_eq_zero, ← assoc],
      have eq := v ⟨a, by linarith⟩
        (by simp only [hnaq, fin.coe_mk, nat.succ_eq_add_one, add_assoc]),
      simp only [fin.succ_mk] at eq,
      simp only [eq, zero_comp], }, },
end

end higher_faces_vanish

lemma comp_P_eq_self_iff {Y : C} {n q : ℕ} {φ : Y ⟶ X _[n+1]} :
  φ ≫ (P q).f (n+1) = φ ↔ higher_faces_vanish q φ :=
begin
  split,
  { intro hφ,
    rw ← hφ,
    apply higher_faces_vanish.of_comp,
    apply higher_faces_vanish.of_P, },
  { exact higher_faces_vanish.comp_P_eq_self, },
end

@[simp, reassoc]
lemma P_f_idem (q n : ℕ) :
  ((P q).f n : X _[n] ⟶ _) ≫ ((P q).f n) = (P q).f n :=
begin
  cases n,
  { rw [P_f_0_eq q, comp_id], },
  { exact (higher_faces_vanish.of_P q n).comp_P_eq_self, }
end

@[simp, reassoc]
lemma Q_f_idem (q n : ℕ) :
  ((Q q).f n : X _[n] ⟶ _) ≫ ((Q q).f n) = (Q q).f n :=
idem_of_id_sub_idem _ (P_f_idem q n)

@[simp, reassoc]
lemma P_idem (q : ℕ) : (P q : K[X] ⟶ K[X]) ≫ P q = P q :=
by { ext n, exact P_f_idem q n, }

@[simp, reassoc]
lemma Q_idem (q : ℕ) : (Q q : K[X] ⟶ K[X]) ≫ Q q = Q q :=
by { ext n, exact Q_f_idem q n, }

/-- For each `q`, `P q` is a natural transformation. -/
@[simps]
def nat_trans_P (q : ℕ) :
  alternating_face_map_complex C ⟶ alternating_face_map_complex C :=
{ app := λ X, P q,
  naturality' := λ X Y f, begin
    induction q with q hq,
    { unfold P,
      dsimp only [alternating_face_map_complex],
      rw [id_comp, comp_id], },
    { unfold P,
      simp only [add_comp, comp_add, assoc, comp_id, hq],
      congr' 1,
      rw [← assoc, hq, assoc],
      congr' 1,
      exact (nat_trans_Hσ q).naturality' f, }
  end }

@[simp, reassoc]
lemma P_f_naturality (q n : ℕ) {X Y : simplicial_object C} (f : X ⟶ Y) :
  f.app (op [n]) ≫ (P q).f n = (P q).f n ≫ f.app (op [n]) :=
homological_complex.congr_hom ((nat_trans_P q).naturality f) n

@[simp, reassoc]
lemma Q_f_naturality (q n : ℕ) {X Y : simplicial_object C} (f : X ⟶ Y) :
  f.app (op [n]) ≫ (Q q).f n = (Q q).f n ≫ f.app (op [n]) :=
begin
  simp only [Q, homological_complex.sub_f_apply, homological_complex.id_f,
    comp_sub, P_f_naturality, sub_comp, sub_left_inj],
  dsimp,
  simp only [comp_id, id_comp],
end

/-- For each `q`, `Q q` is a natural transformation. -/
@[simps]
def nat_trans_Q (q : ℕ) :
  alternating_face_map_complex C ⟶ alternating_face_map_complex C :=
{ app := λ X, Q q, }

lemma map_P {D : Type*} [category D] [preadditive D]
  (G : C ⥤ D) [G.additive] (X : simplicial_object C) (q n : ℕ) :
  G.map ((P q : K[X] ⟶ _).f n) = (P q : K[((whiskering C D).obj G).obj X] ⟶ _).f n :=
begin
  induction q with q hq,
  { unfold P,
    apply G.map_id, },
  { unfold P,
    simp only [comp_add, homological_complex.comp_f, homological_complex.add_f_apply,
      comp_id, functor.map_add, functor.map_comp, hq, map_Hσ], }
end

lemma map_Q {D : Type*} [category D] [preadditive D]
  (G : C ⥤ D) [G.additive] (X : simplicial_object C) (q n : ℕ) :
  G.map ((Q q : K[X] ⟶ _).f n) = (Q q : K[((whiskering C D).obj G).obj X] ⟶ _).f n :=
begin
  rw [← add_right_inj (G.map ((P q : K[X] ⟶ _).f n)), ← G.map_add, map_P G X q n,
    P_add_Q_f, P_add_Q_f],
  apply G.map_id,
end

end dold_kan

end algebraic_topology


import .love08_operational_semantics_demo

/- # LoVe Exercise 8: Operational Semantics -/

set_option pp.beta true
set_option pp.generalized_field_notation false

namespace LoVe

/- ## Question 1: Program Equivalence

For this question, we introduce the notion of program equivalence: `S₁ ≈ S₂`. -/

def big_step_equiv (S₁ S₂ : stmt) : Prop :=
∀s t, (S₁, s) ⟹ t ↔ (S₂, s) ⟹ t

infix ` ≈ ` := big_step_equiv

/- Program equivalence is a equivalence relation, i.e., it is reflexive,
symmetric, and transitive. -/

@[refl] lemma big_step_equiv.refl {S : stmt} :
  S ≈ S :=
fix s t,
show (S, s) ⟹ t ↔ (S, s) ⟹ t, from
  by refl

@[symm] lemma big_step_equiv.symm {S₁ S₂ : stmt}:
  S₁ ≈ S₂ → S₂ ≈ S₁ :=
assume h : S₁ ≈ S₂,
fix s t,
show (S₂, s) ⟹ t ↔ (S₁, s) ⟹ t, from
  iff.symm (h s t)

@[trans] lemma big_step_equiv.trans {S₁ S₂ S₃ : stmt} (h₁₂ : S₁ ≈ S₂)
    (h₂₃ : S₂ ≈ S₃) :
  S₁ ≈ S₃ :=
fix s t,
show (S₁, s) ⟹ t ↔ (S₃, s) ⟹ t, from
  iff.trans (h₁₂ s t) (h₂₃ s t)

/- 1.1. Prove the following program equivalences. -/

lemma big_step_equiv.skip_assign_id {x} :
  stmt.assign x (λs, s x) ≈ stmt.skip :=
begin
  intros s t,
  apply iff.intro,
  { intro hasn,
    cases' hasn,
    simp * at * },
  { intro hskip,
    cases' hskip,
    simp * at * }
end

lemma big_step_equiv.seq_skip_left {S : stmt} :
  stmt.skip ;; S ≈ S :=
begin
  intros s t,
  apply iff.intro,
  { intro h,
    cases' h,
    cases' h_1,
    assumption },
  { intro h,
    exact big_step.seq big_step.skip h }
end

lemma big_step_equiv.seq_skip_right {S : stmt} :
  S ;; stmt.skip ≈ S :=
begin
  intros s t,
  apply iff.intro,
  { intro h,
    cases' h,
    cases' h_1,
    assumption },
  { intro h,
    exact big_step.seq h big_step.skip }
end

lemma big_step_equiv.ite_seq_while {b} {S : stmt} :
  stmt.ite b (S ;; stmt.while b S) stmt.skip ≈ stmt.while b S :=
begin
  intros s t,
  apply iff.intro,
  { intro hite,
    cases' hite,
    { cases' hite,
      apply big_step.while_true; assumption },
    { cases' hite,
      apply big_step.while_false,
      assumption } },
  { intro while,
    cases' while,
    { apply big_step.ite_true hcond,
      apply big_step.seq; assumption },
    { apply big_step.ite_false hcond,
      exact big_step.skip } }
end

/- 1.2. Program equivalence can be used to replace subprograms by other
subprograms with the same semantics. Prove the following so-called congruence
rules: -/

lemma big_step_equiv.seq_congr {S₁ S₂ T₁ T₂ : stmt} (hS : S₁ ≈ S₂)
    (hT : T₁ ≈ T₂) :
  S₁ ;; T₁ ≈ S₂ ;; T₂ :=
begin
  intros s t,
  apply iff.intro,
  { intro hseq,
    cases' hseq with _ _ _ _ _ _ _ u _ hS₁ hT₁,
    apply big_step.seq,
    { apply iff.elim_left (hS _ _) hS₁ },
    { apply iff.elim_left (hT _ _) hT₁ } },
  { intros hseq,
    cases' hseq with _ _ _ _ _ _ _ u _ hS₂ hT₂,
    apply big_step.seq,
    { exact iff.elim_right (hS _ _) hS₂ },
    { exact iff.elim_right (hT _ _) hT₂ } }
end

lemma big_step_equiv.ite_congr {b} {S₁ S₂ T₁ T₂ : stmt} (hS : S₁ ≈ S₂)
    (hT : T₁ ≈ T₂) :
  stmt.ite b S₁ T₁ ≈ stmt.ite b S₂ T₂ :=
begin
  intros s t,
  apply iff.intro,
  { intro hite,
    cases' hite,
    case ite_true : _ _ _ _ _ hcond hbody {
      apply big_step.ite_true hcond,
      exact iff.elim_left (hS _ _) hbody },
    case ite_false : _ _ _ _ _ hcond hbody {
      apply big_step.ite_false hcond,
      exact iff.elim_left (hT _ _) hbody } },
  { intro hite,
    cases' hite,
    case ite_true : _ _ _ _ _ hcond hbody {
      apply big_step.ite_true hcond,
      exact iff.elim_right (hS _ _) hbody },
    case ite_false : _ _ _ _ _ hcond hbody {
      apply big_step.ite_false hcond,
      exact iff.elim_right (hT _ _) hbody } }
end

/- 1.3 (**optional**): Prove one more congruence rule. This one is more
difficult. -/

lemma denote_equiv.while_congr {b} {S₁ S₂ : stmt} (hS : S₁ ≈ S₂) :
  stmt.while b S₁ ≈ stmt.while b S₂ :=
begin
  intros s t,
  apply iff.intro,
  { intro hwhile,
    induction' hwhile,
    case while_true : b S t u v hcond hbody hrest ih_body ih_rest {
      apply big_step.while_true hcond,
      exact iff.elim_left (hS _ _) hbody,
      exact ih_rest hS },
    case while_false {
      exact big_step.while_false hcond } },
  { intro hwhile,
    induction' hwhile,
    case while_true : b S t u v hcond hbody hrest ih_body ih_rest {
      apply big_step.while_true hcond,
      exact iff.elim_right (hS _ _) hbody,
      exact ih_rest hS },
    case while_false {
      exact big_step.while_false hcond } }
end

/- ## Question 2: Guarded Command Language (GCL)

In 1976, E. W. Dijkstra introduced the guarded command language, a
minimalistic imperative language with built-in nondeterminism. A grammar for one
of its variants is given below:

    S  ::=  x := e       -- assignment
         |  assert b     -- assertion
         |  S ; S        -- sequential composition
         |  S | ⋯ | S    -- nondeterministic choice
         |  loop S       -- nondeterministic iteration

Assignment and sequential composition are as in the WHILE language. The other
statements have the following semantics:

* `assert b` aborts if `b` evaluates to false; otherwise, the command is a
  no-op.

* `S | ⋯ | S` chooses any of the branches and executes it, ignoring the other
  branches.

* `loop S` executes `S` any number of times.

In Lean, GCL is captured by the following inductive type: -/

namespace gcl

inductive stmt (σ : Type) : Type
| assign : string → (σ → ℕ) → stmt
| assert : (σ → Prop) → stmt
| seq    : stmt → stmt → stmt
| choice : list stmt → stmt
| loop   : stmt → stmt

infixr ` ;; ` : 90 := stmt.seq

/- The parameter `σ` abstracts over the state type. It is necessary as a work
around for a Lean bug.

The big-step semantics is defined as follows: -/

inductive big_step : (stmt state × state) → state → Prop
| assign {x a s} :
  big_step (stmt.assign x a, s) (s{x ↦ a s})
| assert {b : state → Prop} {s} (hcond : b s) :
  big_step (stmt.assert b, s) s
| seq {S T s t u} (h₁ : big_step (S, s) t) (h₂ : big_step (T, t) u) :
  big_step (S ;; T, s) u
| choice {Ss s t} (i) (hless : i < list.length Ss)
    (hbody : big_step (list.nth_le Ss i hless, s) t) :
  big_step (stmt.choice Ss, s) t
| loop_base {S s} :
  big_step (stmt.loop S, s) s
| loop_step {S s u} (t) (hbody : big_step (S, s) t)
    (hrest : big_step (stmt.loop S, t) u) :
  big_step (stmt.loop S, s) u

infix ` ⟹ ` : 110 := big_step

/- 2.1. Prove the following inversion rules, as we did in the lecture for the
WHILE language. -/

@[simp] lemma big_step_assign_iff {x a s t} :
  (stmt.assign x a, s) ⟹ t ↔ t = s{x ↦ a s} :=
begin
  apply iff.intro,
  { intro hasn,
    cases' hasn,
    refl },
  { intro heq,
    rw heq,
    exact big_step.assign }
end

@[simp] lemma big_step_assert {b s t} :
  (stmt.assert b, s) ⟹ t ↔ t = s ∧ b s :=
begin
  apply iff.intro,
  { intro hast,
    cases' hast,
    simp * at * },
  { intros hand,
    cases' hand,
    rw left,
    apply big_step.assert right }
end

@[simp] lemma big_step_seq_iff {S₁ S₂ s t} :
  (stmt.seq S₁ S₂, s) ⟹ t ↔ (∃u, (S₁, s) ⟹ u ∧ (S₂, u) ⟹ t) :=
begin
  apply iff.intro,
  { intro hseq,
    cases' hseq,
    apply exists.intro,
    apply and.intro; assumption },
  { intro hseq,
    cases' hseq,
    cases' h,
    apply big_step.seq; assumption }
end

lemma big_step_loop {S s u} :
  (stmt.loop S, s) ⟹ u ↔
  (s = u ∨ (∃t, (S, s) ⟹ t ∧ (stmt.loop S, t) ⟹ u)) :=
begin
  apply iff.intro,
  { intro hloop,
    cases' hloop,
    { apply or.intro_left,
      refl },
    { apply or.intro_right,
      apply exists.intro t,
      cc } },
  { intro hor,
    cases' hor,
    { rw h,
      apply big_step.loop_base },
    { cases' h,
      cases' h,
      apply big_step.loop_step; assumption } }
end

@[simp] lemma big_step_choice {Ss s t} :
  (stmt.choice Ss, s) ⟹ t ↔
  (∃(i : ℕ) (hless : i < list.length Ss),
     (list.nth_le Ss i hless, s) ⟹ t) :=
begin
  apply iff.intro,
  { intro hchoice,
    cases' hchoice,
    apply exists.intro i,
    apply exists.intro hless,
    assumption },
  { intro hex,
    cases' hex with i hex,
    cases' hex with hless hstep,
    apply big_step.choice; assumption }
end

end gcl

/- 2.2. Complete the translation below of a deterministic program to a GCL
program, by filling in the `sorry` placeholders below. -/

def gcl_of : stmt → gcl.stmt state
| stmt.skip         := gcl.stmt.assert (λ_, true)
| (stmt.assign x a) :=
  gcl.stmt.assign x a
| (S ;; T)          :=
  gcl_of S ;;
  gcl_of T
| (stmt.ite b S T)  :=
  gcl.stmt.choice [
    gcl.stmt.assert b ;; gcl_of S,
    gcl.stmt.assert (λs, ¬ b s) ;; gcl_of T
  ]
| (stmt.while b S)  :=
  gcl.stmt.loop
    (gcl.stmt.assert b ;;
     gcl_of S) ;;
  gcl.stmt.assert (λs, ¬ b s)

/- 2.3. In the definition of `gcl_of` above, `skip` is translated to
`assert (λ_, true)`. Looking at the big-step semantics of both constructs, we
can convince ourselves that it makes sense. Can you think of other correct ways
to define the `skip` case? -/

/- Here are two other possibilities:

* `loop (assert (λ_, false))`
* `assign "x" (λs, s "x")`

There are infinitely many variants, e.g., `seq` of the above two solutions. -/

end LoVe


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

! This file was ported from Lean 3 source module linear_algebra.exterior_algebra.of_alternating
! leanprover-community/mathlib commit ce11c3c2a285bbe6937e26d9792fda4e51f3fe1a
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.LinearAlgebra.CliffordAlgebra.Fold
import Mathbin.LinearAlgebra.ExteriorAlgebra.Basic

/-!
# Extending an alternating map to the exterior algebra

## Main definitions

* `exterior_algebra.lift_alternating`: construct a linear map out of the exterior algebra
  given alternating maps (corresponding to maps out of the exterior powers).
* `exterior_algebra.lift_alternating_equiv`: the above as a linear equivalence

## Main results

* `exterior_algebra.lhom_ext`: linear maps from the exterior algebra agree if they agree on the
  exterior powers.

-/

variable {R M N N' : Type _}

variable [CommRing R] [AddCommGroup M] [AddCommGroup N] [AddCommGroup N']

variable [Module R M] [Module R N] [Module R N']

-- This instance can't be found where it's needed if we don't remind lean that it exists.
instance AlternatingMap.moduleAddCommGroup {ι : Type _} : Module R (AlternatingMap R M N ι) := by
  infer_instance
#align alternating_map.module_add_comm_group AlternatingMap.moduleAddCommGroup

namespace ExteriorAlgebra

open CliffordAlgebra hiding ι

/-- Build a map out of the exterior algebra given a collection of alternating maps acting on each
exterior power -/
def liftAlternating : (∀ i, AlternatingMap R M N (Fin i)) →ₗ[R] ExteriorAlgebra R M →ₗ[R] N :=
  by
  suffices
    (∀ i, AlternatingMap R M N (Fin i)) →ₗ[R]
      ExteriorAlgebra R M →ₗ[R] ∀ i, AlternatingMap R M N (Fin i)
    by
    refine' LinearMap.compr₂ this _
    refine' LinearEquiv.toLinearMap _ ∘ₗ LinearMap.proj 0
    exact alternating_map.const_linear_equiv_of_is_empty.symm
  refine' CliffordAlgebra.foldl _ _ _
  · refine'
      LinearMap.mk₂ R (fun m f i => (f i.succ).curryLeft m) (fun m₁ m₂ f => _) (fun c m f => _)
        (fun m f₁ f₂ => _) fun c m f => _
    all_goals
      ext i : 1
      simp only [map_smul, map_add, Pi.add_apply, Pi.smul_apply, AlternatingMap.curryLeft_add,
        AlternatingMap.curryLeft_smul, map_add, map_smul, LinearMap.add_apply, LinearMap.smul_apply]
  · -- when applied twice with the same `m`, this recursive step produces 0
    intro m x
    dsimp only [LinearMap.mk₂_apply, QuadraticForm.coeFn_zero, Pi.zero_apply]
    simp_rw [zero_smul]
    ext i : 1
    exact AlternatingMap.curryLeft_same _ _
#align exterior_algebra.lift_alternating ExteriorAlgebra.liftAlternating

@[simp]
theorem liftAlternating_ι (f : ∀ i, AlternatingMap R M N (Fin i)) (m : M) :
    liftAlternating f (ι R m) = f 1 ![m] :=
  by
  dsimp [lift_alternating]
  rw [foldl_ι, LinearMap.mk₂_apply, AlternatingMap.curryLeft_apply_apply]
  congr
#align exterior_algebra.lift_alternating_ι ExteriorAlgebra.liftAlternating_ι

theorem liftAlternating_ι_mul (f : ∀ i, AlternatingMap R M N (Fin i)) (m : M)
    (x : ExteriorAlgebra R M) :
    liftAlternating f (ι R m * x) = liftAlternating (fun i => (f i.succ).curryLeft m) x :=
  by
  dsimp [lift_alternating]
  rw [foldl_mul, foldl_ι]
  rfl
#align exterior_algebra.lift_alternating_ι_mul ExteriorAlgebra.liftAlternating_ι_mul

@[simp]
theorem liftAlternating_one (f : ∀ i, AlternatingMap R M N (Fin i)) :
    liftAlternating f (1 : ExteriorAlgebra R M) = f 0 0 :=
  by
  dsimp [lift_alternating]
  rw [foldl_one]
#align exterior_algebra.lift_alternating_one ExteriorAlgebra.liftAlternating_one

@[simp]
theorem liftAlternating_algebraMap (f : ∀ i, AlternatingMap R M N (Fin i)) (r : R) :
    liftAlternating f (algebraMap _ (ExteriorAlgebra R M) r) = r • f 0 0 := by
  rw [Algebra.algebraMap_eq_smul_one, map_smul, lift_alternating_one]
#align exterior_algebra.lift_alternating_algebra_map ExteriorAlgebra.liftAlternating_algebraMap

@[simp]
theorem liftAlternating_apply_ιMulti {n : ℕ} (f : ∀ i, AlternatingMap R M N (Fin i))
    (v : Fin n → M) : liftAlternating f (ιMulti R n v) = f n v :=
  by
  rw [ι_multi_apply]
  induction' n with n ih generalizing f v
  · rw [List.ofFn_zero, List.prod_nil, lift_alternating_one, Subsingleton.elim 0 v]
  · rw [List.ofFn_succ, List.prod_cons, lift_alternating_ι_mul, ih,
      AlternatingMap.curryLeft_apply_apply]
    congr
    exact Matrix.cons_head_tail _
#align exterior_algebra.lift_alternating_apply_ι_multi ExteriorAlgebra.liftAlternating_apply_ιMulti

@[simp]
theorem liftAlternating_comp_ιMulti {n : ℕ} (f : ∀ i, AlternatingMap R M N (Fin i)) :
    (liftAlternating f).compAlternatingMap (ιMulti R n) = f n :=
  AlternatingMap.ext <| liftAlternating_apply_ιMulti f
#align exterior_algebra.lift_alternating_comp_ι_multi ExteriorAlgebra.liftAlternating_comp_ιMulti

@[simp]
theorem liftAlternating_comp (g : N →ₗ[R] N') (f : ∀ i, AlternatingMap R M N (Fin i)) :
    (liftAlternating fun i => g.compAlternatingMap (f i)) = g ∘ₗ liftAlternating f :=
  by
  ext v
  rw [LinearMap.comp_apply]
  induction' v using CliffordAlgebra.leftInduction with r x y hx hy x m hx generalizing f
  ·
    rw [lift_alternating_algebra_map, lift_alternating_algebra_map, map_smul,
      LinearMap.compAlternatingMap_apply]
  · rw [map_add, map_add, map_add, hx, hy]
  · rw [lift_alternating_ι_mul, lift_alternating_ι_mul, ← hx]
    simp_rw [AlternatingMap.curryLeft_compAlternatingMap]
#align exterior_algebra.lift_alternating_comp ExteriorAlgebra.liftAlternating_comp

@[simp]
theorem liftAlternating_ιMulti :
    liftAlternating (ι_multi R) = (LinearMap.id : ExteriorAlgebra R M →ₗ[R] ExteriorAlgebra R M) :=
  by
  ext v
  dsimp
  induction' v using CliffordAlgebra.leftInduction with r x y hx hy x m hx
  · rw [lift_alternating_algebra_map, ι_multi_zero_apply, Algebra.algebraMap_eq_smul_one]
  · rw [map_add, hx, hy]
  ·
    simp_rw [lift_alternating_ι_mul, ι_multi_succ_curry_left, lift_alternating_comp,
      LinearMap.comp_apply, LinearMap.mulLeft_apply, hx]
#align exterior_algebra.lift_alternating_ι_multi ExteriorAlgebra.liftAlternating_ιMulti

/-- `exterior_algebra.lift_alternating` is an equivalence. -/
@[simps apply symm_apply]
def liftAlternatingEquiv : (∀ i, AlternatingMap R M N (Fin i)) ≃ₗ[R] ExteriorAlgebra R M →ₗ[R] N
    where
  toFun := liftAlternating
  map_add' := map_add _
  map_smul' := map_smul _
  invFun F i := F.compAlternatingMap (ιMulti R i)
  left_inv f := funext fun i => liftAlternating_comp_ιMulti _
  right_inv F :=
    (liftAlternating_comp _ _).trans <| by rw [lift_alternating_ι_multi, LinearMap.comp_id]
#align exterior_algebra.lift_alternating_equiv ExteriorAlgebra.liftAlternatingEquiv

/-- To show that two linear maps from the exterior algebra agree, it suffices to show they agree on
the exterior powers.

See note [partially-applied ext lemmas] -/
@[ext]
theorem lhom_ext ⦃f g : ExteriorAlgebra R M →ₗ[R] N⦄
    (h : ∀ i, f.compAlternatingMap (ιMulti R i) = g.compAlternatingMap (ιMulti R i)) : f = g :=
  liftAlternatingEquiv.symm.Injective <| funext h
#align exterior_algebra.lhom_ext ExteriorAlgebra.lhom_ext

end ExteriorAlgebra


/-
Copyright (c) 2018 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison, Reid Barton, Simon Hudon, Kenny Lau
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.equiv.basic
import Mathlib.PostPort

universes u v

namespace Mathlib

/-!
# Opposites

In this file we define a type synonym `opposite α := α`, denoted by `αᵒᵖ` and two synonyms for the
identity map, `op : α → αᵒᵖ` and `unop : αᵒᵖ → α`. The type tag `αᵒᵖ` is used with two different
meanings:

- if `α` is a category, then `αᵒᵖ` is the opposite category, with all arrows reversed;

- if `α` is a monoid (group, etc), then `αᵒᵖ` is the opposite monoid (group, etc) with
  `op (x * y) = op x * op y`.
-/

/-- The type of objects of the opposite of `α`; used to define the opposite category or group.

  In order to avoid confusion between `α` and its opposite type, we
  set up the type of objects `opposite α` using the following pattern,
  which will be repeated later for the morphisms.

  1. Define `opposite α := α`.
  2. Define the isomorphisms `op : α → opposite α`, `unop : opposite α → α`.
  3. Make the definition `opposite` irreducible.

  This has the following consequences.

  * `opposite α` and `α` are distinct types in the elaborator, so you
    must use `op` and `unop` explicitly to convert between them.
  * Both `unop (op X) = X` and `op (unop X) = X` are definitional
    equalities. Notably, every object of the opposite category is
    definitionally of the form `op X`, which greatly simplifies the
    definition of the structure of the opposite category, for example.

  (If Lean supported definitional eta equality for records, we could
  achieve the same goals using a structure with one field.)
-/
def opposite (α : Sort u) :=
  α

postfix:0 "ᵒᵖ" => Mathlib.opposite

-- Use a high right binding power (like that of postfix ⁻¹) so that, for example,

-- `presheaf Cᵒᵖ` parses as `presheaf (Cᵒᵖ)` and not `(presheaf C)ᵒᵖ`.

namespace opposite

/-- The canonical map `α → αᵒᵖ`. -/
/-- The canonical map `αᵒᵖ → α`. -/
def op {α : Sort u} : α → (αᵒᵖ) :=
  id

def unop {α : Sort u} : αᵒᵖ → α :=
  id

theorem op_injective {α : Sort u} : function.injective op :=
  fun (_x _x_1 : α) => id

theorem unop_injective {α : Sort u} : function.injective unop :=
  fun (_x _x_1 : αᵒᵖ) => id

@[simp] theorem op_inj_iff {α : Sort u} (x : α) (y : α) : op x = op y ↔ x = y :=
  iff.rfl

@[simp] theorem unop_inj_iff {α : Sort u} (x : αᵒᵖ) (y : αᵒᵖ) : unop x = unop y ↔ x = y :=
  iff.rfl

@[simp] theorem op_unop {α : Sort u} (x : αᵒᵖ) : op (unop x) = x :=
  rfl

@[simp] theorem unop_op {α : Sort u} (x : α) : unop (op x) = x :=
  rfl

/-- The type-level equivalence between a type and its opposite. -/
def equiv_to_opposite {α : Sort u} : α ≃ (αᵒᵖ) :=
  equiv.mk op unop unop_op op_unop

@[simp] theorem equiv_to_opposite_apply {α : Sort u} (a : α) : coe_fn equiv_to_opposite a = op a :=
  rfl

@[simp] theorem equiv_to_opposite_symm_apply {α : Sort u} (a : αᵒᵖ) : coe_fn (equiv.symm equiv_to_opposite) a = unop a :=
  rfl

theorem op_eq_iff_eq_unop {α : Sort u} {x : α} {y : αᵒᵖ} : op x = y ↔ x = unop y :=
  equiv.apply_eq_iff_eq_symm_apply equiv_to_opposite

theorem unop_eq_iff_eq_op {α : Sort u} {x : αᵒᵖ} {y : α} : unop x = y ↔ x = op y :=
  equiv.apply_eq_iff_eq_symm_apply (equiv.symm equiv_to_opposite)

protected instance inhabited {α : Sort u} [Inhabited α] : Inhabited (αᵒᵖ) :=
  { default := op Inhabited.default }

@[simp] def op_induction {α : Sort u} {F : αᵒᵖ → Sort v} (h : (X : α) → F (op X)) (X : αᵒᵖ) : F X :=
  h (unop X)