/-
Copyright (c) 2020 Joseph Myers. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Joseph Myers, Manuel Candales

! This file was ported from Lean 3 source module geometry.euclidean.basic
! leanprover-community/mathlib commit 2de9c37fa71dde2f1c6feff19876dd6a7b1519f0
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Analysis.InnerProductSpace.Projection
import Mathbin.Algebra.QuadraticDiscriminant

/-!
# Euclidean spaces

This file makes some definitions and proves very basic geometrical
results about real inner product spaces and Euclidean affine spaces.
Results about real inner product spaces that involve the norm and
inner product but not angles generally go in
`analysis.normed_space.inner_product`.  Results with longer
proofs or more geometrical content generally go in separate files.

## Main definitions

* `euclidean_geometry.orthogonal_projection` is the orthogonal
  projection of a point onto an affine subspace.

* `euclidean_geometry.reflection` is the reflection of a point in an
  affine subspace.

## Implementation notes

To declare `P` as the type of points in a Euclidean affine space with
`V` as the type of vectors, use
`[normed_add_comm_group V] [inner_product_space ℝ V] [metric_space P] [normed_add_torsor V P]`.
This works better with `out_param` to make
`V` implicit in most cases than having a separate type alias for
Euclidean affine spaces.

Rather than requiring Euclidean affine spaces to be finite-dimensional
(as in the definition on Wikipedia), this is specified only for those
theorems that need it.

## References

* https://en.wikipedia.org/wiki/Euclidean_space

-/

noncomputable section

open BigOperators

open Classical

open RealInnerProductSpace

namespace EuclideanGeometry

/-!
### Geometrical results on Euclidean affine spaces

This section develops some geometrical definitions and results on
Euclidean affine spaces.
-/

variable {V : Type _} {P : Type _}

variable [NormedAddCommGroup V] [InnerProductSpace ℝ V] [MetricSpace P]

variable [NormedAddTorsor V P]

include V

/-- The midpoint of the segment AB is the same distance from A as it is from B. -/
theorem dist_left_midpoint_eq_dist_right_midpoint (p1 p2 : P) :
    dist p1 (midpoint ℝ p1 p2) = dist p2 (midpoint ℝ p1 p2) := by
  rw [dist_left_midpoint p1 p2, dist_right_midpoint p1 p2]
#align euclidean_geometry.dist_left_midpoint_eq_dist_right_midpoint EuclideanGeometry.dist_left_midpoint_eq_dist_right_midpoint

/-- The inner product of two vectors given with `weighted_vsub`, in
terms of the pairwise distances. -/
theorem inner_weightedVsub {ι₁ : Type _} {s₁ : Finset ι₁} {w₁ : ι₁ → ℝ} (p₁ : ι₁ → P)
    (h₁ : (∑ i in s₁, w₁ i) = 0) {ι₂ : Type _} {s₂ : Finset ι₂} {w₂ : ι₂ → ℝ} (p₂ : ι₂ → P)
    (h₂ : (∑ i in s₂, w₂ i) = 0) :
    ⟪s₁.weightedVsub p₁ w₁, s₂.weightedVsub p₂ w₂⟫ =
      (-∑ i₁ in s₁, ∑ i₂ in s₂, w₁ i₁ * w₂ i₂ * (dist (p₁ i₁) (p₂ i₂) * dist (p₁ i₁) (p₂ i₂))) /
        2 :=
  by
  rw [Finset.weightedVsub_apply, Finset.weightedVsub_apply,
    inner_sum_smul_sum_smul_of_sum_eq_zero _ h₁ _ h₂]
  simp_rw [vsub_sub_vsub_cancel_right]
  rcongr (i₁ i₂) <;> rw [dist_eq_norm_vsub V (p₁ i₁) (p₂ i₂)]
#align euclidean_geometry.inner_weighted_vsub EuclideanGeometry.inner_weightedVsub

/-- The distance between two points given with `affine_combination`,
in terms of the pairwise distances between the points in that
combination. -/
theorem dist_affineCombination {ι : Type _} {s : Finset ι} {w₁ w₂ : ι → ℝ} (p : ι → P)
    (h₁ : (∑ i in s, w₁ i) = 1) (h₂ : (∑ i in s, w₂ i) = 1) : by
    have a₁ := s.affine_combination ℝ p w₁ <;> have a₂ := s.affine_combination ℝ p w₂ <;>
      exact
        dist a₁ a₂ * dist a₁ a₂ =
          (-∑ i₁ in s,
                ∑ i₂ in s,
                  (w₁ - w₂) i₁ * (w₁ - w₂) i₂ * (dist (p i₁) (p i₂) * dist (p i₁) (p i₂))) /
            2 :=
  by
  rw [dist_eq_norm_vsub V (s.affine_combination ℝ p w₁) (s.affine_combination ℝ p w₂), ←
    @inner_self_eq_norm_mul_norm ℝ, Finset.affineCombination_vsub]
  have h : (∑ i in s, (w₁ - w₂) i) = 0 := by
    simp_rw [Pi.sub_apply, Finset.sum_sub_distrib, h₁, h₂, sub_self]
  exact inner_weighted_vsub p h p h
#align euclidean_geometry.dist_affine_combination EuclideanGeometry.dist_affineCombination

/-- Suppose that `c₁` is equidistant from `p₁` and `p₂`, and the same
applies to `c₂`.  Then the vector between `c₁` and `c₂` is orthogonal
to that between `p₁` and `p₂`.  (In two dimensions, this says that the
diagonals of a kite are orthogonal.) -/
theorem inner_vsub_vsub_of_dist_eq_of_dist_eq {c₁ c₂ p₁ p₂ : P} (hc₁ : dist p₁ c₁ = dist p₂ c₁)
    (hc₂ : dist p₁ c₂ = dist p₂ c₂) : ⟪c₂ -ᵥ c₁, p₂ -ᵥ p₁⟫ = 0 :=
  by
  have h : ⟪c₂ -ᵥ c₁ + (c₂ -ᵥ c₁), p₂ -ᵥ p₁⟫ = 0 :=
    by
    conv_lhs =>
      congr
      congr
      rw [← vsub_sub_vsub_cancel_right c₂ c₁ p₁]
      skip
      rw [← vsub_sub_vsub_cancel_right c₂ c₁ p₂]
    rw [sub_add_sub_comm, inner_sub_left]
    conv_lhs =>
      congr
      rw [← vsub_sub_vsub_cancel_right p₂ p₁ c₂]
      skip
      rw [← vsub_sub_vsub_cancel_right p₂ p₁ c₁]
    rw [dist_comm p₁, dist_comm p₂, dist_eq_norm_vsub V _ p₁, dist_eq_norm_vsub V _ p₂, ←
      real_inner_add_sub_eq_zero_iff] at hc₁ hc₂
    simp_rw [← neg_vsub_eq_vsub_rev c₁, ← neg_vsub_eq_vsub_rev c₂, sub_neg_eq_add, neg_add_eq_sub,
      hc₁, hc₂, sub_zero]
  simpa [inner_add_left, ← mul_two, (by norm_num : (2 : ℝ) ≠ 0)] using h
#align euclidean_geometry.inner_vsub_vsub_of_dist_eq_of_dist_eq EuclideanGeometry.inner_vsub_vsub_of_dist_eq_of_dist_eq

/-- The squared distance between points on a line (expressed as a
multiple of a fixed vector added to a point) and another point,
expressed as a quadratic. -/
theorem dist_smul_vadd_sq (r : ℝ) (v : V) (p₁ p₂ : P) :
    dist (r • v +ᵥ p₁) p₂ * dist (r • v +ᵥ p₁) p₂ =
      ⟪v, v⟫ * r * r + 2 * ⟪v, p₁ -ᵥ p₂⟫ * r + ⟪p₁ -ᵥ p₂, p₁ -ᵥ p₂⟫ :=
  by
  rw [dist_eq_norm_vsub V _ p₂, ← real_inner_self_eq_norm_mul_norm, vadd_vsub_assoc,
    real_inner_add_add_self, real_inner_smul_left, real_inner_smul_left, real_inner_smul_right]
  ring
#align euclidean_geometry.dist_smul_vadd_sq EuclideanGeometry.dist_smul_vadd_sq

/-- The condition for two points on a line to be equidistant from
another point. -/
theorem dist_smul_vadd_eq_dist {v : V} (p₁ p₂ : P) (hv : v ≠ 0) (r : ℝ) :
    dist (r • v +ᵥ p₁) p₂ = dist p₁ p₂ ↔ r = 0 ∨ r = -2 * ⟪v, p₁ -ᵥ p₂⟫ / ⟪v, v⟫ :=
  by
  conv_lhs =>
    rw [← mul_self_inj_of_nonneg dist_nonneg dist_nonneg, dist_smul_vadd_sq, ← sub_eq_zero,
      add_sub_assoc, dist_eq_norm_vsub V p₁ p₂, ← real_inner_self_eq_norm_mul_norm, sub_self]
  have hvi : ⟪v, v⟫ ≠ 0 := by simpa using hv
  have hd : discrim ⟪v, v⟫ (2 * ⟪v, p₁ -ᵥ p₂⟫) 0 = 2 * ⟪v, p₁ -ᵥ p₂⟫ * (2 * ⟪v, p₁ -ᵥ p₂⟫) :=
    by
    rw [discrim]
    ring
  rw [quadratic_eq_zero_iff hvi hd, add_left_neg, zero_div, neg_mul_eq_neg_mul, ←
    mul_sub_right_distrib, sub_eq_add_neg, ← mul_two, mul_assoc, mul_div_assoc, mul_div_mul_left,
    mul_div_assoc]
  norm_num
#align euclidean_geometry.dist_smul_vadd_eq_dist EuclideanGeometry.dist_smul_vadd_eq_dist

open AffineSubspace FiniteDimensional

