/-
Copyright (c) 2020 Sébastien Gouëzel. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Sébastien Gouëzel, Jireh Loreaux

! This file was ported from Lean 3 source module analysis.normed_space.pi_Lp
! leanprover-community/mathlib commit 2fd0de23fbbf0f8a84dbb7bc2e7a2da45de67f8b
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Analysis.MeanInequalities
import Mathbin.Data.Fintype.Order

/-!
# `L^p` distance on finite products of metric spaces
Given finitely many metric spaces, one can put the max distance on their product, but there is also
a whole family of natural distances, indexed by a parameter `p : ℝ≥0∞`, that also induce
the product topology. We define them in this file. For `0 < p < ∞`, the distance on `Π i, α i`
is given by
$$
d(x, y) = \left(\sum d(x_i, y_i)^p\right)^{1/p}.
$$,
whereas for `p = 0` it is the cardinality of the set ${ i | x_i ≠ y_i}$. For `p = ∞` the distance
is the supremum of the distances.

We give instances of this construction for emetric spaces, metric spaces, normed groups and normed
spaces.

To avoid conflicting instances, all these are defined on a copy of the original Π-type, named
`pi_Lp p α`. The assumpion `[fact (1 ≤ p)]` is required for the metric and normed space instances.

We ensure that the topology, bornology and uniform structure on `pi_Lp p α` are (defeq to) the
product topology, product bornology and product uniformity, to be able to use freely continuity
statements for the coordinate functions, for instance.

## Implementation notes

We only deal with the `L^p` distance on a product of finitely many metric spaces, which may be
distinct. A closely related construction is `lp`, the `L^p` norm on a product of (possibly
infinitely many) normed spaces, where the norm is
$$
\left(\sum ‖f (x)‖^p \right)^{1/p}.
$$
However, the topology induced by this construction is not the product topology, and some functions
have infinite `L^p` norm. These subtleties are not present in the case of finitely many metric
spaces, hence it is worth devoting a file to this specific case which is particularly well behaved.

Another related construction is `measure_theory.Lp`, the `L^p` norm on the space of functions from
a measure space to a normed space, where the norm is
$$
\left(\int ‖f (x)‖^p dμ\right)^{1/p}.
$$
This has all the same subtleties as `lp`, and the further subtlety that this only
defines a seminorm (as almost everywhere zero functions have zero `L^p` norm).
The construction `pi_Lp` corresponds to the special case of `measure_theory.Lp` in which the basis
is a finite space equipped with the counting measure.

To prove that the topology (and the uniform structure) on a finite product with the `L^p` distance
are the same as those coming from the `L^∞` distance, we could argue that the `L^p` and `L^∞` norms
are equivalent on `ℝ^n` for abstract (norm equivalence) reasons. Instead, we give a more explicit
(easy) proof which provides a comparison between these two norms with explicit constants.

We also set up the theory for `pseudo_emetric_space` and `pseudo_metric_space`.
-/

open Real Set Filter IsROrC Bornology

open BigOperators uniformity Topology NNReal ENNReal

noncomputable section

/-- A copy of a Pi type, on which we will put the `L^p` distance. Since the Pi type itself is
already endowed with the `L^∞` distance, we need the type synonym to avoid confusing typeclass
resolution. Also, we let it depend on `p`, to get a whole family of type on which we can put
different distances. -/
@[nolint unused_arguments]
def PiLp (p : ℝ≥0∞) {ι : Type _} (α : ι → Type _) : Type _ :=
  ∀ i : ι, α i
#align pi_Lp PiLp

instance (p : ℝ≥0∞) {ι : Type _} (α : ι → Type _) [∀ i, Inhabited (α i)] : Inhabited (PiLp p α) :=
  ⟨fun i => default⟩

namespace PiLp