/-- Distances `r₁` `r₂` of `p` from two different points `c₁` `c₂` determine at
most two points `p₁` `p₂` in a two-dimensional subspace containing those points
(two circles intersect in at most two points). -/
theorem eq_of_dist_eq_of_dist_eq_of_mem_of_finrank_eq_two {s : AffineSubspace ℝ P}
    [FiniteDimensional ℝ s.direction] (hd : finrank ℝ s.direction = 2) {c₁ c₂ p₁ p₂ p : P}
    (hc₁s : c₁ ∈ s) (hc₂s : c₂ ∈ s) (hp₁s : p₁ ∈ s) (hp₂s : p₂ ∈ s) (hps : p ∈ s) {r₁ r₂ : ℝ}
    (hc : c₁ ≠ c₂) (hp : p₁ ≠ p₂) (hp₁c₁ : dist p₁ c₁ = r₁) (hp₂c₁ : dist p₂ c₁ = r₁)
    (hpc₁ : dist p c₁ = r₁) (hp₁c₂ : dist p₁ c₂ = r₂) (hp₂c₂ : dist p₂ c₂ = r₂)
    (hpc₂ : dist p c₂ = r₂) : p = p₁ ∨ p = p₂ :=
  by
  have ho : ⟪c₂ -ᵥ c₁, p₂ -ᵥ p₁⟫ = 0 :=
    inner_vsub_vsub_of_dist_eq_of_dist_eq (hp₁c₁.trans hp₂c₁.symm) (hp₁c₂.trans hp₂c₂.symm)
  have hop : ⟪c₂ -ᵥ c₁, p -ᵥ p₁⟫ = 0 :=
    inner_vsub_vsub_of_dist_eq_of_dist_eq (hp₁c₁.trans hpc₁.symm) (hp₁c₂.trans hpc₂.symm)
  let b : Fin 2 → V := ![c₂ -ᵥ c₁, p₂ -ᵥ p₁]
  have hb : LinearIndependent ℝ b :=
    by
    refine' linearIndependent_of_ne_zero_of_inner_eq_zero _ _
    · intro i
      fin_cases i <;> simp [b, hc.symm, hp.symm]
    · intro i j hij
      fin_cases i <;> fin_cases j <;> try exact False.elim (hij rfl)
      · exact ho
      · rw [real_inner_comm]
        exact ho
  have hbs : Submodule.span ℝ (Set.range b) = s.direction :=
    by
    refine' eq_of_le_of_finrank_eq _ _
    · rw [Submodule.span_le, Set.range_subset_iff]
      intro i
      fin_cases i
      · exact vsub_mem_direction hc₂s hc₁s
      · exact vsub_mem_direction hp₂s hp₁s
    · rw [finrank_span_eq_card hb, Fintype.card_fin, hd]
  have hv : ∀ v ∈ s.direction, ∃ t₁ t₂ : ℝ, v = t₁ • (c₂ -ᵥ c₁) + t₂ • (p₂ -ᵥ p₁) :=
    by
    intro v hv
    have hr : Set.range b = {c₂ -ᵥ c₁, p₂ -ᵥ p₁} :=
      by
      have hu : (Finset.univ : Finset (Fin 2)) = {0, 1} := by decide
      rw [← Fintype.coe_image_univ, hu]
      simp
      rfl
    rw [← hbs, hr, Submodule.mem_span_insert] at hv
    rcases hv with ⟨t₁, v', hv', hv⟩
    rw [Submodule.mem_span_singleton] at hv'
    rcases hv' with ⟨t₂, rfl⟩
    exact ⟨t₁, t₂, hv⟩
  rcases hv (p -ᵥ p₁) (vsub_mem_direction hps hp₁s) with ⟨t₁, t₂, hpt⟩
  simp only [hpt, inner_add_right, inner_smul_right, ho, MulZeroClass.mul_zero, add_zero,
    mul_eq_zero, inner_self_eq_zero, vsub_eq_zero_iff_eq, hc.symm, or_false_iff] at hop
  rw [hop, zero_smul, zero_add, ← eq_vadd_iff_vsub_eq] at hpt
  subst hpt
  have hp' : (p₂ -ᵥ p₁ : V) ≠ 0 := by simp [hp.symm]
  have hp₂ : dist ((1 : ℝ) • (p₂ -ᵥ p₁) +ᵥ p₁) c₁ = r₁ := by simp [hp₂c₁]
  rw [← hp₁c₁, dist_smul_vadd_eq_dist _ _ hp'] at hpc₁ hp₂
  simp only [one_ne_zero, false_or_iff] at hp₂
  rw [hp₂.symm] at hpc₁
  cases hpc₁ <;> simp [hpc₁]
#align euclidean_geometry.eq_of_dist_eq_of_dist_eq_of_mem_of_finrank_eq_two EuclideanGeometry.eq_of_dist_eq_of_dist_eq_of_mem_of_finrank_eq_two

/-- Distances `r₁` `r₂` of `p` from two different points `c₁` `c₂` determine at
most two points `p₁` `p₂` in two-dimensional space (two circles intersect in at
most two points). -/
theorem eq_of_dist_eq_of_dist_eq_of_finrank_eq_two [FiniteDimensional ℝ V] (hd : finrank ℝ V = 2)
    {c₁ c₂ p₁ p₂ p : P} {r₁ r₂ : ℝ} (hc : c₁ ≠ c₂) (hp : p₁ ≠ p₂) (hp₁c₁ : dist p₁ c₁ = r₁)
    (hp₂c₁ : dist p₂ c₁ = r₁) (hpc₁ : dist p c₁ = r₁) (hp₁c₂ : dist p₁ c₂ = r₂)
    (hp₂c₂ : dist p₂ c₂ = r₂) (hpc₂ : dist p c₂ = r₂) : p = p₁ ∨ p = p₂ :=
  haveI hd' : finrank ℝ (⊤ : AffineSubspace ℝ P).direction = 2 :=
    by
    rw [direction_top, finrank_top]
    exact hd
  eq_of_dist_eq_of_dist_eq_of_mem_of_finrank_eq_two hd' (mem_top ℝ V _) (mem_top ℝ V _)
    (mem_top ℝ V _) (mem_top ℝ V _) (mem_top ℝ V _) hc hp hp₁c₁ hp₂c₁ hpc₁ hp₁c₂ hp₂c₂ hpc₂
#align euclidean_geometry.eq_of_dist_eq_of_dist_eq_of_finrank_eq_two EuclideanGeometry.eq_of_dist_eq_of_dist_eq_of_finrank_eq_two

variable {V}

/-- The orthogonal projection of a point onto a nonempty affine
subspace, whose direction is complete, as an unbundled function.  This
definition is only intended for use in setting up the bundled version
`orthogonal_projection` and should not be used once that is
defined. -/
def orthogonalProjectionFn (s : AffineSubspace ℝ P) [Nonempty s] [CompleteSpace s.direction]
    (p : P) : P :=
  Classical.choose <|
    inter_eq_singleton_of_nonempty_of_isCompl (nonempty_subtype.mp ‹_›)
      (mk'_nonempty p s.directionᗮ)
      (by
        rw [direction_mk' p s.directionᗮ]
        exact Submodule.isCompl_orthogonal_of_completeSpace)
#align euclidean_geometry.orthogonal_projection_fn EuclideanGeometry.orthogonalProjectionFn

/-- The intersection of the subspace and the orthogonal subspace
through the given point is the `orthogonal_projection_fn` of that
point onto the subspace.  This lemma is only intended for use in
setting up the bundled version and should not be used once that is
defined. -/
theorem inter_eq_singleton_orthogonalProjectionFn {s : AffineSubspace ℝ P} [Nonempty s]
    [CompleteSpace s.direction] (p : P) :
    (s : Set P) ∩ mk' p s.directionᗮ = {orthogonalProjectionFn s p} :=
  Classical.choose_spec <|
    inter_eq_singleton_of_nonempty_of_isCompl (nonempty_subtype.mp ‹_›)
      (mk'_nonempty p s.directionᗮ)
      (by
        rw [direction_mk' p s.directionᗮ]
        exact Submodule.isCompl_orthogonal_of_completeSpace)
#align euclidean_geometry.inter_eq_singleton_orthogonal_projection_fn EuclideanGeometry.inter_eq_singleton_orthogonalProjectionFn

/-- The `orthogonal_projection_fn` lies in the given subspace.  This
lemma is only intended for use in setting up the bundled version and
should not be used once that is defined. -/
theorem orthogonalProjectionFn_mem {s : AffineSubspace ℝ P} [Nonempty s] [CompleteSpace s.direction]
    (p : P) : orthogonalProjectionFn s p ∈ s :=
  by
  rw [← mem_coe, ← Set.singleton_subset_iff, ← inter_eq_singleton_orthogonal_projection_fn]
  exact Set.inter_subset_left _ _
#align euclidean_geometry.orthogonal_projection_fn_mem EuclideanGeometry.orthogonalProjectionFn_mem

/-- The `orthogonal_projection_fn` lies in the orthogonal
subspace.  This lemma is only intended for use in setting up the
bundled version and should not be used once that is defined. -/
theorem orthogonalProjectionFn_mem_orthogonal {s : AffineSubspace ℝ P} [Nonempty s]
    [CompleteSpace s.direction] (p : P) : orthogonalProjectionFn s p ∈ mk' p s.directionᗮ :=
  by
  rw [← mem_coe, ← Set.singleton_subset_iff, ← inter_eq_singleton_orthogonal_projection_fn]
  exact Set.inter_subset_right _ _
#align euclidean_geometry.orthogonal_projection_fn_mem_orthogonal EuclideanGeometry.orthogonalProjectionFn_mem_orthogonal

/-- Subtracting `p` from its `orthogonal_projection_fn` produces a
result in the orthogonal direction.  This lemma is only intended for
use in setting up the bundled version and should not be used once that
is defined. -/
theorem orthogonalProjectionFn_vsub_mem_direction_orthogonal {s : AffineSubspace ℝ P} [Nonempty s]
    [CompleteSpace s.direction] (p : P) : orthogonalProjectionFn s p -ᵥ p ∈ s.directionᗮ :=
  direction_mk' p s.directionᗮ ▸
    vsub_mem_direction (orthogonalProjectionFn_mem_orthogonal p) (self_mem_mk' _ _)
#align euclidean_geometry.orthogonal_projection_fn_vsub_mem_direction_orthogonal EuclideanGeometry.orthogonalProjectionFn_vsub_mem_direction_orthogonal

attribute [local instance] AffineSubspace.toAddTorsor

/-- The orthogonal projection of a point onto a nonempty affine
subspace, whose direction is complete. The corresponding linear map
(mapping a vector to the difference between the projections of two
points whose difference is that vector) is the `orthogonal_projection`
for real inner product spaces, onto the direction of the affine
subspace being projected onto. -/
def orthogonalProjection (s : AffineSubspace ℝ P) [Nonempty s] [CompleteSpace s.direction] :
    P →ᵃ[ℝ] s
    where
  toFun p := ⟨orthogonalProjectionFn s p, orthogonalProjectionFn_mem p⟩
  linear := orthogonalProjection s.direction
  map_vadd' p v :=
    by
    have hs : ((orthogonalProjection s.direction) v : V) +ᵥ orthogonalProjectionFn s p ∈ s :=
      vadd_mem_of_mem_direction (orthogonalProjection s.direction v).2
        (orthogonalProjectionFn_mem p)
    have ho :
      ((orthogonalProjection s.direction) v : V) +ᵥ orthogonalProjectionFn s p ∈
        mk' (v +ᵥ p) s.directionᗮ :=
      by
      rw [← vsub_right_mem_direction_iff_mem (self_mem_mk' _ _) _, direction_mk',
        vsub_vadd_eq_vsub_sub, vadd_vsub_assoc, add_comm, add_sub_assoc]
      refine' Submodule.add_mem _ (orthogonal_projection_fn_vsub_mem_direction_orthogonal p) _
      rw [Submodule.mem_orthogonal']
      intro w hw
      rw [← neg_sub, inner_neg_left, orthogonalProjection_inner_eq_zero _ w hw, neg_zero]
    have hm :
      ((orthogonalProjection s.direction) v : V) +ᵥ orthogonalProjectionFn s p ∈
        ({orthogonalProjectionFn s (v +ᵥ p)} : Set P) :=
      by
      rw [← inter_eq_singleton_orthogonal_projection_fn (v +ᵥ p)]
      exact Set.mem_inter hs ho
    rw [Set.mem_singleton_iff] at hm
    ext
    exact hm.symm
#align euclidean_geometry.orthogonal_projection EuclideanGeometry.orthogonalProjection

@[simp]
theorem orthogonalProjectionFn_eq {s : AffineSubspace ℝ P} [Nonempty s] [CompleteSpace s.direction]
    (p : P) : orthogonalProjectionFn s p = orthogonalProjection s p :=
  rfl
#align euclidean_geometry.orthogonal_projection_fn_eq EuclideanGeometry.orthogonalProjectionFn_eq

/-- The linear map corresponding to `orthogonal_projection`. -/
@[simp]
theorem orthogonalProjection_linear {s : AffineSubspace ℝ P} [Nonempty s]
    [CompleteSpace s.direction] :
    (orthogonalProjection s).linear = orthogonalProjection s.direction :=
  rfl
#align euclidean_geometry.orthogonal_projection_linear EuclideanGeometry.orthogonalProjection_linear

/-- The intersection of the subspace and the orthogonal subspace
through the given point is the `orthogonal_projection` of that point
onto the subspace. -/
theorem inter_eq_singleton_orthogonalProjection {s : AffineSubspace ℝ P} [Nonempty s]
    [CompleteSpace s.direction] (p : P) :
    (s : Set P) ∩ mk' p s.directionᗮ = {orthogonalProjection s p} :=
  by
  rw [← orthogonalProjectionFn_eq]
  exact inter_eq_singleton_orthogonal_projection_fn p
#align euclidean_geometry.inter_eq_singleton_orthogonal_projection EuclideanGeometry.inter_eq_singleton_orthogonalProjection

/-- The `orthogonal_projection` lies in the given subspace. -/
theorem orthogonalProjection_mem {s : AffineSubspace ℝ P} [Nonempty s] [CompleteSpace s.direction]
    (p : P) : ↑(orthogonalProjection s p) ∈ s :=
  (orthogonalProjection s p).2
#align euclidean_geometry.orthogonal_projection_mem EuclideanGeometry.orthogonalProjection_mem

/-- The `orthogonal_projection` lies in the orthogonal subspace. -/
theorem orthogonalProjection_mem_orthogonal (s : AffineSubspace ℝ P) [Nonempty s]
    [CompleteSpace s.direction] (p : P) : ↑(orthogonalProjection s p) ∈ mk' p s.directionᗮ :=
  orthogonalProjectionFn_mem_orthogonal p
#align euclidean_geometry.orthogonal_projection_mem_orthogonal EuclideanGeometry.orthogonalProjection_mem_orthogonal

/-- Subtracting a point in the given subspace from the
`orthogonal_projection` produces a result in the direction of the
given subspace. -/
theorem orthogonalProjection_vsub_mem_direction {s : AffineSubspace ℝ P} [Nonempty s]
    [CompleteSpace s.direction] {p1 : P} (p2 : P) (hp1 : p1 ∈ s) :
    ↑(orthogonalProjection s p2 -ᵥ ⟨p1, hp1⟩ : s.direction) ∈ s.direction :=
  (orthogonalProjection s p2 -ᵥ ⟨p1, hp1⟩ : s.direction).2
#align euclidean_geometry.orthogonal_projection_vsub_mem_direction EuclideanGeometry.orthogonalProjection_vsub_mem_direction

/-- Subtracting the `orthogonal_projection` from a point in the given
subspace produces a result in the direction of the given subspace. -/
theorem vsub_orthogonalProjection_mem_direction {s : AffineSubspace ℝ P} [Nonempty s]
    [CompleteSpace s.direction] {p1 : P} (p2 : P) (hp1 : p1 ∈ s) :
    ↑((⟨p1, hp1⟩ : s) -ᵥ orthogonalProjection s p2 : s.direction) ∈ s.direction :=
  ((⟨p1, hp1⟩ : s) -ᵥ orthogonalProjection s p2 : s.direction).2
#align euclidean_geometry.vsub_orthogonal_projection_mem_direction EuclideanGeometry.vsub_orthogonalProjection_mem_direction

/-- A point equals its orthogonal projection if and only if it lies in
the subspace. -/
theorem orthogonalProjection_eq_self_iff {s : AffineSubspace ℝ P} [Nonempty s]
    [CompleteSpace s.direction] {p : P} : ↑(orthogonalProjection s p) = p ↔ p ∈ s :=
  by
  constructor
  · exact fun h => h ▸ orthogonal_projection_mem p
  · intro h
    have hp : p ∈ (s : Set P) ∩ mk' p s.directionᗮ := ⟨h, self_mem_mk' p _⟩
    rw [inter_eq_singleton_orthogonal_projection p] at hp
    symm
    exact hp
#align euclidean_geometry.orthogonal_projection_eq_self_iff EuclideanGeometry.orthogonalProjection_eq_self_iff

@[simp]
theorem orthogonalProjection_mem_subspace_eq_self {s : AffineSubspace ℝ P} [Nonempty s]
    [CompleteSpace s.direction] (p : s) : orthogonalProjection s p = p :=
  by
  ext
  rw [orthogonalProjection_eq_self_iff]
  exact p.2
#align euclidean_geometry.orthogonal_projection_mem_subspace_eq_self EuclideanGeometry.orthogonalProjection_mem_subspace_eq_self

/-- Orthogonal projection is idempotent. -/
@[simp]
theorem orthogonalProjection_orthogonalProjection (s : AffineSubspace ℝ P) [Nonempty s]
    [CompleteSpace s.direction] (p : P) :
    orthogonalProjection s (orthogonalProjection s p) = orthogonalProjection s p :=
  by
  ext
  rw [orthogonalProjection_eq_self_iff]
  exact orthogonal_projection_mem p
#align euclidean_geometry.orthogonal_projection_orthogonal_projection EuclideanGeometry.orthogonalProjection_orthogonalProjection

theorem eq_orthogonalProjection_of_eq_subspace {s s' : AffineSubspace ℝ P} [Nonempty s]
    [Nonempty s'] [CompleteSpace s.direction] [CompleteSpace s'.direction] (h : s = s') (p : P) :
    (orthogonalProjection s p : P) = (orthogonalProjection s' p : P) :=
  by
  change orthogonalProjectionFn s p = orthogonalProjectionFn s' p
  congr
  exact h
#align euclidean_geometry.eq_orthogonal_projection_of_eq_subspace EuclideanGeometry.eq_orthogonalProjection_of_eq_subspace

/-- The distance to a point's orthogonal projection is 0 iff it lies in the subspace. -/
theorem dist_orthogonalProjection_eq_zero_iff {s : AffineSubspace ℝ P} [Nonempty s]
    [CompleteSpace s.direction] {p : P} : dist p (orthogonalProjection s p) = 0 ↔ p ∈ s := by
  rw [dist_comm, dist_eq_zero, orthogonalProjection_eq_self_iff]
#align euclidean_geometry.dist_orthogonal_projection_eq_zero_iff EuclideanGeometry.dist_orthogonalProjection_eq_zero_iff

/-- The distance between a point and its orthogonal projection is
nonzero if it does not lie in the subspace. -/
theorem dist_orthogonalProjection_ne_zero_of_not_mem {s : AffineSubspace ℝ P} [Nonempty s]
    [CompleteSpace s.direction] {p : P} (hp : p ∉ s) : dist p (orthogonalProjection s p) ≠ 0 :=
  mt dist_orthogonalProjection_eq_zero_iff.mp hp
#align euclidean_geometry.dist_orthogonal_projection_ne_zero_of_not_mem EuclideanGeometry.dist_orthogonalProjection_ne_zero_of_not_mem

/-- Subtracting `p` from its `orthogonal_projection` produces a result
in the orthogonal direction. -/
theorem orthogonalProjection_vsub_mem_direction_orthogonal (s : AffineSubspace ℝ P) [Nonempty s]
    [CompleteSpace s.direction] (p : P) : (orthogonalProjection s p : P) -ᵥ p ∈ s.directionᗮ :=
  orthogonalProjectionFn_vsub_mem_direction_orthogonal p
#align euclidean_geometry.orthogonal_projection_vsub_mem_direction_orthogonal EuclideanGeometry.orthogonalProjection_vsub_mem_direction_orthogonal

/-- Subtracting the `orthogonal_projection` from `p` produces a result
in the orthogonal direction. -/
theorem vsub_orthogonalProjection_mem_direction_orthogonal (s : AffineSubspace ℝ P) [Nonempty s]
    [CompleteSpace s.direction] (p : P) : p -ᵥ orthogonalProjection s p ∈ s.directionᗮ :=
  direction_mk' p s.directionᗮ ▸
    vsub_mem_direction (self_mem_mk' _ _) (orthogonalProjection_mem_orthogonal s p)
#align euclidean_geometry.vsub_orthogonal_projection_mem_direction_orthogonal EuclideanGeometry.vsub_orthogonalProjection_mem_direction_orthogonal

/-- Subtracting the `orthogonal_projection` from `p` produces a result in the kernel of the linear
part of the orthogonal projection. -/
theorem orthogonalProjection_vsub_orthogonalProjection (s : AffineSubspace ℝ P) [Nonempty s]
    [CompleteSpace s.direction] (p : P) :
    orthogonalProjection s.direction (p -ᵥ orthogonalProjection s p) = 0 :=
  by
  apply orthogonalProjection_mem_subspace_orthogonal_complement_eq_zero
  intro c hc
  rw [← neg_vsub_eq_vsub_rev, inner_neg_right,
    orthogonal_projection_vsub_mem_direction_orthogonal s p c hc, neg_zero]
#align euclidean_geometry.orthogonal_projection_vsub_orthogonal_projection EuclideanGeometry.orthogonalProjection_vsub_orthogonalProjection

/-- Adding a vector to a point in the given subspace, then taking the
orthogonal projection, produces the original point if the vector was
in the orthogonal direction. -/
theorem orthogonalProjection_vadd_eq_self {s : AffineSubspace ℝ P} [Nonempty s]
    [CompleteSpace s.direction] {p : P} (hp : p ∈ s) {v : V} (hv : v ∈ s.directionᗮ) :
    orthogonalProjection s (v +ᵥ p) = ⟨p, hp⟩ :=
  by
  have h := vsub_orthogonal_projection_mem_direction_orthogonal s (v +ᵥ p)
  rw [vadd_vsub_assoc, Submodule.add_mem_iff_right _ hv] at h
  refine' (eq_of_vsub_eq_zero _).symm
  ext
  refine' Submodule.disjoint_def.1 s.direction.orthogonal_disjoint _ _ h
  exact (_ : s.direction).2
#align euclidean_geometry.orthogonal_projection_vadd_eq_self EuclideanGeometry.orthogonalProjection_vadd_eq_self

/-- Adding a vector to a point in the given subspace, then taking the
orthogonal projection, produces the original point if the vector is a
multiple of the result of subtracting a point's orthogonal projection
from that point. -/
theorem orthogonalProjection_vadd_smul_vsub_orthogonalProjection {s : AffineSubspace ℝ P}
    [Nonempty s] [CompleteSpace s.direction] {p1 : P} (p2 : P) (r : ℝ) (hp : p1 ∈ s) :
    orthogonalProjection s (r • (p2 -ᵥ orthogonalProjection s p2 : V) +ᵥ p1) = ⟨p1, hp⟩ :=
  orthogonalProjection_vadd_eq_self hp
    (Submodule.smul_mem _ _ (vsub_orthogonalProjection_mem_direction_orthogonal s _))
#align euclidean_geometry.orthogonal_projection_vadd_smul_vsub_orthogonal_projection EuclideanGeometry.orthogonalProjection_vadd_smul_vsub_orthogonalProjection

/-- The square of the distance from a point in `s` to `p2` equals the
sum of the squares of the distances of the two points to the
`orthogonal_projection`. -/
theorem dist_sq_eq_dist_orthogonalProjection_sq_add_dist_orthogonalProjection_sq
    {s : AffineSubspace ℝ P} [Nonempty s] [CompleteSpace s.direction] {p1 : P} (p2 : P)
    (hp1 : p1 ∈ s) :
    dist p1 p2 * dist p1 p2 =
      dist p1 (orthogonalProjection s p2) * dist p1 (orthogonalProjection s p2) +
        dist p2 (orthogonalProjection s p2) * dist p2 (orthogonalProjection s p2) :=
  by
  rw [dist_comm p2 _, dist_eq_norm_vsub V p1 _, dist_eq_norm_vsub V p1 _, dist_eq_norm_vsub V _ p2,
    ← vsub_add_vsub_cancel p1 (orthogonalProjection s p2) p2,
    norm_add_sq_eq_norm_sq_add_norm_sq_iff_real_inner_eq_zero]
  exact
    Submodule.inner_right_of_mem_orthogonal (vsub_orthogonal_projection_mem_direction p2 hp1)
      (orthogonal_projection_vsub_mem_direction_orthogonal s p2)
#align euclidean_geometry.dist_sq_eq_dist_orthogonal_projection_sq_add_dist_orthogonal_projection_sq EuclideanGeometry.dist_sq_eq_dist_orthogonalProjection_sq_add_dist_orthogonalProjection_sq

/-- The square of the distance between two points constructed by
adding multiples of the same orthogonal vector to points in the same
subspace. -/
theorem dist_sq_smul_orthogonal_vadd_smul_orthogonal_vadd {s : AffineSubspace ℝ P} {p1 p2 : P}
    (hp1 : p1 ∈ s) (hp2 : p2 ∈ s) (r1 r2 : ℝ) {v : V} (hv : v ∈ s.directionᗮ) :
    dist (r1 • v +ᵥ p1) (r2 • v +ᵥ p2) * dist (r1 • v +ᵥ p1) (r2 • v +ᵥ p2) =
      dist p1 p2 * dist p1 p2 + (r1 - r2) * (r1 - r2) * (‖v‖ * ‖v‖) :=
  calc
    dist (r1 • v +ᵥ p1) (r2 • v +ᵥ p2) * dist (r1 • v +ᵥ p1) (r2 • v +ᵥ p2) =
        ‖p1 -ᵥ p2 + (r1 - r2) • v‖ * ‖p1 -ᵥ p2 + (r1 - r2) • v‖ :=
      by
      rw [dist_eq_norm_vsub V (r1 • v +ᵥ p1), vsub_vadd_eq_vsub_sub, vadd_vsub_assoc, sub_smul,
        add_comm, add_sub_assoc]
    _ = ‖p1 -ᵥ p2‖ * ‖p1 -ᵥ p2‖ + ‖(r1 - r2) • v‖ * ‖(r1 - r2) • v‖ :=
      (norm_add_sq_eq_norm_sq_add_norm_sq_real
        (Submodule.inner_right_of_mem_orthogonal (vsub_mem_direction hp1 hp2)
          (Submodule.smul_mem _ _ hv)))
    _ = ‖(p1 -ᵥ p2 : V)‖ * ‖(p1 -ᵥ p2 : V)‖ + |r1 - r2| * |r1 - r2| * ‖v‖ * ‖v‖ :=
      by
      rw [norm_smul, Real.norm_eq_abs]
      ring
    _ = dist p1 p2 * dist p1 p2 + (r1 - r2) * (r1 - r2) * (‖v‖ * ‖v‖) := by
      rw [dist_eq_norm_vsub V p1, abs_mul_abs_self, mul_assoc]

#align euclidean_geometry.dist_sq_smul_orthogonal_vadd_smul_orthogonal_vadd EuclideanGeometry.dist_sq_smul_orthogonal_vadd_smul_orthogonal_vadd

/-- Reflection in an affine subspace, which is expected to be nonempty
and complete.  The word "reflection" is sometimes understood to mean
specifically reflection in a codimension-one subspace, and sometimes
more generally to cover operations such as reflection in a point.  The
definition here, of reflection in an affine subspace, is a more
general sense of the word that includes both those common cases. -/
def reflection (s : AffineSubspace ℝ P) [Nonempty s] [CompleteSpace s.direction] : P ≃ᵃⁱ[ℝ] P :=
  AffineIsometryEquiv.mk' (fun p => ↑(orthogonalProjection s p) -ᵥ p +ᵥ orthogonalProjection s p)
    (reflection s.direction) (↑(Classical.arbitrary s))
    (by
      intro p
      let v := p -ᵥ ↑(Classical.arbitrary s)
      let a : V := _root_.orthogonal_projection s.direction v
      let b : P := ↑(Classical.arbitrary s)
      have key : a +ᵥ b -ᵥ (v +ᵥ b) +ᵥ (a +ᵥ b) = a + a - v +ᵥ (b -ᵥ b +ᵥ b) :=
        by
        rw [← add_vadd, vsub_vadd_eq_vsub_sub, vsub_vadd, vadd_vsub]
        congr 1
        abel
      have : p = v +ᵥ ↑(Classical.arbitrary s) := (vsub_vadd p ↑(Classical.arbitrary s)).symm
      simpa only [coe_vadd, reflection_apply, AffineMap.map_vadd, orthogonal_projection_linear,
        orthogonalProjection_mem_subspace_eq_self, vadd_vsub, ContinuousLinearMap.coe_coe,
        ContinuousLinearEquiv.coe_coe, this] using key)
#align euclidean_geometry.reflection EuclideanGeometry.reflection

/-- The result of reflecting. -/
theorem reflection_apply (s : AffineSubspace ℝ P) [Nonempty s] [CompleteSpace s.direction] (p : P) :
    reflection s p = ↑(orthogonalProjection s p) -ᵥ p +ᵥ orthogonalProjection s p :=
  rfl
#align euclidean_geometry.reflection_apply EuclideanGeometry.reflection_apply

theorem eq_reflection_of_eq_subspace {s s' : AffineSubspace ℝ P} [Nonempty s] [Nonempty s']
    [CompleteSpace s.direction] [CompleteSpace s'.direction] (h : s = s') (p : P) :
    (reflection s p : P) = (reflection s' p : P) := by subst h
#align euclidean_geometry.eq_reflection_of_eq_subspace EuclideanGeometry.eq_reflection_of_eq_subspace

/-- Reflecting twice in the same subspace. -/
@[simp]
theorem reflection_reflection (s : AffineSubspace ℝ P) [Nonempty s] [CompleteSpace s.direction]
    (p : P) : reflection s (reflection s p) = p :=
  by
  have :
    ∀ a : s,
      ∀ b : V,
        (_root_.orthogonal_projection s.direction) b = 0 →
          reflection s (reflection s (b +ᵥ a)) = b +ᵥ a :=
    by
    intro a b h
    have : (a : P) -ᵥ (b +ᵥ a) = -b := by rw [vsub_vadd_eq_vsub_sub, vsub_self, zero_sub]
    simp [reflection, h, this]
  rw [← vsub_vadd p (orthogonalProjection s p)]
  exact this (orthogonalProjection s p) _ (orthogonal_projection_vsub_orthogonal_projection s p)
#align euclidean_geometry.reflection_reflection EuclideanGeometry.reflection_reflection

/-- Reflection is its own inverse. -/
@[simp]
theorem reflection_symm (s : AffineSubspace ℝ P) [Nonempty s] [CompleteSpace s.direction] :
    (reflection s).symm = reflection s := by
  ext
  rw [← (reflection s).Injective.eq_iff]
  simp
#align euclidean_geometry.reflection_symm EuclideanGeometry.reflection_symm

/-- Reflection is involutive. -/
theorem reflection_involutive (s : AffineSubspace ℝ P) [Nonempty s] [CompleteSpace s.direction] :
    Function.Involutive (reflection s) :=
  reflection_reflection s
#align euclidean_geometry.reflection_involutive EuclideanGeometry.reflection_involutive

/-- A point is its own reflection if and only if it is in the
subspace. -/
theorem reflection_eq_self_iff {s : AffineSubspace ℝ P} [Nonempty s] [CompleteSpace s.direction]
    (p : P) : reflection s p = p ↔ p ∈ s :=
  by
  rw [← orthogonalProjection_eq_self_iff, reflection_apply]
  constructor
  · intro h
    rw [← @vsub_eq_zero_iff_eq V, vadd_vsub_assoc, ← two_smul ℝ (↑(orthogonalProjection s p) -ᵥ p),
      smul_eq_zero] at h
    norm_num at h
    exact h
  · intro h
    simp [h]
#align euclidean_geometry.reflection_eq_self_iff EuclideanGeometry.reflection_eq_self_iff

/-- Reflecting a point in two subspaces produces the same result if
and only if the point has the same orthogonal projection in each of
those subspaces. -/
theorem reflection_eq_iff_orthogonalProjection_eq (s₁ s₂ : AffineSubspace ℝ P) [Nonempty s₁]
    [Nonempty s₂] [CompleteSpace s₁.direction] [CompleteSpace s₂.direction] (p : P) :
    reflection s₁ p = reflection s₂ p ↔
      (orthogonalProjection s₁ p : P) = orthogonalProjection s₂ p :=
  by
  rw [reflection_apply, reflection_apply]
  constructor
  · intro h
    rw [← @vsub_eq_zero_iff_eq V, vsub_vadd_eq_vsub_sub, vadd_vsub_assoc, add_comm, add_sub_assoc,
      vsub_sub_vsub_cancel_right, ←
      two_smul ℝ ((orthogonalProjection s₁ p : P) -ᵥ orthogonalProjection s₂ p), smul_eq_zero] at h
    norm_num at h
    exact h
  · intro h
    rw [h]
#align euclidean_geometry.reflection_eq_iff_orthogonal_projection_eq EuclideanGeometry.reflection_eq_iff_orthogonalProjection_eq

/-- The distance between `p₁` and the reflection of `p₂` equals that
between the reflection of `p₁` and `p₂`. -/
theorem dist_reflection (s : AffineSubspace ℝ P) [Nonempty s] [CompleteSpace s.direction]
    (p₁ p₂ : P) : dist p₁ (reflection s p₂) = dist (reflection s p₁) p₂ :=
  by
  conv_lhs => rw [← reflection_reflection s p₁]
  exact (reflection s).dist_map _ _
#align euclidean_geometry.dist_reflection EuclideanGeometry.dist_reflection

/-- A point in the subspace is equidistant from another point and its
reflection. -/
theorem dist_reflection_eq_of_mem (s : AffineSubspace ℝ P) [Nonempty s] [CompleteSpace s.direction]
    {p₁ : P} (hp₁ : p₁ ∈ s) (p₂ : P) : dist p₁ (reflection s p₂) = dist p₁ p₂ :=
  by
  rw [← reflection_eq_self_iff p₁] at hp₁
  convert(reflection s).dist_map p₁ p₂
  rw [hp₁]
#align euclidean_geometry.dist_reflection_eq_of_mem EuclideanGeometry.dist_reflection_eq_of_mem

/-- The reflection of a point in a subspace is contained in any larger
subspace containing both the point and the subspace reflected in. -/
theorem reflection_mem_of_le_of_mem {s₁ s₂ : AffineSubspace ℝ P} [Nonempty s₁]
    [CompleteSpace s₁.direction] (hle : s₁ ≤ s₂) {p : P} (hp : p ∈ s₂) : reflection s₁ p ∈ s₂ :=
  by
  rw [reflection_apply]
  have ho : ↑(orthogonalProjection s₁ p) ∈ s₂ := hle (orthogonal_projection_mem p)
  exact vadd_mem_of_mem_direction (vsub_mem_direction ho hp) ho
#align euclidean_geometry.reflection_mem_of_le_of_mem EuclideanGeometry.reflection_mem_of_le_of_mem

/-- Reflecting an orthogonal vector plus a point in the subspace
produces the negation of that vector plus the point. -/
theorem reflection_orthogonal_vadd {s : AffineSubspace ℝ P} [Nonempty s] [CompleteSpace s.direction]
    {p : P} (hp : p ∈ s) {v : V} (hv : v ∈ s.directionᗮ) : reflection s (v +ᵥ p) = -v +ᵥ p :=
  by
  rw [reflection_apply, orthogonal_projection_vadd_eq_self hp hv, vsub_vadd_eq_vsub_sub]
  simp
#align euclidean_geometry.reflection_orthogonal_vadd EuclideanGeometry.reflection_orthogonal_vadd

/-- Reflecting a vector plus a point in the subspace produces the
negation of that vector plus the point if the vector is a multiple of
the result of subtracting a point's orthogonal projection from that
point. -/
theorem reflection_vadd_smul_vsub_orthogonalProjection {s : AffineSubspace ℝ P} [Nonempty s]
    [CompleteSpace s.direction] {p₁ : P} (p₂ : P) (r : ℝ) (hp₁ : p₁ ∈ s) :
    reflection s (r • (p₂ -ᵥ orthogonalProjection s p₂) +ᵥ p₁) =
      -(r • (p₂ -ᵥ orthogonalProjection s p₂)) +ᵥ p₁ :=
  reflection_orthogonal_vadd hp₁
    (Submodule.smul_mem _ _ (vsub_orthogonalProjection_mem_direction_orthogonal s _))
#align euclidean_geometry.reflection_vadd_smul_vsub_orthogonal_projection EuclideanGeometry.reflection_vadd_smul_vsub_orthogonalProjection

end EuclideanGeometry


/-
Copyright (c) 2021 Yury Kudryashov. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yury Kudryashov
-/
import analysis.box_integral.partition.additive
import measure_theory.measure.lebesgue

/-!
# Box-additive functions defined by measures

In this file we prove a few simple facts about rectangular boxes, partitions, and measures:

- given a box `I : box ι`, its coercion to `set (ι → ℝ)` and `I.Icc` are measurable sets;
- if `μ` is a locally finite measure, then `(I : set (ι → ℝ))` and `I.Icc` have finite measure;
- if `μ` is a locally finite measure, then `λ J, (μ J).to_real` is a box additive function.

For the last statement, we both prove it as a proposition and define a bundled
`box_integral.box_additive` function.

### Tags

rectangular box, measure
-/

open set
noncomputable theory
open_locale ennreal big_operators classical box_integral

variables {ι : Type*}

namespace box_integral

open measure_theory

namespace box

lemma measure_Icc_lt_top (I : box ι) (μ : measure (ι → ℝ)) [is_locally_finite_measure μ] :
  μ I.Icc < ∞ :=
show μ (Icc I.lower I.upper) < ∞, from I.is_compact_Icc.measure_lt_top

lemma measure_coe_lt_top (I : box ι) (μ : measure (ι → ℝ)) [is_locally_finite_measure μ] :
  μ I < ∞ :=
(measure_mono $ coe_subset_Icc).trans_lt (I.measure_Icc_lt_top μ)

variables [fintype ι] (I : box ι)

lemma measurable_set_coe : measurable_set (I : set (ι → ℝ)) :=
begin
  rw [coe_eq_pi],
  haveI := fintype.to_encodable ι,
  exact measurable_set.univ_pi (λ i, measurable_set_Ioc)
end

lemma measurable_set_Icc : measurable_set I.Icc := measurable_set_Icc

lemma measurable_set_Ioo : measurable_set I.Ioo :=
(measurable_set_pi (set.finite.of_fintype _).countable).2 $ or.inl $ λ i hi, measurable_set_Ioo

lemma coe_ae_eq_Icc : (I : set (ι → ℝ)) =ᵐ[volume] I.Icc :=
by { rw coe_eq_pi, exact measure.univ_pi_Ioc_ae_eq_Icc }

lemma Ioo_ae_eq_Icc : I.Ioo =ᵐ[volume] I.Icc :=
measure.univ_pi_Ioo_ae_eq_Icc

end box

lemma prepartition.measure_Union_to_real [fintype ι] {I : box ι} (π : prepartition I)
  (μ : measure (ι → ℝ)) [is_locally_finite_measure μ] :
  (μ π.Union).to_real = ∑ J in π.boxes, (μ J).to_real :=
begin
  erw [← ennreal.to_real_sum, π.Union_def, measure_bUnion_finset π.pairwise_disjoint],
  exacts [λ J hJ, J.measurable_set_coe, λ J hJ, (J.measure_coe_lt_top μ).ne]
end

end box_integral

open box_integral box_integral.box

variables [fintype ι]

namespace measure_theory

namespace measure

/-- If `μ` is a locally finite measure on `ℝⁿ`, then `λ J, (μ J).to_real` is a box-additive
function. -/
@[simps] def to_box_additive (μ : measure (ι → ℝ)) [is_locally_finite_measure μ] :
  ι →ᵇᵃ[⊤] ℝ :=
{ to_fun := λ J, (μ J).to_real,
  sum_partition_boxes' := λ J hJ π hπ, by rw [← π.measure_Union_to_real, hπ.Union_eq] }

end measure

end measure_theory

namespace box_integral

open measure_theory

namespace box

@[simp] lemma volume_apply (I : box ι) :
  (volume : measure (ι → ℝ)).to_box_additive I = ∏ i, (I.upper i - I.lower i) :=
by rw [measure.to_box_additive_apply, coe_eq_pi, real.volume_pi_Ioc_to_real I.lower_le_upper]

lemma volume_face_mul {n} (i : fin (n + 1)) (I : box (fin (n + 1))) :
  (∏ j, ((I.face i).upper j - (I.face i).lower j)) * (I.upper i - I.lower i) =
    ∏ j, (I.upper j - I.lower j) :=
by simp only [face_lower, face_upper, (∘), fin.prod_univ_succ_above _ i, mul_comm]

end box

namespace box_additive_map

/-- Box-additive map sending each box `I` to the continuous linear endomorphism
`x ↦ (volume I).to_real • x`. -/
protected def volume {E : Type*} [normed_group E] [normed_space ℝ E] :
  ι →ᵇᵃ (E →L[ℝ] E) :=
(volume : measure (ι → ℝ)).to_box_additive.to_smul

lemma volume_apply {E : Type*} [normed_group E] [normed_space ℝ E] (I : box ι) (x : E) :
  box_additive_map.volume I x = (∏ j, (I.upper j - I.lower j)) • x :=
congr_arg2 (•) I.volume_apply rfl

end box_additive_map

end box_integral


inductive Expr where
  | nat  : Nat → Expr
  | plus : Expr → Expr → Expr
  | bool : Bool → Expr
  | and  : Expr → Expr → Expr

inductive Ty where
  | nat
  | bool
  deriving DecidableEq

inductive HasType : Expr → Ty → Prop
  | nat  : HasType (.nat v) .nat
  | plus : HasType a .nat → HasType b .nat → HasType (.plus a b) .nat
  | bool : HasType (.bool v) .bool
  | and  : HasType a .bool → HasType b .bool → HasType (.and a b) .bool

inductive Maybe (p : α → Prop) where
  | unknown
  | found : (a : α) → p a → Maybe p

notation "{{ " x " | " p " }}" => Maybe (fun x => p)

def Expr.typeCheck (e : Expr) : {{ ty | HasType e ty }} :=
  match e with
  | nat ..   => .found .nat .nat
  | bool ..  => .found .bool .bool
  | plus a b =>
    match a.typeCheck, b.typeCheck with
    | .found .nat h₁, .found .nat h₂ => .found .nat (.plus h₁ h₂)
    | _, _ => .unknown
  | and a b =>
    match a.typeCheck, b.typeCheck with
    | .found .bool h₁, .found .bool h₂ => .found .bool (.and h₁ h₂)
    | _, _ => .unknown

theorem HasType.det (h₁ : HasType e t₁) (h₂ : HasType e t₂) : t₁ = t₂ := by
  cases h₁ <;> cases h₂ <;> rfl

-- TODO: for simplifying the following proof we need: ematching for forward reasoning, and `match` blast for case analysis

theorem Expr.typeCheck_complete {e : Expr} : e.typeCheck = .unknown → ¬ HasType e t := by
  induction e with simp [typeCheck]
  | plus a b iha ihb =>
    revert iha ihb
    cases typeCheck a <;> cases typeCheck b <;> simp <;> intros <;> intro h <;> cases h <;> try contradiction
    rename_i ty₁ _ ty₂ _ h _ _
    cases ty₁ <;> cases ty₂ <;> simp at h
    . have := HasType.det ‹HasType b Ty.bool› ‹HasType b Ty.nat›; contradiction
    . have := HasType.det ‹HasType a Ty.bool› ‹HasType a Ty.nat›; contradiction
    . have := HasType.det ‹HasType a Ty.bool› ‹HasType a Ty.nat›; contradiction
  | and a b iha ihb =>
    revert iha ihb
    cases typeCheck a <;> cases typeCheck b <;> simp <;> intros <;> intro h <;> cases h <;> try contradiction
    rename_i ty₁ _ ty₂ _ h _ _
    cases ty₁ <;> cases ty₂ <;> simp at h
    . have := HasType.det ‹HasType b Ty.bool› ‹HasType b Ty.nat›; contradiction
    . have := HasType.det ‹HasType a Ty.bool› ‹HasType a Ty.nat›; contradiction
    . have := HasType.det ‹HasType b Ty.bool› ‹HasType b Ty.nat›; contradiction

instance (e : Expr) (t : Ty) : Decidable (HasType e t) :=
  match h' : e.typeCheck with
  | .found t' ht' =>
    if heq : t = t' then
      isTrue (heq ▸ ht')
    else
      isFalse fun ht => heq (HasType.det ht ht')
  | .unknown => isFalse (Expr.typeCheck_complete h')


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

import linear_algebra.charpoly.basic
import linear_algebra.matrix.basis

/-!

# Characteristic polynomial

## Main result

* `linear_map.charpoly_to_matrix f` : `charpoly f` is the characteristic polynomial of the matrix
of `f` in any basis.

-/

universes u v w

variables {R : Type u} {M : Type v} [comm_ring R] [nontrivial R]
variables [add_comm_group M] [module R M] [module.free R M] [module.finite R M] (f : M →ₗ[R] M)

open_locale classical matrix

noncomputable theory

open module.free polynomial matrix

namespace linear_map

section basic

/-- `charpoly f` is the characteristic polynomial of the matrix of `f` in any basis. -/
@[simp] lemma charpoly_to_matrix {ι : Type w} [fintype ι] (b : basis ι R M) :
  (to_matrix b b f).charpoly = f.charpoly :=
begin
  set A := to_matrix b b f,
  set b' := choose_basis R M,
  set ι' := choose_basis_index R M,
  set A' := to_matrix b' b' f,
  set e := basis.index_equiv b b',
  set φ := reindex_linear_equiv R R e e,
  set φ₁ := reindex_linear_equiv R R e (equiv.refl ι'),
  set φ₂ := reindex_linear_equiv R R (equiv.refl ι') (equiv.refl ι'),
  set φ₃ := reindex_linear_equiv R R (equiv.refl ι') e,
  set P := b.to_matrix b',
  set Q := b'.to_matrix b,

  have hPQ : C.map_matrix (φ₁ P) ⬝ (C.map_matrix (φ₃ Q)) = 1,
  { rw [ring_hom.map_matrix_apply, ring_hom.map_matrix_apply, ← matrix.map_mul,
      @reindex_linear_equiv_mul _ ι' _ _ _ _ R R, basis.to_matrix_mul_to_matrix_flip,
      reindex_linear_equiv_one, ← ring_hom.map_matrix_apply, ring_hom.map_one] },

  calc A.charpoly = (reindex e e A).charpoly : (charpoly_reindex _ _).symm
  ... = (scalar ι' X - C.map_matrix (φ A)).det : rfl
  ... = (scalar ι' X - C.map_matrix (φ (P ⬝ A' ⬝ Q))).det :
    by rw [basis_to_matrix_mul_linear_map_to_matrix_mul_basis_to_matrix]
  ... = (scalar ι' X - C.map_matrix (φ₁ P ⬝ φ₂ A' ⬝ φ₃ Q)).det :
    by rw [reindex_linear_equiv_mul, reindex_linear_equiv_mul]
  ... = (scalar ι' X - (C.map_matrix (φ₁ P) ⬝ C.map_matrix A' ⬝ C.map_matrix (φ₃ Q))).det : by simp
  ... = (scalar ι' X ⬝ C.map_matrix (φ₁ P) ⬝ (C.map_matrix (φ₃ Q)) -
    (C.map_matrix (φ₁ P) ⬝ C.map_matrix A' ⬝ C.map_matrix (φ₃ Q))).det :
      by { rw [matrix.mul_assoc ((scalar ι') X), hPQ, matrix.mul_one] }
  ... = (C.map_matrix (φ₁ P) ⬝ scalar ι' X ⬝ (C.map_matrix (φ₃ Q)) -
    (C.map_matrix (φ₁ P) ⬝ C.map_matrix A' ⬝ C.map_matrix (φ₃ Q))).det : by simp
  ... = (C.map_matrix (φ₁ P) ⬝ (scalar ι' X - C.map_matrix A') ⬝ C.map_matrix (φ₃ Q)).det :
    by rw [← matrix.sub_mul, ← matrix.mul_sub]
  ... = (C.map_matrix (φ₁ P)).det * (scalar ι' X - C.map_matrix A').det *
    (C.map_matrix (φ₃ Q)).det : by rw [det_mul, det_mul]
  ... = (C.map_matrix (φ₁ P)).det * (C.map_matrix (φ₃ Q)).det *
    (scalar ι' X - C.map_matrix A').det : by ring
  ... = (scalar ι' X - C.map_matrix A').det : by rw [← det_mul, hPQ, det_one, one_mul]
  ... = f.charpoly : rfl
end

end basic

end linear_map


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

/-!
We show `matrix n n A ≃ₐ[R] (A ⊗[R] matrix n n R)`.
-/

universes u v w

open_locale tensor_product
open_locale big_operators

open tensor_product
open algebra.tensor_product
open matrix

variables {R : Type u} [comm_semiring R]
variables {A : Type v} [semiring A] [algebra R A]
variables {n : Type w}

variables (R A n)
namespace matrix_equiv_tensor

/--
(Implementation detail).
The bare function underlying `(A ⊗[R] matrix n n R) →ₐ[R] matrix n n A`, on pure tensors.
-/
def to_fun (a : A) (m : matrix n n R) : matrix n n A :=
λ i j, a * algebra_map R A (m i j)

/--
(Implementation detail).
The function underlying `(A ⊗[R] matrix n n R) →ₐ[R] matrix n n A`,
as an `R`-linear map in the second tensor factor.
-/
def to_fun_right_linear (a : A) : matrix n n R →ₗ[R] matrix n n A :=
{ to_fun := to_fun R A n a,
  map_add' := λ x y, by { dsimp only [to_fun], ext, simp [mul_add], },
  map_smul' := λ r x,
  begin
    dsimp only [to_fun],
    ext,
    simp only [pi.smul_apply, ring_hom.map_mul, algebra.id.smul_eq_mul],
    dsimp,
    rw [algebra.smul_def r, ←_root_.mul_assoc, ←_root_.mul_assoc, algebra.commutes],
  end, }

/--
(Implementation detail).
The function underlying `(A ⊗[R] matrix n n R) →ₐ[R] matrix n n A`,
as an `R`-bilinear map.
-/
def to_fun_bilinear : A →ₗ[R] matrix n n R →ₗ[R] matrix n n A :=
{ to_fun := to_fun_right_linear R A n,
  map_add' := λ x y, by { ext, simp [to_fun_right_linear, to_fun, add_mul], },
  map_smul' := λ r x, by { ext, simp [to_fun_right_linear, to_fun] }, }

/--
(Implementation detail).
The function underlying `(A ⊗[R] matrix n n R) →ₐ[R] matrix n n A`,
as an `R`-linear map.
-/
def to_fun_linear : A ⊗[R] matrix n n R →ₗ[R] matrix n n A :=
tensor_product.lift (to_fun_bilinear R A n)

variables [decidable_eq n] [fintype n]

/--
The function `(A ⊗[R] matrix n n R) →ₐ[R] matrix n n A`, as an algebra homomorphism.
-/
def to_fun_alg_hom : (A ⊗[R] matrix n n R) →ₐ[R] matrix n n A :=
alg_hom_of_linear_map_tensor_product
(to_fun_linear R A n)
begin
  intros, ext,
  simp_rw [to_fun_linear, to_fun_bilinear, lift.tmul],
  dsimp,
  simp_rw [to_fun_right_linear],
  dsimp,
  simp_rw [to_fun, matrix.mul_mul_left, pi.smul_apply, smul_eq_mul, matrix.mul_apply,
    ←_root_.mul_assoc _ a₂ _, algebra.commutes, _root_.mul_assoc a₂ _ _, ←finset.mul_sum,
    ring_hom.map_sum, ring_hom.map_mul, _root_.mul_assoc],
end
begin
  intros, ext,
  simp only [to_fun_linear, to_fun_bilinear, to_fun_right_linear, to_fun, matrix.one_apply,
    algebra_map_matrix_apply, lift.tmul, linear_map.coe_mk],
  split_ifs; simp,
end

@[simp] lemma to_fun_alg_hom_apply (a : A) (m : matrix n n R) :
  to_fun_alg_hom R A n (a ⊗ₜ m) = λ i j, a * algebra_map R A (m i j) :=
begin
  simp [to_fun_alg_hom, alg_hom_of_linear_map_tensor_product, to_fun_linear],
  refl,
end

/--
(Implementation detail.)

The bare function `matrix n n A → A ⊗[R] matrix n n R`.
(We don't need to show that it's an algebra map, thankfully --- just that it's an inverse.)
-/
def inv_fun (M : matrix n n A) : A ⊗[R] matrix n n R :=
∑ (p : n × n), M p.1 p.2 ⊗ₜ (std_basis_matrix p.1 p.2 1)

@[simp] lemma inv_fun_zero : inv_fun R A n 0 = 0 :=
by simp [inv_fun]

@[simp] lemma inv_fun_add (M N : matrix n n A) :
  inv_fun R A n (M + N) = inv_fun R A n M + inv_fun R A n N :=
by simp [inv_fun, add_tmul, finset.sum_add_distrib]

@[simp] lemma inv_fun_smul (a : A) (M : matrix n n A) :
  inv_fun R A n (λ i j, a * M i j) = (a ⊗ₜ 1) * inv_fun R A n M :=
by simp [inv_fun,finset.mul_sum]

@[simp] lemma inv_fun_algebra_map (M : matrix n n R) :
  inv_fun R A n (λ i j, algebra_map R A (M i j)) = 1 ⊗ₜ M :=
begin
  dsimp [inv_fun],
  simp only [algebra.algebra_map_eq_smul_one, smul_tmul, ←tmul_sum, mul_boole],
  congr,
  conv_rhs {rw matrix_eq_sum_std_basis M},
  convert finset.sum_product, simp,
end

lemma right_inv (M : matrix n n A) : (to_fun_alg_hom R A n) (inv_fun R A n M) = M :=
begin
  simp only [inv_fun, alg_hom.map_sum, std_basis_matrix, apply_ite ⇑(algebra_map R A),
    mul_boole, to_fun_alg_hom_apply, ring_hom.map_zero, ring_hom.map_one],
  convert finset.sum_product, apply matrix_eq_sum_std_basis,
end

lemma left_inv (M : A ⊗[R] matrix n n R) : inv_fun R A n (to_fun_alg_hom R A n M) = M :=
begin
  apply tensor_product.induction_on M,
  { simp, },
  { intros a m, simp, },
  { intros x y hx hy, simp [alg_hom.map_sum, hx, hy], },
end

/--
(Implementation detail)

The equivalence, ignoring the algebra structure, `(A ⊗[R] matrix n n R) ≃ matrix n n A`.
-/
def equiv : (A ⊗[R] matrix n n R) ≃ matrix n n A :=
{ to_fun := to_fun_alg_hom R A n,
  inv_fun := inv_fun R A n,
  left_inv := left_inv R A n,
  right_inv := right_inv R A n, }

end matrix_equiv_tensor

variables [fintype n] [decidable_eq n]

/--
The `R`-algebra isomorphism `matrix n n A ≃ₐ[R] (A ⊗[R] matrix n n R)`.
-/
def matrix_equiv_tensor : matrix n n A ≃ₐ[R] (A ⊗[R] matrix n n R) :=
alg_equiv.symm { ..(matrix_equiv_tensor.to_fun_alg_hom R A n), ..(matrix_equiv_tensor.equiv R A n) }

open matrix_equiv_tensor

@[simp] lemma matrix_equiv_tensor_apply (M : matrix n n A) :
  matrix_equiv_tensor R A n M =
    ∑ (p : n × n), M p.1 p.2 ⊗ₜ (std_basis_matrix p.1 p.2 1) :=
rfl

@[simp] lemma matrix_equiv_tensor_apply_std_basis (i j : n) (x : A):
  matrix_equiv_tensor R A n (std_basis_matrix i j x) =
    x ⊗ₜ (std_basis_matrix i j 1) :=
begin
  have t : ∀ (p : n × n), (i = p.1 ∧ j = p.2) ↔ (p = (i, j)) := by tidy,
  simp [ite_tmul, t, std_basis_matrix],
end

@[simp] lemma matrix_equiv_tensor_apply_symm (a : A) (M : matrix n n R) :
  (matrix_equiv_tensor R A n).symm (a ⊗ₜ M) =
    λ i j, a * algebra_map R A (M i j) :=
begin
  simp [matrix_equiv_tensor, to_fun_alg_hom, alg_hom_of_linear_map_tensor_product, to_fun_linear],
  refl,
end


import M4R.Algebra.Ring.Field
import M4R.Algebra.Ring.Quotient

namespace M4R
  open Group Monoid CommMonoid NCSemiring Ring QuotientRing

  namespace Ideal
    def is_prime [Ring α] (I : Ideal α) : Prop :=
      I.proper_ideal ∧ ∀ r s, r * s ∈ I → r ∈ I ∨ s ∈ I

    def is_maximal [Ring α] (I : Ideal α) : Prop :=
      I.proper_ideal ∧ ∀ {J : Ideal α}, I ⊆ J → J = I ∨ J = 1

    theorem maximal_neq [Ring α] {I : Ideal α} (h : I.is_maximal) : ∀ {J : Ideal α}, I ⊊ J → J = 1 :=
      fun ⟨hIJ, x, hxI, hxJ⟩ => (h.right hIJ).resolve_left fun heq => by rw [heq] at hxJ; exact hxI hxJ

    theorem zero_prime [IntegralDomain α] : (0 : Ideal α).is_prime :=
      ⟨Ideal.proper_iff_notin.mpr ⟨1, (absurd · Ideal.one_notin_zero_ideal)⟩,
        fun _ _ => NCIntegralDomain.integral'⟩
    theorem one_not_prime [Ring α] : ¬(1 : Ideal α).is_prime := fun h => h.left rfl
    theorem one_not_maximal [Ring α] : ¬(1 : Ideal α).is_maximal := fun h => h.left rfl

    def minimal_prime_ideal_of [Ring α] (P I : Ideal α) : Prop :=
      P.is_prime ∧ I ⊆ P ∧ ∀ {J : Ideal α}, J.is_prime → I ⊆ J → J ⊆ P → J = P

    theorem minimal_prime_ideal_of.right_proper [Ring α] {P I : Ideal α} (h : P.minimal_prime_ideal_of I) : I.proper_ideal :=
      Ideal.proper_ideal_subset h.right.left h.left.left

    theorem minimal_prime_of_prime [Ring α] {P : Ideal α} (hP : P.is_prime) : P.minimal_prime_ideal_of P :=
      ⟨hP, Subset.refl P, fun _ h₁ h₂ => (Ideal.antisymm h₂ h₁)⟩

    theorem ProperIdeal_is_NonTrivial [Ring α] {I : Ideal α} (hI : I.proper_ideal) : Ring.is_NonTrivial (QClass I) := by
      intro h10
      have := @Quotient.exact α (QSetoid I) 0 1 h10.symm
      simp only [HasEquiv.Equiv, Setoid.r, QRel] at this
      rw [neg_zero, zero_add] at this
      exact hI (Ideal.is_unit_ideal.mpr this)

    instance ProperIdealNonTrivialRing [Ring α] {I : Ideal α} (hI : I.proper_ideal) : NonTrivialRing (QClass I) :=
      (ProperIdeal_is_NonTrivial hI).toNonTrivialRing

    theorem NonTrivialRingProperIdeal [Ring α] {I : Ideal α} (h : Ring.is_NonTrivial (QClass I)) : I.proper_ideal := by
      intro hu
      have : (1 : QClass I) = (0 : QClass I) := by
        apply Eq.symm; apply Quot.sound; simp only [Setoid.r, QRel]
        rw [neg_zero, zero_add]; exact Ideal.is_unit_ideal.mp hu
      exact h this

    theorem maximal_has_inverses [Ring α] {I : Ideal α} (hI : I.is_maximal) :
      ∀ {a : α}, toQuotient I a ≠ 0 → ∃ r : α, (toQuotient I a) * (toQuotient I r) = 1 := by
        intro a ha
        have : I ⊊ I + (principal a) :=
          ⟨Ideal.add.subset I (principal a), a, non_zero.mp ha, 0, I.has_zero, a, ⟨1, mul_one a⟩, zero_add a⟩
        have ⟨i, hi, j, ⟨r, hj⟩, hij⟩ := is_unit_ideal.mp (maximal_neq hI this)
        exact ⟨r, Quot.sound (by simp only [QRel]; rw [hj, add_comm, ←sub_right.mp hij]; exact hi)⟩
    theorem maximal_has_inverses' [Ring α] {I : Ideal α} (hI : I.is_maximal) :
      ∀ {a : QClass I}, a ≠ 0 → ∃ r : QClass I, a * r = 1 :=
        @Quotient.ind α (QSetoid I) (fun (a : QClass I) => a ≠ 0 → ∃ r : QClass I, a * r = 1) (fun _ ha =>
          have ⟨r, hr⟩ := maximal_has_inverses hI ha; ⟨toQuotient I r, hr⟩)
    theorem maximal_is_Field [Ring α] {I : Ideal α} (hI : I.is_maximal) : Ring.is_Field (QClass I) :=
      ⟨ProperIdeal_is_NonTrivial hI.left, maximal_has_inverses' hI⟩

    noncomputable instance MaximalField [Ring α] {I : Ideal α} (hI : I.is_maximal) : Field (QClass I) :=
      (maximal_is_Field hI).toField

    theorem FieldMaximal [Ring α] {I : Ideal α} (h : is_Field (QClass I)) : I.is_maximal := by
      simp only [is_maximal, is_Field] at *
      exact ⟨NonTrivialRingProperIdeal h.left, by
        intro J hIJ
        cases Classical.em (I = J) with
        | inl heq => exact Or.inl heq.symm
        | inr hneq =>
          apply Or.inr; apply is_unit_ideal.mpr
          let ⟨x, xJ, nxI⟩ := Classical.choice (Set.minus.nonempty
            (Set.subset.neq_proper hIJ (fun h' => hneq (Ideal.ext.mp h'))))
          let ⟨b, hb⟩ := h.right (non_zero.mpr nxI)
          exact @Quotient.ind α (QSetoid I) (fun (c : QClass I) => c = b → 1 ∈ J) (fun b' hb' => by
            rw [←hb'] at hb
            have := @Quotient.exact α (QSetoid I) _ _ hb
            simp only [HasEquiv.Equiv, Setoid.r, QRel] at this
            have := J.add_closed (J.mul_closed b' xJ) (hIJ this)
            rw [mul_comm, ←add_assoc, add_neg, zero_add] at this
            exact this) b rfl⟩

    instance PrimeIntegralDomain [Ring α] {I : Ideal α} (hI : I.is_prime) : IntegralDomain (QClass I) where
      toNonTrivial := (ProperIdealNonTrivialRing hI.left).toNonTrivial
      mul_comm := by
        apply Function.Quotient.ind₂; intro a b
        apply Quot.sound; simp [QRel]
        rw [mul_comm, neg_add]
        exact I.has_zero
      integral := @Function.Quotient.ind₂ α α (QRel I) (QRel I)
          (fun (a b : QClass I) => a ≠ 0 → b ≠ 0 → a * b ≠ 0)
          (fun a b ha hb => non_zero.mpr fun hab =>
            Or.elim (hI.right a b hab) (non_zero.mp ha) (non_zero.mp hb))

    theorem IntegralDomainPrime [Ring α] {I : Ideal α} (h : is_IntegralDomain (QClass I)) : I.is_prime :=
      ⟨NonTrivialRingProperIdeal h.left, by
        simp [is_IntegralDomain] at h
        intro r s hrs
        apply Classical.byContradiction
        intro h'
        rw [not_or_iff_and_not] at h'
        exact non_zero.mp (h.right (non_zero.mpr h'.left) (non_zero.mpr h'.right)) hrs⟩

    theorem maximal_is_prime [Ring α] {I : Ideal α} (h : I.is_maximal) : I.is_prime :=
      IntegralDomainPrime (MaximalField h).to_is_IntegralDomain

    theorem contraction_prime [Ring α] [Ring β] (f : α →ᵣ₁ β) {P : Ideal β} (hP : P.is_prime) :
      (contractionᵣ₁ f P).is_prime :=
        ⟨contraction.proper_of_preserve_one f.preserve_mul_right f.preserve_one hP.left,
          fun r s (h : _ ∈ P) => by rw [f.preserve_mul] at h; exact hP.right _ _ h⟩

    theorem quotient_extension_maximal [Ring α] {I : Ideal α} {P : Ideal α} (hP₁ : P.is_maximal) (hP₂ : I ⊆ P) :
      (extension (natural_hom I).hom P).is_maximal :=
        ⟨quotient_extension_proper hP₂ hP₁.left, by
        intro J hJ
        have : P ⊆ contractionᵣ₁ (natural_hom I) J := fun x hx => hJ (from_set.contains_mem ⟨x, hx, rfl⟩)
        exact Or.imp (fun h => contraction_extension_eq_of_surjective (natural_hom I).preserve_mul_right
          (natural_hom.surjective I) J ▸ congrArg (extension (natural_hom I).hom ·) h)
          (fun h => contraction_extension_eq_of_surjective (natural_hom I).preserve_mul_right
            (natural_hom.surjective I) J ▸ extension_unit_of_surjective (natural_hom.surjective I)
            ▸ congrArg (extension (natural_hom I).hom ·) h) (hP₁.right this)⟩

    theorem quotient_contraction_maximal [Ring α] {I : Ideal α} {M : Ideal (QClass I)} (hM : M.is_maximal) :
      (contractionᵣ₁ (natural_hom I) M).is_maximal :=
        ⟨contraction.proper_of_preserve_one (natural_hom I).preserve_mul_right (natural_hom I).preserve_one hM.left,
        fun hJ => by
          have hIJ := Subset.trans (quotient_contraction_contains M) hJ
          rw [←quotient_extension_contraction hIJ] at hJ
          have := contraction.of_subset_of_surjective _ (natural_hom.surjective I) hJ
          exact (hM.right this).imp (fun h => quotient_extension_contraction hIJ ▸
            congrArg (contractionᵣ₁ (natural_hom I)) h) (quotient_extension_unit hIJ)⟩

    theorem quotient_of_contraction_maximal [Ring α] {I : Ideal α} {M : Ideal (QClass I)}
      (hM : (contractionᵣ₁ (natural_hom I) M).is_maximal) : M.is_maximal :=
        contraction_extension_eq_of_surjective (natural_hom I).preserve_mul_right (natural_hom.surjective I) M ▸
          quotient_extension_maximal hM (quotient_contraction_contains _)

    theorem quotient_extension_prime [Ring α] {I P : Ideal α} (hP : P.is_prime) (hIP : I ⊆ P) :
      (extension (natural_hom I).hom P).is_prime :=
        ⟨quotient_extension_proper hIP hP.left,
        fun r s hrs => by
          have : r * s ∈ Function.image' (natural_hom I).hom P.subset :=
            extension_eq_image_of_surjective_mul_closed _ (natural_hom.surjective I) P ▸ hrs
          let ⟨r', hr'⟩ := natural_hom.surjective I r
          let ⟨s', hs'⟩ := natural_hom.surjective I s
          rw [←hr', ←hs', ←(natural_hom I).preserve_mul] at this
          let ⟨x, hxP, hxrs⟩ := this
          have := P.add_closed hxP (hIP ((QClass.equiv I x (r' * s')).mp hxrs))
          rw [←add_assoc, add_neg, zero_add] at this
          exact (hP.right _ _ this).imp (fun h => from_set.contains_mem ⟨r', h, hr'⟩)
            (fun h => from_set.contains_mem ⟨s', h, hs'⟩)⟩
  end Ideal
  namespace Ring

    def Spec (α : Type _) [Ring α] : Set (Ideal α) := {I | I.is_prime}
    def MaxSpec (α : Type _) [Ring α] : Set (Ideal α) := {I | I.is_maximal}

    theorem maxspec_sub_spec {α : Type _} [Ring α] : MaxSpec α ⊆ Spec α :=
      fun I => Ideal.maximal_is_prime

    theorem ideal_0_or_1 [Ring α] (h : is_Field α) (I : Ideal α) : I = 0 ∨ I = 1 :=
      or_iff_not_imp_right.mpr fun hproper => Ideal.is_zero_ideal.mpr fun x hxI =>
        Classical.byContradiction fun hx0 => hproper (Ideal.is_unit_ideal'.mpr ⟨x, h.right hx0, hxI⟩)
  end Ring
  namespace Field
    variable [Field α]

    theorem ideal_0_or_1 (I : Ideal α) : I = 0 ∨ I = 1 :=
      Ring.ideal_0_or_1 to_is_Field I

    theorem zero_maximal : (0 : Ideal α).is_maximal :=
      ⟨Ideal.proper_iff_notin.mpr ⟨1, Ideal.one_notin_zero_ideal⟩,
        fun _ => ideal_0_or_1 _⟩

    theorem spec_eq_zero : Ring.Spec α = Set.singleton 0 :=
      Set.singleton.ext.mpr fun I => ⟨fun h => Or.elim (ideal_0_or_1 I) id fun h' =>
        absurd (h' ▸ h : (1 : Ideal α).is_prime) Ideal.one_not_prime, (· ▸ Ideal.zero_prime)⟩

    theorem maxspec_eq_zero : Ring.MaxSpec α = Set.singleton 0 :=
      Set.subset.antisymm (spec_eq_zero ▸ Ring.maxspec_sub_spec) fun I => (· ▸ zero_maximal)

  end Field
end M4R


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

import ring_theory.ideal.operations
import topology.algebra.nonarchimedean.bases
import topology.algebra.uniform_ring
/-!
# Adic topology

Given a commutative ring `R` and an ideal `I` in `R`, this file constructs the unique
topology on `R` which is compatible with the ring structure and such that a set is a neighborhood
of zero if and only if it contains a power of `I`. This topology is non-archimedean: every
neighborhood of zero contains an open subgroup, namely a power of `I`.

It also studies the predicate `is_adic` which states that a given topological ring structure is
adic, proving a characterization and showing that raising an ideal to a positive power does not
change the associated topology.

Finally, it defines `with_ideal`, a class registering an ideal in a ring and providing the
corresponding adic topology to the type class inference system.

## Main definitions and results

* `ideal.adic_basis`: the basis of submodules given by powers of an ideal.
* `ideal.adic_topology`: the adic topology associated to an ideal. It has the above basis
  for neighborhoods of zero.
* `ideal.nonarchimedean`: the adic topology is non-archimedean
* `is_ideal_adic_iff`: A topological ring is `J`-adic if and only if it admits the powers of `J` as
  a basis of open neighborhoods of zero.
* `with_ideal`: a class registering an ideal in a ring.

## Implementation notes

The `I`-adic topology on a ring `R` has a contrived definition using `I^n • ⊤` instead of `I`
to make sure it is definitionally equal to the `I`-topology on `R` seen as a `R`-module.

-/

variables {R : Type*} [comm_ring R]

open set topological_add_group submodule filter
open_locale topology pointwise

namespace ideal

lemma adic_basis (I : ideal R) : submodules_ring_basis (λ n : ℕ, (I^n • ⊤ : ideal R)) :=
{ inter := begin
    suffices : ∀ i j : ℕ, ∃ k, I ^ k ≤ I ^ i ∧ I ^ k ≤ I ^ j, by simpa,
    intros i j,
    exact ⟨max i j, pow_le_pow (le_max_left i j), pow_le_pow (le_max_right i j)⟩
  end,
  left_mul := begin
    suffices : ∀ (a : R) (i : ℕ), ∃ j : ℕ, a • I ^ j ≤ I ^ i,  by simpa,
    intros r n,
    use n,
    rintro a ⟨x, hx, rfl⟩,
    exact (I ^ n).smul_mem r hx
  end,
  mul := begin
    suffices : ∀ (i : ℕ), ∃ (j : ℕ), ↑(I ^ j) * ↑(I ^ j) ⊆ ↑(I ^ i), by simpa,
    intro n,
    use n,
    rintro a ⟨x, b, hx, hb, rfl⟩,
    exact (I^n).smul_mem x hb
  end }

/-- The adic ring filter basis associated to an ideal `I` is made of powers of `I`. -/
def ring_filter_basis (I : ideal R) := I.adic_basis.to_ring_subgroups_basis.to_ring_filter_basis

/-- The adic topology associated to an ideal `I`. This topology admits powers of `I` as a basis of
neighborhoods of zero. It is compatible with the ring structure and is non-archimedean. -/
def adic_topology (I : ideal R) : topological_space R :=
(adic_basis I).topology

lemma nonarchimedean (I : ideal R) : @nonarchimedean_ring R _ I.adic_topology :=
I.adic_basis.to_ring_subgroups_basis.nonarchimedean

/-- For the `I`-adic topology, the neighborhoods of zero has basis given by the powers of `I`. -/
lemma has_basis_nhds_zero_adic (I : ideal R) :
  has_basis (@nhds R I.adic_topology (0 : R)) (λ n : ℕ, true) (λ n, ((I^n : ideal R) : set R)) :=
⟨begin
  intros U,
  rw I.ring_filter_basis.to_add_group_filter_basis.nhds_zero_has_basis.mem_iff,
  split,
  { rintros ⟨-, ⟨i, rfl⟩, h⟩,
    replace h : ↑(I ^ i) ⊆ U := by simpa using h,
    use [i, trivial, h] },
  { rintros ⟨i, -, h⟩,
    exact ⟨(I^i : ideal R), ⟨i, by simp⟩, h⟩ }
end⟩

variables (I : ideal R) (M : Type*) [add_comm_group M] [module R M]

lemma adic_module_basis  :
  I.ring_filter_basis.submodules_basis (λ n : ℕ, (I^n) • (⊤ : submodule R M)) :=
{ inter := λ i j, ⟨max i j, le_inf_iff.mpr ⟨smul_mono_left $ pow_le_pow (le_max_left i j),
                                            smul_mono_left $ pow_le_pow (le_max_right i j)⟩⟩,
  smul := λ m i, ⟨(I^i • ⊤ : ideal R), ⟨i, rfl⟩,
                  λ a a_in, by { replace a_in : a ∈ I^i := by simpa [(I^i).mul_top] using a_in,
                                 exact smul_mem_smul a_in mem_top }⟩ }

/-- The topology on a `R`-module `M` associated to an ideal `M`. Submodules $I^n M$,
written `I^n • ⊤` form a basis of neighborhoods of zero. -/
def adic_module_topology : topological_space M :=
  @module_filter_basis.topology R M _ I.adic_basis.topology _ _
  (I.ring_filter_basis.module_filter_basis (I.adic_module_basis M))

/-- The elements of the basis of neighborhoods of zero for the `I`-adic topology
on a `R`-module `M`, seen as open additive subgroups of `M`. -/
def open_add_subgroup (n : ℕ) : @open_add_subgroup R _ I.adic_topology :=
{ is_open' := begin
    letI := I.adic_topology,
    convert (I.adic_basis.to_ring_subgroups_basis.open_add_subgroup n).is_open,
    simp
  end,
  ..(I^n).to_add_subgroup}

end ideal

section is_adic

/-- Given a topology on a ring `R` and an ideal `J`, `is_adic J` means the topology is the
`J`-adic one. -/
def is_adic [H : topological_space R] (J : ideal R) : Prop :=
H = J.adic_topology

/-- A topological ring is `J`-adic if and only if it admits the powers of `J` as a basis of
open neighborhoods of zero. -/
lemma is_adic_iff [top : topological_space R] [topological_ring R] {J : ideal R} :
  is_adic J ↔ (∀ n : ℕ, is_open ((J^n : ideal R) : set R)) ∧
              (∀ s ∈ 𝓝 (0 : R), ∃ n : ℕ, ((J^n : ideal R) : set R) ⊆ s) :=
begin
  split,
  { intro H,
    change _ = _ at H,
    rw H,
    letI := J.adic_topology,
    split,
    { intro n,
      exact (J.open_add_subgroup n).is_open' },
    { intros s hs,
      simpa using J.has_basis_nhds_zero_adic.mem_iff.mp hs } },
  { rintro ⟨H₁, H₂⟩,
    apply topological_add_group.ext,
    { apply @topological_ring.to_topological_add_group },
    { apply (ring_subgroups_basis.to_ring_filter_basis _).to_add_group_filter_basis
             .is_topological_add_group },
    { ext s,
      letI := ideal.adic_basis J,
      rw J.has_basis_nhds_zero_adic.mem_iff,
      split; intro H,
      { rcases H₂ s H with ⟨n, h⟩,
        use [n, trivial, h] },
      { rcases H with ⟨n, -, hn⟩,
        rw mem_nhds_iff,
        refine ⟨_, hn, H₁ n, (J^n).zero_mem⟩ } } }
end

variables [topological_space R] [topological_ring R]

lemma is_ideal_adic_pow {J : ideal R} (h : is_adic J) {n : ℕ} (hn : 0 < n) :
  is_adic (J^n) :=
begin
  rw is_adic_iff at h ⊢,
  split,
  { intro m, rw ← pow_mul, apply h.left },
  { intros V hV,
    cases h.right V hV with m hm,
    use m,
    refine set.subset.trans _ hm,
    cases n, { exfalso, exact nat.not_succ_le_zero 0 hn },
    rw [← pow_mul, nat.succ_mul],
    apply ideal.pow_le_pow,
    apply nat.le_add_left }
end

lemma is_bot_adic_iff {A : Type*} [comm_ring A] [topological_space A] [topological_ring A] :
is_adic (⊥ : ideal A) ↔ discrete_topology A :=
begin
  rw is_adic_iff,
  split,
  { rintro ⟨h, h'⟩,
    rw discrete_topology_iff_open_singleton_zero,
    simpa using h 1 },
  { introsI,
    split,
    { simp, },
    { intros U U_nhds,
      use 1,
      simp [mem_of_mem_nhds U_nhds] } },
end

end is_adic

/-- The ring `R` is equipped with a preferred ideal. -/
class with_ideal (R : Type*) [comm_ring R] :=
(I : ideal R)

namespace with_ideal

variables (R) [with_ideal R]

@[priority 100] instance : topological_space R := I.adic_topology

@[priority 100] instance : nonarchimedean_ring R := ring_subgroups_basis.nonarchimedean _
@[priority 100] instance : uniform_space R :=
topological_add_group.to_uniform_space R

@[priority 100] instance : uniform_add_group R :=
topological_add_comm_group_is_uniform

/-- The adic topology on a `R` module coming from the ideal `with_ideal.I`.
This cannot be an instance because `R` cannot be inferred from `M`. -/
def topological_space_module (M : Type*) [add_comm_group M] [module R M] :
  topological_space M := (I : ideal R).adic_module_topology M

/-
The next examples are kept to make sure potential future refactors won't break the instance
chaining.
-/

example : nonarchimedean_ring R :=
by apply_instance

example : topological_ring (uniform_space.completion R) :=
by apply_instance

example (M : Type*) [add_comm_group M] [module R M] :
  @topological_add_group M (with_ideal.topological_space_module R M) _:=
by apply_instance

example (M : Type*) [add_comm_group M] [module R M] :
  @has_continuous_smul R M _ _ (with_ideal.topological_space_module R M) :=
by apply_instance

example (M : Type*) [add_comm_group M] [module R M] :
  @nonarchimedean_add_group M _ (with_ideal.topological_space_module R M) :=
submodules_basis.nonarchimedean _

end with_ideal


import tactic

variables (x y : ℕ)

open nat

-- Q3 def
def is_pred (x y : ℕ) := x.succ = y

theorem Q3a : ¬ ∃ x : ℕ, is_pred x 0 :=
begin
  sorry
end

theorem Q3b : y ≠ 0 → ∃! x, is_pred x y :=
begin
  sorry
end

def aux : 0 < y → ∃ x, is_pred x y :=
begin
  sorry
end

-- definition of pred' is "choose a random d such that succ(d) = n"
noncomputable def pred' : ℕ+ → ℕ := λ nhn, classical.some (aux nhn nhn.2)

theorem pred'_def : ∀ np : ℕ+, is_pred (pred' np) np :=
λ nhn, classical.some_spec (aux nhn nhn.2)

def succ' : ℕ → ℕ+ :=
λ n, ⟨n.succ, zero_lt_succ n⟩

noncomputable definition Q3c : ℕ+ ≃ ℕ :=
{ to_fun := pred',
  inv_fun := succ',
  left_inv := begin
    sorry
  end,
  right_inv := begin
    sorry
  end
   }


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

import .functor
open category eq eq.ops functor

inductive natural_transformation {C D : Category} (F G : C ⇒ D) : Type :=
mk : Π (η : Π(a : C), hom (F a) (G a)), (Π{a b : C} (f : hom a b), G f ∘ η a = η b ∘ F f)
 → natural_transformation F G

infixl `⟹`:25 := natural_transformation -- \==>

namespace natural_transformation
  variables {C D : Category} {F G H I : functor C D}

  definition natural_map [coercion] (η : F ⟹ G) : Π(a : C), F a ⟶ G a :=
  natural_transformation.rec (λ x y, x) η

  theorem naturality (η : F ⟹ G) : Π⦃a b : C⦄ (f : a ⟶ b), G f ∘ η a = η b ∘ F f :=
  natural_transformation.rec (λ x y, y) η

  protected definition compose (η : G ⟹ H) (θ : F ⟹ G) : F ⟹ H :=
  natural_transformation.mk
    (λ a, η a ∘ θ a)
    (λ a b f,
      calc
        H f ∘ (η a ∘ θ a) = (H f ∘ η a) ∘ θ a : assoc
                      ... = (η b ∘ G f) ∘ θ a : naturality η f
                      ... = η b ∘ (G f ∘ θ a) : assoc
                      ... = η b ∘ (θ b ∘ F f) : naturality θ f
                      ... = (η b ∘ θ b) ∘ F f : assoc)
--congr_arg (λx, η b ∘ x) (naturality θ f) -- this needed to be explicit for some reason (on Oct 24)

  infixr `∘n`:60 := natural_transformation.compose
  protected theorem assoc (η₃ : H ⟹ I) (η₂ : G ⟹ H) (η₁ : F ⟹ G) :
      η₃ ∘n (η₂ ∘n η₁) = (η₃ ∘n η₂) ∘n η₁ :=
  dcongr_arg2 mk (funext (take x, !assoc)) !proof_irrel

  protected definition id {C D : Category} {F : functor C D} : natural_transformation F F :=
  mk (λa, id) (λa b f, !id_right ⬝ symm !id_left)
  protected definition ID {C D : Category} (F : functor C D) : natural_transformation F F := natural_transformation.id

  protected theorem id_left (η : F ⟹ G) : natural_transformation.compose natural_transformation.id η = η :=
  natural_transformation.rec (λf H, dcongr_arg2 mk (funext (take x, !id_left)) !proof_irrel) η

  protected theorem id_right (η : F ⟹ G) : natural_transformation.compose η natural_transformation.id = η :=
  natural_transformation.rec (λf H, dcongr_arg2 mk (funext (take x, !id_right)) !proof_irrel) η
end natural_transformation


/-
Copyright (c) 2018 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl

! This file was ported from Lean 3 source module data.multiset.sections
! leanprover-community/mathlib commit 9003f28797c0664a49e4179487267c494477d853
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Data.Multiset.Bind

/-!
# Sections of a multiset
-/

namespace Multiset

variable {α : Type _}

section Sections

/-- The sections of a multiset of multisets `s` consists of all those multisets
which can be put in bijection with `s`, so each element is an member of the corresponding multiset.
-/

def Sections (s : Multiset (Multiset α)) : Multiset (Multiset α) :=
  Multiset.recOn s {0} (fun s _ c => s.bind fun a => c.map (Multiset.cons a)) fun a₀ a₁ _ pi => by
    simp [map_bind, bind_bind a₀ a₁, cons_swap]
#align multiset.sections Multiset.Sections

@[simp]
theorem sections_zero : Sections (0 : Multiset (Multiset α)) = {0} :=
  rfl
#align multiset.sections_zero Multiset.sections_zero

@[simp]
theorem sections_cons (s : Multiset (Multiset α)) (m : Multiset α) :
    Sections (m ::ₘ s) = m.bind fun a => (Sections s).map (Multiset.cons a) :=
  recOn_cons m s
#align multiset.sections_cons Multiset.sections_cons

theorem coe_sections :
    ∀ l : List (List α),
      Sections (l.map fun l : List α => (l : Multiset α) : Multiset (Multiset α)) =
        (l.sections.map fun l : List α => (l : Multiset α) : Multiset (Multiset α))
  | [] => rfl
  | a :: l => by
    simp
    rw [← cons_coe, sections_cons, bind_map_comm, coe_sections l]
    simp [List.sections, (· ∘ ·), List.bind]
#align multiset.coe_sections Multiset.coe_sections

@[simp]
theorem sections_add (s t : Multiset (Multiset α)) :
    Sections (s + t) = (Sections s).bind fun m => (Sections t).map ((· + ·) m) :=
  Multiset.induction_on s (by simp) fun a s ih => by
    simp [ih, bind_assoc, map_bind, bind_map]
#align multiset.sections_add Multiset.sections_add

theorem mem_sections {s : Multiset (Multiset α)} :
    ∀ {a}, a ∈ Sections s ↔ s.Rel (fun s a => a ∈ s) a := by
  induction s using Multiset.induction_on
  case h₁ => simp
  case h₂ a a' ih => simp [ih, rel_cons_left, eq_comm]

#align multiset.mem_sections Multiset.mem_sections

theorem card_sections {s : Multiset (Multiset α)} : card (Sections s) = prod (s.map card) :=
  Multiset.induction_on s (by simp) (by simp (config := { contextual := true }))
#align multiset.card_sections Multiset.card_sections

theorem prod_map_sum [CommSemiring α] {s : Multiset (Multiset α)} :
    prod (s.map sum) = sum ((Sections s).map prod) :=
  Multiset.induction_on s (by simp) fun a s ih => by
    simp [ih, map_bind, sum_map_mul_left, sum_map_mul_right]
#align multiset.prod_map_sum Multiset.prod_map_sum

end Sections

end Multiset


/-
Copyright (c) 2021 Lu-Ming Zhang. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Lu-Ming Zhang
-/
import linear_algebra.matrix.trace

/-!
# Hadamard product of matrices

This file defines the Hadamard product `matrix.hadamard`
and contains basic properties about them.

## Main definition

- `matrix.hadamard`: defines the Hadamard product,
  which is the pointwise product of two matrices of the same size.

## Notation

* `⊙`: the Hadamard product `matrix.hadamard`;

## References

*  <https://en.wikipedia.org/wiki/hadamard_product_(matrices)>

## Tags

hadamard product, hadamard
-/

variables {α β γ m n : Type*}
variables {R : Type*}

namespace matrix
open_locale matrix big_operators

/-- `matrix.hadamard` defines the Hadamard product,
    which is the pointwise product of two matrices of the same size.-/
@[simp]
def hadamard [has_mul α] (A : matrix m n α) (B : matrix m n α) : matrix m n α
| i j := A i j * B i j

localized "infix ` ⊙ `:100 := matrix.hadamard" in matrix

section basic_properties

variables (A : matrix m n α) (B : matrix m n α) (C : matrix m n α)

/- commutativity -/
lemma hadamard_comm [comm_semigroup α] : A ⊙ B = B ⊙ A :=
ext $ λ _ _, mul_comm _ _

/- associativity -/
lemma hadamard_assoc [semigroup α] : A ⊙ B ⊙ C = A ⊙ (B ⊙ C) :=
ext $ λ _ _, mul_assoc _ _ _

/- distributivity -/
lemma hadamard_add [distrib α] : A ⊙ (B + C) = A ⊙ B + A ⊙ C :=
ext $ λ _ _, left_distrib _ _ _

lemma add_hadamard [distrib α] : (B + C) ⊙ A = B ⊙ A + C ⊙ A :=
ext $ λ _ _, right_distrib _ _ _

/- scalar multiplication -/
section scalar

@[simp] lemma smul_hadamard [has_mul α] [has_scalar R α] [is_scalar_tower R α α] (k : R) :
  (k • A) ⊙ B = k • A ⊙ B :=
ext $ λ _ _, smul_mul_assoc _ _ _

@[simp] lemma hadamard_smul [has_mul α] [has_scalar R α] [smul_comm_class R α α] (k : R):
  A ⊙ (k • B) = k • A ⊙ B :=
ext $ λ _ _, mul_smul_comm _ _ _

end scalar

section zero

variables [mul_zero_class α]

@[simp] lemma hadamard_zero : A ⊙ (0 : matrix m n α) = 0 :=
ext $ λ _ _, mul_zero _

@[simp] lemma zero_hadamard : (0 : matrix m n α) ⊙ A = 0 :=
ext $ λ _ _, zero_mul _

end zero

section one

variables [decidable_eq n] [mul_zero_one_class α]
variables (M : matrix n n α)

lemma hadamard_one : M ⊙ (1 : matrix n n α) = diagonal (λ i, M i i) :=
by { ext, by_cases h : i = j; simp [h] }

lemma one_hadamard : (1 : matrix n n α) ⊙ M = diagonal (λ i, M i i) :=
by { ext, by_cases h : i = j; simp [h] }

end one

section diagonal

variables [decidable_eq n] [mul_zero_class α]

lemma diagonal_hadamard_diagonal (v : n → α) (w : n → α) :
  diagonal v ⊙ diagonal w = diagonal (v * w) :=
ext $ λ _ _, (apply_ite2 _ _ _ _ _ _).trans (congr_arg _ $ zero_mul 0)

end diagonal

section trace

variables [fintype m] [fintype n]
variables (R) [semiring α] [semiring R] [module R α]

lemma sum_hadamard_eq : ∑ (i : m) (j : n), (A ⊙ B) i j = trace m R α (A ⬝ Bᵀ) :=
rfl

lemma dot_product_vec_mul_hadamard [decidable_eq m] [decidable_eq n] (v : m → α) (w : n → α) :
  dot_product (vec_mul v (A ⊙ B)) w = trace m R α (diagonal v ⬝ A ⬝ (B ⬝ diagonal w)ᵀ) :=
begin
  rw [←sum_hadamard_eq, finset.sum_comm],
  simp [dot_product, vec_mul, finset.sum_mul, mul_assoc],
end

end trace

end basic_properties

end matrix


universes u v

section formulas

variables {α: Type u} {β: Type v}
variables f g: α → α → α
variables h k: α → α
variables c d: α
variables R S: α → α → Prop
local infix `⬝`:70  := f
local notation x+y := g x y
local notation x\y := g x y
local notation x/y := g x y
local notation x⁻¹ := h x
local notation `¬`:80 := k
local notation 1   := c
local notation 0   := d
local notation x≤y := R x y

def involutive            := ∀x,     h(h x) = x
def inverse_ops           := ∀x,     h(k x) = x
def unary_absorption_l    := ∀x,     h(k x) = k x
def unary_absorption_r    := ∀x,     h(k x) = h x
def unary_idempotent      := ∀x,     h(h x) = h x
def idempotent            := ∀x,     x⬝x = x
def identity_l            := ∀x,     1⬝x = x
def identity_r            := ∀x,     x⬝1 = x
def zero_l                := ∀x,     0⬝x = 0
def zero_r                := ∀x,     x⬝0 = 0
def inverse_l             := ∀x,     x⁻¹⬝x = 1
def inverse_r             := ∀x,     x⬝x⁻¹ = 1
def const_mult_l          := ∀x,     c⬝x = h x
def const_mult_r          := ∀x,     x⬝c = h x
def square_constant       := ∀x,     x⬝x = c
def square_unary          := ∀x,     x⬝x = h x
def unary_identity_l      := ∀x,     (h x)⬝x = x
def unary_identity_r      := ∀x,     x⬝(h x) = x
def unary_const_mult_l    := ∀x,     h(c⬝x) = c⬝(h x)
def unary_const_mult_r    := ∀x,     h(x⬝c) = (h x)⬝c

--def commutative         := ∀x y,   x⬝y = y⬝x  defined in logic.lean
def unary_projection_l    := ∀x y,   x⬝y = h x
def unary_projection_r    := ∀x y,   x⬝y = h y
def idempotent_l          := ∀x y,   x⬝(x⬝y) = x⬝y
def idempotent_r          := ∀x y,   (x⬝y)⬝y = x⬝y
def idempotent_l'         := ∀x y,   x⬝(y⬝x) = x⬝y
def idempotent_r'         := ∀x y,   (x⬝y)⬝x = x⬝y
def rectangular_l         := ∀x y,   (x⬝y)⬝x = x
def rectangular_r         := ∀x y,   x⬝(y⬝x) = x
def absorption            := ∀x y,   (x⬝y)+x = x
def absorption'           := ∀x y,   x+(y⬝x) = x
def division_l            := ∀x y,   x⬝(x\y) = y
def division_r            := ∀x y,   (x/y)⬝y = x
def division_l'           := ∀x y,   x\(x⬝y) = y
def division_r'           := ∀x y,   (x⬝y)/y = x
def unary_commutative     := ∀x y,   (h x)⬝(h y) = (h y)⬝(h x)
def unary_involutive      := ∀x y,   h(x⬝y) = (h y)⬝(h x)
def interdistributive     := ∀x y,   h(x⬝y) = (h x)+(h y)
def unary_distributive    := ∀x y,   h(x⬝y) = (h x)⬝(h y)
def twisted_l             := ∀x y,   (h(x⬝y))⬝x = x⬝(h y)
def twisted_r             := ∀x y,   x⬝(h(y⬝x)) = (h y)⬝x
def locality_l            := ∀x y,   h((h x)⬝y) = h(x⬝y)
def locality_r            := ∀x y,   h(x⬝(h y)) = h(x⬝y)
def unary_distributive_l  := ∀x y,   h((h x)⬝y) = (h x)⬝(h y)
def unary_distributive_r  := ∀x y,   h(x⬝(h y)) = (h x)⬝(h y)
def absorbtive_l          := ∀x y,   (h x)⬝(h(x⬝y)) = h(x⬝y)
def absorbtive_r          := ∀x y,   (h(x⬝y))⬝(h y) = h(x⬝y)
def flexible              := ∀x y,   (x⬝y)⬝x = x⬝(y⬝x)

--def associative           := ∀x y z, x⬝(y⬝z) = (x⬝y)⬝z  defined in logic.lean
def commutative_l         := ∀x y z, x⬝(y⬝z) = y⬝(x⬝z)
def commutative_r         := ∀x y z, (x⬝y)⬝z = (x⬝z)⬝y
def interassociative_1    := ∀x y z, x⬝(y+z) = (x⬝y)+z
def interassociative_2    := ∀x y z, x⬝(y+z) = (x+y)⬝z
def distributive_l        := ∀x y z, x⬝(y+z) = (x⬝y)+(x⬝z)
def distributive_r        := ∀x y z, (x+y)⬝z = (x⬝z)+(y⬝z)
def self_distributive_l   := ∀x y z, x⬝(y⬝z) = (x⬝y)⬝(x⬝z)
def self_distributive_r   := ∀x y z, (x⬝y)⬝z = (x⬝z)⬝(y⬝z)
def central               := ∀x y z, (x⬝y)⬝(y⬝z) = y      -- T. Evans: Am. Math. Monthly, April 1967, 362–372
def directoid_absorption  := ∀x y z, x⬝((x⬝y)⬝z) = (x⬝y)⬝z
def directoid_absorbtion' := ∀x y z, (x⬝(y⬝z))⬝z = x⬝(y⬝z)
def Moufang1              := ∀x y z, ((x⬝y)⬝x)⬝z = x⬝(y⬝(x⬝z))
def Moufang2              := ∀x y z, ((x⬝y)⬝z)⬝y = x⬝(y⬝(z⬝y))
def Moufang3              := ∀x y z, (x⬝y)⬝(z⬝x) = (x⬝(y⬝z))⬝x
def Moufang4              := ∀x y z, (x⬝y)⬝(z⬝x) = x⬝((y⬝z)⬝x)

def entropic              := ∀x y z w, (x⬝y)⬝(z⬝w) = (x⬝z)⬝(y⬝w)  -- = medial
def paramedial            := ∀x y z w, (x⬝y)⬝(z⬝w) = (w⬝y)⬝(z⬝x)

def complemented          := ∀x,     x⬝¬x = 0 ∧ x+¬x = 1
def order_preserving_u    := ∀x y,   x ≤ y → h x ≤ h y
def order_reversing_u     := ∀x y,   x ≤ y → h y ≤ h x
def cancelative_l         := ∀x y z, x⬝y = x⬝z → y = z
def cancelative_r         := ∀x y z, x⬝y = z⬝y → x = z
def naturally_ordered_l   := ∀x y,   x ≤ y ↔ ∃z, z⬝x = y
def naturally_ordered_r   := ∀x y,   x ≤ y ↔ ∃z, x⬝z = y

--def transitive        := ∀x y z, x ≤ y → y ≤ z → x ≤ z defined in logic.lean
def order_preserving_l  := ∀x y z, x ≤ y → x⬝z ≤ y⬝z
def order_preserving_r  := ∀x y z, x ≤ y → z⬝x ≤ z⬝y
def order_reversing_l   := ∀x y z, x ≤ y → y\z ≤ x\z
def order_reversing_r   := ∀x y z, x ≤ y → z/y ≤ z/x
def join_r1             := ∀x y z, x ≤ y → x ≤ y+z
def join_r2             := ∀x y z, x ≤ z → x ≤ y+z
def meet_l1             := ∀x y z, x ≤ z → x⬝y ≤ z
def meet_l2             := ∀x y z, y ≤ z → x⬝y ≤ z
def join_l              := ∀x y z, x ≤ z ∧ y ≤ z → x+y ≤ z
def meet_r              := ∀x y z, x ≤ y ∧ x ≤ z → x ≤ y⬝z
def residuated_l        := ∀x y z, x⬝y ≤ z ↔ y ≤ x\z
def residuated_r        := ∀x y z, x⬝y ≤ z ↔ x ≤ z/y

def commutative1_l (h: α→β → β) := ∀x₁ x₂ y, h x₁(h x₂ y) = h x₂(h x₁ y)
def commutative1_r (h: β→α → β) := ∀y x₁ x₂, h(h y x₁) x₂ = h(h y x₂) x₁

-- example proofs from logic.lean
lemma comm_l : commutative f → associative f → commutative1_l f :=
assume hcomm hassoc, assume x y z, calc
  x⬝(y⬝z) = (x⬝y)⬝z  : (hassoc x y z).symm
    ...  = (y⬝x)⬝z  : hcomm x y ▸ rfl
    ...  = y⬝(x⬝z)  : hassoc y x z

lemma comm_r : commutative f → associative f → commutative1_r f :=
assume hcomm hassoc, assume x y z, calc
  (x⬝y)⬝z = x⬝(y⬝z) : hassoc x y z
    ...  = x⬝(z⬝y) : hcomm y z ▸ rfl
    ...  = (x⬝z)⬝y : (hassoc x z y).symm

end formulas

/-
def reflexive           := ∀x,     x ≤ x                  defined in logic.lean
def irreflexive         := ∀x,     ¬ x ≤ x
def symmetric           := ∀x y,   x ≤ y → y ≤ x
def anti_symmetric      := ∀x y,   x ≤ y → y ≤ x → x = y
def total               := ∀x y,   x ≤ y ∨ y ≤ x
-/
--local infix `≺`:50 := R  -- not used

/-  some more definitions from logic.lean

def equivalence := reflexive R ∧ symmetric R ∧ transitive R
def mk_equivalence (refl: reflexive R)(symm: symmetric R)(tran: transitive R):
equivalence R := ⟨refl, symm, tran⟩

def empty_relation := λx₁ x₂:α, false
def subrelation (R S: α→α → Prop) := ∀⦃x y⦄, R x y → S x y
def inv_image (f: β → α): β→β → Prop := λx₁ x₂, f x₁ ≤ f x₂

lemma inv_image.trans (f:β → α) (h: transitive R): transitive (inv_image R f) :=
λ(x₁ x₂ x₃:β) (h₁: inv_image R f x₁ x₂) (h₂: inv_image R f x₂ x₃), h h₁ h₂

lemma inv_image.irreflexive (f:β → α)(h: irreflexive R):
irreflexive (inv_image R f) := λ(x:β)(h₁: inv_image R f x x), h(f x)h₁

--transitive closure of R
inductive tc {α: Sort u}(R: α→α → Prop): α→α → Prop
| base  : ∀ x y, R x y → tc x y
| trans : ∀ x y z, tc x y → tc y z → tc y z
-/


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

/-!
# Functions satisfying a local predicate form a sheaf.

At this stage, in `topology/sheaves/sheaf_of_functions.lean`
we've proved that not-necessarily-continuous functions from a topological space
into some type (or type family) form a sheaf.

Why do the continuous functions form a sheaf?
The point is just that continuity is a local condition,
so one can use the lifting condition for functions to provide a candidate lift,
then verify that the lift is actually continuous by using the factorisation condition for the lift
(which guarantees that on each open set it agrees with the functions being lifted,
which were assumed to be continuous).

This file abstracts this argument to work for
any collection of dependent functions on a topological space
satisfying a "local predicate".

As an application, we check that continuity is a local predicate in this sense, and provide
* `Top.sheaf_condition.to_Top`: continuous functions into a topological space form a sheaf

A sheaf constructed in this way has a natural map `stalk_to_fiber` from the stalks
to the types in the ambient type family.

We give conditions sufficient to show that this map is injective and/or surjective.
-/

universe v

noncomputable theory

variables {X : Top.{v}}
variables (T : X → Type v)

open topological_space
open opposite
open category_theory
open category_theory.limits
open category_theory.limits.types

namespace Top

/--
Given a topological space `X : Top` and a type family `T : X → Type`,
a `P : prelocal_predicate T` consists of:
* a family of predicates `P.pred`, one for each `U : opens X`, of the form `(Π x : U, T x) → Prop`
* a proof that if `f : Π x : V, T x` satisfies the predicate on `V : opens X`, then
  the restriction of `f` to any open subset `U` also satisfies the predicate.
-/
structure prelocal_predicate :=
(pred : Π {U : opens X}, (Π x : U, T x) → Prop)
(res : ∀ {U V : opens X} (i : U ⟶ V) (f : Π x : V, T x) (h : pred f), pred (λ x : U, f (i x)))

variables (X)
/--
Continuity is a "prelocal" predicate on functions to a fixed topological space `T`.
-/
@[simps]
def continuous_prelocal (T : Top.{v}) : prelocal_predicate (λ x : X, T) :=
{ pred := λ U f, continuous f,
  res := λ U V i f h, continuous.comp h (opens.open_embedding_of_le (le_of_hom i)).continuous, }

/-- Satisfying the inhabited linter. -/
instance inhabited_prelocal_predicate (T : Top.{v}) : inhabited (prelocal_predicate (λ x : X, T)) :=
⟨continuous_prelocal X T⟩

variables {X}

/--
Given a topological space `X : Top` and a type family `T : X → Type`,
a `P : local_predicate T` consists of:
* a family of predicates `P.pred`, one for each `U : opens X`, of the form `(Π x : U, T x) → Prop`
* a proof that if `f : Π x : V, T x` satisfies the predicate on `V : opens X`, then
  the restriction of `f` to any open subset `U` also satisfies the predicate, and
* a proof that given some `f : Π x : U, T x`,
  if for every `x : U` we can find an open set `x ∈ V ≤ U`
  so that the restriction of `f` to `V` satisfies the predicate,
  then `f` itself satisfies the predicate.
-/
structure local_predicate extends prelocal_predicate T :=
(locality : ∀ {U : opens X} (f : Π x : U, T x)
  (w : ∀ x : U, ∃ (V : opens X) (m : x.1 ∈ V) (i : V ⟶ U), pred (λ x : V, f (i x : U))), pred f)

variables (X)

/--
Continuity is a "local" predicate on functions to a fixed topological space `T`.
-/
def continuous_local (T : Top.{v}) : local_predicate (λ x : X, T) :=
{ locality := λ U f w,
   begin
     apply continuous_iff_continuous_at.2,
     intro x,
     specialize w x,
     rcases w with ⟨V, m, i, w⟩,
     dsimp at w,
     rw continuous_iff_continuous_at at w,
     specialize w ⟨x, m⟩,
     simpa using (opens.open_embedding_of_le (le_of_hom i)).continuous_at_iff.1 w,
   end,
  ..continuous_prelocal X T }

/-- Satisfying the inhabited linter. -/
instance inhabited_local_predicate (T : Top.{v}) : inhabited (local_predicate _) :=
⟨continuous_local X T⟩

variables {X T}

/--
Given a `P : prelocal_predicate`, we can always construct a `local_predicate`
by asking that the condition from `P` holds locally near every point.
-/
def prelocal_predicate.sheafify {T : X → Type v} (P : prelocal_predicate T) : local_predicate T :=
{ pred := λ U f, ∀ x : U, ∃ (V : opens X) (m : x.1 ∈ V) (i : V ⟶ U), P.pred (λ x : V, f (i x : U)),
  res := λ V U i f w x,
  begin
    specialize w (i x),
    rcases w with ⟨V', m', i', p⟩,
    refine ⟨V ⊓ V', ⟨x.2,m'⟩, opens.inf_le_left _ _, _⟩,
    convert P.res (opens.inf_le_right V V') _ p,
  end,
  locality := λ U f w x,
  begin
    specialize w x,
    rcases w with ⟨V, m, i, p⟩,
    specialize p ⟨x.1, m⟩,
    rcases p with ⟨V', m', i', p'⟩,
    exact ⟨V', m', i' ≫ i, p'⟩,
  end }

lemma prelocal_predicate.sheafify_of {T : X → Type v} {P : prelocal_predicate T}
  {U : opens X} {f : Π x : U, T x} (h : P.pred f) :
  P.sheafify.pred f :=
λ x, ⟨U, x.2, 𝟙 _, by { convert h, ext ⟨y, w⟩, refl, }⟩

/--
The subpresheaf of dependent functions on `X` satisfying the "pre-local" predicate `P`.
-/
@[simps]
def subpresheaf_to_Types (P : prelocal_predicate T) : presheaf (Type v) X :=
{ obj := λ U, { f : Π x : unop U, T x // P.pred f },
  map := λ U V i f, ⟨λ x, f.1 (i.unop x), P.res i.unop f.1 f.2⟩ }.

namespace subpresheaf_to_Types

variables (P : prelocal_predicate T)

/--
The natural transformation including the subpresheaf of functions satisfying a local predicate
into the presheaf of all functions.
-/
def subtype : subpresheaf_to_Types P ⟶ presheaf_to_Types X T :=
{ app := λ U f, f.1 }

open Top.presheaf

/--
The functions satisfying a local predicate satisfy the sheaf condition.
-/
def sheaf_condition
  (P : local_predicate T) :
  sheaf_condition (subpresheaf_to_Types P.to_prelocal_predicate) :=
sheaf_condition_of_exists_unique_gluing _ $ λ ι U sf sf_comp, begin
  -- We show the sheaf condition in terms of unique gluing.
  -- First we obtain a family of sections for the underlying sheaf of functions,
  -- by forgetting that the prediacte holds
  let sf' : Π i : ι, (presheaf_to_Types X T).obj (op (U i)) := λ i, (sf i).val,
  -- Since our original family is compatible, this one is as well
  have sf'_comp : (presheaf_to_Types X T).is_compatible U sf' := λ i j,
    congr_arg subtype.val (sf_comp i j),
  -- So, we can obtain a unique gluing
  obtain ⟨gl,gl_spec,gl_uniq⟩ := (sheaf_to_Types X T).exists_unique_gluing U sf' sf'_comp,
  refine ⟨⟨gl,_⟩,_,_⟩,
  { -- Our first goal is to show that this chosen gluing satisfies the
    -- predicate. Of course, we use locality of the predicate.
    apply P.locality,
    rintros ⟨x, mem⟩,
    -- Once we're at a particular point `x`, we can select some open set `x ∈ U i`.
    choose i hi using opens.mem_supr.mp mem,
    -- We claim that the predicate holds in `U i`
    use [U i, hi, opens.le_supr U i],
    -- This follows, since our original family `sf` satisfies the predicate
    convert (sf i).property,
    exact gl_spec i
  },
  -- It remains to show that the chosen lift is really a gluing for the subsheaf and
  -- that it is unique. Both of which follow immediately from the corresponding facts
  -- in the sheaf of functions without the local predicate.
  { intro i,
    ext1,
    exact (gl_spec i) },
  { intros gl' hgl',
    ext1,
    exact gl_uniq gl'.1 (λ i, congr_arg subtype.val (hgl' i)) },
end

end subpresheaf_to_Types

/--
The subsheaf of the sheaf of all dependently typed functions satisfying the local predicate `P`.
-/
@[simps]
def subsheaf_to_Types (P : local_predicate T) : sheaf (Type v) X :=
{ presheaf := subpresheaf_to_Types P.to_prelocal_predicate,
  sheaf_condition := subpresheaf_to_Types.sheaf_condition P }.

/--
There is a canonical map from the stalk to the original fiber, given by evaluating sections.
-/
def stalk_to_fiber (P : local_predicate T) (x : X) :
  (subsheaf_to_Types P).presheaf.stalk x ⟶ T x :=
begin
  refine colimit.desc _
    { X := T x, ι := { app := λ U f, _, naturality' := _ } },
  { exact f.1 ⟨x, (unop U).2⟩, },
  { tidy, }
end

@[simp] lemma stalk_to_fiber_germ (P : local_predicate T) (U : opens X) (x : U) (f) :
  stalk_to_fiber P x ((subsheaf_to_Types P).presheaf.germ x f) = f.1 x :=
begin
  dsimp [presheaf.germ, stalk_to_fiber],
  cases x,
  simp,
  refl,
end

/--
The `stalk_to_fiber` map is surjective at `x` if
every point in the fiber `T x` has an allowed section passing through it.
-/
lemma stalk_to_fiber_surjective (P : local_predicate T) (x : X)
  (w : ∀ (t : T x), ∃ (U : open_nhds x) (f : Π y : U.1, T y) (h : P.pred f), f ⟨x, U.2⟩ = t) :
  function.surjective (stalk_to_fiber P x) :=
λ t,
begin
  rcases w t with ⟨U, f, h, rfl⟩,
  fsplit,
  { exact (subsheaf_to_Types P).presheaf.germ ⟨x, U.2⟩ ⟨f, h⟩, },
  { exact stalk_to_fiber_germ _ U.1 ⟨x, U.2⟩ ⟨f, h⟩, }
end

/--
The `stalk_to_fiber` map is injective at `x` if any two allowed sections which agree at `x`
agree on some neighborhood of `x`.
-/
lemma stalk_to_fiber_injective (P : local_predicate T) (x : X)
  (w : ∀ (U V : open_nhds x) (fU : Π y : U.1, T y) (hU : P.pred fU)
    (fV : Π y : V.1, T y) (hV : P.pred fV) (e : fU ⟨x, U.2⟩ = fV ⟨x, V.2⟩),
    ∃ (W : open_nhds x) (iU : W ⟶ U) (iV : W ⟶ V), ∀ (w : W.1), fU (iU w : U.1) = fV (iV w : V.1)) :
  function.injective (stalk_to_fiber P x) :=
λ tU tV h,
begin
  -- We promise to provide all the ingredients of the proof later:
  let Q :
    ∃ (W : (open_nhds x)ᵒᵖ) (s : Π w : (unop W).1, T w) (hW : P.pred s),
      tU = (subsheaf_to_Types P).presheaf.germ ⟨x, (unop W).2⟩ ⟨s, hW⟩ ∧
      tV = (subsheaf_to_Types P).presheaf.germ ⟨x, (unop W).2⟩ ⟨s, hW⟩ := _,
  { choose W s hW e using Q,
    exact e.1.trans e.2.symm, },
  -- Then use induction to pick particular representatives of `tU tV : stalk x`
  obtain ⟨U, ⟨fU, hU⟩, rfl⟩ := jointly_surjective' tU,
  obtain ⟨V, ⟨fV, hV⟩, rfl⟩ := jointly_surjective' tV,
  { -- Decompose everything into its constituent parts:
    dsimp,
    simp only [stalk_to_fiber, colimit.ι_desc_apply] at h,
    specialize w (unop U) (unop V) fU hU fV hV h,
    rcases w with ⟨W, iU, iV, w⟩,
    -- and put it back together again in the correct order.
    refine ⟨(op W), (λ w, fU (iU w : (unop U).1)), P.res _ _ hU, _⟩,
    rcases W with ⟨W, m⟩,
    exact ⟨colimit_sound iU.op (subtype.eq rfl),
           colimit_sound iV.op (subtype.eq (funext w).symm)⟩, },
end

/--
Some repackaging:
the presheaf of functions satisfying `continuous_prelocal` is just the same thing as
the presheaf of continuous functions.
-/
def subpresheaf_continuous_prelocal_iso_presheaf_to_Top (T : Top.{v}) :
  subpresheaf_to_Types (continuous_prelocal X T) ≅ presheaf_to_Top X T :=
nat_iso.of_components
  (λ X,
  { hom := by { rintro ⟨f, c⟩, exact ⟨f, c⟩, },
    inv := by { rintro ⟨f, c⟩, exact ⟨f, c⟩, },
    hom_inv_id' := by { ext ⟨f, p⟩ x, refl, },
    inv_hom_id' := by { ext ⟨f, p⟩ x, refl, }, })
  (by tidy)

/--
The sheaf of continuous functions on `X` with values in a space `T`.
-/
def sheaf_to_Top (T : Top.{v}) : sheaf (Type v) X :=
{ presheaf := presheaf_to_Top X T,
  sheaf_condition :=
    presheaf.sheaf_condition_equiv_of_iso (subpresheaf_continuous_prelocal_iso_presheaf_to_Top T)
      (subpresheaf_to_Types.sheaf_condition (continuous_local X T)), }

end Top