variable (p : ℝ≥0∞) (𝕜 𝕜' : Type _) {ι : Type _} (α : ι → Type _) (β : ι → Type _)

/-- Canonical bijection between `pi_Lp p α` and the original Pi type. We introduce it to be able
to compare the `L^p` and `L^∞` distances through it. -/
protected def equiv : PiLp p α ≃ ∀ i : ι, α i :=
  Equiv.refl _
#align pi_Lp.equiv PiLp.equiv

/-! Note that the unapplied versions of these lemmas are deliberately omitted, as they break
the use of the type synonym. -/

@[simp]
theorem equiv_apply (x : PiLp p α) (i : ι) : PiLp.equiv p α x i = x i :=
  rfl
#align pi_Lp.equiv_apply PiLp.equiv_apply

@[simp]
theorem equiv_symm_apply (x : ∀ i, α i) (i : ι) : (PiLp.equiv p α).symm x i = x i :=
  rfl
#align pi_Lp.equiv_symm_apply PiLp.equiv_symm_apply

section DistNorm

variable [Fintype ι]

/-!
### Definition of `edist`, `dist` and `norm` on `pi_Lp`

In this section we define the `edist`, `dist` and `norm` functions on `pi_Lp p α` without assuming
`[fact (1 ≤ p)]` or metric properties of the spaces `α i`. This allows us to provide the rewrite
lemmas for each of three cases `p = 0`, `p = ∞` and `0 < p.to_real`.
-/

section Edist

variable [∀ i, EDist (β i)]

/-- Endowing the space `pi_Lp p β` with the `L^p` edistance. We register this instance
separate from `pi_Lp.pseudo_emetric` since the latter requires the type class hypothesis
`[fact (1 ≤ p)]` in order to prove the triangle inequality.

Registering this separately allows for a future emetric-like structure on `pi_Lp p β` for `p < 1`
satisfying a relaxed triangle inequality. The terminology for this varies throughout the
literature, but it is sometimes called a *quasi-metric* or *semi-metric*. -/
instance : EDist (PiLp p β)
    where edist f g :=
    if hp : p = 0 then { i | f i ≠ g i }.toFinite.toFinset.card
    else
      if p = ∞ then ⨆ i, edist (f i) (g i) else (∑ i, edist (f i) (g i) ^ p.toReal) ^ (1 / p.toReal)

variable {β}

theorem edist_eq_card (f g : PiLp 0 β) : edist f g = { i | f i ≠ g i }.toFinite.toFinset.card :=
  if_pos rfl
#align pi_Lp.edist_eq_card PiLp.edist_eq_card

theorem edist_eq_sum {p : ℝ≥0∞} (hp : 0 < p.toReal) (f g : PiLp p β) :
    edist f g = (∑ i, edist (f i) (g i) ^ p.toReal) ^ (1 / p.toReal) :=
  let hp' := ENNReal.toReal_pos_iff.mp hp
  (if_neg hp'.1.ne').trans (if_neg hp'.2.Ne)
#align pi_Lp.edist_eq_sum PiLp.edist_eq_sum

theorem edist_eq_supᵢ (f g : PiLp ∞ β) : edist f g = ⨆ i, edist (f i) (g i) :=
  by
  dsimp [edist]
  exact if_neg ENNReal.top_ne_zero
#align pi_Lp.edist_eq_supr PiLp.edist_eq_supᵢ

end Edist

section EdistProp

variable {β} [∀ i, PseudoEMetricSpace (β i)]

/-- This holds independent of `p` and does not require `[fact (1 ≤ p)]`. We keep it separate
from `pi_Lp.pseudo_emetric_space` so it can be used also for `p < 1`. -/
protected theorem edist_self (f : PiLp p β) : edist f f = 0 :=
  by
  rcases p.trichotomy with (rfl | rfl | h)
  · simp [edist_eq_card]
  · simp [edist_eq_supr]
  · simp [edist_eq_sum h, ENNReal.zero_rpow_of_pos h, ENNReal.zero_rpow_of_pos (inv_pos.2 <| h)]
#align pi_Lp.edist_self PiLp.edist_self

/-- This holds independent of `p` and does not require `[fact (1 ≤ p)]`. We keep it separate
from `pi_Lp.pseudo_emetric_space` so it can be used also for `p < 1`. -/
protected theorem edist_comm (f g : PiLp p β) : edist f g = edist g f :=
  by
  rcases p.trichotomy with (rfl | rfl | h)
  · simp only [edist_eq_card, eq_comm, Ne.def]
  · simp only [edist_eq_supr, edist_comm]
  · simp only [edist_eq_sum h, edist_comm]
#align pi_Lp.edist_comm PiLp.edist_comm

end EdistProp

section Dist

variable [∀ i, Dist (α i)]

/-- Endowing the space `pi_Lp p β` with the `L^p` distance. We register this instance
separate from `pi_Lp.pseudo_metric` since the latter requires the type class hypothesis
`[fact (1 ≤ p)]` in order to prove the triangle inequality.

Registering this separately allows for a future metric-like structure on `pi_Lp p β` for `p < 1`
satisfying a relaxed triangle inequality. The terminology for this varies throughout the
literature, but it is sometimes called a *quasi-metric* or *semi-metric*. -/
instance : Dist (PiLp p α)
    where dist f g :=
    if hp : p = 0 then { i | f i ≠ g i }.toFinite.toFinset.card
    else
      if p = ∞ then ⨆ i, dist (f i) (g i) else (∑ i, dist (f i) (g i) ^ p.toReal) ^ (1 / p.toReal)

variable {α}

theorem dist_eq_card (f g : PiLp 0 α) : dist f g = { i | f i ≠ g i }.toFinite.toFinset.card :=
  if_pos rfl
#align pi_Lp.dist_eq_card PiLp.dist_eq_card

theorem dist_eq_sum {p : ℝ≥0∞} (hp : 0 < p.toReal) (f g : PiLp p α) :
    dist f g = (∑ i, dist (f i) (g i) ^ p.toReal) ^ (1 / p.toReal) :=
  let hp' := ENNReal.toReal_pos_iff.mp hp
  (if_neg hp'.1.ne').trans (if_neg hp'.2.Ne)
#align pi_Lp.dist_eq_sum PiLp.dist_eq_sum

theorem dist_eq_csupr (f g : PiLp ∞ α) : dist f g = ⨆ i, dist (f i) (g i) :=
  by
  dsimp [dist]
  exact if_neg ENNReal.top_ne_zero
#align pi_Lp.dist_eq_csupr PiLp.dist_eq_csupr

end Dist

section Norm

variable [∀ i, Norm (β i)] [∀ i, Zero (β i)]

/-- Endowing the space `pi_Lp p β` with the `L^p` norm. We register this instance
separate from `pi_Lp.seminormed_add_comm_group` since the latter requires the type class hypothesis
`[fact (1 ≤ p)]` in order to prove the triangle inequality.

Registering this separately allows for a future norm-like structure on `pi_Lp p β` for `p < 1`
satisfying a relaxed triangle inequality. These are called *quasi-norms*. -/
instance hasNorm : Norm (PiLp p β)
    where norm f :=
    if hp : p = 0 then { i | f i ≠ 0 }.toFinite.toFinset.card
    else if p = ∞ then ⨆ i, ‖f i‖ else (∑ i, ‖f i‖ ^ p.toReal) ^ (1 / p.toReal)
#align pi_Lp.has_norm PiLp.hasNorm

variable {p β}

theorem norm_eq_card (f : PiLp 0 β) : ‖f‖ = { i | f i ≠ 0 }.toFinite.toFinset.card :=
  if_pos rfl
#align pi_Lp.norm_eq_card PiLp.norm_eq_card

theorem norm_eq_csupr (f : PiLp ∞ β) : ‖f‖ = ⨆ i, ‖f i‖ :=
  by
  dsimp [norm]
  exact if_neg ENNReal.top_ne_zero
#align pi_Lp.norm_eq_csupr PiLp.norm_eq_csupr

theorem norm_eq_sum (hp : 0 < p.toReal) (f : PiLp p β) :
    ‖f‖ = (∑ i, ‖f i‖ ^ p.toReal) ^ (1 / p.toReal) :=
  let hp' := ENNReal.toReal_pos_iff.mp hp
  (if_neg hp'.1.ne').trans (if_neg hp'.2.Ne)
#align pi_Lp.norm_eq_sum PiLp.norm_eq_sum

end Norm

end DistNorm

section Aux

/-!
### The uniformity on finite `L^p` products is the product uniformity

In this section, we put the `L^p` edistance on `pi_Lp p α`, and we check that the uniformity
coming from this edistance coincides with the product uniformity, by showing that the canonical
map to the Pi type (with the `L^∞` distance) is a uniform embedding, as it is both Lipschitz and
antiLipschitz.

We only register this emetric space structure as a temporary instance, as the true instance (to be
registered later) will have as uniformity exactly the product uniformity, instead of the one coming
from the edistance (which is equal to it, but not defeq). See Note [forgetful inheritance]
explaining why having definitionally the right uniformity is often important.
-/

variable [Fact (1 ≤ p)] [∀ i, PseudoMetricSpace (α i)] [∀ i, PseudoEMetricSpace (β i)]

variable [Fintype ι]

/-- Endowing the space `pi_Lp p β` with the `L^p` pseudoemetric structure. This definition is not
satisfactory, as it does not register the fact that the topology and the uniform structure coincide
with the product one. Therefore, we do not register it as an instance. Using this as a temporary
pseudoemetric space instance, we will show that the uniform structure is equal (but not defeq) to
the product one, and then register an instance in which we replace the uniform structure by the
product one using this pseudoemetric space and `pseudo_emetric_space.replace_uniformity`. -/
def pseudoEmetricAux : PseudoEMetricSpace (PiLp p β)
    where
  edist_self := PiLp.edist_self p
  edist_comm := PiLp.edist_comm p
  edist_triangle f g h := by
    rcases p.dichotomy with (rfl | hp)
    · simp only [edist_eq_supr]
      cases isEmpty_or_nonempty ι
      · simp only [csupᵢ_of_empty, ENNReal.bot_eq_zero, add_zero, nonpos_iff_eq_zero]
      exact
        supᵢ_le fun i => (edist_triangle _ (g i) _).trans <| add_le_add (le_supᵢ _ i) (le_supᵢ _ i)
    · simp only [edist_eq_sum (zero_lt_one.trans_le hp)]
      calc
        (∑ i, edist (f i) (h i) ^ p.to_real) ^ (1 / p.to_real) ≤
            (∑ i, (edist (f i) (g i) + edist (g i) (h i)) ^ p.to_real) ^ (1 / p.to_real) :=
          by
          apply ENNReal.rpow_le_rpow _ (one_div_nonneg.2 <| zero_le_one.trans hp)
          refine' Finset.sum_le_sum fun i hi => _
          exact ENNReal.rpow_le_rpow (edist_triangle _ _ _) (zero_le_one.trans hp)
        _ ≤
            (∑ i, edist (f i) (g i) ^ p.to_real) ^ (1 / p.to_real) +
              (∑ i, edist (g i) (h i) ^ p.to_real) ^ (1 / p.to_real) :=
          ENNReal.Lp_add_le _ _ _ hp

#align pi_Lp.pseudo_emetric_aux PiLp.pseudoEmetricAux

attribute [local instance] PiLp.pseudoEmetricAux

/-- An auxiliary lemma used twice in the proof of `pi_Lp.pseudo_metric_aux` below. Not intended for
use outside this file. -/
theorem supᵢ_edist_ne_top_aux {ι : Type _} [Finite ι] {α : ι → Type _}
    [∀ i, PseudoMetricSpace (α i)] (f g : PiLp ∞ α) : (⨆ i, edist (f i) (g i)) ≠ ⊤ :=
  by
  cases nonempty_fintype ι
  obtain ⟨M, hM⟩ := Fintype.exists_le fun i => (⟨dist (f i) (g i), dist_nonneg⟩ : ℝ≥0)
  refine' ne_of_lt ((supᵢ_le fun i => _).trans_lt (@ENNReal.coe_lt_top M))
  simp only [edist, PseudoMetricSpace.edist_dist, ENNReal.ofReal_eq_coe_nnreal dist_nonneg]
  exact_mod_cast hM i
#align pi_Lp.supr_edist_ne_top_aux PiLp.supᵢ_edist_ne_top_aux

/-- Endowing the space `pi_Lp p α` with the `L^p` pseudometric structure. This definition is not
satisfactory, as it does not register the fact that the topology, the uniform structure, and the
bornology coincide with the product ones. Therefore, we do not register it as an instance. Using
this as a temporary pseudoemetric space instance, we will show that the uniform structure is equal
(but not defeq) to the product one, and then register an instance in which we replace the uniform
structure and the bornology by the product ones using this pseudometric space,
`pseudo_metric_space.replace_uniformity`, and `pseudo_metric_space.replace_bornology`.

See note [reducible non-instances] -/
@[reducible]
def pseudoMetricAux : PseudoMetricSpace (PiLp p α) :=
  PseudoEMetricSpace.toPseudoMetricSpaceOfDist dist
    (fun f g => by
      rcases p.dichotomy with (rfl | h)
      · exact supr_edist_ne_top_aux f g
      · rw [edist_eq_sum (zero_lt_one.trans_le h)]
        exact
          ENNReal.rpow_ne_top_of_nonneg (one_div_nonneg.2 (zero_le_one.trans h))
            (ne_of_lt <|
              ENNReal.sum_lt_top fun i hi =>
                ENNReal.rpow_ne_top_of_nonneg (zero_le_one.trans h) (edist_ne_top _ _)))
    fun f g => by
    rcases p.dichotomy with (rfl | h)
    · rw [edist_eq_supr, dist_eq_csupr]
      · cases isEmpty_or_nonempty ι
        · simp only [Real.csupᵢ_empty, csupᵢ_of_empty, ENNReal.bot_eq_zero, ENNReal.zero_toReal]
        · refine' le_antisymm (csupᵢ_le fun i => _) _
          · rw [← ENNReal.ofReal_le_iff_le_toReal (supr_edist_ne_top_aux f g), ←
              PseudoMetricSpace.edist_dist]
            exact le_supᵢ _ i
          · refine' ENNReal.toReal_le_of_le_ofReal (Real.supₛ_nonneg _ _) (supᵢ_le fun i => _)
            · rintro - ⟨i, rfl⟩
              exact dist_nonneg
            · unfold edist
              rw [PseudoMetricSpace.edist_dist]
              exact ENNReal.ofReal_le_ofReal (le_csupᵢ (Fintype.bddAbove_range _) i)
    · have A : ∀ i, edist (f i) (g i) ^ p.to_real ≠ ⊤ := fun i =>
        ENNReal.rpow_ne_top_of_nonneg (zero_le_one.trans h) (edist_ne_top _ _)
      simp only [edist_eq_sum (zero_lt_one.trans_le h), dist_edist, ENNReal.toReal_rpow,
        dist_eq_sum (zero_lt_one.trans_le h), ← ENNReal.toReal_sum fun i _ => A i]
#align pi_Lp.pseudo_metric_aux PiLp.pseudoMetricAux

attribute [local instance] PiLp.pseudoMetricAux

theorem lipschitzWith_equiv_aux : LipschitzWith 1 (PiLp.equiv p β) :=
  by
  intro x y
  rcases p.dichotomy with (rfl | h)
  ·
    simpa only [ENNReal.coe_one, one_mul, edist_eq_supr, edist, Finset.sup_le_iff, Finset.mem_univ,
      forall_true_left] using le_supᵢ fun i => edist (x i) (y i)
  · have cancel : p.to_real * (1 / p.to_real) = 1 := mul_div_cancel' 1 (zero_lt_one.trans_le h).ne'
    rw [edist_eq_sum (zero_lt_one.trans_le h)]
    simp only [edist, forall_prop_of_true, one_mul, Finset.mem_univ, Finset.sup_le_iff,
      ENNReal.coe_one]
    intro i
    calc
      edist (x i) (y i) = (edist (x i) (y i) ^ p.to_real) ^ (1 / p.to_real) := by
        simp [← ENNReal.rpow_mul, cancel, -one_div]
      _ ≤ (∑ i, edist (x i) (y i) ^ p.to_real) ^ (1 / p.to_real) :=
        by
        apply ENNReal.rpow_le_rpow _ (one_div_nonneg.2 <| zero_le_one.trans h)
        exact Finset.single_le_sum (fun i hi => (bot_le : (0 : ℝ≥0∞) ≤ _)) (Finset.mem_univ i)

#align pi_Lp.lipschitz_with_equiv_aux PiLp.lipschitzWith_equiv_aux

theorem antilipschitzWith_equiv_aux :
    AntilipschitzWith ((Fintype.card ι : ℝ≥0) ^ (1 / p).toReal) (PiLp.equiv p β) :=
  by
  intro x y
  rcases p.dichotomy with (rfl | h)
  · simp only [edist_eq_supr, ENNReal.div_top, ENNReal.zero_toReal, NNReal.rpow_zero,
      ENNReal.coe_one, one_mul, supᵢ_le_iff]
    exact fun i => Finset.le_sup (Finset.mem_univ i)
  · have pos : 0 < p.to_real := zero_lt_one.trans_le h
    have nonneg : 0 ≤ 1 / p.to_real := one_div_nonneg.2 (le_of_lt Pos)
    have cancel : p.to_real * (1 / p.to_real) = 1 := mul_div_cancel' 1 (ne_of_gt Pos)
    rw [edist_eq_sum Pos, ENNReal.toReal_div 1 p]
    simp only [edist, ← one_div, ENNReal.one_toReal]
    calc
      (∑ i, edist (x i) (y i) ^ p.to_real) ^ (1 / p.to_real) ≤
          (∑ i, edist (PiLp.equiv p β x) (PiLp.equiv p β y) ^ p.to_real) ^ (1 / p.to_real) :=
        by
        apply ENNReal.rpow_le_rpow _ nonneg
        apply Finset.sum_le_sum fun i hi => _
        apply ENNReal.rpow_le_rpow _ (le_of_lt Pos)
        exact Finset.le_sup (Finset.mem_univ i)
      _ =
          ((Fintype.card ι : ℝ≥0) ^ (1 / p.to_real) : ℝ≥0) *
            edist (PiLp.equiv p β x) (PiLp.equiv p β y) :=
        by
        simp only [nsmul_eq_mul, Finset.card_univ, ENNReal.rpow_one, Finset.sum_const,
          ENNReal.mul_rpow_of_nonneg _ _ nonneg, ← ENNReal.rpow_mul, cancel]
        have : (Fintype.card ι : ℝ≥0∞) = (Fintype.card ι : ℝ≥0) :=
          (ENNReal.coe_nat (Fintype.card ι)).symm
        rw [this, ENNReal.coe_rpow_of_nonneg _ nonneg]

#align pi_Lp.antilipschitz_with_equiv_aux PiLp.antilipschitzWith_equiv_aux

theorem aux_uniformity_eq : 𝓤 (PiLp p β) = 𝓤[Pi.uniformSpace _] :=
  by
  have A : UniformInducing (PiLp.equiv p β) :=
    (antilipschitz_with_equiv_aux p β).UniformInducing
      (lipschitz_with_equiv_aux p β).UniformContinuous
  have : (fun x : PiLp p β × PiLp p β => ((PiLp.equiv p β) x.fst, (PiLp.equiv p β) x.snd)) = id :=
    by ext i <;> rfl
  rw [← A.comap_uniformity, this, comap_id]
#align pi_Lp.aux_uniformity_eq PiLp.aux_uniformity_eq

theorem aux_cobounded_eq : cobounded (PiLp p α) = @cobounded _ Pi.bornology :=
  calc
    cobounded (PiLp p α) = comap (PiLp.equiv p α) (cobounded _) :=
      le_antisymm (antilipschitzWith_equiv_aux p α).tendsto_cobounded.le_comap
        (lipschitzWith_equiv_aux p α).comap_cobounded_le
    _ = _ := comap_id

#align pi_Lp.aux_cobounded_eq PiLp.aux_cobounded_eq

end Aux

/-! ### Instances on finite `L^p` products -/

instance uniformSpace [∀ i, UniformSpace (β i)] : UniformSpace (PiLp p β) :=
  Pi.uniformSpace _
#align pi_Lp.uniform_space PiLp.uniformSpace

theorem uniformContinuous_equiv [∀ i, UniformSpace (β i)] : UniformContinuous (PiLp.equiv p β) :=
  uniformContinuous_id
#align pi_Lp.uniform_continuous_equiv PiLp.uniformContinuous_equiv

theorem uniformContinuous_equiv_symm [∀ i, UniformSpace (β i)] :
    UniformContinuous (PiLp.equiv p β).symm :=
  uniformContinuous_id
#align pi_Lp.uniform_continuous_equiv_symm PiLp.uniformContinuous_equiv_symm

@[continuity]
theorem continuous_equiv [∀ i, UniformSpace (β i)] : Continuous (PiLp.equiv p β) :=
  continuous_id
#align pi_Lp.continuous_equiv PiLp.continuous_equiv

@[continuity]
theorem continuous_equiv_symm [∀ i, UniformSpace (β i)] : Continuous (PiLp.equiv p β).symm :=
  continuous_id
#align pi_Lp.continuous_equiv_symm PiLp.continuous_equiv_symm

variable [Fintype ι]

instance bornology [∀ i, Bornology (β i)] : Bornology (PiLp p β) :=
  Pi.bornology
#align pi_Lp.bornology PiLp.bornology

-- throughout the rest of the file, we assume `1 ≤ p`
variable [Fact (1 ≤ p)]

/-- pseudoemetric space instance on the product of finitely many pseudoemetric spaces, using the
`L^p` pseudoedistance, and having as uniformity the product uniformity. -/
instance [∀ i, PseudoEMetricSpace (β i)] : PseudoEMetricSpace (PiLp p β) :=
  (pseudoEmetricAux p β).replaceUniformity (aux_uniformity_eq p β).symm

/-- emetric space instance on the product of finitely many emetric spaces, using the `L^p`
edistance, and having as uniformity the product uniformity. -/
instance [∀ i, EMetricSpace (α i)] : EMetricSpace (PiLp p α) :=
  @EMetricSpace.ofT0PseudoEMetricSpace (PiLp p α) _ Pi.t0Space

/-- pseudometric space instance on the product of finitely many psuedometric spaces, using the
`L^p` distance, and having as uniformity the product uniformity. -/
instance [∀ i, PseudoMetricSpace (β i)] : PseudoMetricSpace (PiLp p β) :=
  ((pseudoMetricAux p β).replaceUniformity (aux_uniformity_eq p β).symm).replaceBornology fun s =>
    Filter.ext_iff.1 (aux_cobounded_eq p β).symm (sᶜ)

/-- metric space instance on the product of finitely many metric spaces, using the `L^p` distance,
and having as uniformity the product uniformity. -/
instance [∀ i, MetricSpace (α i)] : MetricSpace (PiLp p α) :=
  MetricSpace.ofT0PseudoMetricSpace _

theorem nndist_eq_sum {p : ℝ≥0∞} [Fact (1 ≤ p)] {β : ι → Type _} [∀ i, PseudoMetricSpace (β i)]
    (hp : p ≠ ∞) (x y : PiLp p β) :
    nndist x y = (∑ i : ι, nndist (x i) (y i) ^ p.toReal) ^ (1 / p.toReal) :=
  Subtype.ext <| by
    push_cast
    exact dist_eq_sum (p.to_real_pos_iff_ne_top.mpr hp) _ _
#align pi_Lp.nndist_eq_sum PiLp.nndist_eq_sum

theorem nndist_eq_supᵢ {β : ι → Type _} [∀ i, PseudoMetricSpace (β i)] (x y : PiLp ∞ β) :
    nndist x y = ⨆ i, nndist (x i) (y i) :=
  Subtype.ext <| by
    push_cast
    exact dist_eq_csupr _ _
#align pi_Lp.nndist_eq_supr PiLp.nndist_eq_supᵢ

theorem lipschitzWith_equiv [∀ i, PseudoEMetricSpace (β i)] : LipschitzWith 1 (PiLp.equiv p β) :=
  lipschitzWith_equiv_aux p β
#align pi_Lp.lipschitz_with_equiv PiLp.lipschitzWith_equiv

theorem antilipschitzWith_equiv [∀ i, PseudoEMetricSpace (β i)] :
    AntilipschitzWith ((Fintype.card ι : ℝ≥0) ^ (1 / p).toReal) (PiLp.equiv p β) :=
  antilipschitzWith_equiv_aux p β
#align pi_Lp.antilipschitz_with_equiv PiLp.antilipschitzWith_equiv

theorem infty_equiv_isometry [∀ i, PseudoEMetricSpace (β i)] : Isometry (PiLp.equiv ∞ β) :=
  fun x y =>
  le_antisymm (by simpa only [ENNReal.coe_one, one_mul] using lipschitz_with_equiv ∞ β x y)
    (by
      simpa only [ENNReal.div_top, ENNReal.zero_toReal, NNReal.rpow_zero, ENNReal.coe_one,
        one_mul] using antilipschitz_with_equiv ∞ β x y)
#align pi_Lp.infty_equiv_isometry PiLp.infty_equiv_isometry

variable (p β)

/-- seminormed group instance on the product of finitely many normed groups, using the `L^p`
norm. -/
instance seminormedAddCommGroup [∀ i, SeminormedAddCommGroup (β i)] :
    SeminormedAddCommGroup (PiLp p β) :=
  { Pi.addCommGroup with
    dist_eq := fun x y => by
      rcases p.dichotomy with (rfl | h)
      · simpa only [dist_eq_csupr, norm_eq_csupr, dist_eq_norm]
      · have : p ≠ ∞ := by
          intro hp
          rw [hp, ENNReal.top_toReal] at h
          linarith
        simpa only [dist_eq_sum (zero_lt_one.trans_le h), norm_eq_sum (zero_lt_one.trans_le h),
          dist_eq_norm] }
#align pi_Lp.seminormed_add_comm_group PiLp.seminormedAddCommGroup

/-- normed group instance on the product of finitely many normed groups, using the `L^p` norm. -/
instance normedAddCommGroup [∀ i, NormedAddCommGroup (α i)] : NormedAddCommGroup (PiLp p α) :=
  { PiLp.seminormedAddCommGroup p α with }
#align pi_Lp.normed_add_comm_group PiLp.normedAddCommGroup

theorem nnnorm_eq_sum {p : ℝ≥0∞} [Fact (1 ≤ p)] {β : ι → Type _} (hp : p ≠ ∞)
    [∀ i, SeminormedAddCommGroup (β i)] (f : PiLp p β) :
    ‖f‖₊ = (∑ i, ‖f i‖₊ ^ p.toReal) ^ (1 / p.toReal) :=
  by
  ext
  simp [NNReal.coe_sum, norm_eq_sum (p.to_real_pos_iff_ne_top.mpr hp)]
#align pi_Lp.nnnorm_eq_sum PiLp.nnnorm_eq_sum

theorem nnnorm_eq_csupr {β : ι → Type _} [∀ i, SeminormedAddCommGroup (β i)] (f : PiLp ∞ β) :
    ‖f‖₊ = ⨆ i, ‖f i‖₊ := by
  ext
  simp [NNReal.coe_supᵢ, norm_eq_csupr]
#align pi_Lp.nnnorm_eq_csupr PiLp.nnnorm_eq_csupr

theorem norm_eq_of_nat {p : ℝ≥0∞} [Fact (1 ≤ p)] {β : ι → Type _}
    [∀ i, SeminormedAddCommGroup (β i)] (n : ℕ) (h : p = n) (f : PiLp p β) :
    ‖f‖ = (∑ i, ‖f i‖ ^ n) ^ (1 / (n : ℝ)) :=
  by
  have := p.to_real_pos_iff_ne_top.mpr (ne_of_eq_of_ne h <| ENNReal.nat_ne_top n)
  simp only [one_div, h, Real.rpow_nat_cast, ENNReal.toReal_nat, eq_self_iff_true, Finset.sum_congr,
    norm_eq_sum this]
#align pi_Lp.norm_eq_of_nat PiLp.norm_eq_of_nat

theorem norm_eq_of_L2 {β : ι → Type _} [∀ i, SeminormedAddCommGroup (β i)] (x : PiLp 2 β) :
    ‖x‖ = sqrt (∑ i : ι, ‖x i‖ ^ 2) :=
  by
  convert norm_eq_of_nat 2 (by norm_cast) _
  rw [sqrt_eq_rpow]
  norm_cast
#align pi_Lp.norm_eq_of_L2 PiLp.norm_eq_of_L2

theorem nnnorm_eq_of_L2 {β : ι → Type _} [∀ i, SeminormedAddCommGroup (β i)] (x : PiLp 2 β) :
    ‖x‖₊ = NNReal.sqrt (∑ i : ι, ‖x i‖₊ ^ 2) :=
  Subtype.ext <| by
    push_cast
    exact norm_eq_of_L2 x
#align pi_Lp.nnnorm_eq_of_L2 PiLp.nnnorm_eq_of_L2

theorem norm_sq_eq_of_L2 (β : ι → Type _) [∀ i, SeminormedAddCommGroup (β i)] (x : PiLp 2 β) :
    ‖x‖ ^ 2 = ∑ i : ι, ‖x i‖ ^ 2 :=
  by
  suffices ‖x‖₊ ^ 2 = ∑ i : ι, ‖x i‖₊ ^ 2 by
    simpa only [NNReal.coe_sum] using congr_arg (coe : ℝ≥0 → ℝ) this
  rw [nnnorm_eq_of_L2, NNReal.sq_sqrt]
#align pi_Lp.norm_sq_eq_of_L2 PiLp.norm_sq_eq_of_L2

theorem dist_eq_of_L2 {β : ι → Type _} [∀ i, SeminormedAddCommGroup (β i)] (x y : PiLp 2 β) :
    dist x y = (∑ i, dist (x i) (y i) ^ 2).sqrt := by
  simp_rw [dist_eq_norm, norm_eq_of_L2, Pi.sub_apply]
#align pi_Lp.dist_eq_of_L2 PiLp.dist_eq_of_L2

theorem nndist_eq_of_L2 {β : ι → Type _} [∀ i, SeminormedAddCommGroup (β i)] (x y : PiLp 2 β) :
    nndist x y = (∑ i, nndist (x i) (y i) ^ 2).sqrt :=
  Subtype.ext <| by
    push_cast
    exact dist_eq_of_L2 _ _
#align pi_Lp.nndist_eq_of_L2 PiLp.nndist_eq_of_L2

theorem edist_eq_of_L2 {β : ι → Type _} [∀ i, SeminormedAddCommGroup (β i)] (x y : PiLp 2 β) :
    edist x y = (∑ i, edist (x i) (y i) ^ 2) ^ (1 / 2 : ℝ) := by simp [PiLp.edist_eq_sum]
#align pi_Lp.edist_eq_of_L2 PiLp.edist_eq_of_L2

variable [NormedField 𝕜] [NormedField 𝕜']

/-- The product of finitely many normed spaces is a normed space, with the `L^p` norm. -/
instance normedSpace [∀ i, SeminormedAddCommGroup (β i)] [∀ i, NormedSpace 𝕜 (β i)] :
    NormedSpace 𝕜 (PiLp p β) :=
  { Pi.module ι β 𝕜 with
    norm_smul_le := fun c f => by
      rcases p.dichotomy with (rfl | hp)
      · letI : Module 𝕜 (PiLp ∞ β) := Pi.module ι β 𝕜
        suffices ‖c • f‖₊ = ‖c‖₊ * ‖f‖₊ by exact_mod_cast NNReal.coe_mono this.le
        simpa only [nnnorm_eq_csupr, NNReal.mul_supᵢ, ← nnnorm_smul]
      · have : p.to_real * (1 / p.to_real) = 1 := mul_div_cancel' 1 (zero_lt_one.trans_le hp).ne'
        simp only [norm_eq_sum (zero_lt_one.trans_le hp), norm_smul, mul_rpow, norm_nonneg, ←
          Finset.mul_sum, Pi.smul_apply]
        rw [mul_rpow (rpow_nonneg_of_nonneg (norm_nonneg _) _), ← rpow_mul (norm_nonneg _), this,
          rpow_one]
        exact Finset.sum_nonneg fun i hi => rpow_nonneg_of_nonneg (norm_nonneg _) _ }
#align pi_Lp.normed_space PiLp.normedSpace

instance isScalarTower [∀ i, SeminormedAddCommGroup (β i)] [SMul 𝕜 𝕜'] [∀ i, NormedSpace 𝕜 (β i)]
    [∀ i, NormedSpace 𝕜' (β i)] [∀ i, IsScalarTower 𝕜 𝕜' (β i)] : IsScalarTower 𝕜 𝕜' (PiLp p β) :=
  Pi.isScalarTower
#align pi_Lp.is_scalar_tower PiLp.isScalarTower

instance sMulCommClass [∀ i, SeminormedAddCommGroup (β i)] [∀ i, NormedSpace 𝕜 (β i)]
    [∀ i, NormedSpace 𝕜' (β i)] [∀ i, SMulCommClass 𝕜 𝕜' (β i)] : SMulCommClass 𝕜 𝕜' (PiLp p β) :=
  Pi.smulCommClass
#align pi_Lp.smul_comm_class PiLp.sMulCommClass

instance finiteDimensional [∀ i, SeminormedAddCommGroup (β i)] [∀ i, NormedSpace 𝕜 (β i)]
    [I : ∀ i, FiniteDimensional 𝕜 (β i)] : FiniteDimensional 𝕜 (PiLp p β) :=
  FiniteDimensional.finiteDimensional_pi' _ _
#align pi_Lp.finite_dimensional PiLp.finiteDimensional

/- Register simplification lemmas for the applications of `pi_Lp` elements, as the usual lemmas
for Pi types will not trigger. -/
variable {𝕜 𝕜' p α} [∀ i, SeminormedAddCommGroup (β i)] [∀ i, NormedSpace 𝕜 (β i)] (c : 𝕜)

variable (x y : PiLp p β) (x' y' : ∀ i, β i) (i : ι)

@[simp]
theorem zero_apply : (0 : PiLp p β) i = 0 :=
  rfl
#align pi_Lp.zero_apply PiLp.zero_apply

@[simp]
theorem add_apply : (x + y) i = x i + y i :=
  rfl
#align pi_Lp.add_apply PiLp.add_apply

@[simp]
theorem sub_apply : (x - y) i = x i - y i :=
  rfl
#align pi_Lp.sub_apply PiLp.sub_apply

@[simp]
theorem smul_apply : (c • x) i = c • x i :=
  rfl
#align pi_Lp.smul_apply PiLp.smul_apply

@[simp]
theorem neg_apply : (-x) i = -x i :=
  rfl
#align pi_Lp.neg_apply PiLp.neg_apply

/-- The canonical map `pi_Lp.equiv` between `pi_Lp ∞ β` and `Π i, β i` as a linear isometric
equivalence. -/
def equivₗᵢ : PiLp ∞ β ≃ₗᵢ[𝕜] ∀ i, β i :=
  { PiLp.equiv ∞ β with
    map_add' := fun f g => rfl
    map_smul' := fun c f => rfl
    norm_map' := fun f =>
      by
      suffices (finset.univ.sup fun i => ‖f i‖₊) = ⨆ i, ‖f i‖₊ by
        simpa only [NNReal.coe_supᵢ] using congr_arg (coe : ℝ≥0 → ℝ) this
      refine'
        antisymm (Finset.sup_le fun i _ => le_csupᵢ (Fintype.bddAbove_range fun i => ‖f i‖₊) _) _
      cases isEmpty_or_nonempty ι
      · simp only [csupᵢ_of_empty, Finset.univ_eq_empty, Finset.sup_empty]
      · exact csupᵢ_le fun i => Finset.le_sup (Finset.mem_univ i) }
#align pi_Lp.equivₗᵢ PiLp.equivₗᵢ

variable {ι' : Type _}

variable [Fintype ι']

variable (p 𝕜) (E : Type _) [NormedAddCommGroup E] [NormedSpace 𝕜 E]

/-- An equivalence of finite domains induces a linearly isometric equivalence of finitely supported
functions-/
def LinearIsometryEquiv.piLpCongrLeft (e : ι ≃ ι') :
    (PiLp p fun i : ι => E) ≃ₗᵢ[𝕜] PiLp p fun i : ι' => E
    where
  toLinearEquiv := LinearEquiv.piCongrLeft' 𝕜 (fun i : ι => E) e
  norm_map' x := by
    rcases p.dichotomy with (rfl | h)
    · simp_rw [norm_eq_csupr, LinearEquiv.piCongrLeft'_apply 𝕜 (fun i : ι => E) e x _]
      exact e.symm.supr_congr fun i => rfl
    · simp only [norm_eq_sum (zero_lt_one.trans_le h)]
      simp_rw [LinearEquiv.piCongrLeft'_apply 𝕜 (fun i : ι => E) e x _]
      congr
      exact Fintype.sum_equiv e.symm _ _ fun i => rfl
#align linear_isometry_equiv.pi_Lp_congr_left LinearIsometryEquiv.piLpCongrLeft

variable {p 𝕜 E}

@[simp]
theorem LinearIsometryEquiv.piLpCongrLeft_apply (e : ι ≃ ι') (v : PiLp p fun i : ι => E) :
    LinearIsometryEquiv.piLpCongrLeft p 𝕜 E e v = Equiv.piCongrLeft' (fun i : ι => E) e v :=
  rfl
#align linear_isometry_equiv.pi_Lp_congr_left_apply LinearIsometryEquiv.piLpCongrLeft_apply

@[simp]
theorem LinearIsometryEquiv.piLpCongrLeft_symm (e : ι ≃ ι') :
    (LinearIsometryEquiv.piLpCongrLeft p 𝕜 E e).symm =
      LinearIsometryEquiv.piLpCongrLeft p 𝕜 E e.symm :=
  LinearIsometryEquiv.ext fun x => rfl
#align linear_isometry_equiv.pi_Lp_congr_left_symm LinearIsometryEquiv.piLpCongrLeft_symm

@[simp]
theorem LinearIsometryEquiv.piLpCongrLeft_single [DecidableEq ι] [DecidableEq ι'] (e : ι ≃ ι')
    (i : ι) (v : E) :
    LinearIsometryEquiv.piLpCongrLeft p 𝕜 E e (Pi.single i v) = Pi.single (e i) v :=
  by
  funext x
  simp [LinearIsometryEquiv.piLpCongrLeft, LinearEquiv.piCongrLeft', Equiv.piCongrLeft', Pi.single,
    Function.update, Equiv.symm_apply_eq]
#align linear_isometry_equiv.pi_Lp_congr_left_single LinearIsometryEquiv.piLpCongrLeft_single

@[simp]
theorem equiv_zero : PiLp.equiv p β 0 = 0 :=
  rfl
#align pi_Lp.equiv_zero PiLp.equiv_zero

@[simp]
theorem equiv_symm_zero : (PiLp.equiv p β).symm 0 = 0 :=
  rfl
#align pi_Lp.equiv_symm_zero PiLp.equiv_symm_zero

@[simp]
theorem equiv_add : PiLp.equiv p β (x + y) = PiLp.equiv p β x + PiLp.equiv p β y :=
  rfl
#align pi_Lp.equiv_add PiLp.equiv_add

@[simp]
theorem equiv_symm_add :
    (PiLp.equiv p β).symm (x' + y') = (PiLp.equiv p β).symm x' + (PiLp.equiv p β).symm y' :=
  rfl
#align pi_Lp.equiv_symm_add PiLp.equiv_symm_add

@[simp]
theorem equiv_sub : PiLp.equiv p β (x - y) = PiLp.equiv p β x - PiLp.equiv p β y :=
  rfl
#align pi_Lp.equiv_sub PiLp.equiv_sub

@[simp]
theorem equiv_symm_sub :
    (PiLp.equiv p β).symm (x' - y') = (PiLp.equiv p β).symm x' - (PiLp.equiv p β).symm y' :=
  rfl
#align pi_Lp.equiv_symm_sub PiLp.equiv_symm_sub

@[simp]
theorem equiv_neg : PiLp.equiv p β (-x) = -PiLp.equiv p β x :=
  rfl
#align pi_Lp.equiv_neg PiLp.equiv_neg

@[simp]
theorem equiv_symm_neg : (PiLp.equiv p β).symm (-x') = -(PiLp.equiv p β).symm x' :=
  rfl
#align pi_Lp.equiv_symm_neg PiLp.equiv_symm_neg

@[simp]
theorem equiv_smul : PiLp.equiv p β (c • x) = c • PiLp.equiv p β x :=
  rfl
#align pi_Lp.equiv_smul PiLp.equiv_smul

@[simp]
theorem equiv_symm_smul : (PiLp.equiv p β).symm (c • x') = c • (PiLp.equiv p β).symm x' :=
  rfl
#align pi_Lp.equiv_symm_smul PiLp.equiv_symm_smul

/-- When `p = ∞`, this lemma does not hold without the additional assumption `nonempty ι` because
the left-hand side simplifies to `0`, while the right-hand side simplifies to `‖b‖₊`. See
`pi_Lp.nnnorm_equiv_symm_const'` for a version which exchanges the hypothesis `p ≠ ∞` for
`nonempty ι`. -/
theorem nnnorm_equiv_symm_const {β} [SeminormedAddCommGroup β] (hp : p ≠ ∞) (b : β) :
    ‖(PiLp.equiv p fun _ : ι => β).symm (Function.const _ b)‖₊ =
      Fintype.card ι ^ (1 / p).toReal * ‖b‖₊ :=
  by
  rcases p.dichotomy with (h | h)
  · exact False.elim (hp h)
  · have ne_zero : p.to_real ≠ 0 := (zero_lt_one.trans_le h).ne'
    simp_rw [nnnorm_eq_sum hp, equiv_symm_apply, Function.const_apply, Finset.sum_const,
      Finset.card_univ, nsmul_eq_mul, NNReal.mul_rpow, ← NNReal.rpow_mul, mul_one_div_cancel NeZero,
      NNReal.rpow_one, ENNReal.toReal_div, ENNReal.one_toReal]
#align pi_Lp.nnnorm_equiv_symm_const PiLp.nnnorm_equiv_symm_const

/-- When `is_empty ι`, this lemma does not hold without the additional assumption `p ≠ ∞` because
the left-hand side simplifies to `0`, while the right-hand side simplifies to `‖b‖₊`. See
`pi_Lp.nnnorm_equiv_symm_const` for a version which exchanges the hypothesis `nonempty ι`.
for `p ≠ ∞`. -/
theorem nnnorm_equiv_symm_const' {β} [SeminormedAddCommGroup β] [Nonempty ι] (b : β) :
    ‖(PiLp.equiv p fun _ : ι => β).symm (Function.const _ b)‖₊ =
      Fintype.card ι ^ (1 / p).toReal * ‖b‖₊ :=
  by
  rcases em <| p = ∞ with (rfl | hp)
  ·
    simp only [equiv_symm_apply, ENNReal.div_top, ENNReal.zero_toReal, NNReal.rpow_zero, one_mul,
      nnnorm_eq_csupr, Function.const_apply, csupᵢ_const]
  · exact nnnorm_equiv_symm_const hp b
#align pi_Lp.nnnorm_equiv_symm_const' PiLp.nnnorm_equiv_symm_const'

/-- When `p = ∞`, this lemma does not hold without the additional assumption `nonempty ι` because
the left-hand side simplifies to `0`, while the right-hand side simplifies to `‖b‖₊`. See
`pi_Lp.norm_equiv_symm_const'` for a version which exchanges the hypothesis `p ≠ ∞` for
`nonempty ι`. -/
theorem norm_equiv_symm_const {β} [SeminormedAddCommGroup β] (hp : p ≠ ∞) (b : β) :
    ‖(PiLp.equiv p fun _ : ι => β).symm (Function.const _ b)‖ =
      Fintype.card ι ^ (1 / p).toReal * ‖b‖ :=
  (congr_arg coe <| nnnorm_equiv_symm_const hp b).trans <| by simp
#align pi_Lp.norm_equiv_symm_const PiLp.norm_equiv_symm_const

/-- When `is_empty ι`, this lemma does not hold without the additional assumption `p ≠ ∞` because
the left-hand side simplifies to `0`, while the right-hand side simplifies to `‖b‖₊`. See
`pi_Lp.norm_equiv_symm_const` for a version which exchanges the hypothesis `nonempty ι`.
for `p ≠ ∞`. -/
theorem norm_equiv_symm_const' {β} [SeminormedAddCommGroup β] [Nonempty ι] (b : β) :
    ‖(PiLp.equiv p fun _ : ι => β).symm (Function.const _ b)‖ =
      Fintype.card ι ^ (1 / p).toReal * ‖b‖ :=
  (congr_arg coe <| nnnorm_equiv_symm_const' b).trans <| by simp
#align pi_Lp.norm_equiv_symm_const' PiLp.norm_equiv_symm_const'

theorem nnnorm_equiv_symm_one {β} [SeminormedAddCommGroup β] (hp : p ≠ ∞) [One β] :
    ‖(PiLp.equiv p fun _ : ι => β).symm 1‖₊ = Fintype.card ι ^ (1 / p).toReal * ‖(1 : β)‖₊ :=
  (nnnorm_equiv_symm_const hp (1 : β)).trans rfl
#align pi_Lp.nnnorm_equiv_symm_one PiLp.nnnorm_equiv_symm_one

theorem norm_equiv_symm_one {β} [SeminormedAddCommGroup β] (hp : p ≠ ∞) [One β] :
    ‖(PiLp.equiv p fun _ : ι => β).symm 1‖ = Fintype.card ι ^ (1 / p).toReal * ‖(1 : β)‖ :=
  (norm_equiv_symm_const hp (1 : β)).trans rfl
#align pi_Lp.norm_equiv_symm_one PiLp.norm_equiv_symm_one

variable (𝕜 p)

/-- `pi_Lp.equiv` as a linear map. -/
@[simps (config := { fullyApplied := false })]
protected def linearEquiv : PiLp p β ≃ₗ[𝕜] ∀ i, β i :=
  { LinearEquiv.refl _ _ with
    toFun := PiLp.equiv _ _
    invFun := (PiLp.equiv _ _).symm }
#align pi_Lp.linear_equiv PiLp.linearEquiv

section Basis

variable (ι)

/-- A version of `pi.basis_fun` for `pi_Lp`. -/
def basisFun : Basis ι 𝕜 (PiLp p fun _ => 𝕜) :=
  Basis.ofEquivFun (PiLp.linearEquiv p 𝕜 fun _ : ι => 𝕜)
#align pi_Lp.basis_fun PiLp.basisFun

@[simp]
theorem basisFun_apply [DecidableEq ι] (i) :
    basisFun p 𝕜 ι i = (PiLp.equiv p _).symm (Pi.single i 1) := by
  simp_rw [basis_fun, Basis.coe_ofEquivFun, PiLp.linearEquiv_symm_apply, Pi.single]
#align pi_Lp.basis_fun_apply PiLp.basisFun_apply

@[simp]
theorem basisFun_repr (x : PiLp p fun i : ι => 𝕜) (i : ι) : (basisFun p 𝕜 ι).repr x i = x i :=
  rfl
#align pi_Lp.basis_fun_repr PiLp.basisFun_repr

theorem basisFun_eq_pi_basisFun :
    basisFun p 𝕜 ι = (Pi.basisFun 𝕜 ι).map (PiLp.linearEquiv p 𝕜 fun _ : ι => 𝕜).symm :=
  rfl
#align pi_Lp.basis_fun_eq_pi_basis_fun PiLp.basisFun_eq_pi_basisFun

@[simp]
theorem basisFun_map :
    (basisFun p 𝕜 ι).map (PiLp.linearEquiv p 𝕜 fun _ : ι => 𝕜) = Pi.basisFun 𝕜 ι :=
  rfl
#align pi_Lp.basis_fun_map PiLp.basisFun_map

open Matrix

theorem basis_toMatrix_basisFun_mul (b : Basis ι 𝕜 (PiLp p fun i : ι => 𝕜)) (A : Matrix ι ι 𝕜) :
    b.toMatrix (PiLp.basisFun _ _ _) ⬝ A =
      Matrix.of fun i j => b.repr ((PiLp.equiv _ _).symm (Aᵀ j)) i :=
  by
  have := basis_toMatrix_basisFun_mul (b.map (PiLp.linearEquiv _ 𝕜 _)) A
  simp_rw [← PiLp.basisFun_map p, Basis.map_repr, LinearEquiv.trans_apply,
    PiLp.linearEquiv_symm_apply, Basis.toMatrix_map, Function.comp, Basis.map_apply,
    LinearEquiv.symm_apply_apply] at this
  exact this
#align pi_Lp.basis_to_matrix_basis_fun_mul PiLp.basis_toMatrix_basisFun_mul

end Basis

end PiLp


import tactic data.rat
open_locale big_operators
open finset

theorem sqrt2' : ¬ (∃ m n : ℕ, m ≠ 0 ∧ 2 * m^2 = n ^2) :=
begin
  sorry,
end

theorem sqrt2 : ¬ (∃ m n : ℤ, m ≠ 0 ∧ 2 * m^2 = n ^2) :=
begin
  by_contradiction,
  apply sqrt2',
  rcases a with ⟨m,n,hm, hmn⟩,
  use [m.nat_abs, n.nat_abs],
  split,
  exact int.nat_abs_ne_zero_of_ne_zero hm,
  have m1 := int.nat_abs_pow_two m,
  have n1 := int.nat_abs_pow_two n,
  rw ←m1 at hmn,
  rw ←n1 at hmn,
  norm_cast at hmn,
  exact hmn,
end

lemma temp (n : ℤ) : n * n = n^2 :=
begin
  ring,
end

example : ¬ (∃ q : ℚ, 2 = q * q) :=
begin
  by_contradiction,
  cases a with q key,
  have := rat.eq_iff_mul_eq_mul.mp key,
  have triv : (2:ℚ).denom = 1, refl,
  rw triv at this,
  have triv : (2:ℚ).num = 2, refl,
  rw triv at this,
  rw rat.mul_self_denom at this,
  rw rat.mul_self_num at this,
  simp only [mul_one, int.coe_nat_zero, int.coe_nat_succ, zero_add, int.coe_nat_mul] at this,
  rw temp at this, rw temp at this,
  apply sqrt2,
  use q.denom, use q.num,
  split,
  norm_cast,
  exact rat.denom_ne_zero q,
  exact this,
  -- have : 2 * (↑(q.denom) ^2) = q.num ^2, rw ←temp,
end

example (p q : rat) : q.denom ≠ 0 :=
begin
  exact rat.denom_ne_zero q
end

example (m : int ) : m ^ 2 = (m.nat_abs)^2 :=
begin
  exact (int.nat_abs_pow_two m).symm,
end


/-
Copyright (c) 2015 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura, Johannes Hölzl, Mario Carneiro

An efficient binary implementation of a (sqrt n) function that
returns s s.t.
    s*s ≤ n ≤ s*s + s + s
-/
import data.nat.basic algebra.ordered_group algebra.ring tactic

namespace nat

theorem sqrt_aux_dec {b} (h : b ≠ 0) : shiftr b 2 < b :=
begin
  simp [shiftr_eq_div_pow],
  apply (nat.div_lt_iff_lt_mul' (dec_trivial : 4 > 0)).2,
  have := nat.mul_lt_mul_of_pos_left
    (dec_trivial : 1 < 4) (nat.pos_of_ne_zero h),
  rwa mul_one at this
end

def sqrt_aux : ℕ → ℕ → ℕ → ℕ
| b r n := if b0 : b = 0 then r else
  let b' := shiftr b 2 in
  have b' < b, from sqrt_aux_dec b0,
  match (n - (r + b : ℕ) : ℤ) with
  | (n' : ℕ) := sqrt_aux b' (div2 r + b) n'
  | _ := sqrt_aux b' (div2 r) n
  end

/-- `sqrt n` is the square root of a natural number `n`. If `n` is not a
  perfect square, it returns the largest `k:ℕ` such that `k*k ≤ n`. -/
def sqrt (n : ℕ) : ℕ :=
match size n with
| 0      := 0
| succ s := sqrt_aux (shiftl 1 (bit0 (div2 s))) 0 n
end

theorem sqrt_aux_0 (r n) : sqrt_aux 0 r n = r :=
by rw sqrt_aux; simp
local attribute [simp] sqrt_aux_0

theorem sqrt_aux_1 {r n b} (h : b ≠ 0) {n'} (h₂ : r + b + n' = n) :
  sqrt_aux b r n = sqrt_aux (shiftr b 2) (div2 r + b) n' :=
by rw sqrt_aux; simp only [h, h₂.symm, int.coe_nat_add, if_false];
   rw [add_comm _ (n':ℤ), add_sub_cancel, sqrt_aux._match_1]

theorem sqrt_aux_2 {r n b} (h : b ≠ 0) (h₂ : n < r + b) :
  sqrt_aux b r n = sqrt_aux (shiftr b 2) (div2 r) n :=
begin
  rw sqrt_aux; simp only [h, h₂, if_false],
  cases int.eq_neg_succ_of_lt_zero
    (sub_lt_zero.2 (int.coe_nat_lt_coe_nat_of_lt h₂)) with k e,
  rw [e, sqrt_aux._match_1]
end

private def is_sqrt (n q : ℕ) : Prop := q*q ≤ n ∧ n < (q+1)*(q+1)

private lemma sqrt_aux_is_sqrt_lemma (m r n : ℕ)
  (h₁ : r*r ≤ n)
  (m') (hm : shiftr (2^m * 2^m) 2 = m')
  (H1 : n < (r + 2^m) * (r + 2^m) →
    is_sqrt n (sqrt_aux m' (r * 2^m) (n - r * r)))
  (H2 : (r + 2^m) * (r + 2^m) ≤ n →
    is_sqrt n (sqrt_aux m' ((r + 2^m) * 2^m) (n - (r + 2^m) * (r + 2^m)))) :
  is_sqrt n (sqrt_aux (2^m * 2^m) ((2*r)*2^m) (n - r*r)) :=
begin
  have b0 :=
    have b0:_, from ne_of_gt (@pos_pow_of_pos 2 m dec_trivial),
    nat.mul_ne_zero b0 b0,
  have lb : n - r * r < 2 * r * 2^m + 2^m * 2^m ↔
            n < (r+2^m)*(r+2^m), {
    rw [nat.sub_lt_right_iff_lt_add h₁],
    simp [left_distrib, right_distrib, two_mul, mul_comm, mul_assoc] },
  have re : div2 (2 * r * 2^m) = r * 2^m, {
    rw [div2_val, mul_assoc,
        nat.mul_div_cancel_left _ (dec_trivial:2>0)] },
  cases lt_or_ge n ((r+2^m)*(r+2^m)) with hl hl,
  { rw [sqrt_aux_2 b0 (lb.2 hl), hm, re], apply H1 hl },
  { cases le.dest hl with n' e,
    rw [@sqrt_aux_1 (2 * r * 2^m) (n-r*r) (2^m * 2^m) b0 (n - (r + 2^m) * (r + 2^m)),
      hm, re, ← right_distrib],
    { apply H2 hl },
    apply eq.symm, apply nat.sub_eq_of_eq_add,
    rw [← add_assoc, (_ : r*r + _ = _)],
    exact (nat.add_sub_cancel' hl).symm,
    simp [left_distrib, right_distrib, two_mul, mul_comm, mul_assoc] },
end

private lemma sqrt_aux_is_sqrt (n) : ∀ m r,
  r*r ≤ n → n < (r + 2^(m+1)) * (r + 2^(m+1)) →
  is_sqrt n (sqrt_aux (2^m * 2^m) (2*r*2^m) (n - r*r))
| 0 r h₁ h₂ := by apply sqrt_aux_is_sqrt_lemma 0 r n h₁ 0 rfl;
  intros; simp; [exact ⟨h₁, a⟩, exact ⟨a, h₂⟩]
| (m+1) r h₁ h₂ := begin
    apply sqrt_aux_is_sqrt_lemma
      (m+1) r n h₁ (2^m * 2^m)
      (by simp [shiftr, pow_succ, div2_val, mul_comm, mul_left_comm];
          repeat {rw @nat.mul_div_cancel_left _ 2 dec_trivial});
      intros,
    { have := sqrt_aux_is_sqrt m r h₁ a,
      simpa [pow_succ, mul_comm, mul_assoc] },
    { rw [pow_succ, mul_two, ← add_assoc] at h₂,
      have := sqrt_aux_is_sqrt m (r + 2^(m+1)) a h₂,
      rwa show (r + 2^(m + 1)) * 2^(m+1) = 2 * (r + 2^(m + 1)) * 2^m,
          by simp [pow_succ, mul_comm, mul_left_comm] }
  end

private lemma sqrt_is_sqrt (n : ℕ) : is_sqrt n (sqrt n) :=
begin
  generalize e : size n = s, cases s with s; simp [e, sqrt],
  { rw [size_eq_zero.1 e, is_sqrt], exact dec_trivial },
  { have := sqrt_aux_is_sqrt n (div2 s) 0 (zero_le _),
    simp [show 2^div2 s * 2^div2 s = shiftl 1 (bit0 (div2 s)), by {
      generalize: div2 s = x,
      change bit0 x with x+x,
      rw [one_shiftl, pow_add] }] at this,
    apply this,
    rw [← pow_add, ← mul_two], apply size_le.1,
    rw e, apply (@div_lt_iff_lt_mul _ _ 2 dec_trivial).1,
    rw [div2_val], apply lt_succ_self }
end

theorem sqrt_le (n : ℕ) : sqrt n * sqrt n ≤ n :=
(sqrt_is_sqrt n).left

theorem lt_succ_sqrt (n : ℕ) : n < succ (sqrt n) * succ (sqrt n) :=
(sqrt_is_sqrt n).right

theorem sqrt_le_add (n : ℕ) : n ≤ sqrt n * sqrt n + sqrt n + sqrt n :=
by rw ← succ_mul; exact le_of_lt_succ (lt_succ_sqrt n)

theorem le_sqrt {m n : ℕ} : m ≤ sqrt n ↔ m*m ≤ n :=
⟨λ h, le_trans (mul_self_le_mul_self h) (sqrt_le n),
 λ h, le_of_lt_succ $ mul_self_lt_mul_self_iff.2 $
   lt_of_le_of_lt h (lt_succ_sqrt n)⟩

theorem sqrt_lt {m n : ℕ} : sqrt m < n ↔ m < n*n :=
lt_iff_lt_of_le_iff_le le_sqrt

theorem sqrt_le_self (n : ℕ) : sqrt n ≤ n :=
le_trans (le_mul_self _) (sqrt_le n)

theorem sqrt_le_sqrt {m n : ℕ} (h : m ≤ n) : sqrt m ≤ sqrt n :=
le_sqrt.2 (le_trans (sqrt_le _) h)

theorem sqrt_eq_zero {n : ℕ} : sqrt n = 0 ↔ n = 0 :=
⟨λ h, eq_zero_of_le_zero $ le_of_lt_succ $ (@sqrt_lt n 1).1 $
  by rw [h]; exact dec_trivial,
 λ e, e.symm ▸ rfl⟩

theorem eq_sqrt {n q} : q = sqrt n ↔ q*q ≤ n ∧ n < (q+1)*(q+1) :=
⟨λ e, e.symm ▸ sqrt_is_sqrt n,
 λ ⟨h₁, h₂⟩, le_antisymm (le_sqrt.2 h₁) (le_of_lt_succ $ sqrt_lt.2 h₂)⟩

theorem le_three_of_sqrt_eq_one {n : ℕ} (h : sqrt n = 1) : n ≤ 3 :=
le_of_lt_succ $ (@sqrt_lt n 2).1 $
by rw [h]; exact dec_trivial

theorem sqrt_lt_self {n : ℕ} (h : n > 1) : sqrt n < n :=
sqrt_lt.2 $ by
  have := nat.mul_lt_mul_of_pos_left h (lt_of_succ_lt h);
  rwa [mul_one] at this

theorem sqrt_pos {n : ℕ} : sqrt n > 0 ↔ n > 0 := le_sqrt

theorem sqrt_add_eq (n : ℕ) {a : ℕ} (h : a ≤ n + n) : sqrt (n*n + a) = n :=
le_antisymm
  (le_of_lt_succ $ sqrt_lt.2 $ by rw [succ_mul, mul_succ, add_succ, add_assoc];
    exact lt_succ_of_le (nat.add_le_add_left h _))
  (le_sqrt.2 $ nat.le_add_right _ _)

theorem sqrt_eq (n : ℕ) : sqrt (n*n) = n :=
sqrt_add_eq n (zero_le _)

theorem exists_mul_self (x : ℕ) :
  (∃ n, n * n = x) ↔ sqrt x * sqrt x = x :=
⟨λ ⟨n, hn⟩, by rw [← hn, sqrt_eq], λ h, ⟨sqrt x, h⟩⟩

end nat


/-
Copyright (c) 2017 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl, Kenny Lau, Yury Kudryashov

! This file was ported from Lean 3 source module order.fixed_points
! leanprover-community/mathlib commit ba2245edf0c8bb155f1569fd9b9492a9b384cde6
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Dynamics.FixedPoints.Basic
import Mathlib.Order.Hom.Order
import Mathlib.Tactic.Set

/-!
# Fixed point construction on complete lattices

This file sets up the basic theory of fixed points of a monotone function in a complete lattice.

## Main definitions

* `OrderHom.lfp`: The least fixed point of a bundled monotone function.
* `OrderHom.gfp`: The greatest fixed point of a bundled monotone function.
* `OrderHom.prevFixed`: The greatest fixed point of a bundled monotone function smaller than or
  equal to a given element.
* `OrderHom.nextFixed`: The least fixed point of a bundled monotone function greater than or
  equal to a given element.
* `fixedPoints.completeLattice`: The Knaster-Tarski theorem: fixed points of a monotone
  self-map of a complete lattice form themselves a complete lattice.

## Tags

fixed point, complete lattice, monotone function
-/

universe u v w

variable {α : Type u} {β : Type v} {γ : Type w}

open Function (fixedPoints IsFixedPt)

namespace OrderHom

section Basic

variable [CompleteLattice α] (f : α →o α)

/-- Least fixed point of a monotone function -/
def lfp : (α →o α) →o α where
  toFun f := infₛ { a | f a ≤ a }
  monotone' _ _ hle := infₛ_le_infₛ fun a ha => (hle a).trans ha
#align order_hom.lfp OrderHom.lfp

/-- Greatest fixed point of a monotone function -/
def gfp : (α →o α) →o α where
  toFun f := supₛ { a | a ≤ f a }
  monotone' _ _ hle := supₛ_le_supₛ fun a ha => le_trans ha (hle a)
#align order_hom.gfp OrderHom.gfp

theorem lfp_le {a : α} (h : f a ≤ a) : lfp f ≤ a :=
  infₛ_le h
#align order_hom.lfp_le OrderHom.lfp_le

theorem lfp_le_fixed {a : α} (h : f a = a) : lfp f ≤ a :=
  f.lfp_le h.le
#align order_hom.lfp_le_fixed OrderHom.lfp_le_fixed

theorem le_lfp {a : α} (h : ∀ b, f b ≤ b → a ≤ b) : a ≤ lfp f :=
  le_infₛ h
#align order_hom.le_lfp OrderHom.le_lfp

-- porting note: for the rest of the file, replace the dot notation `_.lfp` with `lfp _`
-- same for `_.gfp`, `_.dual`
-- Probably related to https://github.com/leanprover/lean4/issues/1910
theorem map_le_lfp {a : α} (ha : a ≤ lfp f) : f a ≤ lfp f :=
  f.le_lfp fun _ hb => (f.mono <| le_infₛ_iff.1 ha _ hb).trans hb
#align order_hom.map_le_lfp OrderHom.map_le_lfp

@[simp]
theorem map_lfp : f (lfp f) = lfp f :=
  have h : f (lfp f) ≤ lfp f := f.map_le_lfp le_rfl
  h.antisymm <| f.lfp_le <| f.mono h
#align order_hom.map_lfp OrderHom.map_lfp

theorem isFixedPt_lfp : IsFixedPt f (lfp f) :=
  f.map_lfp
#align order_hom.is_fixed_pt_lfp OrderHom.isFixedPt_lfp

theorem lfp_le_map {a : α} (ha : lfp f ≤ a) : lfp f ≤ f a :=
  calc
    lfp f = f (lfp f) := f.map_lfp.symm
    _ ≤ f a := f.mono ha

#align order_hom.lfp_le_map OrderHom.lfp_le_map

theorem isLeast_lfp_le : IsLeast { a | f a ≤ a } (lfp f) :=
  ⟨f.map_lfp.le, fun _ => f.lfp_le⟩
#align order_hom.is_least_lfp_le OrderHom.isLeast_lfp_le

theorem isLeast_lfp : IsLeast (fixedPoints f) (lfp f) :=
  ⟨f.isFixedPt_lfp, fun _ => f.lfp_le_fixed⟩
#align order_hom.is_least_lfp OrderHom.isLeast_lfp_le

theorem lfp_induction {p : α → Prop} (step : ∀ a, p a → a ≤ lfp f → p (f a))
    (hSup : ∀ s, (∀ a ∈ s, p a) → p (supₛ s)) : p (lfp f) := by
  set s := { a | a ≤ lfp f ∧ p a }
  specialize hSup s fun a => And.right
  suffices : supₛ s = lfp f
  exact this ▸ hSup
  have h : supₛ s ≤ lfp f := supₛ_le fun b => And.left
  have hmem : f (supₛ s) ∈ s := ⟨f.map_le_lfp h, step _ hSup h⟩
  exact h.antisymm (f.lfp_le <| le_supₛ hmem)
#align order_hom.lfp_induction OrderHom.lfp_induction

theorem le_gfp {a : α} (h : a ≤ f a) : a ≤ gfp f :=
  le_supₛ h
#align order_hom.le_gfp OrderHom.le_gfp

theorem gfp_le {a : α} (h : ∀ b, b ≤ f b → b ≤ a) : gfp f ≤ a :=
  supₛ_le h
#align order_hom.gfp_le OrderHom.gfp_le

theorem isFixedPt_gfp : IsFixedPt f (gfp f) :=
  f.dual.isFixedPt_lfp
#align order_hom.is_fixed_pt_gfp OrderHom.isFixedPt_gfp

@[simp]
theorem map_gfp : f (gfp f) = gfp f :=
  f.dual.map_lfp
#align order_hom.map_gfp OrderHom.map_gfp

theorem map_le_gfp {a : α} (ha : a ≤ gfp f) : f a ≤ gfp f :=
  f.dual.lfp_le_map ha
#align order_hom.map_le_gfp OrderHom.map_le_gfp

theorem gfp_le_map {a : α} (ha : gfp f ≤ a) : gfp f ≤ f a :=
  f.dual.map_le_lfp ha
#align order_hom.gfp_le_map OrderHom.gfp_le_map

theorem isGreatest_gfp_le : IsGreatest { a | a ≤ f a } (gfp f) :=
  f.dual.isLeast_lfp_le
#align order_hom.is_greatest_gfp_le OrderHom.isGreatest_gfp_le

theorem isGreatest_gfp : IsGreatest (fixedPoints f) (gfp f) :=
  f.dual.isLeast_lfp
#align order_hom.is_greatest_gfp OrderHom.isGreatest_gfp

theorem gfp_induction {p : α → Prop} (step : ∀ a, p a → gfp f ≤ a → p (f a))
    (hInf : ∀ s, (∀ a ∈ s, p a) → p (infₛ s)) : p (gfp f) :=
  f.dual.lfp_induction step hInf
#align order_hom.gfp_induction OrderHom.gfp_induction

end Basic

section Eqn

variable [CompleteLattice α] [CompleteLattice β] (f : β →o α) (g : α →o β)

-- Rolling rule
theorem map_lfp_comp : f (lfp (g.comp f)) = lfp (f.comp g) :=
  le_antisymm ((f.comp g).map_lfp ▸ f.mono (lfp_le_fixed _ <| congr_arg g (f.comp g).map_lfp)) <|
    lfp_le _ (congr_arg f (g.comp f).map_lfp).le
#align order_hom.map_lfp_comp OrderHom.map_lfp_comp

theorem map_gfp_comp : f (gfp (g.comp f)) = gfp (f.comp g) :=
  f.dual.map_lfp_comp (OrderHom.dual g)
#align order_hom.map_gfp_comp OrderHom.map_gfp_comp

-- Diagonal rule
theorem lfp_lfp (h : α →o α →o α) : lfp (lfp.comp h) = lfp h.onDiag := by
  let a := lfp (lfp.comp h)
  refine' (lfp_le _ _).antisymm (lfp_le _ (Eq.le _))
  · exact lfp_le _ h.onDiag.map_lfp.le
  have ha : (lfp ∘ h) a = a := (lfp.comp h).map_lfp
  calc
    h a a = h a (lfp (h a)) := congr_arg (h a) ha.symm
    _ = lfp (h a) := (h a).map_lfp
    _ = a := ha
#align order_hom.lfp_lfp OrderHom.lfp_lfp

theorem gfp_gfp (h : α →o α →o α) : gfp (gfp.comp h) = gfp h.onDiag :=
  @lfp_lfp αᵒᵈ _ <| (OrderHom.dualIso αᵒᵈ αᵒᵈ).symm.toOrderEmbedding.toOrderHom.comp
    (OrderHom.dual h)
#align order_hom.gfp_gfp OrderHom.gfp_gfp

end Eqn

section PrevNext

variable [CompleteLattice α] (f : α →o α)

/-- Previous fixed point of a monotone map. If `f` is a monotone self-map of a complete lattice and
`x` is a point such that `f x ≤ x`, then `f.prevFixed x hx` is the greatest fixed point of `f`
that is less than or equal to `x`. -/
def prevFixed (x : α) (hx : f x ≤ x) : fixedPoints f :=
  ⟨gfp (const α x ⊓ f),
    calc
      f (gfp (const α x ⊓ f)) = x ⊓ f (gfp (const α x ⊓ f)) :=
        Eq.symm <| inf_of_le_right <| (f.mono <| f.gfp_const_inf_le x).trans hx
      _ = gfp (const α x ⊓ f) := (const α x ⊓ f).map_gfp
      ⟩
#align order_hom.prev_fixed OrderHom.prevFixed

/-- Next fixed point of a monotone map. If `f` is a monotone self-map of a complete lattice and
`x` is a point such that `x ≤ f x`, then `f.nextFixed x hx` is the least fixed point of `f`
that is greater than or equal to `x`. -/
def nextFixed (x : α) (hx : x ≤ f x) : fixedPoints f :=
  { f.dual.prevFixed x hx with val := lfp (const α x ⊔ f) }
#align order_hom.next_fixed OrderHom.nextFixed

theorem prevFixed_le {x : α} (hx : f x ≤ x) : ↑(f.prevFixed x hx) ≤ x :=
  f.gfp_const_inf_le x
#align order_hom.prev_fixed_le OrderHom.prevFixed_le

theorem le_nextFixed {x : α} (hx : x ≤ f x) : x ≤ f.nextFixed x hx :=
  f.dual.prevFixed_le hx
#align order_hom.le_next_fixed OrderHom.le_nextFixed

theorem nextFixed_le {x : α} (hx : x ≤ f x) {y : fixedPoints f} (h : x ≤ y) :
    f.nextFixed x hx ≤ y :=
  Subtype.coe_le_coe.1 <| lfp_le _ <| sup_le h y.2.le
#align order_hom.next_fixed_le OrderHom.nextFixed_le

@[simp]
theorem nextFixed_le_iff {x : α} (hx : x ≤ f x) {y : fixedPoints f} :
    f.nextFixed x hx ≤ y ↔ x ≤ y :=
  ⟨fun h => (f.le_nextFixed hx).trans h, f.nextFixed_le hx⟩
#align order_hom.next_fixed_le_iff OrderHom.nextFixed_le_iff

@[simp]
theorem le_prevFixed_iff {x : α} (hx : f x ≤ x) {y : fixedPoints f} :
    y ≤ f.prevFixed x hx ↔ ↑y ≤ x :=
  f.dual.nextFixed_le_iff hx
#align order_hom.le_prev_fixed_iff OrderHom.le_prevFixed_iff

theorem le_prevFixed {x : α} (hx : f x ≤ x) {y : fixedPoints f} (h : ↑y ≤ x) :
    y ≤ f.prevFixed x hx :=
  (f.le_prevFixed_iff hx).2 h
#align order_hom.le_prev_fixed OrderHom.le_prevFixed

theorem le_map_sup_fixedPoints (x y : fixedPoints f) : (x ⊔ y : α) ≤ f (x ⊔ y) :=
  calc
    (x ⊔ y : α) = f x ⊔ f y := congr_arg₂ (· ⊔ ·) x.2.symm y.2.symm
    _ ≤ f (x ⊔ y) := f.mono.le_map_sup x y
#align order_hom.le_map_sup_fixed_points OrderHom.le_map_sup_fixedPoints

-- porting note: `x ⊓ y` without the `.val`sw fails to synthesize `Inf` instance
theorem map_inf_fixedPoints_le (x y : fixedPoints f) : f (x ⊓ y) ≤ x.val ⊓ y.val :=
  f.dual.le_map_sup_fixedPoints x y
#align order_hom.map_inf_fixed_points_le OrderHom.map_inf_fixedPoints_le

theorem le_map_supₛ_subset_fixedPoints (A : Set α) (hA : A ⊆ fixedPoints f) :
    supₛ A ≤ f (supₛ A) :=
  supₛ_le fun _ hx => hA hx ▸ (f.mono <| le_supₛ hx)
#align order_hom.le_map_Sup_subset_fixed_points OrderHom.le_map_supₛ_subset_fixedPoints

theorem map_infₛ_subset_fixedPoints_le (A : Set α) (hA : A ⊆ fixedPoints f) :
    f (infₛ A) ≤ infₛ A :=
  le_infₛ fun _ hx => hA hx ▸ (f.mono <| infₛ_le hx)
#align order_hom.map_Inf_subset_fixed_points_le OrderHom.map_infₛ_subset_fixedPoints_le

end PrevNext

end OrderHom

namespace fixedPoints

open OrderHom

variable [CompleteLattice α] (f : α →o α)

instance : SemilatticeSup (fixedPoints f) :=
  { Subtype.partialOrder _ with
    sup := fun x y => f.nextFixed (x ⊔ y) (f.le_map_sup_fixedPoints x y)
    le_sup_left := fun _ _ => Subtype.coe_le_coe.1 <| le_sup_left.trans (f.le_nextFixed _)
    le_sup_right := fun _ _ => Subtype.coe_le_coe.1 <| le_sup_right.trans (f.le_nextFixed _)
    sup_le := fun _ _ _ hxz hyz => f.nextFixed_le _ <| sup_le hxz hyz }

/- porting note: removed `Subtype.partialOrder _` from mathlib3port version,
  threw `typeclass instance` error and was seemingly unnecessary?-/
instance : SemilatticeInf (fixedPoints f) :=
  { OrderDual.semilatticeInf (fixedPoints (OrderHom.dual f)) with
    inf := fun x y => f.prevFixed (x ⊓ y) (f.map_inf_fixedPoints_le x y) }

-- porting note: `coe` replaced with `Subtype.val`
instance : CompleteSemilatticeSup (fixedPoints f) :=
  { Subtype.partialOrder _ with
    supₛ := fun s =>
      f.nextFixed (supₛ (Subtype.val '' s))
        (f.le_map_supₛ_subset_fixedPoints (Subtype.val '' s)
          fun _ ⟨x, hx⟩ => hx.2 ▸ x.2)
    le_supₛ := fun _ _ hx =>
      Subtype.coe_le_coe.1 <| le_trans (le_supₛ <| Set.mem_image_of_mem _ hx) (f.le_nextFixed _)
    supₛ_le := fun _ _ hx => f.nextFixed_le _ <| supₛ_le <| Set.ball_image_iff.2 hx }

instance : CompleteSemilatticeInf (fixedPoints f) :=
  { Subtype.partialOrder _ with
    infₛ := fun s =>
      f.prevFixed (infₛ (Subtype.val '' s))
        (f.map_infₛ_subset_fixedPoints_le (Subtype.val '' s) fun _ ⟨x, hx⟩ => hx.2 ▸ x.2)
    le_infₛ := fun _ _ hx => f.le_prevFixed _ <| le_infₛ <| Set.ball_image_iff.2 hx
    infₛ_le := fun _ _ hx =>
      Subtype.coe_le_coe.1 <| le_trans (f.prevFixed_le _) (infₛ_le <| Set.mem_image_of_mem _ hx) }

/- porting note: mathlib3port version contained the instances as a list,
   giving various "expected structure" errors -/
/-- **Knaster-Tarski Theorem**: The fixed points of `f` form a complete lattice. -/
instance completeLattice : CompleteLattice (fixedPoints f) where
  __ := inferInstanceAs (SemilatticeInf (fixedPoints f))
  __ := inferInstanceAs (SemilatticeSup (fixedPoints f))
  __ := inferInstanceAs (CompleteSemilatticeInf (fixedPoints f))
  __ := inferInstanceAs (CompleteSemilatticeSup (fixedPoints f))
  top := ⟨gfp f, f.isFixedPt_gfp⟩
  bot := ⟨lfp f, f.isFixedPt_lfp⟩
  le_top x := f.le_gfp x.2.ge
  bot_le x := f.lfp_le x.2.le


import tactic

section enum_types

inductive weekday : Type
| sunday : weekday
| monday : weekday
| tuesday : weekday
| wednesday : weekday
| thursday : weekday
| friday : weekday
| saturday : weekday

def number_of_day (d : weekday) : ℕ :=
  weekday.rec_on d 1 2 3 4 5 6 7
def number_of_day' (d : weekday) : ℕ :=
  weekday.cases_on d 1 2 3 4 5 6 7

#reduce number_of_day weekday.wednesday

namespace weekday

def next (d : weekday) : weekday :=
  weekday.cases_on d monday tuesday wednesday thursday
    friday saturday sunday

def previous (d : weekday) : weekday :=
  weekday.cases_on d saturday sunday monday tuesday
    wednesday thursday friday

example (d : weekday) : next (previous d) = d :=
  by apply weekday.cases_on d; refl

end weekday

end enum_types

section args

universes u v

inductive prod2 (α : Type u) (β : Type v)
| mk : α → β → prod2

inductive sum2 (α : Type u) (β : Type v)
| inl : α → sum2
| inr : β → sum2

def fst {α : Type u} {β : Type v} (p : α × β) : α :=
  prod.rec_on p (λ a b, a)

def snd {α : Type u} {β : Type v} (p : α × β) : β :=
  prod.rec_on p (λ a b, b)

def prod_example (p : bool × ℕ) : ℕ :=
  prod.rec_on p (λ b n, cond b (2 * n) (2 * n + 1))

#reduce prod_example (tt, 3)
#reduce prod_example (ff, 3)

def sum_example (s : ℕ ⊕ ℕ) : ℕ :=
  sum.cases_on s (λ n, 2 * n) (λ n, 2 * n + 1)

#reduce sum_example (sum.inl 3)
#reduce sum_example (sum.inr 3)

inductive sum3 (α : Type u) (β : Type v)
| inl {} (a : α) : sum3
| inr {} (b : β) : sum3

-- defines constructor, mk, eliminators rec and rec_on,
-- and projections, fst and snd
structure prod4 (α β : Type*) :=
  mk :: (fst : α) (snd : β)

/-
structure Semigroup :=
  mk ::
    (carrier : Type u)
    (mul : carrier → carrier → carrier)
    (mul_assoc : ∀ a b c, mul (mul a b) c = mul a (mul b c))
-/
structure Semigroup :=
  (carrier : Type u)
  (mul : carrier → carrier → carrier)
  (mul_assoc : ∀ a b c, mul (mul a b) c = mul a (mul b c))

-- sigma types:
inductive sigma' {α : Type u} (β : α → Type v)
| dpair : Π a : α, β a → sigma'

inductive option' (α : Type*)
| none {} : option'
| some    : α → option'

-- example of a type class, i.e. lean can be instructed that
-- suitable base types are inhabited
inductive inhabited' (α : Type*)
| mk : α → inhabited'

end args

example : inhabited bool := inhabited.mk ff
example : inhabited ℕ := inhabited.mk 0

universes u v
example {α : Type u} {β : Type v} :
    (inhabited α) × (inhabited β) → inhabited (α × β) :=
  assume hinab : (inhabited α) × (inhabited β),
    inhabited.mk (prod.mk (hinab.fst).default (hinab.snd).default)

example {α : Type u} {β : Type v} :
    inhabited β → inhabited (α → β) :=
  assume h : inhabited β,
    inhabited.rec_on h (λ b, inhabited.mk (λ a, b))

#check exists.intro

inductive subtype' {α : Type*} (p : α → Prop)
| mk : Π x : α, p x → subtype'

section

variables {α : Type u} (p : α → Prop)

#check subtype p
#check { x : α // p x}

end

section defining_nat

inductive nat' : Type
| zero : nat'
| succ : nat' → nat'

#check @nat.rec_on

def add_nat (m n : ℕ) : ℕ :=
  nat.rec_on n m (λ n add_m_n, nat.succ add_m_n)

#reduce add_nat (nat.succ nat.zero) (nat.succ (nat.succ nat.zero))

/-
instance : has_zero nat := has_zero.mk zero
instance : has_add nat := has_add.mk add
-/
theorem zero_add (n : ℕ) : 0 + n = n :=
  @nat.rec_on (λ n : ℕ, 0 + n = n) n
    (show 0 + 0 = 0, from rfl)
    (assume n : ℕ,
      assume ih : 0 + n = n,
      show 0 + nat.succ n = nat.succ n, from
        calc
          0 + nat.succ n = nat.succ (0 + n) : rfl
          ...            = nat.succ n : by rw ih)

example (n : ℕ) : 0 + n = n :=
  nat.rec_on n rfl (λn ih, by rw [nat.add_succ, ih])
example (n : ℕ) : 0 + n = n :=
  nat.rec_on n rfl (λn ih, by simp only [nat.add_succ, ih])

theorem add_assoc (m n k : ℕ) : m + n + k = m + (n + k) :=
  nat.rec_on k
    (show m + n + 0 = m + (n + 0), from rfl)
    (assume k,
      assume ih : m + n + k = m + (n + k),
      show m + n + nat.succ k = m + (n + nat.succ k), from
        calc
          m + n + nat.succ k = nat.succ (m + n + k) : rfl
          ...                = nat.succ (m + (n + k)) : by rw ih
          ...                = m + nat.succ (n + k) : rfl
          ...                = m + (n + nat.succ k) : rfl)

example (m n k : ℕ) : m + n + k = m + (n + k) :=
  nat.rec_on k rfl (λ k ih, by simp only [nat.add_succ, ih])

theorem cons_append {α : Type*} (x : α) (s t : list α) :
  x::s ++ t = x::(s ++ t) := rfl

set_option pp.all true
#print cons_append
set_option pp.all false

-- def append {α : Type*} (s t : list α) : list α :=
--   list.rec t (λ x l u, x::u) s

theorem append_nil {α : Type*} (t : list α) : t ++ list.nil = t :=
  list.rec_on t
    (refl (list.nil ++ list.nil))
    (assume t, assume tl : list α,
      assume ih : tl ++ list.nil = tl,
      show (t :: tl) ++ list.nil = t :: tl, from
        calc
          (t :: tl) ++ list.nil = t :: (tl ++ list.nil) : list.cons_append t tl list.nil
          ...                   = t :: tl               : by rw ih)

theorem append_nil' {α : Type*} (t : list α) : t ++ list.nil = t :=
begin
  induction t,
  apply refl,
  simp [list.append, t_ih]
end

theorem append_assoc {α : Type*} (r s t : list α) :
  r ++ s ++ t = r ++ (s ++ t) :=
    list.rec_on r
      (refl (list.nil ++ s ++ t))
      (assume rh, assume r,
        assume ih : r ++ s ++ t = r ++ (s ++ t),
        show (rh :: r) ++ s ++ t = (rh :: r) ++ (s ++ t), from
          calc
            (rh :: r) ++ s ++ t = rh :: (r ++ s) ++ t   : by rw list.cons_append
            ...                 = rh :: ((r ++ s) ++ t) : by rw list.cons_append
            ...                 = rh :: (r ++ (s ++ t)) : by rw ih)

def list_length {α : Type*} (l : list α) : ℕ :=
  list.rec_on l 0 (λ (hd : α) (l : list α) (ln : ℕ), ln + 1)

inductive binary_tree
| leaf : binary_tree
| node : binary_tree → binary_tree → binary_tree

inductive cbtree
| leaf : cbtree
| sup  : (ℕ → cbtree) → cbtree

def cbtree.succ (t : cbtree) : cbtree :=
  cbtree.sup (λ n, t)

def cbtree.omega : cbtree :=
  cbtree.sup (λ n, nat.rec_on n cbtree.leaf (λ n t, cbtree.succ t))

end defining_nat

section

theorem eq_trans {α : Type u} {a b c : α}
    (h1 : eq a b) (h2 : eq b c) : eq a c :=
  eq.subst h2 (eq.subst h1 (eq.refl a))

theorem eq_congr {α β : Type u} {a b : α} (f : α → β)
    (h : eq a b) : eq (f a) (f b) :=
  eq.rec_on h (eq.refl (f a))

end

section ex

def nat_pred (n : ℕ) : ℕ :=
  nat.rec_on n 0
    (λ n pred_n, nat.rec_on n 0
      (λ n' pred_n', nat.succ pred_n'))

def nat_mul (n m : ℕ) : ℕ :=
  nat.rec_on n 0 (λ n n_m, n_m + m)

def mul2 : nat → nat → nat
| 0 b     := 0
| (a+1) b := (mul2 a b) + b

def nat_sub (n m : ℕ) : ℕ :=
  nat.rec_on m n (λ m n_m, nat_pred n_m)

def nat_exp (n m : ℕ) : ℕ :=
  nat.rec_on m 1 (λ m n_m, nat_mul n n_m)

theorem pred_succ (n : ℕ) : nat.pred (n.succ) = n :=
  rfl

theorem nat_zero_mul (n : ℕ) : nat_mul 0 n = 0 := rfl

lemma succ_mul (n m : ℕ) : nat_mul n.succ m = nat_mul n m + m :=
  calc
    nat_mul n.succ m = nat_mul n m + m : rfl

theorem nat_mul_zero (n : ℕ) : nat_mul n 0 = 0 :=
  nat.rec_on n rfl (λ n ih,
    show nat_mul n.succ 0 = 0, from
      calc
        nat_mul n.succ 0 = nat_mul n 0 + 0 : succ_mul n 0
        ...              = 0 : ih)

theorem nat_mul_zero' (n : ℕ) : nat_mul n 0 = 0 :=
  nat.rec_on n rfl (λ n ih,
    show nat_mul n.succ 0 = 0, from
      (succ_mul n 0).trans ih)

end ex

section test

-- using library_search from "import tactic"
example (n : ℕ) : n + 1 > n :=
begin
  exact lt_add_one n,
end

example (n : ℕ) : nat.prime n → n ≥ 2 :=
begin
  exact nat.prime.two_le,
end

example (a b c : ℕ) : a + c < b + c → a < b :=
begin
  norm_num,
end

end test


/-
Copyright (c) 2020 Riccardo Brasca. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Riccardo Brasca
-/
import data.polynomial.algebra_map
import data.polynomial.monic

/-!
# Polynomials that lift

Given semirings `R` and `S` with a morphism `f : R →+* S`, we define a subsemiring `lifts` of
`polynomial S` by the image of `ring_hom.of (map f)`.
Then, we prove that a polynomial that lifts can always be lifted to a polynomial of the same degree
and that a monic polynomial that lifts can be lifted to a monic polynomial (of the same degree).

## Main definition

* `lifts (f : R →+* S)` : the subsemiring of polynomials that lift.

## Main results

* `lifts_and_degree_eq` : A polynomial lifts if and only if it can be lifted to a polynomial
of the same degree.
* `lifts_and_degree_eq_and_monic` : A monic polynomial lifts if and only if it can be lifted to a
monic polynomial of the same degree.
* `lifts_iff_alg` : if `R` is commutative, a polynomial lifts if and only if it is in the image of
`map_alg`, where `map_alg : R[X] →ₐ[R] S[X]` is the only `R`-algebra map
that sends `X` to `X`.

## Implementation details

In general `R` and `S` are semiring, so `lifts` is a semiring. In the case of rings, see
`lifts_iff_lifts_ring`.

Since we do not assume `R` to be commutative, we cannot say in general that the set of polynomials
that lift is a subalgebra. (By `lift_iff` this is true if `R` is commutative.)

-/

open_locale classical big_operators polynomial
noncomputable theory

namespace polynomial
universes u v w

section semiring

variables {R : Type u} [semiring R] {S : Type v} [semiring S] {f : R →+* S}

/-- We define the subsemiring of polynomials that lifts as the image of `ring_hom.of (map f)`. -/
def lifts (f : R →+* S) : subsemiring S[X] := ring_hom.srange (map_ring_hom f)

lemma mem_lifts (p : S[X]) : p ∈ lifts f ↔ ∃ (q : R[X]), map f q = p :=
by simp only [coe_map_ring_hom, lifts, ring_hom.mem_srange]

lemma lifts_iff_ring_hom_srange (p : S[X]) : p ∈ lifts f ↔ p ∈ (map_ring_hom f).srange :=
by simp only [coe_map_ring_hom, lifts, set.mem_range, ring_hom.mem_srange]

lemma lifts_iff_coeff_lifts (p : S[X]) : p ∈ lifts f ↔ ∀ (n : ℕ), p.coeff n ∈ set.range f :=
by { rw [lifts_iff_ring_hom_srange, mem_map_srange f], refl }

/--If `(r : R)`, then `C (f r)` lifts. -/
lemma C_mem_lifts (f : R →+* S) (r : R) : (C (f r)) ∈ lifts f :=
⟨C r, by simp only [coe_map_ring_hom, map_C, set.mem_univ, subsemiring.coe_top, eq_self_iff_true,
  and_self]⟩

/-- If `(s : S)` is in the image of `f`, then `C s` lifts. -/
lemma C'_mem_lifts {f : R →+* S} {s : S} (h : s ∈ set.range f) : (C s) ∈ lifts f :=
begin
  obtain ⟨r, rfl⟩ := set.mem_range.1 h,
  use C r,
  simp only [coe_map_ring_hom, map_C, set.mem_univ, subsemiring.coe_top, eq_self_iff_true,
    and_self]
end

/-- The polynomial `X` lifts. -/
lemma X_mem_lifts (f : R →+* S) : (X : S[X]) ∈ lifts f :=
⟨X, by simp only [coe_map_ring_hom, set.mem_univ, subsemiring.coe_top, eq_self_iff_true, map_X,
  and_self]⟩

/-- The polynomial `X ^ n` lifts. -/
lemma X_pow_mem_lifts (f : R →+* S) (n : ℕ) : (X ^ n : S[X]) ∈ lifts f :=
⟨X ^ n, by simp only [coe_map_ring_hom, map_pow, set.mem_univ, subsemiring.coe_top,
  eq_self_iff_true, map_X, and_self]⟩

/-- If `p` lifts and `(r : R)` then `r * p` lifts. -/
lemma base_mul_mem_lifts {p : S[X]} (r : R) (hp : p ∈ lifts f) : C (f r) * p ∈ lifts f :=
begin
  simp only [lifts, ring_hom.mem_srange] at hp ⊢,
  obtain ⟨p₁, rfl⟩ := hp,
  use C r * p₁,
  simp only [coe_map_ring_hom, map_C, map_mul]
end

/-- If `(s : S)` is in the image of `f`, then `monomial n s` lifts. -/
lemma monomial_mem_lifts {s : S} (n : ℕ) (h : s ∈ set.range f) : (monomial n s) ∈ lifts f :=
begin
  obtain ⟨r, rfl⟩ := set.mem_range.1 h,
  use monomial n r,
  simp only [coe_map_ring_hom, set.mem_univ, map_monomial, subsemiring.coe_top, eq_self_iff_true,
    and_self],
end

/-- If `p` lifts then `p.erase n` lifts. -/
lemma erase_mem_lifts {p : S[X]} (n : ℕ) (h : p ∈ lifts f) : p.erase n ∈ lifts f :=
begin
  rw [lifts_iff_ring_hom_srange, mem_map_srange] at h ⊢,
  intros k,
  by_cases hk : k = n,
  { use 0,
    simp only [hk, ring_hom.map_zero, erase_same] },
  obtain ⟨i, hi⟩ := h k,
  use i,
  simp only [hi, hk, erase_ne, ne.def, not_false_iff],
end

section lift_deg

lemma monomial_mem_lifts_and_degree_eq {s : S} {n : ℕ} (hl : monomial n s ∈ lifts f) :
  ∃ (q : R[X]), map f q = (monomial n s) ∧ q.degree = (monomial n s).degree :=
begin
  by_cases hzero : s = 0,
  { use 0,
    simp only [hzero, degree_zero, eq_self_iff_true, and_self, monomial_zero_right, map_zero] },
  rw lifts_iff_set_range at hl,
  obtain ⟨q, hq⟩ := hl,
  replace hq := (ext_iff.1 hq) n,
  have hcoeff : f (q.coeff n) = s,
  { simp [coeff_monomial] at hq,
    exact hq },
  use (monomial n (q.coeff n)),
  split,
  { simp only [hcoeff, map_monomial] },
  have hqzero : q.coeff n ≠ 0,
  { intro habs,
    simp only [habs, ring_hom.map_zero] at hcoeff,
    exact hzero hcoeff.symm },
  repeat {rw monomial_eq_C_mul_X},
  simp only [hzero, hqzero, ne.def, not_false_iff, degree_C_mul_X_pow],
end

/-- A polynomial lifts if and only if it can be lifted to a polynomial of the same degree. -/
lemma mem_lifts_and_degree_eq {p : S[X]} (hlifts : p ∈ lifts f) :
  ∃ (q : R[X]), map f q = p ∧ q.degree = p.degree :=
begin
  generalize' hd : p.nat_degree = d,
  revert hd p,
  apply nat.strong_induction_on d,
  intros n hn p hlifts hdeg,
  by_cases erase_zero : p.erase_lead = 0,
  { rw [← erase_lead_add_monomial_nat_degree_leading_coeff p, erase_zero, zero_add, leading_coeff],
    exact monomial_mem_lifts_and_degree_eq (monomial_mem_lifts p.nat_degree
    ((lifts_iff_coeff_lifts p).1 hlifts p.nat_degree)) },
  have deg_erase := or.resolve_right (erase_lead_nat_degree_lt_or_erase_lead_eq_zero p) erase_zero,
  have pzero : p ≠ 0,
  { intro habs,
    exfalso,
    rw [habs, erase_lead_zero, eq_self_iff_true, not_true] at erase_zero,
    exact erase_zero },
  have lead_zero : p.coeff p.nat_degree ≠ 0,
  { rw [← leading_coeff, ne.def, leading_coeff_eq_zero]; exact pzero },
  obtain ⟨lead, hlead⟩ := monomial_mem_lifts_and_degree_eq (monomial_mem_lifts p.nat_degree
    ((lifts_iff_coeff_lifts p).1 hlifts p.nat_degree)),
  have deg_lead : lead.degree = p.nat_degree,
  { rw [hlead.2, monomial_eq_C_mul_X, degree_C_mul_X_pow p.nat_degree lead_zero] },
  rw hdeg at deg_erase,
  obtain ⟨erase, herase⟩ := hn p.erase_lead.nat_degree deg_erase
    (erase_mem_lifts p.nat_degree hlifts) (refl p.erase_lead.nat_degree),
  use erase + lead,
  split,
  { simp only [hlead, herase, map_add],
    nth_rewrite 0 erase_lead_add_monomial_nat_degree_leading_coeff p },
  rw [←hdeg, erase_lead] at deg_erase,
  replace deg_erase := lt_of_le_of_lt degree_le_nat_degree (with_bot.coe_lt_coe.2 deg_erase),
  rw [← deg_lead, ← herase.2] at deg_erase,
  rw [degree_add_eq_right_of_degree_lt deg_erase, deg_lead, degree_eq_nat_degree pzero]
end

end lift_deg

section monic

/-- A monic polynomial lifts if and only if it can be lifted to a monic polynomial
of the same degree. -/
lemma lifts_and_degree_eq_and_monic [nontrivial S] {p : S[X]} (hlifts : p ∈ lifts f)
  (hp : p.monic) : ∃ (q : R[X]), map f q = p ∧ q.degree = p.degree ∧ q.monic :=
begin
  casesI subsingleton_or_nontrivial R with hR hR,
  { obtain ⟨q, hq⟩ := mem_lifts_and_degree_eq hlifts,
    exact ⟨q, hq.1, hq.2, monic_of_subsingleton _⟩ },
  have H : erase p.nat_degree p + X ^ p.nat_degree = p,
  { simpa only [hp.leading_coeff, C_1, one_mul, erase_lead] using erase_lead_add_C_mul_X_pow p },
  by_cases h0 : erase p.nat_degree p = 0,
  { rw [← H, h0, zero_add],
    refine ⟨X ^ p.nat_degree, _, _, monic_X_pow p.nat_degree⟩,
    { rw [polynomial.map_pow, map_X] },
    { rw [degree_X_pow, degree_X_pow] } },
  obtain ⟨q, hq⟩ := mem_lifts_and_degree_eq (erase_mem_lifts p.nat_degree hlifts),
  have hdeg : q.degree < (X ^ p.nat_degree).degree,
  { rw [@degree_X_pow R, hq.2, degree_eq_nat_degree h0, with_bot.coe_lt_coe],
    exact or.resolve_right (erase_lead_nat_degree_lt_or_erase_lead_eq_zero p) h0, },
  refine ⟨q + X ^ p.nat_degree, _, _, (monic_X_pow _).add_of_right hdeg⟩,
  { rw [map_add, hq.1, polynomial.map_pow, map_X, H], },
  { rw [degree_add_eq_right_of_degree_lt hdeg, degree_X_pow, degree_eq_nat_degree hp.ne_zero] }
end

end monic

end semiring

section ring

variables {R : Type u} [ring R] {S : Type v} [ring S] (f : R →+* S)

/-- The subring of polynomials that lift. -/
def lifts_ring (f : R →+* S) : subring S[X] := ring_hom.range (map_ring_hom f)

/-- If `R` and `S` are rings, `p` is in the subring of polynomials that lift if and only if it is in
the subsemiring of polynomials that lift. -/
lemma lifts_iff_lifts_ring (p : S[X]) : p ∈ lifts f ↔ p ∈ lifts_ring f :=
by simp only [lifts, lifts_ring, ring_hom.mem_range, ring_hom.mem_srange]

end ring

section algebra

variables {R : Type u} [comm_semiring R] {S : Type v} [semiring S] [algebra R S]

/-- The map `polynomial R → S[X]` as an algebra homomorphism. -/
def map_alg (R : Type u) [comm_semiring R] (S : Type v) [semiring S] [algebra R S] :
  R[X] →ₐ[R] S[X] := @aeval _ S[X] _ _ _ (X : S[X])

/-- `map_alg` is the morphism induced by `R → S`. -/
lemma map_alg_eq_map (p : R[X]) : map_alg R S p = map (algebra_map R S) p :=
by simp only [map_alg, aeval_def, eval₂, map, algebra_map_apply, ring_hom.coe_comp]

/-- A polynomial `p` lifts if and only if it is in the image of `map_alg`. -/
lemma mem_lifts_iff_mem_alg (R : Type u) [comm_semiring R] {S : Type v} [semiring S] [algebra R S]
  (p : S[X]) :p ∈ lifts (algebra_map R S) ↔ p ∈ (alg_hom.range (@map_alg R _ S _ _)) :=
by simp only [coe_map_ring_hom, lifts, map_alg_eq_map, alg_hom.mem_range,
  ring_hom.mem_srange]

/-- If `p` lifts and `(r : R)` then `r • p` lifts. -/
lemma smul_mem_lifts {p : S[X]} (r : R) (hp : p ∈ lifts (algebra_map R S)) :
  r • p ∈ lifts (algebra_map R S) :=
by { rw mem_lifts_iff_mem_alg at hp ⊢, exact subalgebra.smul_mem (map_alg R S).range hp r }

end algebra

end polynomial


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

import ProofChecker.Data.Pog
import ProofChecker.Count.PropForm

open Nat
open PogElt

namespace Pog

/-
The count function
-/

-- This can be optimized to eliminate the first multiplication / division.
-- We can also avoid creating the array and compute the result with a loop.
def conjProd (nVars : Nat) {n : Nat} (g : Fin n → Nat) : Nat :=
  (Array.ofFn g).foldr (init := 2^nVars) (f := fun a b => a * b / 2^nVars)

-- This shouldn't be used for computation, but we have more theorems about lists.
def conjProd' (nVars : Nat) {n : Nat} (g : Fin n → Nat) : Nat :=
  (List.ofFn g).foldr (init := 2^nVars) (f := fun a b => a * b / 2^nVars)

theorem conjProd_eq_conjProd' : conjProd = conjProd' := by
  ext nVars n f
  rw [conjProd, conjProd', Array.foldr_eq_foldr_data, List.ofFn, Array.toList_eq]

def toCountArray (pog : Pog) (nVars : Nat) :
    { A : Array Nat // A.size = pog.elts.size } :=
  aux pog.elts.size #[] (by rw [add_comm]; rfl)
where
  aux : (n : Nat) → (A : Array Nat) → (pog.elts.size = A.size + n) →
        { A : Array Nat // A.size = pog.elts.size }
  | 0, A, h => ⟨A, h.symm⟩
  | n + 1, A, h =>
    have ASizeLt : A.size < pog.elts.size := by
      rw [h, ←add_assoc]; exact lt_succ_of_le (le_add_right _ _)
    let nextElt : Nat :=
      match pog.elts[A.size]'ASizeLt, pog.wf ⟨A.size, ASizeLt⟩, pog.inv ⟨A.size, ASizeLt⟩ with
        | var x, _, _ => 2^(nVars - 1)
        | disj x left right, ⟨hleft, hright⟩, hinv =>
          have := lt_aux hleft hinv
          have := lt_aux hright hinv
          let lmodels :=
            if left.polarity then A[left.var.natPred] else 2^nVars - A[left.var.natPred]
          let rmodels :=
            if right.polarity then A[right.var.natPred] else 2^nVars - A[right.var.natPred]
          lmodels + rmodels
        | conj n args, hwf, hinv =>
          conjProd nVars fun (j : Fin args.size) =>
              have := lt_aux (hwf j) hinv
              if args[j].polarity then A[args[j].var.natPred] else 2^nVars - A[args[j].var.natPred]
    aux n (A.push nextElt) (by rw [Array.size_push, h, add_assoc, add_comm 1])

def count (pog : Pog) (nVars : Nat) (x : Var) : Nat :=
  if h : x.natPred < pog.elts.size then
    have : x.natPred < (pog.toCountArray nVars).1.size := by
      rwa [(pog.toCountArray nVars).2]
    (pog.toCountArray nVars).1[x.natPred]
  else
    PropForm.countModels nVars (ILit.mkPos x).toPropForm

theorem countModels_foldr_conj (nVars : Nat) (φs : List (PropForm Var)) :
   PropForm.countModels nVars (List.foldr PropForm.conj PropForm.tr φs) =
      List.foldr (fun a b => a * b / 2 ^ nVars) (2 ^ nVars)
        (φs.map (PropForm.countModels nVars)) := by
  induction φs
  . simp [PropForm.countModels]
  . next φ φs ih =>
    rw [List.foldr_cons, PropForm.countModels, ih, List.map, List.foldr]

theorem toCountArray_spec (pog : Pog) (nVars : Nat) :
  ∀ i : Fin (pog.toCountArray nVars).1.size,
      (pog.toCountArray nVars).1[i] =
        PropForm.countModels nVars (pog.toPropForm (.mkPos (succPNat i))) := by
  apply aux
  rintro ⟨i, h⟩; contradiction
where
  aux : (n : Nat) → (A : Array Nat) → (h : pog.elts.size = A.size + n) →
          (h' : (∀ i : Fin A.size, A[i] =
            PropForm.countModels nVars (pog.toPropForm (.mkPos (succPNat i))))) →
    ∀ i : Fin (toCountArray.aux pog nVars n A h).1.size,
      (toCountArray.aux pog nVars n A h).1[i] =
        PropForm.countModels nVars (pog.toPropForm (.mkPos (succPNat i)))
  | 0,     _, _, h' => h'
  | n + 1, A, h, h' => by
    have ASizeLt : A.size < pog.elts.size := by
      rw [h, ←add_assoc]; exact lt_succ_of_le (le_add_right _ _)
    apply aux n; dsimp
    intro ⟨i, i_lt⟩
    rw [Array.size_push] at i_lt
    cases lt_or_eq_of_le (le_of_lt_succ i_lt)
    next ilt =>
      rw [Array.get_push_lt _ _ i ilt]
      exact h' ⟨i, ilt⟩
    next ieq =>
      simp only [ieq, Array.get_push_eq]
      split
      . next x _ hinv heq _ _ =>
        rw [toPropForm]
        simp only [ILit.var_mkPos, natPred_succPNat, PropForm.withPolarity_mkPos, dif_pos ASizeLt]
        rw [toPropForm_aux_eq, heq, PropForm.countModels]
      . next x left right hleft hright hinv heq _ _ =>
        rw [toPropForm]
        simp only [ILit.var_mkPos, natPred_succPNat, PropForm.withPolarity_mkPos, dif_pos ASizeLt]
        have hleft : PNat.natPred (ILit.var left) < A.size := by
          dsimp at hinv; rwa [hinv, PNat.natPred_lt_natPred]
        have hright : PNat.natPred (ILit.var right) < A.size := by
          dsimp at hinv; rwa [hinv, PNat.natPred_lt_natPred]
        have hl := h' ⟨_, hleft⟩; dsimp at hl; rw [hl]
        have hr := h' ⟨_, hright⟩; dsimp at hr; rw [hr]
        rw [toPropForm_aux_eq, heq, PropForm.countModels, PNat.succPNat_natPred,
          PNat.succPNat_natPred]
        split
        . next hlp =>
          rw [ILit.mkPos_var_true _ hlp]
          split
          . next hrp =>
            rw [ILit.mkPos_var_true _ hrp]
          . next hrnp =>
            rw [Bool.not_eq_true] at hrnp
            rw [ILit.mkPos_var_false _ hrnp, pog.toPropForm_of_polarity_eq_false _ hrnp,
              PropForm.countModels]
        . next hlnp =>
          rw [Bool.not_eq_true] at hlnp
          rw [ILit.mkPos_var_false _ hlnp, pog.toPropForm_of_polarity_eq_false _ hlnp,
              PropForm.countModels]
          split
          . next hrp =>
            rw [ILit.mkPos_var_true _ hrp]
          . next hrnp =>
            rw [Bool.not_eq_true] at hrnp
            rw [ILit.mkPos_var_false _ hrnp, pog.toPropForm_of_polarity_eq_false _ hrnp,
              PropForm.countModels]
      . next x args hwf hinv heq _ _ =>
        rw [toPropForm]
        simp only [ILit.var_mkPos, natPred_succPNat, PropForm.withPolarity_mkPos, dif_pos ASizeLt]
        rw [toPropForm_aux_eq, heq]; dsimp
        rw [conjProd_eq_conjProd', conjProd', PropForm.arrayConj, PropForm.listConj,
          countModels_foldr_conj]
        apply congr_arg
        rw [←Array.toList_eq, ←List.ofFn, List.map_ofFn]
        apply congr_arg
        ext j
        simp only [Function.comp_apply]
        simp only [ILit.var_mkPos, natPred_succPNat, PropForm.withPolarity_mkPos, dif_pos ASizeLt]
        have harg : PNat.natPred (ILit.var args[j]) < A.size := by
          dsimp at hinv; rw [hinv, PNat.natPred_lt_natPred]
          exact hwf j
        have ha := h' ⟨_, harg⟩; dsimp at ha; rw [ha]
        rw [PNat.succPNat_natPred]
        split
        . next hlp =>
          rw [ILit.mkPos_var_true _ hlp]
        . next hlnp =>
          rw [Bool.not_eq_true] at hlnp
          rw [ILit.mkPos_var_false _ hlnp, pog.toPropForm_of_polarity_eq_false _ hlnp,
              PropForm.countModels]

theorem count_eq_countModels (pog : Pog) (nVars : Nat) (x : Var) :
    pog.count nVars x = (pog.toPropForm (.mkPos x)).countModels nVars := by
  rw [count, toPropForm, ILit.var_mkPos]
  split
  . next h =>
    have h' := h; rw [←(pog.toCountArray nVars).2] at h'
    have := pog.toCountArray_spec nVars ⟨_, h'⟩
    dsimp at this; rw [PNat.succPNat_natPred] at this
    dsimp; rw [this, toPropForm, ILit.var_mkPos, dif_pos h]
  . next h => rfl

theorem count_eq' (pog : Pog) (nVars : Nat) (x : Var) (φ : PropForm Var) :
    pog.toPropForm (.mkPos x) = φ →
    pog.count nVars x = φ.countModels nVars := by intro h; rw [←h, count_eq_countModels]

/-
The ring evaluation function
-/

variable {R : Type} [CommRing R]

def conjProdW {n : Nat} (g : Fin n → R) : R :=
  (Array.ofFn g).foldr (init := 1) (f := fun a b => a * b)

def conjProdW' {n : Nat} (g : Fin n → R) : R :=
  (List.ofFn g).foldr (init := 1) (f := fun a b => a * b)

theorem conjProdW_eq_conjProdW' : @conjProdW R _ = @conjProdW' R _ := by
  apply funext; intro n
  apply funext; intro g
  rw [conjProdW, conjProdW', Array.foldr_eq_foldr_data, List.ofFn, Array.toList_eq]

def toRingEvalArray (pog : Pog) (weight : Var → R) :
    { A : Array R // A.size = pog.elts.size } :=
  aux pog.elts.size #[] (by rw [add_comm]; rfl)
where
  aux : (n : Nat) → (A : Array R) → (pog.elts.size = A.size + n) →
        { A : Array R // A.size = pog.elts.size }
  | 0, A, h => ⟨A, h.symm⟩
  | n + 1, A, h =>
    have ASizeLt : A.size < pog.elts.size := by
      rw [h, ←add_assoc]; exact lt_succ_of_le (le_add_right _ _)
    let nextElt : R :=
      match pog.elts[A.size]'ASizeLt, pog.wf ⟨A.size, ASizeLt⟩, pog.inv ⟨A.size, ASizeLt⟩ with
        | var x, _, _ => weight x
        | disj x left right, ⟨hleft, hright⟩, hinv =>
          have := lt_aux hleft hinv
          have := lt_aux hright hinv
          let lmodels :=
            if left.polarity then A[left.var.natPred] else 1 - A[left.var.natPred]
          let rmodels :=
            if right.polarity then A[right.var.natPred] else 1 - A[right.var.natPred]
          lmodels + rmodels
        | conj n args, hwf, hinv =>
          conjProdW fun (j : Fin args.size) =>
              have := lt_aux (hwf j) hinv
              if args[j].polarity then A[args[j].var.natPred] else 1 - A[args[j].var.natPred]
    aux n (A.push nextElt) (by rw [Array.size_push, h, add_assoc, add_comm 1])

def ringEval (pog : Pog) (weight : Var → R) (x : Var) : R :=
  if h : x.natPred < pog.elts.size then
    have : x.natPred < (pog.toRingEvalArray weight).1.size := by
      rwa [(pog.toRingEvalArray weight).2]
    (pog.toRingEvalArray weight).1[x.natPred]
  else
    PropForm.ringEval weight (ILit.mkPos x).toPropForm

theorem ringEval_foldr_conj (weight : Var → R) (φs : List (PropForm Var)) :
   PropForm.ringEval weight (List.foldr PropForm.conj PropForm.tr φs) =
      List.foldr (fun a b => a * b) 1
        (φs.map (PropForm.ringEval weight)) := by
  induction φs
  . simp [PropForm.ringEval]
  . next φ φs ih =>
    rw [List.foldr_cons, PropForm.ringEval, ih, List.map, List.foldr]

theorem toRingEvalArray_spec (pog : Pog) (weight : Var → R) :
  ∀ i : Fin (pog.toRingEvalArray weight).1.size,
      (pog.toRingEvalArray weight).1[i] =
        PropForm.ringEval weight (pog.toPropForm (.mkPos (succPNat i))) := by
  apply aux
  rintro ⟨i, h⟩; contradiction
where
  aux : (n : Nat) → (A : Array R) → (h : pog.elts.size = A.size + n) →
          (h' : (∀ i : Fin A.size, A[i] =
            PropForm.ringEval weight (pog.toPropForm (.mkPos (succPNat i))))) →
    ∀ i : Fin (Pog.toRingEvalArray.aux pog weight n A h).1.size,
      (Pog.toRingEvalArray.aux pog weight n A h).1[i] =
        PropForm.ringEval weight (pog.toPropForm (.mkPos (succPNat i)))
  | 0,     _, _, h' => h'
  | n + 1, A, h, h' => by
    have ASizeLt : A.size < pog.elts.size := by
      rw [h, ←add_assoc]; exact lt_succ_of_le (le_add_right _ _)
    apply aux n; dsimp
    intro ⟨i, i_lt⟩
    rw [Array.size_push] at i_lt
    cases lt_or_eq_of_le (le_of_lt_succ i_lt)
    next ilt =>
      rw [Array.get_push_lt _ _ i ilt]
      exact h' ⟨i, ilt⟩
    next ieq =>
      simp only [ieq, Array.get_push_eq]
      split
      . next x _ hinv heq _ _ =>
        rw [toPropForm]
        simp only [ILit.var_mkPos, natPred_succPNat, PropForm.withPolarity_mkPos, dif_pos ASizeLt]
        rw [toPropForm_aux_eq, heq, PropForm.ringEval]
      . next x left right hleft hright hinv heq _ _ =>
        rw [toPropForm]
        simp only [ILit.var_mkPos, natPred_succPNat, PropForm.withPolarity_mkPos, dif_pos ASizeLt]
        have hleft : PNat.natPred (ILit.var left) < A.size := by
          dsimp at hinv; rwa [hinv, PNat.natPred_lt_natPred]
        have hright : PNat.natPred (ILit.var right) < A.size := by
          dsimp at hinv; rwa [hinv, PNat.natPred_lt_natPred]
        have hl := h' ⟨_, hleft⟩; dsimp at hl; rw [hl]
        have hr := h' ⟨_, hright⟩; dsimp at hr; rw [hr]
        rw [toPropForm_aux_eq, heq, PropForm.ringEval, PNat.succPNat_natPred,
          PNat.succPNat_natPred]
        split
        . next hlp =>
          rw [ILit.mkPos_var_true _ hlp]
          split
          . next hrp =>
            rw [ILit.mkPos_var_true _ hrp]
          . next hrnp =>
            rw [Bool.not_eq_true] at hrnp
            rw [ILit.mkPos_var_false _ hrnp, pog.toPropForm_of_polarity_eq_false _ hrnp,
              PropForm.ringEval]
        . next hlnp =>
          rw [Bool.not_eq_true] at hlnp
          rw [ILit.mkPos_var_false _ hlnp, pog.toPropForm_of_polarity_eq_false _ hlnp,
              PropForm.ringEval]
          split
          . next hrp =>
            rw [ILit.mkPos_var_true _ hrp]
          . next hrnp =>
            rw [Bool.not_eq_true] at hrnp
            rw [ILit.mkPos_var_false _ hrnp, pog.toPropForm_of_polarity_eq_false _ hrnp,
              PropForm.ringEval]
      . next x args hwf hinv heq _ _ =>
        rw [toPropForm]
        simp only [ILit.var_mkPos, natPred_succPNat, PropForm.withPolarity_mkPos, dif_pos ASizeLt]
        rw [toPropForm_aux_eq, heq]; dsimp
        rw [conjProdW_eq_conjProdW', conjProdW', PropForm.arrayConj, PropForm.listConj,
          ringEval_foldr_conj]
        apply congr_arg
        rw [←Array.toList_eq, ←List.ofFn, List.map_ofFn]
        apply congr_arg
        apply funext; intro j
        simp only [Function.comp_apply]
        simp only [ILit.var_mkPos, natPred_succPNat, PropForm.withPolarity_mkPos, dif_pos ASizeLt]
        have harg : PNat.natPred (ILit.var args[j]) < A.size := by
          dsimp at hinv; rw [hinv, PNat.natPred_lt_natPred]
          exact hwf j
        have ha := h' ⟨_, harg⟩; dsimp at ha; rw [ha]
        rw [PNat.succPNat_natPred]
        split
        . next hlp =>
          rw [ILit.mkPos_var_true _ hlp]
        . next hlnp =>
          rw [Bool.not_eq_true] at hlnp
          rw [ILit.mkPos_var_false _ hlnp, pog.toPropForm_of_polarity_eq_false _ hlnp,
              PropForm.ringEval]

theorem ringEval_eq_ringEval (pog : Pog) (weight : Var → R) (x : Var) :
    pog.ringEval weight x = (pog.toPropForm (.mkPos x)).ringEval weight := by
  rw [ringEval, toPropForm, ILit.var_mkPos]
  split
  . next h =>
    have h' := h; rw [←(pog.toRingEvalArray weight).2] at h'
    have := pog.toRingEvalArray_spec weight ⟨_, h'⟩
    dsimp at this; rw [PNat.succPNat_natPred] at this
    dsimp; rw [this, toPropForm, ILit.var_mkPos, dif_pos h]
  . next h => rfl

theorem ringEval_eq' (pog : Pog) (weight : Var → R) (x : Var) (φ : PropForm Var) :
    pog.toPropForm (.mkPos x) = φ →
    pog.ringEval weight x = φ.ringEval weight := by
      intro h; rw [←h, ringEval_eq_ringEval]

end Pog